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