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