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