perl 5.0 alpha 3
[perl.git] / eval
1
2 void
3 save_lines(array, sv)
4 AV *array;
5 SV *sv;
6 {
7     register char *s = sv->sv_ptr;
8     register char *send = sv->sv_ptr + sv->sv_cur;
9     register char *t;
10     register int line = 1;
11
12     while (s && s < send) {
13         SV *tmpstr = NEWSV(85,0);
14
15         t = index(s, '\n');
16         if (t)
17             t++;
18         else
19             t = send;
20
21         sv_setpvn(tmpstr, s, t - s);
22         av_store(array, line++, tmpstr);
23         s = t;
24     }
25 }
26
27 int
28 do_eval(sv,optype,stash,savecmd,gimme,arglast)
29 SV *sv;
30 int optype;
31 HV *stash;
32 int savecmd;
33 int gimme;
34 int *arglast;
35 {
36     SV **st = stack->av_array;
37     int retval;
38     COP *myroot = Nullcop;
39     AV *ar;
40     int i;
41     COP * VOL oldcurcmd = curcmd;
42     VOL int oldtmps_floor = tmps_floor;
43     VOL int oldsave = savestack->av_fill;
44     VOL int oldperldb = perldb;
45     PM * VOL oldspat = curspat;
46     PM * VOL oldlspat = lastspat;
47
48     VOL int sp = arglast[0];
49     char *specfilename;
50     char *tmpfilename;
51     int parsing = 1;
52
53     tmps_floor = tmps_ix;
54     if (curstash != stash) {
55         (void)save_hptr(&curstash);
56         curstash = stash;
57     }
58     sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
59     if (curcmd->cop_line == 0)          /* don't debug debugger... */
60         perldb = FALSE;
61     curcmd = &compiling;
62     if (optype == OP_EVAL) {            /* normal oldeval */
63         curcmd->cop_filestab = gv_fetchfile("(oldeval)");
64         curcmd->cop_line = 1;
65         sv_setsv(linestr,sv);
66         sv_catpv(linestr,";\n;\n");     /* be kind to them */
67         if (perldb)
68             save_lines(GvAV(curcmd->cop_filestab), linestr);
69     }
70     else {
71         if (last_root && !in_eval) {
72             Safefree(last_eval);
73             last_eval = Nullch;
74             cop_free(last_root);
75             last_root = Nullcop;
76         }
77         specfilename = SvPV(sv);
78         sv_setpv(linestr,"");
79         if (optype == OP_REQUIRE && &sv_undef !=
80           hv_fetch(GvHVn(incstab), specfilename, strlen(specfilename), 0)) {
81             curcmd = oldcurcmd;
82             tmps_floor = oldtmps_floor;
83             st[++sp] = &sv_yes;
84             perldb = oldperldb;
85             return sp;
86         }
87         tmpfilename = savestr(specfilename);
88         if (*tmpfilename == '/' ||
89             (*tmpfilename == '.' && 
90                 (tmpfilename[1] == '/' ||
91                  (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
92         {
93             rsfp = fopen(tmpfilename,"r");
94         }
95         else {
96             ar = GvAVn(incstab);
97             for (i = 0; i <= ar->av_fill; i++) {
98                 (void)sprintf(buf, "%s/%s",
99                   SvPV(av_fetch(ar,i,TRUE)), specfilename);
100                 rsfp = fopen(buf,"r");
101                 if (rsfp) {
102                     char *s = buf;
103
104                     if (*s == '.' && s[1] == '/')
105                         s += 2;
106                     Safefree(tmpfilename);
107                     tmpfilename = savestr(s);
108                     break;
109                 }
110             }
111         }
112         curcmd->cop_filestab = gv_fetchfile(tmpfilename);
113         Safefree(tmpfilename);
114         tmpfilename = Nullch;
115         if (!rsfp) {
116             curcmd = oldcurcmd;
117             tmps_floor = oldtmps_floor;
118             if (optype == OP_REQUIRE) {
119                 sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
120                 if (instr(tokenbuf,".h "))
121                     strcat(tokenbuf," (change .h to .ph maybe?)");
122                 if (instr(tokenbuf,".ph "))
123                     strcat(tokenbuf," (did you run h2ph?)");
124                 fatal("%s",tokenbuf);
125             }
126             if (gimme != G_ARRAY)
127                 st[++sp] = &sv_undef;
128             perldb = oldperldb;
129             return sp;
130         }
131         curcmd->cop_line = 0;
132     }
133     in_eval++;
134     oldoldbufptr = oldbufptr = bufptr = SvPV(linestr);
135     bufend = bufptr + linestr->sv_cur;
136     if (++cxstack_ix >= block_max) {
137         block_max += 128;
138         Renew(block_stack, block_max, struct loop);
139     }
140     block_stack[cxstack_ix].block_label = "_EVAL_";
141     block_stack[cxstack_ix].block_sp = sp;
142 #ifdef DEBUGGING
143     if (debug & 4) {
144         deb("(Pushing label #%d _EVAL_)\n", cxstack_ix);
145     }
146 #endif
147     eval_root = Nullcop;
148     if (setjmp(block_stack[cxstack_ix].block_env)) {
149         retval = 1;
150     }
151     else {
152         error_count = 0;
153         if (rsfp) {
154             retval = yyparse();
155             retval |= error_count;
156         }
157         else if (last_root && last_elen == bufend - bufptr
158           && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
159             retval = 0;
160             eval_root = last_root;      /* no point in reparsing */
161         }
162         else if (in_eval == 1 && !savecmd) {
163             if (last_root) {
164                 Safefree(last_eval);
165                 last_eval = Nullch;
166                 cop_free(last_root);
167             }
168             last_root = Nullcop;
169             last_elen = bufend - bufptr;
170             last_eval = nsavestr(bufptr, last_elen);
171             retval = yyparse();
172             retval |= error_count;
173             if (!retval)
174                 last_root = eval_root;
175             if (!last_root) {
176                 Safefree(last_eval);
177                 last_eval = Nullch;
178             }
179         }
180         else
181             retval = yyparse();
182     }
183     myroot = eval_root;         /* in case cop_exec does another oldeval! */
184
185     if (retval || error_count) {
186         st = stack->av_array;
187         sp = arglast[0];
188         if (gimme != G_ARRAY)
189             st[++sp] = &sv_undef;
190         if (parsing) {
191 #ifndef MANGLEDPARSE
192 #ifdef DEBUGGING
193             if (debug & 128)
194                 fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
195 #endif
196             cop_free(eval_root);
197 #endif
198             /*SUPPRESS 29*/ /*SUPPRESS 30*/
199             if ((COP*)eval_root == last_root)
200                 last_root = Nullcop;
201             eval_root = myroot = Nullcop;
202         }
203         if (rsfp) {
204             fclose(rsfp);
205             rsfp = 0;
206         }
207     }
208     else {
209         parsing = 0;
210         sp = cop_exec(eval_root,gimme,sp);
211         st = stack->av_array;
212         for (i = arglast[0] + 1; i <= sp; i++)
213             st[i] = sv_mortalcopy(st[i]);
214                                 /* if we don't save result, free zaps it */
215         if (savecmd)
216             eval_root = myroot;
217         else if (in_eval != 1 && myroot != last_root)
218             cop_free(myroot);
219     }
220
221     perldb = oldperldb;
222     in_eval--;
223 #ifdef DEBUGGING
224     if (debug & 4) {
225         char *tmps = block_stack[cxstack_ix].block_label;
226         deb("(Popping label #%d %s)\n",cxstack_ix,
227             tmps ? tmps : "" );
228     }
229 #endif
230     cxstack_ix--;
231     tmps_floor = oldtmps_floor;
232     curspat = oldspat;
233     lastspat = oldlspat;
234     if (savestack->av_fill > oldsave)   /* let them use local() */
235         leave_scope(oldsave);
236
237     if (optype != OP_EVAL) {
238         if (retval) {
239             if (optype == OP_REQUIRE)
240                 fatal("%s", SvPV(GvSV(gv_fetchpv("@",TRUE))));
241         }
242         else {
243             curcmd = oldcurcmd;
244             if (gimme == G_SCALAR ? SvTRUE(st[sp]) : sp > arglast[0]) {
245                 (void)hv_store(GvHVn(incstab), specfilename,
246                   strlen(specfilename), newSVsv(GvSV(curcmd->cop_filestab)),
247                       0 );
248             }
249             else if (optype == OP_REQUIRE)
250                 fatal("%s did not return a true value", specfilename);
251         }
252     }
253     curcmd = oldcurcmd;
254     return sp;
255 }
256
257 int
258 do_try(cmd,gimme,arglast)
259 COP *cmd;
260 int gimme;
261 int *arglast;
262 {
263     SV **st = stack->av_array;
264
265     COP * VOL oldcurcmd = curcmd;
266     VOL int oldtmps_floor = tmps_floor;
267     VOL int oldsave = savestack->av_fill;
268     PM * VOL oldspat = curspat;
269     PM * VOL oldlspat = lastspat;
270     VOL int sp = arglast[0];
271
272     tmps_floor = tmps_ix;
273     sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
274     in_eval++;
275     if (++cxstack_ix >= block_max) {
276         block_max += 128;
277         Renew(block_stack, block_max, struct loop);
278     }
279     block_stack[cxstack_ix].block_label = "_EVAL_";
280     block_stack[cxstack_ix].block_sp = sp;
281 #ifdef DEBUGGING
282     if (debug & 4) {
283         deb("(Pushing label #%d _EVAL_)\n", cxstack_ix);
284     }
285 #endif
286     if (setjmp(block_stack[cxstack_ix].block_env)) {
287         st = stack->av_array;
288         sp = arglast[0];
289         if (gimme != G_ARRAY)
290             st[++sp] = &sv_undef;
291     }
292     else {
293         sp = cop_exec(cmd,gimme,sp);
294         st = stack->av_array;
295 /*      for (i = arglast[0] + 1; i <= sp; i++)
296             st[i] = sv_mortalcopy(st[i]);  not needed, I think */
297                                 /* if we don't save result, free zaps it */
298     }
299
300     in_eval--;
301 #ifdef DEBUGGING
302     if (debug & 4) {
303         char *tmps = block_stack[cxstack_ix].block_label;
304         deb("(Popping label #%d %s)\n",cxstack_ix,
305             tmps ? tmps : "" );
306     }
307 #endif
308     cxstack_ix--;
309     tmps_floor = oldtmps_floor;
310     curspat = oldspat;
311     lastspat = oldlspat;
312     curcmd = oldcurcmd;
313     if (savestack->av_fill > oldsave)   /* let them use local() */
314         leave_scope(oldsave);
315
316     return sp;
317 }
318