This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
test case for change#3470
[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 64 switch (cxstack[cxix].blk_gimme) {
65 case G_ARRAY:
a0d0e21e 66 RETPUSHYES;
54310121 67 case G_SCALAR:
a0d0e21e 68 RETPUSHNO;
54310121 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 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 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 244 }
245}
246
247void
d9f97599 248rxres_restore(void **rsp, REGEXP *rx)
c90c0ff4 249{
250 UV *p = (UV*)*rsp;
251 U32 i;
252
d9f97599
GS		 253 Safefree(rx->subbase);
254 rx->subbase = (char*)(*p);
c90c0ff4 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 264 }
265}
266
267void
8ac85365 268rxres_free(void **rsp)
c90c0ff4 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
KM		 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 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 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 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 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 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 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 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 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 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 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 1521 gimme = (I32)cx->blk_gimme;
1522 if (gimme == G_VOID)
3280af22 1523 PUSHs(&PL_sv_undef);
54310121 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 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 1741 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1742
a1f49e72 1743 TAINT_NOT;
54310121 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 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 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 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 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 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 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 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 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 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 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 1916 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1917 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1918 TAINT_NOT; /* Each item is independent */
1919 }
f86702cc 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 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 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 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 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 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 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 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 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 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 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 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 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 2758 if (cv) {
2759 dSP;
924508f0 2760 PUSHMARK(SP);
3280af22 2761 XPUSHs((SV*)PL_compiling.cop_filegv);
55497cff 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 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 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 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 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 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 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) {
ec889f3a
GS		 2902 char *msgstr = name;
2903 if (namesv) { /* did we lookup @INC? */
2904 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2905 SV *dirmsgsv = NEWSV(0, 0);
2906 AV *ar = GvAVn(PL_incgv);
2907 I32 i;
2908 sv_catpvn(msg, " in @INC", 8);
2909 if (instr(SvPVX(msg), ".h "))
2910 sv_catpv(msg, " (change .h to .ph maybe?)");
2911 if (instr(SvPVX(msg), ".ph "))
2912 sv_catpv(msg, " (did you run h2ph?)");
2913 sv_catpv(msg, " (@INC contains:");
2914 for (i = 0; i <= AvFILL(ar); i++) {
2915 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2916 sv_setpvf(dirmsgsv, " %s", dir);
2917 sv_catsv(msg, dirmsgsv);
2918 }
2919 sv_catpvn(msg, ")", 1);
2920 SvREFCNT_dec(dirmsgsv);
2921 msgstr = SvPV_nolen(msg);
2683423c 2922 }
ec889f3a 2923 DIE("Can't locate %s", msgstr);
a0d0e21e
LW		 2924 }
2925
2926 RETPUSHUNDEF;
2927 }
d8bfb8bd 2928 else
aba27d88 2929 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW		 2930
2931 /* Assume success here to prevent recursive requirement. */
3280af22
NIS		 2932 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2933 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
a0d0e21e
LW		 2934
2935 ENTER;
2936 SAVETMPS;
79cb57f6 2937 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 2938 SAVEGENERICSV(PL_rsfp_filters);
2939 PL_rsfp_filters = Nullav;
e50aee73 2940
3280af22 2941 PL_rsfp = tryrsfp;
a0d0e21e
LW		 2942 name = savepv(name);
2943 SAVEFREEPV(name);
b3ac6de7 2944 SAVEHINTS();
3280af22 2945 PL_hints = 0;
599cee73
PM		 2946 SAVEPPTR(PL_compiling.cop_warnings);
2947 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2948 : WARN_NONE);
a0d0e21e
LW		 2949
2950 /* switch to eval mode */
2951
533c011a 2952 push_return(PL_op->op_next);
a0d0e21e 2953 PUSHBLOCK(cx, CXt_EVAL, SP);
6b88bc9c 2954 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
a0d0e21e 2955
63eb823a 2956 SAVEI16(PL_compiling.cop_line);
3280af22 2957 PL_compiling.cop_line = 0;
a0d0e21e
LW		 2958
2959 PUTBACK;
0f15f207 2960#ifdef USE_THREADS
533c011a
NIS		 2961 MUTEX_LOCK(&PL_eval_mutex);
2962 if (PL_eval_owner && PL_eval_owner != thr)
2963 while (PL_eval_owner)
2964 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2965 PL_eval_owner = thr;
2966 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 2967#endif /* USE_THREADS */
c277df42 2968 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW		 2969}
2970
2971PP(pp_dofile)
2972{
2973 return pp_require(ARGS);
2974}
2975
2976PP(pp_entereval)
2977{
4e35701f 2978 djSP;
c09156bb 2979 register PERL_CONTEXT *cx;
a0d0e21e 2980 dPOPss;
3280af22 2981 I32 gimme = GIMME_V, was = PL_sub_generation;
fc36a67e 2982 char tmpbuf[TYPE_DIGITS(long) + 12];
2983 char *safestr;
a0d0e21e 2984 STRLEN len;
55497cff 2985 OP *ret;
a0d0e21e
LW		 2986
2987 if (!SvPV(sv,len) || !len)
2988 RETPUSHUNDEF;
748a9306 2989 TAINT_PROPER("eval");
a0d0e21e
LW		 2990
2991 ENTER;
a0d0e21e 2992 lex_start(sv);
748a9306 2993 SAVETMPS;
a0d0e21e
LW		 2994
2995 /* switch to eval mode */
2996
3280af22
NIS		 2997 SAVESPTR(PL_compiling.cop_filegv);
2998 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2999 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
3000 PL_compiling.cop_line = 1;
55497cff 3001 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3002 deleting the eval's FILEGV from the stash before gv_check() runs
3003 (i.e. before run-time proper). To work around the coredump that
3004 ensues, we always turn GvMULTI_on for any globals that were
3005 introduced within evals. See force_ident(). GSAR 96-10-12 */
3006 safestr = savepv(tmpbuf);
3280af22 3007 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3008 SAVEHINTS();
533c011a 3009 PL_hints = PL_op->op_targ;
e24b16f9 3010 SAVEPPTR(PL_compiling.cop_warnings);
599cee73
PM		 3011 if (PL_compiling.cop_warnings != WARN_ALL
3012 && PL_compiling.cop_warnings != WARN_NONE){
3013 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3014 SAVEFREESV(PL_compiling.cop_warnings) ;
3015 }
a0d0e21e 3016
533c011a 3017 push_return(PL_op->op_next);
6b35e009 3018 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
6b88bc9c 3019 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
a0d0e21e
LW		 3020
3021 /* prepare to compile string */
3022
3280af22
NIS		 3023 if (PERLDB_LINE && PL_curstash != PL_debstash)
3024 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
a0d0e21e 3025 PUTBACK;
0f15f207 3026#ifdef USE_THREADS
533c011a
NIS		 3027 MUTEX_LOCK(&PL_eval_mutex);
3028 if (PL_eval_owner && PL_eval_owner != thr)
3029 while (PL_eval_owner)
3030 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3031 PL_eval_owner = thr;
3032 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3033#endif /* USE_THREADS */
c277df42 3034 ret = doeval(gimme, NULL);
3280af22 3035 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 3036 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3037 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3038 }
1e422769 3039 return DOCATCH(ret);
a0d0e21e
LW		 3040}
3041
3042PP(pp_leaveeval)
3043{
4e35701f 3044 djSP;
a0d0e21e
LW		 3045 register SV **mark;
3046 SV **newsp;
3047 PMOP *newpm;
3048 I32 gimme;
c09156bb 3049 register PERL_CONTEXT *cx;
a0d0e21e 3050 OP *retop;
533c011a 3051 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3052 I32 optype;
3053
3054 POPBLOCK(cx,newpm);
3055 POPEVAL(cx);
3056 retop = pop_return();
3057
a1f49e72 3058 TAINT_NOT;
54310121 3059 if (gimme == G_VOID)
3060 MARK = newsp;
3061 else if (gimme == G_SCALAR) {
3062 MARK = newsp + 1;
3063 if (MARK <= SP) {
3064 if (SvFLAGS(TOPs) & SVs_TEMP)
3065 *MARK = TOPs;
3066 else
3067 *MARK = sv_mortalcopy(TOPs);
3068 }
a0d0e21e 3069 else {
54310121 3070 MEXTEND(mark,0);
3280af22 3071 *MARK = &PL_sv_undef;
a0d0e21e 3072 }
a0d0e21e
LW		 3073 }
3074 else {
a1f49e72
CS		 3075 /* in case LEAVE wipes old return values */
3076 for (mark = newsp + 1; mark <= SP; mark++) {
3077 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3078 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3079 TAINT_NOT; /* Each item is independent */
3080 }
3081 }
a0d0e21e 3082 }
3280af22 3083 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3084
84902520
TB		 3085 /*
3086 * Closures mentioned at top level of eval cannot be referenced
3087 * again, and their presence indirectly causes a memory leak.
3088 * (Note that the fact that compcv and friends are still set here
3089 * is, AFAIK, an accident.) --Chip
3090 */
3280af22
NIS		 3091 if (AvFILLp(PL_comppad_name) >= 0) {
3092 SV **svp = AvARRAY(PL_comppad_name);
84902520 3093 I32 ix;
3280af22 3094 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
84902520 3095 SV *sv = svp[ix];
3280af22 3096 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
84902520 3097 SvREFCNT_dec(sv);
3280af22 3098 svp[ix] = &PL_sv_undef;
84902520 3099
3280af22 3100 sv = PL_curpad[ix];
84902520
TB		 3101 if (CvCLONE(sv)) {
3102 SvREFCNT_dec(CvOUTSIDE(sv));
3103 CvOUTSIDE(sv) = Nullcv;
3104 }
3105 else {
3106 SvREFCNT_dec(sv);
3107 sv = NEWSV(0,0);
3108 SvPADTMP_on(sv);
3280af22 3109 PL_curpad[ix] = sv;
84902520
TB		 3110 }
3111 }
3112 }
3113 }
3114
4fdae800 3115#ifdef DEBUGGING
3280af22 3116 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3117#endif
3280af22 3118 CvDEPTH(PL_compcv) = 0;
f46d017c 3119 lex_end();
4fdae800 3120
1ce6579f 3121 if (optype == OP_REQUIRE &&
924508f0 3122 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3123 {
1ce6579f 3124 /* Unassume the success we assumed earlier. */
54310121 3125 char *name = cx->blk_eval.old_name;
3280af22 3126 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1ce6579f 3127 retop = die("%s did not return a true value", name);
f46d017c
GS		 3128 /* die_where() did LEAVE, or we won't be here */
3129 }
3130 else {
3131 LEAVE;
3132 if (!(save_flags & OPf_SPECIAL))
3133 sv_setpv(ERRSV,"");
a0d0e21e 3134 }
a0d0e21e
LW		 3135
3136 RETURNOP(retop);
3137}
3138
a0d0e21e
LW		 3139PP(pp_entertry)
3140{
4e35701f 3141 djSP;
c09156bb 3142 register PERL_CONTEXT *cx;
54310121 3143 I32 gimme = GIMME_V;
a0d0e21e
LW		 3144
3145 ENTER;
3146 SAVETMPS;
3147
3148 push_return(cLOGOP->op_other->op_next);
3149 PUSHBLOCK(cx, CXt_EVAL, SP);
3150 PUSHEVAL(cx, 0, 0);
533c011a 3151 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3152
faef0170 3153 PL_in_eval = EVAL_INEVAL;
38a03e6e 3154 sv_setpv(ERRSV,"");
1e422769 3155 PUTBACK;
533c011a 3156 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 3157}
3158
3159PP(pp_leavetry)
3160{
4e35701f 3161 djSP;
a0d0e21e
LW		 3162 register SV **mark;
3163 SV **newsp;
3164 PMOP *newpm;
3165 I32 gimme;
c09156bb 3166 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3167 I32 optype;
3168
3169 POPBLOCK(cx,newpm);
3170 POPEVAL(cx);
3171 pop_return();
3172
a1f49e72 3173 TAINT_NOT;
54310121 3174 if (gimme == G_VOID)
3175 SP = newsp;
3176 else if (gimme == G_SCALAR) {
3177 MARK = newsp + 1;
3178 if (MARK <= SP) {
3179 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3180 *MARK = TOPs;
3181 else
3182 *MARK = sv_mortalcopy(TOPs);
3183 }
a0d0e21e 3184 else {
54310121 3185 MEXTEND(mark,0);
3280af22 3186 *MARK = &PL_sv_undef;
a0d0e21e
LW		 3187 }
3188 SP = MARK;
3189 }
3190 else {
a1f49e72
CS		 3191 /* in case LEAVE wipes old return values */
3192 for (mark = newsp + 1; mark <= SP; mark++) {
3193 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3194 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3195 TAINT_NOT; /* Each item is independent */
3196 }
3197 }
a0d0e21e 3198 }
3280af22 3199 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 3200
3201 LEAVE;
38a03e6e 3202 sv_setpv(ERRSV,"");
a0d0e21e
LW		 3203 RETURN;
3204}
3205
0824fdcb 3206STATIC void
8ac85365 3207doparseform(SV *sv)
a0d0e21e
LW		 3208{
3209 STRLEN len;
3210 register char *s = SvPV_force(sv, len);
3211 register char *send = s + len;
3212 register char *base;
3213 register I32 skipspaces = 0;
3214 bool noblank;
3215 bool repeat;
3216 bool postspace = FALSE;
3217 U16 *fops;
3218 register U16 *fpc;
3219 U16 *linepc;
3220 register I32 arg;
3221 bool ischop;
3222
55497cff 3223 if (len == 0)
bbce6d69 3224 croak("Null picture in formline");
55497cff 3225
3226 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW		 3227 fpc = fops;
3228
3229 if (s < send) {
3230 linepc = fpc;
3231 *fpc++ = FF_LINEMARK;
3232 noblank = repeat = FALSE;
3233 base = s;
3234 }
3235
3236 while (s <= send) {
3237 switch (*s++) {
3238 default:
3239 skipspaces = 0;
3240 continue;
3241
3242 case '~':
3243 if (*s == '~') {
3244 repeat = TRUE;
3245 *s = ' ';
3246 }
3247 noblank = TRUE;
3248 s[-1] = ' ';
3249 /* FALL THROUGH */
3250 case ' ': case '\t':
3251 skipspaces++;
3252 continue;
3253
3254 case '\n': case 0:
3255 arg = s - base;
3256 skipspaces++;
3257 arg -= skipspaces;
3258 if (arg) {
5f05dabc 3259 if (postspace)
a0d0e21e 3260 *fpc++ = FF_SPACE;
a0d0e21e
LW		 3261 *fpc++ = FF_LITERAL;
3262 *fpc++ = arg;
3263 }
5f05dabc 3264 postspace = FALSE;
a0d0e21e
LW		 3265 if (s <= send)
3266 skipspaces--;
3267 if (skipspaces) {
3268 *fpc++ = FF_SKIP;
3269 *fpc++ = skipspaces;
3270 }
3271 skipspaces = 0;
3272 if (s <= send)
3273 *fpc++ = FF_NEWLINE;
3274 if (noblank) {
3275 *fpc++ = FF_BLANK;
3276 if (repeat)
3277 arg = fpc - linepc + 1;
3278 else
3279 arg = 0;
3280 *fpc++ = arg;
3281 }
3282 if (s < send) {
3283 linepc = fpc;
3284 *fpc++ = FF_LINEMARK;
3285 noblank = repeat = FALSE;
3286 base = s;
3287 }
3288 else
3289 s++;
3290 continue;
3291
3292 case '@':
3293 case '^':
3294 ischop = s[-1] == '^';
3295
3296 if (postspace) {
3297 *fpc++ = FF_SPACE;
3298 postspace = FALSE;
3299 }
3300 arg = (s - base) - 1;
3301 if (arg) {
3302 *fpc++ = FF_LITERAL;
3303 *fpc++ = arg;
3304 }
3305
3306 base = s - 1;
3307 *fpc++ = FF_FETCH;
3308 if (*s == '*') {
3309 s++;
3310 *fpc++ = 0;
3311 *fpc++ = FF_LINEGLOB;
3312 }
3313 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3314 arg = ischop ? 512 : 0;
3315 base = s - 1;
3316 while (*s == '#')
3317 s++;
3318 if (*s == '.') {
3319 char *f;
3320 s++;
3321 f = s;
3322 while (*s == '#')
3323 s++;
3324 arg |= 256 + (s - f);
3325 }
3326 *fpc++ = s - base; /* fieldsize for FETCH */
3327 *fpc++ = FF_DECIMAL;
3328 *fpc++ = arg;
3329 }
3330 else {
3331 I32 prespace = 0;
3332 bool ismore = FALSE;
3333
3334 if (*s == '>') {
3335 while (*++s == '>') ;
3336 prespace = FF_SPACE;
3337 }
3338 else if (*s == '|') {
3339 while (*++s == '|') ;
3340 prespace = FF_HALFSPACE;
3341 postspace = TRUE;
3342 }
3343 else {
3344 if (*s == '<')
3345 while (*++s == '<') ;
3346 postspace = TRUE;
3347 }
3348 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3349 s += 3;
3350 ismore = TRUE;
3351 }
3352 *fpc++ = s - base; /* fieldsize for FETCH */
3353
3354 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3355
3356 if (prespace)
3357 *fpc++ = prespace;
3358 *fpc++ = FF_ITEM;
3359 if (ismore)
3360 *fpc++ = FF_MORE;
3361 if (ischop)
3362 *fpc++ = FF_CHOP;
3363 }
3364 base = s;
3365 skipspaces = 0;
3366 continue;
3367 }
3368 }
3369 *fpc++ = FF_END;
3370
3371 arg = fpc - fops;
3372 { /* need to jump to the next word */
3373 int z;
3374 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3375 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3376 s = SvPVX(sv) + SvCUR(sv) + z;
3377 }
3378 Copy(fops, s, arg, U16);
3379 Safefree(fops);
55497cff 3380 sv_magic(sv, Nullsv, 'f', Nullch, 0);
a0d0e21e
LW		 3381 SvCOMPILED_on(sv);
3382}
4e35701f 3383
745d3a65
HM		 3384/*
3385 * The rest of this file was derived from source code contributed
3386 * by Tom Horsley.
3387 *
3388 * NOTE: this code was derived from Tom Horsley's qsort replacement
3389 * and should not be confused with the original code.
3390 */
3391
3392/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3393
3394 Permission granted to distribute under the same terms as perl which are
3395 (briefly):
3396
3397 This program is free software; you can redistribute it and/or modify
3398 it under the terms of either:
3399
3400 a) the GNU General Public License as published by the Free
3401 Software Foundation; either version 1, or (at your option) any
3402 later version, or
3403
3404 b) the "Artistic License" which comes with this Kit.
3405
3406 Details on the perl license can be found in the perl source code which
3407 may be located via the www.perl.com web page.
3408
3409 This is the most wonderfulest possible qsort I can come up with (and
3410 still be mostly portable) My (limited) tests indicate it consistently
3411 does about 20% fewer calls to compare than does the qsort in the Visual
3412 C++ library, other vendors may vary.
3413
3414 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3415 others I invented myself (or more likely re-invented since they seemed
3416 pretty obvious once I watched the algorithm operate for a while).
3417
3418 Most of this code was written while watching the Marlins sweep the Giants
3419 in the 1997 National League Playoffs - no Braves fans allowed to use this
3420 code (just kidding :-).
3421
3422 I realize that if I wanted to be true to the perl tradition, the only
3423 comment in this file would be something like:
3424
3425 ...they shuffled back towards the rear of the line. 'No, not at the
3426 rear!' the slave-driver shouted. 'Three files up. And stay there...
3427
3428 However, I really needed to violate that tradition just so I could keep
3429 track of what happens myself, not to mention some poor fool trying to
3430 understand this years from now :-).
3431*/
3432
3433/* ********************************************************** Configuration */
3434
3435#ifndef QSORT_ORDER_GUESS
3436#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3437#endif
3438
3439/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3440 future processing - a good max upper bound is log base 2 of memory size
3441 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3442 safely be smaller than that since the program is taking up some space and
3443 most operating systems only let you grab some subset of contiguous
3444 memory (not to mention that you are normally sorting data larger than
3445 1 byte element size :-).
3446*/
3447#ifndef QSORT_MAX_STACK
3448#define QSORT_MAX_STACK 32
3449#endif
3450
3451/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3452 Anything bigger and we use qsort. If you make this too small, the qsort
3453 will probably break (or become less efficient), because it doesn't expect
3454 the middle element of a partition to be the same as the right or left -
3455 you have been warned).
3456*/
3457#ifndef QSORT_BREAK_EVEN
3458#define QSORT_BREAK_EVEN 6
3459#endif
3460
3461/* ************************************************************* Data Types */
3462
3463/* hold left and right index values of a partition waiting to be sorted (the
3464 partition includes both left and right - right is NOT one past the end or
3465 anything like that).
3466*/
3467struct partition_stack_entry {
3468 int left;
3469 int right;
3470#ifdef QSORT_ORDER_GUESS
3471 int qsort_break_even;
3472#endif
3473};
3474
3475/* ******************************************************* Shorthand Macros */
3476
3477/* Note that these macros will be used from inside the qsort function where
3478 we happen to know that the variable 'elt_size' contains the size of an
3479 array element and the variable 'temp' points to enough space to hold a
3480 temp element and the variable 'array' points to the array being sorted
3481 and 'compare' is the pointer to the compare routine.
3482
3483 Also note that there are very many highly architecture specific ways
3484 these might be sped up, but this is simply the most generally portable
3485 code I could think of.
3486*/
161b471a 3487
745d3a65
HM		 3488/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3489*/
565764a8
DL		 3490#ifdef PERL_OBJECT
3491#define qsort_cmp(elt1, elt2) \
3492 ((this->*compare)(array[elt1], array[elt2]))
3493#else
745d3a65
HM		 3494#define qsort_cmp(elt1, elt2) \
3495 ((*compare)(array[elt1], array[elt2]))
565764a8 3496#endif
745d3a65
HM		 3497
3498#ifdef QSORT_ORDER_GUESS
3499#define QSORT_NOTICE_SWAP swapped++;
3500#else
3501#define QSORT_NOTICE_SWAP
3502#endif
3503
3504/* swaps contents of array elements elt1, elt2.
3505*/
3506#define qsort_swap(elt1, elt2) \
3507 STMT_START { \
3508 QSORT_NOTICE_SWAP \
3509 temp = array[elt1]; \
3510 array[elt1] = array[elt2]; \
3511 array[elt2] = temp; \
3512 } STMT_END
3513
3514/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3515 elt3 and elt3 gets elt1.
3516*/
3517#define qsort_rotate(elt1, elt2, elt3) \
3518 STMT_START { \
3519 QSORT_NOTICE_SWAP \
3520 temp = array[elt1]; \
3521 array[elt1] = array[elt2]; \
3522 array[elt2] = array[elt3]; \
3523 array[elt3] = temp; \
3524 } STMT_END
3525
3526/* ************************************************************ Debug stuff */
3527
3528#ifdef QSORT_DEBUG
3529
3530static void
3531break_here()
3532{
3533 return; /* good place to set a breakpoint */
3534}
3535
3536#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3537
3538static void
3539doqsort_all_asserts(
3540 void * array,
3541 size_t num_elts,
3542 size_t elt_size,
3543 int (*compare)(const void * elt1, const void * elt2),
3544 int pc_left, int pc_right, int u_left, int u_right)
3545{
3546 int i;
3547
3548 qsort_assert(pc_left <= pc_right);
3549 qsort_assert(u_right < pc_left);
3550 qsort_assert(pc_right < u_left);
3551 for (i = u_right + 1; i < pc_left; ++i) {
3552 qsort_assert(qsort_cmp(i, pc_left) < 0);
3553 }
3554 for (i = pc_left; i < pc_right; ++i) {
3555 qsort_assert(qsort_cmp(i, pc_right) == 0);
3556 }
3557 for (i = pc_right + 1; i < u_left; ++i) {
3558 qsort_assert(qsort_cmp(pc_right, i) < 0);
3559 }
3560}
3561
3562#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3563 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3564 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3565
3566#else
3567
3568#define qsort_assert(t) ((void)0)
3569
3570#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3571
3572#endif
3573
3574/* ****************************************************************** qsort */
3575
6cc33c6d 3576STATIC void
565764a8
DL		 3577#ifdef PERL_OBJECT
3578qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3579#else
745d3a65
HM		 3580qsortsv(
3581 SV ** array,
3582 size_t num_elts,
3583 I32 (*compare)(SV *a, SV *b))
565764a8 3584#endif
745d3a65
HM		 3585{
3586 register SV * temp;
3587
3588 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3589 int next_stack_entry = 0;
3590
3591 int part_left;
3592 int part_right;
3593#ifdef QSORT_ORDER_GUESS
3594 int qsort_break_even;
3595 int swapped;
3596#endif
161b471a 3597
745d3a65
HM		 3598 /* Make sure we actually have work to do.
3599 */
3600 if (num_elts <= 1) {
3601 return;
3602 }
3603
3604 /* Setup the initial partition definition and fall into the sorting loop
3605 */
3606 part_left = 0;
3607 part_right = (int)(num_elts - 1);
3608#ifdef QSORT_ORDER_GUESS
3609 qsort_break_even = QSORT_BREAK_EVEN;
3610#else
3611#define qsort_break_even QSORT_BREAK_EVEN
3612#endif
3613 for ( ; ; ) {
3614 if ((part_right - part_left) >= qsort_break_even) {
3615 /* OK, this is gonna get hairy, so lets try to document all the
3616 concepts and abbreviations and variables and what they keep
3617 track of:
3618
3619 pc: pivot chunk - the set of array elements we accumulate in the
3620 middle of the partition, all equal in value to the original
3621 pivot element selected. The pc is defined by:
3622
3623 pc_left - the leftmost array index of the pc
3624 pc_right - the rightmost array index of the pc
3625
3626 we start with pc_left == pc_right and only one element
3627 in the pivot chunk (but it can grow during the scan).
3628
3629 u: uncompared elements - the set of elements in the partition
3630 we have not yet compared to the pivot value. There are two
3631 uncompared sets during the scan - one to the left of the pc
3632 and one to the right.
3633
3634 u_right - the rightmost index of the left side's uncompared set
3635 u_left - the leftmost index of the right side's uncompared set
3636
3637 The leftmost index of the left sides's uncompared set
3638 doesn't need its own variable because it is always defined
3639 by the leftmost edge of the whole partition (part_left). The
3640 same goes for the rightmost edge of the right partition
3641 (part_right).
3642
3643 We know there are no uncompared elements on the left once we
3644 get u_right < part_left and no uncompared elements on the
3645 right once u_left > part_right. When both these conditions
3646 are met, we have completed the scan of the partition.
3647
3648 Any elements which are between the pivot chunk and the
3649 uncompared elements should be less than the pivot value on
3650 the left side and greater than the pivot value on the right
3651 side (in fact, the goal of the whole algorithm is to arrange
3652 for that to be true and make the groups of less-than and
3653 greater-then elements into new partitions to sort again).
3654
3655 As you marvel at the complexity of the code and wonder why it
3656 has to be so confusing. Consider some of the things this level
3657 of confusion brings:
3658
3659 Once I do a compare, I squeeze every ounce of juice out of it. I
3660 never do compare calls I don't have to do, and I certainly never
3661 do redundant calls.
3662
3663 I also never swap any elements unless I can prove there is a
3664 good reason. Many sort algorithms will swap a known value with
3665 an uncompared value just to get things in the right place (or
3666 avoid complexity :-), but that uncompared value, once it gets
3667 compared, may then have to be swapped again. A lot of the
3668 complexity of this code is due to the fact that it never swaps
3669 anything except compared values, and it only swaps them when the
3670 compare shows they are out of position.
3671 */
3672 int pc_left, pc_right;
3673 int u_right, u_left;
3674
3675 int s;
3676
3677 pc_left = ((part_left + part_right) / 2);
3678 pc_right = pc_left;
3679 u_right = pc_left - 1;
3680 u_left = pc_right + 1;
3681
3682 /* Qsort works best when the pivot value is also the median value
3683 in the partition (unfortunately you can't find the median value
3684 without first sorting :-), so to give the algorithm a helping
3685 hand, we pick 3 elements and sort them and use the median value
3686 of that tiny set as the pivot value.
3687
3688 Some versions of qsort like to use the left middle and right as
3689 the 3 elements to sort so they can insure the ends of the
3690 partition will contain values which will stop the scan in the
3691 compare loop, but when you have to call an arbitrarily complex
3692 routine to do a compare, its really better to just keep track of
3693 array index values to know when you hit the edge of the
3694 partition and avoid the extra compare. An even better reason to
3695 avoid using a compare call is the fact that you can drop off the
3696 edge of the array if someone foolishly provides you with an
3697 unstable compare function that doesn't always provide consistent
3698 results.
3699
3700 So, since it is simpler for us to compare the three adjacent
3701 elements in the middle of the partition, those are the ones we
3702 pick here (conveniently pointed at by u_right, pc_left, and
3703 u_left). The values of the left, center, and right elements
3704 are refered to as l c and r in the following comments.
3705 */
3706
3707#ifdef QSORT_ORDER_GUESS
3708 swapped = 0;
3709#endif
3710 s = qsort_cmp(u_right, pc_left);
3711 if (s < 0) {
3712 /* l < c */
3713 s = qsort_cmp(pc_left, u_left);
3714 /* if l < c, c < r - already in order - nothing to do */
3715 if (s == 0) {
3716 /* l < c, c == r - already in order, pc grows */
3717 ++pc_right;
3718 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3719 } else if (s > 0) {
3720 /* l < c, c > r - need to know more */
3721 s = qsort_cmp(u_right, u_left);
3722 if (s < 0) {
3723 /* l < c, c > r, l < r - swap c & r to get ordered */
3724 qsort_swap(pc_left, u_left);
3725 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3726 } else if (s == 0) {
3727 /* l < c, c > r, l == r - swap c&r, grow pc */
3728 qsort_swap(pc_left, u_left);
3729 --pc_left;
3730 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3731 } else {
3732 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3733 qsort_rotate(pc_left, u_right, u_left);
3734 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3735 }
3736 }
3737 } else if (s == 0) {
3738 /* l == c */
3739 s = qsort_cmp(pc_left, u_left);
3740 if (s < 0) {
3741 /* l == c, c < r - already in order, grow pc */
3742 --pc_left;
3743 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);