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