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