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