1 |
/* pp_ctl.c |
2 |
* |
3 |
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, |
4 |
* 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others |
5 |
* |
6 |
* You may distribute under the terms of either the GNU General Public |
7 |
* License or the Artistic License, as specified in the README file. |
8 |
* |
9 |
*/ |
10 |
|
11 |
/* |
12 |
* Now far ahead the Road has gone, |
13 |
* And I must follow, if I can, |
14 |
* Pursuing it with eager feet, |
15 |
* Until it joins some larger way |
16 |
* Where many paths and errands meet. |
17 |
* And whither then? I cannot say. |
18 |
*/ |
19 |
|
20 |
/* This file contains control-oriented pp ("push/pop") functions that |
21 |
* execute the opcodes that make up a perl program. A typical pp function |
22 |
* expects to find its arguments on the stack, and usually pushes its |
23 |
* results onto the stack, hence the 'pp' terminology. Each OP structure |
24 |
* contains a pointer to the relevant pp_foo() function. |
25 |
* |
26 |
* Control-oriented means things like pp_enteriter() and pp_next(), which |
27 |
* alter the flow of control of the program. |
28 |
*/ |
29 |
|
30 |
|
31 |
#include "EXTERN.h" |
32 |
#define PERL_IN_PP_CTL_C |
33 |
#include "perl.h" |
34 |
|
35 |
#ifndef WORD_ALIGN |
36 |
#define WORD_ALIGN sizeof(U32) |
37 |
#endif |
38 |
|
39 |
#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) |
40 |
|
41 |
static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen); |
42 |
|
43 |
PP(pp_wantarray) |
44 |
{ |
45 |
dSP; |
46 |
I32 cxix; |
47 |
EXTEND(SP, 1); |
48 |
|
49 |
cxix = dopoptosub(cxstack_ix); |
50 |
if (cxix < 0) |
51 |
RETPUSHUNDEF; |
52 |
|
53 |
switch (cxstack[cxix].blk_gimme) { |
54 |
case G_ARRAY: |
55 |
RETPUSHYES; |
56 |
case G_SCALAR: |
57 |
RETPUSHNO; |
58 |
default: |
59 |
RETPUSHUNDEF; |
60 |
} |
61 |
} |
62 |
|
63 |
PP(pp_regcmaybe) |
64 |
{ |
65 |
return NORMAL; |
66 |
} |
67 |
|
68 |
PP(pp_regcreset) |
69 |
{ |
70 |
/* XXXX Should store the old value to allow for tie/overload - and |
71 |
restore in regcomp, where marked with XXXX. */ |
72 |
PL_reginterp_cnt = 0; |
73 |
TAINT_NOT; |
74 |
return NORMAL; |
75 |
} |
76 |
|
77 |
PP(pp_regcomp) |
78 |
{ |
79 |
dSP; |
80 |
register PMOP *pm = (PMOP*)cLOGOP->op_other; |
81 |
register char *t; |
82 |
SV *tmpstr; |
83 |
STRLEN len; |
84 |
MAGIC *mg = Null(MAGIC*); |
85 |
|
86 |
tmpstr = POPs; |
87 |
|
88 |
/* prevent recompiling under /o and ithreads. */ |
89 |
#if defined(USE_ITHREADS) || defined(USE_5005THREADS) |
90 |
if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) |
91 |
RETURN; |
92 |
#endif |
93 |
|
94 |
if (SvROK(tmpstr)) { |
95 |
SV *sv = SvRV(tmpstr); |
96 |
if(SvMAGICAL(sv)) |
97 |
mg = mg_find(sv, PERL_MAGIC_qr); |
98 |
} |
99 |
if (mg) { |
100 |
regexp *re = (regexp *)mg->mg_obj; |
101 |
ReREFCNT_dec(PM_GETRE(pm)); |
102 |
PM_SETRE(pm, ReREFCNT_inc(re)); |
103 |
} |
104 |
else { |
105 |
t = SvPV(tmpstr, len); |
106 |
|
107 |
/* Check against the last compiled regexp. */ |
108 |
if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp || |
109 |
PM_GETRE(pm)->prelen != (I32)len || |
110 |
memNE(PM_GETRE(pm)->precomp, t, len)) |
111 |
{ |
112 |
if (PM_GETRE(pm)) { |
113 |
ReREFCNT_dec(PM_GETRE(pm)); |
114 |
PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */ |
115 |
} |
116 |
if (PL_op->op_flags & OPf_SPECIAL) |
117 |
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ |
118 |
|
119 |
pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ |
120 |
if (DO_UTF8(tmpstr)) |
121 |
pm->op_pmdynflags |= PMdf_DYN_UTF8; |
122 |
else { |
123 |
pm->op_pmdynflags &= ~PMdf_DYN_UTF8; |
124 |
if (pm->op_pmdynflags & PMdf_UTF8) |
125 |
t = (char*)bytes_to_utf8((U8*)t, &len); |
126 |
} |
127 |
PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm)); |
128 |
if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8)) |
129 |
Safefree(t); |
130 |
PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed |
131 |
inside tie/overload accessors. */ |
132 |
} |
133 |
} |
134 |
|
135 |
#ifndef INCOMPLETE_TAINTS |
136 |
if (PL_tainting) { |
137 |
if (PL_tainted) |
138 |
pm->op_pmdynflags |= PMdf_TAINTED; |
139 |
else |
140 |
pm->op_pmdynflags &= ~PMdf_TAINTED; |
141 |
} |
142 |
#endif |
143 |
|
144 |
if (!PM_GETRE(pm)->prelen && PL_curpm) |
145 |
pm = PL_curpm; |
146 |
else if (strEQ("\\s+", PM_GETRE(pm)->precomp)) |
147 |
pm->op_pmflags |= PMf_WHITE; |
148 |
else |
149 |
pm->op_pmflags &= ~PMf_WHITE; |
150 |
|
151 |
/* XXX runtime compiled output needs to move to the pad */ |
152 |
if (pm->op_pmflags & PMf_KEEP) { |
153 |
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ |
154 |
#if !defined(USE_ITHREADS) && !defined(USE_5005THREADS) |
155 |
/* XXX can't change the optree at runtime either */ |
156 |
cLOGOP->op_first->op_next = PL_op->op_next; |
157 |
#endif |
158 |
} |
159 |
RETURN; |
160 |
} |
161 |
|
162 |
PP(pp_substcont) |
163 |
{ |
164 |
dSP; |
165 |
register PMOP *pm = (PMOP*) cLOGOP->op_other; |
166 |
register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; |
167 |
register SV *dstr = cx->sb_dstr; |
168 |
register char *s = cx->sb_s; |
169 |
register char *m = cx->sb_m; |
170 |
char *orig = cx->sb_orig; |
171 |
register REGEXP *rx = cx->sb_rx; |
172 |
SV *nsv = Nullsv; |
173 |
REGEXP *old = PM_GETRE(pm); |
174 |
if(old != rx) { |
175 |
if(old) |
176 |
ReREFCNT_dec(old); |
177 |
PM_SETRE(pm,rx); |
178 |
} |
179 |
|
180 |
rxres_restore(&cx->sb_rxres, rx); |
181 |
RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ)); |
182 |
|
183 |
if (cx->sb_iters++) { |
184 |
I32 saviters = cx->sb_iters; |
185 |
if (cx->sb_iters > cx->sb_maxiters) |
186 |
DIE(aTHX_ "Substitution loop"); |
187 |
|
188 |
if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) |
189 |
cx->sb_rxtainted |= 2; |
190 |
sv_catsv(dstr, POPs); |
191 |
|
192 |
/* Are we done */ |
193 |
if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig, |
194 |
s == m, cx->sb_targ, NULL, |
195 |
((cx->sb_rflags & REXEC_COPY_STR) |
196 |
? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) |
197 |
: (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) |
198 |
{ |
199 |
SV *targ = cx->sb_targ; |
200 |
|
201 |
assert(cx->sb_strend >= s); |
202 |
if(cx->sb_strend > s) { |
203 |
if (DO_UTF8(dstr) && !SvUTF8(targ)) |
204 |
sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); |
205 |
else |
206 |
sv_catpvn(dstr, s, cx->sb_strend - s); |
207 |
} |
208 |
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); |
209 |
|
210 |
SvOOK_off(targ); |
211 |
if (SvLEN(targ)) |
212 |
Safefree(SvPVX(targ)); |
213 |
SvPVX(targ) = SvPVX(dstr); |
214 |
SvCUR_set(targ, SvCUR(dstr)); |
215 |
SvLEN_set(targ, SvLEN(dstr)); |
216 |
if (DO_UTF8(dstr)) |
217 |
SvUTF8_on(targ); |
218 |
SvPVX(dstr) = 0; |
219 |
sv_free(dstr); |
220 |
|
221 |
TAINT_IF(cx->sb_rxtainted & 1); |
222 |
PUSHs(sv_2mortal(newSViv(saviters - 1))); |
223 |
|
224 |
(void)SvPOK_only_UTF8(targ); |
225 |
TAINT_IF(cx->sb_rxtainted); |
226 |
SvSETMAGIC(targ); |
227 |
SvTAINT(targ); |
228 |
|
229 |
LEAVE_SCOPE(cx->sb_oldsave); |
230 |
ReREFCNT_dec(rx); |
231 |
POPSUBST(cx); |
232 |
RETURNOP(pm->op_next); |
233 |
} |
234 |
cx->sb_iters = saviters; |
235 |
} |
236 |
if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { |
237 |
m = s; |
238 |
s = orig; |
239 |
cx->sb_orig = orig = rx->subbeg; |
240 |
s = orig + (m - s); |
241 |
cx->sb_strend = s + (cx->sb_strend - m); |
242 |
} |
243 |
cx->sb_m = m = rx->startp[0] + orig; |
244 |
if (m > s) { |
245 |
if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) |
246 |
sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); |
247 |
else |
248 |
sv_catpvn(dstr, s, m-s); |
249 |
} |
250 |
cx->sb_s = rx->endp[0] + orig; |
251 |
{ /* Update the pos() information. */ |
252 |
SV *sv = cx->sb_targ; |
253 |
MAGIC *mg; |
254 |
I32 i; |
255 |
if (SvTYPE(sv) < SVt_PVMG) |
256 |
(void)SvUPGRADE(sv, SVt_PVMG); |
257 |
if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { |
258 |
sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); |
259 |
mg = mg_find(sv, PERL_MAGIC_regex_global); |
260 |
} |
261 |
i = m - orig; |
262 |
if (DO_UTF8(sv)) |
263 |
sv_pos_b2u(sv, &i); |
264 |
mg->mg_len = i; |
265 |
} |
266 |
if (old != rx) |
267 |
ReREFCNT_inc(rx); |
268 |
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); |
269 |
rxres_save(&cx->sb_rxres, rx); |
270 |
RETURNOP(pm->op_pmreplstart); |
271 |
} |
272 |
|
273 |
void |
274 |
Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) |
275 |
{ |
276 |
UV *p = (UV*)*rsp; |
277 |
U32 i; |
278 |
|
279 |
if (!p || p[1] < rx->nparens) { |
280 |
i = 6 + rx->nparens * 2; |
281 |
if (!p) |
282 |
New(501, p, i, UV); |
283 |
else |
284 |
Renew(p, i, UV); |
285 |
*rsp = (void*)p; |
286 |
} |
287 |
|
288 |
*p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); |
289 |
RX_MATCH_COPIED_off(rx); |
290 |
|
291 |
*p++ = rx->nparens; |
292 |
|
293 |
*p++ = PTR2UV(rx->subbeg); |
294 |
*p++ = (UV)rx->sublen; |
295 |
for (i = 0; i <= rx->nparens; ++i) { |
296 |
*p++ = (UV)rx->startp[i]; |
297 |
*p++ = (UV)rx->endp[i]; |
298 |
} |
299 |
} |
300 |
|
301 |
void |
302 |
Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) |
303 |
{ |
304 |
UV *p = (UV*)*rsp; |
305 |
U32 i; |
306 |
|
307 |
if (RX_MATCH_COPIED(rx)) |
308 |
Safefree(rx->subbeg); |
309 |
RX_MATCH_COPIED_set(rx, *p); |
310 |
*p++ = 0; |
311 |
|
312 |
rx->nparens = *p++; |
313 |
|
314 |
rx->subbeg = INT2PTR(char*,*p++); |
315 |
rx->sublen = (I32)(*p++); |
316 |
for (i = 0; i <= rx->nparens; ++i) { |
317 |
rx->startp[i] = (I32)(*p++); |
318 |
rx->endp[i] = (I32)(*p++); |
319 |
} |
320 |
} |
321 |
|
322 |
void |
323 |
Perl_rxres_free(pTHX_ void **rsp) |
324 |
{ |
325 |
UV *p = (UV*)*rsp; |
326 |
|
327 |
if (p) { |
328 |
Safefree(INT2PTR(char*,*p)); |
329 |
Safefree(p); |
330 |
*rsp = Null(void*); |
331 |
} |
332 |
} |
333 |
|
334 |
PP(pp_formline) |
335 |
{ |
336 |
dSP; dMARK; dORIGMARK; |
337 |
register SV *tmpForm = *++MARK; |
338 |
register U32 *fpc; |
339 |
register char *t; |
340 |
register char *f; |
341 |
register char *s; |
342 |
register char *send; |
343 |
register I32 arg; |
344 |
register SV *sv = Nullsv; |
345 |
char *item = Nullch; |
346 |
I32 itemsize = 0; |
347 |
I32 fieldsize = 0; |
348 |
I32 lines = 0; |
349 |
bool chopspace = (strchr(PL_chopset, ' ') != Nullch); |
350 |
char *chophere = Nullch; |
351 |
char *linemark = Nullch; |
352 |
NV value; |
353 |
bool gotsome = FALSE; |
354 |
STRLEN len; |
355 |
STRLEN fudge = SvPOK(tmpForm) |
356 |
? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0; |
357 |
bool item_is_utf8 = FALSE; |
358 |
bool targ_is_utf8 = FALSE; |
359 |
SV * nsv = Nullsv; |
360 |
OP * parseres = 0; |
361 |
char *fmt; |
362 |
bool oneline; |
363 |
|
364 |
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { |
365 |
if (SvREADONLY(tmpForm)) { |
366 |
SvREADONLY_off(tmpForm); |
367 |
parseres = doparseform(tmpForm); |
368 |
SvREADONLY_on(tmpForm); |
369 |
} |
370 |
else |
371 |
parseres = doparseform(tmpForm); |
372 |
if (parseres) |
373 |
return parseres; |
374 |
} |
375 |
SvPV_force(PL_formtarget, len); |
376 |
if (DO_UTF8(PL_formtarget)) |
377 |
targ_is_utf8 = TRUE; |
378 |
t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ |
379 |
t += len; |
380 |
f = SvPV(tmpForm, len); |
381 |
/* need to jump to the next word */ |
382 |
s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN; |
383 |
|
384 |
fpc = (U32*)s; |
385 |
|
386 |
for (;;) { |
387 |
DEBUG_f( { |
388 |
char *name = "???"; |
389 |
arg = -1; |
390 |
switch (*fpc) { |
391 |
case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; |
392 |
case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; |
393 |
case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; |
394 |
case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; |
395 |
case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; |
396 |
|
397 |
case FF_CHECKNL: name = "CHECKNL"; break; |
398 |
case FF_CHECKCHOP: name = "CHECKCHOP"; break; |
399 |
case FF_SPACE: name = "SPACE"; break; |
400 |
case FF_HALFSPACE: name = "HALFSPACE"; break; |
401 |
case FF_ITEM: name = "ITEM"; break; |
402 |
case FF_CHOP: name = "CHOP"; break; |
403 |
case FF_LINEGLOB: name = "LINEGLOB"; break; |
404 |
case FF_NEWLINE: name = "NEWLINE"; break; |
405 |
case FF_MORE: name = "MORE"; break; |
406 |
case FF_LINEMARK: name = "LINEMARK"; break; |
407 |
case FF_END: name = "END"; break; |
408 |
case FF_0DECIMAL: name = "0DECIMAL"; break; |
409 |
case FF_LINESNGL: name = "LINESNGL"; break; |
410 |
} |
411 |
if (arg >= 0) |
412 |
PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); |
413 |
else |
414 |
PerlIO_printf(Perl_debug_log, "%-16s\n", name); |
415 |
} ); |
416 |
switch (*fpc++) { |
417 |
case FF_LINEMARK: |
418 |
linemark = t; |
419 |
lines++; |
420 |
gotsome = FALSE; |
421 |
break; |
422 |
|
423 |
case FF_LITERAL: |
424 |
arg = *fpc++; |
425 |
if (targ_is_utf8 && !SvUTF8(tmpForm)) { |
426 |
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); |
427 |
*t = '\0'; |
428 |
sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); |
429 |
t = SvEND(PL_formtarget); |
430 |
break; |
431 |
} |
432 |
if (!targ_is_utf8 && DO_UTF8(tmpForm)) { |
433 |
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); |
434 |
*t = '\0'; |
435 |
sv_utf8_upgrade(PL_formtarget); |
436 |
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); |
437 |
t = SvEND(PL_formtarget); |
438 |
targ_is_utf8 = TRUE; |
439 |
} |
440 |
while (arg--) |
441 |
*t++ = *f++; |
442 |
break; |
443 |
|
444 |
case FF_SKIP: |
445 |
f += *fpc++; |
446 |
break; |
447 |
|
448 |
case FF_FETCH: |
449 |
arg = *fpc++; |
450 |
f += arg; |
451 |
fieldsize = arg; |
452 |
|
453 |
if (MARK < SP) |
454 |
sv = *++MARK; |
455 |
else { |
456 |
sv = &PL_sv_no; |
457 |
if (ckWARN(WARN_SYNTAX)) |
458 |
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); |
459 |
} |
460 |
break; |
461 |
|
462 |
case FF_CHECKNL: |
463 |
item = s = SvPV(sv, len); |
464 |
itemsize = len; |
465 |
if (DO_UTF8(sv)) { |
466 |
itemsize = sv_len_utf8(sv); |
467 |
if (itemsize != (I32)len) { |
468 |
I32 itembytes; |
469 |
if (itemsize > fieldsize) { |
470 |
itemsize = fieldsize; |
471 |
itembytes = itemsize; |
472 |
sv_pos_u2b(sv, &itembytes, 0); |
473 |
} |
474 |
else |
475 |
itembytes = len; |
476 |
send = chophere = s + itembytes; |
477 |
while (s < send) { |
478 |
if (*s & ~31) |
479 |
gotsome = TRUE; |
480 |
else if (*s == '\n') |
481 |
break; |
482 |
s++; |
483 |
} |
484 |
item_is_utf8 = TRUE; |
485 |
itemsize = s - item; |
486 |
sv_pos_b2u(sv, &itemsize); |
487 |
break; |
488 |
} |
489 |
} |
490 |
item_is_utf8 = FALSE; |
491 |
if (itemsize > fieldsize) |
492 |
itemsize = fieldsize; |
493 |
send = chophere = s + itemsize; |
494 |
while (s < send) { |
495 |
if (*s & ~31) |
496 |
gotsome = TRUE; |
497 |
else if (*s == '\n') |
498 |
break; |
499 |
s++; |
500 |
} |
501 |
itemsize = s - item; |
502 |
break; |
503 |
|
504 |
case FF_CHECKCHOP: |
505 |
item = s = SvPV(sv, len); |
506 |
itemsize = len; |
507 |
if (DO_UTF8(sv)) { |
508 |
itemsize = sv_len_utf8(sv); |
509 |
if (itemsize != (I32)len) { |
510 |
I32 itembytes; |
511 |
if (itemsize <= fieldsize) { |
512 |
send = chophere = s + itemsize; |
513 |
while (s < send) { |
514 |
if (*s == '\r') { |
515 |
itemsize = s - item; |
516 |
chophere = s; |
517 |
break; |
518 |
} |
519 |
if (*s++ & ~31) |
520 |
gotsome = TRUE; |
521 |
} |
522 |
} |
523 |
else { |
524 |
itemsize = fieldsize; |
525 |
itembytes = itemsize; |
526 |
sv_pos_u2b(sv, &itembytes, 0); |
527 |
send = chophere = s + itembytes; |
528 |
while (s < send || (s == send && isSPACE(*s))) { |
529 |
if (isSPACE(*s)) { |
530 |
if (chopspace) |
531 |
chophere = s; |
532 |
if (*s == '\r') |
533 |
break; |
534 |
} |
535 |
else { |
536 |
if (*s & ~31) |
537 |
gotsome = TRUE; |
538 |
if (strchr(PL_chopset, *s)) |
539 |
chophere = s + 1; |
540 |
} |
541 |
s++; |
542 |
} |
543 |
itemsize = chophere - item; |
544 |
sv_pos_b2u(sv, &itemsize); |
545 |
} |
546 |
item_is_utf8 = TRUE; |
547 |
break; |
548 |
} |
549 |
} |
550 |
item_is_utf8 = FALSE; |
551 |
if (itemsize <= fieldsize) { |
552 |
send = chophere = s + itemsize; |
553 |
while (s < send) { |
554 |
if (*s == '\r') { |
555 |
itemsize = s - item; |
556 |
chophere = s; |
557 |
break; |
558 |
} |
559 |
if (*s++ & ~31) |
560 |
gotsome = TRUE; |
561 |
} |
562 |
} |
563 |
else { |
564 |
itemsize = fieldsize; |
565 |
send = chophere = s + itemsize; |
566 |
while (s < send || (s == send && isSPACE(*s))) { |
567 |
if (isSPACE(*s)) { |
568 |
if (chopspace) |
569 |
chophere = s; |
570 |
if (*s == '\r') |
571 |
break; |
572 |
} |
573 |
else { |
574 |
if (*s & ~31) |
575 |
gotsome = TRUE; |
576 |
if (strchr(PL_chopset, *s)) |
577 |
chophere = s + 1; |
578 |
} |
579 |
s++; |
580 |
} |
581 |
itemsize = chophere - item; |
582 |
} |
583 |
break; |
584 |
|
585 |
case FF_SPACE: |
586 |
arg = fieldsize - itemsize; |
587 |
if (arg) { |
588 |
fieldsize -= arg; |
589 |
while (arg-- > 0) |
590 |
*t++ = ' '; |
591 |
} |
592 |
break; |
593 |
|
594 |
case FF_HALFSPACE: |
595 |
arg = fieldsize - itemsize; |
596 |
if (arg) { |
597 |
arg /= 2; |
598 |
fieldsize -= arg; |
599 |
while (arg-- > 0) |
600 |
*t++ = ' '; |
601 |
} |
602 |
break; |
603 |
|
604 |
case FF_ITEM: |
605 |
arg = itemsize; |
606 |
s = item; |
607 |
if (item_is_utf8) { |
608 |
if (!targ_is_utf8) { |
609 |
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); |
610 |
*t = '\0'; |
611 |
sv_utf8_upgrade(PL_formtarget); |
612 |
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); |
613 |
t = SvEND(PL_formtarget); |
614 |
targ_is_utf8 = TRUE; |
615 |
} |
616 |
while (arg--) { |
617 |
if (UTF8_IS_CONTINUED(*s)) { |
618 |
STRLEN skip = UTF8SKIP(s); |
619 |
switch (skip) { |
620 |
default: |
621 |
Move(s,t,skip,char); |
622 |
s += skip; |
623 |
t += skip; |
624 |
break; |
625 |
case 7: *t++ = *s++; |
626 |
case 6: *t++ = *s++; |
627 |
case 5: *t++ = *s++; |
628 |
case 4: *t++ = *s++; |
629 |
case 3: *t++ = *s++; |
630 |
case 2: *t++ = *s++; |
631 |
case 1: *t++ = *s++; |
632 |
} |
633 |
} |
634 |
else { |
635 |
if ( !((*t++ = *s++) & ~31) ) |
636 |
t[-1] = ' '; |
637 |
} |
638 |
} |
639 |
break; |
640 |
} |
641 |
if (targ_is_utf8 && !item_is_utf8) { |
642 |
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); |
643 |
*t = '\0'; |
644 |
sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv); |
645 |
for (; t < SvEND(PL_formtarget); t++) { |
646 |
#ifdef EBCDIC |
647 |
int ch = *t; |
648 |
if (iscntrl(ch)) |
649 |
#else |
650 |
if (!(*t & ~31)) |
651 |
#endif |
652 |
*t = ' '; |
653 |
} |
654 |
break; |
655 |
} |
656 |
while (arg--) { |
657 |
#ifdef EBCDIC |
658 |
int ch = *t++ = *s++; |
659 |
if (iscntrl(ch)) |
660 |
#else |
661 |
if ( !((*t++ = *s++) & ~31) ) |
662 |
#endif |
663 |
t[-1] = ' '; |
664 |
} |
665 |
break; |
666 |
|
667 |
case FF_CHOP: |
668 |
s = chophere; |
669 |
if (chopspace) { |
670 |
while (*s && isSPACE(*s)) |
671 |
s++; |
672 |
} |
673 |
sv_chop(sv,s); |
674 |
SvSETMAGIC(sv); |
675 |
break; |
676 |
|
677 |
case FF_LINESNGL: |
678 |
chopspace = 0; |
679 |
oneline = TRUE; |
680 |
goto ff_line; |
681 |
case FF_LINEGLOB: |
682 |
oneline = FALSE; |
683 |
ff_line: |
684 |
item = s = SvPV(sv, len); |
685 |
itemsize = len; |
686 |
if ((item_is_utf8 = DO_UTF8(sv))) |
687 |
itemsize = sv_len_utf8(sv); |
688 |
if (itemsize) { |
689 |
bool chopped = FALSE; |
690 |
gotsome = TRUE; |
691 |
send = s + len; |
692 |
chophere = s + itemsize; |
693 |
while (s < send) { |
694 |
if (*s++ == '\n') { |
695 |
if (oneline) { |
696 |
chopped = TRUE; |
697 |
chophere = s; |
698 |
break; |
699 |
} else { |
700 |
if (s == send) { |
701 |
itemsize--; |
702 |
chopped = TRUE; |
703 |
} else |
704 |
lines++; |
705 |
} |
706 |
} |
707 |
} |
708 |
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); |
709 |
if (targ_is_utf8) |
710 |
SvUTF8_on(PL_formtarget); |
711 |
if (oneline) { |
712 |
SvCUR_set(sv, chophere - item); |
713 |
sv_catsv(PL_formtarget, sv); |
714 |
SvCUR_set(sv, itemsize); |
715 |
} else |
716 |
sv_catsv(PL_formtarget, sv); |
717 |
if (chopped) |
718 |
SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1); |
719 |
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); |
720 |
t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); |
721 |
if (item_is_utf8) |
722 |
targ_is_utf8 = TRUE; |
723 |
} |
724 |
break; |
725 |
|
726 |
case FF_0DECIMAL: |
727 |
arg = *fpc++; |
728 |
#if defined(USE_LONG_DOUBLE) |
729 |
fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl; |
730 |
#else |
731 |
fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f"; |
732 |
#endif |
733 |
goto ff_dec; |
734 |
case FF_DECIMAL: |
735 |
arg = *fpc++; |
736 |
#if defined(USE_LONG_DOUBLE) |
737 |
fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl; |
738 |
#else |
739 |
fmt = (arg & 256) ? "%#*.*f" : "%*.*f"; |
740 |
#endif |
741 |
ff_dec: |
742 |
/* If the field is marked with ^ and the value is undefined, |
743 |
blank it out. */ |
744 |
if ((arg & 512) && !SvOK(sv)) { |
745 |
arg = fieldsize; |
746 |
while (arg--) |
747 |
*t++ = ' '; |
748 |
break; |
749 |
} |
750 |
gotsome = TRUE; |
751 |
value = SvNV(sv); |
752 |
/* overflow evidence */ |
753 |
if (num_overflow(value, fieldsize, arg)) { |
754 |
arg = fieldsize; |
755 |
while (arg--) |
756 |
*t++ = '#'; |
757 |
break; |
758 |
} |
759 |
/* Formats aren't yet marked for locales, so assume "yes". */ |
760 |
{ |
761 |
STORE_NUMERIC_STANDARD_SET_LOCAL(); |
762 |
sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value); |
763 |
RESTORE_NUMERIC_STANDARD(); |
764 |
} |
765 |
t += fieldsize; |
766 |
break; |
767 |
|
768 |
case FF_NEWLINE: |
769 |
f++; |
770 |
while (t-- > linemark && *t == ' ') ; |
771 |
t++; |
772 |
*t++ = '\n'; |
773 |
break; |
774 |
|
775 |
case FF_BLANK: |
776 |
arg = *fpc++; |
777 |
if (gotsome) { |
778 |
if (arg) { /* repeat until fields exhausted? */ |
779 |
*t = '\0'; |
780 |
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); |
781 |
lines += FmLINES(PL_formtarget); |
782 |
if (lines == 200) { |
783 |
arg = t - linemark; |
784 |
if (strnEQ(linemark, linemark - arg, arg)) |
785 |
DIE(aTHX_ "Runaway format"); |
786 |
} |
787 |
if (targ_is_utf8) |
788 |
SvUTF8_on(PL_formtarget); |
789 |
FmLINES(PL_formtarget) = lines; |
790 |
SP = ORIGMARK; |
791 |
RETURNOP(cLISTOP->op_first); |
792 |
} |
793 |
} |
794 |
else { |
795 |
t = linemark; |
796 |
lines--; |
797 |
} |
798 |
break; |
799 |
|
800 |
case FF_MORE: |
801 |
s = chophere; |
802 |
send = item + len; |
803 |
if (chopspace) { |
804 |
while (*s && isSPACE(*s) && s < send) |
805 |
s++; |
806 |
} |
807 |
if (s < send) { |
808 |
arg = fieldsize - itemsize; |
809 |
if (arg) { |
810 |
fieldsize -= arg; |
811 |
while (arg-- > 0) |
812 |
*t++ = ' '; |
813 |
} |
814 |
s = t - 3; |
815 |
if (strnEQ(s," ",3)) { |
816 |
while (s > SvPVX(PL_formtarget) && isSPACE(s[-1])) |
817 |
s--; |
818 |
} |
819 |
*s++ = '.'; |
820 |
*s++ = '.'; |
821 |
*s++ = '.'; |
822 |
} |
823 |
break; |
824 |
|
825 |
case FF_END: |
826 |
*t = '\0'; |
827 |
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); |
828 |
if (targ_is_utf8) |
829 |
SvUTF8_on(PL_formtarget); |
830 |
FmLINES(PL_formtarget) += lines; |
831 |
SP = ORIGMARK; |
832 |
RETPUSHYES; |
833 |
} |
834 |
} |
835 |
} |
836 |
|
837 |
PP(pp_grepstart) |
838 |
{ |
839 |
dSP; |
840 |
SV *src; |
841 |
|
842 |
if (PL_stack_base + *PL_markstack_ptr == SP) { |
843 |
(void)POPMARK; |
844 |
if (GIMME_V == G_SCALAR) |
845 |
XPUSHs(sv_2mortal(newSViv(0))); |
846 |
RETURNOP(PL_op->op_next->op_next); |
847 |
} |
848 |
PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; |
849 |
pp_pushmark(); /* push dst */ |
850 |
pp_pushmark(); /* push src */ |
851 |
ENTER; /* enter outer scope */ |
852 |
|
853 |
SAVETMPS; |
854 |
/* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */ |
855 |
SAVESPTR(DEFSV); |
856 |
ENTER; /* enter inner scope */ |
857 |
SAVEVPTR(PL_curpm); |
858 |
|
859 |
src = PL_stack_base[*PL_markstack_ptr]; |
860 |
SvTEMP_off(src); |
861 |
DEFSV = src; |
862 |
|
863 |
PUTBACK; |
864 |
if (PL_op->op_type == OP_MAPSTART) |
865 |
pp_pushmark(); /* push top */ |
866 |
return ((LOGOP*)PL_op->op_next)->op_other; |
867 |
} |
868 |
|
869 |
PP(pp_mapstart) |
870 |
{ |
871 |
DIE(aTHX_ "panic: mapstart"); /* uses grepstart */ |
872 |
} |
873 |
|
874 |
PP(pp_mapwhile) |
875 |
{ |
876 |
dSP; |
877 |
I32 gimme = GIMME_V; |
878 |
I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ |
879 |
I32 count; |
880 |
I32 shift; |
881 |
SV** src; |
882 |
SV** dst; |
883 |
|
884 |
/* first, move source pointer to the next item in the source list */ |
885 |
++PL_markstack_ptr[-1]; |
886 |
|
887 |
/* if there are new items, push them into the destination list */ |
888 |
if (items && gimme != G_VOID) { |
889 |
/* might need to make room back there first */ |
890 |
if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { |
891 |
/* XXX this implementation is very pessimal because the stack |
892 |
* is repeatedly extended for every set of items. Is possible |
893 |
* to do this without any stack extension or copying at all |
894 |
* by maintaining a separate list over which the map iterates |
895 |
* (like foreach does). --gsar */ |
896 |
|
897 |
/* everything in the stack after the destination list moves |
898 |
* towards the end the stack by the amount of room needed */ |
899 |
shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); |
900 |
|
901 |
/* items to shift up (accounting for the moved source pointer) */ |
902 |
count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); |
903 |
|
904 |
/* This optimization is by Ben Tilly and it does |
905 |
* things differently from what Sarathy (gsar) |
906 |
* is describing. The downside of this optimization is |
907 |
* that leaves "holes" (uninitialized and hopefully unused areas) |
908 |
* to the Perl stack, but on the other hand this |
909 |
* shouldn't be a problem. If Sarathy's idea gets |
910 |
* implemented, this optimization should become |
911 |
* irrelevant. --jhi */ |
912 |
if (shift < count) |
913 |
shift = count; /* Avoid shifting too often --Ben Tilly */ |
914 |
|
915 |
EXTEND(SP,shift); |
916 |
src = SP; |
917 |
dst = (SP += shift); |
918 |
PL_markstack_ptr[-1] += shift; |
919 |
*PL_markstack_ptr += shift; |
920 |
while (count--) |
921 |
*dst-- = *src--; |
922 |
} |
923 |
/* copy the new items down to the destination list */ |
924 |
dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; |
925 |
if (gimme == G_ARRAY) { |
926 |
while (items-- > 0) |
927 |
*dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); |
928 |
} |
929 |
else { |
930 |
/* scalar context: we don't care about which values map returns |
931 |
* (we use undef here). And so we certainly don't want to do mortal |
932 |
* copies of meaningless values. */ |
933 |
while (items-- > 0) { |
934 |
(void)POPs; |
935 |
*dst-- = &PL_sv_undef; |
936 |
} |
937 |
} |
938 |
} |
939 |
LEAVE; /* exit inner scope */ |
940 |
|
941 |
/* All done yet? */ |
942 |
if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { |
943 |
|
944 |
(void)POPMARK; /* pop top */ |
945 |
LEAVE; /* exit outer scope */ |
946 |
(void)POPMARK; /* pop src */ |
947 |
items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; |
948 |
(void)POPMARK; /* pop dst */ |
949 |
SP = PL_stack_base + POPMARK; /* pop original mark */ |
950 |
if (gimme == G_SCALAR) { |
951 |
dTARGET; |
952 |
XPUSHi(items); |
953 |
} |
954 |
else if (gimme == G_ARRAY) |
955 |
SP += items; |
956 |
RETURN; |
957 |
} |
958 |
else { |
959 |
SV *src; |
960 |
|
961 |
ENTER; /* enter inner scope */ |
962 |
SAVEVPTR(PL_curpm); |
963 |
|
964 |
/* set $_ to the new source item */ |
965 |
src = PL_stack_base[PL_markstack_ptr[-1]]; |
966 |
SvTEMP_off(src); |
967 |
DEFSV = src; |
968 |
|
969 |
RETURNOP(cLOGOP->op_other); |
970 |
} |
971 |
} |
972 |
|
973 |
/* Range stuff. */ |
974 |
|
975 |
PP(pp_range) |
976 |
{ |
977 |
if (GIMME == G_ARRAY) |
978 |
return NORMAL; |
979 |
if (SvTRUEx(PAD_SV(PL_op->op_targ))) |
980 |
return cLOGOP->op_other; |
981 |
else |
982 |
return NORMAL; |
983 |
} |
984 |
|
985 |
PP(pp_flip) |
986 |
{ |
987 |
dSP; |
988 |
|
989 |
if (GIMME == G_ARRAY) { |
990 |
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); |
991 |
} |
992 |
else { |
993 |
dTOPss; |
994 |
SV *targ = PAD_SV(PL_op->op_targ); |
995 |
int flip = 0; |
996 |
|
997 |
if (PL_op->op_private & OPpFLIP_LINENUM) { |
998 |
if (GvIO(PL_last_in_gv)) { |
999 |
flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); |
1000 |
} |
1001 |
else { |
1002 |
GV *gv = gv_fetchpv(".", TRUE, SVt_PV); |
1003 |
if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv)); |
1004 |
} |
1005 |
} else { |
1006 |
flip = SvTRUE(sv); |
1007 |
} |
1008 |
if (flip) { |
1009 |
sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); |
1010 |
if (PL_op->op_flags & OPf_SPECIAL) { |
1011 |
sv_setiv(targ, 1); |
1012 |
SETs(targ); |
1013 |
RETURN; |
1014 |
} |
1015 |
else { |
1016 |
sv_setiv(targ, 0); |
1017 |
SP--; |
1018 |
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); |
1019 |
} |
1020 |
} |
1021 |
sv_setpv(TARG, ""); |
1022 |
SETs(targ); |
1023 |
RETURN; |
1024 |
} |
1025 |
} |
1026 |
|
1027 |
/* This code tries to decide if "$left .. $right" should use the |
1028 |
magical string increment, or if the range is numeric (we make |
1029 |
an exception for .."0" [#18165]). AMS 20021031. */ |
1030 |
|
1031 |
#define RANGE_IS_NUMERIC(left,right) ( \ |
1032 |
SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ |
1033 |
SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ |
1034 |
(((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ |
1035 |
looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \ |
1036 |
&& (!SvOK(right) || looks_like_number(right)))) |
1037 |
|
1038 |
PP(pp_flop) |
1039 |
{ |
1040 |
dSP; |
1041 |
|
1042 |
if (GIMME == G_ARRAY) { |
1043 |
dPOPPOPssrl; |
1044 |
register IV i, j; |
1045 |
register SV *sv; |
1046 |
IV max; |
1047 |
|
1048 |
if (SvGMAGICAL(left)) |
1049 |
mg_get(left); |
1050 |
if (SvGMAGICAL(right)) |
1051 |
mg_get(right); |
1052 |
|
1053 |
if (RANGE_IS_NUMERIC(left,right)) { |
1054 |
if ((SvOK(left) && SvNV(left) < IV_MIN) || |
1055 |
(SvOK(right) && SvNV(right) > IV_MAX)) |
1056 |
DIE(aTHX_ "Range iterator outside integer range"); |
1057 |
i = SvIV(left); |
1058 |
max = SvIV(right); |
1059 |
if (max >= i) { |
1060 |
j = max - i + 1; |
1061 |
EXTEND_MORTAL(j); |
1062 |
EXTEND(SP, j); |
1063 |
} |
1064 |
else |
1065 |
j = 0; |
1066 |
while (j--) { |
1067 |
sv = sv_2mortal(newSViv(i++)); |
1068 |
PUSHs(sv); |
1069 |
} |
1070 |
} |
1071 |
else { |
1072 |
SV *final = sv_mortalcopy(right); |
1073 |
STRLEN len, n_a; |
1074 |
char *tmps = SvPV(final, len); |
1075 |
|
1076 |
sv = sv_mortalcopy(left); |
1077 |
SvPV_force(sv,n_a); |
1078 |
while (!SvNIOKp(sv) && SvCUR(sv) <= len) { |
1079 |
XPUSHs(sv); |
1080 |
if (strEQ(SvPVX(sv),tmps)) |
1081 |
break; |
1082 |
sv = sv_2mortal(newSVsv(sv)); |
1083 |
sv_inc(sv); |
1084 |
} |
1085 |
} |
1086 |
} |
1087 |
else { |
1088 |
dTOPss; |
1089 |
SV *targ = PAD_SV(cUNOP->op_first->op_targ); |
1090 |
int flop = 0; |
1091 |
sv_inc(targ); |
1092 |
|
1093 |
if (PL_op->op_private & OPpFLIP_LINENUM) { |
1094 |
if (GvIO(PL_last_in_gv)) { |
1095 |
flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); |
1096 |
} |
1097 |
else { |
1098 |
GV *gv = gv_fetchpv(".", TRUE, SVt_PV); |
1099 |
if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv)); |
1100 |
} |
1101 |
} |
1102 |
else { |
1103 |
flop = SvTRUE(sv); |
1104 |
} |
1105 |
|
1106 |
if (flop) { |
1107 |
sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); |
1108 |
sv_catpv(targ, "E0"); |
1109 |
} |
1110 |
SETs(targ); |
1111 |
} |
1112 |
|
1113 |
RETURN; |
1114 |
} |
1115 |
|
1116 |
/* Control. */ |
1117 |
|
1118 |
static char *context_name[] = { |
1119 |
"pseudo-block", |
1120 |
"subroutine", |
1121 |
"eval", |
1122 |
"loop", |
1123 |
"substitution", |
1124 |
"block", |
1125 |
"format" |
1126 |
}; |
1127 |
|
1128 |
STATIC I32 |
1129 |
S_dopoptolabel(pTHX_ char *label) |
1130 |
{ |
1131 |
register I32 i; |
1132 |
register PERL_CONTEXT *cx; |
1133 |
|
1134 |
for (i = cxstack_ix; i >= 0; i--) { |
1135 |
cx = &cxstack[i]; |
1136 |
switch (CxTYPE(cx)) { |
1137 |
case CXt_SUBST: |
1138 |
case CXt_SUB: |
1139 |
case CXt_FORMAT: |
1140 |
case CXt_EVAL: |
1141 |
case CXt_NULL: |
1142 |
if (ckWARN(WARN_EXITING)) |
1143 |
Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", |
1144 |
context_name[CxTYPE(cx)], OP_NAME(PL_op)); |
1145 |
if (CxTYPE(cx) == CXt_NULL) |
1146 |
return -1; |
1147 |
break; |
1148 |
case CXt_LOOP: |
1149 |
if (!cx->blk_loop.label || |
1150 |
strNE(label, cx->blk_loop.label) ) { |
1151 |
DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", |
1152 |
(long)i, cx->blk_loop.label)); |
1153 |
continue; |
1154 |
} |
1155 |
DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); |
1156 |
return i; |
1157 |
} |
1158 |
} |
1159 |
return i; |
1160 |
} |
1161 |
|
1162 |
I32 |
1163 |
Perl_dowantarray(pTHX) |
1164 |
{ |
1165 |
I32 gimme = block_gimme(); |
1166 |
return (gimme == G_VOID) ? G_SCALAR : gimme; |
1167 |
} |
1168 |
|
1169 |
I32 |
1170 |
Perl_block_gimme(pTHX) |
1171 |
{ |
1172 |
I32 cxix; |
1173 |
|
1174 |
cxix = dopoptosub(cxstack_ix); |
1175 |
if (cxix < 0) |
1176 |
return G_VOID; |
1177 |
|
1178 |
switch (cxstack[cxix].blk_gimme) { |
1179 |
case G_VOID: |
1180 |
return G_VOID; |
1181 |
case G_SCALAR: |
1182 |
return G_SCALAR; |
1183 |
case G_ARRAY: |
1184 |
return G_ARRAY; |
1185 |
default: |
1186 |
Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); |
1187 |
/* NOTREACHED */ |
1188 |
return 0; |
1189 |
} |
1190 |
} |
1191 |
|
1192 |
I32 |
1193 |
Perl_is_lvalue_sub(pTHX) |
1194 |
{ |
1195 |
I32 cxix; |
1196 |
|
1197 |
cxix = dopoptosub(cxstack_ix); |
1198 |
assert(cxix >= 0); /* We should only be called from inside subs */ |
1199 |
|
1200 |
if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv)) |
1201 |
return cxstack[cxix].blk_sub.lval; |
1202 |
else |
1203 |
return 0; |
1204 |
} |
1205 |
|
1206 |
STATIC I32 |
1207 |
S_dopoptosub(pTHX_ I32 startingblock) |
1208 |
{ |
1209 |
return dopoptosub_at(cxstack, startingblock); |
1210 |
} |
1211 |
|
1212 |
STATIC I32 |
1213 |
S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) |
1214 |
{ |
1215 |
I32 i; |
1216 |
register PERL_CONTEXT *cx; |
1217 |
for (i = startingblock; i >= 0; i--) { |
1218 |
cx = &cxstk[i]; |
1219 |
switch (CxTYPE(cx)) { |
1220 |
default: |
1221 |
continue; |
1222 |
case CXt_EVAL: |
1223 |
case CXt_SUB: |
1224 |
case CXt_FORMAT: |
1225 |
DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); |
1226 |
return i; |
1227 |
} |
1228 |
} |
1229 |
return i; |
1230 |
} |
1231 |
|
1232 |
STATIC I32 |
1233 |
S_dopoptoeval(pTHX_ I32 startingblock) |
1234 |
{ |
1235 |
I32 i; |
1236 |
register PERL_CONTEXT *cx; |
1237 |
for (i = startingblock; i >= 0; i--) { |
1238 |
cx = &cxstack[i]; |
1239 |
switch (CxTYPE(cx)) { |
1240 |
default: |
1241 |
continue; |
1242 |
case CXt_EVAL: |
1243 |
DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i)); |
1244 |
return i; |
1245 |
} |
1246 |
} |
1247 |
return i; |
1248 |
} |
1249 |
|
1250 |
STATIC I32 |
1251 |
S_dopoptoloop(pTHX_ I32 startingblock) |
1252 |
{ |
1253 |
I32 i; |
1254 |
register PERL_CONTEXT *cx; |
1255 |
for (i = startingblock; i >= 0; i--) { |
1256 |
cx = &cxstack[i]; |
1257 |
switch (CxTYPE(cx)) { |
1258 |
case CXt_SUBST: |
1259 |
case CXt_SUB: |
1260 |
case CXt_FORMAT: |
1261 |
case CXt_EVAL: |
1262 |
case CXt_NULL: |
1263 |
if (ckWARN(WARN_EXITING)) |
1264 |
Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", |
1265 |
context_name[CxTYPE(cx)], OP_NAME(PL_op)); |
1266 |
if ((CxTYPE(cx)) == CXt_NULL) |
1267 |
return -1; |
1268 |
break; |
1269 |
case CXt_LOOP: |
1270 |
DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); |
1271 |
return i; |
1272 |
} |
1273 |
} |
1274 |
return i; |
1275 |
} |
1276 |
|
1277 |
void |
1278 |
Perl_dounwind(pTHX_ I32 cxix) |
1279 |
{ |
1280 |
register PERL_CONTEXT *cx; |
1281 |
I32 optype; |
1282 |
|
1283 |
while (cxstack_ix > cxix) { |
1284 |
SV *sv; |
1285 |
cx = &cxstack[cxstack_ix]; |
1286 |
DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", |
1287 |
(long) cxstack_ix, PL_block_type[CxTYPE(cx)])); |
1288 |
/* Note: we don't need to restore the base context info till the end. */ |
1289 |
switch (CxTYPE(cx)) { |
1290 |
case CXt_SUBST: |
1291 |
POPSUBST(cx); |
1292 |
continue; /* not break */ |
1293 |
case CXt_SUB: |
1294 |
POPSUB(cx,sv); |
1295 |
LEAVESUB(sv); |
1296 |
break; |
1297 |
case CXt_EVAL: |
1298 |
POPEVAL(cx); |
1299 |
break; |
1300 |
case CXt_LOOP: |
1301 |
POPLOOP(cx); |
1302 |
break; |
1303 |
case CXt_NULL: |
1304 |
break; |
1305 |
case CXt_FORMAT: |
1306 |
POPFORMAT(cx); |
1307 |
break; |
1308 |
} |
1309 |
cxstack_ix--; |
1310 |
} |
1311 |
} |
1312 |
|
1313 |
void |
1314 |
Perl_qerror(pTHX_ SV *err) |
1315 |
{ |
1316 |
if (PL_in_eval) |
1317 |
sv_catsv(ERRSV, err); |
1318 |
else if (PL_errors) |
1319 |
sv_catsv(PL_errors, err); |
1320 |
else |
1321 |
Perl_warn(aTHX_ "%"SVf, err); |
1322 |
++PL_error_count; |
1323 |
} |
1324 |
|
1325 |
OP * |
1326 |
Perl_die_where(pTHX_ char *message, STRLEN msglen) |
1327 |
{ |
1328 |
STRLEN n_a; |
1329 |
|
1330 |
if (PL_in_eval) { |
1331 |
I32 cxix; |
1332 |
register PERL_CONTEXT *cx; |
1333 |
I32 gimme; |
1334 |
SV **newsp; |
1335 |
|
1336 |
if (message) { |
1337 |
if (PL_in_eval & EVAL_KEEPERR) { |
1338 |
static char prefix[] = "\t(in cleanup) "; |
1339 |
SV *err = ERRSV; |
1340 |
char *e = Nullch; |
1341 |
if (!SvPOK(err)) |
1342 |
sv_setpv(err,""); |
1343 |
else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { |
1344 |
e = SvPV(err, n_a); |
1345 |
e += n_a - msglen; |
1346 |
if (*e != *message || strNE(e,message)) |
1347 |
e = Nullch; |
1348 |
} |
1349 |
if (!e) { |
1350 |
SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); |
1351 |
sv_catpvn(err, prefix, sizeof(prefix)-1); |
1352 |
sv_catpvn(err, message, msglen); |
1353 |
if (ckWARN(WARN_MISC)) { |
1354 |
STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; |
1355 |
Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start); |
1356 |
} |
1357 |
} |
1358 |
} |
1359 |
else { |
1360 |
sv_setpvn(ERRSV, message, msglen); |
1361 |
} |
1362 |
} |
1363 |
|
1364 |
while ((cxix = dopoptoeval(cxstack_ix)) < 0 |
1365 |
&& PL_curstackinfo->si_prev) |
1366 |
{ |
1367 |
dounwind(-1); |
1368 |
POPSTACK; |
1369 |
} |
1370 |
|
1371 |
if (cxix >= 0) { |
1372 |
I32 optype; |
1373 |
|
1374 |
if (cxix < cxstack_ix) |
1375 |
dounwind(cxix); |
1376 |
|
1377 |
POPBLOCK(cx,PL_curpm); |
1378 |
if (CxTYPE(cx) != CXt_EVAL) { |
1379 |
if (!message) |
1380 |
message = SvPVx(ERRSV, msglen); |
1381 |
PerlIO_write(Perl_error_log, "panic: die ", 11); |
1382 |
PerlIO_write(Perl_error_log, message, msglen); |
1383 |
my_exit(1); |
1384 |
} |
1385 |
POPEVAL(cx); |
1386 |
|
1387 |
if (gimme == G_SCALAR) |
1388 |
*++newsp = &PL_sv_undef; |
1389 |
PL_stack_sp = newsp; |
1390 |
|
1391 |
LEAVE; |
1392 |
|
1393 |
/* LEAVE could clobber PL_curcop (see save_re_context()) |
1394 |
* XXX it might be better to find a way to avoid messing with |
1395 |
* PL_curcop in save_re_context() instead, but this is a more |
1396 |
* minimal fix --GSAR */ |
1397 |
PL_curcop = cx->blk_oldcop; |
1398 |
|
1399 |
if (optype == OP_REQUIRE) { |
1400 |
char* msg = SvPVx(ERRSV, n_a); |
1401 |
DIE(aTHX_ "%sCompilation failed in require", |
1402 |
*msg ? msg : "Unknown error\n"); |
1403 |
} |
1404 |
return pop_return(); |
1405 |
} |
1406 |
} |
1407 |
if (!message) |
1408 |
message = SvPVx(ERRSV, msglen); |
1409 |
|
1410 |
write_to_stderr(message, msglen); |
1411 |
my_failure_exit(); |
1412 |
/* NOTREACHED */ |
1413 |
return 0; |
1414 |
} |
1415 |
|
1416 |
PP(pp_xor) |
1417 |
{ |
1418 |
dSP; dPOPTOPssrl; |
1419 |
if (SvTRUE(left) != SvTRUE(right)) |
1420 |
RETSETYES; |
1421 |
else |
1422 |
RETSETNO; |
1423 |
} |
1424 |
|
1425 |
PP(pp_andassign) |
1426 |
{ |
1427 |
dSP; |
1428 |
if (!SvTRUE(TOPs)) |
1429 |
RETURN; |
1430 |
else |
1431 |
RETURNOP(cLOGOP->op_other); |
1432 |
} |
1433 |
|
1434 |
PP(pp_orassign) |
1435 |
{ |
1436 |
dSP; |
1437 |
if (SvTRUE(TOPs)) |
1438 |
RETURN; |
1439 |
else |
1440 |
RETURNOP(cLOGOP->op_other); |
1441 |
} |
1442 |
|
1443 |
PP(pp_caller) |
1444 |
{ |
1445 |
dSP; |
1446 |
register I32 cxix = dopoptosub(cxstack_ix); |
1447 |
register PERL_CONTEXT *cx; |
1448 |
register PERL_CONTEXT *ccstack = cxstack; |
1449 |
PERL_SI *top_si = PL_curstackinfo; |
1450 |
I32 dbcxix; |
1451 |
I32 gimme; |
1452 |
char *stashname; |
1453 |
SV *sv; |
1454 |
I32 count = 0; |
1455 |
|
1456 |
if (MAXARG) |
1457 |
count = POPi; |
1458 |
|
1459 |
for (;;) { |
1460 |
/* we may be in a higher stacklevel, so dig down deeper */ |
1461 |
while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { |
1462 |
top_si = top_si->si_prev; |
1463 |
ccstack = top_si->si_cxstack; |
1464 |
cxix = dopoptosub_at(ccstack, top_si->si_cxix); |
1465 |
} |
1466 |
if (cxix < 0) { |
1467 |
if (GIMME != G_ARRAY) { |
1468 |
EXTEND(SP, 1); |
1469 |
RETPUSHUNDEF; |
1470 |
} |
1471 |
RETURN; |
1472 |
} |
1473 |
/* caller() should not report the automatic calls to &DB::sub */ |
1474 |
if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && |
1475 |
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) |
1476 |
count++; |
1477 |
if (!count--) |
1478 |
break; |
1479 |
cxix = dopoptosub_at(ccstack, cxix - 1); |
1480 |
} |
1481 |
|
1482 |
cx = &ccstack[cxix]; |
1483 |
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { |
1484 |
dbcxix = dopoptosub_at(ccstack, cxix - 1); |
1485 |
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the |
1486 |
field below is defined for any cx. */ |
1487 |
/* caller() should not report the automatic calls to &DB::sub */ |
1488 |
if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) |
1489 |
cx = &ccstack[dbcxix]; |
1490 |
} |
1491 |
|
1492 |
stashname = CopSTASHPV(cx->blk_oldcop); |
1493 |
if (GIMME != G_ARRAY) { |
1494 |
EXTEND(SP, 1); |
1495 |
if (!stashname) |
1496 |
PUSHs(&PL_sv_undef); |
1497 |
else { |
1498 |
dTARGET; |
1499 |
sv_setpv(TARG, stashname); |
1500 |
PUSHs(TARG); |
1501 |
} |
1502 |
RETURN; |
1503 |
} |
1504 |
|
1505 |
EXTEND(SP, 10); |
1506 |
|
1507 |
if (!stashname) |
1508 |
PUSHs(&PL_sv_undef); |
1509 |
else |
1510 |
PUSHs(sv_2mortal(newSVpv(stashname, 0))); |
1511 |
PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0))); |
1512 |
PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); |
1513 |
if (!MAXARG) |
1514 |
RETURN; |
1515 |
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { |
1516 |
GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv); |
1517 |
/* So is ccstack[dbcxix]. */ |
1518 |
if (isGV(cvgv)) { |
1519 |
sv = NEWSV(49, 0); |
1520 |
gv_efullname3(sv, cvgv, Nullch); |
1521 |
PUSHs(sv_2mortal(sv)); |
1522 |
PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); |
1523 |
} |
1524 |
else { |
1525 |
PUSHs(sv_2mortal(newSVpvn("(unknown)",9))); |
1526 |
PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); |
1527 |
} |
1528 |
} |
1529 |
else { |
1530 |
PUSHs(sv_2mortal(newSVpvn("(eval)",6))); |
1531 |
PUSHs(sv_2mortal(newSViv(0))); |
1532 |
} |
1533 |
gimme = (I32)cx->blk_gimme; |
1534 |
if (gimme == G_VOID) |
1535 |
PUSHs(&PL_sv_undef); |
1536 |
else |
1537 |
PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); |
1538 |
if (CxTYPE(cx) == CXt_EVAL) { |
1539 |
/* eval STRING */ |
1540 |
if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { |
1541 |
PUSHs(cx->blk_eval.cur_text); |
1542 |
PUSHs(&PL_sv_no); |
1543 |
} |
1544 |
/* require */ |
1545 |
else if (cx->blk_eval.old_namesv) { |
1546 |
PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); |
1547 |
PUSHs(&PL_sv_yes); |
1548 |
} |
1549 |
/* eval BLOCK (try blocks have old_namesv == 0) */ |
1550 |
else { |
1551 |
PUSHs(&PL_sv_undef); |
1552 |
PUSHs(&PL_sv_undef); |
1553 |
} |
1554 |
} |
1555 |
else { |
1556 |
PUSHs(&PL_sv_undef); |
1557 |
PUSHs(&PL_sv_undef); |
1558 |
} |
1559 |
if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs |
1560 |
&& CopSTASH_eq(PL_curcop, PL_debstash)) |
1561 |
{ |
1562 |
AV *ary = cx->blk_sub.argarray; |
1563 |
int off = AvARRAY(ary) - AvALLOC(ary); |
1564 |
|
1565 |
if (!PL_dbargs) { |
1566 |
GV* tmpgv; |
1567 |
PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, |
1568 |
SVt_PVAV))); |
1569 |
GvMULTI_on(tmpgv); |
1570 |
AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ |
1571 |
} |
1572 |
|
1573 |
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) |
1574 |
av_extend(PL_dbargs, AvFILLp(ary) + off); |
1575 |
Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); |
1576 |
AvFILLp(PL_dbargs) = AvFILLp(ary) + off; |
1577 |
} |
1578 |
/* XXX only hints propagated via op_private are currently |
1579 |
* visible (others are not easily accessible, since they |
1580 |
* use the global PL_hints) */ |
1581 |
PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & |
1582 |
HINT_PRIVATE_MASK))); |
1583 |
{ |
1584 |
SV * mask ; |
1585 |
SV * old_warnings = cx->blk_oldcop->cop_warnings ; |
1586 |
|
1587 |
if (old_warnings == pWARN_NONE || |
1588 |
(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) |
1589 |
mask = newSVpvn(WARN_NONEstring, WARNsize) ; |
1590 |
else if (old_warnings == pWARN_ALL || |
1591 |
(old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { |
1592 |
/* Get the bit mask for $warnings::Bits{all}, because |
1593 |
* it could have been extended by warnings::register */ |
1594 |
SV **bits_all; |
1595 |
HV *bits = get_hv("warnings::Bits", FALSE); |
1596 |
if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { |
1597 |
mask = newSVsv(*bits_all); |
1598 |
} |
1599 |
else { |
1600 |
mask = newSVpvn(WARN_ALLstring, WARNsize) ; |
1601 |
} |
1602 |
} |
1603 |
else |
1604 |
mask = newSVsv(old_warnings); |
1605 |
PUSHs(sv_2mortal(mask)); |
1606 |
} |
1607 |
RETURN; |
1608 |
} |
1609 |
|
1610 |
PP(pp_reset) |
1611 |
{ |
1612 |
dSP; |
1613 |
char *tmps; |
1614 |
STRLEN n_a; |
1615 |
|
1616 |
if (MAXARG < 1) |
1617 |
tmps = ""; |
1618 |
else |
1619 |
tmps = POPpx; |
1620 |
sv_reset(tmps, CopSTASH(PL_curcop)); |
1621 |
PUSHs(&PL_sv_yes); |
1622 |
RETURN; |
1623 |
} |
1624 |
|
1625 |
PP(pp_lineseq) |
1626 |
{ |
1627 |
return NORMAL; |
1628 |
} |
1629 |
|
1630 |
/* like pp_nextstate, but used instead when the debugger is active */ |
1631 |
|
1632 |
PP(pp_dbstate) |
1633 |
{ |
1634 |
PL_curcop = (COP*)PL_op; |
1635 |
TAINT_NOT; /* Each statement is presumed innocent */ |
1636 |
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; |
1637 |
FREETMPS; |
1638 |
|
1639 |
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ |
1640 |
|| SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) |
1641 |
{ |
1642 |
dSP; |
1643 |
register CV *cv; |
1644 |
register PERL_CONTEXT *cx; |
1645 |
I32 gimme = G_ARRAY; |
1646 |
U8 hasargs; |
1647 |
GV *gv; |
1648 |
|
1649 |
gv = PL_DBgv; |
1650 |
cv = GvCV(gv); |
1651 |
if (!cv) |
1652 |
DIE(aTHX_ "No DB::DB routine defined"); |
1653 |
|
1654 |
if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) |
1655 |
/* don't do recursive DB::DB call */ |
1656 |
return NORMAL; |
1657 |
|
1658 |
ENTER; |
1659 |
SAVETMPS; |
1660 |
|
1661 |
SAVEI32(PL_debug); |
1662 |
SAVESTACK_POS(); |
1663 |
PL_debug = 0; |
1664 |
hasargs = 0; |
1665 |
SPAGAIN; |
1666 |
|
1667 |
push_return(PL_op->op_next); |
1668 |
PUSHBLOCK(cx, CXt_SUB, SP); |
1669 |
PUSHSUB_DB(cx); |
1670 |
CvDEPTH(cv)++; |
1671 |
PAD_SET_CUR(CvPADLIST(cv),1); |
1672 |
RETURNOP(CvSTART(cv)); |
1673 |
} |
1674 |
else |
1675 |
return NORMAL; |
1676 |
} |
1677 |
|
1678 |
PP(pp_scope) |
1679 |
{ |
1680 |
return NORMAL; |
1681 |
} |
1682 |
|
1683 |
PP(pp_enteriter) |
1684 |
{ |
1685 |
dSP; dMARK; |
1686 |
register PERL_CONTEXT *cx; |
1687 |
I32 gimme = GIMME_V; |
1688 |
SV **svp; |
1689 |
U32 cxtype = CXt_LOOP; |
1690 |
#ifdef USE_ITHREADS |
1691 |
void *iterdata; |
1692 |
#endif |
1693 |
|
1694 |
ENTER; |
1695 |
SAVETMPS; |
1696 |
|
1697 |
#ifdef USE_5005THREADS |
1698 |
if (PL_op->op_flags & OPf_SPECIAL) { |
1699 |
svp = &THREADSV(PL_op->op_targ); /* per-thread variable */ |
1700 |
SAVEGENERICSV(*svp); |
1701 |
*svp = NEWSV(0,0); |
1702 |
} |
1703 |
else |
1704 |
#endif /* USE_5005THREADS */ |
1705 |
if (PL_op->op_targ) { |
1706 |
#ifndef USE_ITHREADS |
1707 |
svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ |
1708 |
SAVESPTR(*svp); |
1709 |
#else |
1710 |
SAVEPADSV(PL_op->op_targ); |
1711 |
iterdata = INT2PTR(void*, PL_op->op_targ); |
1712 |
cxtype |= CXp_PADVAR; |
1713 |
#endif |
1714 |
} |
1715 |
else { |
1716 |
GV *gv = (GV*)POPs; |
1717 |
svp = &GvSV(gv); /* symbol table variable */ |
1718 |
SAVEGENERICSV(*svp); |
1719 |
*svp = NEWSV(0,0); |
1720 |
#ifdef USE_ITHREADS |
1721 |
iterdata = (void*)gv; |
1722 |
#endif |
1723 |
} |
1724 |
|
1725 |
ENTER; |
1726 |
|
1727 |
PUSHBLOCK(cx, cxtype, SP); |
1728 |
#ifdef USE_ITHREADS |
1729 |
PUSHLOOP(cx, iterdata, MARK); |
1730 |
#else |
1731 |
PUSHLOOP(cx, svp, MARK); |
1732 |
#endif |
1733 |
if (PL_op->op_flags & OPf_STACKED) { |
1734 |
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); |
1735 |
if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { |
1736 |
dPOPss; |
1737 |
SV *right = (SV*)cx->blk_loop.iterary; |
1738 |
if (RANGE_IS_NUMERIC(sv,right)) { |
1739 |
if ((SvOK(sv) && SvNV(sv) < IV_MIN) || |
1740 |
(SvOK(right) && SvNV(right) >= IV_MAX)) |
1741 |
DIE(aTHX_ "Range iterator outside integer range"); |
1742 |
cx->blk_loop.iterix = SvIV(sv); |
1743 |
cx->blk_loop.itermax = SvIV(right); |
1744 |
} |
1745 |
else { |
1746 |
STRLEN n_a; |
1747 |
cx->blk_loop.iterlval = newSVsv(sv); |
1748 |
(void) SvPV_force(cx->blk_loop.iterlval,n_a); |
1749 |
(void) SvPV(right,n_a); |
1750 |
} |
1751 |
} |
1752 |
else if (PL_op->op_private & OPpITER_REVERSED) { |
1753 |
cx->blk_loop.itermax = -1; |
1754 |
cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary); |
1755 |
|
1756 |
} |
1757 |
} |
1758 |
else { |
1759 |
cx->blk_loop.iterary = PL_curstack; |
1760 |
AvFILLp(PL_curstack) = SP - PL_stack_base; |
1761 |
if (PL_op->op_private & OPpITER_REVERSED) { |
1762 |
cx->blk_loop.itermax = MARK - PL_stack_base; |
1763 |
cx->blk_loop.iterix = cx->blk_oldsp; |
1764 |
} |
1765 |
else { |
1766 |
cx->blk_loop.iterix = MARK - PL_stack_base; |
1767 |
} |
1768 |
} |
1769 |
|
1770 |
RETURN; |
1771 |
} |
1772 |
|
1773 |
PP(pp_enterloop) |
1774 |
{ |
1775 |
dSP; |
1776 |
register PERL_CONTEXT *cx; |
1777 |
I32 gimme = GIMME_V; |
1778 |
|
1779 |
ENTER; |
1780 |
SAVETMPS; |
1781 |
ENTER; |
1782 |
|
1783 |
PUSHBLOCK(cx, CXt_LOOP, SP); |
1784 |
PUSHLOOP(cx, 0, SP); |
1785 |
|
1786 |
RETURN; |
1787 |
} |
1788 |
|
1789 |
PP(pp_leaveloop) |
1790 |
{ |
1791 |
dSP; |
1792 |
register PERL_CONTEXT *cx; |
1793 |
I32 gimme; |
1794 |
SV **newsp; |
1795 |
PMOP *newpm; |
1796 |
SV **mark; |
1797 |
|
1798 |
POPBLOCK(cx,newpm); |
1799 |
mark = newsp; |
1800 |
newsp = PL_stack_base + cx->blk_loop.resetsp; |
1801 |
|
1802 |
TAINT_NOT; |
1803 |
if (gimme == G_VOID) |
1804 |
; /* do nothing */ |
1805 |
else if (gimme == G_SCALAR) { |
1806 |
if (mark < SP) |
1807 |
*++newsp = sv_mortalcopy(*SP); |
1808 |
else |
1809 |
*++newsp = &PL_sv_undef; |
1810 |
} |
1811 |
else { |
1812 |
while (mark < SP) { |
1813 |
*++newsp = sv_mortalcopy(*++mark); |
1814 |
TAINT_NOT; /* Each item is independent */ |
1815 |
} |
1816 |
} |
1817 |
SP = newsp; |
1818 |
PUTBACK; |
1819 |
|
1820 |
POPLOOP(cx); /* Stack values are safe: release loop vars ... */ |
1821 |
PL_curpm = newpm; /* ... and pop $1 et al */ |
1822 |
|
1823 |
LEAVE; |
1824 |
LEAVE; |
1825 |
|
1826 |
return NORMAL; |
1827 |
} |
1828 |
|
1829 |
PP(pp_return) |
1830 |
{ |
1831 |
dSP; dMARK; |
1832 |
I32 cxix; |
1833 |
register PERL_CONTEXT *cx; |
1834 |
bool popsub2 = FALSE; |
1835 |
bool clear_errsv = FALSE; |
1836 |
I32 gimme; |
1837 |
SV **newsp; |
1838 |
PMOP *newpm; |
1839 |
I32 optype = 0; |
1840 |
SV *sv; |
1841 |
|
1842 |
if (PL_curstackinfo->si_type == PERLSI_SORT) { |
1843 |
if (cxstack_ix == PL_sortcxix |
1844 |
|| dopoptosub(cxstack_ix) <= PL_sortcxix) |
1845 |
{ |
1846 |
if (cxstack_ix > PL_sortcxix) |
1847 |
dounwind(PL_sortcxix); |
1848 |
AvARRAY(PL_curstack)[1] = *SP; |
1849 |
PL_stack_sp = PL_stack_base + 1; |
1850 |
return 0; |
1851 |
} |
1852 |
} |
1853 |
|
1854 |
cxix = dopoptosub(cxstack_ix); |
1855 |
if (cxix < 0) |
1856 |
DIE(aTHX_ "Can't return outside a subroutine"); |
1857 |
if (cxix < cxstack_ix) |
1858 |
dounwind(cxix); |
1859 |
|
1860 |
POPBLOCK(cx,newpm); |
1861 |
switch (CxTYPE(cx)) { |
1862 |
case CXt_SUB: |
1863 |
popsub2 = TRUE; |
1864 |
cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ |
1865 |
break; |
1866 |
case CXt_EVAL: |
1867 |
if (!(PL_in_eval & EVAL_KEEPERR)) |
1868 |
clear_errsv = TRUE; |
1869 |
POPEVAL(cx); |
1870 |
if (CxTRYBLOCK(cx)) |
1871 |
break; |
1872 |
lex_end(); |
1873 |
if (optype == OP_REQUIRE && |
1874 |
(MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) |
1875 |
{ |
1876 |
/* Unassume the success we assumed earlier. */ |
1877 |
SV *nsv = cx->blk_eval.old_namesv; |
1878 |
(void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); |
1879 |
DIE(aTHX_ "%"SVf" did not return a true value", nsv); |
1880 |
} |
1881 |
break; |
1882 |
case CXt_FORMAT: |
1883 |
POPFORMAT(cx); |
1884 |
break; |
1885 |
default: |
1886 |
DIE(aTHX_ "panic: return"); |
1887 |
} |
1888 |
|
1889 |
TAINT_NOT; |
1890 |
if (gimme == G_SCALAR) { |
1891 |
if (MARK < SP) { |
1892 |
if (popsub2) { |
1893 |
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { |
1894 |
if (SvTEMP(TOPs)) { |
1895 |
*++newsp = SvREFCNT_inc(*SP); |
1896 |
FREETMPS; |
1897 |
sv_2mortal(*newsp); |
1898 |
} |
1899 |
else { |
1900 |
sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ |
1901 |
FREETMPS; |
1902 |
*++newsp = sv_mortalcopy(sv); |
1903 |
SvREFCNT_dec(sv); |
1904 |
} |
1905 |
} |
1906 |
else |
1907 |
*++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); |
1908 |
} |
1909 |
else |
1910 |
*++newsp = sv_mortalcopy(*SP); |
1911 |
} |
1912 |
else |
1913 |
*++newsp = &PL_sv_undef; |
1914 |
} |
1915 |
else if (gimme == G_ARRAY) { |
1916 |
while (++MARK <= SP) { |
1917 |
*++newsp = (popsub2 && SvTEMP(*MARK)) |
1918 |
? *MARK : sv_mortalcopy(*MARK); |
1919 |
TAINT_NOT; /* Each item is independent */ |
1920 |
} |
1921 |
} |
1922 |
PL_stack_sp = newsp; |
1923 |
|
1924 |
LEAVE; |
1925 |
/* Stack values are safe: */ |
1926 |
if (popsub2) { |
1927 |
cxstack_ix--; |
1928 |
POPSUB(cx,sv); /* release CV and @_ ... */ |
1929 |
} |
1930 |
else |
1931 |
sv = Nullsv; |
1932 |
PL_curpm = newpm; /* ... and pop $1 et al */ |
1933 |
|
1934 |
LEAVESUB(sv); |
1935 |
if (clear_errsv) |
1936 |
sv_setpv(ERRSV,""); |
1937 |
return pop_return(); |
1938 |
} |
1939 |
|
1940 |
PP(pp_last) |
1941 |
{ |
1942 |
dSP; |
1943 |
I32 cxix; |
1944 |
register PERL_CONTEXT *cx; |
1945 |
I32 pop2 = 0; |
1946 |
I32 gimme; |
1947 |
I32 optype; |
1948 |
OP *nextop; |
1949 |
SV **newsp; |
1950 |
PMOP *newpm; |
1951 |
SV **mark; |
1952 |
SV *sv = Nullsv; |
1953 |
|
1954 |
if (PL_op->op_flags & OPf_SPECIAL) { |
1955 |
cxix = dopoptoloop(cxstack_ix); |
1956 |
if (cxix < 0) |
1957 |
DIE(aTHX_ "Can't \"last\" outside a loop block"); |
1958 |
} |
1959 |
else { |
1960 |
cxix = dopoptolabel(cPVOP->op_pv); |
1961 |
if (cxix < 0) |
1962 |
DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv); |
1963 |
} |
1964 |
if (cxix < cxstack_ix) |
1965 |
dounwind(cxix); |
1966 |
|
1967 |
POPBLOCK(cx,newpm); |
1968 |
cxstack_ix++; /* temporarily protect top context */ |
1969 |
mark = newsp; |
1970 |
switch (CxTYPE(cx)) { |
1971 |
case CXt_LOOP: |
1972 |
pop2 = CXt_LOOP; |
1973 |
newsp = PL_stack_base + cx->blk_loop.resetsp; |
1974 |
nextop = cx->blk_loop.last_op->op_next; |
1975 |
break; |
1976 |
case CXt_SUB: |
1977 |
pop2 = CXt_SUB; |
1978 |
nextop = pop_return(); |
1979 |
break; |
1980 |
case CXt_EVAL: |
1981 |
POPEVAL(cx); |
1982 |
nextop = pop_return(); |
1983 |
break; |
1984 |
case CXt_FORMAT: |
1985 |
POPFORMAT(cx); |
1986 |
nextop = pop_return(); |
1987 |
break; |
1988 |
default: |
1989 |
DIE(aTHX_ "panic: last"); |
1990 |
} |
1991 |
|
1992 |
TAINT_NOT; |
1993 |
if (gimme == G_SCALAR) { |
1994 |
if (MARK < SP) |
1995 |
*++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) |
1996 |
? *SP : sv_mortalcopy(*SP); |
1997 |
else |
1998 |
*++newsp = &PL_sv_undef; |
1999 |
} |
2000 |
else if (gimme == G_ARRAY) { |
2001 |
while (++MARK <= SP) { |
2002 |
*++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) |
2003 |
? *MARK : sv_mortalcopy(*MARK); |
2004 |
TAINT_NOT; /* Each item is independent */ |
2005 |
} |
2006 |
} |
2007 |
SP = newsp; |
2008 |
PUTBACK; |
2009 |
|
2010 |
LEAVE; |
2011 |
cxstack_ix--; |
2012 |
/* Stack values are safe: */ |
2013 |
switch (pop2) { |
2014 |
case CXt_LOOP: |
2015 |
POPLOOP(cx); /* release loop vars ... */ |
2016 |
LEAVE; |
2017 |
break; |
2018 |
case CXt_SUB: |
2019 |
POPSUB(cx,sv); /* release CV and @_ ... */ |
2020 |
break; |
2021 |
} |
2022 |
PL_curpm = newpm; /* ... and pop $1 et al */ |
2023 |
|
2024 |
LEAVESUB(sv); |
2025 |
return nextop; |
2026 |
} |
2027 |
|
2028 |
PP(pp_next) |
2029 |
{ |
2030 |
I32 cxix; |
2031 |
register PERL_CONTEXT *cx; |
2032 |
I32 inner; |
2033 |
|
2034 |
if (PL_op->op_flags & OPf_SPECIAL) { |
2035 |
cxix = dopoptoloop(cxstack_ix); |
2036 |
if (cxix < 0) |
2037 |
DIE(aTHX_ "Can't \"next\" outside a loop block"); |
2038 |
} |
2039 |
else { |
2040 |
cxix = dopoptolabel(cPVOP->op_pv); |
2041 |
if (cxix < 0) |
2042 |
DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv); |
2043 |
} |
2044 |
if (cxix < cxstack_ix) |
2045 |
dounwind(cxix); |
2046 |
|
2047 |
/* clear off anything above the scope we're re-entering, but |
2048 |
* save the rest until after a possible continue block */ |
2049 |
inner = PL_scopestack_ix; |
2050 |
TOPBLOCK(cx); |
2051 |
if (PL_scopestack_ix < inner) |
2052 |
leave_scope(PL_scopestack[PL_scopestack_ix]); |
2053 |
return cx->blk_loop.next_op; |
2054 |
} |
2055 |
|
2056 |
PP(pp_redo) |
2057 |
{ |
2058 |
I32 cxix; |
2059 |
register PERL_CONTEXT *cx; |
2060 |
I32 oldsave; |
2061 |
|
2062 |
if (PL_op->op_flags & OPf_SPECIAL) { |
2063 |
cxix = dopoptoloop(cxstack_ix); |
2064 |
if (cxix < 0) |
2065 |
DIE(aTHX_ "Can't \"redo\" outside a loop block"); |
2066 |
} |
2067 |
else { |
2068 |
cxix = dopoptolabel(cPVOP->op_pv); |
2069 |
if (cxix < 0) |
2070 |
DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv); |
2071 |
} |
2072 |
if (cxix < cxstack_ix) |
2073 |
dounwind(cxix); |
2074 |
|
2075 |
TOPBLOCK(cx); |
2076 |
oldsave = PL_scopestack[PL_scopestack_ix - 1]; |
2077 |
LEAVE_SCOPE(oldsave); |
2078 |
FREETMPS; |
2079 |
return cx->blk_loop.redo_op; |
2080 |
} |
2081 |
|
2082 |
STATIC OP * |
2083 |
S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) |
2084 |
{ |
2085 |
OP *kid = Nullop; |
2086 |
OP **ops = opstack; |
2087 |
static char too_deep[] = "Target of goto is too deeply nested"; |
2088 |
|
2089 |
if (ops >= oplimit) |
2090 |
Perl_croak(aTHX_ too_deep); |
2091 |
if (o->op_type == OP_LEAVE || |
2092 |
o->op_type == OP_SCOPE || |
2093 |
o->op_type == OP_LEAVELOOP || |
2094 |
o->op_type == OP_LEAVESUB || |
2095 |
o->op_type == OP_LEAVETRY) |
2096 |
{ |
2097 |
*ops++ = cUNOPo->op_first; |
2098 |
if (ops >= oplimit) |
2099 |
Perl_croak(aTHX_ too_deep); |
2100 |
} |
2101 |
*ops = 0; |
2102 |
if (o->op_flags & OPf_KIDS) { |
2103 |
/* First try all the kids at this level, since that's likeliest. */ |
2104 |
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { |
2105 |
if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && |
2106 |
kCOP->cop_label && strEQ(kCOP->cop_label, label)) |
2107 |
return kid; |
2108 |
} |
2109 |
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { |
2110 |
if (kid == PL_lastgotoprobe) |
2111 |
continue; |
2112 |
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { |
2113 |
if (ops == opstack) |
2114 |
*ops++ = kid; |
2115 |
else if (ops[-1]->op_type == OP_NEXTSTATE || |
2116 |
ops[-1]->op_type == OP_DBSTATE) |
2117 |
ops[-1] = kid; |
2118 |
else |
2119 |
*ops++ = kid; |
2120 |
} |
2121 |
if ((o = dofindlabel(kid, label, ops, oplimit))) |
2122 |
return o; |
2123 |
} |
2124 |
} |
2125 |
*ops = 0; |
2126 |
return 0; |
2127 |
} |
2128 |
|
2129 |
PP(pp_dump) |
2130 |
{ |
2131 |
return pp_goto(); |
2132 |
/*NOTREACHED*/ |
2133 |
} |
2134 |
|
2135 |
PP(pp_goto) |
2136 |
{ |
2137 |
dSP; |
2138 |
OP *retop = 0; |
2139 |
I32 ix; |
2140 |
register PERL_CONTEXT *cx; |
2141 |
#define GOTO_DEPTH 64 |
2142 |
OP *enterops[GOTO_DEPTH]; |
2143 |
char *label; |
2144 |
int do_dump = (PL_op->op_type == OP_DUMP); |
2145 |
static char must_have_label[] = "goto must have label"; |
2146 |
|
2147 |
label = 0; |
2148 |
if (PL_op->op_flags & OPf_STACKED) { |
2149 |
SV *sv = POPs; |
2150 |
STRLEN n_a; |
2151 |
|
2152 |
/* This egregious kludge implements goto &subroutine */ |
2153 |
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { |
2154 |
I32 cxix; |
2155 |
register PERL_CONTEXT *cx; |
2156 |
CV* cv = (CV*)SvRV(sv); |
2157 |
SV** mark; |
2158 |
I32 items = 0; |
2159 |
I32 oldsave; |
2160 |
bool reified = 0; |
2161 |
|
2162 |
retry: |
2163 |
if (!CvROOT(cv) && !CvXSUB(cv)) { |
2164 |
GV *gv = CvGV(cv); |
2165 |
GV *autogv; |
2166 |
if (gv) { |
2167 |
SV *tmpstr; |
2168 |
/* autoloaded stub? */ |
2169 |
if (cv != GvCV(gv) && (cv = GvCV(gv))) |
2170 |
goto retry; |
2171 |
autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), |
2172 |
GvNAMELEN(gv), FALSE); |
2173 |
if (autogv && (cv = GvCV(autogv))) |
2174 |
goto retry; |
2175 |
tmpstr = sv_newmortal(); |
2176 |
gv_efullname3(tmpstr, gv, Nullch); |
2177 |
DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr); |
2178 |
} |
2179 |
DIE(aTHX_ "Goto undefined subroutine"); |
2180 |
} |
2181 |
|
2182 |
/* First do some returnish stuff. */ |
2183 |
SvREFCNT_inc(cv); /* avoid premature free during unwind */ |
2184 |
FREETMPS; |
2185 |
cxix = dopoptosub(cxstack_ix); |
2186 |
if (cxix < 0) |
2187 |
DIE(aTHX_ "Can't goto subroutine outside a subroutine"); |
2188 |
if (cxix < cxstack_ix) |
2189 |
dounwind(cxix); |
2190 |
TOPBLOCK(cx); |
2191 |
if (CxREALEVAL(cx)) |
2192 |
DIE(aTHX_ "Can't goto subroutine from an eval-string"); |
2193 |
if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { |
2194 |
/* put @_ back onto stack */ |
2195 |
AV* av = cx->blk_sub.argarray; |
2196 |
|
2197 |
items = AvFILLp(av) + 1; |
2198 |
EXTEND(SP, items+1); /* @_ could have been extended. */ |
2199 |
Copy(AvARRAY(av), SP + 1, items, SV*); |
2200 |
#ifndef USE_5005THREADS |
2201 |
SvREFCNT_dec(GvAV(PL_defgv)); |
2202 |
GvAV(PL_defgv) = cx->blk_sub.savearray; |
2203 |
#endif /* USE_5005THREADS */ |
2204 |
CLEAR_ARGARRAY(av); |
2205 |
/* abandon @_ if it got reified */ |
2206 |
if (AvREAL(av)) { |
2207 |
reified = 1; |
2208 |
SvREFCNT_dec(av); |
2209 |
av = newAV(); |
2210 |
av_extend(av, items-1); |
2211 |
AvFLAGS(av) = AVf_REIFY; |
2212 |
PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av); |
2213 |
} |
2214 |
} |
2215 |
else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ |
2216 |
AV* av; |
2217 |
#ifdef USE_5005THREADS |
2218 |
av = (AV*)PAD_SVl(0); |
2219 |
#else |
2220 |
av = GvAV(PL_defgv); |
2221 |
#endif |
2222 |
items = AvFILLp(av) + 1; |
2223 |
EXTEND(SP, items+1); /* @_ could have been extended. */ |
2224 |
Copy(AvARRAY(av), SP + 1, items, SV*); |
2225 |
} |
2226 |
mark = SP; |
2227 |
SP += items; |
2228 |
if (CxTYPE(cx) == CXt_SUB && |
2229 |
!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) |
2230 |
SvREFCNT_dec(cx->blk_sub.cv); |
2231 |
oldsave = PL_scopestack[PL_scopestack_ix - 1]; |
2232 |
LEAVE_SCOPE(oldsave); |
2233 |
|
2234 |
/* Now do some callish stuff. */ |
2235 |
SAVETMPS; |
2236 |
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ |
2237 |
if (CvXSUB(cv)) { |
2238 |
if (reified) { |
2239 |
I32 index; |
2240 |
for (index=0; index<items; index++) |
2241 |
sv_2mortal(SP[-index]); |
2242 |
} |
2243 |
#ifdef PERL_XSUB_OLDSTYLE |
2244 |
if (CvOLDSTYLE(cv)) { |
2245 |
I32 (*fp3)(int,int,int); |
2246 |
while (SP > mark) { |
2247 |
SP[1] = SP[0]; |
2248 |
SP--; |
2249 |
} |
2250 |
fp3 = (I32(*)(int,int,int))CvXSUB(cv); |
2251 |
items = (*fp3)(CvXSUBANY(cv).any_i32, |
2252 |
mark - PL_stack_base + 1, |
2253 |
items); |
2254 |
SP = PL_stack_base + items; |
2255 |
} |
2256 |
else |
2257 |
#endif /* PERL_XSUB_OLDSTYLE */ |
2258 |
{ |
2259 |
SV **newsp; |
2260 |
I32 gimme; |
2261 |
|
2262 |
/* Push a mark for the start of arglist */ |
2263 |
PUSHMARK(mark); |
2264 |
PUTBACK; |
2265 |
(void)(*CvXSUB(cv))(aTHX_ cv); |
2266 |
/* Pop the current context like a decent sub should */ |
2267 |
POPBLOCK(cx, PL_curpm); |
2268 |
/* Do _not_ use PUTBACK, keep the XSUB's return stack! */ |
2269 |
} |
2270 |
LEAVE; |
2271 |
return pop_return(); |
2272 |
} |
2273 |
else { |
2274 |
AV* padlist = CvPADLIST(cv); |
2275 |
if (CxTYPE(cx) == CXt_EVAL) { |
2276 |
PL_in_eval = cx->blk_eval.old_in_eval; |
2277 |
PL_eval_root = cx->blk_eval.old_eval_root; |
2278 |
cx->cx_type = CXt_SUB; |
2279 |
cx->blk_sub.hasargs = 0; |
2280 |
} |
2281 |
cx->blk_sub.cv = cv; |
2282 |
cx->blk_sub.olddepth = (U16)CvDEPTH(cv); |
2283 |
|
2284 |
CvDEPTH(cv)++; |
2285 |
if (CvDEPTH(cv) < 2) |
2286 |
(void)SvREFCNT_inc(cv); |
2287 |
else { |
2288 |
if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) |
2289 |
sub_crush_depth(cv); |
2290 |
pad_push(padlist, CvDEPTH(cv), 1); |
2291 |
} |
2292 |
#ifdef USE_5005THREADS |
2293 |
if (!cx->blk_sub.hasargs) { |
2294 |
AV* av = (AV*)PAD_SVl(0); |
2295 |
|
2296 |
items = AvFILLp(av) + 1; |
2297 |
if (items) { |
2298 |
/* Mark is at the end of the stack. */ |
2299 |
EXTEND(SP, items); |
2300 |
Copy(AvARRAY(av), SP + 1, items, SV*); |
2301 |
SP += items; |
2302 |
PUTBACK ; |
2303 |
} |
2304 |
} |
2305 |
#endif /* USE_5005THREADS */ |
2306 |
PAD_SET_CUR(padlist, CvDEPTH(cv)); |
2307 |
#ifndef USE_5005THREADS |
2308 |
if (cx->blk_sub.hasargs) |
2309 |
#endif /* USE_5005THREADS */ |
2310 |
{ |
2311 |
AV* av = (AV*)PAD_SVl(0); |
2312 |
SV** ary; |
2313 |
|
2314 |
#ifndef USE_5005THREADS |
2315 |
cx->blk_sub.savearray = GvAV(PL_defgv); |
2316 |
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); |
2317 |
#endif /* USE_5005THREADS */ |
2318 |
CX_CURPAD_SAVE(cx->blk_sub); |
2319 |
cx->blk_sub.argarray = av; |
2320 |
|
2321 |
if (items >= AvMAX(av) + 1) { |
2322 |
ary = AvALLOC(av); |
2323 |
if (AvARRAY(av) != ary) { |
2324 |
AvMAX(av) += AvARRAY(av) - AvALLOC(av); |
2325 |
SvPVX(av) = (char*)ary; |
2326 |
} |
2327 |
if (items >= AvMAX(av) + 1) { |
2328 |
AvMAX(av) = items - 1; |
2329 |
Renew(ary,items+1,SV*); |
2330 |
AvALLOC(av) = ary; |
2331 |
SvPVX(av) = (char*)ary; |
2332 |
} |
2333 |
} |
2334 |
++mark; |
2335 |
Copy(mark,AvARRAY(av),items,SV*); |
2336 |
AvFILLp(av) = items - 1; |
2337 |
assert(!AvREAL(av)); |
2338 |
if (reified) { |
2339 |
/* transfer 'ownership' of refcnts to new @_ */ |
2340 |
AvREAL_on(av); |
2341 |
AvREIFY_off(av); |
2342 |
} |
2343 |
while (items--) { |
2344 |
if (*mark) |
2345 |
SvTEMP_off(*mark); |
2346 |
mark++; |
2347 |
} |
2348 |
} |
2349 |
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ |
2350 |
/* |
2351 |
* We do not care about using sv to call CV; |
2352 |
* it's for informational purposes only. |
2353 |
*/ |
2354 |
SV *sv = GvSV(PL_DBsub); |
2355 |
CV *gotocv; |
2356 |
|
2357 |
if (PERLDB_SUB_NN) { |
2358 |
(void)SvUPGRADE(sv, SVt_PVIV); |
2359 |
(void)SvIOK_on(sv); |
2360 |
SAVEIV(SvIVX(sv)); |
2361 |
SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */ |
2362 |
} else { |
2363 |
save_item(sv); |
2364 |
gv_efullname3(sv, CvGV(cv), Nullch); |
2365 |
} |
2366 |
if ( PERLDB_GOTO |
2367 |
&& (gotocv = get_cv("DB::goto", FALSE)) ) { |
2368 |
PUSHMARK( PL_stack_sp ); |
2369 |
call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); |
2370 |
PL_stack_sp--; |
2371 |
} |
2372 |
} |
2373 |
RETURNOP(CvSTART(cv)); |
2374 |
} |
2375 |
} |
2376 |
else { |
2377 |
label = SvPV(sv,n_a); |
2378 |
if (!(do_dump || *label)) |
2379 |
DIE(aTHX_ must_have_label); |
2380 |
} |
2381 |
} |
2382 |
else if (PL_op->op_flags & OPf_SPECIAL) { |
2383 |
if (! do_dump) |
2384 |
DIE(aTHX_ must_have_label); |
2385 |
} |
2386 |
else |
2387 |
label = cPVOP->op_pv; |
2388 |
|
2389 |
if (label && *label) { |
2390 |
OP *gotoprobe = 0; |
2391 |
bool leaving_eval = FALSE; |
2392 |
bool in_block = FALSE; |
2393 |
PERL_CONTEXT *last_eval_cx = 0; |
2394 |
|
2395 |
/* find label */ |
2396 |
|
2397 |
PL_lastgotoprobe = 0; |
2398 |
*enterops = 0; |
2399 |
for (ix = cxstack_ix; ix >= 0; ix--) { |
2400 |
cx = &cxstack[ix]; |
2401 |
switch (CxTYPE(cx)) { |
2402 |
case CXt_EVAL: |
2403 |
leaving_eval = TRUE; |
2404 |
if (!CxTRYBLOCK(cx)) { |
2405 |
gotoprobe = (last_eval_cx ? |
2406 |
last_eval_cx->blk_eval.old_eval_root : |
2407 |
PL_eval_root); |
2408 |
last_eval_cx = cx; |
2409 |
break; |
2410 |
} |
2411 |
/* else fall through */ |
2412 |
case CXt_LOOP: |
2413 |
gotoprobe = cx->blk_oldcop->op_sibling; |
2414 |
break; |
2415 |
case CXt_SUBST: |
2416 |
continue; |
2417 |
case CXt_BLOCK: |
2418 |
if (ix) { |
2419 |
gotoprobe = cx->blk_oldcop->op_sibling; |
2420 |
in_block = TRUE; |
2421 |
} else |
2422 |
gotoprobe = PL_main_root; |
2423 |
break; |
2424 |
case CXt_SUB: |
2425 |
if (CvDEPTH(cx->blk_sub.cv)) { |
2426 |
gotoprobe = CvROOT(cx->blk_sub.cv); |
2427 |
break; |
2428 |
} |
2429 |
/* FALL THROUGH */ |
2430 |
case CXt_FORMAT: |
2431 |
case CXt_NULL: |
2432 |
DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); |
2433 |
default: |
2434 |
if (ix) |
2435 |
DIE(aTHX_ "panic: goto"); |
2436 |
gotoprobe = PL_main_root; |
2437 |
break; |
2438 |
} |
2439 |
if (gotoprobe) { |
2440 |
retop = dofindlabel(gotoprobe, label, |
2441 |
enterops, enterops + GOTO_DEPTH); |
2442 |
if (retop) |
2443 |
break; |
2444 |
} |
2445 |
PL_lastgotoprobe = gotoprobe; |
2446 |
} |
2447 |
if (!retop) |
2448 |
DIE(aTHX_ "Can't find label %s", label); |
2449 |
|
2450 |
/* if we're leaving an eval, check before we pop any frames |
2451 |
that we're not going to punt, otherwise the error |
2452 |
won't be caught */ |
2453 |
|
2454 |
if (leaving_eval && *enterops && enterops[1]) { |
2455 |
I32 i; |
2456 |
for (i = 1; enterops[i]; i++) |
2457 |
if (enterops[i]->op_type == OP_ENTERITER) |
2458 |
DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); |
2459 |
} |
2460 |
|
2461 |
/* pop unwanted frames */ |
2462 |
|
2463 |
if (ix < cxstack_ix) { |
2464 |
I32 oldsave; |
2465 |
|
2466 |
if (ix < 0) |
2467 |
ix = 0; |
2468 |
dounwind(ix); |
2469 |
TOPBLOCK(cx); |
2470 |
oldsave = PL_scopestack[PL_scopestack_ix]; |
2471 |
LEAVE_SCOPE(oldsave); |
2472 |
} |
2473 |
|
2474 |
/* push wanted frames */ |
2475 |
|
2476 |
if (*enterops && enterops[1]) { |
2477 |
OP *oldop = PL_op; |
2478 |
ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; |
2479 |
for (; enterops[ix]; ix++) { |
2480 |
PL_op = enterops[ix]; |
2481 |
/* Eventually we may want to stack the needed arguments |
2482 |
* for each op. For now, we punt on the hard ones. */ |
2483 |
if (PL_op->op_type == OP_ENTERITER) |
2484 |
DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); |
2485 |
CALL_FPTR(PL_op->op_ppaddr)(aTHX); |
2486 |
} |
2487 |
PL_op = oldop; |
2488 |
} |
2489 |
} |
2490 |
|
2491 |
if (do_dump) { |
2492 |
#ifdef VMS |
2493 |
if (!retop) retop = PL_main_start; |
2494 |
#endif |
2495 |
PL_restartop = retop; |
2496 |
PL_do_undump = TRUE; |
2497 |
|
2498 |
my_unexec(); |
2499 |
|
2500 |
PL_restartop = 0; /* hmm, must be GNU unexec().. */ |
2501 |
PL_do_undump = FALSE; |
2502 |
} |
2503 |
|
2504 |
RETURNOP(retop); |
2505 |
} |
2506 |
|
2507 |
PP(pp_exit) |
2508 |
{ |
2509 |
dSP; |
2510 |
I32 anum; |
2511 |
|
2512 |
if (MAXARG < 1) |
2513 |
anum = 0; |
2514 |
else { |
2515 |
anum = SvIVx(POPs); |
2516 |
#ifdef VMS |
2517 |
if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) |
2518 |
anum = 0; |
2519 |
VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); |
2520 |
#endif |
2521 |
} |
2522 |
PL_exit_flags |= PERL_EXIT_EXPECTED; |
2523 |
my_exit(anum); |
2524 |
PUSHs(&PL_sv_undef); |
2525 |
RETURN; |
2526 |
} |
2527 |
|
2528 |
#ifdef NOTYET |
2529 |
PP(pp_nswitch) |
2530 |
{ |
2531 |
dSP; |
2532 |
NV value = SvNVx(GvSV(cCOP->cop_gv)); |
2533 |
register I32 match = I_32(value); |
2534 |
|
2535 |
if (value < 0.0) { |
2536 |
if (((NV)match) > value) |
2537 |
--match; /* was fractional--truncate other way */ |
2538 |
} |
2539 |
match -= cCOP->uop.scop.scop_offset; |
2540 |
if (match < 0) |
2541 |
match = 0; |
2542 |
else if (match > cCOP->uop.scop.scop_max) |
2543 |
match = cCOP->uop.scop.scop_max; |
2544 |
PL_op = cCOP->uop.scop.scop_next[match]; |
2545 |
RETURNOP(PL_op); |
2546 |
} |
2547 |
|
2548 |
PP(pp_cswitch) |
2549 |
{ |
2550 |
dSP; |
2551 |
register I32 match; |
2552 |
|
2553 |
if (PL_multiline) |
2554 |
PL_op = PL_op->op_next; /* can't assume anything */ |
2555 |
else { |
2556 |
STRLEN n_a; |
2557 |
match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255; |
2558 |
match -= cCOP->uop.scop.scop_offset; |
2559 |
if (match < 0) |
2560 |
match = 0; |
2561 |
else if (match > cCOP->uop.scop.scop_max) |
2562 |
match = cCOP->uop.scop.scop_max; |
2563 |
PL_op = cCOP->uop.scop.scop_next[match]; |
2564 |
} |
2565 |
RETURNOP(PL_op); |
2566 |
} |
2567 |
#endif |
2568 |
|
2569 |
/* Eval. */ |
2570 |
|
2571 |
STATIC void |
2572 |
S_save_lines(pTHX_ AV *array, SV *sv) |
2573 |
{ |
2574 |
register char *s = SvPVX(sv); |
2575 |
register char *send = SvPVX(sv) + SvCUR(sv); |
2576 |
register char *t; |
2577 |
register I32 line = 1; |
2578 |
|
2579 |
while (s && s < send) { |
2580 |
SV *tmpstr = NEWSV(85,0); |
2581 |
|
2582 |
sv_upgrade(tmpstr, SVt_PVMG); |
2583 |
t = strchr(s, '\n'); |
2584 |
if (t) |
2585 |
t++; |
2586 |
else |
2587 |
t = send; |
2588 |
|
2589 |
sv_setpvn(tmpstr, s, t - s); |
2590 |
av_store(array, line++, tmpstr); |
2591 |
s = t; |
2592 |
} |
2593 |
} |
2594 |
|
2595 |
#ifdef PERL_FLEXIBLE_EXCEPTIONS |
2596 |
STATIC void * |
2597 |
S_docatch_body(pTHX_ va_list args) |
2598 |
{ |
2599 |
return docatch_body(); |
2600 |
} |
2601 |
#endif |
2602 |
|
2603 |
STATIC void * |
2604 |
S_docatch_body(pTHX) |
2605 |
{ |
2606 |
CALLRUNOPS(aTHX); |
2607 |
return NULL; |
2608 |
} |
2609 |
|
2610 |
STATIC OP * |
2611 |
S_docatch(pTHX_ OP *o) |
2612 |
{ |
2613 |
int ret; |
2614 |
OP *oldop = PL_op; |
2615 |
OP *retop; |
2616 |
volatile PERL_SI *cursi = PL_curstackinfo; |
2617 |
dJMPENV; |
2618 |
|
2619 |
#ifdef DEBUGGING |
2620 |
assert(CATCH_GET == TRUE); |
2621 |
#endif |
2622 |
PL_op = o; |
2623 |
|
2624 |
/* Normally, the leavetry at the end of this block of ops will |
2625 |
* pop an op off the return stack and continue there. By setting |
2626 |
* the op to Nullop, we force an exit from the inner runops() |
2627 |
* loop. DAPM. |
2628 |
*/ |
2629 |
retop = pop_return(); |
2630 |
push_return(Nullop); |
2631 |
|
2632 |
#ifdef PERL_FLEXIBLE_EXCEPTIONS |
2633 |
redo_body: |
2634 |
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body)); |
2635 |
#else |
2636 |
JMPENV_PUSH(ret); |
2637 |
#endif |
2638 |
switch (ret) { |
2639 |
case 0: |
2640 |
#ifndef PERL_FLEXIBLE_EXCEPTIONS |
2641 |
redo_body: |
2642 |
docatch_body(); |
2643 |
#endif |
2644 |
break; |
2645 |
case 3: |
2646 |
/* die caught by an inner eval - continue inner loop */ |
2647 |
if (PL_restartop && cursi == PL_curstackinfo) { |
2648 |
PL_op = PL_restartop; |
2649 |
PL_restartop = 0; |
2650 |
goto redo_body; |
2651 |
} |
2652 |
/* a die in this eval - continue in outer loop */ |
2653 |
if (!PL_restartop) |
2654 |
break; |
2655 |
/* FALL THROUGH */ |
2656 |
default: |
2657 |
JMPENV_POP; |
2658 |
PL_op = oldop; |
2659 |
JMPENV_JUMP(ret); |
2660 |
/* NOTREACHED */ |
2661 |
} |
2662 |
JMPENV_POP; |
2663 |
PL_op = oldop; |
2664 |
return retop; |
2665 |
} |
2666 |
|
2667 |
OP * |
2668 |
Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) |
2669 |
/* sv Text to convert to OP tree. */ |
2670 |
/* startop op_free() this to undo. */ |
2671 |
/* code Short string id of the caller. */ |
2672 |
{ |
2673 |
dSP; /* Make POPBLOCK work. */ |
2674 |
PERL_CONTEXT *cx; |
2675 |
SV **newsp; |
2676 |
I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */ |
2677 |
I32 optype; |
2678 |
OP dummy; |
2679 |
OP *rop; |
2680 |
char tbuf[TYPE_DIGITS(long) + 12 + 10]; |
2681 |
char *tmpbuf = tbuf; |
2682 |
char *safestr; |
2683 |
int runtime; |
2684 |
CV* runcv = Nullcv; /* initialise to avoid compiler warnings */ |
2685 |
|
2686 |
ENTER; |
2687 |
lex_start(sv); |
2688 |
SAVETMPS; |
2689 |
/* switch to eval mode */ |
2690 |
|
2691 |
if (IN_PERL_COMPILETIME) { |
2692 |
SAVECOPSTASH_FREE(&PL_compiling); |
2693 |
CopSTASH_set(&PL_compiling, PL_curstash); |
2694 |
} |
2695 |
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { |
2696 |
SV *sv = sv_newmortal(); |
2697 |
Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", |
2698 |
code, (unsigned long)++PL_evalseq, |
2699 |
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); |
2700 |
tmpbuf = SvPVX(sv); |
2701 |
} |
2702 |
else |
2703 |
sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); |
2704 |
SAVECOPFILE_FREE(&PL_compiling); |
2705 |
CopFILE_set(&PL_compiling, tmpbuf+2); |
2706 |
SAVECOPLINE(&PL_compiling); |
2707 |
CopLINE_set(&PL_compiling, 1); |
2708 |
/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up |
2709 |
deleting the eval's FILEGV from the stash before gv_check() runs |
2710 |
(i.e. before run-time proper). To work around the coredump that |
2711 |
ensues, we always turn GvMULTI_on for any globals that were |
2712 |
introduced within evals. See force_ident(). GSAR 96-10-12 */ |
2713 |
safestr = savepv(tmpbuf); |
2714 |
SAVEDELETE(PL_defstash, safestr, strlen(safestr)); |
2715 |
SAVEHINTS(); |
2716 |
#ifdef OP_IN_REGISTER |
2717 |
PL_opsave = op; |
2718 |
#else |
2719 |
SAVEVPTR(PL_op); |
2720 |
#endif |
2721 |
|
2722 |
/* we get here either during compilation, or via pp_regcomp at runtime */ |
2723 |
runtime = IN_PERL_RUNTIME; |
2724 |
if (runtime) |
2725 |
runcv = find_runcv(NULL); |
2726 |
|
2727 |
PL_op = &dummy; |
2728 |
PL_op->op_type = OP_ENTEREVAL; |
2729 |
PL_op->op_flags = 0; /* Avoid uninit warning. */ |
2730 |
PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); |
2731 |
PUSHEVAL(cx, 0, Nullgv); |
2732 |
|
2733 |
if (runtime) |
2734 |
rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); |
2735 |
else |
2736 |
rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); |
2737 |
POPBLOCK(cx,PL_curpm); |
2738 |
POPEVAL(cx); |
2739 |
|
2740 |
(*startop)->op_type = OP_NULL; |
2741 |
(*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; |
2742 |
lex_end(); |
2743 |
/* XXX DAPM do this properly one year */ |
2744 |
*padp = (AV*)SvREFCNT_inc(PL_comppad); |
2745 |
LEAVE; |
2746 |
if (IN_PERL_COMPILETIME) |
2747 |
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); |
2748 |
#ifdef OP_IN_REGISTER |
2749 |
op = PL_opsave; |
2750 |
#endif |
2751 |
return rop; |
2752 |
} |
2753 |
|
2754 |
|
2755 |
/* |
2756 |
=for apidoc find_runcv |
2757 |
|
2758 |
Locate the CV corresponding to the currently executing sub or eval. |
2759 |
If db_seqp is non_null, skip CVs that are in the DB package and populate |
2760 |
*db_seqp with the cop sequence number at the point that the DB:: code was |
2761 |
entered. (allows debuggers to eval in the scope of the breakpoint rather |
2762 |
than in in the scope of the debugger itself). |
2763 |
|
2764 |
=cut |
2765 |
*/ |
2766 |
|
2767 |
CV* |
2768 |
Perl_find_runcv(pTHX_ U32 *db_seqp) |
2769 |
{ |
2770 |
I32 ix; |
2771 |
PERL_SI *si; |
2772 |
PERL_CONTEXT *cx; |
2773 |
|
2774 |
if (db_seqp) |
2775 |
*db_seqp = PL_curcop->cop_seq; |
2776 |
for (si = PL_curstackinfo; si; si = si->si_prev) { |
2777 |
for (ix = si->si_cxix; ix >= 0; ix--) { |
2778 |
cx = &(si->si_cxstack[ix]); |
2779 |
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { |
2780 |
CV *cv = cx->blk_sub.cv; |
2781 |
/* skip DB:: code */ |
2782 |
if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { |
2783 |
*db_seqp = cx->blk_oldcop->cop_seq; |
2784 |
continue; |
2785 |
} |
2786 |
return cv; |
2787 |
} |
2788 |
else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) |
2789 |
return PL_compcv; |
2790 |
} |
2791 |
} |
2792 |
return PL_main_cv; |
2793 |
} |
2794 |
|
2795 |
|
2796 |
/* Compile a require/do, an eval '', or a /(?{...})/. |
2797 |
* In the last case, startop is non-null, and contains the address of |
2798 |
* a pointer that should be set to the just-compiled code. |
2799 |
* outside is the lexically enclosing CV (if any) that invoked us. |
2800 |
*/ |
2801 |
|
2802 |
/* With USE_5005THREADS, eval_owner must be held on entry to doeval */ |
2803 |
STATIC OP * |
2804 |
S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) |
2805 |
{ |
2806 |
dSP; |
2807 |
OP *saveop = PL_op; |
2808 |
|
2809 |
PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) |
2810 |
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) |
2811 |
: EVAL_INEVAL); |
2812 |
|
2813 |
PUSHMARK(SP); |
2814 |
|
2815 |
SAVESPTR(PL_compcv); |
2816 |
PL_compcv = (CV*)NEWSV(1104,0); |
2817 |
sv_upgrade((SV *)PL_compcv, SVt_PVCV); |
2818 |
CvEVAL_on(PL_compcv); |
2819 |
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); |
2820 |
cxstack[cxstack_ix].blk_eval.cv = PL_compcv; |
2821 |
|
2822 |
#ifdef USE_5005THREADS |
2823 |
CvOWNER(PL_compcv) = 0; |
2824 |
New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); |
2825 |
MUTEX_INIT(CvMUTEXP(PL_compcv)); |
2826 |
#endif /* USE_5005THREADS */ |
2827 |
|
2828 |
CvOUTSIDE_SEQ(PL_compcv) = seq; |
2829 |
CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside); |
2830 |
|
2831 |
/* set up a scratch pad */ |
2832 |
|
2833 |
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); |
2834 |
|
2835 |
|
2836 |
SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ |
2837 |
|
2838 |
/* make sure we compile in the right package */ |
2839 |
|
2840 |
if (CopSTASH_ne(PL_curcop, PL_curstash)) { |
2841 |
SAVESPTR(PL_curstash); |
2842 |
PL_curstash = CopSTASH(PL_curcop); |
2843 |
} |
2844 |
SAVESPTR(PL_beginav); |
2845 |
PL_beginav = newAV(); |
2846 |
SAVEFREESV(PL_beginav); |
2847 |
SAVEI32(PL_error_count); |
2848 |
|
2849 |
/* try to compile it */ |
2850 |
|
2851 |
PL_eval_root = Nullop; |
2852 |
PL_error_count = 0; |
2853 |
PL_curcop = &PL_compiling; |
2854 |
PL_curcop->cop_arybase = 0; |
2855 |
if (saveop && saveop->op_flags & OPf_SPECIAL) |
2856 |
PL_in_eval |= EVAL_KEEPERR; |
2857 |
else |
2858 |
sv_setpv(ERRSV,""); |
2859 |
if (yyparse() || PL_error_count || !PL_eval_root) { |
2860 |
SV **newsp; /* Used by POPBLOCK. */ |
2861 |
PERL_CONTEXT *cx; |
2862 |
I32 optype = 0; /* Might be reset by POPEVAL. */ |
2863 |
STRLEN n_a; |
2864 |
|
2865 |
PL_op = saveop; |
2866 |
if (PL_eval_root) { |
2867 |
op_free(PL_eval_root); |
2868 |
PL_eval_root = Nullop; |
2869 |
} |
2870 |
SP = PL_stack_base + POPMARK; /* pop original mark */ |
2871 |
if (!startop) { |
2872 |
POPBLOCK(cx,PL_curpm); |
2873 |
POPEVAL(cx); |
2874 |
pop_return(); |
2875 |
} |
2876 |
lex_end(); |
2877 |
LEAVE; |
2878 |
if (optype == OP_REQUIRE) { |
2879 |
char* msg = SvPVx(ERRSV, n_a); |
2880 |
DIE(aTHX_ "%sCompilation failed in require", |
2881 |
*msg ? msg : "Unknown error\n"); |
2882 |
} |
2883 |
else if (startop) { |
2884 |
char* msg = SvPVx(ERRSV, n_a); |
2885 |
|
2886 |
POPBLOCK(cx,PL_curpm); |
2887 |
POPEVAL(cx); |
2888 |
Perl_croak(aTHX_ "%sCompilation failed in regexp", |
2889 |
(*msg ? msg : "Unknown error\n")); |
2890 |
} |
2891 |
else { |
2892 |
char* msg = SvPVx(ERRSV, n_a); |
2893 |
if (!*msg) { |
2894 |
sv_setpv(ERRSV, "Compilation error"); |
2895 |
} |
2896 |
} |
2897 |
#ifdef USE_5005THREADS |
2898 |
MUTEX_LOCK(&PL_eval_mutex); |
2899 |
PL_eval_owner = 0; |
2900 |
COND_SIGNAL(&PL_eval_cond); |
2901 |
MUTEX_UNLOCK(&PL_eval_mutex); |
2902 |
#endif /* USE_5005THREADS */ |
2903 |
RETPUSHUNDEF; |
2904 |
} |
2905 |
CopLINE_set(&PL_compiling, 0); |
2906 |
if (startop) { |
2907 |
*startop = PL_eval_root; |
2908 |
} else |
2909 |
SAVEFREEOP(PL_eval_root); |
2910 |
|
2911 |
/* Set the context for this new optree. |
2912 |
* If the last op is an OP_REQUIRE, force scalar context. |
2913 |
* Otherwise, propagate the context from the eval(). */ |
2914 |
if (PL_eval_root->op_type == OP_LEAVEEVAL |
2915 |
&& cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ |
2916 |
&& cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type |
2917 |
== OP_REQUIRE) |
2918 |
scalar(PL_eval_root); |
2919 |
else if (gimme & G_VOID) |
2920 |
scalarvoid(PL_eval_root); |
2921 |
else if (gimme & G_ARRAY) |
2922 |
list(PL_eval_root); |
2923 |
else |
2924 |
scalar(PL_eval_root); |
2925 |
|
2926 |
DEBUG_x(dump_eval()); |
2927 |
|
2928 |
/* Register with debugger: */ |
2929 |
if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { |
2930 |
CV *cv = get_cv("DB::postponed", FALSE); |
2931 |
if (cv) { |
2932 |
dSP; |
2933 |
PUSHMARK(SP); |
2934 |
XPUSHs((SV*)CopFILEGV(&PL_compiling)); |
2935 |
PUTBACK; |
2936 |
call_sv((SV*)cv, G_DISCARD); |
2937 |
} |
2938 |
} |
2939 |
|
2940 |
/* compiled okay, so do it */ |
2941 |
|
2942 |
CvDEPTH(PL_compcv) = 1; |
2943 |
SP = PL_stack_base + POPMARK; /* pop original mark */ |
2944 |
PL_op = saveop; /* The caller may need it. */ |
2945 |
PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */ |
2946 |
#ifdef USE_5005THREADS |
2947 |
MUTEX_LOCK(&PL_eval_mutex); |
2948 |
PL_eval_owner = 0; |
2949 |
COND_SIGNAL(&PL_eval_cond); |
2950 |
MUTEX_UNLOCK(&PL_eval_mutex); |
2951 |
#endif /* USE_5005THREADS */ |
2952 |
|
2953 |
RETURNOP(PL_eval_start); |
2954 |
} |
2955 |
|
2956 |
STATIC PerlIO * |
2957 |
S_doopen_pm(pTHX_ const char *name, const char *mode) |
2958 |
{ |
2959 |
#ifndef PERL_DISABLE_PMC |
2960 |
STRLEN namelen = strlen(name); |
2961 |
PerlIO *fp; |
2962 |
|
2963 |
if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { |
2964 |
SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); |
2965 |
char *pmc = SvPV_nolen(pmcsv); |
2966 |
Stat_t pmstat; |
2967 |
Stat_t pmcstat; |
2968 |
if (PerlLIO_stat(pmc, &pmcstat) < 0) { |
2969 |
fp = PerlIO_open(name, mode); |
2970 |
} |
2971 |
else { |
2972 |
if (PerlLIO_stat(name, &pmstat) < 0 || |
2973 |
pmstat.st_mtime < pmcstat.st_mtime) |
2974 |
{ |
2975 |
fp = PerlIO_open(pmc, mode); |
2976 |
} |
2977 |
else { |
2978 |
fp = PerlIO_open(name, mode); |
2979 |
} |
2980 |
} |
2981 |
SvREFCNT_dec(pmcsv); |
2982 |
} |
2983 |
else { |
2984 |
fp = PerlIO_open(name, mode); |
2985 |
} |
2986 |
return fp; |
2987 |
#else |
2988 |
return PerlIO_open(name, mode); |
2989 |
#endif /* !PERL_DISABLE_PMC */ |
2990 |
} |
2991 |
|
2992 |
PP(pp_require) |
2993 |
{ |
2994 |
dSP; |
2995 |
register PERL_CONTEXT *cx; |
2996 |
SV *sv; |
2997 |
char *name; |
2998 |
STRLEN len; |
2999 |
char *tryname = Nullch; |
3000 |
SV *namesv = Nullsv; |
3001 |
SV** svp; |
3002 |
I32 gimme = GIMME_V; |
3003 |
PerlIO *tryrsfp = 0; |
3004 |
STRLEN n_a; |
3005 |
int filter_has_file = 0; |
3006 |
GV *filter_child_proc = 0; |
3007 |
SV *filter_state = 0; |
3008 |
SV *filter_sub = 0; |
3009 |
SV *hook_sv = 0; |
3010 |
SV *encoding; |
3011 |
OP *op; |
3012 |
|
3013 |
sv = POPs; |
3014 |
if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) { |
3015 |
if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */ |
3016 |
UV rev = 0, ver = 0, sver = 0; |
3017 |
STRLEN len; |
3018 |
U8 *s = (U8*)SvPVX(sv); |
3019 |
U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); |
3020 |
if (s < end) { |
3021 |
rev = utf8n_to_uvchr(s, end - s, &len, 0); |
3022 |
s += len; |
3023 |
if (s < end) { |
3024 |
ver = utf8n_to_uvchr(s, end - s, &len, 0); |
3025 |
s += len; |
3026 |
if (s < end) |
3027 |
sver = utf8n_to_uvchr(s, end - s, &len, 0); |
3028 |
} |
3029 |
} |
3030 |
if (PERL_REVISION < rev |
3031 |
|| (PERL_REVISION == rev |
3032 |
&& (PERL_VERSION < ver |
3033 |
|| (PERL_VERSION == ver |
3034 |
&& PERL_SUBVERSION < sver)))) |
3035 |
{ |
3036 |
DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only " |
3037 |
"v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, |
3038 |
PERL_VERSION, PERL_SUBVERSION); |
3039 |
} |
3040 |
RETPUSHYES; |
3041 |
} |
3042 |
else if (!SvPOKp(sv)) { /* require 5.005_03 */ |
3043 |
if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000) |
3044 |
+ ((NV)PERL_SUBVERSION/(NV)1000000) |
3045 |
+ 0.00000099 < SvNV(sv)) |
3046 |
{ |
3047 |
NV nrev = SvNV(sv); |
3048 |
UV rev = (UV)nrev; |
3049 |
NV nver = (nrev - rev) * 1000; |
3050 |
UV ver = (UV)(nver + 0.0009); |
3051 |
NV nsver = (nver - ver) * 1000; |
3052 |
UV sver = (UV)(nsver + 0.0009); |
3053 |
|
3054 |
/* help out with the "use 5.6" confusion */ |
3055 |
if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) { |
3056 |
DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required" |
3057 |
" (did you mean v%"UVuf".%03"UVuf"?)--" |
3058 |
"this is only v%d.%d.%d, stopped", |
3059 |
rev, ver, sver, rev, ver/100, |
3060 |
PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); |
3061 |
} |
3062 |
else { |
3063 |
DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" |
3064 |
"this is only v%d.%d.%d, stopped", |
3065 |
rev, ver, sver, PERL_REVISION, PERL_VERSION, |
3066 |
PERL_SUBVERSION); |
3067 |
} |
3068 |
} |
3069 |
RETPUSHYES; |
3070 |
} |
3071 |
} |
3072 |
name = SvPV(sv, len); |
3073 |
if (!(name && len > 0 && *name)) |
3074 |
DIE(aTHX_ "Null filename used"); |
3075 |
TAINT_PROPER("require"); |
3076 |
if (PL_op->op_type == OP_REQUIRE && |
3077 |
(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) && |
3078 |
*svp != &PL_sv_undef) |
3079 |
RETPUSHYES; |
3080 |
|
3081 |
/* prepare to compile file */ |
3082 |
|
3083 |
if (path_is_absolute(name)) { |
3084 |
tryname = name; |
3085 |
tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE); |
3086 |
} |
3087 |
#ifdef MACOS_TRADITIONAL |
3088 |
if (!tryrsfp) { |
3089 |
char newname[256]; |
3090 |
|
3091 |
MacPerl_CanonDir(name, newname, 1); |
3092 |
if (path_is_absolute(newname)) { |
3093 |
tryname = newname; |
3094 |
tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE); |
3095 |
} |
3096 |
} |
3097 |
#endif |
3098 |
if (!tryrsfp) { |
3099 |
AV *ar = GvAVn(PL_incgv); |
3100 |
I32 i; |
3101 |
#ifdef VMS |
3102 |
char *unixname; |
3103 |
if ((unixname = tounixspec(name, Nullch)) != Nullch) |
3104 |
#endif |
3105 |
{ |
3106 |
namesv = NEWSV(806, 0); |
3107 |
for (i = 0; i <= AvFILL(ar); i++) { |
3108 |
SV *dirsv = *av_fetch(ar, i, TRUE); |
3109 |
|
3110 |
if (SvROK(dirsv)) { |
3111 |
int count; |
3112 |
SV *loader = dirsv; |
3113 |
|
3114 |
if (SvTYPE(SvRV(loader)) == SVt_PVAV |
3115 |
&& !sv_isobject(loader)) |
3116 |
{ |
3117 |
loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); |
3118 |
} |
3119 |
|
3120 |
Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", |
3121 |
PTR2UV(SvRV(dirsv)), name); |
3122 |
tryname = SvPVX(namesv); |
3123 |
tryrsfp = 0; |
3124 |
|
3125 |
ENTER; |
3126 |
SAVETMPS; |
3127 |
EXTEND(SP, 2); |
3128 |
|
3129 |
PUSHMARK(SP); |
3130 |
PUSHs(dirsv); |
3131 |
PUSHs(sv); |
3132 |
PUTBACK; |
3133 |
if (sv_isobject(loader)) |
3134 |
count = call_method("INC", G_ARRAY); |
3135 |
else |
3136 |
count = call_sv(loader, G_ARRAY); |
3137 |
SPAGAIN; |
3138 |
|
3139 |
if (count > 0) { |
3140 |
int i = 0; |
3141 |
SV *arg; |
3142 |
|
3143 |
SP -= count - 1; |
3144 |
arg = SP[i++]; |
3145 |
|
3146 |
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { |
3147 |
arg = SvRV(arg); |
3148 |
} |
3149 |
|
3150 |
if (SvTYPE(arg) == SVt_PVGV) { |
3151 |
IO *io = GvIO((GV *)arg); |
3152 |
|
3153 |
++filter_has_file; |
3154 |
|
3155 |
if (io) { |
3156 |
tryrsfp = IoIFP(io); |
3157 |
if (IoTYPE(io) == IoTYPE_PIPE) { |
3158 |
/* reading from a child process doesn't |
3159 |
nest -- when returning from reading |
3160 |
the inner module, the outer one is |
3161 |
unreadable (closed?) I've tried to |
3162 |
save the gv to manage the lifespan of |
3163 |
the pipe, but this didn't help. XXX */ |
3164 |
filter_child_proc = (GV *)arg; |
3165 |
(void)SvREFCNT_inc(filter_child_proc); |
3166 |
} |
3167 |
else { |
3168 |
if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { |
3169 |
PerlIO_close(IoOFP(io)); |
3170 |
} |
3171 |
IoIFP(io) = Nullfp; |
3172 |
IoOFP(io) = Nullfp; |
3173 |
} |
3174 |
} |
3175 |
|
3176 |
if (i < count) { |
3177 |
arg = SP[i++]; |
3178 |
} |
3179 |
} |
3180 |
|
3181 |
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { |
3182 |
filter_sub = arg; |
3183 |
(void)SvREFCNT_inc(filter_sub); |
3184 |
|
3185 |
if (i < count) { |
3186 |
filter_state = SP[i]; |
3187 |
(void)SvREFCNT_inc(filter_state); |
3188 |
} |
3189 |
|
3190 |
if (tryrsfp == 0) { |
3191 |
tryrsfp = PerlIO_open("/dev/null", |
3192 |
PERL_SCRIPT_MODE); |
3193 |
} |
3194 |
} |
3195 |
SP--; |
3196 |
} |
3197 |
|
3198 |
PUTBACK; |
3199 |
FREETMPS; |
3200 |
LEAVE; |
3201 |
|
3202 |
if (tryrsfp) { |
3203 |
hook_sv = dirsv; |
3204 |
break; |
3205 |
} |
3206 |
|
3207 |
filter_has_file = 0; |
3208 |
if (filter_child_proc) { |
3209 |
SvREFCNT_dec(filter_child_proc); |
3210 |
filter_child_proc = 0; |
3211 |
} |
3212 |
if (filter_state) { |
3213 |
SvREFCNT_dec(filter_state); |
3214 |
filter_state = 0; |
3215 |
} |
3216 |
if (filter_sub) { |
3217 |
SvREFCNT_dec(filter_sub); |
3218 |
filter_sub = 0; |
3219 |
} |
3220 |
} |
3221 |
else { |
3222 |
if (!path_is_absolute(name) |
3223 |
#ifdef MACOS_TRADITIONAL |
3224 |
/* We consider paths of the form :a:b ambiguous and interpret them first |
3225 |
as global then as local |
3226 |
*/ |
3227 |
|| (*name == ':' && name[1] != ':' && strchr(name+2, ':')) |
3228 |
#endif |
3229 |
) { |
3230 |
char *dir = SvPVx(dirsv, n_a); |
3231 |
#ifdef MACOS_TRADITIONAL |
3232 |
char buf1[256]; |
3233 |
char buf2[256]; |
3234 |
|
3235 |
MacPerl_CanonDir(name, buf2, 1); |
3236 |
Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':')); |
3237 |
#else |
3238 |
#ifdef VMS |
3239 |
char *unixdir; |
3240 |
if ((unixdir = tounixpath(dir, Nullch)) == Nullch) |
3241 |
continue; |
3242 |
sv_setpv(namesv, unixdir); |
3243 |
sv_catpv(namesv, unixname); |
3244 |
#else |
3245 |
Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); |
3246 |
#endif |
3247 |
#endif |
3248 |
TAINT_PROPER("require"); |
3249 |
tryname = SvPVX(namesv); |
3250 |
tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE); |
3251 |
if (tryrsfp) { |
3252 |
if (tryname[0] == '.' && tryname[1] == '/') |
3253 |
tryname += 2; |
3254 |
break; |
3255 |
} |
3256 |
} |
3257 |
} |
3258 |
} |
3259 |
} |
3260 |
} |
3261 |
SAVECOPFILE_FREE(&PL_compiling); |
3262 |
CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); |
3263 |
SvREFCNT_dec(namesv); |
3264 |
if (!tryrsfp) { |
3265 |
if (PL_op->op_type == OP_REQUIRE) { |
3266 |
char *msgstr = name; |
3267 |
if (namesv) { /* did we lookup @INC? */ |
3268 |
SV *msg = sv_2mortal(newSVpv(msgstr,0)); |
3269 |
SV *dirmsgsv = NEWSV(0, 0); |
3270 |
AV *ar = GvAVn(PL_incgv); |
3271 |
I32 i; |
3272 |
sv_catpvn(msg, " in @INC", 8); |
3273 |
if (instr(SvPVX(msg), ".h ")) |
3274 |
sv_catpv(msg, " (change .h to .ph maybe?)"); |
3275 |
if (instr(SvPVX(msg), ".ph ")) |
3276 |
sv_catpv(msg, " (did you run h2ph?)"); |
3277 |
sv_catpv(msg, " (@INC contains:"); |
3278 |
for (i = 0; i <= AvFILL(ar); i++) { |
3279 |
char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); |
3280 |
Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir); |
3281 |
sv_catsv(msg, dirmsgsv); |
3282 |
} |
3283 |
sv_catpvn(msg, ")", 1); |
3284 |
SvREFCNT_dec(dirmsgsv); |
3285 |
msgstr = SvPV_nolen(msg); |
3286 |
} |
3287 |
DIE(aTHX_ "Can't locate %s", msgstr); |
3288 |
} |
3289 |
|
3290 |
RETPUSHUNDEF; |
3291 |
} |
3292 |
else |
3293 |
SETERRNO(0, SS_NORMAL); |
3294 |
|
3295 |
/* Assume success here to prevent recursive requirement. */ |
3296 |
len = strlen(name); |
3297 |
/* Check whether a hook in @INC has already filled %INC */ |
3298 |
if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) { |
3299 |
(void)hv_store(GvHVn(PL_incgv), name, len, |
3300 |
(hook_sv ? SvREFCNT_inc(hook_sv) |
3301 |
: newSVpv(CopFILE(&PL_compiling), 0)), |
3302 |
0 ); |
3303 |
} |
3304 |
|
3305 |
ENTER; |
3306 |
SAVETMPS; |
3307 |
lex_start(sv_2mortal(newSVpvn("",0))); |
3308 |
SAVEGENERICSV(PL_rsfp_filters); |
3309 |
PL_rsfp_filters = Nullav; |
3310 |
|
3311 |
PL_rsfp = tryrsfp; |
3312 |
SAVEHINTS(); |
3313 |
PL_hints = 0; |
3314 |
SAVESPTR(PL_compiling.cop_warnings); |
3315 |
if (PL_dowarn & G_WARN_ALL_ON) |
3316 |
PL_compiling.cop_warnings = pWARN_ALL ; |
3317 |
else if (PL_dowarn & G_WARN_ALL_OFF) |
3318 |
PL_compiling.cop_warnings = pWARN_NONE ; |
3319 |
else if (PL_taint_warn) |
3320 |
PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize); |
3321 |
else |
3322 |
PL_compiling.cop_warnings = pWARN_STD ; |
3323 |
SAVESPTR(PL_compiling.cop_io); |
3324 |
PL_compiling.cop_io = Nullsv; |
3325 |
|
3326 |
if (filter_sub || filter_child_proc) { |
3327 |
SV *datasv = filter_add(run_user_filter, Nullsv); |
3328 |
IoLINES(datasv) = filter_has_file; |
3329 |
IoFMT_GV(datasv) = (GV *)filter_child_proc; |
3330 |
IoTOP_GV(datasv) = (GV *)filter_state; |
3331 |
IoBOTTOM_GV(datasv) = (GV *)filter_sub; |
3332 |
} |
3333 |
|
3334 |
/* switch to eval mode */ |
3335 |
push_return(PL_op->op_next); |
3336 |
PUSHBLOCK(cx, CXt_EVAL, SP); |
3337 |
PUSHEVAL(cx, name, Nullgv); |
3338 |
|
3339 |
SAVECOPLINE(&PL_compiling); |
3340 |
CopLINE_set(&PL_compiling, 0); |
3341 |
|
3342 |
PUTBACK; |
3343 |
#ifdef USE_5005THREADS |
3344 |
MUTEX_LOCK(&PL_eval_mutex); |
3345 |
if (PL_eval_owner && PL_eval_owner != thr) |
3346 |
while (PL_eval_owner) |
3347 |
COND_WAIT(&PL_eval_cond, &PL_eval_mutex); |
3348 |
PL_eval_owner = thr; |
3349 |
MUTEX_UNLOCK(&PL_eval_mutex); |
3350 |
#endif /* USE_5005THREADS */ |
3351 |
|
3352 |
/* Store and reset encoding. */ |
3353 |
encoding = PL_encoding; |
3354 |
PL_encoding = Nullsv; |
3355 |
|
3356 |
op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq)); |
3357 |
|
3358 |
/* Restore encoding. */ |
3359 |
PL_encoding = encoding; |
3360 |
|
3361 |
return op; |
3362 |
} |
3363 |
|
3364 |
PP(pp_dofile) |
3365 |
{ |
3366 |
return pp_require(); |
3367 |
} |
3368 |
|
3369 |
PP(pp_entereval) |
3370 |
{ |
3371 |
dSP; |
3372 |
register PERL_CONTEXT *cx; |
3373 |
dPOPss; |
3374 |
I32 gimme = GIMME_V, was = PL_sub_generation; |
3375 |
char tbuf[TYPE_DIGITS(long) + 12]; |
3376 |
char *tmpbuf = tbuf; |
3377 |
char *safestr; |
3378 |
STRLEN len; |
3379 |
OP *ret; |
3380 |
CV* runcv; |
3381 |
U32 seq; |
3382 |
|
3383 |
if (!SvPV(sv,len)) |
3384 |
RETPUSHUNDEF; |
3385 |
TAINT_PROPER("eval"); |
3386 |
|
3387 |
ENTER; |
3388 |
lex_start(sv); |
3389 |
SAVETMPS; |
3390 |
|
3391 |
/* switch to eval mode */ |
3392 |
|
3393 |
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { |
3394 |
SV *sv = sv_newmortal(); |
3395 |
Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", |
3396 |
(unsigned long)++PL_evalseq, |
3397 |
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); |
3398 |
tmpbuf = SvPVX(sv); |
3399 |
} |
3400 |
else |
3401 |
sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); |
3402 |
SAVECOPFILE_FREE(&PL_compiling); |
3403 |
CopFILE_set(&PL_compiling, tmpbuf+2); |
3404 |
SAVECOPLINE(&PL_compiling); |
3405 |
CopLINE_set(&PL_compiling, 1); |
3406 |
/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up |
3407 |
deleting the eval's FILEGV from the stash before gv_check() runs |
3408 |
(i.e. before run-time proper). To work around the coredump that |
3409 |
ensues, we always turn GvMULTI_on for any globals that were |
3410 |
introduced within evals. See force_ident(). GSAR 96-10-12 */ |
3411 |
safestr = savepv(tmpbuf); |
3412 |
SAVEDELETE(PL_defstash, safestr, strlen(safestr)); |
3413 |
SAVEHINTS(); |
3414 |
PL_hints = PL_op->op_targ; |
3415 |
SAVESPTR(PL_compiling.cop_warnings); |
3416 |
if (specialWARN(PL_curcop->cop_warnings)) |
3417 |
PL_compiling.cop_warnings = PL_curcop->cop_warnings; |
3418 |
else { |
3419 |
PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings); |
3420 |
SAVEFREESV(PL_compiling.cop_warnings); |
3421 |
} |
3422 |
SAVESPTR(PL_compiling.cop_io); |
3423 |
if (specialCopIO(PL_curcop->cop_io)) |
3424 |
PL_compiling.cop_io = PL_curcop->cop_io; |
3425 |
else { |
3426 |
PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); |
3427 |
SAVEFREESV(PL_compiling.cop_io); |
3428 |
} |
3429 |
/* special case: an eval '' executed within the DB package gets lexically |
3430 |
* placed in the first non-DB CV rather than the current CV - this |
3431 |
* allows the debugger to execute code, find lexicals etc, in the |
3432 |
* scope of the code being debugged. Passing &seq gets find_runcv |
3433 |
* to do the dirty work for us */ |
3434 |
runcv = find_runcv(&seq); |
3435 |
|
3436 |
push_return(PL_op->op_next); |
3437 |
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); |
3438 |
PUSHEVAL(cx, 0, Nullgv); |
3439 |
|
3440 |
/* prepare to compile string */ |
3441 |
|
3442 |
if (PERLDB_LINE && PL_curstash != PL_debstash) |
3443 |
save_lines(CopFILEAV(&PL_compiling), PL_linestr); |
3444 |
PUTBACK; |
3445 |
#ifdef USE_5005THREADS |
3446 |
MUTEX_LOCK(&PL_eval_mutex); |
3447 |
if (PL_eval_owner && PL_eval_owner != thr) |
3448 |
while (PL_eval_owner) |
3449 |
COND_WAIT(&PL_eval_cond, &PL_eval_mutex); |
3450 |
PL_eval_owner = thr; |
3451 |
MUTEX_UNLOCK(&PL_eval_mutex); |
3452 |
#endif /* USE_5005THREADS */ |
3453 |
ret = doeval(gimme, NULL, runcv, seq); |
3454 |
if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ |
3455 |
&& ret != PL_op->op_next) { /* Successive compilation. */ |
3456 |
strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ |
3457 |
} |
3458 |
return DOCATCH(ret); |
3459 |
} |
3460 |
|
3461 |
PP(pp_leaveeval) |
3462 |
{ |
3463 |
dSP; |
3464 |
register SV **mark; |
3465 |
SV **newsp; |
3466 |
PMOP *newpm; |
3467 |
I32 gimme; |
3468 |
register PERL_CONTEXT *cx; |
3469 |
OP *retop; |
3470 |
U8 save_flags = PL_op -> op_flags; |
3471 |
I32 optype; |
3472 |
|
3473 |
POPBLOCK(cx,newpm); |
3474 |
POPEVAL(cx); |
3475 |
retop = pop_return(); |
3476 |
|
3477 |
TAINT_NOT; |
3478 |
if (gimme == G_VOID) |
3479 |
MARK = newsp; |
3480 |
else if (gimme == G_SCALAR) { |
3481 |
MARK = newsp + 1; |
3482 |
if (MARK <= SP) { |
3483 |
if (SvFLAGS(TOPs) & SVs_TEMP) |
3484 |
*MARK = TOPs; |
3485 |
else |
3486 |
*MARK = sv_mortalcopy(TOPs); |
3487 |
} |
3488 |
else { |
3489 |
MEXTEND(mark,0); |
3490 |
*MARK = &PL_sv_undef; |
3491 |
} |
3492 |
SP = MARK; |
3493 |
} |
3494 |
else { |
3495 |
/* in case LEAVE wipes old return values */ |
3496 |
for (mark = newsp + 1; mark <= SP; mark++) { |
3497 |
if (!(SvFLAGS(*mark) & SVs_TEMP)) { |
3498 |
*mark = sv_mortalcopy(*mark); |
3499 |
TAINT_NOT; /* Each item is independent */ |
3500 |
} |
3501 |
} |
3502 |
} |
3503 |
PL_curpm = newpm; /* Don't pop $1 et al till now */ |
3504 |
|
3505 |
#ifdef DEBUGGING |
3506 |
assert(CvDEPTH(PL_compcv) == 1); |
3507 |
#endif |
3508 |
CvDEPTH(PL_compcv) = 0; |
3509 |
lex_end(); |
3510 |
|
3511 |
if (optype == OP_REQUIRE && |
3512 |
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) |
3513 |
{ |
3514 |
/* Unassume the success we assumed earlier. */ |
3515 |
SV *nsv = cx->blk_eval.old_namesv; |
3516 |
(void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD); |
3517 |
retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv); |
3518 |
/* die_where() did LEAVE, or we won't be here */ |
3519 |
} |
3520 |
else { |
3521 |
LEAVE; |
3522 |
if (!(save_flags & OPf_SPECIAL)) |
3523 |
sv_setpv(ERRSV,""); |
3524 |
} |
3525 |
|
3526 |
RETURNOP(retop); |
3527 |
} |
3528 |
|
3529 |
PP(pp_entertry) |
3530 |
{ |
3531 |
dSP; |
3532 |
register PERL_CONTEXT *cx; |
3533 |
I32 gimme = GIMME_V; |
3534 |
|
3535 |
ENTER; |
3536 |
SAVETMPS; |
3537 |
|
3538 |
push_return(cLOGOP->op_other->op_next); |
3539 |
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); |
3540 |
PUSHEVAL(cx, 0, 0); |
3541 |
|
3542 |
PL_in_eval = EVAL_INEVAL; |
3543 |
sv_setpv(ERRSV,""); |
3544 |
PUTBACK; |
3545 |
return DOCATCH(PL_op->op_next); |
3546 |
} |
3547 |
|
3548 |
PP(pp_leavetry) |
3549 |
{ |
3550 |
dSP; |
3551 |
register SV **mark; |
3552 |
SV **newsp; |
3553 |
PMOP *newpm; |
3554 |
OP* retop; |
3555 |
I32 gimme; |
3556 |
register PERL_CONTEXT *cx; |
3557 |
I32 optype; |
3558 |
|
3559 |
POPBLOCK(cx,newpm); |
3560 |
POPEVAL(cx); |
3561 |
retop = pop_return(); |
3562 |
|
3563 |
TAINT_NOT; |
3564 |
if (gimme == G_VOID) |
3565 |
SP = newsp; |
3566 |
else if (gimme == G_SCALAR) { |
3567 |
MARK = newsp + 1; |
3568 |
if (MARK <= SP) { |
3569 |
if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) |
3570 |
*MARK = TOPs; |
3571 |
else |
3572 |
*MARK = sv_mortalcopy(TOPs); |
3573 |
} |
3574 |
else { |
3575 |
MEXTEND(mark,0); |
3576 |
*MARK = &PL_sv_undef; |
3577 |
} |
3578 |
SP = MARK; |
3579 |
} |
3580 |
else { |
3581 |
/* in case LEAVE wipes old return values */ |
3582 |
for (mark = newsp + 1; mark <= SP; mark++) { |
3583 |
if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { |
3584 |
*mark = sv_mortalcopy(*mark); |
3585 |
TAINT_NOT; /* Each item is independent */ |
3586 |
} |
3587 |
} |
3588 |
} |
3589 |
PL_curpm = newpm; /* Don't pop $1 et al till now */ |
3590 |
|
3591 |
LEAVE; |
3592 |
sv_setpv(ERRSV,""); |
3593 |
RETURNOP(retop); |
3594 |
} |
3595 |
|
3596 |
STATIC OP * |
3597 |
S_doparseform(pTHX_ SV *sv) |
3598 |
{ |
3599 |
STRLEN len; |
3600 |
register char *s = SvPV_force(sv, len); |
3601 |
register char *send = s + len; |
3602 |
register char *base = Nullch; |
3603 |
register I32 skipspaces = 0; |
3604 |
bool noblank = FALSE; |
3605 |
bool repeat = FALSE; |
3606 |
bool postspace = FALSE; |
3607 |
U32 *fops; |
3608 |
register U32 *fpc; |
3609 |
U32 *linepc = 0; |
3610 |
register I32 arg; |
3611 |
bool ischop; |
3612 |
bool unchopnum = FALSE; |
3613 |
int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ |
3614 |
|
3615 |
if (len == 0) |
3616 |
Perl_croak(aTHX_ "Null picture in formline"); |
3617 |
|
3618 |
/* estimate the buffer size needed */ |
3619 |
for (base = s; s <= send; s++) { |
3620 |
if (*s == '\n' || *s == '@' || *s == '^') |
3621 |
maxops += 10; |
3622 |
} |
3623 |
s = base; |
3624 |
base = Nullch; |
3625 |
|
3626 |
New(804, fops, maxops, U32); |
3627 |
fpc = fops; |
3628 |
|
3629 |
if (s < send) { |
3630 |
linepc = fpc; |
3631 |
*fpc++ = FF_LINEMARK; |
3632 |
noblank = repeat = FALSE; |
3633 |
base = s; |
3634 |
} |
3635 |
|
3636 |
while (s <= send) { |
3637 |
switch (*s++) { |
3638 |
default: |
3639 |
skipspaces = 0; |
3640 |
continue; |
3641 |
|
3642 |
case '~': |
3643 |
if (*s == '~') { |
3644 |
repeat = TRUE; |
3645 |
*s = ' '; |
3646 |
} |
3647 |
noblank = TRUE; |
3648 |
s[-1] = ' '; |
3649 |
/* FALL THROUGH */ |
3650 |
case ' ': case '\t': |
3651 |
skipspaces++; |
3652 |
continue; |
3653 |
case 0: |
3654 |
if (s < send) { |
3655 |
skipspaces = 0; |
3656 |
continue; |
3657 |
} /* else FALL THROUGH */ |
3658 |
case '\n': |
3659 |
arg = s - base; |
3660 |
skipspaces++; |
3661 |
arg -= skipspaces; |
3662 |
if (arg) { |
3663 |
if (postspace) |
3664 |
*fpc++ = FF_SPACE; |
3665 |
*fpc++ = FF_LITERAL; |
3666 |
*fpc++ = (U16)arg; |
3667 |
} |
3668 |
postspace = FALSE; |
3669 |
if (s <= send) |
3670 |
skipspaces--; |
3671 |
if (skipspaces) { |
3672 |
*fpc++ = FF_SKIP; |
3673 |
*fpc++ = (U16)skipspaces; |
3674 |
} |
3675 |
skipspaces = 0; |
3676 |
if (s <= send) |
3677 |
*fpc++ = FF_NEWLINE; |
3678 |
if (noblank) { |
3679 |
*fpc++ = FF_BLANK; |
3680 |
if (repeat) |
3681 |
arg = fpc - linepc + 1; |
3682 |
else |
3683 |
arg = 0; |
3684 |
*fpc++ = (U16)arg; |
3685 |
} |
3686 |
if (s < send) { |
3687 |
linepc = fpc; |
3688 |
*fpc++ = FF_LINEMARK; |
3689 |
noblank = repeat = FALSE; |
3690 |
base = s; |
3691 |
} |
3692 |
else |
3693 |
s++; |
3694 |
continue; |
3695 |
|
3696 |
case '@': |
3697 |
case '^': |
3698 |
ischop = s[-1] == '^'; |
3699 |
|
3700 |
if (postspace) { |
3701 |
*fpc++ = FF_SPACE; |
3702 |
postspace = FALSE; |
3703 |
} |
3704 |
arg = (s - base) - 1; |
3705 |
if (arg) { |
3706 |
*fpc++ = FF_LITERAL; |
3707 |
*fpc++ = (U16)arg; |
3708 |
} |
3709 |
|
3710 |
base = s - 1; |
3711 |
*fpc++ = FF_FETCH; |
3712 |
if (*s == '*') { |
3713 |
s++; |
3714 |
*fpc++ = 2; /* skip the @* or ^* */ |
3715 |
if (ischop) { |
3716 |
*fpc++ = FF_LINESNGL; |
3717 |
*fpc++ = FF_CHOP; |
3718 |
} else |
3719 |
*fpc++ = FF_LINEGLOB; |
3720 |
} |
3721 |
else if (*s == '#' || (*s == '.' && s[1] == '#')) { |
3722 |
arg = ischop ? 512 : 0; |
3723 |
base = s - 1; |
3724 |
while (*s == '#') |
3725 |
s++; |
3726 |
if (*s == '.') { |
3727 |
char *f; |
3728 |
s++; |
3729 |
f = s; |
3730 |
while (*s == '#') |
3731 |
s++; |
3732 |
arg |= 256 + (s - f); |
3733 |
} |
3734 |
*fpc++ = s - base; /* fieldsize for FETCH */ |
3735 |
*fpc++ = FF_DECIMAL; |
3736 |
*fpc++ = (U16)arg; |
3737 |
unchopnum |= ! ischop; |
3738 |
} |
3739 |
else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ |
3740 |
arg = ischop ? 512 : 0; |
3741 |
base = s - 1; |
3742 |
s++; /* skip the '0' first */ |
3743 |
while (*s == '#') |
3744 |
s++; |
3745 |
if (*s == '.') { |
3746 |
char *f; |
3747 |
s++; |
3748 |
f = s; |
3749 |
while (*s == '#') |
3750 |
s++; |
3751 |
arg |= 256 + (s - f); |
3752 |
} |
3753 |
*fpc++ = s - base; /* fieldsize for FETCH */ |
3754 |
*fpc++ = FF_0DECIMAL; |
3755 |
*fpc++ = (U16)arg; |
3756 |
unchopnum |= ! ischop; |
3757 |
} |
3758 |
else { |
3759 |
I32 prespace = 0; |
3760 |
bool ismore = FALSE; |
3761 |
|
3762 |
if (*s == '>') { |
3763 |
while (*++s == '>') ; |
3764 |
prespace = FF_SPACE; |
3765 |
} |
3766 |
else if (*s == '|') { |
3767 |
while (*++s == '|') ; |
3768 |
prespace = FF_HALFSPACE; |
3769 |
postspace = TRUE; |
3770 |
} |
3771 |
else { |
3772 |
if (*s == '<') |
3773 |
while (*++s == '<') ; |
3774 |
postspace = TRUE; |
3775 |
} |
3776 |
if (*s == '.' && s[1] == '.' && s[2] == '.') { |
3777 |
s += 3; |
3778 |
ismore = TRUE; |
3779 |
} |
3780 |
*fpc++ = s - base; /* fieldsize for FETCH */ |
3781 |
|
3782 |
*fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; |
3783 |
|
3784 |
if (prespace) |
3785 |
*fpc++ = (U16)prespace; |
3786 |
*fpc++ = FF_ITEM; |
3787 |
if (ismore) |
3788 |
*fpc++ = FF_MORE; |
3789 |
if (ischop) |
3790 |
*fpc++ = FF_CHOP; |
3791 |
} |
3792 |
base = s; |
3793 |
skipspaces = 0; |
3794 |
continue; |
3795 |
} |
3796 |
} |
3797 |
*fpc++ = FF_END; |
3798 |
|
3799 |
assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ |
3800 |
arg = fpc - fops; |
3801 |
{ /* need to jump to the next word */ |
3802 |
int z; |
3803 |
z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; |
3804 |
SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4); |
3805 |
s = SvPVX(sv) + SvCUR(sv) + z; |
3806 |
} |
3807 |
Copy(fops, s, arg, U32); |
3808 |
Safefree(fops); |
3809 |
sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0); |
3810 |
SvCOMPILED_on(sv); |
3811 |
|
3812 |
if (unchopnum && repeat) |
3813 |
DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)"); |
3814 |
return 0; |
3815 |
} |
3816 |
|
3817 |
|
3818 |
STATIC bool |
3819 |
S_num_overflow(NV value, I32 fldsize, I32 frcsize) |
3820 |
{ |
3821 |
/* Can value be printed in fldsize chars, using %*.*f ? */ |
3822 |
NV pwr = 1; |
3823 |
NV eps = 0.5; |
3824 |
bool res = FALSE; |
3825 |
int intsize = fldsize - (value < 0 ? 1 : 0); |
3826 |
|
3827 |
if (frcsize & 256) |
3828 |
intsize--; |
3829 |
frcsize &= 255; |
3830 |
intsize -= frcsize; |
3831 |
|
3832 |
while (intsize--) pwr *= 10.0; |
3833 |
while (frcsize--) eps /= 10.0; |
3834 |
|
3835 |
if( value >= 0 ){ |
3836 |
if (value + eps >= pwr) |
3837 |
res = TRUE; |
3838 |
} else { |
3839 |
if (value - eps <= -pwr) |
3840 |
res = TRUE; |
3841 |
} |
3842 |
return res; |
3843 |
} |
3844 |
|
3845 |
static I32 |
3846 |
run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) |
3847 |
{ |
3848 |
SV *datasv = FILTER_DATA(idx); |
3849 |
int filter_has_file = IoLINES(datasv); |
3850 |
GV *filter_child_proc = (GV *)IoFMT_GV(datasv); |
3851 |
SV *filter_state = (SV *)IoTOP_GV(datasv); |
3852 |
SV *filter_sub = (SV *)IoBOTTOM_GV(datasv); |
3853 |
int len = 0; |
3854 |
|
3855 |
/* I was having segfault trouble under Linux 2.2.5 after a |
3856 |
parse error occured. (Had to hack around it with a test |
3857 |
for PL_error_count == 0.) Solaris doesn't segfault -- |
3858 |
not sure where the trouble is yet. XXX */ |
3859 |
|
3860 |
if (filter_has_file) { |
3861 |
len = FILTER_READ(idx+1, buf_sv, maxlen); |
3862 |
} |
3863 |
|
3864 |
if (filter_sub && len >= 0) { |
3865 |
dSP; |
3866 |
int count; |
3867 |
|
3868 |
ENTER; |
3869 |
SAVE_DEFSV; |
3870 |
SAVETMPS; |
3871 |
EXTEND(SP, 2); |
3872 |
|
3873 |
DEFSV = buf_sv; |
3874 |
PUSHMARK(SP); |
3875 |
PUSHs(sv_2mortal(newSViv(maxlen))); |
3876 |
if (filter_state) { |
3877 |
PUSHs(filter_state); |
3878 |
} |
3879 |
PUTBACK; |
3880 |
count = call_sv(filter_sub, G_SCALAR); |
3881 |
SPAGAIN; |
3882 |
|
3883 |
if (count > 0) { |
3884 |
SV *out = POPs; |
3885 |
if (SvOK(out)) { |
3886 |
len = SvIV(out); |
3887 |
} |
3888 |
} |
3889 |
|
3890 |
PUTBACK; |
3891 |
FREETMPS; |
3892 |
LEAVE; |
3893 |
} |
3894 |
|
3895 |
if (len <= 0) { |
3896 |
IoLINES(datasv) = 0; |
3897 |
if (filter_child_proc) { |
3898 |
SvREFCNT_dec(filter_child_proc); |
3899 |
IoFMT_GV(datasv) = Nullgv; |
3900 |
} |
3901 |
if (filter_state) { |
3902 |
SvREFCNT_dec(filter_state); |
3903 |
IoTOP_GV(datasv) = Nullgv; |
3904 |
} |
3905 |
if (filter_sub) { |
3906 |
SvREFCNT_dec(filter_sub); |
3907 |
IoBOTTOM_GV(datasv) = Nullgv; |
3908 |
} |
3909 |
filter_del(run_user_filter); |
3910 |
} |
3911 |
|
3912 |
return len; |
3913 |
} |
3914 |
|
3915 |
/* perhaps someone can come up with a better name for |
3916 |
this? it is not really "absolute", per se ... */ |
3917 |
static bool |
3918 |
S_path_is_absolute(pTHX_ char *name) |
3919 |
{ |
3920 |
if (PERL_FILE_IS_ABSOLUTE(name) |
3921 |
#ifdef MACOS_TRADITIONAL |
3922 |
|| (*name == ':')) |
3923 |
#else |
3924 |
|| (*name == '.' && (name[1] == '/' || |
3925 |
(name[1] == '.' && name[2] == '/')))) |
3926 |
#endif |
3927 |
{ |
3928 |
return TRUE; |
3929 |
} |
3930 |
else |
3931 |
return FALSE; |
3932 |
} |
3933 |
|
3934 |
/* |
3935 |
* Local variables: |
3936 |
* c-indentation-style: bsd |
3937 |
* c-basic-offset: 4 |
3938 |
* indent-tabs-mode: t |
3939 |
* End: |
3940 |
* |
3941 |
* vim: shiftwidth=4: |
3942 |
*/ |