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