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