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