This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[ID 19991216.006] [PATCH 5.005_63] Reloading modules that use 'fields'
[perl5.git] / pp_ctl.c
CommitLineData
a0d0e21e
LW
1/* pp_ctl.c
2 *
4eb8286e 3 * Copyright (c) 1991-1999, Larry Wall
a0d0e21e
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
17 */
18
19#include "EXTERN.h"
864dbfa3 20#define PERL_IN_PP_CTL_C
a0d0e21e
LW
21#include "perl.h"
22
23#ifndef WORD_ALIGN
24#define WORD_ALIGN sizeof(U16)
25#endif
26
54310121 27#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
1e422769 28
51371543 29static I32 sortcv(pTHXo_ SV *a, SV *b);
43481408
GS
30static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
31static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
51371543
GS
32static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
33static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
34static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
35static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
36static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
37static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
bbed91b5
KF
38static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
39
e7513ba0 40#ifdef PERL_OBJECT
51371543
GS
41static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
42static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
e7513ba0
GS
43#else
44#define sv_cmp_static Perl_sv_cmp
45#define sv_cmp_locale_static Perl_sv_cmp_locale
46#endif
51371543 47
a0d0e21e
LW
48PP(pp_wantarray)
49{
4e35701f 50 djSP;
a0d0e21e
LW
51 I32 cxix;
52 EXTEND(SP, 1);
53
54 cxix = dopoptosub(cxstack_ix);
55 if (cxix < 0)
56 RETPUSHUNDEF;
57
54310121
PP
58 switch (cxstack[cxix].blk_gimme) {
59 case G_ARRAY:
a0d0e21e 60 RETPUSHYES;
54310121 61 case G_SCALAR:
a0d0e21e 62 RETPUSHNO;
54310121
PP
63 default:
64 RETPUSHUNDEF;
65 }
a0d0e21e
LW
66}
67
68PP(pp_regcmaybe)
69{
70 return NORMAL;
71}
72
2cd61cdb
IZ
73PP(pp_regcreset)
74{
75 /* XXXX Should store the old value to allow for tie/overload - and
76 restore in regcomp, where marked with XXXX. */
3280af22 77 PL_reginterp_cnt = 0;
2cd61cdb
IZ
78 return NORMAL;
79}
80
b3eb6a9b
GS
81PP(pp_regcomp)
82{
4e35701f 83 djSP;
a0d0e21e
LW
84 register PMOP *pm = (PMOP*)cLOGOP->op_other;
85 register char *t;
86 SV *tmpstr;
87 STRLEN len;
c277df42 88 MAGIC *mg = Null(MAGIC*);
a0d0e21e
LW
89
90 tmpstr = POPs;
b3eb6a9b 91 if (SvROK(tmpstr)) {
227a8b4b 92 SV *sv = SvRV(tmpstr);
c277df42
IZ
93 if(SvMAGICAL(sv))
94 mg = mg_find(sv, 'r');
95 }
b3eb6a9b 96 if (mg) {
c277df42
IZ
97 regexp *re = (regexp *)mg->mg_obj;
98 ReREFCNT_dec(pm->op_pmregexp);
99 pm->op_pmregexp = ReREFCNT_inc(re);
100 }
101 else {
102 t = SvPV(tmpstr, len);
103
20408e3c 104 /* Check against the last compiled regexp. */
85aff577 105 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
20408e3c
GS
106 pm->op_pmregexp->prelen != len ||
107 memNE(pm->op_pmregexp->precomp, t, len))
85aff577 108 {
c277df42
IZ
109 if (pm->op_pmregexp) {
110 ReREFCNT_dec(pm->op_pmregexp);
111 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
112 }
533c011a 113 if (PL_op->op_flags & OPf_SPECIAL)
3280af22 114 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
a0d0e21e 115
c277df42 116 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
cea2e8a9 117 pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
3280af22 118 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
2cd61cdb 119 inside tie/overload accessors. */
c277df42 120 }
4633a7c4 121 }
a0d0e21e 122
72311751 123#ifndef INCOMPLETE_TAINTS
3280af22
NIS
124 if (PL_tainting) {
125 if (PL_tainted)
72311751
GS
126 pm->op_pmdynflags |= PMdf_TAINTED;
127 else
128 pm->op_pmdynflags &= ~PMdf_TAINTED;
129 }
130#endif
131
3280af22
NIS
132 if (!pm->op_pmregexp->prelen && PL_curpm)
133 pm = PL_curpm;
a0d0e21e
LW
134 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
135 pm->op_pmflags |= PMf_WHITE;
136
2360cd68 137 /* XXX runtime compiled output needs to move to the pad */
a0d0e21e 138 if (pm->op_pmflags & PMf_KEEP) {
c90c0ff4 139 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
2360cd68
GS
140#if !defined(USE_ITHREADS) && !defined(USE_THREADS)
141 /* XXX can't change the optree at runtime either */
533c011a 142 cLOGOP->op_first->op_next = PL_op->op_next;
2360cd68 143#endif
a0d0e21e
LW
144 }
145 RETURN;
146}
147
148PP(pp_substcont)
149{
4e35701f 150 djSP;
a0d0e21e 151 register PMOP *pm = (PMOP*) cLOGOP->op_other;
c09156bb 152 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
a0d0e21e
LW
153 register SV *dstr = cx->sb_dstr;
154 register char *s = cx->sb_s;
155 register char *m = cx->sb_m;
156 char *orig = cx->sb_orig;
d9f97599 157 register REGEXP *rx = cx->sb_rx;
a0d0e21e 158
d9f97599 159 rxres_restore(&cx->sb_rxres, rx);
c90c0ff4 160
a0d0e21e
LW
161 if (cx->sb_iters++) {
162 if (cx->sb_iters > cx->sb_maxiters)
cea2e8a9 163 DIE(aTHX_ "Substitution loop");
a0d0e21e 164
48c036b1
GS
165 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
166 cx->sb_rxtainted |= 2;
a0d0e21e 167 sv_catsv(dstr, POPs);
a0d0e21e
LW
168
169 /* Are we done */
cea2e8a9 170 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
9661b544 171 s == m, cx->sb_targ, NULL,
22e551b9 172 ((cx->sb_rflags & REXEC_COPY_STR)
cf93c79d
IZ
173 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
174 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
a0d0e21e
LW
175 {
176 SV *targ = cx->sb_targ;
177 sv_catpvn(dstr, s, cx->sb_strend - s);
748a9306 178
48c036b1 179 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
9212bbba 180
4633a7c4 181 (void)SvOOK_off(targ);
cb0b1708 182 Safefree(SvPVX(targ));
748a9306
LW
183 SvPVX(targ) = SvPVX(dstr);
184 SvCUR_set(targ, SvCUR(dstr));
185 SvLEN_set(targ, SvLEN(dstr));
186 SvPVX(dstr) = 0;
187 sv_free(dstr);
48c036b1
GS
188
189 TAINT_IF(cx->sb_rxtainted & 1);
190 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
191
a0d0e21e 192 (void)SvPOK_only(targ);
48c036b1 193 TAINT_IF(cx->sb_rxtainted);
a0d0e21e 194 SvSETMAGIC(targ);
9212bbba 195 SvTAINT(targ);
5cd24f17 196
4633a7c4 197 LEAVE_SCOPE(cx->sb_oldsave);
a0d0e21e
LW
198 POPSUBST(cx);
199 RETURNOP(pm->op_next);
200 }
201 }
cf93c79d 202 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW
203 m = s;
204 s = orig;
cf93c79d 205 cx->sb_orig = orig = rx->subbeg;
a0d0e21e
LW
206 s = orig + (m - s);
207 cx->sb_strend = s + (cx->sb_strend - m);
208 }
cf93c79d 209 cx->sb_m = m = rx->startp[0] + orig;
a0d0e21e 210 sv_catpvn(dstr, s, m-s);
cf93c79d 211 cx->sb_s = rx->endp[0] + orig;
d9f97599
GS
212 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
213 rxres_save(&cx->sb_rxres, rx);
a0d0e21e
LW
214 RETURNOP(pm->op_pmreplstart);
215}
216
c90c0ff4 217void
864dbfa3 218Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4
PP
219{
220 UV *p = (UV*)*rsp;
221 U32 i;
222
d9f97599
GS
223 if (!p || p[1] < rx->nparens) {
224 i = 6 + rx->nparens * 2;
c90c0ff4
PP
225 if (!p)
226 New(501, p, i, UV);
227 else
228 Renew(p, i, UV);
229 *rsp = (void*)p;
230 }
231
56431972 232 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
cf93c79d 233 RX_MATCH_COPIED_off(rx);
c90c0ff4 234
d9f97599 235 *p++ = rx->nparens;
c90c0ff4 236
56431972 237 *p++ = PTR2UV(rx->subbeg);
cf93c79d 238 *p++ = (UV)rx->sublen;
d9f97599
GS
239 for (i = 0; i <= rx->nparens; ++i) {
240 *p++ = (UV)rx->startp[i];
241 *p++ = (UV)rx->endp[i];
c90c0ff4
PP
242 }
243}
244
245void
864dbfa3 246Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
c90c0ff4
PP
247{
248 UV *p = (UV*)*rsp;
249 U32 i;
250
cf93c79d
IZ
251 if (RX_MATCH_COPIED(rx))
252 Safefree(rx->subbeg);
253 RX_MATCH_COPIED_set(rx, *p);
c90c0ff4
PP
254 *p++ = 0;
255
d9f97599 256 rx->nparens = *p++;
c90c0ff4 257
56431972 258 rx->subbeg = INT2PTR(char*,*p++);
cf93c79d 259 rx->sublen = (I32)(*p++);
d9f97599 260 for (i = 0; i <= rx->nparens; ++i) {
cf93c79d
IZ
261 rx->startp[i] = (I32)(*p++);
262 rx->endp[i] = (I32)(*p++);
c90c0ff4
PP
263 }
264}
265
266void
864dbfa3 267Perl_rxres_free(pTHX_ void **rsp)
c90c0ff4
PP
268{
269 UV *p = (UV*)*rsp;
270
271 if (p) {
56431972 272 Safefree(INT2PTR(char*,*p));
c90c0ff4
PP
273 Safefree(p);
274 *rsp = Null(void*);
275 }
276}
277
a0d0e21e
LW
278PP(pp_formline)
279{
4e35701f 280 djSP; dMARK; dORIGMARK;
76e3520e 281 register SV *tmpForm = *++MARK;
a0d0e21e
LW
282 register U16 *fpc;
283 register char *t;
284 register char *f;
285 register char *s;
286 register char *send;
287 register I32 arg;
288 register SV *sv;
289 char *item;
290 I32 itemsize;
291 I32 fieldsize;
292 I32 lines = 0;
3280af22 293 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
a0d0e21e
LW
294 char *chophere;
295 char *linemark;
65202027 296 NV value;
a0d0e21e
LW
297 bool gotsome;
298 STRLEN len;
a0ed51b3 299 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
a0d0e21e 300
76e3520e
GS
301 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
302 SvREADONLY_off(tmpForm);
303 doparseform(tmpForm);
a0d0e21e
LW
304 }
305
3280af22 306 SvPV_force(PL_formtarget, len);
a0ed51b3 307 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
a0d0e21e 308 t += len;
76e3520e 309 f = SvPV(tmpForm, len);
a0d0e21e 310 /* need to jump to the next word */
76e3520e 311 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
a0d0e21e
LW
312
313 fpc = (U16*)s;
314
315 for (;;) {
316 DEBUG_f( {
317 char *name = "???";
318 arg = -1;
319 switch (*fpc) {
320 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
321 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
322 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
323 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
324 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
325
326 case FF_CHECKNL: name = "CHECKNL"; break;
327 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
328 case FF_SPACE: name = "SPACE"; break;
329 case FF_HALFSPACE: name = "HALFSPACE"; break;
330 case FF_ITEM: name = "ITEM"; break;
331 case FF_CHOP: name = "CHOP"; break;
332 case FF_LINEGLOB: name = "LINEGLOB"; break;
333 case FF_NEWLINE: name = "NEWLINE"; break;
334 case FF_MORE: name = "MORE"; break;
335 case FF_LINEMARK: name = "LINEMARK"; break;
336 case FF_END: name = "END"; break;
337 }
338 if (arg >= 0)
bf49b057 339 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
a0d0e21e 340 else
bf49b057 341 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
a0d0e21e
LW
342 } )
343 switch (*fpc++) {
344 case FF_LINEMARK:
345 linemark = t;
a0d0e21e
LW
346 lines++;
347 gotsome = FALSE;
348 break;
349
350 case FF_LITERAL:
351 arg = *fpc++;
352 while (arg--)
353 *t++ = *f++;
354 break;
355
356 case FF_SKIP:
357 f += *fpc++;
358 break;
359
360 case FF_FETCH:
361 arg = *fpc++;
362 f += arg;
363 fieldsize = arg;
364
365 if (MARK < SP)
366 sv = *++MARK;
367 else {
3280af22 368 sv = &PL_sv_no;
599cee73 369 if (ckWARN(WARN_SYNTAX))
cea2e8a9 370 Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
a0d0e21e
LW
371 }
372 break;
373
374 case FF_CHECKNL:
375 item = s = SvPV(sv, len);
376 itemsize = len;
a0ed51b3
LW
377 if (IN_UTF8) {
378 itemsize = sv_len_utf8(sv);
379 if (itemsize != len) {
380 I32 itembytes;
381 if (itemsize > fieldsize) {
382 itemsize = fieldsize;
383 itembytes = itemsize;
384 sv_pos_u2b(sv, &itembytes, 0);
385 }
386 else
387 itembytes = len;
388 send = chophere = s + itembytes;
389 while (s < send) {
390 if (*s & ~31)
391 gotsome = TRUE;
392 else if (*s == '\n')
393 break;
394 s++;
395 }
396 itemsize = s - item;
397 sv_pos_b2u(sv, &itemsize);
398 break;
399 }
400 }
a0d0e21e
LW
401 if (itemsize > fieldsize)
402 itemsize = fieldsize;
403 send = chophere = s + itemsize;
404 while (s < send) {
405 if (*s & ~31)
406 gotsome = TRUE;
407 else if (*s == '\n')
408 break;
409 s++;
410 }
411 itemsize = s - item;
412 break;
413
414 case FF_CHECKCHOP:
415 item = s = SvPV(sv, len);
416 itemsize = len;
a0ed51b3
LW
417 if (IN_UTF8) {
418 itemsize = sv_len_utf8(sv);
419 if (itemsize != len) {
420 I32 itembytes;
421 if (itemsize <= fieldsize) {
422 send = chophere = s + itemsize;
423 while (s < send) {
424 if (*s == '\r') {
425 itemsize = s - item;
426 break;
427 }
428 if (*s++ & ~31)
429 gotsome = TRUE;
430 }
431 }
432 else {
433 itemsize = fieldsize;
434 itembytes = itemsize;
435 sv_pos_u2b(sv, &itembytes, 0);
436 send = chophere = s + itembytes;
437 while (s < send || (s == send && isSPACE(*s))) {
438 if (isSPACE(*s)) {
439 if (chopspace)
440 chophere = s;
441 if (*s == '\r')
442 break;
443 }
444 else {
445 if (*s & ~31)
446 gotsome = TRUE;
447 if (strchr(PL_chopset, *s))
448 chophere = s + 1;
449 }
450 s++;
451 }
452 itemsize = chophere - item;
453 sv_pos_b2u(sv, &itemsize);
454 }
455 break;
456 }
457 }
a0d0e21e
LW
458 if (itemsize <= fieldsize) {
459 send = chophere = s + itemsize;
460 while (s < send) {
461 if (*s == '\r') {
462 itemsize = s - item;
463 break;
464 }
465 if (*s++ & ~31)
466 gotsome = TRUE;
467 }
468 }
469 else {
470 itemsize = fieldsize;
471 send = chophere = s + itemsize;
472 while (s < send || (s == send && isSPACE(*s))) {
473 if (isSPACE(*s)) {
474 if (chopspace)
475 chophere = s;
476 if (*s == '\r')
477 break;
478 }
479 else {
480 if (*s & ~31)
481 gotsome = TRUE;
3280af22 482 if (strchr(PL_chopset, *s))
a0d0e21e
LW
483 chophere = s + 1;
484 }
485 s++;
486 }
487 itemsize = chophere - item;
488 }
489 break;
490
491 case FF_SPACE:
492 arg = fieldsize - itemsize;
493 if (arg) {
494 fieldsize -= arg;
495 while (arg-- > 0)
496 *t++ = ' ';
497 }
498 break;
499
500 case FF_HALFSPACE:
501 arg = fieldsize - itemsize;
502 if (arg) {
503 arg /= 2;
504 fieldsize -= arg;
505 while (arg-- > 0)
506 *t++ = ' ';
507 }
508 break;
509
510 case FF_ITEM:
511 arg = itemsize;
512 s = item;
a0ed51b3
LW
513 if (IN_UTF8) {
514 while (arg--) {
515 if (*s & 0x80) {
516 switch (UTF8SKIP(s)) {
517 case 7: *t++ = *s++;
518 case 6: *t++ = *s++;
519 case 5: *t++ = *s++;
520 case 4: *t++ = *s++;
521 case 3: *t++ = *s++;
522 case 2: *t++ = *s++;
523 case 1: *t++ = *s++;
524 }
525 }
526 else {
527 if ( !((*t++ = *s++) & ~31) )
528 t[-1] = ' ';
529 }
530 }
531 break;
532 }
a0d0e21e 533 while (arg--) {
9d116dd7 534#ifdef EBCDIC
a0d0e21e 535 int ch = *t++ = *s++;
9d116dd7 536 if (iscntrl(ch))
a0d0e21e
LW
537#else
538 if ( !((*t++ = *s++) & ~31) )
a0d0e21e 539#endif
9d116dd7 540 t[-1] = ' ';
a0d0e21e
LW
541 }
542 break;
543
544 case FF_CHOP:
545 s = chophere;
546 if (chopspace) {
547 while (*s && isSPACE(*s))
548 s++;
549 }
550 sv_chop(sv,s);
551 break;
552
553 case FF_LINEGLOB:
554 item = s = SvPV(sv, len);
555 itemsize = len;
556 if (itemsize) {
557 gotsome = TRUE;
558 send = s + itemsize;
559 while (s < send) {
560 if (*s++ == '\n') {
561 if (s == send)
562 itemsize--;
563 else
564 lines++;
565 }
566 }
3280af22
NIS
567 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
568 sv_catpvn(PL_formtarget, item, itemsize);
a0ed51b3 569 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
3280af22 570 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
a0d0e21e
LW
571 }
572 break;
573
574 case FF_DECIMAL:
575 /* If the field is marked with ^ and the value is undefined,
576 blank it out. */
577 arg = *fpc++;
578 if ((arg & 512) && !SvOK(sv)) {
579 arg = fieldsize;
580 while (arg--)
581 *t++ = ' ';
582 break;
583 }
584 gotsome = TRUE;
585 value = SvNV(sv);
bbce6d69 586 /* Formats aren't yet marked for locales, so assume "yes". */
097ee67d
JH
587 {
588 RESTORE_NUMERIC_LOCAL();
65202027
DS
589#if defined(USE_LONG_DOUBLE)
590 if (arg & 256) {
cf2093f6 591 sprintf(t, "%#*.*" PERL_PRIfldbl,
65202027
DS
592 (int) fieldsize, (int) arg & 255, value);
593 } else {
cf2093f6 594 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
65202027
DS
595 }
596#else
097ee67d
JH
597 if (arg & 256) {
598 sprintf(t, "%#*.*f",
599 (int) fieldsize, (int) arg & 255, value);
600 } else {
601 sprintf(t, "%*.0f",
602 (int) fieldsize, value);
603 }
65202027 604#endif
097ee67d 605 RESTORE_NUMERIC_STANDARD();
a0d0e21e
LW
606 }
607 t += fieldsize;
608 break;
609
610 case FF_NEWLINE:
611 f++;
612 while (t-- > linemark && *t == ' ') ;
613 t++;
614 *t++ = '\n';
615 break;
616
617 case FF_BLANK:
618 arg = *fpc++;
619 if (gotsome) {
620 if (arg) { /* repeat until fields exhausted? */
621 *t = '\0';
3280af22
NIS
622 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
623 lines += FmLINES(PL_formtarget);
a0d0e21e
LW
624 if (lines == 200) {
625 arg = t - linemark;
626 if (strnEQ(linemark, linemark - arg, arg))
cea2e8a9 627 DIE(aTHX_ "Runaway format");
a0d0e21e 628 }
3280af22 629 FmLINES(PL_formtarget) = lines;
a0d0e21e
LW
630 SP = ORIGMARK;
631 RETURNOP(cLISTOP->op_first);
632 }
633 }
634 else {
635 t = linemark;
636 lines--;
637 }
638 break;
639
640 case FF_MORE:
7056ecde
URCI
641 s = chophere;
642 send = item + len;
643 if (chopspace) {
644 while (*s && isSPACE(*s) && s < send)
645 s++;
646 }
647 if (s < send) {
a0d0e21e
LW
648 arg = fieldsize - itemsize;
649 if (arg) {
650 fieldsize -= arg;
651 while (arg-- > 0)
652 *t++ = ' ';
653 }
654 s = t - 3;
655 if (strnEQ(s," ",3)) {
3280af22 656 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
a0d0e21e
LW
657 s--;
658 }
659 *s++ = '.';
660 *s++ = '.';
661 *s++ = '.';
662 }
663 break;
664
665 case FF_END:
666 *t = '\0';
3280af22
NIS
667 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
668 FmLINES(PL_formtarget) += lines;
a0d0e21e
LW
669 SP = ORIGMARK;
670 RETPUSHYES;
671 }
672 }
673}
674
675PP(pp_grepstart)
676{
4e35701f 677 djSP;
a0d0e21e
LW
678 SV *src;
679
3280af22 680 if (PL_stack_base + *PL_markstack_ptr == SP) {
a0d0e21e 681 (void)POPMARK;
54310121 682 if (GIMME_V == G_SCALAR)
0b024f31 683 XPUSHs(sv_2mortal(newSViv(0)));
533c011a 684 RETURNOP(PL_op->op_next->op_next);
a0d0e21e 685 }
3280af22 686 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
cea2e8a9
GS
687 pp_pushmark(); /* push dst */
688 pp_pushmark(); /* push src */
a0d0e21e
LW
689 ENTER; /* enter outer scope */
690
691 SAVETMPS;
127ad2b7
GS
692 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
693 SAVESPTR(DEFSV);
a0d0e21e 694 ENTER; /* enter inner scope */
7766f137 695 SAVEVPTR(PL_curpm);
a0d0e21e 696
3280af22 697 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 698 SvTEMP_off(src);
54b9620d 699 DEFSV = src;
a0d0e21e
LW
700
701 PUTBACK;
533c011a 702 if (PL_op->op_type == OP_MAPSTART)
cea2e8a9 703 pp_pushmark(); /* push top */
533c011a 704 return ((LOGOP*)PL_op->op_next)->op_other;
a0d0e21e
LW
705}
706
707PP(pp_mapstart)
708{
cea2e8a9 709 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
a0d0e21e
LW
710}
711
712PP(pp_mapwhile)
713{
4e35701f 714 djSP;
3280af22 715 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
a0d0e21e
LW
716 I32 count;
717 I32 shift;
718 SV** src;
719 SV** dst;
720
3280af22 721 ++PL_markstack_ptr[-1];
a0d0e21e 722 if (diff) {
3280af22
NIS
723 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
724 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
725 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
a0d0e21e 726
924508f0
GS
727 EXTEND(SP,shift);
728 src = SP;
729 dst = (SP += shift);
3280af22
NIS
730 PL_markstack_ptr[-1] += shift;
731 *PL_markstack_ptr += shift;
a0d0e21e
LW
732 while (--count)
733 *dst-- = *src--;
734 }
3280af22 735 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
a0d0e21e
LW
736 ++diff;
737 while (--diff)
738 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
739 }
740 LEAVE; /* exit inner scope */
741
742 /* All done yet? */
3280af22 743 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e 744 I32 items;
54310121 745 I32 gimme = GIMME_V;
a0d0e21e
LW
746
747 (void)POPMARK; /* pop top */
748 LEAVE; /* exit outer scope */
749 (void)POPMARK; /* pop src */
3280af22 750 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 751 (void)POPMARK; /* pop dst */
3280af22 752 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 753 if (gimme == G_SCALAR) {
a0d0e21e
LW
754 dTARGET;
755 XPUSHi(items);
a0d0e21e 756 }
54310121
PP
757 else if (gimme == G_ARRAY)
758 SP += items;
a0d0e21e
LW
759 RETURN;
760 }
761 else {
762 SV *src;
763
764 ENTER; /* enter inner scope */
7766f137 765 SAVEVPTR(PL_curpm);
a0d0e21e 766
3280af22 767 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 768 SvTEMP_off(src);
54b9620d 769 DEFSV = src;
a0d0e21e
LW
770
771 RETURNOP(cLOGOP->op_other);
772 }
773}
774
a0d0e21e
LW
775PP(pp_sort)
776{
4e35701f 777 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
778 register SV **up;
779 SV **myorigmark = ORIGMARK;
780 register I32 max;
781 HV *stash;
782 GV *gv;
783 CV *cv;
784 I32 gimme = GIMME;
533c011a 785 OP* nextop = PL_op->op_next;
d0ecd44c 786 I32 overloading = 0;
43481408
GS
787 bool hasargs = FALSE;
788 I32 is_xsub = 0;
a0d0e21e
LW
789
790 if (gimme != G_ARRAY) {
791 SP = MARK;
792 RETPUSHUNDEF;
793 }
794
d0abe6c5 795 ENTER;
7766f137 796 SAVEVPTR(PL_sortcop);
533c011a
NIS
797 if (PL_op->op_flags & OPf_STACKED) {
798 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
799 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
800 kid = kUNOP->op_first; /* pass rv2gv */
801 kid = kUNOP->op_first; /* pass leave */
3280af22 802 PL_sortcop = kid->op_next;
11faa288 803 stash = CopSTASH(PL_curcop);
a0d0e21e
LW
804 }
805 else {
806 cv = sv_2cv(*++MARK, &stash, &gv, 0);
43481408
GS
807 if (cv && SvPOK(cv)) {
808 STRLEN n_a;
809 char *proto = SvPV((SV*)cv, n_a);
810 if (proto && strEQ(proto, "$$")) {
811 hasargs = TRUE;
812 }
813 }
a0d0e21e 814 if (!(cv && CvROOT(cv))) {
43481408
GS
815 if (cv && CvXSUB(cv)) {
816 is_xsub = 1;
817 }
818 else if (gv) {
a0d0e21e 819 SV *tmpstr = sv_newmortal();
e5cf08de 820 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 821 DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
a0d0e21e
LW
822 SvPVX(tmpstr));
823 }
43481408 824 else {
cea2e8a9 825 DIE(aTHX_ "Undefined subroutine in sort");
a0d0e21e 826 }
a0d0e21e 827 }
b3933176 828
43481408
GS
829 if (is_xsub)
830 PL_sortcop = (OP*)cv;
831 else {
832 PL_sortcop = CvSTART(cv);
833 SAVEVPTR(CvROOT(cv)->op_ppaddr);
834 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
835
836 SAVEVPTR(PL_curpad);
837 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
838 }
a0d0e21e
LW
839 }
840 }
841 else {
3280af22 842 PL_sortcop = Nullop;
11faa288 843 stash = CopSTASH(PL_curcop);
a0d0e21e
LW
844 }
845
846 up = myorigmark + 1;
847 while (MARK < SP) { /* This may or may not shift down one here. */
848 /*SUPPRESS 560*/
849 if (*up = *++MARK) { /* Weed out nulls. */
9f8d30d5 850 SvTEMP_off(*up);
d0ecd44c 851 if (!PL_sortcop && !SvPOK(*up)) {
2d8e6c8d 852 STRLEN n_a;
d0ecd44c
IZ
853 if (SvAMAGIC(*up))
854 overloading = 1;
855 else
2d8e6c8d 856 (void)sv_2pv(*up, &n_a);
d0ecd44c 857 }
a0d0e21e
LW
858 up++;
859 }
860 }
861 max = --up - myorigmark;
3280af22 862 if (PL_sortcop) {
a0d0e21e 863 if (max > 1) {
c09156bb 864 PERL_CONTEXT *cx;
a0d0e21e 865 SV** newsp;
54310121 866 bool oldcatch = CATCH_GET;
a0d0e21e
LW
867
868 SAVETMPS;
462e5cf6 869 SAVEOP();
a0d0e21e 870
54310121 871 CATCH_SET(TRUE);
e788e7d3 872 PUSHSTACKi(PERLSI_SORT);
3280af22
NIS
873 if (PL_sortstash != stash) {
874 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
875 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
876 PL_sortstash = stash;
a0d0e21e
LW
877 }
878
3280af22
NIS
879 SAVESPTR(GvSV(PL_firstgv));
880 SAVESPTR(GvSV(PL_secondgv));
b3933176 881
3280af22 882 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
533c011a 883 if (!(PL_op->op_flags & OPf_SPECIAL)) {
b3933176
CS
884 cx->cx_type = CXt_SUB;
885 cx->blk_gimme = G_SCALAR;
886 PUSHSUB(cx);
887 if (!CvDEPTH(cv))
3e3baf6d 888 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
b3933176 889 }
3280af22 890 PL_sortcxix = cxstack_ix;
43481408
GS
891
892 if (hasargs && !is_xsub) {
893 /* This is mostly copied from pp_entersub */
894 AV *av = (AV*)PL_curpad[0];
895
896#ifndef USE_THREADS
897 cx->blk_sub.savearray = GvAV(PL_defgv);
898 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
899#endif /* USE_THREADS */
900 cx->blk_sub.argarray = av;
901 }
902 qsortsv((myorigmark+1), max,
903 is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
a0d0e21e 904
3280af22 905 POPBLOCK(cx,PL_curpm);
ebafeae7 906 PL_stack_sp = newsp;
d3acc0f7 907 POPSTACK;
54310121 908 CATCH_SET(oldcatch);
a0d0e21e 909 }
a0d0e21e
LW
910 }
911 else {
912 if (max > 1) {
913 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
745d3a65 914 qsortsv(ORIGMARK+1, max,
9c007264
JH
915 (PL_op->op_private & OPpSORT_NUMERIC)
916 ? ( (PL_op->op_private & OPpSORT_INTEGER)
0b94c7bb
GS
917 ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
918 : ( overloading ? amagic_ncmp : sv_ncmp))
9c007264
JH
919 : ( (PL_op->op_private & OPpLOCALE)
920 ? ( overloading
0b94c7bb
GS
921 ? amagic_cmp_locale
922 : sv_cmp_locale_static)
923 : ( overloading ? amagic_cmp : sv_cmp_static)));
9c007264
JH
924 if (PL_op->op_private & OPpSORT_REVERSE) {
925 SV **p = ORIGMARK+1;
926 SV **q = ORIGMARK+max;
927 while (p < q) {
928 SV *tmp = *p;
929 *p++ = *q;
930 *q-- = tmp;
931 }
932 }
a0d0e21e
LW
933 }
934 }
d0abe6c5 935 LEAVE;
3280af22 936 PL_stack_sp = ORIGMARK + max;
a0d0e21e
LW
937 return nextop;
938}
939
940/* Range stuff. */
941
942PP(pp_range)
943{
944 if (GIMME == G_ARRAY)
1a67a97c 945 return NORMAL;
538573f7 946 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1a67a97c 947 return cLOGOP->op_other;
538573f7 948 else
1a67a97c 949 return NORMAL;
a0d0e21e
LW
950}
951
952PP(pp_flip)
953{
4e35701f 954 djSP;
a0d0e21e
LW
955
956 if (GIMME == G_ARRAY) {
1a67a97c 957 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW
958 }
959 else {
960 dTOPss;
533c011a 961 SV *targ = PAD_SV(PL_op->op_targ);
a0d0e21e 962
533c011a 963 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 964 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW
965 : SvTRUE(sv) ) {
966 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 967 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 968 sv_setiv(targ, 1);
3e3baf6d 969 SETs(targ);
a0d0e21e
LW
970 RETURN;
971 }
972 else {
973 sv_setiv(targ, 0);
924508f0 974 SP--;
1a67a97c 975 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
a0d0e21e
LW
976 }
977 }
978 sv_setpv(TARG, "");
979 SETs(targ);
980 RETURN;
981 }
982}
983
984PP(pp_flop)
985{
4e35701f 986 djSP;
a0d0e21e
LW
987
988 if (GIMME == G_ARRAY) {
989 dPOPPOPssrl;
c1ab3db2 990 register I32 i, j;
a0d0e21e
LW
991 register SV *sv;
992 I32 max;
86cb7173
HS
993
994 if (SvGMAGICAL(left))
995 mg_get(left);
996 if (SvGMAGICAL(right))
997 mg_get(right);
a0d0e21e 998
4633a7c4 999 if (SvNIOKp(left) || !SvPOKp(left) ||
39eb4040
GS
1000 SvNIOKp(right) || !SvPOKp(right) ||
1001 (looks_like_number(left) && *SvPVX(left) != '0' &&
1002 looks_like_number(right) && *SvPVX(right) != '0'))
bbce6d69 1003 {
c1ab3db2 1004 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
d470f89e 1005 DIE(aTHX_ "Range iterator outside integer range");
a0d0e21e
LW
1006 i = SvIV(left);
1007 max = SvIV(right);
bbce6d69 1008 if (max >= i) {
c1ab3db2
AK
1009 j = max - i + 1;
1010 EXTEND_MORTAL(j);
1011 EXTEND(SP, j);
bbce6d69 1012 }
c1ab3db2
AK
1013 else
1014 j = 0;
1015 while (j--) {
bbce6d69 1016 sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW
1017 PUSHs(sv);
1018 }
1019 }
1020 else {
1021 SV *final = sv_mortalcopy(right);
2d8e6c8d 1022 STRLEN len, n_a;
a0d0e21e
LW
1023 char *tmps = SvPV(final, len);
1024
1025 sv = sv_mortalcopy(left);
2d8e6c8d 1026 SvPV_force(sv,n_a);
89ea2908 1027 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1028 XPUSHs(sv);
89ea2908
GA
1029 if (strEQ(SvPVX(sv),tmps))
1030 break;
a0d0e21e
LW
1031 sv = sv_2mortal(newSVsv(sv));
1032 sv_inc(sv);
1033 }
a0d0e21e
LW
1034 }
1035 }
1036 else {
1037 dTOPss;
1038 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1039 sv_inc(targ);
533c011a 1040 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 1041 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW
1042 : SvTRUE(sv) ) {
1043 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1044 sv_catpv(targ, "E0");
1045 }
1046 SETs(targ);
1047 }
1048
1049 RETURN;
1050}
1051
1052/* Control. */
1053
76e3520e 1054STATIC I32
cea2e8a9 1055S_dopoptolabel(pTHX_ char *label)
a0d0e21e 1056{
11343788 1057 dTHR;
a0d0e21e 1058 register I32 i;
c09156bb 1059 register PERL_CONTEXT *cx;
a0d0e21e
LW
1060
1061 for (i = cxstack_ix; i >= 0; i--) {
1062 cx = &cxstack[i];
6b35e009 1063 switch (CxTYPE(cx)) {
a0d0e21e 1064 case CXt_SUBST:
599cee73 1065 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1066 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
22c35a8c 1067 PL_op_name[PL_op->op_type]);
a0d0e21e
LW
1068 break;
1069 case CXt_SUB:
599cee73 1070 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1071 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
22c35a8c 1072 PL_op_name[PL_op->op_type]);
a0d0e21e 1073 break;
7766f137
GS
1074 case CXt_FORMAT:
1075 if (ckWARN(WARN_UNSAFE))
1076 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1077 PL_op_name[PL_op->op_type]);
1078 break;
a0d0e21e 1079 case CXt_EVAL:
599cee73 1080 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1081 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
22c35a8c 1082 PL_op_name[PL_op->op_type]);
a0d0e21e 1083 break;
0a753a76 1084 case CXt_NULL:
599cee73 1085 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1086 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
22c35a8c 1087 PL_op_name[PL_op->op_type]);
0a753a76 1088 return -1;
a0d0e21e
LW
1089 case CXt_LOOP:
1090 if (!cx->blk_loop.label ||
1091 strNE(label, cx->blk_loop.label) ) {
cea2e8a9 1092 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
68dc0745 1093 (long)i, cx->blk_loop.label));
a0d0e21e
LW
1094 continue;
1095 }
cea2e8a9 1096 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW
1097 return i;
1098 }
1099 }
1100 return i;
1101}
1102
e50aee73 1103I32
864dbfa3 1104Perl_dowantarray(pTHX)
e50aee73 1105{
54310121
PP
1106 I32 gimme = block_gimme();
1107 return (gimme == G_VOID) ? G_SCALAR : gimme;
1108}
1109
1110I32
864dbfa3 1111Perl_block_gimme(pTHX)
54310121 1112{
11343788 1113 dTHR;
e50aee73
AD
1114 I32 cxix;
1115
1116 cxix = dopoptosub(cxstack_ix);
1117 if (cxix < 0)
46fc3d4c 1118 return G_VOID;
e50aee73 1119
54310121 1120 switch (cxstack[cxix].blk_gimme) {
d2719217
GS
1121 case G_VOID:
1122 return G_VOID;
54310121 1123 case G_SCALAR:
e50aee73 1124 return G_SCALAR;
54310121
PP
1125 case G_ARRAY:
1126 return G_ARRAY;
1127 default:
cea2e8a9 1128 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS
1129 /* NOTREACHED */
1130 return 0;
54310121 1131 }
e50aee73
AD
1132}
1133
76e3520e 1134STATIC I32
cea2e8a9 1135S_dopoptosub(pTHX_ I32 startingblock)
a0d0e21e 1136{
11343788 1137 dTHR;
2c375eb9
GS
1138 return dopoptosub_at(cxstack, startingblock);
1139}
1140
1141STATIC I32
cea2e8a9 1142S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
2c375eb9
GS
1143{
1144 dTHR;
a0d0e21e 1145 I32 i;
c09156bb 1146 register PERL_CONTEXT *cx;
a0d0e21e 1147 for (i = startingblock; i >= 0; i--) {
2c375eb9 1148 cx = &cxstk[i];
6b35e009 1149 switch (CxTYPE(cx)) {
a0d0e21e
LW
1150 default:
1151 continue;
1152 case CXt_EVAL:
1153 case CXt_SUB:
7766f137 1154 case CXt_FORMAT:
cea2e8a9 1155 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
a0d0e21e
LW
1156 return i;
1157 }
1158 }
1159 return i;
1160}
1161
76e3520e 1162STATIC I32
cea2e8a9 1163S_dopoptoeval(pTHX_ I32 startingblock)
a0d0e21e 1164{
11343788 1165 dTHR;
a0d0e21e 1166 I32 i;
c09156bb 1167 register PERL_CONTEXT *cx;
a0d0e21e
LW
1168 for (i = startingblock; i >= 0; i--) {
1169 cx = &cxstack[i];
6b35e009 1170 switch (CxTYPE(cx)) {
a0d0e21e
LW
1171 default:
1172 continue;
1173 case CXt_EVAL:
cea2e8a9 1174 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
a0d0e21e
LW
1175 return i;
1176 }
1177 }
1178 return i;
1179}
1180
76e3520e 1181STATIC I32
cea2e8a9 1182S_dopoptoloop(pTHX_ I32 startingblock)
a0d0e21e 1183{
11343788 1184 dTHR;
a0d0e21e 1185 I32 i;
c09156bb 1186 register PERL_CONTEXT *cx;
a0d0e21e
LW
1187 for (i = startingblock; i >= 0; i--) {
1188 cx = &cxstack[i];
6b35e009 1189 switch (CxTYPE(cx)) {
a0d0e21e 1190 case CXt_SUBST:
599cee73 1191 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1192 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s",
22c35a8c 1193 PL_op_name[PL_op->op_type]);
a0d0e21e
LW
1194 break;
1195 case CXt_SUB:
599cee73 1196 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1197 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s",
22c35a8c 1198 PL_op_name[PL_op->op_type]);
a0d0e21e 1199 break;
7766f137
GS
1200 case CXt_FORMAT:
1201 if (ckWARN(WARN_UNSAFE))
1202 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s",
1203 PL_op_name[PL_op->op_type]);
1204 break;
a0d0e21e 1205 case CXt_EVAL:
599cee73 1206 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1207 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s",
22c35a8c 1208 PL_op_name[PL_op->op_type]);
a0d0e21e 1209 break;
0a753a76 1210 case CXt_NULL:
599cee73 1211 if (ckWARN(WARN_UNSAFE))
cea2e8a9 1212 Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s",
22c35a8c 1213 PL_op_name[PL_op->op_type]);
0a753a76 1214 return -1;
a0d0e21e 1215 case CXt_LOOP:
cea2e8a9 1216 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
a0d0e21e
LW
1217 return i;
1218 }
1219 }
1220 return i;
1221}
1222
1223void
864dbfa3 1224Perl_dounwind(pTHX_ I32 cxix)
a0d0e21e 1225{
11343788 1226 dTHR;
c09156bb 1227 register PERL_CONTEXT *cx;
a0d0e21e
LW
1228 SV **newsp;
1229 I32 optype;
1230
1231 while (cxstack_ix > cxix) {
b0d9ce38 1232 SV *sv;
c90c0ff4
PP
1233 cx = &cxstack[cxstack_ix];
1234 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1235 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1236 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1237 switch (CxTYPE(cx)) {
c90c0ff4
PP
1238 case CXt_SUBST:
1239 POPSUBST(cx);
1240 continue; /* not break */
a0d0e21e 1241 case CXt_SUB:
b0d9ce38
GS
1242 POPSUB(cx,sv);
1243 LEAVESUB(sv);
a0d0e21e
LW
1244 break;
1245 case CXt_EVAL:
1246 POPEVAL(cx);
1247 break;
1248 case CXt_LOOP:
1249 POPLOOP(cx);
1250 break;
0a753a76 1251 case CXt_NULL:
a0d0e21e 1252 break;
7766f137
GS
1253 case CXt_FORMAT:
1254 POPFORMAT(cx);
1255 break;
a0d0e21e 1256 }
c90c0ff4 1257 cxstack_ix--;
a0d0e21e
LW
1258 }
1259}
1260
067f92a0
GS
1261/*
1262 * Closures mentioned at top level of eval cannot be referenced
1263 * again, and their presence indirectly causes a memory leak.
1264 * (Note that the fact that compcv and friends are still set here
1265 * is, AFAIK, an accident.) --Chip
1266 *
1267 * XXX need to get comppad et al from eval's cv rather than
1268 * relying on the incidental global values.
1269 */
1270STATIC void
cea2e8a9 1271S_free_closures(pTHX)
067f92a0
GS
1272{
1273 dTHR;
1274 SV **svp = AvARRAY(PL_comppad_name);
1275 I32 ix;
1276 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1277 SV *sv = svp[ix];
1278 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1279 SvREFCNT_dec(sv);
1280 svp[ix] = &PL_sv_undef;
1281
1282 sv = PL_curpad[ix];
1283 if (CvCLONE(sv)) {
1284 SvREFCNT_dec(CvOUTSIDE(sv));
1285 CvOUTSIDE(sv) = Nullcv;
1286 }
1287 else {
1288 SvREFCNT_dec(sv);
1289 sv = NEWSV(0,0);
1290 SvPADTMP_on(sv);
1291 PL_curpad[ix] = sv;
1292 }
1293 }
1294 }
1295}
1296
5a844595
GS
1297void
1298Perl_qerror(pTHX_ SV *err)
1299{
1300 if (PL_in_eval)
1301 sv_catsv(ERRSV, err);
1302 else if (PL_errors)
1303 sv_catsv(PL_errors, err);
1304 else
1305 Perl_warn(aTHX_ "%_", err);
1306 ++PL_error_count;
1307}
1308
a0d0e21e 1309OP *
864dbfa3 1310Perl_die_where(pTHX_ char *message, STRLEN msglen)
a0d0e21e 1311{
e336de0d 1312 dSP;
2d8e6c8d 1313 STRLEN n_a;
3280af22 1314 if (PL_in_eval) {
a0d0e21e 1315 I32 cxix;
c09156bb 1316 register PERL_CONTEXT *cx;
a0d0e21e
LW
1317 I32 gimme;
1318 SV **newsp;
1319
4e6ea2c3 1320 if (message) {
faef0170 1321 if (PL_in_eval & EVAL_KEEPERR) {
98eae8f5
GS
1322 static char prefix[] = "\t(in cleanup) ";
1323 SV *err = ERRSV;
1324 char *e = Nullch;
1325 if (!SvPOK(err))
1326 sv_setpv(err,"");
1327 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1328 e = SvPV(err, n_a);
1329 e += n_a - msglen;
1330 if (*e != *message || strNE(e,message))
1331 e = Nullch;
1332 }
1333 if (!e) {
1334 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1335 sv_catpvn(err, prefix, sizeof(prefix)-1);
1336 sv_catpvn(err, message, msglen);
1337 if (ckWARN(WARN_UNSAFE)) {
1338 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1339 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
4e6ea2c3 1340 }
4633a7c4 1341 }
4633a7c4 1342 }
4e6ea2c3 1343 else
06bf62c7 1344 sv_setpvn(ERRSV, message, msglen);
4633a7c4
LW
1345 }
1346 else
06bf62c7 1347 message = SvPVx(ERRSV, msglen);
4e6ea2c3 1348
5a844595
GS
1349 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1350 && PL_curstackinfo->si_prev)
1351 {
bac4b2ad 1352 dounwind(-1);
d3acc0f7 1353 POPSTACK;
bac4b2ad 1354 }
e336de0d 1355
a0d0e21e
LW
1356 if (cxix >= 0) {
1357 I32 optype;
1358
1359 if (cxix < cxstack_ix)
1360 dounwind(cxix);
1361
3280af22 1362 POPBLOCK(cx,PL_curpm);
6b35e009 1363 if (CxTYPE(cx) != CXt_EVAL) {
bf49b057
GS
1364 PerlIO_write(Perl_error_log, "panic: die ", 11);
1365 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW
1366 my_exit(1);
1367 }
1368 POPEVAL(cx);
1369
1370 if (gimme == G_SCALAR)
3280af22
NIS
1371 *++newsp = &PL_sv_undef;
1372 PL_stack_sp = newsp;
a0d0e21e
LW
1373
1374 LEAVE;
748a9306 1375
7a2e2cd6 1376 if (optype == OP_REQUIRE) {
2d8e6c8d 1377 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS
1378 DIE(aTHX_ "%sCompilation failed in require",
1379 *msg ? msg : "Unknown error\n");
7a2e2cd6 1380 }
a0d0e21e
LW
1381 return pop_return();
1382 }
1383 }
9cc2fdd3 1384 if (!message)
06bf62c7 1385 message = SvPVx(ERRSV, msglen);
d175a3f0
GS
1386 {
1387#ifdef USE_SFIO
1388 /* SFIO can really mess with your errno */
1389 int e = errno;
1390#endif
bf49b057
GS
1391 PerlIO *serr = Perl_error_log;
1392
1393 PerlIO_write(serr, message, msglen);
1394 (void)PerlIO_flush(serr);
d175a3f0
GS
1395#ifdef USE_SFIO
1396 errno = e;
1397#endif
1398 }
f86702cc
PP
1399 my_failure_exit();
1400 /* NOTREACHED */
a0d0e21e
LW
1401 return 0;
1402}
1403
1404PP(pp_xor)
1405{
4e35701f 1406 djSP; dPOPTOPssrl;
a0d0e21e
LW
1407 if (SvTRUE(left) != SvTRUE(right))
1408 RETSETYES;
1409 else
1410 RETSETNO;
1411}
1412
1413PP(pp_andassign)
1414{
4e35701f 1415 djSP;
a0d0e21e
LW
1416 if (!SvTRUE(TOPs))
1417 RETURN;
1418 else
1419 RETURNOP(cLOGOP->op_other);
1420}
1421
1422PP(pp_orassign)
1423{
4e35701f 1424 djSP;
a0d0e21e
LW
1425 if (SvTRUE(TOPs))
1426 RETURN;
1427 else
1428 RETURNOP(cLOGOP->op_other);
1429}
1430
a0d0e21e
LW
1431PP(pp_caller)
1432{
4e35701f 1433 djSP;
a0d0e21e 1434 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1435 register PERL_CONTEXT *cx;
2c375eb9 1436 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1437 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1438 I32 dbcxix;
54310121 1439 I32 gimme;
ed094faf 1440 char *stashname;
a0d0e21e
LW
1441 SV *sv;
1442 I32 count = 0;
1443
1444 if (MAXARG)
1445 count = POPi;
f3aa04c2 1446 EXTEND(SP, 7);
a0d0e21e 1447 for (;;) {
2c375eb9
GS
1448 /* we may be in a higher stacklevel, so dig down deeper */
1449 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1450 top_si = top_si->si_prev;
1451 ccstack = top_si->si_cxstack;
1452 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1453 }
a0d0e21e
LW
1454 if (cxix < 0) {
1455 if (GIMME != G_ARRAY)
1456 RETPUSHUNDEF;
1457 RETURN;
1458 }
3280af22
NIS
1459 if (PL_DBsub && cxix >= 0 &&
1460 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW
1461 count++;
1462 if (!count--)
1463 break;
2c375eb9 1464 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1465 }
2c375eb9
GS
1466
1467 cx = &ccstack[cxix];
7766f137 1468 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2c375eb9
GS
1469 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1470 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1471 field below is defined for any cx. */
3280af22 1472 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1473 cx = &ccstack[dbcxix];
06a5b730
PP
1474 }
1475
ed094faf 1476 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1477 if (GIMME != G_ARRAY) {
ed094faf 1478 if (!stashname)
3280af22 1479 PUSHs(&PL_sv_undef);
49d8d3a1
MB
1480 else {
1481 dTARGET;
ed094faf 1482 sv_setpv(TARG, stashname);
49d8d3a1
MB
1483 PUSHs(TARG);
1484 }
a0d0e21e
LW
1485 RETURN;
1486 }
a0d0e21e 1487
ed094faf 1488 if (!stashname)
3280af22 1489 PUSHs(&PL_sv_undef);
49d8d3a1 1490 else
ed094faf
GS
1491 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1492 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
57843af0 1493 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW
1494 if (!MAXARG)
1495 RETURN;
7766f137
GS
1496 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1497 /* So is ccstack[dbcxix]. */
a0d0e21e 1498 sv = NEWSV(49, 0);
2c375eb9 1499 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
a0d0e21e
LW
1500 PUSHs(sv_2mortal(sv));
1501 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1502 }
1503 else {
79cb57f6 1504 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW
1505 PUSHs(sv_2mortal(newSViv(0)));
1506 }
54310121
PP
1507 gimme = (I32)cx->blk_gimme;
1508 if (gimme == G_VOID)
3280af22 1509 PUSHs(&PL_sv_undef);
54310121
PP
1510 else
1511 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1512 if (CxTYPE(cx) == CXt_EVAL) {
06a5b730 1513 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1514 PUSHs(cx->blk_eval.cur_text);
3280af22 1515 PUSHs(&PL_sv_no);
06a5b730
PP
1516 }
1517 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1518 /* Require, put the name. */
1519 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
3280af22 1520 PUSHs(&PL_sv_yes);
06a5b730 1521 }
4633a7c4 1522 }
a682de96
GS
1523 else {
1524 PUSHs(&PL_sv_undef);
1525 PUSHs(&PL_sv_undef);
1526 }
1527 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1528 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1529 {
a0d0e21e
LW
1530 AV *ary = cx->blk_sub.argarray;
1531 int off = AvARRAY(ary) - AvALLOC(ary);
1532
3280af22 1533 if (!PL_dbargs) {
a0d0e21e 1534 GV* tmpgv;
3280af22 1535 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1536 SVt_PVAV)));
a5f75d66 1537 GvMULTI_on(tmpgv);
3280af22 1538 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
a0d0e21e
LW
1539 }
1540
3280af22
NIS
1541 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1542 av_extend(PL_dbargs, AvFILLp(ary) + off);
1543 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1544 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1545 }
f3aa04c2
GS
1546 /* XXX only hints propagated via op_private are currently
1547 * visible (others are not easily accessible, since they
1548 * use the global PL_hints) */
1549 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1550 HINT_PRIVATE_MASK)));
a0d0e21e
LW
1551 RETURN;
1552}
1553
a0d0e21e
LW
1554PP(pp_reset)
1555{
4e35701f 1556 djSP;
a0d0e21e 1557 char *tmps;
2d8e6c8d 1558 STRLEN n_a;
a0d0e21e
LW
1559
1560 if (MAXARG < 1)
1561 tmps = "";
1562 else
2d8e6c8d 1563 tmps = POPpx;
11faa288 1564 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1565 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1566 RETURN;
1567}
1568
1569PP(pp_lineseq)
1570{
1571 return NORMAL;
1572}
1573
1574PP(pp_dbstate)
1575{
533c011a 1576 PL_curcop = (COP*)PL_op;
a0d0e21e 1577 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1578 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW
1579 FREETMPS;
1580
533c011a 1581 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1582 {
924508f0 1583 djSP;
a0d0e21e 1584 register CV *cv;
c09156bb 1585 register PERL_CONTEXT *cx;
748a9306 1586 I32 gimme = G_ARRAY;
a0d0e21e
LW
1587 I32 hasargs;
1588 GV *gv;
1589
3280af22 1590 gv = PL_DBgv;
a0d0e21e 1591 cv = GvCV(gv);
a0d0e21e 1592 if (!cv)
cea2e8a9 1593 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1594
3280af22 1595 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
a0d0e21e 1596 return NORMAL;
748a9306 1597
4633a7c4
LW
1598 ENTER;
1599 SAVETMPS;
1600
3280af22 1601 SAVEI32(PL_debug);
55497cff 1602 SAVESTACK_POS();
3280af22 1603 PL_debug = 0;
748a9306 1604 hasargs = 0;
924508f0 1605 SPAGAIN;
748a9306 1606
533c011a 1607 push_return(PL_op->op_next);
924508f0 1608 PUSHBLOCK(cx, CXt_SUB, SP);
a0d0e21e
LW
1609 PUSHSUB(cx);
1610 CvDEPTH(cv)++;
1611 (void)SvREFCNT_inc(cv);
7766f137 1612 SAVEVPTR(PL_curpad);
3280af22 1613 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
a0d0e21e
LW
1614 RETURNOP(CvSTART(cv));
1615 }
1616 else
1617 return NORMAL;
1618}
1619
1620PP(pp_scope)
1621{
1622 return NORMAL;
1623}
1624
1625PP(pp_enteriter)
1626{
4e35701f 1627 djSP; dMARK;
c09156bb 1628 register PERL_CONTEXT *cx;
54310121 1629 I32 gimme = GIMME_V;
a0d0e21e 1630 SV **svp;
7766f137
GS
1631 U32 cxtype = CXt_LOOP;
1632#ifdef USE_ITHREADS
1633 void *iterdata;
1634#endif
a0d0e21e 1635
4633a7c4
LW
1636 ENTER;
1637 SAVETMPS;
1638
54b9620d 1639#ifdef USE_THREADS
0214ae40
GS
1640 if (PL_op->op_flags & OPf_SPECIAL) {
1641 dTHR;
1642 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1643 SAVEGENERICSV(*svp);
1644 *svp = NEWSV(0,0);
1645 }
a0d0e21e 1646 else
54b9620d 1647#endif /* USE_THREADS */
533c011a
NIS
1648 if (PL_op->op_targ) {
1649 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
54b9620d 1650 SAVESPTR(*svp);
7766f137
GS
1651#ifdef USE_ITHREADS
1652 iterdata = (void*)PL_op->op_targ;
1653 cxtype |= CXp_PADVAR;
1654#endif
54b9620d
MB
1655 }
1656 else {
7766f137
GS
1657 GV *gv = (GV*)POPs;
1658 svp = &GvSV(gv); /* symbol table variable */
0214ae40
GS
1659 SAVEGENERICSV(*svp);
1660 *svp = NEWSV(0,0);
7766f137
GS
1661#ifdef USE_ITHREADS
1662 iterdata = (void*)gv;
1663#endif
54b9620d 1664 }
4633a7c4 1665
a0d0e21e
LW
1666 ENTER;
1667
7766f137
GS
1668 PUSHBLOCK(cx, cxtype, SP);
1669#ifdef USE_ITHREADS
1670 PUSHLOOP(cx, iterdata, MARK);
1671#else
a0d0e21e 1672 PUSHLOOP(cx, svp, MARK);
7766f137 1673#endif
533c011a 1674 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1675 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA
1676 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1677 dPOPss;
1678 if (SvNIOKp(sv) || !SvPOKp(sv) ||
39eb4040
GS
1679 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1680 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1681 looks_like_number((SV*)cx->blk_loop.iterary) &&
1682 *SvPVX(cx->blk_loop.iterary) != '0'))
1683 {
89ea2908
GA
1684 if (SvNV(sv) < IV_MIN ||
1685 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
d470f89e 1686 DIE(aTHX_ "Range iterator outside integer range");
89ea2908
GA
1687 cx->blk_loop.iterix = SvIV(sv);
1688 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1689 }
1690 else
1691 cx->blk_loop.iterlval = newSVsv(sv);
1692 }
1693 }
4633a7c4 1694 else {
3280af22
NIS
1695 cx->blk_loop.iterary = PL_curstack;
1696 AvFILLp(PL_curstack) = SP - PL_stack_base;
1697 cx->blk_loop.iterix = MARK - PL_stack_base;
4633a7c4 1698 }
a0d0e21e
LW
1699
1700 RETURN;
1701}
1702
1703PP(pp_enterloop)
1704{
4e35701f 1705 djSP;
c09156bb 1706 register PERL_CONTEXT *cx;
54310121 1707 I32 gimme = GIMME_V;
a0d0e21e
LW
1708
1709 ENTER;
1710 SAVETMPS;
1711 ENTER;
1712
1713 PUSHBLOCK(cx, CXt_LOOP, SP);
1714 PUSHLOOP(cx, 0, SP);
1715
1716 RETURN;
1717}
1718
1719PP(pp_leaveloop)
1720{
4e35701f 1721 djSP;
c09156bb 1722 register PERL_CONTEXT *cx;
a0d0e21e
LW
1723 I32 gimme;
1724 SV **newsp;
1725 PMOP *newpm;
1726 SV **mark;
1727
1728 POPBLOCK(cx,newpm);
4fdae800 1729 mark = newsp;
a8bba7fa 1730 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1731
a1f49e72 1732 TAINT_NOT;
54310121
PP
1733 if (gimme == G_VOID)
1734 ; /* do nothing */
1735 else if (gimme == G_SCALAR) {
1736 if (mark < SP)
1737 *++newsp = sv_mortalcopy(*SP);
1738 else
3280af22 1739 *++newsp = &PL_sv_undef;
a0d0e21e
LW
1740 }
1741 else {
a1f49e72 1742 while (mark < SP) {
a0d0e21e 1743 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS
1744 TAINT_NOT; /* Each item is independent */
1745 }
a0d0e21e 1746 }
f86702cc
PP
1747 SP = newsp;
1748 PUTBACK;
1749
a8bba7fa 1750 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1751 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1752
a0d0e21e
LW
1753 LEAVE;
1754 LEAVE;
1755
f86702cc 1756 return NORMAL;
a0d0e21e
LW
1757}
1758
1759PP(pp_return)
1760{
4e35701f 1761 djSP; dMARK;
a0d0e21e 1762 I32 cxix;
c09156bb 1763 register PERL_CONTEXT *cx;
f86702cc 1764 bool popsub2 = FALSE;
a0d0e21e
LW
1765 I32 gimme;
1766 SV **newsp;
1767 PMOP *newpm;
1768 I32 optype = 0;
b0d9ce38 1769 SV *sv;
a0d0e21e 1770
3280af22 1771 if (PL_curstackinfo->si_type == PERLSI_SORT) {
7766f137
GS
1772 if (cxstack_ix == PL_sortcxix
1773 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1774 {
3280af22
NIS
1775 if (cxstack_ix > PL_sortcxix)
1776 dounwind(PL_sortcxix);
1777 AvARRAY(PL_curstack)[1] = *SP;
1778 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW
1779 return 0;
1780 }
1781 }
1782
1783 cxix = dopoptosub(cxstack_ix);
1784 if (cxix < 0)
cea2e8a9 1785 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW
1786 if (cxix < cxstack_ix)
1787 dounwind(cxix);
1788
1789 POPBLOCK(cx,newpm);
6b35e009 1790 switch (CxTYPE(cx)) {
a0d0e21e 1791 case CXt_SUB:
f86702cc 1792 popsub2 = TRUE;
a0d0e21e
LW
1793 break;
1794 case CXt_EVAL:
1795 POPEVAL(cx);
067f92a0
GS
1796 if (AvFILLp(PL_comppad_name) >= 0)
1797 free_closures();
1798 lex_end();
748a9306
LW
1799 if (optype == OP_REQUIRE &&
1800 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1801 {
54310121 1802 /* Unassume the success we assumed earlier. */
748a9306 1803 char *name = cx->blk_eval.old_name;
3280af22 1804 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 1805 DIE(aTHX_ "%s did not return a true value", name);
748a9306 1806 }
a0d0e21e 1807 break;
7766f137
GS
1808 case CXt_FORMAT:
1809 POPFORMAT(cx);
1810 break;
a0d0e21e 1811 default:
cea2e8a9 1812 DIE(aTHX_ "panic: return");
a0d0e21e
LW
1813 }
1814
a1f49e72 1815 TAINT_NOT;
a0d0e21e 1816 if (gimme == G_SCALAR) {
a29cdaf0
IZ
1817 if (MARK < SP) {
1818 if (popsub2) {
a8bba7fa 1819 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
1820 if (SvTEMP(TOPs)) {
1821 *++newsp = SvREFCNT_inc(*SP);
1822 FREETMPS;
1823 sv_2mortal(*newsp);
1824 } else {
1825 FREETMPS;
1826 *++newsp = sv_mortalcopy(*SP);
1827 }
1828 } else
1829 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1830 } else
1831 *++newsp = sv_mortalcopy(*SP);
1832 } else
3280af22 1833 *++newsp = &PL_sv_undef;
a0d0e21e 1834 }
54310121 1835 else if (gimme == G_ARRAY) {
a1f49e72 1836 while (++MARK <= SP) {
f86702cc
PP
1837 *++newsp = (popsub2 && SvTEMP(*MARK))
1838 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
1839 TAINT_NOT; /* Each item is independent */
1840 }
a0d0e21e 1841 }
3280af22 1842 PL_stack_sp = newsp;
a0d0e21e 1843
f86702cc
PP
1844 /* Stack values are safe: */
1845 if (popsub2) {
b0d9ce38 1846 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1847 }
b0d9ce38
GS
1848 else
1849 sv = Nullsv;
3280af22 1850 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1851
a0d0e21e 1852 LEAVE;
b0d9ce38 1853 LEAVESUB(sv);
a0d0e21e
LW
1854 return pop_return();
1855}
1856
1857PP(pp_last)
1858{
4e35701f 1859 djSP;
a0d0e21e 1860 I32 cxix;
c09156bb 1861 register PERL_CONTEXT *cx;
f86702cc 1862 I32 pop2 = 0;
a0d0e21e
LW
1863 I32 gimme;
1864 I32 optype;
1865 OP *nextop;
1866 SV **newsp;
1867 PMOP *newpm;
a8bba7fa 1868 SV **mark;
b0d9ce38 1869 SV *sv = Nullsv;
a0d0e21e 1870
533c011a 1871 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1872 cxix = dopoptoloop(cxstack_ix);
1873 if (cxix < 0)
a651a37d 1874 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW
1875 }
1876 else {
1877 cxix = dopoptolabel(cPVOP->op_pv);
1878 if (cxix < 0)
cea2e8a9 1879 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW
1880 }
1881 if (cxix < cxstack_ix)
1882 dounwind(cxix);
1883
1884 POPBLOCK(cx,newpm);
a8bba7fa 1885 mark = newsp;
6b35e009 1886 switch (CxTYPE(cx)) {
a0d0e21e 1887 case CXt_LOOP:
f86702cc 1888 pop2 = CXt_LOOP;
a8bba7fa
GS
1889 newsp = PL_stack_base + cx->blk_loop.resetsp;
1890 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 1891 break;
f86702cc 1892 case CXt_SUB:
f86702cc 1893 pop2 = CXt_SUB;
a0d0e21e
LW
1894 nextop = pop_return();
1895 break;
f86702cc
PP
1896 case CXt_EVAL:
1897 POPEVAL(cx);
a0d0e21e
LW
1898 nextop = pop_return();
1899 break;
7766f137
GS
1900 case CXt_FORMAT:
1901 POPFORMAT(cx);
1902 nextop = pop_return();
1903 break;
a0d0e21e 1904 default:
cea2e8a9 1905 DIE(aTHX_ "panic: last");
a0d0e21e
LW
1906 }
1907
a1f49e72 1908 TAINT_NOT;
a0d0e21e 1909 if (gimme == G_SCALAR) {
f86702cc
PP
1910 if (MARK < SP)
1911 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1912 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1913 else
3280af22 1914 *++newsp = &PL_sv_undef;
a0d0e21e 1915 }
54310121 1916 else if (gimme == G_ARRAY) {
a1f49e72 1917 while (++MARK <= SP) {
f86702cc
PP
1918 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1919 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
1920 TAINT_NOT; /* Each item is independent */
1921 }
f86702cc
PP
1922 }
1923 SP = newsp;
1924 PUTBACK;
1925
1926 /* Stack values are safe: */
1927 switch (pop2) {
1928 case CXt_LOOP:
a8bba7fa 1929 POPLOOP(cx); /* release loop vars ... */
4fdae800 1930 LEAVE;
f86702cc
PP
1931 break;
1932 case CXt_SUB:
b0d9ce38 1933 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1934 break;
a0d0e21e 1935 }
3280af22 1936 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW
1937
1938 LEAVE;
b0d9ce38 1939 LEAVESUB(sv);
f86702cc 1940 return nextop;
a0d0e21e
LW
1941}
1942
1943PP(pp_next)
1944{
1945 I32 cxix;
c09156bb 1946 register PERL_CONTEXT *cx;
a0d0e21e
LW
1947 I32 oldsave;
1948
533c011a 1949 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1950 cxix = dopoptoloop(cxstack_ix);
1951 if (cxix < 0)
a651a37d 1952 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW
1953 }
1954 else {
1955 cxix = dopoptolabel(cPVOP->op_pv);
1956 if (cxix < 0)
cea2e8a9 1957 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW
1958 }
1959 if (cxix < cxstack_ix)
1960 dounwind(cxix);
1961
1962 TOPBLOCK(cx);
3280af22 1963 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
1964 LEAVE_SCOPE(oldsave);
1965 return cx->blk_loop.next_op;
1966}
1967
1968PP(pp_redo)
1969{
1970 I32 cxix;
c09156bb 1971 register PERL_CONTEXT *cx;
a0d0e21e
LW
1972 I32 oldsave;
1973
533c011a 1974 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1975 cxix = dopoptoloop(cxstack_ix);
1976 if (cxix < 0)
a651a37d 1977 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW
1978 }
1979 else {
1980 cxix = dopoptolabel(cPVOP->op_pv);
1981 if (cxix < 0)
cea2e8a9 1982 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW
1983 }
1984 if (cxix < cxstack_ix)
1985 dounwind(cxix);
1986
1987 TOPBLOCK(cx);
3280af22 1988 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
1989 LEAVE_SCOPE(oldsave);
1990 return cx->blk_loop.redo_op;
1991}
1992
0824fdcb 1993STATIC OP *
cea2e8a9 1994S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW
1995{
1996 OP *kid;
1997 OP **ops = opstack;
fc36a67e 1998 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 1999
fc36a67e 2000 if (ops >= oplimit)
cea2e8a9 2001 Perl_croak(aTHX_ too_deep);
11343788
MB
2002 if (o->op_type == OP_LEAVE ||
2003 o->op_type == OP_SCOPE ||
2004 o->op_type == OP_LEAVELOOP ||
2005 o->op_type == OP_LEAVETRY)
fc36a67e 2006 {
5dc0d613 2007 *ops++ = cUNOPo->op_first;
fc36a67e 2008 if (ops >= oplimit)
cea2e8a9 2009 Perl_croak(aTHX_ too_deep);
fc36a67e 2010 }
c4aa4e48 2011 *ops = 0;
11343788 2012 if (o->op_flags & OPf_KIDS) {
5c0ca799 2013 dTHR;
a0d0e21e 2014 /* First try all the kids at this level, since that's likeliest. */
11343788 2015 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS
2016 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2017 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW
2018 return kid;
2019 }
11343788 2020 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2021 if (kid == PL_lastgotoprobe)
a0d0e21e 2022 continue;
c4aa4e48
GS
2023 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2024 (ops == opstack ||
2025 (ops[-1]->op_type != OP_NEXTSTATE &&
2026 ops[-1]->op_type != OP_DBSTATE)))
fc36a67e 2027 *ops++ = kid;
5dc0d613 2028 if (o = dofindlabel(kid, label, ops, oplimit))
11343788 2029 return o;
a0d0e21e
LW
2030 }
2031 }
c4aa4e48 2032 *ops = 0;
a0d0e21e
LW
2033 return 0;
2034}
2035
2036PP(pp_dump)
2037{
cea2e8a9 2038 return pp_goto();
a0d0e21e
LW
2039 /*NOTREACHED*/
2040}
2041
2042PP(pp_goto)
2043{
4e35701f 2044 djSP;
a0d0e21e
LW
2045 OP *retop = 0;
2046 I32 ix;
c09156bb 2047 register PERL_CONTEXT *cx;
fc36a67e
PP
2048#define GOTO_DEPTH 64
2049 OP *enterops[GOTO_DEPTH];
a0d0e21e 2050 char *label;
533c011a 2051 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 2052 static char must_have_label[] = "goto must have label";
a0d0e21e
LW
2053
2054 label = 0;
533c011a 2055 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2056 SV *sv = POPs;
2d8e6c8d 2057 STRLEN n_a;
a0d0e21e
LW
2058
2059 /* This egregious kludge implements goto &subroutine */
2060 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2061 I32 cxix;
c09156bb 2062 register PERL_CONTEXT *cx;
a0d0e21e
LW
2063 CV* cv = (CV*)SvRV(sv);
2064 SV** mark;
2065 I32 items = 0;
2066 I32 oldsave;
2067
e8f7dd13 2068 retry:
4aa0a1f7 2069 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS
2070 GV *gv = CvGV(cv);
2071 GV *autogv;
2072 if (gv) {
2073 SV *tmpstr;
2074 /* autoloaded stub? */
2075 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2076 goto retry;
2077 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2078 GvNAMELEN(gv), FALSE);
2079 if (autogv && (cv = GvCV(autogv)))
2080 goto retry;
2081 tmpstr = sv_newmortal();
2082 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 2083 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
4aa0a1f7 2084 }
cea2e8a9 2085 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD
2086 }
2087
a0d0e21e
LW
2088 /* First do some returnish stuff. */
2089 cxix = dopoptosub(cxstack_ix);
2090 if (cxix < 0)
cea2e8a9 2091 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW
2092 if (cxix < cxstack_ix)
2093 dounwind(cxix);
2094 TOPBLOCK(cx);
6b35e009 2095 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
cea2e8a9 2096 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3280af22 2097 mark = PL_stack_sp;
d8b46c1b
GS
2098 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2099 /* put @_ back onto stack */
a0d0e21e
LW
2100 AV* av = cx->blk_sub.argarray;
2101
93965878 2102 items = AvFILLp(av) + 1;
3280af22
NIS
2103 PL_stack_sp++;
2104 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2105 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2106 PL_stack_sp += items;
6d4ff0d2 2107#ifndef USE_THREADS
3280af22
NIS
2108 SvREFCNT_dec(GvAV(PL_defgv));
2109 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 2110#endif /* USE_THREADS */
d8b46c1b 2111 /* abandon @_ if it got reified */
62b1ebc2 2112 if (AvREAL(av)) {
d8b46c1b
GS
2113 (void)sv_2mortal((SV*)av); /* delay until return */
2114 av = newAV();
2115 av_extend(av, items-1);
2116 AvFLAGS(av) = AVf_REIFY;
2117 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2118 }
a0d0e21e 2119 }
1fa4e549
AD
2120 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2121 AV* av;
2122 int i;
2123#ifdef USE_THREADS
533c011a 2124 av = (AV*)PL_curpad[0];
1fa4e549 2125#else
3280af22 2126 av = GvAV(PL_defgv);
1fa4e549
AD
2127#endif
2128 items = AvFILLp(av) + 1;
3280af22
NIS
2129 PL_stack_sp++;
2130 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2131 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2132 PL_stack_sp += items;
1fa4e549 2133 }
6b35e009 2134 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2135 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2136 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2137 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
2138 LEAVE_SCOPE(oldsave);
2139
2140 /* Now do some callish stuff. */
2141 SAVETMPS;
2142 if (CvXSUB(cv)) {
67caa1fe 2143#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2144 if (CvOLDSTYLE(cv)) {
20ce7b12 2145 I32 (*fp3)(int,int,int);
924508f0
GS
2146 while (SP > mark) {
2147 SP[1] = SP[0];
2148 SP--;
a0d0e21e 2149 }
7766f137 2150 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2151 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2152 mark - PL_stack_base + 1,
ecfc5424 2153 items);
3280af22 2154 SP = PL_stack_base + items;
a0d0e21e 2155 }
67caa1fe
GS
2156 else
2157#endif /* PERL_XSUB_OLDSTYLE */
2158 {
1fa4e549
AD
2159 SV **newsp;
2160 I32 gimme;
2161
3280af22 2162 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD
2163 /* Push a mark for the start of arglist */
2164 PUSHMARK(mark);
0cb96387 2165 (void)(*CvXSUB(cv))(aTHXo_ cv);
1fa4e549 2166 /* Pop the current context like a decent sub should */
3280af22 2167 POPBLOCK(cx, PL_curpm);
1fa4e549 2168 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW
2169 }
2170 LEAVE;
2171 return pop_return();
2172 }
2173 else {
2174 AV* padlist = CvPADLIST(cv);
2175 SV** svp = AvARRAY(padlist);
6b35e009 2176 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS
2177 PL_in_eval = cx->blk_eval.old_in_eval;
2178 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH
2179 cx->cx_type = CXt_SUB;
2180 cx->blk_sub.hasargs = 0;
2181 }
a0d0e21e
LW
2182 cx->blk_sub.cv = cv;
2183 cx->blk_sub.olddepth = CvDEPTH(cv);
2184 CvDEPTH(cv)++;
2185 if (CvDEPTH(cv) < 2)
2186 (void)SvREFCNT_inc(cv);
2187 else { /* save temporaries on recursion? */
599cee73 2188 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2189 sub_crush_depth(cv);
93965878 2190 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2191 AV *newpad = newAV();
4aa0a1f7 2192 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2193 I32 ix = AvFILLp((AV*)svp[1]);
7766f137 2194 I32 names_fill = AvFILLp((AV*)svp[0]);
a0d0e21e 2195 svp = AvARRAY(svp[0]);
748a9306 2196 for ( ;ix > 0; ix--) {
7766f137 2197 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
748a9306 2198 char *name = SvPVX(svp[ix]);
5f05dabc
PP
2199 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2200 || *name == '&')
2201 {
2202 /* outer lexical or anon code */
748a9306 2203 av_store(newpad, ix,
4aa0a1f7 2204 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW
2205 }
2206 else { /* our own lexical */
2207 if (*name == '@')
2208 av_store(newpad, ix, sv = (SV*)newAV());
2209 else if (*name == '%')
2210 av_store(newpad, ix, sv = (SV*)newHV());
2211 else
2212 av_store(newpad, ix, sv = NEWSV(0,0));
2213 SvPADMY_on(sv);
2214 }
a0d0e21e 2215 }
7766f137 2216 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
743e66e6
GS
2217 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2218 }
a0d0e21e 2219 else {
748a9306 2220 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW
2221 SvPADTMP_on(sv);
2222 }
2223 }
2224 if (cx->blk_sub.hasargs) {
2225 AV* av = newAV();
2226 av_extend(av, 0);
2227 av_store(newpad, 0, (SV*)av);
2228 AvFLAGS(av) = AVf_REIFY;
2229 }
2230 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2231 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW
2232 svp = AvARRAY(padlist);
2233 }
2234 }
6d4ff0d2
MB
2235#ifdef USE_THREADS
2236 if (!cx->blk_sub.hasargs) {
533c011a 2237 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2238
93965878 2239 items = AvFILLp(av) + 1;
6d4ff0d2
MB
2240 if (items) {
2241 /* Mark is at the end of the stack. */
924508f0
GS
2242 EXTEND(SP, items);
2243 Copy(AvARRAY(av), SP + 1, items, SV*);
2244 SP += items;
6d4ff0d2
MB
2245 PUTBACK ;
2246 }
2247 }
2248#endif /* USE_THREADS */
7766f137 2249 SAVEVPTR(PL_curpad);
3280af22 2250 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB
2251#ifndef USE_THREADS
2252 if (cx->blk_sub.hasargs)
2253#endif /* USE_THREADS */
2254 {
3280af22 2255 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW
2256 SV** ary;
2257
6d4ff0d2 2258#ifndef USE_THREADS
3280af22
NIS
2259 cx->blk_sub.savearray = GvAV(PL_defgv);
2260 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB
2261#endif /* USE_THREADS */
2262 cx->blk_sub.argarray = av;
a0d0e21e
LW
2263 ++mark;
2264
2265 if (items >= AvMAX(av) + 1) {
2266 ary = AvALLOC(av);
2267 if (AvARRAY(av) != ary) {
2268 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2269 SvPVX(av) = (char*)ary;
2270 }
2271 if (items >= AvMAX(av) + 1) {
2272 AvMAX(av) = items - 1;
2273 Renew(ary,items+1,SV*);
2274 AvALLOC(av) = ary;
2275 SvPVX(av) = (char*)ary;
2276 }
2277 }
2278 Copy(mark,AvARRAY(av),items,SV*);
93965878 2279 AvFILLp(av) = items - 1;
d8b46c1b 2280 assert(!AvREAL(av));
a0d0e21e
LW
2281 while (items--) {
2282 if (*mark)
2283 SvTEMP_off(*mark);
2284 mark++;
2285 }
2286 }
491527d0 2287 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a
PP
2288 /*
2289 * We do not care about using sv to call CV;
2290 * it's for informational purposes only.
2291 */
3280af22 2292 SV *sv = GvSV(PL_DBsub);
491527d0
GS
2293 CV *gotocv;
2294
2295 if (PERLDB_SUB_NN) {
56431972 2296 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
491527d0
GS
2297 } else {
2298 save_item(sv);
2299 gv_efullname3(sv, CvGV(cv), Nullch);
2300 }
2301 if ( PERLDB_GOTO
864dbfa3 2302 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2303 PUSHMARK( PL_stack_sp );
864dbfa3 2304 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2305 PL_stack_sp--;
491527d0 2306 }
1ce6579f 2307 }
a0d0e21e
LW
2308 RETURNOP(CvSTART(cv));
2309 }
2310 }
1614b0e3 2311 else {
2d8e6c8d 2312 label = SvPV(sv,n_a);
1614b0e3 2313 if (!(do_dump || *label))
cea2e8a9 2314 DIE(aTHX_ must_have_label);
1614b0e3 2315 }
a0d0e21e 2316 }
533c011a 2317 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2318 if (! do_dump)
cea2e8a9 2319 DIE(aTHX_ must_have_label);
a0d0e21e
LW
2320 }
2321 else
2322 label = cPVOP->op_pv;
2323
2324 if (label && *label) {
2325 OP *gotoprobe = 0;
2326
2327 /* find label */
2328
3280af22 2329 PL_lastgotoprobe = 0;
a0d0e21e
LW
2330 *enterops = 0;
2331 for (ix = cxstack_ix; ix >= 0; ix--) {
2332 cx = &cxstack[ix];
6b35e009 2333 switch (CxTYPE(cx)) {
a0d0e21e 2334 case CXt_EVAL:
3280af22 2335 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW
2336 break;
2337 case CXt_LOOP:
2338 gotoprobe = cx->blk_oldcop->op_sibling;
2339 break;
2340 case CXt_SUBST:
2341 continue;
2342 case CXt_BLOCK:
2343 if (ix)
2344 gotoprobe = cx->blk_oldcop->op_sibling;
2345 else
3280af22 2346 gotoprobe = PL_main_root;
a0d0e21e 2347 break;
b3933176
CS
2348 case CXt_SUB:
2349 if (CvDEPTH(cx->blk_sub.cv)) {
2350 gotoprobe = CvROOT(cx->blk_sub.cv);
2351 break;
2352 }
2353 /* FALL THROUGH */
7766f137 2354 case CXt_FORMAT:
0a753a76 2355 case CXt_NULL:
a651a37d 2356 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW
2357 default:
2358 if (ix)
cea2e8a9 2359 DIE(aTHX_ "panic: goto");
3280af22 2360 gotoprobe = PL_main_root;
a0d0e21e
LW
2361 break;
2362 }
fc36a67e
PP
2363 retop = dofindlabel(gotoprobe, label,
2364 enterops, enterops + GOTO_DEPTH);
a0d0e21e
LW
2365 if (retop)
2366 break;
3280af22 2367 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
2368 }
2369 if (!retop)
cea2e8a9 2370 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e
LW
2371
2372 /* pop unwanted frames */
2373
2374 if (ix < cxstack_ix) {
2375 I32 oldsave;
2376
2377 if (ix < 0)
2378 ix = 0;
2379 dounwind(ix);
2380 TOPBLOCK(cx);
3280af22 2381 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
2382 LEAVE_SCOPE(oldsave);
2383 }
2384
2385 /* push wanted frames */
2386
748a9306 2387 if (*enterops && enterops[1]) {
533c011a 2388 OP *oldop = PL_op;
748a9306 2389 for (ix = 1; enterops[ix]; ix++) {
533c011a 2390 PL_op = enterops[ix];
84902520
TB
2391 /* Eventually we may want to stack the needed arguments
2392 * for each op. For now, we punt on the hard ones. */
533c011a 2393 if (PL_op->op_type == OP_ENTERITER)
cea2e8a9 2394 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
84902520 2395 label);
fc0dc3b3 2396 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2397 }
533c011a 2398 PL_op = oldop;
a0d0e21e
LW
2399 }
2400 }
2401
2402 if (do_dump) {
a5f75d66 2403#ifdef VMS
6b88bc9c 2404 if (!retop) retop = PL_main_start;
a5f75d66 2405#endif
3280af22
NIS
2406 PL_restartop = retop;
2407 PL_do_undump = TRUE;
a0d0e21e
LW
2408
2409 my_unexec();
2410
3280af22
NIS
2411 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2412 PL_do_undump = FALSE;
a0d0e21e
LW
2413 }
2414
2415 RETURNOP(retop);
2416}
2417
2418PP(pp_exit)
2419{
4e35701f 2420 djSP;
a0d0e21e
LW
2421 I32 anum;
2422
2423 if (MAXARG < 1)
2424 anum = 0;
ff0cee69 2425 else {
a0d0e21e 2426 anum = SvIVx(POPs);
ff0cee69
PP
2427#ifdef VMSISH_EXIT
2428 if (anum == 1 && VMSISH_EXIT)
2429 anum = 0;
2430#endif
2431 }
cc3604b1 2432 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2433 my_exit(anum);
3280af22 2434 PUSHs(&PL_sv_undef);
a0d0e21e
LW
2435 RETURN;
2436}
2437
2438#ifdef NOTYET
2439PP(pp_nswitch)
2440{
4e35701f 2441 djSP;
65202027 2442 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW
2443 register I32 match = I_32(value);
2444
2445 if (value < 0.0) {
65202027 2446 if (((NV)match) > value)
a0d0e21e
LW
2447 --match; /* was fractional--truncate other way */
2448 }
2449 match -= cCOP->uop.scop.scop_offset;
2450 if (match < 0)
2451 match = 0;
2452 else if (match > cCOP->uop.scop.scop_max)
2453 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS
2454 PL_op = cCOP->uop.scop.scop_next[match];
2455 RETURNOP(PL_op);
a0d0e21e
LW
2456}
2457
2458PP(pp_cswitch)
2459{
4e35701f 2460 djSP;
a0d0e21e
LW
2461 register I32 match;
2462
6b88bc9c
GS
2463 if (PL_multiline)
2464 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2465 else {
2d8e6c8d
GS
2466 STRLEN n_a;
2467 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW
2468 match -= cCOP->uop.scop.scop_offset;
2469 if (match < 0)
2470 match = 0;
2471 else if (match > cCOP->uop.scop.scop_max)
2472 match = cCOP->uop.scop.scop_max;
6b88bc9c 2473 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2474 }
6b88bc9c 2475 RETURNOP(PL_op);
a0d0e21e
LW
2476}
2477#endif
2478
2479/* Eval. */
2480
0824fdcb 2481STATIC void
cea2e8a9 2482S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW
2483{
2484 register char *s = SvPVX(sv);
2485 register char *send = SvPVX(sv) + SvCUR(sv);
2486 register char *t;
2487 register I32 line = 1;
2488
2489 while (s && s < send) {
2490 SV *tmpstr = NEWSV(85,0);
2491
2492 sv_upgrade(tmpstr, SVt_PVMG);
2493 t = strchr(s, '\n');
2494 if (t)
2495 t++;
2496 else
2497 t = send;
2498
2499 sv_setpvn(tmpstr, s, t - s);
2500 av_store(array, line++, tmpstr);
2501 s = t;
2502 }
2503}
2504
312caa8e 2505STATIC void *
cea2e8a9 2506S_docatch_body(pTHX_ va_list args)
312caa8e 2507{
cea2e8a9 2508 CALLRUNOPS(aTHX);
312caa8e
CS
2509 return NULL;
2510}
2511
0824fdcb 2512STATIC OP *
cea2e8a9 2513S_docatch(pTHX_ OP *o)
1e422769 2514{
e858de61 2515 dTHR;
6224f72b 2516 int ret;
533c011a 2517 OP *oldop = PL_op;
0cdb2077 2518 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2519 dJMPENV;
1e422769 2520
1e422769 2521#ifdef DEBUGGING
54310121 2522 assert(CATCH_GET == TRUE);
1e422769 2523#endif
312caa8e
CS
2524 PL_op = o;
2525 redo_body:
db36c5a1 2526 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
6224f72b 2527 switch (ret) {
312caa8e
CS
2528 case 0:
2529 break;
2530 case 3:
0cdb2077 2531 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS
2532 PL_op = PL_restartop;
2533 PL_restartop = 0;
2534 goto redo_body;
2535 }
2536 /* FALL THROUGH */
2537 default:
533c011a 2538 PL_op = oldop;
6224f72b 2539 JMPENV_JUMP(ret);
1e422769 2540 /* NOTREACHED */
1e422769 2541 }
533c011a 2542 PL_op = oldop;
1e422769
PP
2543 return Nullop;
2544}
2545
c277df42 2546OP *
864dbfa3 2547Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
c277df42
IZ
2548/* sv Text to convert to OP tree. */
2549/* startop op_free() this to undo. */
2550/* code Short string id of the caller. */
2551{
2552 dSP; /* Make POPBLOCK work. */
2553 PERL_CONTEXT *cx;
2554 SV **newsp;
f987c7de 2555 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ
2556 I32 optype;
2557 OP dummy;
533c011a 2558 OP *oop = PL_op, *rop;
c277df42
IZ
2559 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2560 char *safestr;
2561
2562 ENTER;
2563 lex_start(sv);
2564 SAVETMPS;
2565 /* switch to eval mode */
2566
cbce877f 2567 if (PL_curcop == &PL_compiling) {
11faa288
GS
2568 SAVECOPSTASH(&PL_compiling);
2569 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2570 }
57843af0
GS
2571 SAVECOPFILE(&PL_compiling);
2572 SAVECOPLINE(&PL_compiling);
3280af22 2573 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
57843af0
GS
2574 CopFILE_set(&PL_compiling, tmpbuf+2);
2575 CopLINE_set(&PL_compiling, 1);
c277df42
IZ
2576 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2577 deleting the eval's FILEGV from the stash before gv_check() runs
2578 (i.e. before run-time proper). To work around the coredump that
2579 ensues, we always turn GvMULTI_on for any globals that were
2580 introduced within evals. See force_ident(). GSAR 96-10-12 */
2581 safestr = savepv(tmpbuf);
3280af22 2582 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2583 SAVEHINTS();
d1ca3daa 2584#ifdef OP_IN_REGISTER
6b88bc9c 2585 PL_opsave = op;
d1ca3daa 2586#else
7766f137 2587 SAVEVPTR(PL_op);
d1ca3daa 2588#endif
3280af22 2589 PL_hints = 0;
c277df42 2590
533c011a 2591 PL_op = &dummy;
13b51b79 2592 PL_op->op_type = OP_ENTEREVAL;
533c011a 2593 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2594 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 2595 PUSHEVAL(cx, 0, Nullgv);
c277df42 2596 rop = doeval(G_SCALAR, startop);
13b51b79 2597 POPBLOCK(cx,PL_curpm);
e84b9f1f 2598 POPEVAL(cx);
c277df42
IZ
2599
2600 (*startop)->op_type = OP_NULL;
22c35a8c 2601 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2602 lex_end();
3280af22 2603 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2604 LEAVE;
13b51b79 2605 if (PL_curcop == &PL_compiling)
a0ed51b3 2606 PL_compiling.op_private = PL_hints;
d1ca3daa 2607#ifdef OP_IN_REGISTER
6b88bc9c 2608 op = PL_opsave;
d1ca3daa 2609#endif
c277df42
IZ
2610 return rop;
2611}
2612
0f15f207 2613/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2614STATIC OP *
cea2e8a9 2615S_doeval(pTHX_ int gimme, OP** startop)
a0d0e21e
LW
2616{
2617 dSP;
533c011a 2618 OP *saveop = PL_op;
ff3ff8d1 2619 CV *caller;
748a9306 2620 AV* comppadlist;
67a38de0 2621 I32 i;
a0d0e21e 2622
faef0170 2623 PL_in_eval = EVAL_INEVAL;
a0d0e21e 2624
1ce6579f
PP
2625 PUSHMARK(SP);
2626
a0d0e21e
LW
2627 /* set up a scratch pad */
2628
3280af22 2629 SAVEI32(PL_padix);
7766f137 2630 SAVEVPTR(PL_curpad);
3280af22
NIS
2631 SAVESPTR(PL_comppad);
2632 SAVESPTR(PL_comppad_name);
2633 SAVEI32(PL_comppad_name_fill);
2634 SAVEI32(PL_min_intro_pending);
2635 SAVEI32(PL_max_intro_pending);
748a9306 2636
3280af22 2637 caller = PL_compcv;
6b35e009 2638 for (i = cxstack_ix - 1; i >= 0; i--) {
67a38de0 2639 PERL_CONTEXT *cx = &cxstack[i];
6b35e009 2640 if (CxTYPE(cx) == CXt_EVAL)
67a38de0 2641 break;
7766f137 2642 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
67a38de0
NIS
2643 caller = cx->blk_sub.cv;
2644 break;
2645 }
2646 }
2647
3280af22
NIS
2648 SAVESPTR(PL_compcv);
2649 PL_compcv = (CV*)NEWSV(1104,0);
2650 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2651 CvEVAL_on(PL_compcv);
11343788 2652#ifdef USE_THREADS
533c011a
NIS
2653 CvOWNER(PL_compcv) = 0;
2654 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2655 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2656#endif /* USE_THREADS */
748a9306 2657
3280af22
NIS
2658 PL_comppad = newAV();
2659 av_push(PL_comppad, Nullsv);
2660 PL_curpad = AvARRAY(PL_comppad);
2661 PL_comppad_name = newAV();
2662 PL_comppad_name_fill = 0;
2663 PL_min_intro_pending = 0;
2664 PL_padix = 0;
11343788 2665#ifdef USE_THREADS
79cb57f6 2666 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS
2667 PL_curpad[0] = (SV*)newAV();
2668 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2669#endif /* USE_THREADS */
a0d0e21e 2670
748a9306
LW
2671 comppadlist = newAV();
2672 AvREAL_off(comppadlist);
3280af22
NIS
2673 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2674 av_store(comppadlist, 1, (SV*)PL_comppad);
2675 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2676
c277df42 2677 if (!saveop || saveop->op_type != OP_REQUIRE)
3280af22 2678 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
07055b4c 2679
3280af22 2680 SAVEFREESV(PL_compcv);
748a9306 2681
a0d0e21e
LW
2682 /* make sure we compile in the right package */
2683
ed094faf 2684 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2685 SAVESPTR(PL_curstash);
ed094faf 2686 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2687 }
3280af22
NIS
2688 SAVESPTR(PL_beginav);
2689 PL_beginav = newAV();
2690 SAVEFREESV(PL_beginav);
a0d0e21e
LW
2691
2692 /* try to compile it */
2693
3280af22
NIS
2694 PL_eval_root = Nullop;
2695 PL_error_count = 0;
2696 PL_curcop = &PL_compiling;
2697 PL_curcop->cop_arybase = 0;
2698 SvREFCNT_dec(PL_rs);
79cb57f6 2699 PL_rs = newSVpvn("\n", 1);
c277df42 2700 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2701 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2702 else
38a03e6e 2703 sv_setpv(ERRSV,"");
3280af22 2704 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW
2705 SV **newsp;
2706 I32 gimme;
c09156bb 2707 PERL_CONTEXT *cx;
c277df42 2708 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2709 STRLEN n_a;
097ee67d 2710
533c011a 2711 PL_op = saveop;
3280af22
NIS
2712 if (PL_eval_root) {
2713 op_free(PL_eval_root);
2714 PL_eval_root = Nullop;
a0d0e21e 2715 }
3280af22 2716 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2717 if (!startop) {
3280af22 2718 POPBLOCK(cx,PL_curpm);
c277df42
IZ
2719 POPEVAL(cx);
2720 pop_return();
2721 }
a0d0e21e
LW
2722 lex_end();
2723 LEAVE;
7a2e2cd6 2724 if (optype == OP_REQUIRE) {
2d8e6c8d 2725 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS
2726 DIE(aTHX_ "%sCompilation failed in require",
2727 *msg ? msg : "Unknown error\n");
2728 }
2729 else if (startop) {
2d8e6c8d 2730 char* msg = SvPVx(ERRSV, n_a);
c277df42 2731
3280af22 2732 POPBLOCK(cx,PL_curpm);
c277df42 2733 POPEVAL(cx);
5a844595
GS
2734 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2735 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2736 }
3280af22
NIS
2737 SvREFCNT_dec(PL_rs);
2738 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2739#ifdef USE_THREADS
533c011a
NIS
2740 MUTEX_LOCK(&PL_eval_mutex);
2741 PL_eval_owner = 0;
2742 COND_SIGNAL(&PL_eval_cond);
2743 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2744#endif /* USE_THREADS */
a0d0e21e
LW
2745 RETPUSHUNDEF;
2746 }
3280af22
NIS
2747 SvREFCNT_dec(PL_rs);
2748 PL_rs = SvREFCNT_inc(PL_nrs);
57843af0 2749 CopLINE_set(&PL_compiling, 0);
c277df42 2750 if (startop) {
3280af22
NIS
2751 *startop = PL_eval_root;
2752 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2753 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2754 } else
3280af22 2755 SAVEFREEOP(PL_eval_root);
54310121 2756 if (gimme & G_VOID)
3280af22 2757 scalarvoid(PL_eval_root);
54310121 2758 else if (gimme & G_ARRAY)
3280af22 2759 list(PL_eval_root);
a0d0e21e 2760 else
3280af22 2761 scalar(PL_eval_root);
a0d0e21e
LW
2762
2763 DEBUG_x(dump_eval());
2764
55497cff 2765 /* Register with debugger: */
84902520 2766 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2767 CV *cv = get_cv("DB::postponed", FALSE);
55497cff
PP
2768 if (cv) {
2769 dSP;
924508f0 2770 PUSHMARK(SP);
cc49e20b 2771 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2772 PUTBACK;
864dbfa3 2773 call_sv((SV*)cv, G_DISCARD);
55497cff
PP
2774 }
2775 }
2776
a0d0e21e
LW
2777 /* compiled okay, so do it */
2778
3280af22
NIS
2779 CvDEPTH(PL_compcv) = 1;
2780 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2781 PL_op = saveop; /* The caller may need it. */
b35b2403 2782#ifdef USE_THREADS
533c011a
NIS
2783 MUTEX_LOCK(&PL_eval_mutex);
2784 PL_eval_owner = 0;
2785 COND_SIGNAL(&PL_eval_cond);
2786 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2787#endif /* USE_THREADS */
5dc0d613 2788
3280af22 2789 RETURNOP(PL_eval_start);
a0d0e21e
LW
2790}
2791
a6c40364 2792STATIC PerlIO *
cea2e8a9 2793S_doopen_pmc(pTHX_ const char *name, const char *mode)
b295d113
TH
2794{
2795 STRLEN namelen = strlen(name);
2796 PerlIO *fp;
2797
7894fbab 2798 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 2799 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH
2800 char *pmc = SvPV_nolen(pmcsv);
2801 Stat_t pmstat;
a6c40364
GS
2802 Stat_t pmcstat;
2803 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 2804 fp = PerlIO_open(name, mode);
a6c40364
GS
2805 }
2806 else {
b295d113 2807 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS
2808 pmstat.st_mtime < pmcstat.st_mtime)
2809 {
2810 fp = PerlIO_open(pmc, mode);
2811 }
2812 else {
2813 fp = PerlIO_open(name, mode);
2814 }
b295d113 2815 }
a6c40364
GS
2816 SvREFCNT_dec(pmcsv);
2817 }
2818 else {
2819 fp = PerlIO_open(name, mode);
b295d113 2820 }
b295d113
TH
2821 return fp;
2822}
2823
a0d0e21e
LW
2824PP(pp_require)
2825{
4e35701f 2826 djSP;
c09156bb 2827 register PERL_CONTEXT *cx;
a0d0e21e
LW
2828 SV *sv;
2829 char *name;
6132ea6c 2830 STRLEN len;
46fc3d4c
PP
2831 char *tryname;
2832 SV *namesv = Nullsv;
a0d0e21e
LW
2833 SV** svp;
2834 I32 gimme = G_SCALAR;
760ac839 2835 PerlIO *tryrsfp = 0;
2d8e6c8d 2836 STRLEN n_a;
bbed91b5
KF
2837 int filter_has_file = 0;
2838 GV *filter_child_proc = 0;
2839 SV *filter_state = 0;
2840 SV *filter_sub = 0;
a0d0e21e
LW
2841
2842 sv = POPs;
a7cb1f99
GS
2843 if (SvNIOKp(sv)) {
2844 UV rev, ver, sver;
2845 if (SvPOKp(sv) && SvUTF8(sv)) { /* require v5.6.1 */
2846 I32 len;
2847 U8 *s = (U8*)SvPVX(sv);
2848 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2849 if (s < end) {
2850 rev = utf8_to_uv(s, &len);
2851 s += len;
2852 if (s < end) {
2853 ver = utf8_to_uv(s, &len);
2854 s += len;
2855 if (s < end)
2856 sver = utf8_to_uv(s, &len);
2857 else
2858 sver = 0;
2859 }
2860 else
2861 ver = 0;
2862 }
2863 else
2864 rev = 0;
2865 if (PERL_REVISION < rev
2866 || (PERL_REVISION == rev
2867 && (PERL_VERSION < ver
2868 || (PERL_VERSION == ver
2869 && PERL_SUBVERSION < sver))))
2870 {
2871 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2872 "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION,
2873 PERL_VERSION, PERL_SUBVERSION);
2874 }
2875 }
2876 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2877 NV n = SvNV(sv);
2878 rev = (UV)n;
2879 ver = (UV)((n-rev)*1000);
2880 sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
2881
2882 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2883 + ((NV)PERL_SUBVERSION/(NV)1000000)
2884 + 0.00000099 < SvNV(sv))
2885 {
2886 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
2887 "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION,
2888 PERL_VERSION, PERL_SUBVERSION);
2889 }
2890 }
a0d0e21e
LW
2891 RETPUSHYES;
2892 }
6132ea6c
GS
2893 name = SvPV(sv, len);
2894 if (!(name && len > 0 && *name))
cea2e8a9 2895 DIE(aTHX_ "Null filename used");
4633a7c4 2896 TAINT_PROPER("require");
533c011a 2897 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS
2898 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2899 *svp != &PL_sv_undef)
a0d0e21e
LW
2900 RETPUSHYES;
2901
2902 /* prepare to compile file */
2903
57843af0
GS
2904 if (PERL_FILE_IS_ABSOLUTE(name)
2905 || (*name == '.' && (name[1] == '/' ||
2906 (name[1] == '.' && name[2] == '/'))))
a0d0e21e 2907 {
46fc3d4c 2908 tryname = name;
a6c40364 2909 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
a0d0e21e
LW
2910 }
2911 else {
3280af22 2912 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2913 I32 i;
748a9306 2914#ifdef VMS
46fc3d4c
PP
2915 char *unixname;
2916 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2917#endif
2918 {
2919 namesv = NEWSV(806, 0);
2920 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF
2921 SV *dirsv = *av_fetch(ar, i, TRUE);
2922
2923 if (SvROK(dirsv)) {
2924 int count;
2925 SV *loader = dirsv;
2926
2927 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2928 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2929 }
2930
b900a521
JH
2931 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2932 PTR2UV(SvANY(loader)), name);
bbed91b5
KF
2933 tryname = SvPVX(namesv);
2934 tryrsfp = 0;
2935
2936 ENTER;
2937 SAVETMPS;
2938 EXTEND(SP, 2);
2939
2940 PUSHMARK(SP);
2941 PUSHs(dirsv);
2942 PUSHs(sv);
2943 PUTBACK;
2944 count = call_sv(loader, G_ARRAY);
2945 SPAGAIN;
2946
2947 if (count > 0) {
2948 int i = 0;
2949 SV *arg;
2950
2951 SP -= count - 1;
2952 arg = SP[i++];
2953
2954 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2955 arg = SvRV(arg);
2956 }
2957
2958 if (SvTYPE(arg) == SVt_PVGV) {
2959 IO *io = GvIO((GV *)arg);
2960
2961 ++filter_has_file;
2962
2963 if (io) {
2964 tryrsfp = IoIFP(io);
2965 if (IoTYPE(io) == '|') {
2966 /* reading from a child process doesn't
2967 nest -- when returning from reading
2968 the inner module, the outer one is
2969 unreadable (closed?) I've tried to
2970 save the gv to manage the lifespan of
2971 the pipe, but this didn't help. XXX */
2972 filter_child_proc = (GV *)arg;
520c758a 2973 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF
2974 }
2975 else {
2976 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2977 PerlIO_close(IoOFP(io));
2978 }
2979 IoIFP(io) = Nullfp;
2980 IoOFP(io) = Nullfp;
2981 }
2982 }
2983
2984 if (i < count) {
2985 arg = SP[i++];
2986 }
2987 }
2988
2989 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2990 filter_sub = arg;
520c758a 2991 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF
2992
2993 if (i < count) {
2994 filter_state = SP[i];
520c758a 2995 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF
2996 }
2997
2998 if (tryrsfp == 0) {
2999 tryrsfp = PerlIO_open("/dev/null",
3000 PERL_SCRIPT_MODE);
3001 }
3002 }
3003 }
3004
3005 PUTBACK;
3006 FREETMPS;
3007 LEAVE;
3008
3009 if (tryrsfp) {
3010 break;
3011 }
3012
3013 filter_has_file = 0;
3014 if (filter_child_proc) {
3015 SvREFCNT_dec(filter_child_proc);
3016 filter_child_proc = 0;
3017 }
3018 if (filter_state) {
3019 SvREFCNT_dec(filter_state);
3020 filter_state = 0;
3021 }
3022 if (filter_sub) {
3023 SvREFCNT_dec(filter_sub);
3024 filter_sub = 0;
3025 }
3026 }
3027 else {
3028 char *dir = SvPVx(dirsv, n_a);
46fc3d4c 3029#ifdef VMS
bbed91b5
KF
3030 char *unixdir;
3031 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3032 continue;
3033 sv_setpv(namesv, unixdir);
3034 sv_catpv(namesv, unixname);
748a9306 3035#else
bbed91b5 3036 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 3037#endif
bbed91b5
KF
3038 TAINT_PROPER("require");
3039 tryname = SvPVX(namesv);
3040 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3041 if (tryrsfp) {
3042 if (tryname[0] == '.' && tryname[1] == '/')
3043 tryname += 2;
3044 break;
3045 }
46fc3d4c 3046 }
a0d0e21e
LW
3047 }
3048 }
3049 }
57843af0
GS
3050 SAVECOPFILE(&PL_compiling);
3051 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3052 SvREFCNT_dec(namesv);
a0d0e21e 3053 if (!tryrsfp) {
533c011a 3054 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS
3055 char *msgstr = name;
3056 if (namesv) { /* did we lookup @INC? */
3057 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3058 SV *dirmsgsv = NEWSV(0, 0);
3059 AV *ar = GvAVn(PL_incgv);
3060 I32 i;
3061 sv_catpvn(msg, " in @INC", 8);
3062 if (instr(SvPVX(msg), ".h "))
3063 sv_catpv(msg, " (change .h to .ph maybe?)");
3064 if (instr(SvPVX(msg), ".ph "))
3065 sv_catpv(msg, " (did you run h2ph?)");
3066 sv_catpv(msg, " (@INC contains:");
3067 for (i = 0; i <= AvFILL(ar); i++) {
3068 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3069 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS
3070 sv_catsv(msg, dirmsgsv);
3071 }
3072 sv_catpvn(msg, ")", 1);
3073 SvREFCNT_dec(dirmsgsv);
3074 msgstr = SvPV_nolen(msg);
2683423c 3075 }
cea2e8a9 3076 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW
3077 }
3078
3079 RETPUSHUNDEF;
3080 }
d8bfb8bd 3081 else
aba27d88 3082 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW
3083
3084 /* Assume success here to prevent recursive requirement. */
3280af22 3085 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
ed094faf 3086 newSVpv(CopFILE(&PL_compiling), 0), 0 );
a0d0e21e
LW
3087
3088 ENTER;
3089 SAVETMPS;
79cb57f6 3090 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS
3091 SAVEGENERICSV(PL_rsfp_filters);
3092 PL_rsfp_filters = Nullav;
e50aee73 3093
3280af22 3094 PL_rsfp = tryrsfp;
b3ac6de7 3095 SAVEHINTS();
3280af22 3096 PL_hints = 0;
7766f137 3097 SAVESPTR(PL_compiling.cop_warnings);
0453d815
PM
3098 if (PL_dowarn & G_WARN_ALL_ON)
3099 PL_compiling.cop_warnings = WARN_ALL ;
3100 else if (PL_dowarn & G_WARN_ALL_OFF)
3101 PL_compiling.cop_warnings = WARN_NONE ;
3102 else
3103 PL_compiling.cop_warnings = WARN_STD ;
a0d0e21e 3104
bbed91b5
KF
3105 if (filter_sub || filter_child_proc) {
3106 SV *datasv = filter_add(run_user_filter, Nullsv);
3107 IoLINES(datasv) = filter_has_file;
3108 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3109 IoTOP_GV(datasv) = (GV *)filter_state;
3110 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3111 }
3112
3113 /* switch to eval mode */
533c011a 3114 push_return(PL_op->op_next);
a0d0e21e 3115 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3116 PUSHEVAL(cx, name, Nullgv);
a0d0e21e 3117
57843af0
GS
3118 SAVECOPLINE(&PL_compiling);
3119 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW
3120
3121 PUTBACK;
0f15f207 3122#ifdef USE_THREADS
533c011a
NIS
3123 MUTEX_LOCK(&PL_eval_mutex);
3124 if (PL_eval_owner && PL_eval_owner != thr)
3125 while (PL_eval_owner)
3126 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3127 PL_eval_owner = thr;
3128 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3129#endif /* USE_THREADS */
c277df42 3130 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW
3131}
3132
3133PP(pp_dofile)
3134{
cea2e8a9 3135 return pp_require();
a0d0e21e
LW
3136}
3137
3138PP(pp_entereval)
3139{
4e35701f 3140 djSP;
c09156bb 3141 register PERL_CONTEXT *cx;
a0d0e21e 3142 dPOPss;
3280af22 3143 I32 gimme = GIMME_V, was = PL_sub_generation;
fc36a67e
PP
3144 char tmpbuf[TYPE_DIGITS(long) + 12];
3145 char *safestr;
a0d0e21e 3146 STRLEN len;
55497cff 3147 OP *ret;
a0d0e21e
LW
3148
3149 if (!SvPV(sv,len) || !len)
3150 RETPUSHUNDEF;
748a9306 3151 TAINT_PROPER("eval");
a0d0e21e
LW
3152
3153 ENTER;
a0d0e21e 3154 lex_start(sv);
748a9306 3155 SAVETMPS;
a0d0e21e
LW
3156
3157 /* switch to eval mode */
3158
57843af0 3159 SAVECOPFILE(&PL_compiling);
3280af22 3160 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
57843af0
GS
3161 CopFILE_set(&PL_compiling, tmpbuf+2);
3162 CopLINE_set(&PL_compiling, 1);
55497cff
PP
3163 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3164 deleting the eval's FILEGV from the stash before gv_check() runs
3165 (i.e. before run-time proper). To work around the coredump that
3166 ensues, we always turn GvMULTI_on for any globals that were
3167 introduced within evals. See force_ident(). GSAR 96-10-12 */
3168 safestr = savepv(tmpbuf);
3280af22 3169 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3170 SAVEHINTS();
533c011a 3171 PL_hints = PL_op->op_targ;
7766f137 3172 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3173 if (!specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM
3174 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3175 SAVEFREESV(PL_compiling.cop_warnings) ;
3176 }
a0d0e21e 3177
533c011a 3178 push_return(PL_op->op_next);
6b35e009 3179 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3180 PUSHEVAL(cx, 0, Nullgv);
a0d0e21e
LW
3181
3182 /* prepare to compile string */
3183
3280af22 3184 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3185 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3186 PUTBACK;
0f15f207 3187#ifdef USE_THREADS
533c011a
NIS
3188 MUTEX_LOCK(&PL_eval_mutex);
3189 if (PL_eval_owner && PL_eval_owner != thr)
3190 while (PL_eval_owner)
3191 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3192 PL_eval_owner = thr;
3193 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3194#endif /* USE_THREADS */
c277df42 3195 ret = doeval(gimme, NULL);
3280af22 3196 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 3197 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff
PP
3198 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3199 }
1e422769 3200 return DOCATCH(ret);
a0d0e21e
LW
3201}
3202
3203PP(pp_leaveeval)
3204{
4e35701f 3205 djSP;
a0d0e21e
LW
3206 register SV **mark;
3207 SV **newsp;
3208 PMOP *newpm;
3209 I32 gimme;
c09156bb 3210 register PERL_CONTEXT *cx;
a0d0e21e 3211 OP *retop;
533c011a 3212 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW
3213 I32 optype;
3214
3215 POPBLOCK(cx,newpm);
3216 POPEVAL(cx);
3217 retop = pop_return();
3218
a1f49e72 3219 TAINT_NOT;
54310121
PP
3220 if (gimme == G_VOID)
3221 MARK = newsp;
3222 else if (gimme == G_SCALAR) {
3223 MARK = newsp + 1;
3224 if (MARK <= SP) {
3225 if (SvFLAGS(TOPs) & SVs_TEMP)
3226 *MARK = TOPs;
3227 else
3228 *MARK = sv_mortalcopy(TOPs);
3229 }
a0d0e21e 3230 else {
54310121 3231 MEXTEND(mark,0);
3280af22 3232 *MARK = &PL_sv_undef;
a0d0e21e 3233 }
a7ec2b44 3234 SP = MARK;
a0d0e21e
LW
3235 }
3236 else {
a1f49e72
CS
3237 /* in case LEAVE wipes old return values */
3238 for (mark = newsp + 1; mark <= SP; mark++) {
3239 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3240 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
3241 TAINT_NOT; /* Each item is independent */
3242 }
3243 }
a0d0e21e 3244 }
3280af22 3245 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3246
067f92a0
GS
3247 if (AvFILLp(PL_comppad_name) >= 0)
3248 free_closures();
84902520 3249
4fdae800 3250#ifdef DEBUGGING
3280af22 3251 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3252#endif
3280af22 3253 CvDEPTH(PL_compcv) = 0;
f46d017c 3254 lex_end();
4fdae800 3255
1ce6579f 3256 if (optype == OP_REQUIRE &&
924508f0 3257 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3258 {
1ce6579f 3259 /* Unassume the success we assumed earlier. */
54310121 3260 char *name = cx->blk_eval.old_name;
3280af22 3261 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 3262 retop = Perl_die(aTHX_ "%s did not return a true value", name);
f46d017c
GS
3263 /* die_where() did LEAVE, or we won't be here */
3264 }
3265 else {
3266 LEAVE;
3267 if (!(save_flags & OPf_SPECIAL))
3268 sv_setpv(ERRSV,"");
a0d0e21e 3269 }
a0d0e21e
LW
3270
3271 RETURNOP(retop);
3272}
3273
a0d0e21e
LW
3274PP(pp_entertry)
3275{
4e35701f 3276 djSP;
c09156bb 3277 register PERL_CONTEXT *cx;
54310121 3278 I32 gimme = GIMME_V;
a0d0e21e
LW
3279
3280 ENTER;
3281 SAVETMPS;
3282
3283 push_return(cLOGOP->op_other->op_next);
3284 PUSHBLOCK(cx, CXt_EVAL, SP);
3285 PUSHEVAL(cx, 0, 0);
533c011a 3286 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3287
faef0170 3288 PL_in_eval = EVAL_INEVAL;
38a03e6e 3289 sv_setpv(ERRSV,"");
1e422769 3290 PUTBACK;
533c011a 3291 return DOCATCH(PL_op->op_next);
a0d0e21e
LW
3292}
3293
3294PP(pp_leavetry)
3295{
4e35701f 3296 djSP;
a0d0e21e
LW
3297 register SV **mark;
3298 SV **newsp;
3299 PMOP *newpm;
3300 I32 gimme;
c09156bb 3301 register PERL_CONTEXT *cx;
a0d0e21e
LW
3302 I32 optype;
3303
3304 POPBLOCK(cx,newpm);
3305 POPEVAL(cx);
3306 pop_return();
3307
a1f49e72 3308 TAINT_NOT;
54310121
PP
3309 if (gimme == G_VOID)
3310 SP = newsp;
3311 else if (gimme == G_SCALAR) {
3312 MARK = newsp + 1;
3313 if (MARK <= SP) {
3314 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3315 *MARK = TOPs;
3316 else
3317 *MARK = sv_mortalcopy(TOPs);
3318 }
a0d0e21e 3319 else {
54310121 3320 MEXTEND(mark,0);
3280af22 3321 *MARK = &PL_sv_undef;
a0d0e21e
LW
3322 }
3323 SP = MARK;
3324 }
3325 else {
a1f49e72
CS
3326 /* in case LEAVE wipes old return values */
3327 for (mark = newsp + 1; mark <= SP; mark++) {
3328 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3329 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
3330 TAINT_NOT; /* Each item is independent */
3331 }
3332 }
a0d0e21e 3333 }
3280af22 3334 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW
3335
3336 LEAVE;
38a03e6e 3337 sv_setpv(ERRSV,"");
a0d0e21e
LW
3338 RETURN;
3339}
3340
0824fdcb 3341STATIC void
cea2e8a9 3342S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW
3343{
3344 STRLEN len;
3345 register char *s = SvPV_force(sv, len);
3346 register char *send = s + len;
3347 register char *base;
3348 register I32 skipspaces = 0;
3349 bool noblank;
3350 bool repeat;
3351 bool postspace = FALSE;
3352 U16 *fops;
3353 register U16 *fpc;
3354 U16 *linepc;
3355 register I32 arg;
3356 bool ischop;
3357
55497cff 3358 if (len == 0)
cea2e8a9 3359 Perl_croak(aTHX_ "Null picture in formline");
55497cff
PP
3360
3361 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW
3362 fpc = fops;
3363
3364 if (s < send) {
3365 linepc = fpc;
3366 *fpc++ = FF_LINEMARK;
3367 noblank = repeat = FALSE;
3368 base = s;
3369 }
3370
3371 while (s <= send) {
3372 switch (*s++) {
3373 default:
3374 skipspaces = 0;
3375 continue;
3376
3377 case '~':
3378 if (*s == '~') {
3379 repeat = TRUE;
3380 *s = ' ';
3381 }
3382 noblank = TRUE;
3383 s[-1] = ' ';
3384 /* FALL THROUGH */
3385 case ' ': case '\t':
3386 skipspaces++;
3387 continue;
3388
3389 case '\n': case 0:
3390 arg = s - base;
3391 skipspaces++;
3392 arg -= skipspaces;
3393 if (arg) {
5f05dabc 3394 if (postspace)
a0d0e21e 3395 *fpc++ = FF_SPACE;
a0d0e21e
LW
3396 *fpc++ = FF_LITERAL;
3397 *fpc++ = arg;
3398 }
5f05dabc 3399 postspace = FALSE;
a0d0e21e
LW
3400 if (s <= send)
3401 skipspaces--;
3402 if (skipspaces) {
3403 *fpc++ = FF_SKIP;
3404 *fpc++ = skipspaces;
3405 }
3406 skipspaces = 0;
3407 if (s <= send)
3408 *fpc++ = FF_NEWLINE;
3409 if (noblank) {
3410 *fpc++ = FF_BLANK;
3411 if (repeat)
3412 arg = fpc - linepc + 1;
3413 else
3414 arg = 0;
3415 *fpc++ = arg;
3416 }
3417 if (s < send) {
3418 linepc = fpc;
3419 *fpc++ = FF_LINEMARK;
3420 noblank = repeat = FALSE;
3421 base = s;
3422 }
3423 else
3424 s++;
3425 continue;
3426
3427 case '@':
3428 case '^':
3429 ischop = s[-1] == '^';
3430
3431 if (postspace) {
3432 *fpc++ = FF_SPACE;
3433 postspace = FALSE;
3434 }
3435 arg = (s - base) - 1;
3436 if (arg) {
3437 *fpc++ = FF_LITERAL;
3438 *fpc++ = arg;
3439 }
3440
3441 base = s - 1;
3442 *fpc++ = FF_FETCH;
3443 if (*s == '*') {
3444 s++;
3445 *fpc++ = 0;
3446 *fpc++ = FF_LINEGLOB;
3447 }
3448 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3449 arg = ischop ? 512 : 0;
3450 base = s - 1;
3451 while (*s == '#')
3452 s++;
3453 if (*s == '.') {
3454 char *f;
3455 s++;
3456 f = s;
3457 while (*s == '#')
3458 s++;
3459 arg |= 256 + (s - f);
3460 }
3461 *fpc++ = s - base; /* fieldsize for FETCH */
3462 *fpc++ = FF_DECIMAL;
3463 *fpc++ = arg;
3464 }
3465 else {
3466 I32 prespace = 0;
3467 bool ismore = FALSE;
3468
3469 if (*s == '>') {
3470 while (*++s == '>') ;
3471 prespace = FF_SPACE;
3472 }
3473 else if (*s == '|') {
3474 while (*++s == '|') ;
3475 prespace = FF_HALFSPACE;
3476 postspace = TRUE;
3477 }
3478 else {
3479 if (*s == '<')
3480 while (*++s == '<') ;
3481 postspace = TRUE;
3482 }
3483 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3484 s += 3;
3485 ismore = TRUE;
3486 }
3487 *fpc++ = s - base; /* fieldsize for FETCH */
3488
3489 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3490
3491 if (prespace)
3492 *fpc++ = prespace;
3493 *fpc++ = FF_ITEM;
3494 if (ismore)
3495 *fpc++ = FF_MORE;
3496 if (ischop)
3497 *fpc++ = FF_CHOP;
3498 }
3499 base = s;
3500 skipspaces = 0;
3501 continue;
3502 }
3503 }
3504 *fpc++ = FF_END;
3505
3506 arg = fpc - fops;
3507 { /* need to jump to the next word */
3508 int z;
3509 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3510 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3511 s = SvPVX(sv) + SvCUR(sv) + z;
3512 }
3513 Copy(fops, s, arg, U16);
3514 Safefree(fops);
55497cff 3515 sv_magic(sv, Nullsv, 'f', Nullch, 0);
a0d0e21e
LW
3516 SvCOMPILED_on(sv);
3517}
4e35701f 3518
745d3a65
HM
3519/*
3520 * The rest of this file was derived from source code contributed
3521 * by Tom Horsley.
3522 *
3523 * NOTE: this code was derived from Tom Horsley's qsort replacement
3524 * and should not be confused with the original code.
3525 */
3526
3527/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3528
3529 Permission granted to distribute under the same terms as perl which are
3530 (briefly):
3531
3532 This program is free software; you can redistribute it and/or modify
3533 it under the terms of either:
3534
3535 a) the GNU General Public License as published by the Free
3536 Software Foundation; either version 1, or (at your option) any
3537 later version, or
3538
3539 b) the "Artistic License" which comes with this Kit.
3540
3541 Details on the perl license can be found in the perl source code which
3542 may be located via the www.perl.com web page.
3543
3544 This is the most wonderfulest possible qsort I can come up with (and
3545 still be mostly portable) My (limited) tests indicate it consistently
3546 does about 20% fewer calls to compare than does the qsort in the Visual
3547 C++ library, other vendors may vary.
3548
3549 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3550 others I invented myself (or more likely re-invented since they seemed
3551 pretty obvious once I watched the algorithm operate for a while).
3552
3553 Most of this code was written while watching the Marlins sweep the Giants
3554 in the 1997 National League Playoffs - no Braves fans allowed to use this
3555 code (just kidding :-).
3556
3557 I realize that if I wanted to be true to the perl tradition, the only
3558 comment in this file would be something like:
3559
3560 ...they shuffled back towards the rear of the line. 'No, not at the
3561 rear!' the slave-driver shouted. 'Three files up. And stay there...
3562
3563 However, I really needed to violate that tradition just so I could keep
3564 track of what happens myself, not to mention some poor fool trying to
3565 understand this years from now :-).
3566*/
3567
3568/* ********************************************************** Configuration */
3569
3570#ifndef QSORT_ORDER_GUESS
3571#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3572#endif
3573
3574/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3575 future processing - a good max upper bound is log base 2 of memory size
3576 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3577 safely be smaller than that since the program is taking up some space and
3578 most operating systems only let you grab some subset of contiguous
3579 memory (not to mention that you are normally sorting data larger than
3580 1 byte element size :-).
3581*/
3582#ifndef QSORT_MAX_STACK
3583#define QSORT_MAX_STACK 32
3584#endif
3585
3586/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3587 Anything bigger and we use qsort. If you make this too small, the qsort
3588 will probably break (or become less efficient), because it doesn't expect
3589 the middle element of a partition to be the same as the right or left -
3590 you have been warned).
3591*/
3592#ifndef QSORT_BREAK_EVEN
3593#define QSORT_BREAK_EVEN 6
3594#endif
3595
3596/* ************************************************************* Data Types */
3597
3598/* hold left and right index values of a partition waiting to be sorted (the
3599 partition includes both left and right - right is NOT one past the end or
3600 anything like that).
3601*/
3602struct partition_stack_entry {
3603 int left;
3604 int right;
3605#ifdef QSORT_ORDER_GUESS
3606 int qsort_break_even;
3607#endif
3608};
3609
3610/* ******************************************************* Shorthand Macros */
3611
3612/* Note that these macros will be used from inside the qsort function where
3613 we happen to know that the variable 'elt_size' contains the size of an
3614 array element and the variable 'temp' points to enough space to hold a
3615 temp element and the variable 'array' points to the array being sorted
3616 and 'compare' is the pointer to the compare routine.
3617
3618 Also note that there are very many highly architecture specific ways
3619 these might be sped up, but this is simply the most generally portable
3620 code I could think of.
3621*/
161b471a 3622
745d3a65
HM
3623/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3624*/
565764a8 3625#define qsort_cmp(elt1, elt2) \
51371543 3626 ((*compare)(aTHXo_ array[elt1], array[elt2]))
745d3a65
HM
3627
3628#ifdef QSORT_ORDER_GUESS
3629#define QSORT_NOTICE_SWAP swapped++;
3630#else
3631#define QSORT_NOTICE_SWAP
3632#endif
3633
3634/* swaps contents of array elements elt1, elt2.
3635*/
3636#