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