1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1997--2018 The R Core Team
4 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, a copy is available at
18 * https://www.R-project.org/Licenses/
19 */
20
21 /* <UTF8> byte-level access is only to compare with chars <= 0x7F */
22
23 #ifdef HAVE_CONFIG_H
24 #include <config.h>
25 #endif
26
27 #define NEED_CONNECTION_PSTREAMS
28 #define R_USE_SIGNALS 1
29 #include <Defn.h>
30 #include <Internal.h>
31 #include <Rinterface.h>
32 #include <Rmath.h>
33 #include <Fileio.h>
34 #include <R_ext/RS.h>
35 #include <errno.h>
36 #include <ctype.h> /* for isspace */
37
38 /* From time to time changes in R, such as the addition of a new SXP,
39 * may require changes in the save file format. Here are some
40 * guidelines on handling format changes:
41 *
42 * Starting with R 1.4.0 there is a version number associated with
43 * save file formats. This version number should be incremented
44 * when the format is changed so older versions of R can recognize
45 * and reject the new format with a meaningful error message.
46 *
47 * R should remain able to write older workspace formats. An error
48 * should be signaled if the contents to be saved is not compatible
49 * with the requested format.
50 *
51 * To allow older versions of R to give useful error messages, the
52 * header now contains the version of R that wrote the workspace
53 * and the oldest version that can read the workspace. These
54 * versions are stored as an integer packed by the R_Version macro
55 * from Rversion.h. Some workspace formats may only exist
56 * temporarily in the development stage. If readers are not
57 * provided in a release version, then these should specify the
58 * oldest reader R version as -1.
59 */
60
61 #define R_MAGIC_ASCII_V3 3001
62 #define R_MAGIC_BINARY_V3 3002
63 #define R_MAGIC_XDR_V3 3003
64 #define R_MAGIC_ASCII_V2 2001
65 #define R_MAGIC_BINARY_V2 2002
66 #define R_MAGIC_XDR_V2 2003
67 #define R_MAGIC_ASCII_V1 1001
68 #define R_MAGIC_BINARY_V1 1002
69 #define R_MAGIC_XDR_V1 1003
70 #define R_MAGIC_EMPTY 999
71 #define R_MAGIC_CORRUPT 998
72 #define R_MAGIC_MAYBE_TOONEW 997
73
74 /* pre-1 formats (R < 0.99.0) */
75 #define R_MAGIC_BINARY 1975
76 #define R_MAGIC_ASCII 1976
77 #define R_MAGIC_XDR 1977
78 #define R_MAGIC_BINARY_VERSION16 1971
79 #define R_MAGIC_ASCII_VERSION16 1972
80
81
82 /* Static Globals, DIE, DIE, DIE! */
83
84
85 #include "RBufferUtils.h"
86
87 /* These are used by OffsetToNode & DataLoad.
88 OffsetToNode is called by DataLoad() and RestoreSEXP()
89 which itself is only called by RestoreSEXP.
90 */
91 typedef struct {
92 int NSymbol; /* Number of symbols */
93 int NSave; /* Number of non-symbols */
94 int NTotal; /* NSymbol + NSave */
95 int NVSize; /* Number of vector cells */
96
97 int *OldOffset; /* Offsets in previous incarnation */
98
99 SEXP NewAddress; /* Addresses in this incarnation */
100 } NodeInfo;
101
102
103 #ifndef INT_32_BITS
104 /* The way XDR is used pretty much assumes that int is 32 bits and
105 maybe even 2's complement representation--without that, NA_INTEGER
106 is not likely to be preserved properly. Since 32 bit ints (and 2's
107 complement) are pretty much universal, we can worry about that when
108 the need arises. To be safe, we signal a compiler error if int is
109 not 32 bits. There may be similar issues with doubles. */
110 */
111 # error code requires that int have 32 bits
112 #endif
113
114
115 #include <rpc/types.h>
116 #include <rpc/xdr.h>
117
118 #define SMBUF_SIZE 512
119 #define SMBUF_SIZED_STRING "%511s"
120
121 typedef struct {
122 /* These variables are accessed in the
123 InInteger, InComplex, InReal, InString
124 methods for Ascii, Binary, XDR.
125 bufsize is only used in XdrInString!
126
127 The Ascii* routines could declare their own local
128 copy of smbuf and use that (non-static). That would
129 mean some of them wouldn't need the extra argument.
130 */
131
132 R_StringBuffer buffer;
133 char smbuf[SMBUF_SIZE]; /* Small buffer for temp use */
134 /* smbuf is only used by Ascii. */
135 XDR xdrs;
136 } SaveLoadData;
137
138 /* ----- I / O -- F u n c t i o n -- P o i n t e r s ----- */
139
140 typedef struct {
141 void (*OutInit)(FILE*, SaveLoadData *d);
142 void (*OutInteger)(FILE*, int, SaveLoadData *);
143 void (*OutReal)(FILE*, double, SaveLoadData *);
144 void (*OutComplex)(FILE*, Rcomplex, SaveLoadData *);
145 void (*OutString)(FILE*, const char*, SaveLoadData *);
146 void (*OutSpace)(FILE*, int, SaveLoadData *);
147 void (*OutNewline)(FILE*, SaveLoadData *);
148 void (*OutTerm)(FILE*, SaveLoadData *);
149 } OutputRoutines;
150
151 typedef struct {
152 void (*InInit)(FILE*, SaveLoadData *d);
153 int (*InInteger)(FILE*, SaveLoadData *);
154 double (*InReal)(FILE*, SaveLoadData *);
155 Rcomplex (*InComplex)(FILE*, SaveLoadData *);
156 char* (*InString)(FILE*, SaveLoadData *);
157 void (*InTerm)(FILE*, SaveLoadData *d);
158 } InputRoutines;
159
160 typedef struct {
161 FILE *fp;
162 OutputRoutines *methods;
163 SaveLoadData *data;
164 } OutputCtxtData;
165
166 typedef struct {
167 FILE *fp;
168 InputRoutines *methods;
169 SaveLoadData *data;
170 } InputCtxtData;
171
172
173 static SEXP DataLoad(FILE*, int startup, InputRoutines *m, int version, SaveLoadData *d);
174
175
176 /* ----- D u m m y -- P l a c e h o l d e r -- R o u t i n e s ----- */
177
DummyInit(FILE * fp,SaveLoadData * d)178 static void DummyInit(FILE *fp, SaveLoadData *d)
179 {
180 }
181
DummyOutSpace(FILE * fp,int nspace,SaveLoadData * d)182 static void DummyOutSpace(FILE *fp, int nspace, SaveLoadData *d)
183 {
184 }
185
DummyOutNewline(FILE * fp,SaveLoadData * d)186 static void DummyOutNewline(FILE *fp, SaveLoadData *d)
187 {
188 }
189
DummyTerm(FILE * fp,SaveLoadData * d)190 static void DummyTerm(FILE *fp, SaveLoadData *d)
191 {
192 }
193
194 /* ----- O l d - s t y l e (p r e 1. 0) R e s t o r e ----- */
195
196 /* This section is only used to load old-style workspaces / objects */
197
198
199 /* ----- L o w l e v e l -- A s c i i -- I / O ----- */
200
AsciiInInteger(FILE * fp,SaveLoadData * d)201 static int AsciiInInteger(FILE *fp, SaveLoadData *d)
202 {
203 int x, res;
204 res = fscanf(fp, SMBUF_SIZED_STRING, d->smbuf);
205 if(res != 1) error(_("read error"));
206 if (strcmp(d->smbuf, "NA") == 0)
207 return NA_INTEGER;
208 else {
209 res = sscanf(d->smbuf, "%d", &x);
210 if(res != 1) error(_("read error"));
211 return x;
212 }
213 }
214
AsciiInReal(FILE * fp,SaveLoadData * d)215 static double AsciiInReal(FILE *fp, SaveLoadData *d)
216 {
217 double x;
218 int res = fscanf(fp, SMBUF_SIZED_STRING, d->smbuf);
219 if(res != 1) error(_("read error"));
220 if (strcmp(d->smbuf, "NA") == 0)
221 x = NA_REAL;
222 else if (strcmp(d->smbuf, "Inf") == 0)
223 x = R_PosInf;
224 else if (strcmp(d->smbuf, "-Inf") == 0)
225 x = R_NegInf;
226 else
227 res = sscanf(d->smbuf, "%lg", &x);
228 if(res != 1) error(_("read error"));
229 return x;
230 }
231
AsciiInComplex(FILE * fp,SaveLoadData * d)232 static Rcomplex AsciiInComplex(FILE *fp, SaveLoadData *d)
233 {
234 Rcomplex x;
235 int res;
236 res = fscanf(fp, SMBUF_SIZED_STRING, d->smbuf);
237 if(res != 1) error(_("read error"));
238 if (strcmp(d->smbuf, "NA") == 0)
239 x.r = NA_REAL;
240 else if (strcmp(d->smbuf, "Inf") == 0)
241 x.r = R_PosInf;
242 else if (strcmp(d->smbuf, "-Inf") == 0)
243 x.r = R_NegInf;
244 else {
245 res = sscanf(d->smbuf, "%lg", &x.r);
246 if(res != 1) error(_("read error"));
247 }
248
249 res = fscanf(fp, SMBUF_SIZED_STRING, d->smbuf);
250 if(res != 1) error(_("read error"));
251 if (strcmp(d->smbuf, "NA") == 0)
252 x.i = NA_REAL;
253 else if (strcmp(d->smbuf, "Inf") == 0)
254 x.i = R_PosInf;
255 else if (strcmp(d->smbuf, "-Inf") == 0)
256 x.i = R_NegInf;
257 else {
258 res = sscanf(d->smbuf, "%lg", &x.i);
259 if(res != 1) error(_("read error"));
260 }
261 return x;
262 }
263
264
AsciiInString(FILE * fp,SaveLoadData * d)265 static char *AsciiInString(FILE *fp, SaveLoadData *d)
266 {
267 int c;
268 char *bufp = d->buffer.data;
269 while ((c = R_fgetc(fp)) != '"');
270 while ((c = R_fgetc(fp)) != R_EOF && c != '"') {
271 if (c == '\\') {
272 if ((c = R_fgetc(fp)) == R_EOF) break;
273 switch(c) {
274 case 'n': c = '\n'; break;
275 case 't': c = '\t'; break;
276 case 'v': c = '\v'; break;
277 case 'b': c = '\b'; break;
278 case 'r': c = '\r'; break;
279 case 'f': c = '\f'; break;
280 case 'a': c = '\a'; break;
281 case '\\': c = '\\'; break;
282 case '\?': c = '\?'; break;
283 case '\'': c = '\''; break;
284 case '\"': c = '\"'; break;
285 default: break;
286 }
287 }
288 *bufp++ = (char) c;
289 }
290 *bufp = '\0';
291 return d->buffer.data;
292 }
293
AsciiLoad(FILE * fp,int startup,SaveLoadData * d)294 static SEXP AsciiLoad(FILE *fp, int startup, SaveLoadData *d)
295 {
296 InputRoutines m;
297
298 m.InInit = DummyInit;
299 m.InInteger = AsciiInInteger;
300 m.InReal = AsciiInReal;
301 m.InComplex = AsciiInComplex;
302 m.InString = AsciiInString;
303 m.InTerm = DummyTerm;
304 return DataLoad(fp, startup, &m, 0, d);
305 }
306
AsciiLoadOld(FILE * fp,int version,int startup,SaveLoadData * d)307 static SEXP AsciiLoadOld(FILE *fp, int version, int startup, SaveLoadData *d)
308 {
309 InputRoutines m;
310
311 m.InInit = DummyInit;
312 m.InInteger = AsciiInInteger;
313 m.InReal = AsciiInReal;
314 m.InComplex = AsciiInComplex;
315 m.InString = AsciiInString;
316 m.InTerm = DummyTerm;
317 return DataLoad(fp, startup, &m, version, d);
318 }
319
320 /* ----- L o w l e v e l -- X D R -- I / O ----- */
321
XdrInInit(FILE * fp,SaveLoadData * d)322 static void XdrInInit(FILE *fp, SaveLoadData *d)
323 {
324 xdrstdio_create(&d->xdrs, fp, XDR_DECODE);
325 }
326
XdrInTerm(FILE * fp,SaveLoadData * d)327 static void XdrInTerm(FILE *fp, SaveLoadData *d)
328 {
329 xdr_destroy(&d->xdrs);
330 }
331
XdrInInteger(FILE * fp,SaveLoadData * d)332 static int XdrInInteger(FILE * fp, SaveLoadData *d)
333 {
334 int i;
335 if (!xdr_int(&d->xdrs, &i)) {
336 xdr_destroy(&d->xdrs);
337 error(_("a I read error occurred"));
338 }
339 return i;
340 }
341
XdrInReal(FILE * fp,SaveLoadData * d)342 static double XdrInReal(FILE * fp, SaveLoadData *d)
343 {
344 double x;
345 if (!xdr_double(&d->xdrs, &x)) {
346 xdr_destroy(&d->xdrs);
347 error(_("a R read error occurred"));
348 }
349 return x;
350 }
351
XdrInComplex(FILE * fp,SaveLoadData * d)352 static Rcomplex XdrInComplex(FILE * fp, SaveLoadData *d)
353 {
354 Rcomplex x;
355 if (!xdr_double(&d->xdrs, &(x.r)) || !xdr_double(&d->xdrs, &(x.i))) {
356 xdr_destroy(&d->xdrs);
357 error(_("a C read error occurred"));
358 }
359 return x;
360 }
361
XdrInString(FILE * fp,SaveLoadData * d)362 static char *XdrInString(FILE *fp, SaveLoadData *d)
363 {
364 char *bufp = d->buffer.data;
365 if (!xdr_string(&d->xdrs, &bufp, (unsigned int)d->buffer.bufsize)) {
366 xdr_destroy(&d->xdrs);
367 error(_("a S read error occurred"));
368 }
369 return d->buffer.data;
370 }
371
XdrLoad(FILE * fp,int startup,SaveLoadData * d)372 static SEXP XdrLoad(FILE *fp, int startup, SaveLoadData *d)
373 {
374 InputRoutines m;
375
376 m.InInit = XdrInInit;
377 m.InInteger = XdrInInteger;
378 m.InReal = XdrInReal;
379 m.InComplex = XdrInComplex;
380 m.InString = XdrInString;
381 m.InTerm = XdrInTerm;
382 return DataLoad(fp, startup, &m, 0, d);
383 }
384
385
386 /* ----- L o w l e v e l -- B i n a r y -- I / O ----- */
387
BinaryInInteger(FILE * fp,SaveLoadData * unused)388 static int BinaryInInteger(FILE * fp, SaveLoadData *unused)
389 {
390 int i;
391 if (fread(&i, sizeof(int), 1, fp) != 1)
392 error(_("a read error occurred"));
393 return i;
394 }
395
BinaryInReal(FILE * fp,SaveLoadData * unused)396 static double BinaryInReal(FILE * fp, SaveLoadData *unused)
397 {
398 double x;
399 if (fread(&x, sizeof(double), 1, fp) != 1)
400 error(_("a read error occurred"));
401 return x;
402 }
403
BinaryInComplex(FILE * fp,SaveLoadData * unused)404 static Rcomplex BinaryInComplex(FILE * fp, SaveLoadData *unused)
405 {
406 Rcomplex x;
407 if (fread(&x, sizeof(Rcomplex), 1, fp) != 1)
408 error(_("a read error occurred"));
409 return x;
410 }
411
BinaryInString(FILE * fp,SaveLoadData * d)412 static char *BinaryInString(FILE *fp, SaveLoadData *d)
413 {
414 char *bufp = d->buffer.data;
415 do {
416 *bufp = (char) R_fgetc(fp);
417 }
418 while (*bufp++);
419 return d->buffer.data;
420 }
421
BinaryLoad(FILE * fp,int startup,SaveLoadData * d)422 static SEXP BinaryLoad(FILE *fp, int startup, SaveLoadData *d)
423 {
424 InputRoutines m;
425
426 m.InInit = DummyInit;
427 m.InInteger = BinaryInInteger;
428 m.InReal = BinaryInReal;
429 m.InComplex = BinaryInComplex;
430 m.InString = BinaryInString;
431 m.InTerm = DummyTerm;
432 return DataLoad(fp, startup, &m, 0, d);
433 }
434
BinaryLoadOld(FILE * fp,int version,int startup,SaveLoadData * d)435 static SEXP BinaryLoadOld(FILE *fp, int version, int startup, SaveLoadData *d)
436 {
437 InputRoutines m;
438
439 m.InInit = DummyInit;
440 m.InInteger = BinaryInInteger;
441 m.InReal = BinaryInReal;
442 m.InComplex = BinaryInComplex;
443 m.InString = BinaryInString;
444 m.InTerm = DummyTerm;
445 return DataLoad(fp, startup, &m, version, d);
446 }
447
OffsetToNode(int offset,NodeInfo * node)448 static SEXP OffsetToNode(int offset, NodeInfo *node)
449 {
450 int l, m, r;
451
452 if (offset == -1) return R_NilValue;
453 if (offset == -2) return R_GlobalEnv;
454 if (offset == -3) return R_UnboundValue;
455 if (offset == -4) return R_MissingArg;
456
457 /* binary search for offset */
458
459 l = 0;
460 r = node->NTotal - 1;
461 do {
462 m = (l + r) / 2;
463 if (offset < node->OldOffset[m])
464 r = m - 1;
465 else
466 l = m + 1;
467 }
468 while (offset != node->OldOffset[m] && l <= r);
469 if (offset == node->OldOffset[m]) return VECTOR_ELT(node->NewAddress, m);
470
471 /* Not supposed to happen: */
472 warning(_("unresolved node during restore"));
473 return R_NilValue;
474 }
475
FixupType(unsigned int type,int VersionId)476 static unsigned int FixupType(unsigned int type, int VersionId)
477 {
478 if (VersionId) {
479 switch(VersionId) {
480
481 case 16:
482 /* In the version 0.16.1 -> 0.50 switch */
483 /* we really introduced complex values */
484 /* and found that numeric/complex numbers */
485 /* had to be contiguous. Hence this switch */
486 if (type == STRSXP)
487 type = CPLXSXP;
488 else if (type == CPLXSXP)
489 type = STRSXP;
490 break;
491
492 default:
493 error(_("restore compatibility error - no version %d compatibility"),
494 VersionId);
495 }
496 }
497
498 /* Map old factors to new ... (0.61->0.62) */
499 if (type == 11 || type == 12)
500 type = 13;
501
502 return type;
503 }
504
RemakeNextSEXP(FILE * fp,NodeInfo * node,int version,InputRoutines * m,SaveLoadData * d)505 static void RemakeNextSEXP(FILE *fp, NodeInfo *node, int version, InputRoutines *m, SaveLoadData *d)
506 {
507 unsigned int j, idx, type;
508 int len;
509 SEXP s = R_NilValue; /* -Wall */
510
511 idx = m->InInteger(fp, d);
512 type = FixupType(m->InInteger(fp, d), version);
513
514 /* skip over OBJECT, LEVELS, and ATTRIB */
515 /* OBJECT(s) = */ m->InInteger(fp, d);
516 /* LEVELS(s) = */ m->InInteger(fp, d);
517 /* ATTRIB(s) = */ m->InInteger(fp, d);
518 switch (type) {
519 case LISTSXP:
520 case LANGSXP:
521 case CLOSXP:
522 case PROMSXP:
523 case ENVSXP:
524 s = allocSExp(type);
525 /* skip over CAR, CDR, and TAG */
526 /* CAR(s) = */ m->InInteger(fp, d);
527 /* CDR(s) = */ m->InInteger(fp, d);
528 /* TAG(s) = */ m->InInteger(fp, d);
529 break;
530 case SPECIALSXP:
531 case BUILTINSXP:
532 s = allocSExp(type);
533 /* skip over length and name fields */
534 /* length = */ m->InInteger(fp, d);
535 R_AllocStringBuffer(MAXELTSIZE - 1, &(d->buffer));
536 /* name = */ m->InString(fp, d);
537 break;
538 case CHARSXP:
539 len = m->InInteger(fp, d);
540 s = allocCharsxp(len); /* This is not longer correct */
541 R_AllocStringBuffer(len, &(d->buffer));
542 /* skip over the string */
543 /* string = */ m->InString(fp, d);
544 break;
545 case REALSXP:
546 len = m->InInteger(fp, d);
547 s = allocVector(type, len);
548 /* skip over the vector content */
549 for (j = 0; j < len; j++)
550 /*REAL(s)[j] = */ m->InReal(fp, d);
551 break;
552 case CPLXSXP:
553 len = m->InInteger(fp, d);
554 s = allocVector(type, len);
555 /* skip over the vector content */
556 for (j = 0; j < len; j++)
557 /* COMPLEX(s)[j] = */ m->InComplex(fp, d);
558 break;
559 case INTSXP:
560 case LGLSXP:
561 len = m->InInteger(fp, d);;
562 s = allocVector(type, len);
563 /* skip over the vector content */
564 for (j = 0; j < len; j++)
565 /* INTEGER(s)[j] = */ m->InInteger(fp, d);
566 break;
567 case STRSXP:
568 case VECSXP:
569 case EXPRSXP:
570 len = m->InInteger(fp, d);
571 s = allocVector(type, len);
572 /* skip over the vector content */
573 for (j = 0; j < len; j++) {
574 /* VECTOR(s)[j] = */ m->InInteger(fp, d);
575 }
576 break;
577 default: error(_("bad SEXP type in data file"));
578 }
579
580 /* install the new SEXP */
581 SET_VECTOR_ELT(node->NewAddress, idx, s);
582 }
583
RestoreSEXP(SEXP s,FILE * fp,InputRoutines * m,NodeInfo * node,int version,SaveLoadData * d)584 static void RestoreSEXP(SEXP s, FILE *fp, InputRoutines *m, NodeInfo *node, int version, SaveLoadData *d)
585 {
586 unsigned int j, type;
587 int len;
588
589 type = FixupType(m->InInteger(fp, d), version);
590 if (type != TYPEOF(s))
591 error(_("mismatch on types"));
592
593 SET_OBJECT(s, m->InInteger(fp, d));
594 SETLEVELS(s, m->InInteger(fp, d));
595 SET_ATTRIB(s, OffsetToNode(m->InInteger(fp, d), node));
596 switch (TYPEOF(s)) {
597 case LISTSXP:
598 case LANGSXP:
599 case CLOSXP:
600 case PROMSXP:
601 case ENVSXP:
602 SETCAR(s, OffsetToNode(m->InInteger(fp, d), node));
603 SETCDR(s, OffsetToNode(m->InInteger(fp, d), node));
604 SET_TAG(s, OffsetToNode(m->InInteger(fp, d), node));
605 break;
606 case SPECIALSXP:
607 case BUILTINSXP:
608 len = m->InInteger(fp, d);
609 R_AllocStringBuffer(MAXELTSIZE - 1, &(d->buffer));
610 int index = StrToInternal(m->InString(fp, d));
611 if (index == NA_INTEGER) {
612 warning(_("unrecognized internal function name \"%s\""), d->buffer.data);
613 index = 0; /* zero doesn't make sense, but is back compatible with 3.0.0 and earlier */
614 }
615 SET_PRIMOFFSET(s, index);
616 break;
617 case CHARSXP:
618 len = m->InInteger(fp, d);
619 R_AllocStringBuffer(len, &(d->buffer));
620 /* Better to use a fresh copy in the cache */
621 strcpy(CHAR_RW(s), m->InString(fp, d));
622 break;
623 case REALSXP:
624 len = m->InInteger(fp, d);
625 for (j = 0; j < len; j++)
626 REAL(s)[j] = m->InReal(fp, d);
627 break;
628 case CPLXSXP:
629 len = m->InInteger(fp, d);
630 for (j = 0; j < len; j++)
631 COMPLEX(s)[j] = m->InComplex(fp, d);
632 break;
633 case INTSXP:
634 case LGLSXP:
635 len = m->InInteger(fp, d);;
636 for (j = 0; j < len; j++)
637 INTEGER(s)[j] = m->InInteger(fp, d);
638 break;
639 case STRSXP:
640 len = m->InInteger(fp, d);
641 for (j = 0; j < len; j++)
642 SET_STRING_ELT(s, j, OffsetToNode(m->InInteger(fp, d), node));
643 break;
644 case VECSXP:
645 case EXPRSXP:
646 len = m->InInteger(fp, d);
647 for (j = 0; j < len; j++)
648 SET_VECTOR_ELT(s, j, OffsetToNode(m->InInteger(fp, d), node));
649 break;
650 default: error(_("bad SEXP type in data file"));
651 }
652 }
653
RestoreError(char * msg,int startup)654 static void RestoreError(/* const */ char *msg, int startup)
655 {
656 if(startup)
657 R_Suicide(msg);
658 else
659 error("%s", msg);
660 }
661
662 /* used for pre-version 1 formats */
DataLoad(FILE * fp,int startup,InputRoutines * m,int version,SaveLoadData * d)663 static SEXP DataLoad(FILE *fp, int startup, InputRoutines *m,
664 int version, SaveLoadData *d)
665 {
666 int i, j;
667 const void *vmaxsave;
668 fpos_t savepos;
669 NodeInfo node;
670
671 /* read in the size information */
672
673 m->InInit(fp, d);
674
675 node.NSymbol = m->InInteger(fp, d);
676 node.NSave = m->InInteger(fp, d);
677 node.NVSize = m->InInteger(fp, d);
678 node.NTotal = node.NSymbol + node.NSave;
679
680 /* allocate the forwarding-address tables */
681 /* these are non-relocatable, so we must */
682 /* save the current non-relocatable base */
683
684 vmaxsave = vmaxget();
685 node.OldOffset = (int*)R_alloc(node.NSymbol + node.NSave, sizeof(int));
686 PROTECT(node.NewAddress = allocVector(VECSXP, node.NSymbol + node.NSave));
687 for (i = 0 ; i < node.NTotal ; i++) {
688 node.OldOffset[i] = 0;
689 SET_VECTOR_ELT(node.NewAddress, i, R_NilValue);
690 }
691
692 /* read in the required symbols */
693 /* expanding the symbol table and */
694 /* computing the forwarding addresses */
695
696 for (i = 0 ; i < node.NSymbol ; i++) {
697 j = m->InInteger(fp, d);
698 node.OldOffset[j] = m->InInteger(fp, d);
699 R_AllocStringBuffer(MAXELTSIZE - 1, &(d->buffer));
700 SET_VECTOR_ELT(node.NewAddress, j, install(m->InString(fp, d)));
701 }
702
703 /* build the full forwarding table */
704
705 for (i = 0 ; i < node.NSave ; i++) {
706 j = m->InInteger(fp, d);
707 node.OldOffset[j] = m->InInteger(fp, d);
708 }
709
710
711 /* f[gs]etpos are 64-bit on MSVCRT Windows */
712 /* save the file position */
713 if (fgetpos(fp, &savepos))
714 RestoreError(_("cannot save file position while restoring data"),
715 startup);
716
717
718 /* first pass: allocate nodes */
719
720 for (i = 0 ; i < node.NSave ; i++) {
721 RemakeNextSEXP(fp, &node, version, m, d);
722 }
723
724
725 /* restore the file position */
726 if (fsetpos(fp, &savepos))
727 RestoreError(_("cannot restore file position while restoring data"),
728 startup);
729
730
731 /* second pass: restore the contents of the nodes */
732
733 for (i = 0 ; i < node.NSave ; i++) {
734 RestoreSEXP(VECTOR_ELT(node.NewAddress, m->InInteger(fp, d)), fp, m, &node, version, d);
735 }
736
737 /* restore the heap */
738
739 vmaxset(vmaxsave);
740 UNPROTECT(1);
741
742 /* clean the string buffer */
743 R_FreeStringBufferL(&(d->buffer));
744
745 /* return the "top-level" object */
746 /* this is usually a list */
747
748 i = m->InInteger(fp, d);
749 m->InTerm(fp, d);
750
751 return OffsetToNode(i, &node);
752 }
753
754
755 /* ----- V e r s i o n -- O n e -- S a v e / R e s t o r e ----- */
756
757 /* Code Developed by Chris K. Young <cky@pobox.com>
758 * and Ross Ihaka for Chris' Honours project -- 1999.
759 * Copyright Assigned to the R Project.
760 */
761
762 /* An assert function which doesn't crash the program.
763 * Something like this might be useful in an R header file
764 */
765
766 #ifdef NDEBUG
767 #define R_assert(e) ((void) 0)
768 #else
769 /* The line below requires an ANSI C preprocessor (stringify operator) */
770 #define R_assert(e) ((e) ? (void) 0 : error("assertion `%s' failed: file `%s', line %d\n", #e, __FILE__, __LINE__))
771 #endif /* NDEBUG */
772
773
774 static void NewWriteItem (SEXP s, SEXP sym_list, SEXP env_list, FILE *fp, OutputRoutines *, SaveLoadData *);
775 static SEXP NewReadItem (SEXP sym_table, SEXP env_table, FILE *fp, InputRoutines *, SaveLoadData *);
776
777
778 /* We use special (negative) type codes to indicate the special
779 * values: R_NilValue, R_GlobalEnv, R_UnboundValue, R_MissingArg.
780 * The following routines handle these conversions (both
781 * directions). */
782
NewSaveSpecialHook(SEXP item)783 static int NewSaveSpecialHook (SEXP item)
784 {
785 if (item == R_NilValue) return -1;
786 if (item == R_GlobalEnv) return -2;
787 if (item == R_UnboundValue) return -3;
788 if (item == R_MissingArg) return -4;
789 return 0;
790 }
791
NewLoadSpecialHook(SEXPTYPE type)792 static SEXP NewLoadSpecialHook (SEXPTYPE type)
793 {
794 switch (type) {
795 case -1: return R_NilValue;
796 case -2: return R_GlobalEnv;
797 case -3: return R_UnboundValue;
798 case -4: return R_MissingArg;
799 }
800 return (SEXP) 0; /* not strictly legal... */
801 }
802
803
804 /* If "item" is a special value (as defined in "NewSaveSpecialHook")
805 * then a negative value is returned.
806 *
807 * If "item" is present in "list" the a positive value is returned
808 * (the 1-based offset into the list).
809 *
810 * Otherwise, a value of zero is returned.
811 *
812 * The "list" is managed with a hash table. This results in
813 * significant speedups for saving large amounts of code. A fixed
814 * hash table size is used; this is not ideal but seems adequate for
815 * now. The hash table representation consists of a (list . vector)
816 * pair. The hash buckets are in the vector. The list holds the
817 * list of keys. This list is in reverse order to the way the keys
818 * were added (i.e. the most recently added key is first). The
819 * indices produced by HashAdd are in order. Since the list is
820 * written out in order, we either have to reverse the list or
821 * reverse the indices; to retain byte for byte compatibility the
822 * function FixHashEntries reverses the indices. FixHashEntries must
823 * be called after filling the tables and before using them to find
824 * indices. LT */
825
826 #define HASHSIZE 1099
827
828 #define PTRHASH(obj) (((R_size_t) (obj)) >> 2)
829
830 #define HASH_TABLE_KEYS_LIST(ht) CAR(ht)
831 #define SET_HASH_TABLE_KEYS_LIST(ht, v) SETCAR(ht, v)
832
833 #define HASH_TABLE_COUNT(ht) ((int) TRUELENGTH(CDR(ht)))
834 #define SET_HASH_TABLE_COUNT(ht, val) SET_TRUELENGTH(CDR(ht), ((int) (val)))
835
836 #define HASH_TABLE_SIZE(ht) LENGTH(CDR(ht))
837
838 #define HASH_BUCKET(ht, pos) VECTOR_ELT(CDR(ht), pos)
839 #define SET_HASH_BUCKET(ht, pos, val) SET_VECTOR_ELT(CDR(ht), pos, val)
840
MakeHashTable(void)841 static SEXP MakeHashTable(void)
842 {
843 SEXP val = CONS(R_NilValue, allocVector(VECSXP, HASHSIZE));
844 SET_HASH_TABLE_COUNT(val, 0);
845 return val;
846 }
847
FixHashEntries(SEXP ht)848 static void FixHashEntries(SEXP ht)
849 {
850 SEXP cell;
851 int count;
852 for (cell = HASH_TABLE_KEYS_LIST(ht), count = 1;
853 cell != R_NilValue;
854 cell = CDR(cell), count++)
855 INTEGER(TAG(cell))[0] = count;
856 }
857
HashAdd(SEXP obj,SEXP ht)858 static void HashAdd(SEXP obj, SEXP ht)
859 {
860 R_size_t pos = PTRHASH(obj) % HASH_TABLE_SIZE(ht);
861 int count = HASH_TABLE_COUNT(ht) + 1;
862 SEXP val = ScalarInteger(count);
863 SEXP cell = CONS(val, HASH_BUCKET(ht, pos));
864
865 SET_HASH_TABLE_COUNT(ht, count);
866 SET_HASH_BUCKET(ht, pos, cell);
867 SET_TAG(cell, obj);
868 SET_HASH_TABLE_KEYS_LIST(ht, CONS(obj, HASH_TABLE_KEYS_LIST(ht)));
869 SET_TAG(HASH_TABLE_KEYS_LIST(ht), val);
870 }
871
HashGet(SEXP item,SEXP ht)872 static int HashGet(SEXP item, SEXP ht)
873 {
874 R_size_t pos = PTRHASH(item) % HASH_TABLE_SIZE(ht);
875 SEXP cell;
876 for (cell = HASH_BUCKET(ht, pos); cell != R_NilValue; cell = CDR(cell))
877 if (item == TAG(cell))
878 return INTEGER(CAR(cell))[0];
879 return 0;
880 }
881
NewLookup(SEXP item,SEXP ht)882 static int NewLookup (SEXP item, SEXP ht)
883 {
884 int count = NewSaveSpecialHook(item);
885
886 if (count != 0)
887 return count;
888 else
889 return HashGet(item, ht);
890 }
891
892 /* This code carries out the basic inspection of an object, building
893 * the tables of symbols and environments.
894 *
895 * We don't really need to build a table of symbols here, but it does
896 * prevent repeated "install"s. On the other hand there will generally
897 * be huge delays because of disk or network latency ...
898 *
899 * CKY: One thing I've found out is that you have to build all the
900 * lists together or you risk getting infinite loops. Of course, the
901 * method used here somehow shoots functional programming in the
902 * head --- sorry. */
903
NewMakeLists(SEXP obj,SEXP sym_list,SEXP env_list)904 static void NewMakeLists (SEXP obj, SEXP sym_list, SEXP env_list)
905 {
906 int count, length;
907
908 if (NewSaveSpecialHook(obj))
909 return;
910 switch (TYPEOF(obj)) {
911 case SYMSXP:
912 if (NewLookup(obj, sym_list))
913 return;
914 HashAdd(obj, sym_list);
915 break;
916 case ENVSXP:
917 if (NewLookup(obj, env_list))
918 return;
919 if (obj == R_BaseNamespace)
920 warning(_("base namespace is not preserved in version 1 workspaces"));
921 else if (R_IsNamespaceEnv(obj))
922 error(_("cannot save namespace in version 1 workspaces"));
923 if (R_HasFancyBindings(obj))
924 error(_("cannot save environment with locked/active bindings \
925 in version 1 workspaces"));
926 HashAdd(obj, env_list);
927 /* FALLTHROUGH */
928 case LISTSXP:
929 case LANGSXP:
930 case PROMSXP:
931 case DOTSXP:
932 NewMakeLists(TAG(obj), sym_list, env_list);
933 NewMakeLists(CAR(obj), sym_list, env_list);
934 NewMakeLists(CDR(obj), sym_list, env_list);
935 break;
936 case CLOSXP:
937 NewMakeLists(CLOENV(obj), sym_list, env_list);
938 NewMakeLists(FORMALS(obj), sym_list, env_list);
939 NewMakeLists(BODY(obj), sym_list, env_list);
940 break;
941 case EXTPTRSXP:
942 NewMakeLists(EXTPTR_PROT(obj), sym_list, env_list);
943 NewMakeLists(EXTPTR_TAG(obj), sym_list, env_list);
944 break;
945 case VECSXP:
946 case EXPRSXP:
947 length = LENGTH(obj);
948 for (count = 0; count < length; ++count)
949 NewMakeLists(VECTOR_ELT(obj, count), sym_list, env_list);
950 break;
951 case WEAKREFSXP:
952 error(_("cannot save weak references in version 1 workspaces"));
953 }
954 NewMakeLists(ATTRIB(obj), sym_list, env_list);
955 }
956
957 /* e.g., OutVec(fp, obj, INTEGER, OutInteger)
958 The passMethods argument tells it whether to call outfunc with the
959 other methods. This is only needed when calling OutCHARSXP
960 since it needs to know how to write sub-elements!
961 */
962 #define OutVec(fp, obj, accessor, outfunc, methods, d) \
963 do { \
964 int cnt; \
965 for (cnt = 0; cnt < LENGTH(obj); ++cnt) { \
966 methods->OutSpace(fp, 1,d); \
967 outfunc(fp, accessor(obj, cnt), d); \
968 methods->OutNewline(fp, d); \
969 } \
970 } while (0)
971
972 #define LOGICAL_ELT(x,__i__) LOGICAL(x)[__i__]
973 #define INTEGER_ELT(x,__i__) INTEGER(x)[__i__]
974 #define REAL_ELT(x,__i__) REAL(x)[__i__]
975 #define COMPLEX_ELT(x,__i__) COMPLEX(x)[__i__]
976
977 /* Simply outputs the string associated with a CHARSXP, one day this
978 * will handle null characters in CHARSXPs and not just blindly call
979 * OutString. */
OutCHARSXP(FILE * fp,SEXP s,OutputRoutines * m,SaveLoadData * d)980 static void OutCHARSXP (FILE *fp, SEXP s, OutputRoutines *m, SaveLoadData *d)
981 {
982 R_assert(TYPEOF(s) == CHARSXP);
983 m->OutString(fp, CHAR(s), d);
984 }
985
NewWriteVec(SEXP s,SEXP sym_list,SEXP env_list,FILE * fp,OutputRoutines * m,SaveLoadData * d)986 static void NewWriteVec (SEXP s, SEXP sym_list, SEXP env_list, FILE *fp, OutputRoutines *m, SaveLoadData *d)
987 {
988 int count;
989
990 /* I can assert here that `s' is one of the vector types, but
991 * it'll turn out to be one big ugly statement... so I'll do it at
992 * the bottom. */
993
994 m->OutInteger(fp, LENGTH(s), d);
995 m->OutNewline(fp, d);
996 switch (TYPEOF(s)) {
997 case CHARSXP:
998 m->OutSpace(fp, 1, d);
999 OutCHARSXP(fp, s, m, d);
1000 break;
1001 case LGLSXP:
1002 case INTSXP:
1003 OutVec(fp, s, INTEGER_ELT, m->OutInteger, m, d);
1004 break;
1005 case REALSXP:
1006 OutVec(fp, s, REAL_ELT, m->OutReal, m, d);
1007 break;
1008 case CPLXSXP:
1009 OutVec(fp, s, COMPLEX_ELT, m->OutComplex, m, d);
1010 break;
1011 case STRSXP:
1012 do {
1013 int cnt;
1014 for (cnt = 0; cnt < LENGTH(s); ++cnt) {
1015 m->OutSpace(fp, 1, d);
1016 OutCHARSXP(fp, STRING_ELT(s, cnt), m, d);
1017 m->OutNewline(fp, d);
1018 }
1019 } while (0);
1020 break;
1021 case VECSXP:
1022 case EXPRSXP:
1023 for (count = 0; count < LENGTH(s); ++count) {
1024 /* OutSpace(fp, 1); */
1025 NewWriteItem(VECTOR_ELT(s, count), sym_list, env_list, fp, m, d);
1026 m->OutNewline(fp, d);
1027 }
1028 break;
1029 default:
1030 error(_("NewWriteVec called with non-vector type"));
1031 }
1032 }
1033
NewWriteItem(SEXP s,SEXP sym_list,SEXP env_list,FILE * fp,OutputRoutines * m,SaveLoadData * d)1034 static void NewWriteItem (SEXP s, SEXP sym_list, SEXP env_list, FILE *fp, OutputRoutines *m, SaveLoadData *d)
1035 {
1036 int i;
1037
1038 if ((i = NewSaveSpecialHook(s))) {
1039 m->OutInteger(fp, i, d);
1040 m->OutNewline(fp, d);
1041 }
1042 else {
1043 m->OutInteger(fp, TYPEOF(s), d);
1044 m->OutSpace(fp, 1, d); m->OutInteger(fp, LEVELS(s), d);
1045 m->OutSpace(fp, 1, d); m->OutInteger(fp, OBJECT(s), d);
1046 m->OutNewline(fp, d);
1047 switch (TYPEOF(s)) {
1048 /* Note : NILSXP can't occur here */
1049 case SYMSXP:
1050 i = NewLookup(s, sym_list);
1051 R_assert(i);
1052 m->OutInteger(fp, i, d); m->OutNewline(fp, d);
1053 break;
1054 case ENVSXP:
1055 i = NewLookup(s, env_list);
1056 R_assert(i);
1057 m->OutInteger(fp, i, d); m->OutNewline(fp, d);
1058 break;
1059 case LISTSXP:
1060 case LANGSXP:
1061 case PROMSXP:
1062 case DOTSXP:
1063 /* Dotted pair objects */
1064 NewWriteItem(TAG(s), sym_list, env_list, fp, m, d);
1065 NewWriteItem(CAR(s), sym_list, env_list, fp, m, d);
1066 NewWriteItem(CDR(s), sym_list, env_list, fp, m, d);
1067 break;
1068 case CLOSXP:
1069 NewWriteItem(CLOENV(s), sym_list, env_list, fp, m, d);
1070 NewWriteItem(FORMALS(s), sym_list, env_list, fp, m, d);
1071 NewWriteItem(BODY(s), sym_list, env_list, fp, m, d);
1072 break;
1073 case EXTPTRSXP:
1074 NewWriteItem(EXTPTR_PROT(s), sym_list, env_list, fp, m, d);
1075 NewWriteItem(EXTPTR_TAG(s), sym_list, env_list, fp, m, d);
1076 break;
1077 case WEAKREFSXP:
1078 /* Weak references */
1079 break;
1080 case SPECIALSXP:
1081 case BUILTINSXP:
1082 /* Builtin functions */
1083 m->OutString(fp, PRIMNAME(s), d); m->OutNewline(fp, d);
1084 break;
1085 case CHARSXP:
1086 case LGLSXP:
1087 case INTSXP:
1088 case REALSXP:
1089 case CPLXSXP:
1090 case STRSXP:
1091 case VECSXP:
1092 case EXPRSXP:
1093 /* Vector Objects */
1094 NewWriteVec(s, sym_list, env_list, fp, m, d);
1095 break;
1096 case BCODESXP:
1097 error(_("cannot save byte code objects in version 1 workspaces"));
1098 default:
1099 error(_("NewWriteItem: unknown type %i"), TYPEOF(s));
1100 }
1101 NewWriteItem(ATTRIB(s), sym_list, env_list, fp, m, d);
1102 }
1103 }
1104
1105 /* General format: the total number of symbols, then the total number
1106 * of environments. Then all the symbol names get written out,
1107 * followed by the environments, then the items to be saved. If
1108 * symbols or environments are encountered, references to them are
1109 * made instead of writing them out totally. */
1110
newdatasave_cleanup(void * data)1111 static void newdatasave_cleanup(void *data)
1112 {
1113 OutputCtxtData *cinfo = (OutputCtxtData*)data;
1114 FILE *fp = cinfo->fp;
1115 cinfo->methods->OutTerm(fp, cinfo->data);
1116 }
1117
NewDataSave(SEXP s,FILE * fp,OutputRoutines * m,SaveLoadData * d)1118 static void NewDataSave (SEXP s, FILE *fp, OutputRoutines *m, SaveLoadData *d)
1119 {
1120 SEXP sym_table, env_table, iterator;
1121 int sym_count, env_count;
1122 RCNTXT cntxt;
1123 OutputCtxtData cinfo;
1124 cinfo.fp = fp; cinfo.methods = m; cinfo.data = d;
1125
1126 PROTECT(sym_table = MakeHashTable());
1127 PROTECT(env_table = MakeHashTable());
1128 NewMakeLists(s, sym_table, env_table);
1129 FixHashEntries(sym_table);
1130 FixHashEntries(env_table);
1131
1132 m->OutInit(fp, d);
1133 /* set up a context which will call OutTerm if there is an error */
1134 begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
1135 R_NilValue, R_NilValue);
1136 cntxt.cend = &newdatasave_cleanup;
1137 cntxt.cenddata = &cinfo;
1138
1139 m->OutInteger(fp, sym_count = HASH_TABLE_COUNT(sym_table), d); m->OutSpace(fp, 1, d);
1140 m->OutInteger(fp, env_count = HASH_TABLE_COUNT(env_table), d); m->OutNewline(fp, d);
1141 for (iterator = HASH_TABLE_KEYS_LIST(sym_table);
1142 sym_count--;
1143 iterator = CDR(iterator)) {
1144 R_assert(TYPEOF(CAR(iterator)) == SYMSXP);
1145 m->OutString(fp, CHAR(PRINTNAME(CAR(iterator))), d);
1146 m->OutNewline(fp, d);
1147 }
1148 for (iterator = HASH_TABLE_KEYS_LIST(env_table);
1149 env_count--;
1150 iterator = CDR(iterator)) {
1151 R_assert(TYPEOF(CAR(iterator)) == ENVSXP);
1152 NewWriteItem(ENCLOS(CAR(iterator)), sym_table, env_table, fp, m, d);
1153 NewWriteItem(FRAME(CAR(iterator)), sym_table, env_table, fp, m, d);
1154 NewWriteItem(HASHTAB(CAR(iterator)), sym_table, env_table, fp, m, d);
1155 }
1156 NewWriteItem(s, sym_table, env_table, fp, m, d);
1157
1158 /* end the context after anything that could raise an error but before
1159 calling OutTerm so it doesn't get called twice */
1160 endcontext(&cntxt);
1161
1162 m->OutTerm(fp, d);
1163 UNPROTECT(2);
1164 }
1165
1166 #define InVec(fp, obj, accessor, infunc, length, d) \
1167 do { \
1168 int cnt; \
1169 for (cnt = 0; cnt < length; ++cnt) \
1170 accessor(obj, cnt, infunc(fp, d)); \
1171 } while (0)
1172
1173
1174
1175 #define SET_LOGICAL_ELT(x,__i__,v) (LOGICAL_ELT(x,__i__)=(v))
1176 #define SET_INTEGER_ELT(x,__i__,v) (INTEGER_ELT(x,__i__)=(v))
1177 #define SET_REAL_ELT(x,__i__,v) (REAL_ELT(x,__i__)=(v))
1178 #define SET_COMPLEX_ELT(x,__i__,v) (COMPLEX_ELT(x,__i__)=(v))
1179
InCHARSXP(FILE * fp,InputRoutines * m,SaveLoadData * d)1180 static SEXP InCHARSXP (FILE *fp, InputRoutines *m, SaveLoadData *d)
1181 {
1182 SEXP s;
1183 char *tmp;
1184 size_t len;
1185
1186 /* FIXME: rather than use strlen, use actual length of string when
1187 * sized strings get implemented in R's save/load code. */
1188 tmp = m->InString(fp, d);
1189 len = strlen(tmp);
1190 R_AllocStringBuffer(len, &(d->buffer));
1191 s = mkChar(tmp);
1192 return s;
1193 }
1194
NewReadVec(SEXPTYPE type,SEXP sym_table,SEXP env_table,FILE * fp,InputRoutines * m,SaveLoadData * d)1195 static SEXP NewReadVec(SEXPTYPE type, SEXP sym_table, SEXP env_table, FILE *fp, InputRoutines *m, SaveLoadData *d)
1196 {
1197 int length, count;
1198 SEXP my_vec;
1199
1200 length = m->InInteger(fp, d);
1201 PROTECT(my_vec = allocVector(type, length));
1202 switch(type) {
1203 case CHARSXP:
1204 my_vec = InCHARSXP(fp, m, d);
1205 break;
1206 case LGLSXP:
1207 case INTSXP:
1208 InVec(fp, my_vec, SET_INTEGER_ELT, m->InInteger, length, d);
1209 break;
1210 case REALSXP:
1211 InVec(fp, my_vec, SET_REAL_ELT, m->InReal, length, d);
1212 break;
1213 case CPLXSXP:
1214 InVec(fp, my_vec, SET_COMPLEX_ELT, m->InComplex, length, d);
1215 break;
1216 case STRSXP:
1217 do {
1218 int cnt;
1219 for (cnt = 0; cnt < length(my_vec); ++cnt)
1220 SET_STRING_ELT(my_vec, cnt, InCHARSXP(fp, m, d));
1221 } while (0);
1222 break;
1223 case VECSXP:
1224 case EXPRSXP:
1225 for (count = 0; count < length; ++count)
1226 SET_VECTOR_ELT(my_vec, count, NewReadItem(sym_table, env_table, fp, m, d));
1227 break;
1228 default:
1229 error(_("NewReadVec called with non-vector type"));
1230 }
1231 UNPROTECT(1);
1232 return my_vec;
1233 }
1234
NewReadItem(SEXP sym_table,SEXP env_table,FILE * fp,InputRoutines * m,SaveLoadData * d)1235 static SEXP NewReadItem (SEXP sym_table, SEXP env_table, FILE *fp,
1236 InputRoutines *m, SaveLoadData *d)
1237 {
1238 SEXPTYPE type;
1239 SEXP s;
1240 int pos, levs, objf;
1241
1242 R_assert(TYPEOF(sym_table) == VECSXP && TYPEOF(env_table) == VECSXP);
1243 type = m->InInteger(fp, d);
1244 if ((s = NewLoadSpecialHook(type)))
1245 return s;
1246 levs = m->InInteger(fp, d);
1247 objf = m->InInteger(fp, d);
1248 switch (type) {
1249 case SYMSXP:
1250 pos = m->InInteger(fp, d);
1251 PROTECT(s = pos ? VECTOR_ELT(sym_table, pos - 1) : R_NilValue);
1252 break;
1253 case ENVSXP:
1254 pos = m->InInteger(fp, d);
1255 PROTECT(s = pos ? VECTOR_ELT(env_table, pos - 1) : R_NilValue);
1256 break;
1257 case LISTSXP:
1258 case LANGSXP:
1259 case CLOSXP:
1260 case PROMSXP:
1261 case DOTSXP:
1262 PROTECT(s = allocSExp(type));
1263 SET_TAG(s, NewReadItem(sym_table, env_table, fp, m, d));
1264 SETCAR(s, NewReadItem(sym_table, env_table, fp, m, d));
1265 SETCDR(s, NewReadItem(sym_table, env_table, fp, m, d));
1266 /*UNPROTECT(1);*/
1267 break;
1268 case EXTPTRSXP:
1269 PROTECT(s = allocSExp(type));
1270 R_SetExternalPtrAddr(s, NULL);
1271 R_SetExternalPtrProtected(s, NewReadItem(sym_table, env_table, fp, m, d));
1272 R_SetExternalPtrTag(s, NewReadItem(sym_table, env_table, fp, m, d));
1273 /*UNPROTECT(1);*/
1274 break;
1275 case WEAKREFSXP:
1276 PROTECT(s = R_MakeWeakRef(R_NilValue, R_NilValue, R_NilValue, FALSE));
1277 break;
1278 case SPECIALSXP:
1279 case BUILTINSXP:
1280 R_AllocStringBuffer(MAXELTSIZE - 1, &(d->buffer));
1281 int index = StrToInternal(m->InString(fp, d));
1282 if (index == NA_INTEGER) {
1283 warning(_("unrecognized internal function name \"%s\""), d->buffer.data);
1284 PROTECT(s = R_NilValue);
1285 } else
1286 PROTECT(s = mkPRIMSXP(index, type == BUILTINSXP));
1287 break;
1288 case CHARSXP:
1289 case LGLSXP:
1290 case INTSXP:
1291 case REALSXP:
1292 case CPLXSXP:
1293 case STRSXP:
1294 case VECSXP:
1295 case EXPRSXP:
1296 PROTECT(s = NewReadVec(type, sym_table, env_table, fp, m, d));
1297 break;
1298 case BCODESXP:
1299 error(_("cannot read byte code objects from version 1 workspaces"));
1300 default:
1301 error(_("NewReadItem: unknown type %i"), type);
1302 }
1303 SETLEVELS(s, (unsigned short) levs);
1304 SET_OBJECT(s, objf);
1305 SET_ATTRIB(s, NewReadItem(sym_table, env_table, fp, m, d));
1306 UNPROTECT(1); /* s */
1307 return s;
1308 }
1309
newdataload_cleanup(void * data)1310 static void newdataload_cleanup(void *data)
1311 {
1312 InputCtxtData *cinfo = (InputCtxtData*)data;
1313 FILE *fp = (FILE *) data;
1314 cinfo->methods->InTerm(fp, cinfo->data);
1315 }
1316
NewDataLoad(FILE * fp,InputRoutines * m,SaveLoadData * d)1317 static SEXP NewDataLoad (FILE *fp, InputRoutines *m, SaveLoadData *d)
1318 {
1319 int sym_count, env_count, count;
1320 SEXP sym_table, env_table, obj;
1321 RCNTXT cntxt;
1322 InputCtxtData cinfo;
1323 cinfo.fp = fp; cinfo.methods = m; cinfo.data = d;
1324
1325 m->InInit(fp, d);
1326
1327 /* set up a context which will call InTerm if there is an error */
1328 begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
1329 R_NilValue, R_NilValue);
1330 cntxt.cend = &newdataload_cleanup;
1331 cntxt.cenddata = &cinfo;
1332
1333 /* Read the table sizes */
1334 sym_count = m->InInteger(fp, d);
1335 env_count = m->InInteger(fp, d);
1336
1337 /* Allocate the symbol and environment tables */
1338 PROTECT(sym_table = allocVector(VECSXP, sym_count));
1339 PROTECT(env_table = allocVector(VECSXP, env_count));
1340
1341 /* Read back and install symbols */
1342 for (count = 0; count < sym_count; ++count) {
1343 SET_VECTOR_ELT(sym_table, count, install(m->InString(fp, d)));
1344 }
1345 /* Allocate the environments */
1346 for (count = 0; count < env_count; ++count)
1347 SET_VECTOR_ELT(env_table, count, allocSExp(ENVSXP));
1348
1349 /* Now fill them in */
1350 for (count = 0; count < env_count; ++count) {
1351 obj = VECTOR_ELT(env_table, count);
1352 SET_ENCLOS(obj, NewReadItem(sym_table, env_table, fp, m, d));
1353 SET_FRAME(obj, NewReadItem(sym_table, env_table, fp, m, d));
1354 SET_TAG(obj, NewReadItem(sym_table, env_table, fp, m, d));
1355 R_RestoreHashCount(obj);
1356 }
1357
1358 /* Read the actual object back */
1359 PROTECT(obj = NewReadItem(sym_table, env_table, fp, m, d));
1360
1361 /* end the context after anything that could raise an error but before
1362 calling InTerm so it doesn't get called twice */
1363 endcontext(&cntxt);
1364
1365 /* Wrap up */
1366 m->InTerm(fp, d);
1367 UNPROTECT(3); /* obj, env_table, sym_table */
1368 return obj;
1369 }
1370
1371 /* ----- L o w l e v e l -- A s c i i -- I / O ------ */
1372
OutSpaceAscii(FILE * fp,int nspace,SaveLoadData * unused)1373 static void OutSpaceAscii(FILE *fp, int nspace, SaveLoadData *unused)
1374 {
1375 while(--nspace >= 0)
1376 fputc(' ', fp);
1377 }
OutNewlineAscii(FILE * fp,SaveLoadData * unused)1378 static void OutNewlineAscii(FILE *fp, SaveLoadData *unused)
1379 {
1380 fputc('\n', fp);
1381 }
1382
OutIntegerAscii(FILE * fp,int x,SaveLoadData * unused)1383 static void OutIntegerAscii(FILE *fp, int x, SaveLoadData *unused)
1384 {
1385 if (x == NA_INTEGER) fprintf(fp, "NA");
1386 else fprintf(fp, "%d", x);
1387 }
1388
InIntegerAscii(FILE * fp,SaveLoadData * unused)1389 static int InIntegerAscii(FILE *fp, SaveLoadData *unused)
1390 {
1391 char buf[128];
1392 int x, res;
1393 res = fscanf(fp, "%127s", buf);
1394 if(res != 1) error(_("read error"));
1395 if (strcmp(buf, "NA") == 0)
1396 return NA_INTEGER;
1397 else {
1398 res = sscanf(buf, "%d", &x);
1399 if(res != 1) error(_("read error"));
1400 }
1401 return x;
1402 }
1403
OutStringAscii(FILE * fp,const char * x,SaveLoadData * unused)1404 static void OutStringAscii(FILE *fp, const char *x, SaveLoadData *unused)
1405 {
1406 size_t i, nbytes;
1407 nbytes = strlen(x);
1408 fprintf(fp, "%d ", (int) nbytes);
1409 for (i = 0; i < nbytes; i++) {
1410 switch(x[i]) {
1411 case '\n': fprintf(fp, "\\n"); break;
1412 case '\t': fprintf(fp, "\\t"); break;
1413 case '\v': fprintf(fp, "\\v"); break;
1414 case '\b': fprintf(fp, "\\b"); break;
1415 case '\r': fprintf(fp, "\\r"); break;
1416 case '\f': fprintf(fp, "\\f"); break;
1417 case '\a': fprintf(fp, "\\a"); break;
1418 case '\\': fprintf(fp, "\\\\"); break;
1419 case '\?': fprintf(fp, "\\?"); break;
1420 case '\'': fprintf(fp, "\\'"); break;
1421 case '\"': fprintf(fp, "\\\""); break;
1422 default :
1423 /* cannot print char in octal mode -> cast to unsigned
1424 char first */
1425 /* actually, since x is signed char and '\?' == 127
1426 is handled above, x[i] > 126 can't happen, but
1427 I'm superstitious... -pd */
1428 if (x[i] <= 32 || x[i] > 126)
1429 fprintf(fp, "\\%03o", (unsigned char) x[i]);
1430 else
1431 fputc(x[i], fp);
1432 }
1433 }
1434 }
1435
InStringAscii(FILE * fp,SaveLoadData * unused)1436 static char *InStringAscii(FILE *fp, SaveLoadData *unused)
1437 {
1438 static char *buf = NULL;
1439 static int buflen = 0;
1440 int c, d, i, j;
1441 int nbytes, res;
1442 res = fscanf(fp, "%d", &nbytes);
1443 if(res != 1) error(_("read error"));
1444 /* FIXME : Ultimately we need to replace */
1445 /* this with a real string allocation. */
1446 /* All buffers must die! */
1447 if (nbytes >= buflen) {
1448 char *newbuf;
1449 /* Protect against broken realloc */
1450 if(buf) newbuf = (char *) realloc(buf, nbytes + 1);
1451 else newbuf = (char *) malloc(nbytes + 1);
1452 if (newbuf == NULL) /* buf remains allocated */
1453 error(_("out of memory reading ascii string"));
1454 buf = newbuf;
1455 buflen = nbytes + 1;
1456 }
1457 while(isspace(c = fgetc(fp)))
1458 ;
1459 ungetc(c, fp);
1460 for (i = 0; i < nbytes; i++) {
1461 if ((c = fgetc(fp)) == '\\') {
1462 switch(c = fgetc(fp)) {
1463 case 'n' : buf[i] = '\n'; break;
1464 case 't' : buf[i] = '\t'; break;
1465 case 'v' : buf[i] = '\v'; break;
1466 case 'b' : buf[i] = '\b'; break;
1467 case 'r' : buf[i] = '\r'; break;
1468 case 'f' : buf[i] = '\f'; break;
1469 case 'a' : buf[i] = '\a'; break;
1470 case '\\': buf[i] = '\\'; break;
1471 case '?' : buf[i] = '\?'; break;
1472 case '\'': buf[i] = '\''; break;
1473 case '\"': buf[i] = '\"'; break;
1474 case '0': case '1': case '2': case '3':
1475 case '4': case '5': case '6': case '7':
1476 d = 0; j = 0;
1477 while('0' <= c && c < '8' && j < 3) {
1478 d = d * 8 + (c - '0');
1479 c = fgetc(fp);
1480 j++;
1481 }
1482 buf[i] = (char) d;
1483 ungetc(c, fp);
1484 break;
1485 default : buf[i] = (char) c;
1486 }
1487 }
1488 else buf[i] = (char) c;
1489 }
1490 buf[i] = '\0';
1491 return buf;
1492 }
1493
OutDoubleAscii(FILE * fp,double x,SaveLoadData * unused)1494 static void OutDoubleAscii(FILE *fp, double x, SaveLoadData *unused)
1495 {
1496 if (!R_FINITE(x)) {
1497 if (ISNAN(x)) fprintf(fp, "NA");
1498 else if (x < 0) fprintf(fp, "-Inf");
1499 else fprintf(fp, "Inf");
1500 }
1501 /* 16: full precision; 17 gives 999, 000 &c */
1502 else fprintf(fp, "%.16g", x);
1503 }
1504
InDoubleAscii(FILE * fp,SaveLoadData * unused)1505 static double InDoubleAscii(FILE *fp, SaveLoadData *unused)
1506 {
1507 char buf[128];
1508 double x;
1509 int res;
1510 res = fscanf(fp, "%127s", buf);
1511 if(res != 1) error(_("read error"));
1512 if (strcmp(buf, "NA") == 0)
1513 x = NA_REAL;
1514 else if (strcmp(buf, "Inf") == 0)
1515 x = R_PosInf;
1516 else if (strcmp(buf, "-Inf") == 0)
1517 x = R_NegInf;
1518 else {
1519 res = sscanf(buf, "%lg", &x);
1520 if(res != 1) error(_("read error"));
1521 }
1522 return x;
1523 }
1524
OutComplexAscii(FILE * fp,Rcomplex x,SaveLoadData * unused)1525 static void OutComplexAscii(FILE *fp, Rcomplex x, SaveLoadData *unused)
1526 {
1527 if (ISNAN(x.r) || ISNAN(x.i))
1528 fprintf(fp, "NA NA");
1529 else {
1530 OutDoubleAscii(fp, x.r, unused);
1531 OutSpaceAscii(fp, 1, unused);
1532 OutDoubleAscii(fp, x.i, unused);
1533 }
1534 }
1535
InComplexAscii(FILE * fp,SaveLoadData * unused)1536 static Rcomplex InComplexAscii(FILE *fp, SaveLoadData *unused)
1537 {
1538 Rcomplex x;
1539 x.r = InDoubleAscii(fp, unused);
1540 x.i = InDoubleAscii(fp, unused);
1541 return x;
1542 }
1543
NewAsciiSave(SEXP s,FILE * fp,SaveLoadData * d)1544 static void NewAsciiSave(SEXP s, FILE *fp, SaveLoadData *d)
1545 {
1546 OutputRoutines m;
1547
1548 m.OutInit = DummyInit;
1549 m.OutInteger = OutIntegerAscii;
1550 m.OutReal = OutDoubleAscii;
1551 m.OutComplex = OutComplexAscii;
1552 m.OutString = OutStringAscii;
1553 m.OutSpace = OutSpaceAscii;
1554 m.OutNewline = OutNewlineAscii;
1555 m.OutTerm = DummyTerm;
1556 NewDataSave(s, fp, &m, d);
1557 }
1558
NewAsciiLoad(FILE * fp,SaveLoadData * d)1559 static SEXP NewAsciiLoad(FILE *fp, SaveLoadData *d)
1560 {
1561 InputRoutines m;
1562
1563 m.InInit = DummyInit;
1564 m.InInteger = InIntegerAscii;
1565 m.InReal = InDoubleAscii;
1566 m.InComplex = InComplexAscii;
1567 m.InString = InStringAscii;
1568 m.InTerm = DummyTerm;
1569 return NewDataLoad(fp, &m, d);
1570 }
1571
1572 /* ----- L o w l e v e l -- B i n a r y -- I / O ----- */
1573
InIntegerBinary(FILE * fp,SaveLoadData * unused)1574 static int InIntegerBinary(FILE * fp, SaveLoadData *unused)
1575 {
1576 int i;
1577 if (fread(&i, sizeof(int), 1, fp) != 1)
1578 error(_("a binary read error occurred"));
1579 return i;
1580 }
1581
InStringBinary(FILE * fp,SaveLoadData * unused)1582 static char *InStringBinary(FILE *fp, SaveLoadData *unused)
1583 {
1584 static char *buf = NULL;
1585 static int buflen = 0;
1586 int nbytes = InIntegerBinary(fp, unused);
1587 if (nbytes >= buflen) {
1588 char *newbuf;
1589 /* Protect against broken realloc */
1590 if(buf) newbuf = (char *) realloc(buf, nbytes + 1);
1591 else newbuf = (char *) malloc(nbytes + 1);
1592 if (newbuf == NULL)
1593 error(_("out of memory reading binary string"));
1594 buf = newbuf;
1595 buflen = nbytes + 1;
1596 }
1597 if (fread(buf, sizeof(char), nbytes, fp) != nbytes)
1598 error(_("a binary string read error occurred"));
1599 buf[nbytes] = '\0';
1600 return buf;
1601 }
1602
InRealBinary(FILE * fp,SaveLoadData * unused)1603 static double InRealBinary(FILE * fp, SaveLoadData *unused)
1604 {
1605 double x;
1606 if (fread(&x, sizeof(double), 1, fp) != 1)
1607 error(_("a read error occurred"));
1608 return x;
1609 }
1610
InComplexBinary(FILE * fp,SaveLoadData * unused)1611 static Rcomplex InComplexBinary(FILE * fp, SaveLoadData *unused)
1612 {
1613 Rcomplex x;
1614 if (fread(&x, sizeof(Rcomplex), 1, fp) != 1)
1615 error(_("a read error occurred"));
1616 return x;
1617 }
1618
NewBinaryLoad(FILE * fp,SaveLoadData * d)1619 static SEXP NewBinaryLoad(FILE *fp, SaveLoadData *d)
1620 {
1621 InputRoutines m;
1622
1623 m.InInit = DummyInit;
1624 m.InInteger = InIntegerBinary;
1625 m.InReal = InRealBinary;
1626 m.InComplex = InComplexBinary;
1627 m.InString = InStringBinary;
1628 m.InTerm = DummyTerm;
1629 return NewDataLoad(fp, &m, d);
1630 }
1631
1632
1633 /* ----- L o w l e v e l -- X D R -- I / O ----- */
1634
InInitXdr(FILE * fp,SaveLoadData * d)1635 static void InInitXdr(FILE *fp, SaveLoadData *d)
1636 {
1637 xdrstdio_create(&d->xdrs, fp, XDR_DECODE);
1638 }
1639
OutInitXdr(FILE * fp,SaveLoadData * d)1640 static void OutInitXdr(FILE *fp, SaveLoadData *d)
1641 {
1642 xdrstdio_create(&d->xdrs, fp, XDR_ENCODE);
1643 }
1644
InTermXdr(FILE * fp,SaveLoadData * d)1645 static void InTermXdr(FILE *fp, SaveLoadData *d)
1646 {
1647 xdr_destroy(&d->xdrs);
1648 }
1649
OutTermXdr(FILE * fp,SaveLoadData * d)1650 static void OutTermXdr(FILE *fp, SaveLoadData *d)
1651 {
1652 xdr_destroy(&d->xdrs);
1653 }
1654
OutIntegerXdr(FILE * fp,int i,SaveLoadData * d)1655 static void OutIntegerXdr(FILE *fp, int i, SaveLoadData *d)
1656 {
1657 if (!xdr_int(&d->xdrs, &i))
1658 error(_("an xdr integer data write error occurred"));
1659 }
1660
InIntegerXdr(FILE * fp,SaveLoadData * d)1661 static int InIntegerXdr(FILE *fp, SaveLoadData *d)
1662 {
1663 int i;
1664 if (!xdr_int(&d->xdrs, &i))
1665 error(_("an xdr integer data read error occurred"));
1666 return i;
1667 }
1668
OutStringXdr(FILE * fp,const char * s,SaveLoadData * d)1669 static void OutStringXdr(FILE *fp, const char *s, SaveLoadData *d)
1670 {
1671 unsigned int n = (unsigned int) strlen(s);
1672 char *t = CallocCharBuf(n);
1673 bool_t res;
1674 /* This copy may not be needed, will xdr_bytes ever modify 2nd arg? */
1675 strcpy(t, s);
1676 OutIntegerXdr(fp, n, d);
1677 res = xdr_bytes(&d->xdrs, &t, &n, n);
1678 Free(t);
1679 if (!res)
1680 error(_("an xdr string data write error occurred"));
1681 }
1682
InStringXdr(FILE * fp,SaveLoadData * d)1683 static char *InStringXdr(FILE *fp, SaveLoadData *d)
1684 {
1685 static char *buf = NULL;
1686 static int buflen = 0;
1687 unsigned int nbytes = InIntegerXdr(fp, d);
1688 if (nbytes >= buflen) {
1689 char *newbuf;
1690 /* Protect against broken realloc */
1691 if(buf) newbuf = (char *) realloc(buf, nbytes + 1);
1692 else newbuf = (char *) malloc(nbytes + 1);
1693 if (newbuf == NULL)
1694 error(_("out of memory reading binary string"));
1695 buf = newbuf;
1696 buflen = nbytes + 1;
1697 }
1698 if (!xdr_bytes(&d->xdrs, &buf, &nbytes, nbytes))
1699 error(_("an xdr string data write error occurred"));
1700 buf[nbytes] = '\0';
1701 return buf;
1702 }
1703
OutRealXdr(FILE * fp,double x,SaveLoadData * d)1704 static void OutRealXdr(FILE *fp, double x, SaveLoadData *d)
1705 {
1706 if (!xdr_double(&d->xdrs, &x))
1707 error(_("an xdr real data write error occurred"));
1708 }
1709
InRealXdr(FILE * fp,SaveLoadData * d)1710 static double InRealXdr(FILE * fp, SaveLoadData *d)
1711 {
1712 double x;
1713 if (!xdr_double(&d->xdrs, &x))
1714 error(_("an xdr real data read error occurred"));
1715 return x;
1716 }
1717
OutComplexXdr(FILE * fp,Rcomplex x,SaveLoadData * d)1718 static void OutComplexXdr(FILE *fp, Rcomplex x, SaveLoadData *d)
1719 {
1720 if (!xdr_double(&d->xdrs, &(x.r)) || !xdr_double(&d->xdrs, &(x.i)))
1721 error(_("an xdr complex data write error occurred"));
1722 }
1723
InComplexXdr(FILE * fp,SaveLoadData * d)1724 static Rcomplex InComplexXdr(FILE * fp, SaveLoadData *d)
1725 {
1726 Rcomplex x;
1727 if (!xdr_double(&d->xdrs, &(x.r)) || !xdr_double(&d->xdrs, &(x.i)))
1728 error(_("an xdr complex data read error occurred"));
1729 return x;
1730 }
1731
NewXdrSave(SEXP s,FILE * fp,SaveLoadData * d)1732 static void NewXdrSave(SEXP s, FILE *fp, SaveLoadData *d)
1733 {
1734 OutputRoutines m;
1735
1736 m.OutInit = OutInitXdr;
1737 m.OutInteger = OutIntegerXdr;
1738 m.OutReal = OutRealXdr;
1739 m.OutComplex = OutComplexXdr;
1740 m.OutString = OutStringXdr;
1741 m.OutSpace = DummyOutSpace;
1742 m.OutNewline = DummyOutNewline;
1743 m.OutTerm = OutTermXdr;
1744 NewDataSave(s, fp, &m, d);
1745 }
1746
NewXdrLoad(FILE * fp,SaveLoadData * d)1747 static SEXP NewXdrLoad(FILE *fp, SaveLoadData *d)
1748 {
1749 InputRoutines m;
1750
1751 m.InInit = InInitXdr;
1752 m.InInteger = InIntegerXdr;
1753 m.InReal = InRealXdr;
1754 m.InComplex = InComplexXdr;
1755 m.InString = InStringXdr;
1756 m.InTerm = InTermXdr;
1757 return NewDataLoad(fp, &m, d);
1758 }
1759
1760
1761 /* ----- F i l e -- M a g i c -- N u m b e r s ----- */
1762
R_WriteMagic(FILE * fp,int number)1763 static void R_WriteMagic(FILE *fp, int number)
1764 {
1765 unsigned char buf[5];
1766 size_t res;
1767
1768 number = abs(number);
1769 switch (number) {
1770 case R_MAGIC_ASCII_V1: /* Version 1 - R Data, ASCII Format */
1771 strcpy((char*)buf, "RDA1");
1772 break;
1773 case R_MAGIC_BINARY_V1: /* Version 1 - R Data, Binary Format */
1774 strcpy((char*)buf, "RDB1");
1775 break;
1776 case R_MAGIC_XDR_V1: /* Version 1 - R Data, XDR Binary Format */
1777 strcpy((char*)buf, "RDX1");
1778 break;
1779 case R_MAGIC_ASCII_V2: /* Version 2 - R Data, ASCII Format */
1780 strcpy((char*)buf, "RDA2");
1781 break;
1782 case R_MAGIC_BINARY_V2: /* Version 2 - R Data, Binary Format */
1783 strcpy((char*)buf, "RDB2");
1784 break;
1785 case R_MAGIC_XDR_V2: /* Version 2 - R Data, XDR Binary Format */
1786 strcpy((char*)buf, "RDX2");
1787 break;
1788 case R_MAGIC_ASCII_V3: /* Version >=3 - R Data, ASCII Format */
1789 strcpy((char*)buf, "RDA3");
1790 break;
1791 case R_MAGIC_BINARY_V3: /* Version >=3 - R Data, Binary Format */
1792 strcpy((char*)buf, "RDB3");
1793 break;
1794 case R_MAGIC_XDR_V3: /* Version >=3 - R Data, XDR Binary Format */
1795 strcpy((char*)buf, "RDX3");
1796 break;
1797 default:
1798 buf[0] = (unsigned char)((number/1000) % 10 + '0');
1799 buf[1] = (unsigned char)((number/100) % 10 + '0');
1800 buf[2] = (unsigned char)((number/10) % 10 + '0');
1801 buf[3] = (unsigned char)(number % 10 + '0');
1802 }
1803 buf[4] = '\n';
1804 res = fwrite((char*)buf, sizeof(char), 5, fp);
1805 if(res != 5) error(_("write failed"));
1806 }
1807
R_ReadMagic(FILE * fp)1808 static int R_ReadMagic(FILE *fp)
1809 {
1810 unsigned char buf[6];
1811 int d1, d2, d3, d4;
1812 size_t count;
1813
1814 count = fread((char*)buf, sizeof(char), 5, fp);
1815 if (count != 5) {
1816 if (count == 0)
1817 return R_MAGIC_EMPTY;
1818 else
1819 return R_MAGIC_CORRUPT;
1820 }
1821
1822 if (strncmp((char*)buf, "RDA1\n", 5) == 0) {
1823 return R_MAGIC_ASCII_V1;
1824 }
1825 else if (strncmp((char*)buf, "RDB1\n", 5) == 0) {
1826 return R_MAGIC_BINARY_V1;
1827 }
1828 else if (strncmp((char*)buf, "RDX1\n", 5) == 0) {
1829 return R_MAGIC_XDR_V1;
1830 }
1831 if (strncmp((char*)buf, "RDA2\n", 5) == 0) {
1832 return R_MAGIC_ASCII_V2;
1833 }
1834 else if (strncmp((char*)buf, "RDB2\n", 5) == 0) {
1835 return R_MAGIC_BINARY_V2;
1836 }
1837 else if (strncmp((char*)buf, "RDX2\n", 5) == 0) {
1838 return R_MAGIC_XDR_V2;
1839 }
1840 if (strncmp((char*)buf, "RDA3\n", 5) == 0) {
1841 return R_MAGIC_ASCII_V3;
1842 }
1843 else if (strncmp((char*)buf, "RDB3\n", 5) == 0) {
1844 return R_MAGIC_BINARY_V3;
1845 }
1846 else if (strncmp((char*)buf, "RDX3\n", 5) == 0) {
1847 return R_MAGIC_XDR_V3;
1848 }
1849 else if (strncmp((char *)buf, "RD", 2) == 0)
1850 return R_MAGIC_MAYBE_TOONEW;
1851
1852 /* Intel gcc seems to screw up a single expression here */
1853 d1 = (buf[3]-'0') % 10;
1854 d2 = (buf[2]-'0') % 10;
1855 d3 = (buf[1]-'0') % 10;
1856 d4 = (buf[0]-'0') % 10;
1857 return d1 + 10 * d2 + 100 * d3 + 1000 * d4;
1858 }
1859
defaultSaveVersion()1860 static int defaultSaveVersion()
1861 {
1862 static int dflt = -1;
1863
1864 if (dflt < 0) {
1865 char *valstr = getenv("R_DEFAULT_SAVE_VERSION");
1866 int val = -1;
1867 if (valstr != NULL)
1868 val = atoi(valstr);
1869 if (val == 2 || val == 3)
1870 dflt = val;
1871 else
1872 dflt = 3; /* the default */
1873 }
1874 return dflt;
1875 }
1876
1877 /* ----- E x t e r n a l -- I n t e r f a c e s ----- */
1878
R_SaveToFileV(SEXP obj,FILE * fp,int ascii,int version)1879 void attribute_hidden R_SaveToFileV(SEXP obj, FILE *fp, int ascii, int version)
1880 {
1881 SaveLoadData data = {{NULL, 0, MAXELTSIZE}};
1882
1883 if (version == 1) {
1884 if (ascii) {
1885 R_WriteMagic(fp, R_MAGIC_ASCII_V1);
1886 NewAsciiSave(obj, fp, &data);
1887 } else {
1888 R_WriteMagic(fp, R_MAGIC_XDR_V1);
1889 NewXdrSave(obj, fp, &data);
1890 }
1891 }
1892 else {
1893 struct R_outpstream_st out;
1894 R_pstream_format_t type;
1895 int magic;
1896
1897 /* version == 0 means default version */
1898 int v = (version == 0) ? defaultSaveVersion() : version;
1899 if (ascii) {
1900 magic = (v == 2) ? R_MAGIC_ASCII_V2 : R_MAGIC_ASCII_V3;
1901 type = R_pstream_ascii_format;
1902 }
1903 else {
1904 magic = (v == 2) ? R_MAGIC_XDR_V2 : R_MAGIC_XDR_V3;
1905 type = R_pstream_xdr_format;
1906 }
1907 R_WriteMagic(fp, magic);
1908 /* version == 0 means defaultSerializeVersion()
1909 unsupported version will result in error */
1910 R_InitFileOutPStream(&out, fp, type, version, NULL, NULL);
1911 R_Serialize(obj, &out);
1912 }
1913 }
1914
R_SaveToFile(SEXP obj,FILE * fp,int ascii)1915 void attribute_hidden R_SaveToFile(SEXP obj, FILE *fp, int ascii)
1916 {
1917 R_SaveToFileV(obj, fp, ascii, defaultSaveVersion());
1918 }
1919
1920 /* different handling of errors */
1921
1922 #define return_and_free(X) {r = X; R_FreeStringBuffer(&data.buffer); return r;}
R_LoadFromFile(FILE * fp,int startup)1923 SEXP attribute_hidden R_LoadFromFile(FILE *fp, int startup)
1924 {
1925 struct R_inpstream_st in;
1926 int magic;
1927 SaveLoadData data = {{NULL, 0, MAXELTSIZE}};
1928 SEXP r;
1929
1930 magic = R_ReadMagic(fp);
1931 switch(magic) {
1932 case R_MAGIC_XDR:
1933 return_and_free(XdrLoad(fp, startup, &data));
1934 case R_MAGIC_BINARY:
1935 return_and_free(BinaryLoad(fp, startup, &data));
1936 case R_MAGIC_ASCII:
1937 return_and_free(AsciiLoad(fp, startup, &data));
1938 case R_MAGIC_BINARY_VERSION16:
1939 return_and_free(BinaryLoadOld(fp, 16, startup, &data));
1940 case R_MAGIC_ASCII_VERSION16:
1941 return_and_free(AsciiLoadOld(fp, 16, startup, &data));
1942 case R_MAGIC_ASCII_V1:
1943 return_and_free(NewAsciiLoad(fp, &data));
1944 case R_MAGIC_BINARY_V1:
1945 return_and_free(NewBinaryLoad(fp, &data));
1946 case R_MAGIC_XDR_V1:
1947 return_and_free(NewXdrLoad(fp, &data));
1948 case R_MAGIC_ASCII_V2:
1949 case R_MAGIC_ASCII_V3:
1950 R_InitFileInPStream(&in, fp, R_pstream_ascii_format, NULL, NULL);
1951 return_and_free(R_Unserialize(&in));
1952 case R_MAGIC_BINARY_V2:
1953 case R_MAGIC_BINARY_V3:
1954 R_InitFileInPStream(&in, fp, R_pstream_binary_format, NULL, NULL);
1955 return_and_free(R_Unserialize(&in));
1956 case R_MAGIC_XDR_V2:
1957 case R_MAGIC_XDR_V3:
1958 R_InitFileInPStream(&in, fp, R_pstream_xdr_format, NULL, NULL);
1959 return_and_free(R_Unserialize(&in));
1960 default:
1961 R_FreeStringBuffer(&data.buffer);
1962 switch (magic) {
1963 case R_MAGIC_EMPTY:
1964 error(_("restore file may be empty -- no data loaded"));
1965 case R_MAGIC_MAYBE_TOONEW:
1966 error(_("restore file may be from a newer version of R -- no data loaded"));
1967 default:
1968 error(_("bad restore file magic number (file may be corrupted) -- no data loaded"));
1969 }
1970 return(R_NilValue);/* for -Wall */
1971 }
1972 }
1973
do_loadfile(SEXP call,SEXP op,SEXP args,SEXP env)1974 SEXP attribute_hidden do_loadfile(SEXP call, SEXP op, SEXP args, SEXP env)
1975 {
1976 SEXP file, s;
1977 FILE *fp;
1978
1979 checkArity(op, args);
1980
1981 PROTECT(file = coerceVector(CAR(args), STRSXP));
1982
1983 if (! isValidStringF(file))
1984 error(_("bad file name"));
1985
1986 fp = RC_fopen(STRING_ELT(file, 0), "rb", TRUE);
1987 if (!fp)
1988 error(_("unable to open 'file'"));
1989 s = R_LoadFromFile(fp, 0);
1990 fclose(fp);
1991
1992 UNPROTECT(1);
1993 return s;
1994 }
1995
do_savefile(SEXP call,SEXP op,SEXP args,SEXP env)1996 SEXP attribute_hidden do_savefile(SEXP call, SEXP op, SEXP args, SEXP env)
1997 {
1998 FILE *fp;
1999 int version;
2000
2001 checkArity(op, args);
2002
2003 if (!isValidStringF(CADR(args)))
2004 error(_("'file' must be non-empty string"));
2005 if (TYPEOF(CADDR(args)) != LGLSXP)
2006 error(_("'ascii' must be logical"));
2007 if (CADDDR(args) == R_NilValue)
2008 version = defaultSaveVersion();
2009 else
2010 version = asInteger(CADDDR(args));
2011 if (version == NA_INTEGER || version <= 0)
2012 error(_("invalid '%s' argument"), "version");
2013
2014 fp = RC_fopen(STRING_ELT(CADR(args), 0), "wb", TRUE);
2015 if (!fp)
2016 error(_("unable to open 'file'"));
2017
2018 R_SaveToFileV(CAR(args), fp, INTEGER(CADDR(args))[0], version);
2019
2020 fclose(fp);
2021 return R_NilValue;
2022 }
2023
saveload_cleanup(void * data)2024 static void saveload_cleanup(void *data)
2025 {
2026 FILE *fp = (FILE *) data;
2027 fclose(fp);
2028 }
2029
2030 /* Only used for version 1 saves */
do_save(SEXP call,SEXP op,SEXP args,SEXP env)2031 SEXP attribute_hidden do_save(SEXP call, SEXP op, SEXP args, SEXP env)
2032 {
2033 /* save(list, file, ascii, version, environment) */
2034
2035 SEXP s, t, source, tmp;
2036 int len, j, version, ep;
2037 FILE *fp;
2038 RCNTXT cntxt;
2039
2040 checkArity(op, args);
2041
2042
2043 if (TYPEOF(CAR(args)) != STRSXP)
2044 error(_("first argument must be a character vector"));
2045 if (!isValidStringF(CADR(args)))
2046 error(_("'file' must be non-empty string"));
2047 if (TYPEOF(CADDR(args)) != LGLSXP)
2048 error(_("'ascii' must be logical"));
2049 if (CADDDR(args) == R_NilValue)
2050 version = defaultSaveVersion();
2051 else
2052 version = asInteger(CADDDR(args));
2053 if (version == NA_INTEGER || version <= 0)
2054 error(_("invalid '%s' argument"), "version");
2055 source = CAR(nthcdr(args,4));
2056 if (source != R_NilValue && TYPEOF(source) != ENVSXP)
2057 error(_("invalid '%s' argument"), "environment");
2058 ep = asLogical(CAR(nthcdr(args,5)));
2059 if (ep == NA_LOGICAL)
2060 error(_("invalid '%s' argument"), "eval.promises");
2061
2062 fp = RC_fopen(STRING_ELT(CADR(args), 0), "wb", TRUE);
2063 if (!fp) {
2064 const char *cfile = CHAR(STRING_ELT(CADR(args), 0));
2065 error(_("cannot open file '%s': %s"), cfile, strerror(errno));
2066 }
2067
2068 /* set up a context which will close the file if there is an error */
2069 begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
2070 R_NilValue, R_NilValue);
2071 cntxt.cend = &saveload_cleanup;
2072 cntxt.cenddata = fp;
2073
2074 len = length(CAR(args));
2075 PROTECT(s = allocList(len));
2076
2077 t = s;
2078 for (j = 0; j < len; j++, t = CDR(t)) {
2079 SET_TAG(t, installTrChar(STRING_ELT(CAR(args), j)));
2080 tmp = findVar(TAG(t), source);
2081 if (tmp == R_UnboundValue)
2082 error(_("object '%s' not found"), EncodeChar(PRINTNAME(TAG(t))));
2083 if(ep && TYPEOF(tmp) == PROMSXP) {
2084 PROTECT(tmp);
2085 tmp = eval(tmp, source);
2086 UNPROTECT(1);
2087 }
2088 SETCAR(t, tmp);
2089 }
2090
2091 R_SaveToFileV(s, fp, INTEGER(CADDR(args))[0], version);
2092
2093 UNPROTECT(1);
2094 /* end the context after anything that could raise an error but before
2095 closing the file so it doesn't get done twice */
2096 endcontext(&cntxt);
2097 fclose(fp);
2098 return R_NilValue;
2099 }
2100
RestoreToEnv(SEXP ans,SEXP aenv)2101 static SEXP RestoreToEnv(SEXP ans, SEXP aenv)
2102 {
2103 SEXP a, names, obj;
2104 int cnt = 0;
2105 /* Store the components of the list in aenv. We either replace
2106 * the existing objects in aenv or establish new bindings for
2107 * them.
2108 */
2109
2110 /* allow ans to be a vector-style list */
2111 if (TYPEOF(ans) == VECSXP) {
2112 int i;
2113 PROTECT(ans);
2114 PROTECT(names = getAttrib(ans, R_NamesSymbol)); /* PROTECT needed?? */
2115 if (TYPEOF(names) != STRSXP || LENGTH(names) != LENGTH(ans))
2116 error(_("not a valid named list"));
2117 for (i = 0; i < LENGTH(ans); i++) {
2118 SEXP sym = installTrChar(STRING_ELT(names, i));
2119 obj = VECTOR_ELT(ans, i);
2120 defineVar(sym, obj, aenv);
2121 if(R_seemsOldStyleS4Object(obj))
2122 warningcall(R_NilValue,
2123 _("'%s' looks like a pre-2.4.0 S4 object: please recreate it"),
2124 CHAR(STRING_ELT(names, i)));
2125 }
2126 UNPROTECT(2);
2127 return names;
2128 }
2129
2130 if (! isList(ans))
2131 error(_("loaded data is not in pair list form"));
2132
2133 PROTECT(ans);
2134 a = ans;
2135 while (a != R_NilValue) {a = CDR(a); cnt++;}
2136 PROTECT(names = allocVector(STRSXP, cnt));
2137 cnt = 0;
2138 a = ans;
2139 while (a != R_NilValue) {
2140 SET_STRING_ELT(names, cnt++, PRINTNAME(TAG(a)));
2141 defineVar(TAG(a), CAR(a), aenv);
2142 if(R_seemsOldStyleS4Object(CAR(a)))
2143 warningcall(R_NilValue,
2144 _("'%s' looks like a pre-2.4.0 S4 object: please recreate it"),
2145 CHAR(PRINTNAME(TAG(a))));
2146 a = CDR(a);
2147 }
2148 UNPROTECT(2);
2149 return names;
2150 }
2151
R_LoadSavedData(FILE * fp,SEXP aenv)2152 static SEXP R_LoadSavedData(FILE *fp, SEXP aenv)
2153 {
2154 return RestoreToEnv(R_LoadFromFile(fp, 0), aenv);
2155 }
2156
2157 /* This is only used for version 1 or earlier formats */
do_load(SEXP call,SEXP op,SEXP args,SEXP env)2158 SEXP attribute_hidden do_load(SEXP call, SEXP op, SEXP args, SEXP env)
2159 {
2160 SEXP fname, aenv, val;
2161 FILE *fp;
2162 RCNTXT cntxt;
2163
2164 checkArity(op, args);
2165
2166 if (!isValidString(fname = CAR(args)))
2167 error(_("first argument must be a file name"));
2168
2169 /* GRW 1/26/99 GRW : added environment parameter so that */
2170 /* the loaded objects can be placed where desired */
2171
2172 aenv = CADR(args);
2173 if (TYPEOF(aenv) == NILSXP)
2174 error(_("use of NULL environment is defunct"));
2175 else if (TYPEOF(aenv) != ENVSXP)
2176 error(_("invalid '%s' argument"), "envir");
2177
2178 /* Process the saved file to obtain a list of saved objects. */
2179 fp = RC_fopen(STRING_ELT(fname, 0), "rb", TRUE);
2180 if (!fp) error(_("unable to open file"));
2181
2182 /* set up a context which will close the file if there is an error */
2183 begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
2184 R_NilValue, R_NilValue);
2185 cntxt.cend = &saveload_cleanup;
2186 cntxt.cenddata = fp;
2187
2188 PROTECT(val = R_LoadSavedData(fp, aenv));
2189
2190 /* end the context after anything that could raise an error but before
2191 closing the file so it doesn't get done twice */
2192 endcontext(&cntxt);
2193 fclose(fp);
2194 UNPROTECT(1);
2195 return val;
2196 }
2197
2198 /* defined in Rinternals.h
2199 #define R_XDR_DOUBLE_SIZE 8
2200 #define R_XDR_INTEGER_SIZE 4
2201 */
2202
R_XDREncodeDouble(double d,void * buf)2203 void attribute_hidden R_XDREncodeDouble(double d, void *buf)
2204 {
2205 XDR xdrs;
2206 int success;
2207
2208 xdrmem_create(&xdrs, (char *) buf, R_XDR_DOUBLE_SIZE, XDR_ENCODE);
2209 success = xdr_double(&xdrs, &d);
2210 xdr_destroy(&xdrs);
2211 if (! success)
2212 error(_("XDR write failed"));
2213 }
2214
R_XDRDecodeDouble(void * buf)2215 double attribute_hidden R_XDRDecodeDouble(void *buf)
2216 {
2217 XDR xdrs;
2218 double d;
2219 int success;
2220
2221 xdrmem_create(&xdrs, (char *) buf, R_XDR_DOUBLE_SIZE, XDR_DECODE);
2222 success = xdr_double(&xdrs, &d);
2223 xdr_destroy(&xdrs);
2224 if (! success)
2225 error(_("XDR read failed"));
2226 return d;
2227 }
2228
R_XDREncodeInteger(int i,void * buf)2229 void attribute_hidden R_XDREncodeInteger(int i, void *buf)
2230 {
2231 XDR xdrs;
2232 int success;
2233
2234 xdrmem_create(&xdrs, (char *) buf, R_XDR_INTEGER_SIZE, XDR_ENCODE);
2235 success = xdr_int(&xdrs, &i);
2236 xdr_destroy(&xdrs);
2237 if (! success)
2238 error(_("XDR write failed"));
2239 }
2240
R_XDRDecodeInteger(void * buf)2241 int attribute_hidden R_XDRDecodeInteger(void *buf)
2242 {
2243 XDR xdrs;
2244 int i, success;
2245
2246 xdrmem_create(&xdrs, (char *) buf, R_XDR_INTEGER_SIZE, XDR_DECODE);
2247 success = xdr_int(&xdrs, &i);
2248 xdr_destroy(&xdrs);
2249 if (! success)
2250 error(_("XDR read failed"));
2251 return i;
2252 }
2253
2254 /* Next two were used in gnomeGUI package, are in Rinterface.h */
R_SaveGlobalEnvToFile(const char * name)2255 void R_SaveGlobalEnvToFile(const char *name)
2256 {
2257 SEXP sym = install("sys.save.image");
2258 if (findVar(sym, R_GlobalEnv) == R_UnboundValue) { /* not a perfect test */
2259 FILE *fp = R_fopen(name, "wb"); /* binary file */
2260 if (!fp) {
2261 error(_("cannot save data -- unable to open '%s': %s"),
2262 name, strerror(errno));
2263 }
2264 R_SaveToFile(FRAME(R_GlobalEnv), fp, 0);
2265 fclose(fp);
2266 }
2267 else {
2268 SEXP args, call;
2269 args = LCONS(ScalarString(mkChar(name)), R_NilValue);
2270 PROTECT(call = LCONS(sym, args));
2271 eval(call, R_GlobalEnv);
2272 UNPROTECT(1);
2273 }
2274 }
2275
R_RestoreGlobalEnvFromFile(const char * name,Rboolean quiet)2276 void R_RestoreGlobalEnvFromFile(const char *name, Rboolean quiet)
2277 {
2278 SEXP sym = install("sys.load.image");
2279 if (findVar(sym, R_GlobalEnv) == R_UnboundValue) { /* not a perfect test */
2280 FILE *fp = R_fopen(name, "rb"); /* binary file */
2281 if(fp != NULL) {
2282 R_LoadSavedData(fp, R_GlobalEnv);
2283 if(! quiet)
2284 Rprintf("[Previously saved workspace restored]\n\n");
2285 fclose(fp);
2286 }
2287 }
2288 else {
2289 SEXP args, call, sQuiet;
2290 sQuiet = quiet ? mkTrue() : mkFalse();
2291 PROTECT(args = LCONS(sQuiet, R_NilValue));
2292 args = LCONS(ScalarString(mkChar(name)), args);
2293 PROTECT(call = LCONS(sym, args));
2294 eval(call, R_GlobalEnv);
2295 UNPROTECT(2);
2296 }
2297 }
2298
2299
2300 #include <Rconnections.h>
2301
con_cleanup(void * data)2302 static void con_cleanup(void *data)
2303 {
2304 Rconnection con = data;
2305 if(con->isopen) con->close(con);
2306 }
2307
2308
2309 /* Ideally it should be possible to do this entirely in R code with
2310 something like
2311
2312 magic <- if (ascii) "RDA3\n" else ...
2313 writeChar(magic, con, eos = NULL)
2314 val <- lapply(list, get, envir = envir)
2315 names(val) <- list
2316 invisible(serialize(val, con, ascii = ascii))
2317
2318 Unfortunately, this will result in too much duplication in the lapply
2319 (and any other way of doing this). Hence we need an internal version.
2320
2321 In case anyone wants to do this another way, in fact it is a
2322 pairlist of objects that is serialized, but RestoreToEnv copes
2323 with either a pairlist or list.
2324 */
2325
do_saveToConn(SEXP call,SEXP op,SEXP args,SEXP env)2326 SEXP attribute_hidden do_saveToConn(SEXP call, SEXP op, SEXP args, SEXP env)
2327 {
2328 /* saveToConn(list, conn, ascii, version, environment) */
2329
2330 SEXP s, t, source, list, tmp;
2331 Rboolean ascii, wasopen;
2332 int len, j, version, ep;
2333 Rconnection con;
2334 struct R_outpstream_st out;
2335 R_pstream_format_t type;
2336 char magic[6];
2337 RCNTXT cntxt;
2338
2339 checkArity(op, args);
2340
2341 if (TYPEOF(CAR(args)) != STRSXP)
2342 error(_("first argument must be a character vector"));
2343 list = CAR(args);
2344
2345 con = getConnection(asInteger(CADR(args)));
2346
2347 if (TYPEOF(CADDR(args)) != LGLSXP)
2348 error(_("'ascii' must be logical"));
2349 ascii = INTEGER(CADDR(args))[0];
2350
2351 if (CADDDR(args) == R_NilValue)
2352 version = defaultSaveVersion();
2353 else
2354 version = asInteger(CADDDR(args));
2355 if (version == NA_INTEGER || version <= 0)
2356 error(_("invalid '%s' argument"), "version");
2357 if (version < 2)
2358 error(_("cannot save to connections in version %d format"), version);
2359 source = CAR(nthcdr(args,4));
2360 if (source != R_NilValue && TYPEOF(source) != ENVSXP)
2361 error(_("invalid '%s' argument"), "environment");
2362 ep = asLogical(CAR(nthcdr(args,5)));
2363 if (ep == NA_LOGICAL)
2364 error(_("invalid '%s' argument"), "eval.promises");
2365
2366 wasopen = con->isopen;
2367 if(!wasopen) {
2368 char mode[5];
2369 strcpy(mode, con->mode);
2370 strcpy(con->mode, "wb");
2371 if(!con->open(con)) error(_("cannot open the connection"));
2372 strcpy(con->mode, mode);
2373 /* set up a context which will close the connection
2374 if there is an error */
2375 begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
2376 R_NilValue, R_NilValue);
2377 cntxt.cend = &con_cleanup;
2378 cntxt.cenddata = con;
2379 }
2380 if(!con->canwrite)
2381 error(_("connection not open for writing"));
2382
2383 strcpy(magic, "RD??\n");
2384 if (ascii) {
2385 magic[2] = 'A';
2386 type = (ascii == NA_LOGICAL) ?
2387 R_pstream_asciihex_format : R_pstream_ascii_format;
2388 }
2389 else {
2390 if (con->text)
2391 error(_("cannot save XDR format to a text-mode connection"));
2392 magic[2] = 'X';
2393 type = R_pstream_xdr_format;
2394 }
2395 /* if version is too high, R_Serialize will fail with error */
2396 magic[3] = (char)('0' + version);
2397
2398 if (con->text)
2399 Rconn_printf(con, "%s", magic);
2400 else {
2401 size_t len = strlen(magic);
2402 if (len != con->write(magic, 1, len, con))
2403 error(_("error writing to connection"));
2404 }
2405
2406 R_InitConnOutPStream(&out, con, type, version, NULL, NULL);
2407
2408 len = length(list);
2409 PROTECT(s = allocList(len));
2410
2411 t = s;
2412 for (j = 0; j < len; j++, t = CDR(t)) {
2413 SET_TAG(t, installTrChar(STRING_ELT(list, j)));
2414 SETCAR(t, findVar(TAG(t), source));
2415 tmp = findVar(TAG(t), source);
2416 if (tmp == R_UnboundValue)
2417 error(_("object '%s' not found"), EncodeChar(PRINTNAME(TAG(t))));
2418 if(ep && TYPEOF(tmp) == PROMSXP) {
2419 PROTECT(tmp);
2420 tmp = eval(tmp, source);
2421 UNPROTECT(1);
2422 }
2423 SETCAR(t, tmp);
2424 }
2425
2426 R_Serialize(s, &out);
2427 if (!wasopen) con->close(con);
2428 UNPROTECT(1);
2429 return R_NilValue;
2430 }
2431
2432 /* Read and checks the magic number, open the connection if needed */
2433
do_loadFromConn2(SEXP call,SEXP op,SEXP args,SEXP env)2434 SEXP attribute_hidden do_loadFromConn2(SEXP call, SEXP op, SEXP args, SEXP env)
2435 {
2436 /* 0 .. loadFromConn2(conn, environment, verbose) */
2437 /* 1 .. loadInfoFromConn2(conn) */
2438
2439 struct R_inpstream_st in;
2440 Rconnection con;
2441 SEXP aenv = R_NilValue, res = R_NilValue;
2442 unsigned char buf[6];
2443 size_t count;
2444 Rboolean wasopen;
2445 RCNTXT cntxt;
2446
2447 checkArity(op, args);
2448
2449 con = getConnection(asInteger(CAR(args)));
2450
2451 wasopen = con->isopen;
2452 if(!wasopen) {
2453 char mode[5];
2454 strcpy(mode, con->mode);
2455 strcpy(con->mode, "rb");
2456 if(!con->open(con)) error(_("cannot open the connection"));
2457 strcpy(con->mode, mode);
2458 /* set up a context which will close the connection
2459 if there is an error */
2460 begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
2461 R_NilValue, R_NilValue);
2462 cntxt.cend = &con_cleanup;
2463 cntxt.cenddata = con;
2464 }
2465 if(!con->canread) error(_("connection not open for reading"));
2466 if(con->text) error(_("can only load() from a binary connection"));
2467
2468 if (PRIMVAL(op) == 0) {
2469 aenv = CADR(args);
2470 if (TYPEOF(aenv) == NILSXP)
2471 error(_("use of NULL environment is defunct"));
2472 else if (TYPEOF(aenv) != ENVSXP)
2473 error(_("invalid '%s' argument"), "envir");
2474 }
2475
2476 /* check magic */
2477 memset(buf, 0, 6);
2478 count = con->read(buf, sizeof(char), 5, con);
2479 if (count == 0) error(_("no input is available"));
2480 if (strncmp((char*)buf, "RDA2\n", 5) == 0 ||
2481 strncmp((char*)buf, "RDB2\n", 5) == 0 ||
2482 strncmp((char*)buf, "RDX2\n", 5) == 0 ||
2483 strncmp((char*)buf, "RDA3\n", 5) == 0 ||
2484 strncmp((char*)buf, "RDB3\n", 5) == 0 ||
2485 strncmp((char*)buf, "RDX3\n", 5) == 0) {
2486 R_InitConnInPStream(&in, con, R_pstream_any_format, NULL, NULL);
2487 if (PRIMVAL(op) == 0) {
2488 int old_InitReadItemDepth = R_InitReadItemDepth,
2489 old_ReadItemDepth = R_ReadItemDepth;
2490 R_InitReadItemDepth = R_ReadItemDepth = -asInteger(CADDR(args));
2491 res = RestoreToEnv(R_Unserialize(&in), aenv);
2492 R_InitReadItemDepth = old_InitReadItemDepth;
2493 R_ReadItemDepth = old_ReadItemDepth;
2494 } else
2495 res = R_SerializeInfo(&in);
2496 if(!wasopen) {
2497 /* PROTECT is paranoia: some close() method might allocate */
2498 PROTECT(res);
2499 endcontext(&cntxt);
2500 con->close(con);
2501 UNPROTECT(1);
2502 }
2503 } else
2504 error(_("the input does not start with a magic number compatible with loading from a connection"));
2505 return res;
2506 }
2507
2508