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