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
rudimentary support for remote debugging, from aeons ago (somewhat
[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)
bf49b057 333 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
a0d0e21e 334 else
bf49b057 335 PerlIO_printf(Perl_debug_log, "%-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 794 PL_sortcop = kid->op_next;
11faa288 795 stash = CopSTASH(PL_curcop);
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 824 PL_sortcop = Nullop;
11faa288 825 stash = CopSTASH(PL_curcop);
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)
d470f89e 974 DIE(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) {
b0d9ce38 1190 SV *sv;
c90c0ff4 1191 cx = &cxstack[cxstack_ix];
1192 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1193 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1194 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1195 switch (CxTYPE(cx)) {
c90c0ff4 1196 case CXt_SUBST:
1197 POPSUBST(cx);
1198 continue; /* not break */
a0d0e21e 1199 case CXt_SUB:
b0d9ce38
GS		 1200 POPSUB(cx,sv);
1201 LEAVESUB(sv);
a0d0e21e
LW		 1202 break;
1203 case CXt_EVAL:
1204 POPEVAL(cx);
1205 break;
1206 case CXt_LOOP:
1207 POPLOOP(cx);
1208 break;
0a753a76 1209 case CXt_NULL:
a0d0e21e
LW		 1210 break;
1211 }
c90c0ff4 1212 cxstack_ix--;
a0d0e21e
LW		 1213 }
1214}
1215
067f92a0
GS		 1216/*
1217 * Closures mentioned at top level of eval cannot be referenced
1218 * again, and their presence indirectly causes a memory leak.
1219 * (Note that the fact that compcv and friends are still set here
1220 * is, AFAIK, an accident.) --Chip
1221 *
1222 * XXX need to get comppad et al from eval's cv rather than
1223 * relying on the incidental global values.
1224 */
1225STATIC void
cea2e8a9 1226S_free_closures(pTHX)
067f92a0
GS		 1227{
1228 dTHR;
1229 SV **svp = AvARRAY(PL_comppad_name);
1230 I32 ix;
1231 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1232 SV *sv = svp[ix];
1233 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1234 SvREFCNT_dec(sv);
1235 svp[ix] = &PL_sv_undef;
1236
1237 sv = PL_curpad[ix];
1238 if (CvCLONE(sv)) {
1239 SvREFCNT_dec(CvOUTSIDE(sv));
1240 CvOUTSIDE(sv) = Nullcv;
1241 }
1242 else {
1243 SvREFCNT_dec(sv);
1244 sv = NEWSV(0,0);
1245 SvPADTMP_on(sv);
1246 PL_curpad[ix] = sv;
1247 }
1248 }
1249 }
1250}
1251
5a844595
GS		 1252void
1253Perl_qerror(pTHX_ SV *err)
1254{
1255 if (PL_in_eval)
1256 sv_catsv(ERRSV, err);
1257 else if (PL_errors)
1258 sv_catsv(PL_errors, err);
1259 else
1260 Perl_warn(aTHX_ "%_", err);
1261 ++PL_error_count;
1262}
1263
a0d0e21e 1264OP *
864dbfa3 1265Perl_die_where(pTHX_ char *message, STRLEN msglen)
a0d0e21e 1266{
e336de0d 1267 dSP;
2d8e6c8d 1268 STRLEN n_a;
3280af22 1269 if (PL_in_eval) {
a0d0e21e 1270 I32 cxix;
c09156bb 1271 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1272 I32 gimme;
1273 SV **newsp;
1274
4e6ea2c3 1275 if (message) {
faef0170 1276 if (PL_in_eval & EVAL_KEEPERR) {
98eae8f5
GS		 1277 static char prefix[] = "\t(in cleanup) ";
1278 SV *err = ERRSV;
1279 char *e = Nullch;
1280 if (!SvPOK(err))
1281 sv_setpv(err,"");
1282 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1283 e = SvPV(err, n_a);
1284 e += n_a - msglen;
1285 if (*e != *message || strNE(e,message))
1286 e = Nullch;
1287 }
1288 if (!e) {
1289 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1290 sv_catpvn(err, prefix, sizeof(prefix)-1);
1291 sv_catpvn(err, message, msglen);
1292 if (ckWARN(WARN_UNSAFE)) {
1293 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1294 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
4e6ea2c3 1295 }
4633a7c4 1296 }
4633a7c4 1297 }
4e6ea2c3 1298 else
06bf62c7 1299 sv_setpvn(ERRSV, message, msglen);
4633a7c4
LW		 1300 }
1301 else
06bf62c7 1302 message = SvPVx(ERRSV, msglen);
4e6ea2c3 1303
5a844595
GS		 1304 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1305 && PL_curstackinfo->si_prev)
1306 {
bac4b2ad 1307 dounwind(-1);
d3acc0f7 1308 POPSTACK;
bac4b2ad 1309 }
e336de0d 1310
a0d0e21e
LW		 1311 if (cxix >= 0) {
1312 I32 optype;
1313
1314 if (cxix < cxstack_ix)
1315 dounwind(cxix);
1316
3280af22 1317 POPBLOCK(cx,PL_curpm);
6b35e009 1318 if (CxTYPE(cx) != CXt_EVAL) {
bf49b057
GS		 1319 PerlIO_write(Perl_error_log, "panic: die ", 11);
1320 PerlIO_write(Perl_error_log, message, msglen);
a0d0e21e
LW		 1321 my_exit(1);
1322 }
1323 POPEVAL(cx);
1324
1325 if (gimme == G_SCALAR)
3280af22
NIS		 1326 *++newsp = &PL_sv_undef;
1327 PL_stack_sp = newsp;
a0d0e21e
LW		 1328
1329 LEAVE;
748a9306 1330
7a2e2cd6 1331 if (optype == OP_REQUIRE) {
2d8e6c8d 1332 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS		 1333 DIE(aTHX_ "%sCompilation failed in require",
1334 *msg ? msg : "Unknown error\n");
7a2e2cd6 1335 }
a0d0e21e
LW		 1336 return pop_return();
1337 }
1338 }
9cc2fdd3 1339 if (!message)
06bf62c7 1340 message = SvPVx(ERRSV, msglen);
d175a3f0
GS		 1341 {
1342#ifdef USE_SFIO
1343 /* SFIO can really mess with your errno */
1344 int e = errno;
1345#endif
bf49b057
GS		 1346 PerlIO *serr = Perl_error_log;
1347
1348 PerlIO_write(serr, message, msglen);
1349 (void)PerlIO_flush(serr);
d175a3f0
GS		 1350#ifdef USE_SFIO
1351 errno = e;
1352#endif
1353 }
f86702cc 1354 my_failure_exit();
1355 /* NOTREACHED */
a0d0e21e
LW		 1356 return 0;
1357}
1358
1359PP(pp_xor)
1360{
4e35701f 1361 djSP; dPOPTOPssrl;
a0d0e21e
LW		 1362 if (SvTRUE(left) != SvTRUE(right))
1363 RETSETYES;
1364 else
1365 RETSETNO;
1366}
1367
1368PP(pp_andassign)
1369{
4e35701f 1370 djSP;
a0d0e21e
LW		 1371 if (!SvTRUE(TOPs))
1372 RETURN;
1373 else
1374 RETURNOP(cLOGOP->op_other);
1375}
1376
1377PP(pp_orassign)
1378{
4e35701f 1379 djSP;
a0d0e21e
LW		 1380 if (SvTRUE(TOPs))
1381 RETURN;
1382 else
1383 RETURNOP(cLOGOP->op_other);
1384}
1385
a0d0e21e
LW		 1386PP(pp_caller)
1387{
4e35701f 1388 djSP;
a0d0e21e 1389 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1390 register PERL_CONTEXT *cx;
2c375eb9 1391 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1392 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1393 I32 dbcxix;
54310121 1394 I32 gimme;
ed094faf 1395 char *stashname;
a0d0e21e
LW		 1396 SV *sv;
1397 I32 count = 0;
1398
1399 if (MAXARG)
1400 count = POPi;
f3aa04c2 1401 EXTEND(SP, 7);
a0d0e21e 1402 for (;;) {
2c375eb9
GS		 1403 /* we may be in a higher stacklevel, so dig down deeper */
1404 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1405 top_si = top_si->si_prev;
1406 ccstack = top_si->si_cxstack;
1407 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1408 }
a0d0e21e
LW		 1409 if (cxix < 0) {
1410 if (GIMME != G_ARRAY)
1411 RETPUSHUNDEF;
1412 RETURN;
1413 }
3280af22
NIS		 1414 if (PL_DBsub && cxix >= 0 &&
1415 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1416 count++;
1417 if (!count--)
1418 break;
2c375eb9 1419 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1420 }
2c375eb9
GS		 1421
1422 cx = &ccstack[cxix];
6b35e009 1423 if (CxTYPE(cx) == CXt_SUB) {
2c375eb9
GS		 1424 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1425 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1426 field below is defined for any cx. */
3280af22 1427 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1428 cx = &ccstack[dbcxix];
06a5b730 1429 }
1430
ed094faf 1431 stashname = CopSTASHPV(cx->blk_oldcop);
a0d0e21e 1432 if (GIMME != G_ARRAY) {
ed094faf 1433 if (!stashname)
3280af22 1434 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1435 else {
1436 dTARGET;
ed094faf 1437 sv_setpv(TARG, stashname);
49d8d3a1
MB		 1438 PUSHs(TARG);
1439 }
a0d0e21e
LW		 1440 RETURN;
1441 }
a0d0e21e 1442
ed094faf 1443 if (!stashname)
3280af22 1444 PUSHs(&PL_sv_undef);
49d8d3a1 1445 else
ed094faf
GS		 1446 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1447 PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
57843af0 1448 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
a0d0e21e
LW		 1449 if (!MAXARG)
1450 RETURN;
6b35e009 1451 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
a0d0e21e 1452 sv = NEWSV(49, 0);
2c375eb9 1453 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
a0d0e21e
LW		 1454 PUSHs(sv_2mortal(sv));
1455 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1456 }
1457 else {
79cb57f6 1458 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW		 1459 PUSHs(sv_2mortal(newSViv(0)));
1460 }
54310121 1461 gimme = (I32)cx->blk_gimme;
1462 if (gimme == G_VOID)
3280af22 1463 PUSHs(&PL_sv_undef);
54310121 1464 else
1465 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1466 if (CxTYPE(cx) == CXt_EVAL) {
06a5b730 1467 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1468 PUSHs(cx->blk_eval.cur_text);
3280af22 1469 PUSHs(&PL_sv_no);
06a5b730 1470 }
1471 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1472 /* Require, put the name. */
1473 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
3280af22 1474 PUSHs(&PL_sv_yes);
06a5b730 1475 }
4633a7c4 1476 }
a682de96
GS		 1477 else {
1478 PUSHs(&PL_sv_undef);
1479 PUSHs(&PL_sv_undef);
1480 }
1481 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
ed094faf 1482 && CopSTASH_eq(PL_curcop, PL_debstash))
4633a7c4 1483 {
a0d0e21e
LW		 1484 AV *ary = cx->blk_sub.argarray;
1485 int off = AvARRAY(ary) - AvALLOC(ary);
1486
3280af22 1487 if (!PL_dbargs) {
a0d0e21e 1488 GV* tmpgv;
3280af22 1489 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1490 SVt_PVAV)));
a5f75d66 1491 GvMULTI_on(tmpgv);
3280af22 1492 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
a0d0e21e
LW		 1493 }
1494
3280af22
NIS		 1495 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1496 av_extend(PL_dbargs, AvFILLp(ary) + off);
1497 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1498 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1499 }
f3aa04c2
GS		 1500 /* XXX only hints propagated via op_private are currently
1501 * visible (others are not easily accessible, since they
1502 * use the global PL_hints) */
1503 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1504 HINT_PRIVATE_MASK)));
a0d0e21e
LW		 1505 RETURN;
1506}
1507
a0d0e21e
LW		 1508PP(pp_reset)
1509{
4e35701f 1510 djSP;
a0d0e21e 1511 char *tmps;
2d8e6c8d 1512 STRLEN n_a;
a0d0e21e
LW		 1513
1514 if (MAXARG < 1)
1515 tmps = "";
1516 else
2d8e6c8d 1517 tmps = POPpx;
11faa288 1518 sv_reset(tmps, CopSTASH(PL_curcop));
3280af22 1519 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1520 RETURN;
1521}
1522
1523PP(pp_lineseq)
1524{
1525 return NORMAL;
1526}
1527
1528PP(pp_dbstate)
1529{
533c011a 1530 PL_curcop = (COP*)PL_op;
a0d0e21e 1531 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1532 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1533 FREETMPS;
1534
533c011a 1535 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1536 {
924508f0 1537 djSP;
a0d0e21e 1538 register CV *cv;
c09156bb 1539 register PERL_CONTEXT *cx;
748a9306 1540 I32 gimme = G_ARRAY;
a0d0e21e
LW		 1541 I32 hasargs;
1542 GV *gv;
1543
3280af22 1544 gv = PL_DBgv;
a0d0e21e 1545 cv = GvCV(gv);
a0d0e21e 1546 if (!cv)
cea2e8a9 1547 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1548
3280af22 1549 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
a0d0e21e 1550 return NORMAL;
748a9306 1551
4633a7c4
LW		 1552 ENTER;
1553 SAVETMPS;
1554
3280af22 1555 SAVEI32(PL_debug);
55497cff 1556 SAVESTACK_POS();
3280af22 1557 PL_debug = 0;
748a9306 1558 hasargs = 0;
924508f0 1559 SPAGAIN;
748a9306 1560
533c011a 1561 push_return(PL_op->op_next);
924508f0 1562 PUSHBLOCK(cx, CXt_SUB, SP);
a0d0e21e
LW		 1563 PUSHSUB(cx);
1564 CvDEPTH(cv)++;
1565 (void)SvREFCNT_inc(cv);
3280af22
NIS		 1566 SAVESPTR(PL_curpad);
1567 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
a0d0e21e
LW		 1568 RETURNOP(CvSTART(cv));
1569 }
1570 else
1571 return NORMAL;
1572}
1573
1574PP(pp_scope)
1575{
1576 return NORMAL;
1577}
1578
1579PP(pp_enteriter)
1580{
4e35701f 1581 djSP; dMARK;
c09156bb 1582 register PERL_CONTEXT *cx;
54310121 1583 I32 gimme = GIMME_V;
a0d0e21e
LW		 1584 SV **svp;
1585
4633a7c4
LW		 1586 ENTER;
1587 SAVETMPS;
1588
54b9620d 1589#ifdef USE_THREADS
0214ae40
GS		 1590 if (PL_op->op_flags & OPf_SPECIAL) {
1591 dTHR;
1592 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1593 SAVEGENERICSV(*svp);
1594 *svp = NEWSV(0,0);
1595 }
a0d0e21e 1596 else
54b9620d 1597#endif /* USE_THREADS */
533c011a
NIS		 1598 if (PL_op->op_targ) {
1599 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
54b9620d
MB		 1600 SAVESPTR(*svp);
1601 }
1602 else {
0214ae40
GS		 1603 svp = &GvSV((GV*)POPs); /* symbol table variable */
1604 SAVEGENERICSV(*svp);
1605 *svp = NEWSV(0,0);
54b9620d 1606 }
4633a7c4 1607
a0d0e21e
LW		 1608 ENTER;
1609
1610 PUSHBLOCK(cx, CXt_LOOP, SP);
1611 PUSHLOOP(cx, svp, MARK);
533c011a 1612 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1613 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1614 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1615 dPOPss;
1616 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1617 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1618 if (SvNV(sv) < IV_MIN ||
1619 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
d470f89e 1620 DIE(aTHX_ "Range iterator outside integer range");
89ea2908
GA		 1621 cx->blk_loop.iterix = SvIV(sv);
1622 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1623 }
1624 else
1625 cx->blk_loop.iterlval = newSVsv(sv);
1626 }
1627 }
4633a7c4 1628 else {
3280af22
NIS		 1629 cx->blk_loop.iterary = PL_curstack;
1630 AvFILLp(PL_curstack) = SP - PL_stack_base;
1631 cx->blk_loop.iterix = MARK - PL_stack_base;
4633a7c4 1632 }
a0d0e21e
LW		 1633
1634 RETURN;
1635}
1636
1637PP(pp_enterloop)
1638{
4e35701f 1639 djSP;
c09156bb 1640 register PERL_CONTEXT *cx;
54310121 1641 I32 gimme = GIMME_V;
a0d0e21e
LW		 1642
1643 ENTER;
1644 SAVETMPS;
1645 ENTER;
1646
1647 PUSHBLOCK(cx, CXt_LOOP, SP);
1648 PUSHLOOP(cx, 0, SP);
1649
1650 RETURN;
1651}
1652
1653PP(pp_leaveloop)
1654{
4e35701f 1655 djSP;
c09156bb 1656 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1657 I32 gimme;
1658 SV **newsp;
1659 PMOP *newpm;
1660 SV **mark;
1661
1662 POPBLOCK(cx,newpm);
4fdae800 1663 mark = newsp;
a8bba7fa 1664 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1665
a1f49e72 1666 TAINT_NOT;
54310121 1667 if (gimme == G_VOID)
1668 ; /* do nothing */
1669 else if (gimme == G_SCALAR) {
1670 if (mark < SP)
1671 *++newsp = sv_mortalcopy(*SP);
1672 else
3280af22 1673 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1674 }
1675 else {
a1f49e72 1676 while (mark < SP) {
a0d0e21e 1677 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1678 TAINT_NOT; /* Each item is independent */
1679 }
a0d0e21e 1680 }
f86702cc 1681 SP = newsp;
1682 PUTBACK;
1683
a8bba7fa 1684 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1685 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1686
a0d0e21e
LW		 1687 LEAVE;
1688 LEAVE;
1689
f86702cc 1690 return NORMAL;
a0d0e21e
LW		 1691}
1692
1693PP(pp_return)
1694{
4e35701f 1695 djSP; dMARK;
a0d0e21e 1696 I32 cxix;
c09156bb 1697 register PERL_CONTEXT *cx;
f86702cc 1698 bool popsub2 = FALSE;
a0d0e21e
LW		 1699 I32 gimme;
1700 SV **newsp;
1701 PMOP *newpm;
1702 I32 optype = 0;
b0d9ce38 1703 SV *sv;
a0d0e21e 1704
3280af22
NIS		 1705 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1706 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1707 if (cxstack_ix > PL_sortcxix)
1708 dounwind(PL_sortcxix);
1709 AvARRAY(PL_curstack)[1] = *SP;
1710 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1711 return 0;
1712 }
1713 }
1714
1715 cxix = dopoptosub(cxstack_ix);
1716 if (cxix < 0)
cea2e8a9 1717 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW		 1718 if (cxix < cxstack_ix)
1719 dounwind(cxix);
1720
1721 POPBLOCK(cx,newpm);
6b35e009 1722 switch (CxTYPE(cx)) {
a0d0e21e 1723 case CXt_SUB:
f86702cc 1724 popsub2 = TRUE;
a0d0e21e
LW		 1725 break;
1726 case CXt_EVAL:
1727 POPEVAL(cx);
067f92a0
GS		 1728 if (AvFILLp(PL_comppad_name) >= 0)
1729 free_closures();
1730 lex_end();
748a9306
LW		 1731 if (optype == OP_REQUIRE &&
1732 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1733 {
54310121 1734 /* Unassume the success we assumed earlier. */
748a9306 1735 char *name = cx->blk_eval.old_name;
3280af22 1736 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 1737 DIE(aTHX_ "%s did not return a true value", name);
748a9306 1738 }
a0d0e21e
LW		 1739 break;
1740 default:
cea2e8a9 1741 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 1742 }
1743
a1f49e72 1744 TAINT_NOT;
a0d0e21e 1745 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 1746 if (MARK < SP) {
1747 if (popsub2) {
a8bba7fa 1748 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ		 1749 if (SvTEMP(TOPs)) {
1750 *++newsp = SvREFCNT_inc(*SP);
1751 FREETMPS;
1752 sv_2mortal(*newsp);
1753 } else {
1754 FREETMPS;
1755 *++newsp = sv_mortalcopy(*SP);
1756 }
1757 } else
1758 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1759 } else
1760 *++newsp = sv_mortalcopy(*SP);
1761 } else
3280af22 1762 *++newsp = &PL_sv_undef;
a0d0e21e 1763 }
54310121 1764 else if (gimme == G_ARRAY) {
a1f49e72 1765 while (++MARK <= SP) {
f86702cc 1766 *++newsp = (popsub2 && SvTEMP(*MARK))
1767 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1768 TAINT_NOT; /* Each item is independent */
1769 }
a0d0e21e 1770 }
3280af22 1771 PL_stack_sp = newsp;
a0d0e21e 1772
f86702cc 1773 /* Stack values are safe: */
1774 if (popsub2) {
b0d9ce38 1775 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1776 }
b0d9ce38
GS		 1777 else
1778 sv = Nullsv;
3280af22 1779 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1780
a0d0e21e 1781 LEAVE;
b0d9ce38 1782 LEAVESUB(sv);
a0d0e21e
LW		 1783 return pop_return();
1784}
1785
1786PP(pp_last)
1787{
4e35701f 1788 djSP;
a0d0e21e 1789 I32 cxix;
c09156bb 1790 register PERL_CONTEXT *cx;
f86702cc 1791 I32 pop2 = 0;
a0d0e21e
LW		 1792 I32 gimme;
1793 I32 optype;
1794 OP *nextop;
1795 SV **newsp;
1796 PMOP *newpm;
a8bba7fa 1797 SV **mark;
b0d9ce38 1798 SV *sv = Nullsv;
a0d0e21e 1799
533c011a 1800 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1801 cxix = dopoptoloop(cxstack_ix);
1802 if (cxix < 0)
cea2e8a9 1803 DIE(aTHX_ "Can't \"last\" outside a block");
a0d0e21e
LW		 1804 }
1805 else {
1806 cxix = dopoptolabel(cPVOP->op_pv);
1807 if (cxix < 0)
cea2e8a9 1808 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1809 }
1810 if (cxix < cxstack_ix)
1811 dounwind(cxix);
1812
1813 POPBLOCK(cx,newpm);
a8bba7fa 1814 mark = newsp;
6b35e009 1815 switch (CxTYPE(cx)) {
a0d0e21e 1816 case CXt_LOOP:
f86702cc 1817 pop2 = CXt_LOOP;
a8bba7fa
GS		 1818 newsp = PL_stack_base + cx->blk_loop.resetsp;
1819 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 1820 break;
f86702cc 1821 case CXt_SUB:
f86702cc 1822 pop2 = CXt_SUB;
a0d0e21e
LW		 1823 nextop = pop_return();
1824 break;
f86702cc 1825 case CXt_EVAL:
1826 POPEVAL(cx);
a0d0e21e
LW		 1827 nextop = pop_return();
1828 break;
1829 default:
cea2e8a9 1830 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 1831 }
1832
a1f49e72 1833 TAINT_NOT;
a0d0e21e 1834 if (gimme == G_SCALAR) {
f86702cc 1835 if (MARK < SP)
1836 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1837 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1838 else
3280af22 1839 *++newsp = &PL_sv_undef;
a0d0e21e 1840 }
54310121 1841 else if (gimme == G_ARRAY) {
a1f49e72 1842 while (++MARK <= SP) {
f86702cc 1843 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1844 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1845 TAINT_NOT; /* Each item is independent */
1846 }
f86702cc 1847 }
1848 SP = newsp;
1849 PUTBACK;
1850
1851 /* Stack values are safe: */
1852 switch (pop2) {
1853 case CXt_LOOP:
a8bba7fa 1854 POPLOOP(cx); /* release loop vars ... */
4fdae800 1855 LEAVE;
f86702cc 1856 break;
1857 case CXt_SUB:
b0d9ce38 1858 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1859 break;
a0d0e21e 1860 }
3280af22 1861 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW		 1862
1863 LEAVE;
b0d9ce38 1864 LEAVESUB(sv);
f86702cc 1865 return nextop;
a0d0e21e
LW		 1866}
1867
1868PP(pp_next)
1869{
1870 I32 cxix;
c09156bb 1871 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1872 I32 oldsave;
1873
533c011a 1874 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1875 cxix = dopoptoloop(cxstack_ix);
1876 if (cxix < 0)
cea2e8a9 1877 DIE(aTHX_ "Can't \"next\" outside a block");
a0d0e21e
LW		 1878 }
1879 else {
1880 cxix = dopoptolabel(cPVOP->op_pv);
1881 if (cxix < 0)
cea2e8a9 1882 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1883 }
1884 if (cxix < cxstack_ix)
1885 dounwind(cxix);
1886
1887 TOPBLOCK(cx);
3280af22 1888 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 1889 LEAVE_SCOPE(oldsave);
1890 return cx->blk_loop.next_op;
1891}
1892
1893PP(pp_redo)
1894{
1895 I32 cxix;
c09156bb 1896 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1897 I32 oldsave;
1898
533c011a 1899 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1900 cxix = dopoptoloop(cxstack_ix);
1901 if (cxix < 0)
cea2e8a9 1902 DIE(aTHX_ "Can't \"redo\" outside a block");
a0d0e21e
LW		 1903 }
1904 else {
1905 cxix = dopoptolabel(cPVOP->op_pv);
1906 if (cxix < 0)
cea2e8a9 1907 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1908 }
1909 if (cxix < cxstack_ix)
1910 dounwind(cxix);
1911
1912 TOPBLOCK(cx);
3280af22 1913 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 1914 LEAVE_SCOPE(oldsave);
1915 return cx->blk_loop.redo_op;
1916}
1917
0824fdcb 1918STATIC OP *
cea2e8a9 1919S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW		 1920{
1921 OP *kid;
1922 OP **ops = opstack;
fc36a67e 1923 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 1924
fc36a67e 1925 if (ops >= oplimit)
cea2e8a9 1926 Perl_croak(aTHX_ too_deep);
11343788
MB		 1927 if (o->op_type == OP_LEAVE ||
1928 o->op_type == OP_SCOPE ||
1929 o->op_type == OP_LEAVELOOP ||
1930 o->op_type == OP_LEAVETRY)
fc36a67e 1931 {
5dc0d613 1932 *ops++ = cUNOPo->op_first;
fc36a67e 1933 if (ops >= oplimit)
cea2e8a9 1934 Perl_croak(aTHX_ too_deep);
fc36a67e 1935 }
c4aa4e48 1936 *ops = 0;
11343788 1937 if (o->op_flags & OPf_KIDS) {
5c0ca799 1938 dTHR;
a0d0e21e 1939 /* First try all the kids at this level, since that's likeliest. */
11343788 1940 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 1941 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1942 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 1943 return kid;
1944 }
11343788 1945 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 1946 if (kid == PL_lastgotoprobe)
a0d0e21e 1947 continue;
c4aa4e48
GS		 1948 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1949 (ops == opstack ||
1950 (ops[-1]->op_type != OP_NEXTSTATE &&
1951 ops[-1]->op_type != OP_DBSTATE)))
fc36a67e 1952 *ops++ = kid;
5dc0d613 1953 if (o = dofindlabel(kid, label, ops, oplimit))
11343788 1954 return o;
a0d0e21e
LW		 1955 }
1956 }
c4aa4e48 1957 *ops = 0;
a0d0e21e
LW		 1958 return 0;
1959}
1960
1961PP(pp_dump)
1962{
cea2e8a9 1963 return pp_goto();
a0d0e21e
LW		 1964 /*NOTREACHED*/
1965}
1966
1967PP(pp_goto)
1968{
4e35701f 1969 djSP;
a0d0e21e
LW		 1970 OP *retop = 0;
1971 I32 ix;
c09156bb 1972 register PERL_CONTEXT *cx;
fc36a67e 1973#define GOTO_DEPTH 64
1974 OP *enterops[GOTO_DEPTH];
a0d0e21e 1975 char *label;
533c011a 1976 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 1977 static char must_have_label[] = "goto must have label";
a0d0e21e
LW		 1978
1979 label = 0;
533c011a 1980 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 1981 SV *sv = POPs;
2d8e6c8d 1982 STRLEN n_a;
a0d0e21e
LW		 1983
1984 /* This egregious kludge implements goto &subroutine */
1985 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1986 I32 cxix;
c09156bb 1987 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1988 CV* cv = (CV*)SvRV(sv);
1989 SV** mark;
1990 I32 items = 0;
1991 I32 oldsave;
1992
e8f7dd13 1993 retry:
4aa0a1f7 1994 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS		 1995 GV *gv = CvGV(cv);
1996 GV *autogv;
1997 if (gv) {
1998 SV *tmpstr;
1999 /* autoloaded stub? */
2000 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2001 goto retry;
2002 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2003 GvNAMELEN(gv), FALSE);
2004 if (autogv && (cv = GvCV(autogv)))
2005 goto retry;
2006 tmpstr = sv_newmortal();
2007 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 2008 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
4aa0a1f7 2009 }
cea2e8a9 2010 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2011 }
2012
a0d0e21e
LW		 2013 /* First do some returnish stuff. */
2014 cxix = dopoptosub(cxstack_ix);
2015 if (cxix < 0)
cea2e8a9 2016 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2017 if (cxix < cxstack_ix)
2018 dounwind(cxix);
2019 TOPBLOCK(cx);
6b35e009 2020 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
cea2e8a9 2021 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3280af22 2022 mark = PL_stack_sp;
d8b46c1b
GS		 2023 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2024 /* put @_ back onto stack */
a0d0e21e
LW		 2025 AV* av = cx->blk_sub.argarray;
2026
93965878 2027 items = AvFILLp(av) + 1;
3280af22
NIS		 2028 PL_stack_sp++;
2029 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2030 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2031 PL_stack_sp += items;
6d4ff0d2 2032#ifndef USE_THREADS
3280af22
NIS		 2033 SvREFCNT_dec(GvAV(PL_defgv));
2034 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 2035#endif /* USE_THREADS */
d8b46c1b 2036 /* abandon @_ if it got reified */
62b1ebc2 2037 if (AvREAL(av)) {
d8b46c1b
GS		 2038 (void)sv_2mortal((SV*)av); /* delay until return */
2039 av = newAV();
2040 av_extend(av, items-1);
2041 AvFLAGS(av) = AVf_REIFY;
2042 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2043 }
a0d0e21e 2044 }
1fa4e549
AD		 2045 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2046 AV* av;
2047 int i;
2048#ifdef USE_THREADS
533c011a 2049 av = (AV*)PL_curpad[0];
1fa4e549 2050#else
3280af22 2051 av = GvAV(PL_defgv);
1fa4e549
AD		 2052#endif
2053 items = AvFILLp(av) + 1;
3280af22
NIS		 2054 PL_stack_sp++;
2055 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2056 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2057 PL_stack_sp += items;
1fa4e549 2058 }
6b35e009 2059 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2060 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2061 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2062 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2063 LEAVE_SCOPE(oldsave);
2064
2065 /* Now do some callish stuff. */
2066 SAVETMPS;
2067 if (CvXSUB(cv)) {
67caa1fe 2068#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2069 if (CvOLDSTYLE(cv)) {
20ce7b12 2070 I32 (*fp3)(int,int,int);
924508f0
GS		 2071 while (SP > mark) {
2072 SP[1] = SP[0];
2073 SP--;
a0d0e21e 2074 }
20ce7b12 2075 fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
ecfc5424 2076 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2077 mark - PL_stack_base + 1,
ecfc5424 2078 items);
3280af22 2079 SP = PL_stack_base + items;
a0d0e21e 2080 }
67caa1fe
GS		 2081 else
2082#endif /* PERL_XSUB_OLDSTYLE */
2083 {
1fa4e549
AD		 2084 SV **newsp;
2085 I32 gimme;
2086
3280af22 2087 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD		 2088 /* Push a mark for the start of arglist */
2089 PUSHMARK(mark);
0cb96387 2090 (void)(*CvXSUB(cv))(aTHXo_ cv);
1fa4e549 2091 /* Pop the current context like a decent sub should */
3280af22 2092 POPBLOCK(cx, PL_curpm);
1fa4e549 2093 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW		 2094 }
2095 LEAVE;
2096 return pop_return();
2097 }
2098 else {
2099 AV* padlist = CvPADLIST(cv);
2100 SV** svp = AvARRAY(padlist);
6b35e009 2101 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2102 PL_in_eval = cx->blk_eval.old_in_eval;
2103 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2104 cx->cx_type = CXt_SUB;
2105 cx->blk_sub.hasargs = 0;
2106 }
a0d0e21e
LW		 2107 cx->blk_sub.cv = cv;
2108 cx->blk_sub.olddepth = CvDEPTH(cv);
2109 CvDEPTH(cv)++;
2110 if (CvDEPTH(cv) < 2)
2111 (void)SvREFCNT_inc(cv);
2112 else { /* save temporaries on recursion? */
599cee73 2113 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2114 sub_crush_depth(cv);
93965878 2115 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2116 AV *newpad = newAV();
4aa0a1f7 2117 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2118 I32 ix = AvFILLp((AV*)svp[1]);
a0d0e21e 2119 svp = AvARRAY(svp[0]);
748a9306 2120 for ( ;ix > 0; ix--) {
3280af22 2121 if (svp[ix] != &PL_sv_undef) {
748a9306 2122 char *name = SvPVX(svp[ix]);
5f05dabc 2123 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2124 || *name == '&')
2125 {
2126 /* outer lexical or anon code */
748a9306 2127 av_store(newpad, ix,
4aa0a1f7 2128 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW		 2129 }
2130 else { /* our own lexical */
2131 if (*name == '@')
2132 av_store(newpad, ix, sv = (SV*)newAV());
2133 else if (*name == '%')
2134 av_store(newpad, ix, sv = (SV*)newHV());
2135 else
2136 av_store(newpad, ix, sv = NEWSV(0,0));
2137 SvPADMY_on(sv);
2138 }
a0d0e21e 2139 }
743e66e6
GS		 2140 else if (IS_PADGV(oldpad[ix])) {
2141 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2142 }
a0d0e21e 2143 else {
748a9306 2144 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW		 2145 SvPADTMP_on(sv);
2146 }
2147 }
2148 if (cx->blk_sub.hasargs) {
2149 AV* av = newAV();
2150 av_extend(av, 0);
2151 av_store(newpad, 0, (SV*)av);
2152 AvFLAGS(av) = AVf_REIFY;
2153 }
2154 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2155 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW		 2156 svp = AvARRAY(padlist);
2157 }
2158 }
6d4ff0d2
MB		 2159#ifdef USE_THREADS
2160 if (!cx->blk_sub.hasargs) {
533c011a 2161 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2162
93965878 2163 items = AvFILLp(av) + 1;
6d4ff0d2
MB		 2164 if (items) {
2165 /* Mark is at the end of the stack. */
924508f0
GS		 2166 EXTEND(SP, items);
2167 Copy(AvARRAY(av), SP + 1, items, SV*);
2168 SP += items;
6d4ff0d2
MB		 2169 PUTBACK ;
2170 }
2171 }
2172#endif /* USE_THREADS */
3280af22
NIS		 2173 SAVESPTR(PL_curpad);
2174 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB		 2175#ifndef USE_THREADS
2176 if (cx->blk_sub.hasargs)
2177#endif /* USE_THREADS */
2178 {
3280af22 2179 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW		 2180 SV** ary;
2181
6d4ff0d2 2182#ifndef USE_THREADS
3280af22
NIS		 2183 cx->blk_sub.savearray = GvAV(PL_defgv);
2184 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB		 2185#endif /* USE_THREADS */
2186 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2187 ++mark;
2188
2189 if (items >= AvMAX(av) + 1) {
2190 ary = AvALLOC(av);
2191 if (AvARRAY(av) != ary) {
2192 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2193 SvPVX(av) = (char*)ary;
2194 }
2195 if (items >= AvMAX(av) + 1) {
2196 AvMAX(av) = items - 1;
2197 Renew(ary,items+1,SV*);
2198 AvALLOC(av) = ary;
2199 SvPVX(av) = (char*)ary;
2200 }
2201 }
2202 Copy(mark,AvARRAY(av),items,SV*);
93965878 2203 AvFILLp(av) = items - 1;
d8b46c1b 2204 assert(!AvREAL(av));
a0d0e21e
LW		 2205 while (items--) {
2206 if (*mark)
2207 SvTEMP_off(*mark);
2208 mark++;
2209 }
2210 }
491527d0 2211 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2212 /*
2213 * We do not care about using sv to call CV;
2214 * it's for informational purposes only.
2215 */
3280af22 2216 SV *sv = GvSV(PL_DBsub);
491527d0
GS		 2217 CV *gotocv;
2218
2219 if (PERLDB_SUB_NN) {
56431972 2220 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
491527d0
GS		 2221 } else {
2222 save_item(sv);
2223 gv_efullname3(sv, CvGV(cv), Nullch);
2224 }
2225 if ( PERLDB_GOTO
864dbfa3 2226 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2227 PUSHMARK( PL_stack_sp );
864dbfa3 2228 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2229 PL_stack_sp--;
491527d0 2230 }
1ce6579f 2231 }
a0d0e21e
LW		 2232 RETURNOP(CvSTART(cv));
2233 }
2234 }
1614b0e3 2235 else {
2d8e6c8d 2236 label = SvPV(sv,n_a);
1614b0e3 2237 if (!(do_dump || *label))
cea2e8a9 2238 DIE(aTHX_ must_have_label);
1614b0e3 2239 }
a0d0e21e 2240 }
533c011a 2241 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2242 if (! do_dump)
cea2e8a9 2243 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2244 }
2245 else
2246 label = cPVOP->op_pv;
2247
2248 if (label && *label) {
2249 OP *gotoprobe = 0;
2250
2251 /* find label */
2252
3280af22 2253 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2254 *enterops = 0;
2255 for (ix = cxstack_ix; ix >= 0; ix--) {
2256 cx = &cxstack[ix];
6b35e009 2257 switch (CxTYPE(cx)) {
a0d0e21e 2258 case CXt_EVAL:
3280af22 2259 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW		 2260 break;
2261 case CXt_LOOP:
2262 gotoprobe = cx->blk_oldcop->op_sibling;
2263 break;
2264 case CXt_SUBST:
2265 continue;
2266 case CXt_BLOCK:
2267 if (ix)
2268 gotoprobe = cx->blk_oldcop->op_sibling;
2269 else
3280af22 2270 gotoprobe = PL_main_root;
a0d0e21e 2271 break;
b3933176
CS		 2272 case CXt_SUB:
2273 if (CvDEPTH(cx->blk_sub.cv)) {
2274 gotoprobe = CvROOT(cx->blk_sub.cv);
2275 break;
2276 }
2277 /* FALL THROUGH */
0a753a76 2278 case CXt_NULL:
cea2e8a9 2279 DIE(aTHX_ "Can't \"goto\" outside a block");
a0d0e21e
LW		 2280 default:
2281 if (ix)
cea2e8a9 2282 DIE(aTHX_ "panic: goto");
3280af22 2283 gotoprobe = PL_main_root;
a0d0e21e
LW		 2284 break;
2285 }
fc36a67e 2286 retop = dofindlabel(gotoprobe, label,
2287 enterops, enterops + GOTO_DEPTH);
a0d0e21e
LW		 2288 if (retop)
2289 break;
3280af22 2290 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2291 }
2292 if (!retop)
cea2e8a9 2293 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e
LW		 2294
2295 /* pop unwanted frames */
2296
2297 if (ix < cxstack_ix) {
2298 I32 oldsave;
2299
2300 if (ix < 0)
2301 ix = 0;
2302 dounwind(ix);
2303 TOPBLOCK(cx);
3280af22 2304 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2305 LEAVE_SCOPE(oldsave);
2306 }
2307
2308 /* push wanted frames */
2309
748a9306 2310 if (*enterops && enterops[1]) {
533c011a 2311 OP *oldop = PL_op;
748a9306 2312 for (ix = 1; enterops[ix]; ix++) {
533c011a 2313 PL_op = enterops[ix];
84902520
TB		 2314 /* Eventually we may want to stack the needed arguments
2315 * for each op. For now, we punt on the hard ones. */
533c011a 2316 if (PL_op->op_type == OP_ENTERITER)
cea2e8a9 2317 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
84902520 2318 label);
fc0dc3b3 2319 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2320 }
533c011a 2321 PL_op = oldop;
a0d0e21e
LW		 2322 }
2323 }
2324
2325 if (do_dump) {
a5f75d66 2326#ifdef VMS
6b88bc9c 2327 if (!retop) retop = PL_main_start;
a5f75d66 2328#endif
3280af22
NIS		 2329 PL_restartop = retop;
2330 PL_do_undump = TRUE;
a0d0e21e
LW		 2331
2332 my_unexec();
2333
3280af22
NIS		 2334 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2335 PL_do_undump = FALSE;
a0d0e21e
LW		 2336 }
2337
2338 RETURNOP(retop);
2339}
2340
2341PP(pp_exit)
2342{
4e35701f 2343 djSP;
a0d0e21e
LW		 2344 I32 anum;
2345
2346 if (MAXARG < 1)
2347 anum = 0;
ff0cee69 2348 else {
a0d0e21e 2349 anum = SvIVx(POPs);
ff0cee69 2350#ifdef VMSISH_EXIT
2351 if (anum == 1 && VMSISH_EXIT)
2352 anum = 0;
2353#endif
2354 }
a0d0e21e 2355 my_exit(anum);
3280af22 2356 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2357 RETURN;
2358}
2359
2360#ifdef NOTYET
2361PP(pp_nswitch)
2362{
4e35701f 2363 djSP;
65202027 2364 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2365 register I32 match = I_32(value);
2366
2367 if (value < 0.0) {
65202027 2368 if (((NV)match) > value)
a0d0e21e
LW		 2369 --match; /* was fractional--truncate other way */
2370 }
2371 match -= cCOP->uop.scop.scop_offset;
2372 if (match < 0)
2373 match = 0;
2374 else if (match > cCOP->uop.scop.scop_max)
2375 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2376 PL_op = cCOP->uop.scop.scop_next[match];
2377 RETURNOP(PL_op);
a0d0e21e
LW		 2378}
2379
2380PP(pp_cswitch)
2381{
4e35701f 2382 djSP;
a0d0e21e
LW		 2383 register I32 match;
2384
6b88bc9c
GS		 2385 if (PL_multiline)
2386 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2387 else {
2d8e6c8d
GS		 2388 STRLEN n_a;
2389 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW		 2390 match -= cCOP->uop.scop.scop_offset;
2391 if (match < 0)
2392 match = 0;
2393 else if (match > cCOP->uop.scop.scop_max)
2394 match = cCOP->uop.scop.scop_max;
6b88bc9c 2395 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2396 }
6b88bc9c 2397 RETURNOP(PL_op);
a0d0e21e
LW		 2398}
2399#endif
2400
2401/* Eval. */
2402
0824fdcb 2403STATIC void
cea2e8a9 2404S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW		 2405{
2406 register char *s = SvPVX(sv);
2407 register char *send = SvPVX(sv) + SvCUR(sv);
2408 register char *t;
2409 register I32 line = 1;
2410
2411 while (s && s < send) {
2412 SV *tmpstr = NEWSV(85,0);
2413
2414 sv_upgrade(tmpstr, SVt_PVMG);
2415 t = strchr(s, '\n');
2416 if (t)
2417 t++;
2418 else
2419 t = send;
2420
2421 sv_setpvn(tmpstr, s, t - s);
2422 av_store(array, line++, tmpstr);
2423 s = t;
2424 }
2425}
2426
312caa8e 2427STATIC void *
cea2e8a9 2428S_docatch_body(pTHX_ va_list args)
312caa8e 2429{
cea2e8a9 2430 CALLRUNOPS(aTHX);
312caa8e
CS		 2431 return NULL;
2432}
2433
0824fdcb 2434STATIC OP *
cea2e8a9 2435S_docatch(pTHX_ OP *o)
1e422769 2436{
e858de61 2437 dTHR;
6224f72b 2438 int ret;
533c011a 2439 OP *oldop = PL_op;
0cdb2077 2440 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2441 dJMPENV;
1e422769 2442
1e422769 2443#ifdef DEBUGGING
54310121 2444 assert(CATCH_GET == TRUE);
1e422769 2445#endif
312caa8e
CS		 2446 PL_op = o;
2447 redo_body:
db36c5a1 2448 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
6224f72b 2449 switch (ret) {
312caa8e
CS		 2450 case 0:
2451 break;
2452 case 3:
0cdb2077 2453 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS		 2454 PL_op = PL_restartop;
2455 PL_restartop = 0;
2456 goto redo_body;
2457 }
2458 /* FALL THROUGH */
2459 default:
533c011a 2460 PL_op = oldop;
6224f72b 2461 JMPENV_JUMP(ret);
1e422769 2462 /* NOTREACHED */
1e422769 2463 }
533c011a 2464 PL_op = oldop;
1e422769 2465 return Nullop;
2466}
2467
c277df42 2468OP *
864dbfa3 2469Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
c277df42
IZ		 2470/* sv Text to convert to OP tree. */
2471/* startop op_free() this to undo. */
2472/* code Short string id of the caller. */
2473{
2474 dSP; /* Make POPBLOCK work. */
2475 PERL_CONTEXT *cx;
2476 SV **newsp;
f987c7de 2477 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2478 I32 optype;
2479 OP dummy;
533c011a 2480 OP *oop = PL_op, *rop;
c277df42
IZ		 2481 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2482 char *safestr;
2483
2484 ENTER;
2485 lex_start(sv);
2486 SAVETMPS;
2487 /* switch to eval mode */
2488
cbce877f 2489 if (PL_curcop == &PL_compiling) {
11faa288
GS		 2490 SAVECOPSTASH(&PL_compiling);
2491 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2492 }
57843af0
GS		 2493 SAVECOPFILE(&PL_compiling);
2494 SAVECOPLINE(&PL_compiling);
3280af22 2495 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
57843af0
GS		 2496 CopFILE_set(&PL_compiling, tmpbuf+2);
2497 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2498 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2499 deleting the eval's FILEGV from the stash before gv_check() runs
2500 (i.e. before run-time proper). To work around the coredump that
2501 ensues, we always turn GvMULTI_on for any globals that were
2502 introduced within evals. See force_ident(). GSAR 96-10-12 */
2503 safestr = savepv(tmpbuf);
3280af22 2504 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2505 SAVEHINTS();
d1ca3daa 2506#ifdef OP_IN_REGISTER
6b88bc9c 2507 PL_opsave = op;
d1ca3daa 2508#else
533c011a 2509 SAVEPPTR(PL_op);
d1ca3daa 2510#endif
3280af22 2511 PL_hints = 0;
c277df42 2512
533c011a 2513 PL_op = &dummy;
13b51b79 2514 PL_op->op_type = OP_ENTEREVAL;
533c011a 2515 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2516 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 2517 PUSHEVAL(cx, 0, Nullgv);
c277df42 2518 rop = doeval(G_SCALAR, startop);
13b51b79 2519 POPBLOCK(cx,PL_curpm);
e84b9f1f 2520 POPEVAL(cx);
c277df42
IZ		 2521
2522 (*startop)->op_type = OP_NULL;
22c35a8c 2523 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2524 lex_end();
3280af22 2525 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2526 LEAVE;
13b51b79 2527 if (PL_curcop == &PL_compiling)
a0ed51b3 2528 PL_compiling.op_private = PL_hints;
d1ca3daa 2529#ifdef OP_IN_REGISTER
6b88bc9c 2530 op = PL_opsave;
d1ca3daa 2531#endif
c277df42
IZ		 2532 return rop;
2533}
2534
0f15f207 2535/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2536STATIC OP *
cea2e8a9 2537S_doeval(pTHX_ int gimme, OP** startop)
a0d0e21e
LW		 2538{
2539 dSP;
533c011a 2540 OP *saveop = PL_op;
ff3ff8d1 2541 CV *caller;
748a9306 2542 AV* comppadlist;
67a38de0 2543 I32 i;
a0d0e21e 2544
faef0170 2545 PL_in_eval = EVAL_INEVAL;
a0d0e21e 2546
1ce6579f 2547 PUSHMARK(SP);
2548
a0d0e21e
LW		 2549 /* set up a scratch pad */
2550
3280af22
NIS		 2551 SAVEI32(PL_padix);
2552 SAVESPTR(PL_curpad);
2553 SAVESPTR(PL_comppad);
2554 SAVESPTR(PL_comppad_name);
2555 SAVEI32(PL_comppad_name_fill);
2556 SAVEI32(PL_min_intro_pending);
2557 SAVEI32(PL_max_intro_pending);
748a9306 2558
3280af22 2559 caller = PL_compcv;
6b35e009 2560 for (i = cxstack_ix - 1; i >= 0; i--) {
67a38de0 2561 PERL_CONTEXT *cx = &cxstack[i];
6b35e009 2562 if (CxTYPE(cx) == CXt_EVAL)
67a38de0 2563 break;
6b35e009 2564 else if (CxTYPE(cx) == CXt_SUB) {
67a38de0
NIS		 2565 caller = cx->blk_sub.cv;
2566 break;
2567 }
2568 }
2569
3280af22
NIS		 2570 SAVESPTR(PL_compcv);
2571 PL_compcv = (CV*)NEWSV(1104,0);
2572 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2573 CvEVAL_on(PL_compcv);
11343788 2574#ifdef USE_THREADS
533c011a
NIS		 2575 CvOWNER(PL_compcv) = 0;
2576 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2577 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2578#endif /* USE_THREADS */
748a9306 2579
3280af22
NIS		 2580 PL_comppad = newAV();
2581 av_push(PL_comppad, Nullsv);
2582 PL_curpad = AvARRAY(PL_comppad);
2583 PL_comppad_name = newAV();
2584 PL_comppad_name_fill = 0;
2585 PL_min_intro_pending = 0;
2586 PL_padix = 0;
11343788 2587#ifdef USE_THREADS
79cb57f6 2588 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS		 2589 PL_curpad[0] = (SV*)newAV();
2590 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2591#endif /* USE_THREADS */
a0d0e21e 2592
748a9306
LW		 2593 comppadlist = newAV();
2594 AvREAL_off(comppadlist);
3280af22
NIS		 2595 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2596 av_store(comppadlist, 1, (SV*)PL_comppad);
2597 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2598
c277df42 2599 if (!saveop || saveop->op_type != OP_REQUIRE)
3280af22 2600 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
07055b4c 2601
3280af22 2602 SAVEFREESV(PL_compcv);
748a9306 2603
a0d0e21e
LW		 2604 /* make sure we compile in the right package */
2605
ed094faf 2606 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2607 SAVESPTR(PL_curstash);
ed094faf 2608 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2609 }
3280af22
NIS		 2610 SAVESPTR(PL_beginav);
2611 PL_beginav = newAV();
2612 SAVEFREESV(PL_beginav);
a0d0e21e
LW		 2613
2614 /* try to compile it */
2615
3280af22
NIS		 2616 PL_eval_root = Nullop;
2617 PL_error_count = 0;
2618 PL_curcop = &PL_compiling;
2619 PL_curcop->cop_arybase = 0;
2620 SvREFCNT_dec(PL_rs);
79cb57f6 2621 PL_rs = newSVpvn("\n", 1);
c277df42 2622 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2623 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2624 else
38a03e6e 2625 sv_setpv(ERRSV,"");
3280af22 2626 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW		 2627 SV **newsp;
2628 I32 gimme;
c09156bb 2629 PERL_CONTEXT *cx;
c277df42 2630 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2631 STRLEN n_a;
097ee67d 2632
533c011a 2633 PL_op = saveop;
3280af22
NIS		 2634 if (PL_eval_root) {
2635 op_free(PL_eval_root);
2636 PL_eval_root = Nullop;
a0d0e21e 2637 }
3280af22 2638 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2639 if (!startop) {
3280af22 2640 POPBLOCK(cx,PL_curpm);
c277df42
IZ		 2641 POPEVAL(cx);
2642 pop_return();
2643 }
a0d0e21e
LW		 2644 lex_end();
2645 LEAVE;
7a2e2cd6 2646 if (optype == OP_REQUIRE) {
2d8e6c8d 2647 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS		 2648 DIE(aTHX_ "%sCompilation failed in require",
2649 *msg ? msg : "Unknown error\n");
2650 }
2651 else if (startop) {
2d8e6c8d 2652 char* msg = SvPVx(ERRSV, n_a);
c277df42 2653
3280af22 2654 POPBLOCK(cx,PL_curpm);
c277df42 2655 POPEVAL(cx);
5a844595
GS		 2656 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2657 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2658 }
3280af22
NIS		 2659 SvREFCNT_dec(PL_rs);
2660 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2661#ifdef USE_THREADS
533c011a
NIS		 2662 MUTEX_LOCK(&PL_eval_mutex);
2663 PL_eval_owner = 0;
2664 COND_SIGNAL(&PL_eval_cond);
2665 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2666#endif /* USE_THREADS */
a0d0e21e
LW		 2667 RETPUSHUNDEF;
2668 }
3280af22
NIS		 2669 SvREFCNT_dec(PL_rs);
2670 PL_rs = SvREFCNT_inc(PL_nrs);
57843af0 2671 CopLINE_set(&PL_compiling, 0);
c277df42 2672 if (startop) {
3280af22
NIS		 2673 *startop = PL_eval_root;
2674 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2675 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2676 } else
3280af22 2677 SAVEFREEOP(PL_eval_root);
54310121 2678 if (gimme & G_VOID)
3280af22 2679 scalarvoid(PL_eval_root);
54310121 2680 else if (gimme & G_ARRAY)
3280af22 2681 list(PL_eval_root);
a0d0e21e 2682 else
3280af22 2683 scalar(PL_eval_root);
a0d0e21e
LW		 2684
2685 DEBUG_x(dump_eval());
2686
55497cff 2687 /* Register with debugger: */
84902520 2688 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2689 CV *cv = get_cv("DB::postponed", FALSE);
55497cff 2690 if (cv) {
2691 dSP;
924508f0 2692 PUSHMARK(SP);
cc49e20b 2693 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2694 PUTBACK;
864dbfa3 2695 call_sv((SV*)cv, G_DISCARD);
55497cff 2696 }
2697 }
2698
a0d0e21e
LW		 2699 /* compiled okay, so do it */
2700
3280af22
NIS		 2701 CvDEPTH(PL_compcv) = 1;
2702 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2703 PL_op = saveop; /* The caller may need it. */
b35b2403 2704#ifdef USE_THREADS
533c011a
NIS		 2705 MUTEX_LOCK(&PL_eval_mutex);
2706 PL_eval_owner = 0;
2707 COND_SIGNAL(&PL_eval_cond);
2708 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2709#endif /* USE_THREADS */
5dc0d613 2710
3280af22 2711 RETURNOP(PL_eval_start);
a0d0e21e
LW		 2712}
2713
a6c40364 2714STATIC PerlIO *
cea2e8a9 2715S_doopen_pmc(pTHX_ const char *name, const char *mode)
b295d113
TH		 2716{
2717 STRLEN namelen = strlen(name);
2718 PerlIO *fp;
2719
7894fbab 2720 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 2721 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH		 2722 char *pmc = SvPV_nolen(pmcsv);
2723 Stat_t pmstat;
a6c40364
GS		 2724 Stat_t pmcstat;
2725 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 2726 fp = PerlIO_open(name, mode);
a6c40364
GS		 2727 }
2728 else {
b295d113 2729 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 2730 pmstat.st_mtime < pmcstat.st_mtime)
2731 {
2732 fp = PerlIO_open(pmc, mode);
2733 }
2734 else {
2735 fp = PerlIO_open(name, mode);
2736 }
b295d113 2737 }
a6c40364
GS		 2738 SvREFCNT_dec(pmcsv);
2739 }
2740 else {
2741 fp = PerlIO_open(name, mode);
b295d113 2742 }
b295d113
TH		 2743 return fp;
2744}
2745
a0d0e21e
LW		 2746PP(pp_require)
2747{
4e35701f 2748 djSP;
c09156bb 2749 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2750 SV *sv;
2751 char *name;
6132ea6c 2752 STRLEN len;
46fc3d4c 2753 char *tryname;
2754 SV *namesv = Nullsv;
a0d0e21e
LW		 2755 SV** svp;
2756 I32 gimme = G_SCALAR;
760ac839 2757 PerlIO *tryrsfp = 0;
2d8e6c8d 2758 STRLEN n_a;
bbed91b5
KF		 2759 int filter_has_file = 0;
2760 GV *filter_child_proc = 0;
2761 SV *filter_state = 0;
2762 SV *filter_sub = 0;
a0d0e21e
LW		 2763
2764 sv = POPs;
4633a7c4 2765 if (SvNIOKp(sv) && !SvPOKp(sv)) {
097ee67d 2766 if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
cea2e8a9 2767 DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2d8e6c8d 2768 SvPV(sv,n_a),PL_patchlevel);
a0d0e21e
LW		 2769 RETPUSHYES;
2770 }
6132ea6c
GS		 2771 name = SvPV(sv, len);
2772 if (!(name && len > 0 && *name))
cea2e8a9 2773 DIE(aTHX_ "Null filename used");
4633a7c4 2774 TAINT_PROPER("require");
533c011a 2775 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS		 2776 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2777 *svp != &PL_sv_undef)
a0d0e21e
LW		 2778 RETPUSHYES;
2779
2780 /* prepare to compile file */
2781
57843af0
GS		 2782 if (PERL_FILE_IS_ABSOLUTE(name)
2783 || (*name == '.' && (name[1] == '/' ||
2784 (name[1] == '.' && name[2] == '/'))))
a0d0e21e 2785 {
46fc3d4c 2786 tryname = name;
a6c40364 2787 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
a0d0e21e
LW		 2788 }
2789 else {
3280af22 2790 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2791 I32 i;
748a9306 2792#ifdef VMS
46fc3d4c 2793 char *unixname;
2794 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2795#endif
2796 {
2797 namesv = NEWSV(806, 0);
2798 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 2799 SV *dirsv = *av_fetch(ar, i, TRUE);
2800
2801 if (SvROK(dirsv)) {
2802 int count;
2803 SV *loader = dirsv;
2804
2805 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2806 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2807 }
2808
b900a521
JH		 2809 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2810 PTR2UV(SvANY(loader)), name);
bbed91b5
KF		 2811 tryname = SvPVX(namesv);
2812 tryrsfp = 0;
2813
2814 ENTER;
2815 SAVETMPS;
2816 EXTEND(SP, 2);
2817
2818 PUSHMARK(SP);
2819 PUSHs(dirsv);
2820 PUSHs(sv);
2821 PUTBACK;
2822 count = call_sv(loader, G_ARRAY);
2823 SPAGAIN;
2824
2825 if (count > 0) {
2826 int i = 0;
2827 SV *arg;
2828
2829 SP -= count - 1;
2830 arg = SP[i++];
2831
2832 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2833 arg = SvRV(arg);
2834 }
2835
2836 if (SvTYPE(arg) == SVt_PVGV) {
2837 IO *io = GvIO((GV *)arg);
2838
2839 ++filter_has_file;
2840
2841 if (io) {
2842 tryrsfp = IoIFP(io);
2843 if (IoTYPE(io) == '|') {
2844 /* reading from a child process doesn't
2845 nest -- when returning from reading
2846 the inner module, the outer one is
2847 unreadable (closed?) I've tried to
2848 save the gv to manage the lifespan of
2849 the pipe, but this didn't help. XXX */
2850 filter_child_proc = (GV *)arg;
520c758a 2851 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 2852 }
2853 else {
2854 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2855 PerlIO_close(IoOFP(io));
2856 }
2857 IoIFP(io) = Nullfp;
2858 IoOFP(io) = Nullfp;
2859 }
2860 }
2861
2862 if (i < count) {
2863 arg = SP[i++];
2864 }
2865 }
2866
2867 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2868 filter_sub = arg;
520c758a 2869 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 2870
2871 if (i < count) {
2872 filter_state = SP[i];
520c758a 2873 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 2874 }
2875
2876 if (tryrsfp == 0) {
2877 tryrsfp = PerlIO_open("/dev/null",
2878 PERL_SCRIPT_MODE);
2879 }
2880 }
2881 }
2882
2883 PUTBACK;
2884 FREETMPS;
2885 LEAVE;
2886
2887 if (tryrsfp) {
2888 break;
2889 }
2890
2891 filter_has_file = 0;
2892 if (filter_child_proc) {
2893 SvREFCNT_dec(filter_child_proc);
2894 filter_child_proc = 0;
2895 }
2896 if (filter_state) {
2897 SvREFCNT_dec(filter_state);
2898 filter_state = 0;
2899 }
2900 if (filter_sub) {
2901 SvREFCNT_dec(filter_sub);
2902 filter_sub = 0;
2903 }
2904 }
2905 else {
2906 char *dir = SvPVx(dirsv, n_a);
46fc3d4c 2907#ifdef VMS
bbed91b5
KF		 2908 char *unixdir;
2909 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2910 continue;
2911 sv_setpv(namesv, unixdir);
2912 sv_catpv(namesv, unixname);
748a9306 2913#else
bbed91b5 2914 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 2915#endif
bbed91b5
KF		 2916 TAINT_PROPER("require");
2917 tryname = SvPVX(namesv);
2918 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2919 if (tryrsfp) {
2920 if (tryname[0] == '.' && tryname[1] == '/')
2921 tryname += 2;
2922 break;
2923 }
46fc3d4c 2924 }
a0d0e21e
LW		 2925 }
2926 }
2927 }
57843af0
GS		 2928 SAVECOPFILE(&PL_compiling);
2929 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 2930 SvREFCNT_dec(namesv);
a0d0e21e 2931 if (!tryrsfp) {
533c011a 2932 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS		 2933 char *msgstr = name;
2934 if (namesv) { /* did we lookup @INC? */
2935 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2936 SV *dirmsgsv = NEWSV(0, 0);
2937 AV *ar = GvAVn(PL_incgv);
2938 I32 i;
2939 sv_catpvn(msg, " in @INC", 8);
2940 if (instr(SvPVX(msg), ".h "))
2941 sv_catpv(msg, " (change .h to .ph maybe?)");
2942 if (instr(SvPVX(msg), ".ph "))
2943 sv_catpv(msg, " (did you run h2ph?)");
2944 sv_catpv(msg, " (@INC contains:");
2945 for (i = 0; i <= AvFILL(ar); i++) {
2946 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 2947 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 2948 sv_catsv(msg, dirmsgsv);
2949 }
2950 sv_catpvn(msg, ")", 1);
2951 SvREFCNT_dec(dirmsgsv);
2952 msgstr = SvPV_nolen(msg);
2683423c 2953 }
cea2e8a9 2954 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 2955 }
2956
2957 RETPUSHUNDEF;
2958 }
d8bfb8bd 2959 else
aba27d88 2960 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW		 2961
2962 /* Assume success here to prevent recursive requirement. */
3280af22 2963 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
ed094faf 2964 newSVpv(CopFILE(&PL_compiling), 0), 0 );
a0d0e21e
LW		 2965
2966 ENTER;
2967 SAVETMPS;
79cb57f6 2968 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 2969 SAVEGENERICSV(PL_rsfp_filters);
2970 PL_rsfp_filters = Nullav;
e50aee73 2971
3280af22 2972 PL_rsfp = tryrsfp;
a0d0e21e
LW		 2973 name = savepv(name);
2974 SAVEFREEPV(name);
b3ac6de7 2975 SAVEHINTS();
3280af22 2976 PL_hints = 0;
599cee73 2977 SAVEPPTR(PL_compiling.cop_warnings);
0453d815
PM		 2978 if (PL_dowarn & G_WARN_ALL_ON)
2979 PL_compiling.cop_warnings = WARN_ALL ;
2980 else if (PL_dowarn & G_WARN_ALL_OFF)
2981 PL_compiling.cop_warnings = WARN_NONE ;
2982 else
2983 PL_compiling.cop_warnings = WARN_STD ;
a0d0e21e 2984
bbed91b5
KF		 2985 if (filter_sub || filter_child_proc) {
2986 SV *datasv = filter_add(run_user_filter, Nullsv);
2987 IoLINES(datasv) = filter_has_file;
2988 IoFMT_GV(datasv) = (GV *)filter_child_proc;
2989 IoTOP_GV(datasv) = (GV *)filter_state;
2990 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
2991 }
2992
2993 /* switch to eval mode */
533c011a 2994 push_return(PL_op->op_next);
a0d0e21e 2995 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 2996 PUSHEVAL(cx, name, Nullgv);
a0d0e21e 2997
57843af0
GS		 2998 SAVECOPLINE(&PL_compiling);
2999 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3000
3001 PUTBACK;
0f15f207 3002#ifdef USE_THREADS
533c011a
NIS		 3003 MUTEX_LOCK(&PL_eval_mutex);
3004 if (PL_eval_owner && PL_eval_owner != thr)
3005 while (PL_eval_owner)
3006 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3007 PL_eval_owner = thr;
3008 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3009#endif /* USE_THREADS */
c277df42 3010 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW		 3011}
3012
3013PP(pp_dofile)
3014{
cea2e8a9 3015 return pp_require();
a0d0e21e
LW		 3016}
3017
3018PP(pp_entereval)
3019{
4e35701f 3020 djSP;
c09156bb 3021 register PERL_CONTEXT *cx;
a0d0e21e 3022 dPOPss;
3280af22 3023 I32 gimme = GIMME_V, was = PL_sub_generation;
fc36a67e 3024 char tmpbuf[TYPE_DIGITS(long) + 12];
3025 char *safestr;
a0d0e21e 3026 STRLEN len;
55497cff 3027 OP *ret;
a0d0e21e
LW		 3028
3029 if (!SvPV(sv,len) || !len)
3030 RETPUSHUNDEF;
748a9306 3031 TAINT_PROPER("eval");
a0d0e21e
LW		 3032
3033 ENTER;
a0d0e21e 3034 lex_start(sv);
748a9306 3035 SAVETMPS;
a0d0e21e
LW		 3036
3037 /* switch to eval mode */
3038
57843af0 3039 SAVECOPFILE(&PL_compiling);
3280af22 3040 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
57843af0
GS		 3041 CopFILE_set(&PL_compiling, tmpbuf+2);
3042 CopLINE_set(&PL_compiling, 1);
55497cff 3043 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3044 deleting the eval's FILEGV from the stash before gv_check() runs
3045 (i.e. before run-time proper). To work around the coredump that
3046 ensues, we always turn GvMULTI_on for any globals that were
3047 introduced within evals. See force_ident(). GSAR 96-10-12 */
3048 safestr = savepv(tmpbuf);
3280af22 3049 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3050 SAVEHINTS();
533c011a 3051 PL_hints = PL_op->op_targ;
e24b16f9 3052 SAVEPPTR(PL_compiling.cop_warnings);
0453d815 3053 if (!specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 3054 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3055 SAVEFREESV(PL_compiling.cop_warnings) ;
3056 }
a0d0e21e 3057
533c011a 3058 push_return(PL_op->op_next);
6b35e009 3059 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3060 PUSHEVAL(cx, 0, Nullgv);
a0d0e21e
LW		 3061
3062 /* prepare to compile string */
3063
3280af22 3064 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3065 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3066 PUTBACK;
0f15f207 3067#ifdef USE_THREADS
533c011a
NIS		 3068 MUTEX_LOCK(&PL_eval_mutex);
3069 if (PL_eval_owner && PL_eval_owner != thr)
3070 while (PL_eval_owner)
3071 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3072 PL_eval_owner = thr;
3073 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3074#endif /* USE_THREADS */
c277df42 3075 ret = doeval(gimme, NULL);
3280af22 3076 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 3077 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3078 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3079 }
1e422769 3080 return DOCATCH(ret);
a0d0e21e
LW		 3081}
3082
3083PP(pp_leaveeval)
3084{
4e35701f 3085 djSP;
a0d0e21e
LW		 3086 register SV **mark;
3087 SV **newsp;
3088 PMOP *newpm;
3089 I32 gimme;
c09156bb 3090 register PERL_CONTEXT *cx;
a0d0e21e 3091 OP *retop;
533c011a 3092 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3093 I32 optype;
3094
3095 POPBLOCK(cx,newpm);
3096 POPEVAL(cx);
3097 retop = pop_return();
3098
a1f49e72 3099 TAINT_NOT;
54310121 3100 if (gimme == G_VOID)
3101 MARK = newsp;
3102 else if (gimme == G_SCALAR) {
3103 MARK = newsp + 1;
3104 if (MARK <= SP) {
3105 if (SvFLAGS(TOPs) & SVs_TEMP)
3106 *MARK = TOPs;
3107 else
3108 *MARK = sv_mortalcopy(TOPs);
3109 }
a0d0e21e 3110 else {
54310121 3111 MEXTEND(mark,0);
3280af22 3112 *MARK = &PL_sv_undef;
a0d0e21e 3113 }
a7ec2b44 3114 SP = MARK;
a0d0e21e
LW		 3115 }
3116 else {
a1f49e72
CS		 3117 /* in case LEAVE wipes old return values */
3118 for (mark = newsp + 1; mark <= SP; mark++) {
3119 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3120 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3121 TAINT_NOT; /* Each item is independent */
3122 }
3123 }
a0d0e21e 3124 }
3280af22 3125 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3126
067f92a0
GS		 3127 if (AvFILLp(PL_comppad_name) >= 0)
3128 free_closures();
84902520 3129
4fdae800 3130#ifdef DEBUGGING
3280af22 3131 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3132#endif
3280af22 3133 CvDEPTH(PL_compcv) = 0;
f46d017c 3134 lex_end();
4fdae800 3135
1ce6579f 3136 if (optype == OP_REQUIRE &&
924508f0 3137 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3138 {
1ce6579f 3139 /* Unassume the success we assumed earlier. */
54310121 3140 char *name = cx->blk_eval.old_name;
3280af22 3141 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 3142 retop = Perl_die(aTHX_ "%s did not return a true value", name);
f46d017c
GS		 3143 /* die_where() did LEAVE, or we won't be here */
3144 }
3145 else {
3146 LEAVE;
3147 if (!(save_flags & OPf_SPECIAL))
3148 sv_setpv(ERRSV,"");
a0d0e21e 3149 }
a0d0e21e
LW		 3150
3151 RETURNOP(retop);
3152}
3153
a0d0e21e
LW		 3154PP(pp_entertry)
3155{
4e35701f 3156 djSP;
c09156bb 3157 register PERL_CONTEXT *cx;
54310121 3158 I32 gimme = GIMME_V;
a0d0e21e
LW		 3159
3160 ENTER;
3161 SAVETMPS;
3162
3163 push_return(cLOGOP->op_other->op_next);
3164 PUSHBLOCK(cx, CXt_EVAL, SP);
3165 PUSHEVAL(cx, 0, 0);
533c011a 3166 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3167
faef0170 3168 PL_in_eval = EVAL_INEVAL;
38a03e6e 3169 sv_setpv(ERRSV,"");
1e422769 3170 PUTBACK;
533c011a 3171 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 3172}
3173
3174PP(pp_leavetry)
3175{
4e35701f 3176 djSP;
a0d0e21e
LW		 3177 register SV **mark;
3178 SV **newsp;
3179 PMOP *newpm;
3180 I32 gimme;
c09156bb 3181 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3182 I32 optype;
3183
3184 POPBLOCK(cx,newpm);
3185 POPEVAL(cx);
3186 pop_return();
3187
a1f49e72 3188 TAINT_NOT;
54310121 3189 if (gimme == G_VOID)
3190 SP = newsp;
3191 else if (gimme == G_SCALAR) {
3192 MARK = newsp + 1;
3193 if (MARK <= SP) {
3194 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3195 *MARK = TOPs;
3196 else
3197 *MARK = sv_mortalcopy(TOPs);
3198 }
a0d0e21e 3199 else {
54310121 3200 MEXTEND(mark,0);
3280af22 3201 *MARK = &PL_sv_undef;
a0d0e21e
LW		 3202 }
3203 SP = MARK;
3204 }
3205 else {
a1f49e72
CS		 3206 /* in case LEAVE wipes old return values */
3207 for (mark = newsp + 1; mark <= SP; mark++) {
3208 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3209 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3210 TAINT_NOT; /* Each item is independent */
3211 }
3212 }
a0d0e21e 3213 }
3280af22 3214 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 3215
3216 LEAVE;
38a03e6e 3217 sv_setpv(ERRSV,"");
a0d0e21e
LW		 3218 RETURN;
3219}
3220
0824fdcb 3221STATIC void
cea2e8a9 3222S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 3223{
3224 STRLEN len;
3225 register char *s = SvPV_force(sv, len);
3226 register char *send = s + len;
3227 register char *base;
3228 register I32 skipspaces = 0;
3229 bool noblank;
3230 bool repeat;
3231 bool postspace = FALSE;
3232 U16 *fops;
3233 register U16 *fpc;
3234 U16 *linepc;
3235 register I32 arg;
3236 bool ischop;
3237
55497cff 3238 if (len == 0)
cea2e8a9 3239 Perl_croak(aTHX_ "Null picture in formline");
55497cff 3240
3241 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW		 3242 fpc = fops;
3243
3244 if (s < send) {
3245 linepc = fpc;
3246 *fpc++ = FF_LINEMARK;
3247 noblank = repeat = FALSE;
3248 base = s;
3249 }
3250
3251 while (s <= send) {
3252 switch (*s++) {
3253 default:
3254 skipspaces = 0;
3255 continue;
3256
3257 case '~':
3258 if (*s == '~') {
3259 repeat = TRUE;
3260 *s = ' ';
3261 }
3262 noblank = TRUE;
3263 s[-1] = ' ';
3264 /* FALL THROUGH */
3265 case ' ': case '\t':
3266 skipspaces++;
3267 continue;
3268
3269 case '\n': case 0:
3270 arg = s - base;
3271 skipspaces++;
3272 arg -= skipspaces;
3273 if (arg) {
5f05dabc 3274 if (postspace)
a0d0e21e 3275 *fpc++ = FF_SPACE;
a0d0e21e
LW		 3276 *fpc++ = FF_LITERAL;
3277 *fpc++ = arg;
3278 }
5f05dabc 3279 postspace = FALSE;
a0d0e21e
LW		 3280 if (s <= send)
3281 skipspaces--;
3282 if (skipspaces) {
3283 *fpc++ = FF_SKIP;
3284 *fpc++ = skipspaces;
3285 }
3286 skipspaces = 0;
3287 if (s <= send)
3288 *fpc++ = FF_NEWLINE;
3289 if (noblank) {
3290 *fpc++ = FF_BLANK;
3291 if (repeat)
3292 arg = fpc - linepc + 1;
3293 else
3294 arg = 0;
3295 *fpc++ = arg;
3296 }
3297 if (s < send) {
3298 linepc = fpc;
3299 *fpc++ = FF_LINEMARK;
3300 noblank = repeat = FALSE;
3301 base = s;
3302 }
3303 else
3304 s++;
3305 continue;
3306
3307 case '@':
3308 case '^':
3309 ischop = s[-1] == '^';
3310
3311 if (postspace) {
3312 *fpc++ = FF_SPACE;
3313 postspace = FALSE;
3314 }
3315 arg = (s - base) - 1;
3316 if (arg) {
3317 *fpc++ = FF_LITERAL;
3318 *fpc++ = arg;
3319 }
3320
3321 base = s - 1;
3322 *fpc++ = FF_FETCH;
3323 if (*s == '*') {
3324 s++;
3325 *fpc++ = 0;
3326 *fpc++ = FF_LINEGLOB;
3327 }
3328 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3329 arg = ischop ? 512 : 0;
3330 base = s - 1;
3331 while (*s == '#')
3332 s++;
3333 if (*s == '.') {
3334 char *f;
3335 s++;
3336 f = s;
3337 while (*s == '#')
3338 s++;
3339 arg |= 256 + (s - f);
3340 }
3341 *fpc++ = s - base; /* fieldsize for FETCH */
3342 *fpc++ = FF_DECIMAL;
3343 *fpc++ = arg;
3344 }
3345 else {
3346 I32 prespace = 0;
3347 bool ismore = FALSE;
3348
3349 if (*s == '>') {
3350 while (*++s == '>') ;
3351 prespace = FF_SPACE;
3352 }
3353 else if (*s == '|') {
3354 while (*++s == '|') ;
3355 prespace = FF_HALFSPACE;
3356 postspace = TRUE;
3357 }
3358 else {
3359 if (*s == '<')
3360 while (*++s == '<') ;
3361 postspace = TRUE;
3362 }
3363 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3364 s += 3;
3365 ismore = TRUE;
3366 }
3367 *fpc++ = s - base; /* fieldsize for FETCH */
3368
3369 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3370
3371 if (prespace)
3372 *fpc++ = prespace;
3373 *fpc++ = FF_ITEM;
3374 if (ismore)
3375 *fpc++ = FF_MORE;
3376 if (ischop)
3377 *fpc++ = FF_CHOP;
3378 }
3379 base = s;
3380 skipspaces = 0;
3381 continue;
3382 }
3383 }
3384 *fpc++ = FF_END;
3385
3386 arg = fpc - fops;
3387 { /* need to jump to the next word */
3388 int z;
3389 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3390 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3391 s = SvPVX(sv) + SvCUR(sv) + z;
3392 }
3393 Copy(fops, s, arg, U16);
3394 Safefree(fops);
55497cff 3395 sv_magic(sv, Nullsv, 'f', Nullch, 0);
a0d0e21e
LW		 3396 SvCOMPILED_on(sv);
3397}
4e35701f 3398
745d3a65
HM		 3399/*
3400 * The rest of this file was derived from source code contributed
3401 * by Tom Horsley.
3402 *
3403 * NOTE: this code was derived from Tom Horsley's qsort replacement
3404 * and should not be confused with the original code.
3405 */
3406
3407/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3408
3409 Permission granted to distribute under the same terms as perl which are
3410 (briefly):
3411
3412 This program is free software; you can redistribute it and/or modify
3413 it under the terms of either:
3414
3415 a) the GNU General Public License as published by the Free
3416 Software Foundation; either version 1, or (at your option) any
3417 later version, or
3418
3419 b) the "Artistic License" which comes with this Kit.
3420
3421 Details on the perl license can be found in the perl source code which
3422 may be located via the www.perl.com web page.
3423
3424 This is the most wonderfulest possible qsort I can come up with (and
3425 still be mostly portable) My (limited) tests indicate it consistently
3426 does about 20% fewer calls to compare than does the qsort in the Visual
3427 C++ library, other vendors may vary.
3428
3429 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3430 others I invented myself (or more likely re-invented since they seemed
3431 pretty obvious once I watched the algorithm operate for a while).
3432
3433 Most of this code was written while watching the Marlins sweep the Giants
3434 in the 1997 National League Playoffs - no Braves fans allowed to use this
3435 code (just kidding :-).
3436
3437 I realize that if I wanted to be true to the perl tradition, the only
3438 comment in this file would be something like:
3439
3440 ...they shuffled back towards the rear of the line. 'No, not at the
3441 rear!' the slave-driver shouted. 'Three files up. And stay there...
3442
3443 However, I really needed to violate that tradition just so I could keep
3444 track of what happens myself, not to mention some poor fool trying to
3445 understand this years from now :-).
3446*/
3447
3448/* ********************************************************** Configuration */
3449
3450#ifndef QSORT_ORDER_GUESS
3451#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3452#endif
3453
3454/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3455 future processing - a good max upper bound is log base 2 of memory size
3456 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3457 safely be smaller than that since the program is taking up some space and
3458 most operating systems only let you grab some subset of contiguous
3459 memory (not to mention that you are normally sorting data larger than
3460 1 byte element size :-).
3461*/
3462#ifndef QSORT_MAX_STACK
3463#define QSORT_MAX_STACK 32
3464#endif
3465
3466/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3467 Anything bigger and we use qsort. If you make this too small, the qsort
3468 will probably break (or become less efficient), because it doesn't expect
3469 the middle element of a partition to be the same as the right or left -
3470 you have been warned).
3471*/
3472#ifndef QSORT_BREAK_EVEN
3473#define QSORT_BREAK_EVEN 6
3474#endif
3475
3476/* ************************************************************* Data Types */
3477
3478/* hold left and right index values of a partition waiting to be sorted (the
3479 partition includes both left and right - right is NOT one past the end or
3480 anything like that).
3481*/
3482struct partition_stack_entry {
3483 int left;
3484 int right;
3485#ifdef QSORT_ORDER_GUESS
3486 int qsort_break_even;
3487#endif
3488};
3489
3490/* ******************************************************* Shorthand Macros */
3491
3492/* Note that these macros will be used from inside the qsort function where
3493 we happen to know that the variable 'elt_size' contains the size of an
3494 array element and the variable 'temp' points to enough space to hold a
3495 temp element and the variable 'array' points to the array being sorted
3496 and 'compare' is the pointer to the compare routine.
3497
3498 Also note that there are very many highly architecture specific ways
3499 these might be sped up, but this is simply the most generally portable
3500 code I could think of.
3501*/
161b471a 3502
745d3a65
HM		 3503/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3504*/
565764a8 3505#define qsort_cmp(elt1, elt2) \
51371543 3506 ((*compare)(aTHXo_ array[elt1], array[elt2]))
745d3a65
HM		 3507
3508#ifdef QSORT_ORDER_GUESS
3509#define QSORT_NOTICE_SWAP swapped++;
3510#else
3511#define QSORT_NOTICE_SWAP
3512#endif
3513
3514/* swaps contents of array elements elt1, elt2.
3515*/
3516#define qsort_swap(elt1, elt2) \
3517 STMT_START { \
3518 QSORT_NOTICE_SWAP \
3519 temp = array[elt1]; \
3520 array[elt1] = array[elt2]; \
3521 array[elt2] = temp; \
3522 } STMT_END
3523
3524/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3525 elt3 and elt3 gets elt1.
3526*/
3527#define qsort_rotate(elt1, elt2, elt3) \
3528 STMT_START { \
3529 QSORT_NOTICE_SWAP \
3530 temp = array[elt1]; \
3531 array[elt1] = array[elt2]; \
3532 array[elt2] = array[elt3]; \
3533 array[elt3] = temp; \
3534 } STMT_END
3535
3536/* ************************************************************ Debug stuff */
3537
3538#ifdef QSORT_DEBUG
3539
3540static void
3541break_here()
3542{
3543 return; /* good place to set a breakpoint */
3544}
3545
3546#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3547
3548static void
3549doqsort_all_asserts(
3550 void * array,
3551 size_t num_elts,
3552 size_t elt_size,
3553 int (*compare)(const void * elt1, const void * elt2),
3554 int pc_left, int pc_right, int u_left, int u_right)
3555{
3556 int i;
3557
3558 qsort_assert(pc_left <= pc_right);
3559 qsort_assert(u_right < pc_left);
3560 qsort_assert(pc_right < u_left);
3561 for (i = u_right + 1; i < pc_left; ++i) {
3562 qsort_assert(qsort_cmp(i, pc_left) < 0);
3563 }
3564 for (i = pc_left; i < pc_right; ++i) {
3565 qsort_assert(qsort_cmp(i, pc_right) == 0);
3566 }
3567 for (i = pc_right + 1; i < u_left; ++i) {
3568 qsort_assert(qsort_cmp(pc_right, i) < 0);
3569 }
3570}
3571
3572#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3573 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3574 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3575
3576#else
3577
3578#define qsort_assert(t) ((void)0)
3579
3580#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3581
3582#endif
3583
3584/* ****************************************************************** qsort */
3585
6cc33c6d 3586STATIC void
cea2e8a9 3587S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
745d3a65
HM		 3588{
3589 register SV * temp;
3590
3591 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3592 int next_stack_entry = 0;
3593
3594 int part_left;
3595 int part_right;
3596#ifdef QSORT_ORDER_GUESS
3597 int qsort_break_even;
3598 int swapped;
3599#endif
161b471a 3600
745d3a65
HM		 3601 /* Make sure we actually have work to do.
3602 */
3603 if (num_elts <= 1) {
3604 return;
3605 }
3606
3607 /* Setup the initial partition definition and fall into the sorting loop
3608 */
3609 part_left = 0;
3610 part_right = (int)(num_elts - 1);
3611#ifdef QSORT_ORDER_GUESS
3612 qsort_break_even = QSORT_BREAK_EVEN;
3613#else
3614#define qsort_break_even QSORT_BREAK_EVEN
3615#endif
3616 for ( ; ; ) {
3617 if ((part_right - part_left) >= qsort_break_even) {
3618 /* OK, this is gonna get hairy, so lets try to document all the
3619 concepts and abbreviations and variables and what they keep
3620 track of:
3621
3622 pc: pivot chunk - the set of array elements we accumulate in the
3623 middle of the partition, all equal in value to the original
3624 pivot element selected. The pc is defined by:
3625
3626 pc_left - the leftmost array index of the pc
3627 pc_right - the rightmost array index of the pc
3628
3629 we start with pc_left == pc_right and only one element
3630 in the pivot chunk (but it can grow during the scan).
3631
3632 u: uncompared elements - the set of elements in the partition
3633 we have not yet compared to the pivot value. There are two
3634 uncompared sets during the scan - one to the left of the pc
3635 and one to the right.
3636
3637 u_right - the rightmost index of the left side's uncompared set
3638 u_left - the leftmost index of the right side's uncompared set
3639
3640 The leftmost index of the left sides's uncompared set
3641 doesn't need its own variable because it is always defined
3642 by the leftmost edge of the whole partition (part_left). The
3643 same goes for the rightmost edge of the right partition
3644 (part_right).
3645
3646 We know there are no uncompared elements on the left once we
3647 get u_right < part_left and no uncompared elements on the
3648 right once u_left > part_right. When both these conditions
3649 are met, we have completed the scan of the partition.
3650
3651 Any elements which are between the pivot chunk and the
3652 uncompared elements should be less than the pivot value on
3653 the left side and greater than the pivot value on the right
3654 side (in fact, the goal of the whole algorithm is to arrange
3655 for that to be true and make the groups of less-than and
3656 greater-then elements into new partitions to sort again).
3657
3658 As you marvel at the complexity of the code and wonder why it
3659 has to be so confusing. Consider some of the things this level
3660 of confusion brings:
3661
3662 Once I do a compare, I squeeze every ounce of juice out of it. I
3663 never