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