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