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