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