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