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