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