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