This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Pass 4 at perldelta - cleanup problems found by podchecker.
[perl5.git] / pp_hot.c
CommitLineData
a0d0e21e
LW
1/* pp_hot.c
2 *
bc89e66f 3 * Copyright (c) 1991-2001, 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 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
12 * shaking the air.
13 *
14 * Awake! Awake! Fear, Fire, Foes! Awake!
15 * Fire, Foes! Awake!
16 */
17
18#include "EXTERN.h"
864dbfa3 19#define PERL_IN_PP_HOT_C
a0d0e21e
LW
20#include "perl.h"
21
22/* Hot code. */
23
4d1ff10f 24#ifdef USE_5005THREADS
acfe0abc 25static void unset_cvowner(pTHX_ void *cvarg);
4d1ff10f 26#endif /* USE_5005THREADS */
11343788 27
a0d0e21e
LW
28PP(pp_const)
29{
39644a26 30 dSP;
1d7c1841 31 XPUSHs(cSVOP_sv);
a0d0e21e
LW
32 RETURN;
33}
34
35PP(pp_nextstate)
36{
533c011a 37 PL_curcop = (COP*)PL_op;
a0d0e21e 38 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 39 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW
40 FREETMPS;
41 return NORMAL;
42}
43
44PP(pp_gvsv)
45{
39644a26 46 dSP;
924508f0 47 EXTEND(SP,1);
533c011a 48 if (PL_op->op_private & OPpLVAL_INTRO)
1d7c1841 49 PUSHs(save_scalar(cGVOP_gv));
a0d0e21e 50 else
1d7c1841 51 PUSHs(GvSV(cGVOP_gv));
a0d0e21e
LW
52 RETURN;
53}
54
55PP(pp_null)
56{
57 return NORMAL;
58}
59
7399586d
HS
60PP(pp_setstate)
61{
62 PL_curcop = (COP*)PL_op;
63 return NORMAL;
64}
65
a0d0e21e
LW
66PP(pp_pushmark)
67{
3280af22 68 PUSHMARK(PL_stack_sp);
a0d0e21e
LW
69 return NORMAL;
70}
71
72PP(pp_stringify)
73{
39644a26 74 dSP; dTARGET;
a0d0e21e
LW
75 STRLEN len;
76 char *s;
77 s = SvPV(TOPs,len);
78 sv_setpvn(TARG,s,len);
9aa983d2 79 if (SvUTF8(TOPs))
234a4bc6 80 SvUTF8_on(TARG);
a227d84d
NIS
81 else
82 SvUTF8_off(TARG);
a0d0e21e
LW
83 SETTARG;
84 RETURN;
85}
86
87PP(pp_gv)
88{
39644a26 89 dSP;
1d7c1841 90 XPUSHs((SV*)cGVOP_gv);
a0d0e21e
LW
91 RETURN;
92}
93
94PP(pp_and)
95{
39644a26 96 dSP;
a0d0e21e
LW
97 if (!SvTRUE(TOPs))
98 RETURN;
99 else {
100 --SP;
101 RETURNOP(cLOGOP->op_other);
102 }
103}
104
105PP(pp_sassign)
106{
39644a26 107 dSP; dPOPTOPssrl;
748a9306 108
533c011a 109 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
a0d0e21e
LW
110 SV *temp;
111 temp = left; left = right; right = temp;
112 }
3280af22 113 if (PL_tainting && PL_tainted && !SvTAINTED(left))
a0d0e21e 114 TAINT_NOT;
54310121 115 SvSetMagicSV(right, left);
a0d0e21e
LW
116 SETs(right);
117 RETURN;
118}
119
120PP(pp_cond_expr)
121{
39644a26 122 dSP;
a0d0e21e 123 if (SvTRUEx(POPs))
1a67a97c 124 RETURNOP(cLOGOP->op_other);
a0d0e21e 125 else
1a67a97c 126 RETURNOP(cLOGOP->op_next);
a0d0e21e
LW
127}
128
129PP(pp_unstack)
130{
131 I32 oldsave;
132 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 133 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 134 FREETMPS;
3280af22 135 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
136 LEAVE_SCOPE(oldsave);
137 return NORMAL;
138}
139
a0d0e21e
LW
140PP(pp_concat)
141{
39644a26 142 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
748a9306
LW
143 {
144 dPOPTOPssrl;
8d6d96c1
HS
145 STRLEN llen;
146 char* lpv;
147 bool lbyte;
148 STRLEN rlen;
149 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
150 bool rbyte = !SvUTF8(right);
151
152 if (TARG == right && right != left) {
153 right = sv_2mortal(newSVpvn(rpv, rlen));
154 rpv = SvPV(right, rlen); /* no point setting UTF8 here */
155 }
7889fe52 156
8d6d96c1
HS
157 if (TARG != left) {
158 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
159 lbyte = !SvUTF8(left);
160 sv_setpvn(TARG, lpv, llen);
161 if (!lbyte)
162 SvUTF8_on(TARG);
163 else
164 SvUTF8_off(TARG);
165 }
166 else { /* TARG == left */
167 if (SvGMAGICAL(left))
168 mg_get(left); /* or mg_get(left) may happen here */
169 if (!SvOK(TARG))
170 sv_setpv(left, "");
171 lpv = SvPV_nomg(left, llen);
172 lbyte = !SvUTF8(left);
173 }
a12c0f56 174
fd15e783
PN
175#if defined(PERL_Y2KWARN)
176 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
8d6d96c1
HS
177 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
178 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
179 {
180 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
181 "about to append an integer to '19'");
182 }
fd15e783
PN
183 }
184#endif
185
8d6d96c1
HS
186 if (lbyte != rbyte) {
187 if (lbyte)
188 sv_utf8_upgrade_nomg(TARG);
189 else {
190 sv_utf8_upgrade_nomg(right);
191 rpv = SvPV(right, rlen);
69b47968 192 }
a0d0e21e 193 }
8d6d96c1 194 sv_catpvn_nomg(TARG, rpv, rlen);
43ebc500 195
a0d0e21e
LW
196 SETTARG;
197 RETURN;
748a9306 198 }
a0d0e21e
LW
199}
200
201PP(pp_padsv)
202{
39644a26 203 dSP; dTARGET;
a0d0e21e 204 XPUSHs(TARG);
533c011a
NIS
205 if (PL_op->op_flags & OPf_MOD) {
206 if (PL_op->op_private & OPpLVAL_INTRO)
207 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
208 else if (PL_op->op_private & OPpDEREF) {
8ec5e241 209 PUTBACK;
533c011a 210 vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
8ec5e241
NIS
211 SPAGAIN;
212 }
4633a7c4 213 }
a0d0e21e
LW
214 RETURN;
215}
216
217PP(pp_readline)
218{
f5284f61 219 tryAMAGICunTARGET(iter, 0);
3280af22 220 PL_last_in_gv = (GV*)(*PL_stack_sp--);
8efb3254 221 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
1c846c1f 222 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
f5284f61 223 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
8efb3254 224 else {
f5284f61
IZ
225 dSP;
226 XPUSHs((SV*)PL_last_in_gv);
227 PUTBACK;
cea2e8a9 228 pp_rv2gv();
f5284f61 229 PL_last_in_gv = (GV*)(*PL_stack_sp--);
f5284f61
IZ
230 }
231 }
a0d0e21e
LW
232 return do_readline();
233}
234
235PP(pp_eq)
236{
39644a26 237 dSP; tryAMAGICbinSET(eq,0);
4c9fe80f
AS
238#ifndef NV_PRESERVES_UV
239 if (SvROK(TOPs) && SvROK(TOPm1s)) {
240 SETs(boolSV(SvRV(TOPs) == SvRV(TOPm1s)));
241 RETURN;
242 }
243#endif
28e5dec8
JH
244#ifdef PERL_PRESERVE_IVUV
245 SvIV_please(TOPs);
246 if (SvIOK(TOPs)) {
4c9fe80f
AS
247 /* Unless the left argument is integer in range we are going
248 to have to use NV maths. Hence only attempt to coerce the
249 right argument if we know the left is integer. */
28e5dec8
JH
250 SvIV_please(TOPm1s);
251 if (SvIOK(TOPm1s)) {
252 bool auvok = SvUOK(TOPm1s);
253 bool buvok = SvUOK(TOPs);
a12c0f56 254
28e5dec8
JH
255 if (!auvok && !buvok) { /* ## IV == IV ## */
256 IV aiv = SvIVX(TOPm1s);
257 IV biv = SvIVX(TOPs);
258
259 SP--;
260 SETs(boolSV(aiv == biv));
261 RETURN;
262 }
263 if (auvok && buvok) { /* ## UV == UV ## */
264 UV auv = SvUVX(TOPm1s);
265 UV buv = SvUVX(TOPs);
266
267 SP--;
268 SETs(boolSV(auv == buv));
269 RETURN;
270 }
271 { /* ## Mixed IV,UV ## */
272 IV iv;
273 UV uv;
274
275 /* == is commutative so swap if needed (save code) */
276 if (auvok) {
277 /* swap. top of stack (b) is the iv */
278 iv = SvIVX(TOPs);
279 SP--;
280 if (iv < 0) {
281 /* As (a) is a UV, it's >0, so it cannot be == */
282 SETs(&PL_sv_no);
283 RETURN;
284 }
285 uv = SvUVX(TOPs);
286 } else {
287 iv = SvIVX(TOPm1s);
288 SP--;
289 if (iv < 0) {
290 /* As (b) is a UV, it's >0, so it cannot be == */
291 SETs(&PL_sv_no);
292 RETURN;
293 }
294 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
295 }
296 /* we know iv is >= 0 */
28e5dec8
JH
297 SETs(boolSV((UV)iv == uv));
298 RETURN;
299 }
300 }
301 }
302#endif
a0d0e21e
LW
303 {
304 dPOPnv;
54310121 305 SETs(boolSV(TOPn == value));
a0d0e21e
LW
306 RETURN;
307 }
308}
309
310PP(pp_preinc)
311{
39644a26 312 dSP;
68dc0745 313 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 314 DIE(aTHX_ PL_no_modify);
25da4f38 315 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff
PP
316 SvIVX(TOPs) != IV_MAX)
317 {
748a9306 318 ++SvIVX(TOPs);
55497cff 319 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 320 }
28e5dec8 321 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
748a9306 322 sv_inc(TOPs);
a0d0e21e
LW
323 SvSETMAGIC(TOPs);
324 return NORMAL;
325}
326
327PP(pp_or)
328{
39644a26 329 dSP;
a0d0e21e
LW
330 if (SvTRUE(TOPs))
331 RETURN;
332 else {
333 --SP;
334 RETURNOP(cLOGOP->op_other);
335 }
336}
337
338PP(pp_add)
339{
39644a26 340 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
28e5dec8
JH
341 useleft = USE_LEFT(TOPm1s);
342#ifdef PERL_PRESERVE_IVUV
343 /* We must see if we can perform the addition with integers if possible,
344 as the integer code detects overflow while the NV code doesn't.
345 If either argument hasn't had a numeric conversion yet attempt to get
346 the IV. It's important to do this now, rather than just assuming that
347 it's not IOK as a PV of "9223372036854775806" may not take well to NV
348 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
349 integer in case the second argument is IV=9223372036854775806
350 We can (now) rely on sv_2iv to do the right thing, only setting the
351 public IOK flag if the value in the NV (or PV) slot is truly integer.
352
353 A side effect is that this also aggressively prefers integer maths over
7dca457a
NC
354 fp maths for integer values.
355
a00b5bd3 356 How to detect overflow?
7dca457a
NC
357
358 C 99 section 6.2.6.1 says
359
360 The range of nonnegative values of a signed integer type is a subrange
361 of the corresponding unsigned integer type, and the representation of
362 the same value in each type is the same. A computation involving
363 unsigned operands can never overflow, because a result that cannot be
364 represented by the resulting unsigned integer type is reduced modulo
365 the number that is one greater than the largest value that can be
366 represented by the resulting type.
367
368 (the 9th paragraph)
369
370 which I read as "unsigned ints wrap."
371
372 signed integer overflow seems to be classed as "exception condition"
373
374 If an exceptional condition occurs during the evaluation of an
375 expression (that is, if the result is not mathematically defined or not
376 in the range of representable values for its type), the behavior is
377 undefined.
378
379 (6.5, the 5th paragraph)
380
381 I had assumed that on 2s complement machines signed arithmetic would
382 wrap, hence coded pp_add and pp_subtract on the assumption that
383 everything perl builds on would be happy. After much wailing and
384 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
385 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
386 unsigned code below is actually shorter than the old code. :-)
387 */
388
28e5dec8
JH
389 SvIV_please(TOPs);
390 if (SvIOK(TOPs)) {
391 /* Unless the left argument is integer in range we are going to have to
392 use NV maths. Hence only attempt to coerce the right argument if
393 we know the left is integer. */
9c5ffd7c
JH
394 register UV auv = 0;
395 bool auvok = FALSE;
7dca457a
NC
396 bool a_valid = 0;
397
28e5dec8 398 if (!useleft) {
7dca457a
NC
399 auv = 0;
400 a_valid = auvok = 1;
401 /* left operand is undef, treat as zero. + 0 is identity,
402 Could SETi or SETu right now, but space optimise by not adding
403 lots of code to speed up what is probably a rarish case. */
404 } else {
405 /* Left operand is defined, so is it IV? */
406 SvIV_please(TOPm1s);
407 if (SvIOK(TOPm1s)) {
408 if ((auvok = SvUOK(TOPm1s)))
409 auv = SvUVX(TOPm1s);
410 else {
411 register IV aiv = SvIVX(TOPm1s);
412 if (aiv >= 0) {
413 auv = aiv;
414 auvok = 1; /* Now acting as a sign flag. */
415 } else { /* 2s complement assumption for IV_MIN */
416 auv = (UV)-aiv;
417 }
418 }
419 a_valid = 1;
28e5dec8
JH
420 }
421 }
7dca457a
NC
422 if (a_valid) {
423 bool result_good = 0;
424 UV result;
425 register UV buv;
28e5dec8 426 bool buvok = SvUOK(TOPs);
a00b5bd3 427
7dca457a
NC
428 if (buvok)
429 buv = SvUVX(TOPs);
430 else {
431 register IV biv = SvIVX(TOPs);
432 if (biv >= 0) {
433 buv = biv;
434 buvok = 1;
435 } else
436 buv = (UV)-biv;
437 }
438 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
439 else "IV" now, independant of how it came in.
440 if a, b represents positive, A, B negative, a maps to -A etc
441 a + b => (a + b)
442 A + b => -(a - b)
443 a + B => (a - b)
444 A + B => -(a + b)
445 all UV maths. negate result if A negative.
446 add if signs same, subtract if signs differ. */
447
448 if (auvok ^ buvok) {
449 /* Signs differ. */
450 if (auv >= buv) {
451 result = auv - buv;
452 /* Must get smaller */
453 if (result <= auv)
454 result_good = 1;
455 } else {
456 result = buv - auv;
457 if (result <= buv) {
458 /* result really should be -(auv-buv). as its negation
459 of true value, need to swap our result flag */
460 auvok = !auvok;
461 result_good = 1;
28e5dec8
JH
462 }
463 }
7dca457a
NC
464 } else {
465 /* Signs same */
466 result = auv + buv;
467 if (result >= auv)
468 result_good = 1;
469 }
470 if (result_good) {
471 SP--;
472 if (auvok)
28e5dec8 473 SETu( result );
7dca457a
NC
474 else {
475 /* Negate result */
476 if (result <= (UV)IV_MIN)
477 SETi( -(IV)result );
478 else {
479 /* result valid, but out of range for IV. */
480 SETn( -(NV)result );
28e5dec8
JH
481 }
482 }
7dca457a
NC
483 RETURN;
484 } /* Overflow, drop through to NVs. */
28e5dec8
JH
485 }
486 }
487#endif
a0d0e21e 488 {
28e5dec8
JH
489 dPOPnv;
490 if (!useleft) {
491 /* left operand is undef, treat as zero. + 0.0 is identity. */
492 SETn(value);
493 RETURN;
494 }
495 SETn( value + TOPn );
496 RETURN;
a0d0e21e
LW
497 }
498}
499
500PP(pp_aelemfast)
501{
39644a26 502 dSP;
1d7c1841 503 AV *av = GvAV(cGVOP_gv);
533c011a
NIS
504 U32 lval = PL_op->op_flags & OPf_MOD;
505 SV** svp = av_fetch(av, PL_op->op_private, lval);
3280af22 506 SV *sv = (svp ? *svp : &PL_sv_undef);
6ff81951 507 EXTEND(SP, 1);
be6c24e0
GS
508 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
509 sv = sv_mortalcopy(sv);
510 PUSHs(sv);
a0d0e21e
LW
511 RETURN;
512}
513
514PP(pp_join)
515{
39644a26 516 dSP; dMARK; dTARGET;
a0d0e21e
LW
517 MARK++;
518 do_join(TARG, *MARK, MARK, SP);
519 SP = MARK;
520 SETs(TARG);
521 RETURN;
522}
523
524PP(pp_pushre)
525{
39644a26 526 dSP;
44a8e56a
PP
527#ifdef DEBUGGING
528 /*
529 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
530 * will be enough to hold an OP*.
531 */
532 SV* sv = sv_newmortal();
533 sv_upgrade(sv, SVt_PVLV);
534 LvTYPE(sv) = '/';
533c011a 535 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
44a8e56a
PP
536 XPUSHs(sv);
537#else
6b88bc9c 538 XPUSHs((SV*)PL_op);
44a8e56a 539#endif
a0d0e21e
LW
540 RETURN;
541}
542
543/* Oversized hot code. */
544
545PP(pp_print)
546{
39644a26 547 dSP; dMARK; dORIGMARK;
a0d0e21e
LW
548 GV *gv;
549 IO *io;
760ac839 550 register PerlIO *fp;
236988e4 551 MAGIC *mg;
a0d0e21e 552
533c011a 553 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
554 gv = (GV*)*++MARK;
555 else
3280af22 556 gv = PL_defoutgv;
5b468f54
AMS
557
558 if (gv && (io = GvIO(gv))
559 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
560 {
01bb7c6d 561 had_magic:
68dc0745 562 if (MARK == ORIGMARK) {
1c846c1f 563 /* If using default handle then we need to make space to
a60c0954
NIS
564 * pass object as 1st arg, so move other args up ...
565 */
4352c267 566 MEXTEND(SP, 1);
68dc0745
PP
567 ++MARK;
568 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
569 ++SP;
570 }
571 PUSHMARK(MARK - 1);
5b468f54 572 *MARK = SvTIED_obj((SV*)io, mg);
68dc0745 573 PUTBACK;
236988e4 574 ENTER;
864dbfa3 575 call_method("PRINT", G_SCALAR);
236988e4
PP
576 LEAVE;
577 SPAGAIN;
68dc0745
PP
578 MARK = ORIGMARK + 1;
579 *MARK = *SP;
580 SP = MARK;
236988e4
PP
581 RETURN;
582 }
a0d0e21e 583 if (!(io = GvIO(gv))) {
5b468f54
AMS
584 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
585 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
01bb7c6d 586 goto had_magic;
2dd78f96
JH
587 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
588 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 589 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
590 goto just_say_no;
591 }
592 else if (!(fp = IoOFP(io))) {
599cee73 593 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
4c80c0b2
NC
594 if (IoIFP(io))
595 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
2dd78f96 596 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
bc37a18f 597 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 598 }
91487cfc 599 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW
600 goto just_say_no;
601 }
602 else {
603 MARK++;
7889fe52 604 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
a0d0e21e
LW
605 while (MARK <= SP) {
606 if (!do_print(*MARK, fp))
607 break;
608 MARK++;
609 if (MARK <= SP) {
7889fe52 610 if (!do_print(PL_ofs_sv, fp)) { /* $, */
a0d0e21e
LW
611 MARK--;
612 break;
613 }
614 }
615 }
616 }
617 else {
618 while (MARK <= SP) {
619 if (!do_print(*MARK, fp))
620 break;
621 MARK++;
622 }
623 }
624 if (MARK <= SP)
625 goto just_say_no;
626 else {
7889fe52
NIS
627 if (PL_ors_sv && SvOK(PL_ors_sv))
628 if (!do_print(PL_ors_sv, fp)) /* $\ */
a0d0e21e
LW
629 goto just_say_no;
630
631 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 632 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
633 goto just_say_no;
634 }
635 }
636 SP = ORIGMARK;
3280af22 637 PUSHs(&PL_sv_yes);
a0d0e21e
LW
638 RETURN;
639
640 just_say_no:
641 SP = ORIGMARK;
3280af22 642 PUSHs(&PL_sv_undef);
a0d0e21e
LW
643 RETURN;
644}
645
646PP(pp_rv2av)
647{
39644a26 648 dSP; dTOPss;
a0d0e21e
LW
649 AV *av;
650
651 if (SvROK(sv)) {
652 wasref:
f5284f61
IZ
653 tryAMAGICunDEREF(to_av);
654
a0d0e21e
LW
655 av = (AV*)SvRV(sv);
656 if (SvTYPE(av) != SVt_PVAV)
cea2e8a9 657 DIE(aTHX_ "Not an ARRAY reference");
533c011a 658 if (PL_op->op_flags & OPf_REF) {
f5284f61 659 SETs((SV*)av);
a0d0e21e
LW
660 RETURN;
661 }
78f9721b
SM
662 else if (LVRET) {
663 if (GIMME == G_SCALAR)
664 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
665 SETs((SV*)av);
666 RETURN;
667 }
a0d0e21e
LW
668 }
669 else {
670 if (SvTYPE(sv) == SVt_PVAV) {
671 av = (AV*)sv;
533c011a 672 if (PL_op->op_flags & OPf_REF) {
f5284f61 673 SETs((SV*)av);
a0d0e21e
LW
674 RETURN;
675 }
78f9721b
SM
676 else if (LVRET) {
677 if (GIMME == G_SCALAR)
678 Perl_croak(aTHX_ "Can't return array to lvalue"
679 " scalar context");
680 SETs((SV*)av);
681 RETURN;
682 }
a0d0e21e
LW
683 }
684 else {
67955e0c 685 GV *gv;
1c846c1f 686
a0d0e21e 687 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 688 char *sym;
c9d5ac95 689 STRLEN len;
748a9306 690
a0d0e21e
LW
691 if (SvGMAGICAL(sv)) {
692 mg_get(sv);
693 if (SvROK(sv))
694 goto wasref;
695 }
696 if (!SvOK(sv)) {
533c011a
NIS
697 if (PL_op->op_flags & OPf_REF ||
698 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 699 DIE(aTHX_ PL_no_usym, "an ARRAY");
599cee73 700 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 701 report_uninit();
f5284f61 702 if (GIMME == G_ARRAY) {
c2444246 703 (void)POPs;
4633a7c4 704 RETURN;
f5284f61
IZ
705 }
706 RETSETUNDEF;
a0d0e21e 707 }
c9d5ac95 708 sym = SvPV(sv,len);
35cd451c
GS
709 if ((PL_op->op_flags & OPf_SPECIAL) &&
710 !(PL_op->op_flags & OPf_MOD))
711 {
712 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
c9d5ac95
GS
713 if (!gv
714 && (!is_gv_magical(sym,len,0)
715 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
716 {
35cd451c 717 RETSETUNDEF;
c9d5ac95 718 }
35cd451c
GS
719 }
720 else {
721 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 722 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
35cd451c
GS
723 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
724 }
725 }
726 else {
67955e0c 727 gv = (GV*)sv;
a0d0e21e 728 }
67955e0c 729 av = GvAVn(gv);
533c011a 730 if (PL_op->op_private & OPpLVAL_INTRO)
67955e0c 731 av = save_ary(gv);
533c011a 732 if (PL_op->op_flags & OPf_REF) {
f5284f61 733 SETs((SV*)av);
a0d0e21e
LW
734 RETURN;
735 }
78f9721b
SM
736 else if (LVRET) {
737 if (GIMME == G_SCALAR)
738 Perl_croak(aTHX_ "Can't return array to lvalue"
739 " scalar context");
740 SETs((SV*)av);
741 RETURN;
742 }
a0d0e21e
LW
743 }
744 }
745
746 if (GIMME == G_ARRAY) {
747 I32 maxarg = AvFILL(av) + 1;
c2444246 748 (void)POPs; /* XXXX May be optimized away? */
1c846c1f 749 EXTEND(SP, maxarg);
93965878 750 if (SvRMAGICAL(av)) {
1c846c1f 751 U32 i;
93965878
NIS
752 for (i=0; i < maxarg; i++) {
753 SV **svp = av_fetch(av, i, FALSE);
3280af22 754 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878 755 }
1c846c1f 756 }
93965878
NIS
757 else {
758 Copy(AvARRAY(av), SP+1, maxarg, SV*);
759 }
a0d0e21e
LW
760 SP += maxarg;
761 }
762 else {
763 dTARGET;
764 I32 maxarg = AvFILL(av) + 1;
f5284f61 765 SETi(maxarg);
a0d0e21e
LW
766 }
767 RETURN;
768}
769
770PP(pp_rv2hv)
771{
39644a26 772 dSP; dTOPss;
a0d0e21e
LW
773 HV *hv;
774
775 if (SvROK(sv)) {
776 wasref:
f5284f61
IZ
777 tryAMAGICunDEREF(to_hv);
778
a0d0e21e 779 hv = (HV*)SvRV(sv);
c750a3ec 780 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
cea2e8a9 781 DIE(aTHX_ "Not a HASH reference");
533c011a 782 if (PL_op->op_flags & OPf_REF) {
a0d0e21e
LW
783 SETs((SV*)hv);
784 RETURN;
785 }
78f9721b
SM
786 else if (LVRET) {
787 if (GIMME == G_SCALAR)
788 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
789 SETs((SV*)hv);
790 RETURN;
791 }
a0d0e21e
LW
792 }
793 else {
c750a3ec 794 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
a0d0e21e 795 hv = (HV*)sv;
533c011a 796 if (PL_op->op_flags & OPf_REF) {
a0d0e21e
LW
797 SETs((SV*)hv);
798 RETURN;
799 }
78f9721b
SM
800 else if (LVRET) {
801 if (GIMME == G_SCALAR)
802 Perl_croak(aTHX_ "Can't return hash to lvalue"
803 " scalar context");
804 SETs((SV*)hv);
805 RETURN;
806 }
a0d0e21e
LW
807 }
808 else {
67955e0c 809 GV *gv;
1c846c1f 810
a0d0e21e 811 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 812 char *sym;
c9d5ac95 813 STRLEN len;
748a9306 814
a0d0e21e
LW
815 if (SvGMAGICAL(sv)) {
816 mg_get(sv);
817 if (SvROK(sv))
818 goto wasref;
819 }
820 if (!SvOK(sv)) {
533c011a
NIS
821 if (PL_op->op_flags & OPf_REF ||
822 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 823 DIE(aTHX_ PL_no_usym, "a HASH");
599cee73 824 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 825 report_uninit();
4633a7c4
LW
826 if (GIMME == G_ARRAY) {
827 SP--;
828 RETURN;
829 }
a0d0e21e
LW
830 RETSETUNDEF;
831 }
c9d5ac95 832 sym = SvPV(sv,len);
35cd451c
GS
833 if ((PL_op->op_flags & OPf_SPECIAL) &&
834 !(PL_op->op_flags & OPf_MOD))
835 {
836 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
c9d5ac95
GS
837 if (!gv
838 && (!is_gv_magical(sym,len,0)
839 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
840 {
35cd451c 841 RETSETUNDEF;
c9d5ac95 842 }
35cd451c
GS
843 }
844 else {
845 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 846 DIE(aTHX_ PL_no_symref, sym, "a HASH");
35cd451c
GS
847 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
848 }
849 }
850 else {
67955e0c 851 gv = (GV*)sv;
a0d0e21e 852 }
67955e0c 853 hv = GvHVn(gv);
533c011a 854 if (PL_op->op_private & OPpLVAL_INTRO)
67955e0c 855 hv = save_hash(gv);
533c011a 856 if (PL_op->op_flags & OPf_REF) {
a0d0e21e
LW
857 SETs((SV*)hv);
858 RETURN;
859 }
78f9721b
SM
860 else if (LVRET) {
861 if (GIMME == G_SCALAR)
862 Perl_croak(aTHX_ "Can't return hash to lvalue"
863 " scalar context");
864 SETs((SV*)hv);
865 RETURN;
866 }
a0d0e21e
LW
867 }
868 }
869
870 if (GIMME == G_ARRAY) { /* array wanted */
3280af22 871 *PL_stack_sp = (SV*)hv;
cea2e8a9 872 return do_kv();
a0d0e21e
LW
873 }
874 else {
875 dTARGET;
4b154ab5
GA
876 if (SvTYPE(hv) == SVt_PVAV)
877 hv = avhv_keys((AV*)hv);
b9c39e73 878 if (HvFILL(hv))
57def98f
JH
879 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
880 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
a0d0e21e
LW
881 else
882 sv_setiv(TARG, 0);
c750a3ec 883
a0d0e21e
LW
884 SETTARG;
885 RETURN;
886 }
887}
888
10c8fecd
GS
889STATIC int
890S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
891 SV **lastrelem)
892{
893 OP *leftop;
10c8fecd
GS
894 I32 i;
895
896 leftop = ((BINOP*)PL_op)->op_last;
897 assert(leftop);
898 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
899 leftop = ((LISTOP*)leftop)->op_first;
900 assert(leftop);
901 /* Skip PUSHMARK and each element already assigned to. */
902 for (i = lelem - firstlelem; i > 0; i--) {
903 leftop = leftop->op_sibling;
904 assert(leftop);
905 }
906 if (leftop->op_type != OP_RV2HV)
907 return 0;
908
909 /* pseudohash */
910 if (av_len(ary) > 0)
911 av_fill(ary, 0); /* clear all but the fields hash */
912 if (lastrelem >= relem) {
913 while (relem < lastrelem) { /* gobble up all the rest */
914 SV *tmpstr;
915 assert(relem[0]);
916 assert(relem[1]);
917 /* Avoid a memory leak when avhv_store_ent dies. */
918 tmpstr = sv_newmortal();
919 sv_setsv(tmpstr,relem[1]); /* value */
920 relem[1] = tmpstr;
921 if (avhv_store_ent(ary,relem[0],tmpstr,0))
d16e9ed9 922 (void)SvREFCNT_inc(tmpstr);
10c8fecd
GS
923 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
924 mg_set(tmpstr);
925 relem += 2;
926 TAINT_NOT;
927 }
928 }
929 if (relem == lastrelem)
930 return 1;
931 return 2;
932}
933
934STATIC void
935S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
936{
937 if (*relem) {
938 SV *tmpstr;
939 if (ckWARN(WARN_MISC)) {
940 if (relem == firstrelem &&
941 SvROK(*relem) &&
942 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
943 SvTYPE(SvRV(*relem)) == SVt_PVHV))
944 {
945 Perl_warner(aTHX_ WARN_MISC,
946 "Reference found where even-sized list expected");
947 }
948 else
949 Perl_warner(aTHX_ WARN_MISC,
950 "Odd number of elements in hash assignment");
951 }
952 if (SvTYPE(hash) == SVt_PVAV) {
953 /* pseudohash */
954 tmpstr = sv_newmortal();
955 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
d16e9ed9 956 (void)SvREFCNT_inc(tmpstr);
10c8fecd
GS
957 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
958 mg_set(tmpstr);
959 }
960 else {
961 HE *didstore;
962 tmpstr = NEWSV(29,0);
963 didstore = hv_store_ent(hash,*relem,tmpstr,0);
964 if (SvMAGICAL(hash)) {
965 if (SvSMAGICAL(tmpstr))
966 mg_set(tmpstr);
967 if (!didstore)
968 sv_2mortal(tmpstr);
969 }
970 }
971 TAINT_NOT;
972 }
973}
974
a0d0e21e
LW
975PP(pp_aassign)
976{
39644a26 977 dSP;
3280af22
NIS
978 SV **lastlelem = PL_stack_sp;
979 SV **lastrelem = PL_stack_base + POPMARK;
980 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
981 SV **firstlelem = lastrelem + 1;
982
983 register SV **relem;
984 register SV **lelem;
985
986 register SV *sv;
987 register AV *ary;
988
54310121 989 I32 gimme;
a0d0e21e
LW
990 HV *hash;
991 I32 i;
992 int magic;
993
3280af22 994 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
a0d0e21e
LW
995
996 /* If there's a common identifier on both sides we have to take
997 * special care that assigning the identifier on the left doesn't
998 * clobber a value on the right that's used later in the list.
999 */
10c8fecd 1000 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
cc5e57d2 1001 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd
GS
1002 for (relem = firstrelem; relem <= lastrelem; relem++) {
1003 /*SUPPRESS 560*/
155aba94 1004 if ((sv = *relem)) {
a1f49e72 1005 TAINT_NOT; /* Each item is independent */
10c8fecd 1006 *relem = sv_mortalcopy(sv);
a1f49e72 1007 }
10c8fecd 1008 }
a0d0e21e
LW
1009 }
1010
1011 relem = firstrelem;
1012 lelem = firstlelem;
1013 ary = Null(AV*);
1014 hash = Null(HV*);
10c8fecd 1015
a0d0e21e 1016 while (lelem <= lastlelem) {
bbce6d69 1017 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e
LW
1018 sv = *lelem++;
1019 switch (SvTYPE(sv)) {
1020 case SVt_PVAV:
1021 ary = (AV*)sv;
748a9306 1022 magic = SvMAGICAL(ary) != 0;
10c8fecd
GS
1023 if (PL_op->op_private & OPpASSIGN_HASH) {
1024 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
1025 lastrelem))
1026 {
1027 case 0:
1028 goto normal_array;
1029 case 1:
1030 do_oddball((HV*)ary, relem, firstrelem);
1031 }
1032 relem = lastrelem + 1;
1033 break;
1034 }
1035 normal_array:
a0d0e21e 1036 av_clear(ary);
7e42bd57 1037 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
1038 i = 0;
1039 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 1040 SV **didstore;
a0d0e21e
LW
1041 sv = NEWSV(28,0);
1042 assert(*relem);
1043 sv_setsv(sv,*relem);
1044 *(relem++) = sv;
5117ca91
GS
1045 didstore = av_store(ary,i++,sv);
1046 if (magic) {
fb73857a
PP
1047 if (SvSMAGICAL(sv))
1048 mg_set(sv);
5117ca91 1049 if (!didstore)
8127e0e3 1050 sv_2mortal(sv);
5117ca91 1051 }
bbce6d69 1052 TAINT_NOT;
a0d0e21e
LW
1053 }
1054 break;
10c8fecd 1055 case SVt_PVHV: { /* normal hash */
a0d0e21e
LW
1056 SV *tmpstr;
1057
1058 hash = (HV*)sv;
748a9306 1059 magic = SvMAGICAL(hash) != 0;
a0d0e21e
LW
1060 hv_clear(hash);
1061
1062 while (relem < lastrelem) { /* gobble up all the rest */
5117ca91 1063 HE *didstore;
4633a7c4 1064 if (*relem)
a0d0e21e 1065 sv = *(relem++);
4633a7c4 1066 else
3280af22 1067 sv = &PL_sv_no, relem++;
a0d0e21e
LW
1068 tmpstr = NEWSV(29,0);
1069 if (*relem)
1070 sv_setsv(tmpstr,*relem); /* value */
1071 *(relem++) = tmpstr;
5117ca91
GS
1072 didstore = hv_store_ent(hash,sv,tmpstr,0);
1073 if (magic) {
fb73857a
PP
1074 if (SvSMAGICAL(tmpstr))
1075 mg_set(tmpstr);
5117ca91 1076 if (!didstore)
8127e0e3 1077 sv_2mortal(tmpstr);
5117ca91 1078 }
bbce6d69 1079 TAINT_NOT;
8e07c86e 1080 }
6a0deba8 1081 if (relem == lastrelem) {
10c8fecd 1082 do_oddball(hash, relem, firstrelem);
6a0deba8 1083 relem++;
1930e939 1084 }
a0d0e21e
LW
1085 }
1086 break;
1087 default:
6fc92669
GS
1088 if (SvIMMORTAL(sv)) {
1089 if (relem <= lastrelem)
1090 relem++;
1091 break;
a0d0e21e
LW
1092 }
1093 if (relem <= lastrelem) {
1094 sv_setsv(sv, *relem);
1095 *(relem++) = sv;
1096 }
1097 else
3280af22 1098 sv_setsv(sv, &PL_sv_undef);
a0d0e21e
LW
1099 SvSETMAGIC(sv);
1100 break;
1101 }
1102 }
3280af22
NIS
1103 if (PL_delaymagic & ~DM_DELAY) {
1104 if (PL_delaymagic & DM_UID) {
a0d0e21e 1105#ifdef HAS_SETRESUID
b28d0864 1106 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
56febc5e
AD
1107#else
1108# ifdef HAS_SETREUID
3280af22 1109 (void)setreuid(PL_uid,PL_euid);
56febc5e
AD
1110# else
1111# ifdef HAS_SETRUID
b28d0864
NIS
1112 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1113 (void)setruid(PL_uid);
1114 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1115 }
56febc5e
AD
1116# endif /* HAS_SETRUID */
1117# ifdef HAS_SETEUID
b28d0864
NIS
1118 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1119 (void)seteuid(PL_uid);
1120 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1121 }
56febc5e 1122# endif /* HAS_SETEUID */
b28d0864
NIS
1123 if (PL_delaymagic & DM_UID) {
1124 if (PL_uid != PL_euid)
cea2e8a9 1125 DIE(aTHX_ "No setreuid available");
b28d0864 1126 (void)PerlProc_setuid(PL_uid);
a0d0e21e 1127 }
56febc5e
AD
1128# endif /* HAS_SETREUID */
1129#endif /* HAS_SETRESUID */
d8eceb89
JH
1130 PL_uid = PerlProc_getuid();
1131 PL_euid = PerlProc_geteuid();
a0d0e21e 1132 }
3280af22 1133 if (PL_delaymagic & DM_GID) {
a0d0e21e 1134#ifdef HAS_SETRESGID
b28d0864 1135 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
56febc5e
AD
1136#else
1137# ifdef HAS_SETREGID
3280af22 1138 (void)setregid(PL_gid,PL_egid);
56febc5e
AD
1139# else
1140# ifdef HAS_SETRGID
b28d0864
NIS
1141 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1142 (void)setrgid(PL_gid);
1143 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1144 }
56febc5e
AD
1145# endif /* HAS_SETRGID */
1146# ifdef HAS_SETEGID
b28d0864
NIS
1147 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1148 (void)setegid(PL_gid);
1149 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1150 }
56febc5e 1151# endif /* HAS_SETEGID */
b28d0864
NIS
1152 if (PL_delaymagic & DM_GID) {
1153 if (PL_gid != PL_egid)
cea2e8a9 1154 DIE(aTHX_ "No setregid available");
b28d0864 1155 (void)PerlProc_setgid(PL_gid);
a0d0e21e 1156 }
56febc5e
AD
1157# endif /* HAS_SETREGID */
1158#endif /* HAS_SETRESGID */
d8eceb89
JH
1159 PL_gid = PerlProc_getgid();
1160 PL_egid = PerlProc_getegid();
a0d0e21e 1161 }
3280af22 1162 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
a0d0e21e 1163 }
3280af22 1164 PL_delaymagic = 0;
54310121
PP
1165
1166 gimme = GIMME_V;
1167 if (gimme == G_VOID)
1168 SP = firstrelem - 1;
1169 else if (gimme == G_SCALAR) {
1170 dTARGET;
1171 SP = firstrelem;
1172 SETi(lastrelem - firstrelem + 1);
1173 }
1174 else {
a0d0e21e
LW
1175 if (ary || hash)
1176 SP = lastrelem;
1177 else
1178 SP = firstrelem + (lastlelem - firstlelem);
0c8c7a05 1179 lelem = firstlelem + (relem - firstrelem);
5f05dabc 1180 while (relem <= SP)
3280af22 1181 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
a0d0e21e 1182 }
54310121 1183 RETURN;
a0d0e21e
LW
1184}
1185
8782bef2
GB
1186PP(pp_qr)
1187{
39644a26 1188 dSP;
8782bef2
GB
1189 register PMOP *pm = cPMOP;
1190 SV *rv = sv_newmortal();
57668c4d 1191 SV *sv = newSVrv(rv, "Regexp");
e08e52cf
AMS
1192 if (pm->op_pmdynflags & PMdf_TAINTED)
1193 SvTAINTED_on(rv);
aaa362c4 1194 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
8782bef2
GB
1195 RETURNX(PUSHs(rv));
1196}
1197
a0d0e21e
LW
1198PP(pp_match)
1199{
39644a26 1200 dSP; dTARG;
a0d0e21e
LW
1201 register PMOP *pm = cPMOP;
1202 register char *t;
1203 register char *s;
1204 char *strend;
1205 I32 global;
f722798b
IZ
1206 I32 r_flags = REXEC_CHECKED;
1207 char *truebase; /* Start of string */
aaa362c4 1208 register REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1209 bool rxtainted;
a0d0e21e
LW
1210 I32 gimme = GIMME;
1211 STRLEN len;
748a9306 1212 I32 minmatch = 0;
3280af22 1213 I32 oldsave = PL_savestack_ix;
f86702cc 1214 I32 update_minmatch = 1;
e60df1fa 1215 I32 had_zerolen = 0;
a0d0e21e 1216
533c011a 1217 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1218 TARG = POPs;
1219 else {
54b9620d 1220 TARG = DEFSV;
a0d0e21e
LW
1221 EXTEND(SP,1);
1222 }
d9f424b2 1223
c277df42 1224 PUTBACK; /* EVAL blocks need stack_sp. */
a0d0e21e
LW
1225 s = SvPV(TARG, len);
1226 strend = s + len;
1227 if (!s)
2269b42e 1228 DIE(aTHX_ "panic: pp_match");
b3eb6a9b 1229 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22 1230 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1231 TAINT_NOT;
a0d0e21e 1232
53c4c00c 1233 PL_reg_match_utf8 = DO_UTF8(TARG);
d9f424b2 1234
48c036b1 1235 if (pm->op_pmdynflags & PMdf_USED) {
c277df42 1236 failure:
a0d0e21e
LW
1237 if (gimme == G_ARRAY)
1238 RETURN;
1239 RETPUSHNO;
1240 }
1241
3280af22
NIS
1242 if (!rx->prelen && PL_curpm) {
1243 pm = PL_curpm;
aaa362c4 1244 rx = PM_GETRE(pm);
a0d0e21e 1245 }
d9f97599 1246 if (rx->minlen > len) goto failure;
c277df42 1247
a0d0e21e 1248 truebase = t = s;
ad94a511
IZ
1249
1250 /* XXXX What part of this is needed with true \G-support? */
155aba94 1251 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
cf93c79d 1252 rx->startp[0] = -1;
a0d0e21e 1253 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
14befaf4 1254 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
565764a8 1255 if (mg && mg->mg_len >= 0) {
b7a35066 1256 if (!(rx->reganch & ROPT_GPOS_SEEN))
1c846c1f 1257 rx->endp[0] = rx->startp[0] = mg->mg_len;
0ef3e39e
HS
1258 else if (rx->reganch & ROPT_ANCH_GPOS) {
1259 r_flags |= REXEC_IGNOREPOS;
1c846c1f 1260 rx->endp[0] = rx->startp[0] = mg->mg_len;
0ef3e39e 1261 }
748a9306 1262 minmatch = (mg->mg_flags & MGf_MINMATCH);
f86702cc 1263 update_minmatch = 0;
748a9306 1264 }
a0d0e21e
LW
1265 }
1266 }
14977893
JH
1267 if ((!global && rx->nparens)
1268 || SvTEMP(TARG) || PL_sawampersand)
1269 r_flags |= REXEC_COPY_STR;
1c846c1f 1270 if (SvSCREAM(TARG))
22e551b9
IZ
1271 r_flags |= REXEC_SCREAM;
1272
a0d0e21e 1273 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS
1274 SAVEINT(PL_multiline);
1275 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
a0d0e21e
LW
1276 }
1277
1278play_it_again:
cf93c79d
IZ
1279 if (global && rx->startp[0] != -1) {
1280 t = s = rx->endp[0] + truebase;
d9f97599 1281 if ((s + rx->minlen) > strend)
a0d0e21e 1282 goto nope;
f86702cc 1283 if (update_minmatch++)
e60df1fa 1284 minmatch = had_zerolen;
a0d0e21e 1285 }
60aeb6fd
NIS
1286 if (rx->reganch & RE_USE_INTUIT &&
1287 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
ee0b7718 1288 PL_bostr = truebase;
f722798b
IZ
1289 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1290
1291 if (!s)
1292 goto nope;
1293 if ( (rx->reganch & ROPT_CHECK_ALL)
14977893 1294 && !PL_sawampersand
f722798b
IZ
1295 && ((rx->reganch & ROPT_NOSCAN)
1296 || !((rx->reganch & RE_INTUIT_TAIL)
05b4157f
GS
1297 && (r_flags & REXEC_SCREAM)))
1298 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
f722798b 1299 goto yup;
a0d0e21e 1300 }
cea2e8a9 1301 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
bbce6d69 1302 {
3280af22 1303 PL_curpm = pm;
a0d0e21e 1304 if (pm->op_pmflags & PMf_ONCE)
48c036b1 1305 pm->op_pmdynflags |= PMdf_USED;
a0d0e21e
LW
1306 goto gotcha;
1307 }
1308 else
1309 goto ret_no;
1310 /*NOTREACHED*/
1311
1312 gotcha:
72311751
GS
1313 if (rxtainted)
1314 RX_MATCH_TAINTED_on(rx);
1315 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1316 if (gimme == G_ARRAY) {
ffc61ed2 1317 I32 nparens, i, len;
a0d0e21e 1318
ffc61ed2
JH
1319 nparens = rx->nparens;
1320 if (global && !nparens)
a0d0e21e
LW
1321 i = 1;
1322 else
1323 i = 0;
c277df42 1324 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1325 EXTEND(SP, nparens + i);
1326 EXTEND_MORTAL(nparens + i);
1327 for (i = !i; i <= nparens; i++) {
a0d0e21e
LW
1328 PUSHs(sv_newmortal());
1329 /*SUPPRESS 560*/
cf93c79d
IZ
1330 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1331 len = rx->endp[i] - rx->startp[i];
1332 s = rx->startp[i] + truebase;
a0d0e21e 1333 sv_setpvn(*SP, s, len);
cce850e4 1334 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1335 SvUTF8_on(*SP);
a0d0e21e
LW
1336 }
1337 }
1338 if (global) {
0af80b60
HS
1339 if (pm->op_pmflags & PMf_CONTINUE) {
1340 MAGIC* mg = 0;
1341 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1342 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1343 if (!mg) {
1344 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1345 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1346 }
1347 if (rx->startp[0] != -1) {
1348 mg->mg_len = rx->endp[0];
1349 if (rx->startp[0] == rx->endp[0])
1350 mg->mg_flags |= MGf_MINMATCH;
1351 else
1352 mg->mg_flags &= ~MGf_MINMATCH;
1353 }
1354 }
cf93c79d
IZ
1355 had_zerolen = (rx->startp[0] != -1
1356 && rx->startp[0] == rx->endp[0]);
c277df42 1357 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1358 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1359 goto play_it_again;
1360 }
ffc61ed2 1361 else if (!nparens)
bde848c5 1362 XPUSHs(&PL_sv_yes);
4633a7c4 1363 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1364 RETURN;
1365 }
1366 else {
1367 if (global) {
1368 MAGIC* mg = 0;
1369 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
14befaf4 1370 mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1371 if (!mg) {
14befaf4
DM
1372 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1373 mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1374 }
cf93c79d
IZ
1375 if (rx->startp[0] != -1) {
1376 mg->mg_len = rx->endp[0];
d9f97599 1377 if (rx->startp[0] == rx->endp[0])
748a9306
LW
1378 mg->mg_flags |= MGf_MINMATCH;
1379 else
1380 mg->mg_flags &= ~MGf_MINMATCH;
1381 }
a0d0e21e 1382 }
4633a7c4 1383 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1384 RETPUSHYES;
1385 }
1386
f722798b 1387yup: /* Confirmed by INTUIT */
72311751
GS
1388 if (rxtainted)
1389 RX_MATCH_TAINTED_on(rx);
1390 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1391 PL_curpm = pm;
a0d0e21e 1392 if (pm->op_pmflags & PMf_ONCE)
48c036b1 1393 pm->op_pmdynflags |= PMdf_USED;
cf93c79d
IZ
1394 if (RX_MATCH_COPIED(rx))
1395 Safefree(rx->subbeg);
1396 RX_MATCH_COPIED_off(rx);
1397 rx->subbeg = Nullch;
a0d0e21e 1398 if (global) {
d9f97599 1399 rx->subbeg = truebase;
cf93c79d 1400 rx->startp[0] = s - truebase;
53c4c00c 1401 if (PL_reg_match_utf8) {
60aeb6fd
NIS
1402 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1403 rx->endp[0] = t - truebase;
1404 }
1405 else {
1406 rx->endp[0] = s - truebase + rx->minlen;
1407 }
cf93c79d 1408 rx->sublen = strend - truebase;
a0d0e21e 1409 goto gotcha;
1c846c1f 1410 }
14977893
JH
1411 if (PL_sawampersand) {
1412 I32 off;
1413
1414 rx->subbeg = savepvn(t, strend - t);
1415 rx->sublen = strend - t;
1416 RX_MATCH_COPIED_on(rx);
1417 off = rx->startp[0] = s - t;
1418 rx->endp[0] = off + rx->minlen;
1419 }
1420 else { /* startp/endp are used by @- @+. */
1421 rx->startp[0] = s - truebase;
1422 rx->endp[0] = s - truebase + rx->minlen;
1423 }
fc19f8d0 1424 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
4633a7c4 1425 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1426 RETPUSHYES;
1427
1428nope:
a0d0e21e 1429ret_no:
c90c0ff4 1430 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1431 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
14befaf4 1432 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1433 if (mg)
565764a8 1434 mg->mg_len = -1;
a0d0e21e
LW
1435 }
1436 }
4633a7c4 1437 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1438 if (gimme == G_ARRAY)
1439 RETURN;
1440 RETPUSHNO;
1441}
1442
1443OP *
864dbfa3 1444Perl_do_readline(pTHX)
a0d0e21e
LW
1445{
1446 dSP; dTARGETSTACKED;
1447 register SV *sv;
1448 STRLEN tmplen = 0;
1449 STRLEN offset;
760ac839 1450 PerlIO *fp;
3280af22 1451 register IO *io = GvIO(PL_last_in_gv);
533c011a 1452 register I32 type = PL_op->op_type;
54310121 1453 I32 gimme = GIMME_V;
e79b0511 1454 MAGIC *mg;
a0d0e21e 1455
5b468f54 1456 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
e79b0511 1457 PUSHMARK(SP);
5b468f54 1458 XPUSHs(SvTIED_obj((SV*)io, mg));
e79b0511
PP
1459 PUTBACK;
1460 ENTER;
864dbfa3 1461 call_method("READLINE", gimme);
e79b0511
PP
1462 LEAVE;
1463 SPAGAIN;
54310121
PP
1464 if (gimme == G_SCALAR)
1465 SvSetMagicSV_nosteal(TARG, TOPs);
e79b0511
PP
1466 RETURN;
1467 }
a0d0e21e
LW
1468 fp = Nullfp;
1469 if (io) {
1470 fp = IoIFP(io);
1471 if (!fp) {
1472 if (IoFLAGS(io) & IOf_ARGV) {
1473 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1474 IoLINES(io) = 0;
3280af22 1475 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1476 IoFLAGS(io) &= ~IOf_START;
9d116dd7 1477 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
3280af22
NIS
1478 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1479 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1480 fp = IoIFP(io);
1481 goto have_fp;
a0d0e21e
LW
1482 }
1483 }
3280af22 1484 fp = nextargv(PL_last_in_gv);
a0d0e21e 1485 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1486 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1487 }
1488 }
0d44d22b
NC
1489 else if (type == OP_GLOB)
1490 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1491 }
1492 else if (type == OP_GLOB)
1493 SP--;
a00b5bd3 1494 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
4c80c0b2 1495 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
a00b5bd3 1496 }
a0d0e21e
LW
1497 }
1498 if (!fp) {
790090df
HS
1499 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1500 && (!io || !(IoFLAGS(io) & IOf_START))) {
3f4520fe 1501 if (type == OP_GLOB)
e476b1b5 1502 Perl_warner(aTHX_ WARN_GLOB,
af8c498a
GS
1503 "glob failed (can't start child: %s)",
1504 Strerror(errno));
69282e91 1505 else
bc37a18f 1506 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
3f4520fe 1507 }
54310121 1508 if (gimme == G_SCALAR) {
a0d0e21e
LW
1509 (void)SvOK_off(TARG);
1510 PUSHTARG;
1511 }
1512 RETURN;
1513 }
a2008d6d 1514 have_fp:
54310121 1515 if (gimme == G_SCALAR) {
a0d0e21e 1516 sv = TARG;
9607fc9c
PP
1517 if (SvROK(sv))
1518 sv_unref(sv);
a0d0e21e
LW
1519 (void)SvUPGRADE(sv, SVt_PV);
1520 tmplen = SvLEN(sv); /* remember if already alloced */
1521 if (!tmplen)
1522 Sv_Grow(sv, 80); /* try short-buffering it */
1523 if (type == OP_RCATLINE)
1524 offset = SvCUR(sv);
1525 else
1526 offset = 0;
1527 }
54310121
PP
1528 else {
1529 sv = sv_2mortal(NEWSV(57, 80));
1530 offset = 0;
1531 }
fbad3eb5 1532
3887d568
AP
1533 /* This should not be marked tainted if the fp is marked clean */
1534#define MAYBE_TAINT_LINE(io, sv) \
1535 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1536 TAINT; \
1537 SvTAINTED_on(sv); \
1538 }
1539
684bef36 1540/* delay EOF state for a snarfed empty file */
fbad3eb5 1541#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1542 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1543 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1544
a0d0e21e 1545 for (;;) {
09e8efcc 1546 PUTBACK;
fbad3eb5
GS
1547 if (!sv_gets(sv, fp, offset)
1548 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1549 {
760ac839 1550 PerlIO_clearerr(fp);
a0d0e21e 1551 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1552 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW
1553 if (fp)
1554 continue;
3280af22 1555 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1556 }
1557 else if (type == OP_GLOB) {
e476b1b5
GS
1558 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1559 Perl_warner(aTHX_ WARN_GLOB,
4eb79ab5 1560 "glob failed (child exited with status %d%s)",
894356b3 1561 (int)(STATUS_CURRENT >> 8),
cf494569 1562 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1563 }
a0d0e21e 1564 }
54310121 1565 if (gimme == G_SCALAR) {
a0d0e21e 1566 (void)SvOK_off(TARG);
09e8efcc 1567 SPAGAIN;
a0d0e21e
LW
1568 PUSHTARG;
1569 }
3887d568 1570 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1571 RETURN;
1572 }
3887d568 1573 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1574 IoLINES(io)++;
b9fee9ba 1575 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1576 SvSETMAGIC(sv);
09e8efcc 1577 SPAGAIN;
a0d0e21e 1578 XPUSHs(sv);
a0d0e21e
LW
1579 if (type == OP_GLOB) {
1580 char *tmps;
1581
3280af22 1582 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
c07a80fd 1583 tmps = SvEND(sv) - 1;
3280af22 1584 if (*tmps == *SvPVX(PL_rs)) {
c07a80fd
PP
1585 *tmps = '\0';
1586 SvCUR(sv)--;
1587 }
1588 }
a0d0e21e
LW
1589 for (tmps = SvPVX(sv); *tmps; tmps++)
1590 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1591 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1592 break;
43384a1a 1593 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1594 (void)POPs; /* Unmatched wildcard? Chuck it... */
1595 continue;
1596 }
1597 }
54310121 1598 if (gimme == G_ARRAY) {
a0d0e21e
LW
1599 if (SvLEN(sv) - SvCUR(sv) > 20) {
1600 SvLEN_set(sv, SvCUR(sv)+1);
1601 Renew(SvPVX(sv), SvLEN(sv), char);
1602 }
1603 sv = sv_2mortal(NEWSV(58, 80));
1604 continue;
1605 }
54310121 1606 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e
LW
1607 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1608 if (SvCUR(sv) < 60)
1609 SvLEN_set(sv, 80);
1610 else
1611 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1612 Renew(SvPVX(sv), SvLEN(sv), char);
1613 }
1614 RETURN;
1615 }
1616}
1617
1618PP(pp_enter)
1619{
39644a26 1620 dSP;
c09156bb 1621 register PERL_CONTEXT *cx;
533c011a 1622 I32 gimme = OP_GIMME(PL_op, -1);
a0d0e21e 1623
54310121
PP
1624 if (gimme == -1) {
1625 if (cxstack_ix >= 0)
1626 gimme = cxstack[cxstack_ix].blk_gimme;
1627 else
1628 gimme = G_SCALAR;
1629 }
a0d0e21e
LW
1630
1631 ENTER;
1632
1633 SAVETMPS;
924508f0 1634 PUSHBLOCK(cx, CXt_BLOCK, SP);
a0d0e21e
LW
1635
1636 RETURN;
1637}
1638
1639PP(pp_helem)
1640{
39644a26 1641 dSP;
760ac839 1642 HE* he;
ae77835f 1643 SV **svp;
a0d0e21e 1644 SV *keysv = POPs;
a0d0e21e 1645 HV *hv = (HV*)POPs;
78f9721b 1646 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
533c011a 1647 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1648 SV *sv;
1c846c1f 1649 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
9c5ffd7c 1650 I32 preeminent = 0;
a0d0e21e 1651
ae77835f 1652 if (SvTYPE(hv) == SVt_PVHV) {
1f5346dc
SC
1653 if (PL_op->op_private & OPpLVAL_INTRO)
1654 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1c846c1f 1655 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
97fcbf96 1656 svp = he ? &HeVAL(he) : 0;
ae77835f
MB
1657 }
1658 else if (SvTYPE(hv) == SVt_PVAV) {
0ebe0038 1659 if (PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 1660 DIE(aTHX_ "Can't localize pseudo-hash element");
1c846c1f 1661 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
ae77835f 1662 }
c750a3ec 1663 else {
a0d0e21e 1664 RETPUSHUNDEF;
c750a3ec 1665 }
a0d0e21e 1666 if (lval) {
3280af22 1667 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
1668 SV* lv;
1669 SV* key2;
2d8e6c8d
GS
1670 if (!defer) {
1671 STRLEN n_a;
cea2e8a9 1672 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 1673 }
68dc0745
PP
1674 lv = sv_newmortal();
1675 sv_upgrade(lv, SVt_PVLV);
1676 LvTYPE(lv) = 'y';
14befaf4 1677 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
1678 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1679 LvTARG(lv) = SvREFCNT_inc(hv);
1680 LvTARGLEN(lv) = 1;
1681 PUSHs(lv);
1682 RETURN;
1683 }
533c011a 1684 if (PL_op->op_private & OPpLVAL_INTRO) {
ae77835f 1685 if (HvNAME(hv) && isGV(*svp))
533c011a 1686 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1f5346dc
SC
1687 else {
1688 if (!preeminent) {
1689 STRLEN keylen;
1690 char *key = SvPV(keysv, keylen);
57813020 1691 SAVEDELETE(hv, savepvn(key,keylen), keylen);
a12c0f56 1692 } else
1f5346dc
SC
1693 save_helem(hv, keysv, svp);
1694 }
5f05dabc 1695 }
533c011a
NIS
1696 else if (PL_op->op_private & OPpDEREF)
1697 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 1698 }
3280af22 1699 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
1700 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1701 * Pushing the magical RHS on to the stack is useless, since
1702 * that magic is soon destined to be misled by the local(),
1703 * and thus the later pp_sassign() will fail to mg_get() the
1704 * old value. This should also cure problems with delayed
1705 * mg_get()s. GSAR 98-07-03 */
1706 if (!lval && SvGMAGICAL(sv))
1707 sv = sv_mortalcopy(sv);
1708 PUSHs(sv);
a0d0e21e
LW
1709 RETURN;
1710}
1711
1712PP(pp_leave)
1713{
39644a26 1714 dSP;
c09156bb 1715 register PERL_CONTEXT *cx;
a0d0e21e
LW
1716 register SV **mark;
1717 SV **newsp;
1718 PMOP *newpm;
1719 I32 gimme;
1720
533c011a 1721 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1722 cx = &cxstack[cxstack_ix];
3280af22 1723 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
a0d0e21e
LW
1724 }
1725
1726 POPBLOCK(cx,newpm);
1727
533c011a 1728 gimme = OP_GIMME(PL_op, -1);
54310121
PP
1729 if (gimme == -1) {
1730 if (cxstack_ix >= 0)
1731 gimme = cxstack[cxstack_ix].blk_gimme;
1732 else
1733 gimme = G_SCALAR;
1734 }
a0d0e21e 1735
a1f49e72 1736 TAINT_NOT;
54310121
PP
1737 if (gimme == G_VOID)
1738 SP = newsp;
1739 else if (gimme == G_SCALAR) {
1740 MARK = newsp + 1;
09256e2f 1741 if (MARK <= SP) {
54310121
PP
1742 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1743 *MARK = TOPs;
1744 else
1745 *MARK = sv_mortalcopy(TOPs);
09256e2f 1746 } else {
54310121 1747 MEXTEND(mark,0);
3280af22 1748 *MARK = &PL_sv_undef;
a0d0e21e 1749 }
54310121 1750 SP = MARK;
a0d0e21e 1751 }
54310121 1752 else if (gimme == G_ARRAY) {
a1f49e72
CS
1753 /* in case LEAVE wipes old return values */
1754 for (mark = newsp + 1; mark <= SP; mark++) {
1755 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 1756 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
1757 TAINT_NOT; /* Each item is independent */
1758 }
1759 }
a0d0e21e 1760 }
3280af22 1761 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW
1762
1763 LEAVE;
1764
1765 RETURN;
1766}
1767
1768PP(pp_iter)
1769{
39644a26 1770 dSP;
c09156bb 1771 register PERL_CONTEXT *cx;
5f05dabc 1772 SV* sv;
4633a7c4 1773 AV* av;
1d7c1841 1774 SV **itersvp;
a0d0e21e 1775
924508f0 1776 EXTEND(SP, 1);
a0d0e21e 1777 cx = &cxstack[cxstack_ix];
6b35e009 1778 if (CxTYPE(cx) != CXt_LOOP)
cea2e8a9 1779 DIE(aTHX_ "panic: pp_iter");
a0d0e21e 1780
1d7c1841 1781 itersvp = CxITERVAR(cx);
4633a7c4 1782 av = cx->blk_loop.iterary;
89ea2908
GA
1783 if (SvTYPE(av) != SVt_PVAV) {
1784 /* iterate ($min .. $max) */
1785 if (cx->blk_loop.iterlval) {
1786 /* string increment */
1787 register SV* cur = cx->blk_loop.iterlval;
1788 STRLEN maxlen;
1789 char *max = SvPV((SV*)av, maxlen);
1790 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
4d1ff10f 1791#ifndef USE_5005THREADS /* don't risk potential race */
1d7c1841 1792 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1793 /* safe to reuse old SV */
1d7c1841 1794 sv_setsv(*itersvp, cur);
eaa5c2d6 1795 }
1c846c1f 1796 else
eaa5c2d6
GA
1797#endif
1798 {
1799 /* we need a fresh SV every time so that loop body sees a
1800 * completely new SV for closures/references to work as
1801 * they used to */
1d7c1841
GS
1802 SvREFCNT_dec(*itersvp);
1803 *itersvp = newSVsv(cur);
eaa5c2d6 1804 }
89ea2908
GA
1805 if (strEQ(SvPVX(cur), max))
1806 sv_setiv(cur, 0); /* terminate next time */
1807 else
1808 sv_inc(cur);
1809 RETPUSHYES;
1810 }
1811 RETPUSHNO;
1812 }
1813 /* integer increment */
1814 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1815 RETPUSHNO;
7f61b687 1816
4d1ff10f 1817#ifndef USE_5005THREADS /* don't risk potential race */
1d7c1841 1818 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1819 /* safe to reuse old SV */
1d7c1841 1820 sv_setiv(*itersvp, cx->blk_loop.iterix++);
eaa5c2d6 1821 }
1c846c1f 1822 else
eaa5c2d6
GA
1823#endif
1824 {
1825 /* we need a fresh SV every time so that loop body sees a
1826 * completely new SV for closures/references to work as they
1827 * used to */
1d7c1841
GS
1828 SvREFCNT_dec(*itersvp);
1829 *itersvp = newSViv(cx->blk_loop.iterix++);
eaa5c2d6 1830 }
89ea2908
GA
1831 RETPUSHYES;
1832 }
1833
1834 /* iterate array */
3280af22 1835 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
4633a7c4 1836 RETPUSHNO;
a0d0e21e 1837
1d7c1841 1838 SvREFCNT_dec(*itersvp);
a0d0e21e 1839
d42935ef
JH
1840 if (SvMAGICAL(av) || AvREIFY(av)) {
1841 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1842 if (svp)
1843 sv = *svp;
1844 else
1845 sv = Nullsv;
1846 }
1847 else {
1848 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1849 }
1850 if (sv)
a0d0e21e 1851 SvTEMP_off(sv);
a0d0e21e 1852 else
3280af22 1853 sv = &PL_sv_undef;
8b530633 1854 if (av != PL_curstack && sv == &PL_sv_undef) {
5f05dabc 1855 SV *lv = cx->blk_loop.iterlval;
71be2cbc
PP
1856 if (lv && SvREFCNT(lv) > 1) {
1857 SvREFCNT_dec(lv);
1858 lv = Nullsv;
1859 }
5f05dabc
PP
1860 if (lv)
1861 SvREFCNT_dec(LvTARG(lv));
1862 else {
68dc0745 1863 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
5f05dabc 1864 sv_upgrade(lv, SVt_PVLV);
5f05dabc 1865 LvTYPE(lv) = 'y';
14befaf4 1866 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
5f05dabc
PP
1867 }
1868 LvTARG(lv) = SvREFCNT_inc(av);
1869 LvTARGOFF(lv) = cx->blk_loop.iterix;
42718184 1870 LvTARGLEN(lv) = (STRLEN)UV_MAX;
5f05dabc
PP
1871 sv = (SV*)lv;
1872 }
a0d0e21e 1873
1d7c1841 1874 *itersvp = SvREFCNT_inc(sv);
a0d0e21e
LW
1875 RETPUSHYES;
1876}
1877
1878PP(pp_subst)
1879{
39644a26 1880 dSP; dTARG;
a0d0e21e
LW
1881 register PMOP *pm = cPMOP;
1882 PMOP *rpm = pm;
1883 register SV *dstr;
1884 register char *s;
1885 char *strend;
1886 register char *m;
1887 char *c;
1888 register char *d;
1889 STRLEN clen;
1890 I32 iters = 0;
1891 I32 maxiters;
1892 register I32 i;
1893 bool once;
71be2cbc 1894 bool rxtainted;
a0d0e21e 1895 char *orig;
22e551b9 1896 I32 r_flags;
aaa362c4 1897 register REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
1898 STRLEN len;
1899 int force_on_match = 0;
3280af22 1900 I32 oldsave = PL_savestack_ix;
792b2c16 1901 STRLEN slen;
a0d0e21e 1902
5cd24f17
PP
1903 /* known replacement string? */
1904 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
533c011a 1905 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1906 TARG = POPs;
1907 else {
54b9620d 1908 TARG = DEFSV;
a0d0e21e 1909 EXTEND(SP,1);
1c846c1f 1910 }
d9f424b2 1911
eca06228
NIS
1912 if (SvFAKE(TARG) && SvREADONLY(TARG))
1913 sv_force_normal(TARG);
68dc0745
PP
1914 if (SvREADONLY(TARG)
1915 || (SvTYPE(TARG) > SVt_PVLV
1916 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
d470f89e 1917 DIE(aTHX_ PL_no_modify);
8ec5e241
NIS
1918 PUTBACK;
1919
a0d0e21e 1920 s = SvPV(TARG, len);
68dc0745 1921 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 1922 force_on_match = 1;
b3eb6a9b 1923 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22
NIS
1924 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1925 if (PL_tainted)
b3eb6a9b 1926 rxtainted |= 2;
9212bbba 1927 TAINT_NOT;
a12c0f56 1928
53c4c00c 1929 PL_reg_match_utf8 = DO_UTF8(TARG);
d9f424b2 1930
a0d0e21e
LW
1931 force_it:
1932 if (!pm || !s)
2269b42e 1933 DIE(aTHX_ "panic: pp_subst");
a0d0e21e
LW
1934
1935 strend = s + len;
53c4c00c 1936 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
1937 maxiters = 2 * slen + 10; /* We can match twice at each
1938 position, once with zero-length,
1939 second time with non-zero. */
a0d0e21e 1940
3280af22
NIS
1941 if (!rx->prelen && PL_curpm) {
1942 pm = PL_curpm;
aaa362c4 1943 rx = PM_GETRE(pm);
a0d0e21e 1944 }
22e551b9 1945 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
9d080a66 1946 ? REXEC_COPY_STR : 0;
f722798b 1947 if (SvSCREAM(TARG))
22e551b9 1948 r_flags |= REXEC_SCREAM;
a0d0e21e 1949 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS
1950 SAVEINT(PL_multiline);
1951 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
a0d0e21e
LW
1952 }
1953 orig = m = s;
f722798b 1954 if (rx->reganch & RE_USE_INTUIT) {
ee0b7718 1955 PL_bostr = orig;
f722798b
IZ
1956 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1957
1958 if (!s)
1959 goto nope;
1960 /* How to do it in subst? */
1961/* if ( (rx->reganch & ROPT_CHECK_ALL)
1c846c1f 1962 && !PL_sawampersand
f722798b
IZ
1963 && ((rx->reganch & ROPT_NOSCAN)
1964 || !((rx->reganch & RE_INTUIT_TAIL)
1965 && (r_flags & REXEC_SCREAM))))
1966 goto yup;
1967*/
a0d0e21e 1968 }
71be2cbc
PP
1969
1970 /* only replace once? */
a0d0e21e 1971 once = !(rpm->op_pmflags & PMf_GLOBAL);
71be2cbc
PP
1972
1973 /* known replacement string? */
5cd24f17 1974 c = dstr ? SvPV(dstr, clen) : Nullch;
71be2cbc
PP
1975
1976 /* can do inplace substitution? */
22e551b9 1977 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
d9f97599 1978 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
f722798b
IZ
1979 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1980 r_flags | REXEC_CHECKED))
1981 {
8ec5e241 1982 SPAGAIN;
3280af22 1983 PUSHs(&PL_sv_no);
71be2cbc
PP
1984 LEAVE_SCOPE(oldsave);
1985 RETURN;
1986 }
1987 if (force_on_match) {
1988 force_on_match = 0;
1989 s = SvPV_force(TARG, len);
1990 goto force_it;
1991 }
71be2cbc 1992 d = s;
3280af22 1993 PL_curpm = pm;
71be2cbc
PP
1994 SvSCREAM_off(TARG); /* disable possible screamer */
1995 if (once) {
48c036b1 1996 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d
IZ
1997 m = orig + rx->startp[0];
1998 d = orig + rx->endp[0];
71be2cbc
PP
1999 s = orig;
2000 if (m - s > strend - d) { /* faster to shorten from end */
2001 if (clen) {
2002 Copy(c, m, clen, char);
2003 m += clen;
a0d0e21e 2004 }
71be2cbc
PP
2005 i = strend - d;
2006 if (i > 0) {
2007 Move(d, m, i, char);
2008 m += i;
a0d0e21e 2009 }
71be2cbc
PP
2010 *m = '\0';
2011 SvCUR_set(TARG, m - s);
2012 }
2013 /*SUPPRESS 560*/
155aba94 2014 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
2015 d -= clen;
2016 m = d;
2017 sv_chop(TARG, d-i);
2018 s += i;
2019 while (i--)
2020 *--d = *--s;
2021 if (clen)
2022 Copy(c, m, clen, char);
2023 }
2024 else if (clen) {
2025 d -= clen;
2026 sv_chop(TARG, d);
2027 Copy(c, d, clen, char);
2028 }
2029 else {
2030 sv_chop(TARG, d);
2031 }
48c036b1 2032 TAINT_IF(rxtainted & 1);
8ec5e241 2033 SPAGAIN;
3280af22 2034 PUSHs(&PL_sv_yes);
71be2cbc
PP
2035 }
2036 else {
71be2cbc
PP
2037 do {
2038 if (iters++ > maxiters)
cea2e8a9 2039 DIE(aTHX_ "Substitution loop");
d9f97599 2040 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2041 m = rx->startp[0] + orig;
71be2cbc 2042 /*SUPPRESS 560*/
155aba94 2043 if ((i = m - s)) {
71be2cbc
PP
2044 if (s != d)
2045 Move(s, d, i, char);
2046 d += i;
a0d0e21e 2047 }
71be2cbc
PP
2048 if (clen) {
2049 Copy(c, d, clen, char);
2050 d += clen;
2051 }
cf93c79d 2052 s = rx->endp[0] + orig;
cea2e8a9 2053 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
f722798b
IZ
2054 TARG, NULL,
2055 /* don't match same null twice */
2056 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
2057 if (s != d) {
2058 i = strend - s;
2059 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2060 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2061 }
48c036b1 2062 TAINT_IF(rxtainted & 1);
8ec5e241 2063 SPAGAIN;
71be2cbc 2064 PUSHs(sv_2mortal(newSViv((I32)iters)));
a0d0e21e 2065 }
80b498e0 2066 (void)SvPOK_only_UTF8(TARG);
48c036b1 2067 TAINT_IF(rxtainted);
8ec5e241
NIS
2068 if (SvSMAGICAL(TARG)) {
2069 PUTBACK;
2070 mg_set(TARG);
2071 SPAGAIN;
2072 }
9212bbba 2073 SvTAINT(TARG);
71be2cbc
PP
2074 LEAVE_SCOPE(oldsave);
2075 RETURN;
a0d0e21e 2076 }
71be2cbc 2077
f722798b
IZ
2078 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2079 r_flags | REXEC_CHECKED))
2080 {
60aeb6fd
NIS
2081 bool isutf8;
2082
a0d0e21e
LW
2083 if (force_on_match) {
2084 force_on_match = 0;
2085 s = SvPV_force(TARG, len);
2086 goto force_it;
2087 }
48c036b1 2088 rxtainted |= RX_MATCH_TAINTED(rx);
8ec5e241 2089 dstr = NEWSV(25, len);
a0d0e21e 2090 sv_setpvn(dstr, m, s-m);
ffc61ed2
JH
2091 if (DO_UTF8(TARG))
2092 SvUTF8_on(dstr);
3280af22 2093 PL_curpm = pm;
a0d0e21e 2094 if (!c) {
c09156bb 2095 register PERL_CONTEXT *cx;
8ec5e241 2096 SPAGAIN;
a0d0e21e
LW
2097 PUSHSUBST(cx);
2098 RETURNOP(cPMOP->op_pmreplroot);
2099 }
cf93c79d 2100 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2101 do {
2102 if (iters++ > maxiters)
cea2e8a9 2103 DIE(aTHX_ "Substitution loop");
d9f97599 2104 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2105 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW
2106 m = s;
2107 s = orig;
cf93c79d 2108 orig = rx->subbeg;
a0d0e21e
LW
2109 s = orig + (m - s);
2110 strend = s + (strend - m);
2111 }
cf93c79d 2112 m = rx->startp[0] + orig;
a0d0e21e 2113 sv_catpvn(dstr, s, m-s);
cf93c79d 2114 s = rx->endp[0] + orig;
a0d0e21e
LW
2115 if (clen)
2116 sv_catpvn(dstr, c, clen);
2117 if (once)
2118 break;
ffc61ed2
JH
2119 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2120 TARG, NULL, r_flags));
a0d0e21e 2121 sv_catpvn(dstr, s, strend - s);
748a9306 2122
4633a7c4 2123 (void)SvOOK_off(TARG);
cb0b1708 2124 Safefree(SvPVX(TARG));
748a9306
LW
2125 SvPVX(TARG) = SvPVX(dstr);
2126 SvCUR_set(TARG, SvCUR(dstr));
2127 SvLEN_set(TARG, SvLEN(dstr));
60aeb6fd 2128 isutf8 = DO_UTF8(dstr);
748a9306
LW
2129 SvPVX(dstr) = 0;
2130 sv_free(dstr);
2131
48c036b1 2132 TAINT_IF(rxtainted & 1);
f878fbec 2133 SPAGAIN;
48c036b1
GS
2134 PUSHs(sv_2mortal(newSViv((I32)iters)));
2135
a0d0e21e 2136 (void)SvPOK_only(TARG);
60aeb6fd
NIS
2137 if (isutf8)
2138 SvUTF8_on(TARG);
48c036b1 2139 TAINT_IF(rxtainted);
a0d0e21e 2140 SvSETMAGIC(TARG);
9212bbba 2141 SvTAINT(TARG);
4633a7c4 2142 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2143 RETURN;
2144 }
5cd24f17 2145 goto ret_no;
a0d0e21e
LW
2146
2147nope:
1c846c1f 2148ret_no:
8ec5e241 2149 SPAGAIN;
3280af22 2150 PUSHs(&PL_sv_no);
4633a7c4 2151 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2152 RETURN;
2153}
2154
2155PP(pp_grepwhile)
2156{
39644a26 2157 dSP;
a0d0e21e
LW
2158
2159 if (SvTRUEx(POPs))
3280af22
NIS
2160 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2161 ++*PL_markstack_ptr;
a0d0e21e
LW
2162 LEAVE; /* exit inner scope */
2163
2164 /* All done yet? */
3280af22 2165 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2166 I32 items;
54310121 2167 I32 gimme = GIMME_V;
a0d0e21e
LW
2168
2169 LEAVE; /* exit outer scope */
2170 (void)POPMARK; /* pop src */
3280af22 2171 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2172 (void)POPMARK; /* pop dst */
3280af22 2173 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2174 if (gimme == G_SCALAR) {
a0d0e21e
LW
2175 dTARGET;
2176 XPUSHi(items);
a0d0e21e 2177 }
54310121
PP
2178 else if (gimme == G_ARRAY)
2179 SP += items;
a0d0e21e
LW
2180 RETURN;
2181 }
2182 else {
2183 SV *src;
2184
2185 ENTER; /* enter inner scope */
1d7c1841 2186 SAVEVPTR(PL_curpm);
a0d0e21e 2187
3280af22 2188 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2189 SvTEMP_off(src);
54b9620d 2190 DEFSV = src;
a0d0e21e
LW
2191
2192 RETURNOP(cLOGOP->op_other);
2193 }
2194}
2195
2196PP(pp_leavesub)
2197{
39644a26 2198 dSP;
a0d0e21e
LW
2199 SV **mark;
2200 SV **newsp;
2201 PMOP *newpm;
2202 I32 gimme;
c09156bb 2203 register PERL_CONTEXT *cx;
b0d9ce38 2204 SV *sv;
a0d0e21e
LW
2205
2206 POPBLOCK(cx,newpm);
1c846c1f 2207
a1f49e72 2208 TAINT_NOT;
a0d0e21e
LW
2209 if (gimme == G_SCALAR) {
2210 MARK = newsp + 1;
a29cdaf0 2211 if (MARK <= SP) {
a8bba7fa 2212 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2213 if (SvTEMP(TOPs)) {
2214 *MARK = SvREFCNT_inc(TOPs);
2215 FREETMPS;
2216 sv_2mortal(*MARK);
cd06dffe
GS
2217 }
2218 else {
959e3673 2219 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2220 FREETMPS;
959e3673
GS
2221 *MARK = sv_mortalcopy(sv);
2222 SvREFCNT_dec(sv);
a29cdaf0 2223 }
cd06dffe
GS
2224 }
2225 else
a29cdaf0 2226 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS
2227 }
2228 else {
f86702cc 2229 MEXTEND(MARK, 0);
3280af22 2230 *MARK = &PL_sv_undef;
a0d0e21e
LW
2231 }
2232 SP = MARK;
2233 }
54310121 2234 else if (gimme == G_ARRAY) {
f86702cc 2235 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2236 if (!SvTEMP(*MARK)) {
f86702cc 2237 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2238 TAINT_NOT; /* Each item is independent */
2239 }
f86702cc 2240 }
a0d0e21e 2241 }
f86702cc 2242 PUTBACK;
1c846c1f 2243
b0d9ce38 2244 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2245 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW
2246
2247 LEAVE;
b0d9ce38 2248 LEAVESUB(sv);
a0d0e21e
LW
2249 return pop_return();
2250}
2251
cd06dffe
GS
2252/* This duplicates the above code because the above code must not
2253 * get any slower by more conditions */
2254PP(pp_leavesublv)
2255{
39644a26 2256 dSP;
cd06dffe
GS
2257 SV **mark;
2258 SV **newsp;
2259 PMOP *newpm;
2260 I32 gimme;
2261 register PERL_CONTEXT *cx;
b0d9ce38 2262 SV *sv;
cd06dffe
GS
2263
2264 POPBLOCK(cx,newpm);
1c846c1f 2265
cd06dffe
GS
2266 TAINT_NOT;
2267
2268 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2269 /* We are an argument to a function or grep().
2270 * This kind of lvalueness was legal before lvalue
2271 * subroutines too, so be backward compatible:
2272 * cannot report errors. */
2273
2274 /* Scalar context *is* possible, on the LHS of -> only,
2275 * as in f()->meth(). But this is not an lvalue. */
2276 if (gimme == G_SCALAR)
2277 goto temporise;
2278 if (gimme == G_ARRAY) {
a8bba7fa 2279 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS
2280 goto temporise_array;
2281 EXTEND_MORTAL(SP - newsp);
2282 for (mark = newsp + 1; mark <= SP; mark++) {
2283 if (SvTEMP(*mark))
2284 /* empty */ ;
2285 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2286 *mark = sv_mortalcopy(*mark);
2287 else {
2288 /* Can be a localized value subject to deletion. */
2289 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2290 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2291 }
2292 }
2293 }
2294 }
2295 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2296 /* Here we go for robustness, not for speed, so we change all
2297 * the refcounts so the caller gets a live guy. Cannot set
2298 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2299 if (!CvLVALUE(cx->blk_sub.cv)) {
b0d9ce38 2300 POPSUB(cx,sv);
d470f89e 2301 PL_curpm = newpm;
b0d9ce38
GS
2302 LEAVE;
2303 LEAVESUB(sv);
d470f89e
GS
2304 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2305 }
cd06dffe
GS
2306 if (gimme == G_SCALAR) {
2307 MARK = newsp + 1;
2308 EXTEND_MORTAL(1);
2309 if (MARK == SP) {
d470f89e 2310 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
b0d9ce38 2311 POPSUB(cx,sv);
d470f89e 2312 PL_curpm = newpm;
b0d9ce38
GS
2313 LEAVE;
2314 LEAVESUB(sv);
d470f89e 2315 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
cd06dffe 2316 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2317 }
cd06dffe
GS
2318 else { /* Can be a localized value
2319 * subject to deletion. */
2320 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2321 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2322 }
2323 }
d470f89e 2324 else { /* Should not happen? */
b0d9ce38 2325 POPSUB(cx,sv);
d470f89e 2326 PL_curpm = newpm;
b0d9ce38
GS
2327 LEAVE;
2328 LEAVESUB(sv);
d470f89e 2329 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
cd06dffe 2330 (MARK > SP ? "Empty array" : "Array"));
d470f89e 2331 }
cd06dffe
GS
2332 SP = MARK;
2333 }
2334 else if (gimme == G_ARRAY) {
2335 EXTEND_MORTAL(SP - newsp);
2336 for (mark = newsp + 1; mark <= SP; mark++) {
f206cdda
AMS
2337 if (*mark != &PL_sv_undef
2338 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
d470f89e
GS
2339 /* Might be flattened array after $#array = */
2340 PUTBACK;
b0d9ce38 2341 POPSUB(cx,sv);
d470f89e 2342 PL_curpm = newpm;
b0d9ce38
GS
2343 LEAVE;
2344 LEAVESUB(sv);
f206cdda
AMS
2345 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2346 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2347 }
cd06dffe 2348 else {
cd06dffe
GS
2349 /* Can be a localized value subject to deletion. */
2350 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2351 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2352 }
2353 }
2354 }
2355 }
2356 else {
2357 if (gimme == G_SCALAR) {
2358 temporise:
2359 MARK = newsp + 1;
2360 if (MARK <= SP) {
a8bba7fa 2361 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS
2362 if (SvTEMP(TOPs)) {
2363 *MARK = SvREFCNT_inc(TOPs);
2364 FREETMPS;
2365 sv_2mortal(*MARK);
2366 }
2367 else {
959e3673 2368 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2369 FREETMPS;
959e3673
GS
2370 *MARK = sv_mortalcopy(sv);
2371 SvREFCNT_dec(sv);
cd06dffe
GS
2372 }
2373 }
2374 else
2375 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2376 }
2377 else {
2378 MEXTEND(MARK, 0);
2379 *MARK = &PL_sv_undef;
2380 }
2381 SP = MARK;
2382 }
2383 else if (gimme == G_ARRAY) {
2384 temporise_array:
2385 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2386 if (!SvTEMP(*MARK)) {
2387 *MARK = sv_mortalcopy(*MARK);
2388 TAINT_NOT; /* Each item is independent */
2389 }
2390 }
2391 }
2392 }
2393 PUTBACK;
1c846c1f 2394
b0d9ce38 2395 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS
2396 PL_curpm = newpm; /* ... and pop $1 et al */
2397
2398 LEAVE;
b0d9ce38 2399 LEAVESUB(sv);
cd06dffe
GS
2400 return pop_return();
2401}
2402
2403
76e3520e 2404STATIC CV *
cea2e8a9 2405S_get_db_sub(pTHX_ SV **svp, CV *cv)
3de9ffa1 2406{
3280af22 2407 SV *dbsv = GvSV(PL_DBsub);
491527d0
GS
2408
2409 if (!PERLDB_SUB_NN) {
2410 GV *gv = CvGV(cv);
2411
2412 save_item(dbsv);
2413 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1c846c1f 2414 || strEQ(GvNAME(gv), "END")
491527d0
GS
2415 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2416 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2417 && (gv = (GV*)*svp) ))) {
2418 /* Use GV from the stack as a fallback. */
2419 /* GV is potentially non-unique, or contain different CV. */
c2e66d9e
GS
2420 SV *tmp = newRV((SV*)cv);
2421 sv_setsv(dbsv, tmp);
2422 SvREFCNT_dec(tmp);
491527d0
GS
2423 }
2424 else {
2425 gv_efullname3(dbsv, gv, Nullch);
2426 }
3de9ffa1
MB
2427 }
2428 else {
155aba94
GS
2429 (void)SvUPGRADE(dbsv, SVt_PVIV);
2430 (void)SvIOK_on(dbsv);
491527d0 2431 SAVEIV(SvIVX(dbsv));
5bc28da9 2432 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
3de9ffa1 2433 }
491527d0 2434
3de9ffa1 2435 if (CvXSUB(cv))
3280af22
NIS
2436 PL_curcopdb = PL_curcop;
2437 cv = GvCV(PL_DBsub);
3de9ffa1
MB
2438 return cv;
2439}
2440
a0d0e21e
LW
2441PP(pp_entersub)
2442{
39644a26 2443 dSP; dPOPss;
a0d0e21e
LW
2444 GV *gv;
2445 HV *stash;
2446 register CV *cv;
c09156bb 2447 register PERL_CONTEXT *cx;
5d94fbed 2448 I32 gimme;
533c011a 2449 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2450
2451 if (!sv)
cea2e8a9 2452 DIE(aTHX_ "Not a CODE reference");
a0d0e21e
LW
2453 switch (SvTYPE(sv)) {
2454 default:
2455 if (!SvROK(sv)) {
748a9306 2456 char *sym;
2d8e6c8d 2457 STRLEN n_a;
748a9306 2458
3280af22 2459 if (sv == &PL_sv_yes) { /* unfound import, ignore */
fb73857a 2460 if (hasargs)
3280af22 2461 SP = PL_stack_base + POPMARK;
a0d0e21e 2462 RETURN;
fb73857a 2463 }
15ff848f
CS
2464 if (SvGMAGICAL(sv)) {
2465 mg_get(sv);
f5f1d18e
AMS
2466 if (SvROK(sv))
2467 goto got_rv;
15ff848f
CS
2468 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2469 }
2470 else
2d8e6c8d 2471 sym = SvPV(sv, n_a);
15ff848f 2472 if (!sym)
cea2e8a9 2473 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2474 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 2475 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
864dbfa3 2476 cv = get_cv(sym, TRUE);
a0d0e21e
LW
2477 break;
2478 }
f5f1d18e 2479 got_rv:
f5284f61
IZ
2480 {
2481 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2482 tryAMAGICunDEREF(to_cv);
2483 }
a0d0e21e
LW
2484 cv = (CV*)SvRV(sv);
2485 if (SvTYPE(cv) == SVt_PVCV)
2486 break;
2487 /* FALL THROUGH */
2488 case SVt_PVHV:
2489 case SVt_PVAV:
cea2e8a9 2490 DIE(aTHX_ "Not a CODE reference");
a0d0e21e
LW
2491 case SVt_PVCV:
2492 cv = (CV*)sv;
2493 break;
2494 case SVt_PVGV:
8ebc5c01 2495 if (!(cv = GvCVu((GV*)sv)))
f6ec51f7
GS
2496 cv = sv_2cv(sv, &stash, &gv, FALSE);
2497 if (!cv) {
2498 ENTER;
2499 SAVETMPS;
2500 goto try_autoload;
2501 }
2502 break;
a0d0e21e
LW
2503 }
2504
2505 ENTER;
2506 SAVETMPS;
2507
2508 retry:
a0d0e21e 2509 if (!CvROOT(cv) && !CvXSUB(cv)) {
44a8e56a 2510 GV* autogv;
22239a37 2511 SV* sub_name;
44a8e56a
PP
2512
2513 /* anonymous or undef'd function leaves us no recourse */
2514 if (CvANON(cv) || !(gv = CvGV(cv)))
cea2e8a9 2515 DIE(aTHX_ "Undefined subroutine called");
67caa1fe 2516
44a8e56a
PP
2517 /* autoloaded stub? */
2518 if (cv != GvCV(gv)) {
2519 cv = GvCV(gv);
a0d0e21e 2520 }
44a8e56a 2521 /* should call AUTOLOAD now? */
67caa1fe 2522 else {
f6ec51f7
GS
2523try_autoload:
2524 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2525 FALSE)))
2526 {
2527 cv = GvCV(autogv);
2528 }
2529 /* sorry */
2530 else {
2531 sub_name = sv_newmortal();
2532 gv_efullname3(sub_name, gv, Nullch);
cea2e8a9 2533 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
f6ec51f7 2534 }
67caa1fe
GS
2535 }
2536 if (!cv)
cea2e8a9 2537 DIE(aTHX_ "Not a CODE reference");
67caa1fe 2538 goto retry;
a0d0e21e
LW
2539 }
2540
54310121 2541 gimme = GIMME_V;
67caa1fe 2542 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
4f01c5a5 2543 cv = get_db_sub(&sv, cv);
67caa1fe 2544 if (!cv)
cea2e8a9 2545 DIE(aTHX_ "No DBsub routine");
67caa1fe 2546 }
a0d0e21e 2547
4d1ff10f 2548#ifdef USE_5005THREADS
3de9ffa1
MB
2549 /*
2550 * First we need to check if the sub or method requires locking.
458fb581
MB
2551 * If so, we gain a lock on the CV, the first argument or the
2552 * stash (for static methods), as appropriate. This has to be
2553 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2554 * reschedule by returning a new op.
3de9ffa1 2555 */
11343788 2556 MUTEX_LOCK(CvMUTEXP(cv));
77a005ab
MB
2557 if (CvFLAGS(cv) & CVf_LOCKED) {
2558 MAGIC *mg;
2559 if (CvFLAGS(cv) & CVf_METHOD) {
533c011a
NIS
2560 if (SP > PL_stack_base + TOPMARK)
2561 sv = *(PL_stack_base + TOPMARK + 1);
77a005ab 2562 else {
13e08037
GS
2563 AV *av = (AV*)PL_curpad[0];
2564 if (hasargs || !av || AvFILLp(av) < 0
2565 || !(sv = AvARRAY(av)[0]))
2566 {
2567 MUTEX_UNLOCK(CvMUTEXP(cv));
d470f89e 2568 DIE(aTHX_ "no argument for locked method call");
13e08037 2569 }
77a005ab
MB
2570 }
2571 if (SvROK(sv))
2572 sv = SvRV(sv);
458fb581
MB
2573 else {
2574 STRLEN len;
2575 char *stashname = SvPV(sv, len);
2576 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2577 }
77a005ab
MB
2578 }
2579 else {
2580 sv = (SV*)cv;
2581 }
2582 MUTEX_UNLOCK(CvMUTEXP(cv));
2583 mg = condpair_magic(sv);
2584 MUTEX_LOCK(MgMUTEXP(mg));
2585 if (MgOWNER(mg) == thr)
2586 MUTEX_UNLOCK(MgMUTEXP(mg));
2587 else {
2588 while (MgOWNER(mg))
2589 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2590 MgOWNER(mg) = thr;
bf49b057 2591 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
a674cc95 2592 thr, sv));
77a005ab 2593 MUTEX_UNLOCK(MgMUTEXP(mg));
c76ac1ee 2594 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
11343788 2595 }
77a005ab 2596 MUTEX_LOCK(CvMUTEXP(cv));
11343788 2597 }
3de9ffa1
MB
2598 /*
2599 * Now we have permission to enter the sub, we must distinguish
2600 * four cases. (0) It's an XSUB (in which case we don't care
2601 * about ownership); (1) it's ours already (and we're recursing);
2602 * (2) it's free (but we may already be using a cached clone);
2603 * (3) another thread owns it. Case (1) is easy: we just use it.
2604 * Case (2) means we look for a clone--if we have one, use it
2605 * otherwise grab ownership of cv. Case (3) means we look for a
2606 * clone (for non-XSUBs) and have to create one if we don't
2607 * already have one.
2608 * Why look for a clone in case (2) when we could just grab
2609 * ownership of cv straight away? Well, we could be recursing,
2610 * i.e. we originally tried to enter cv while another thread
2611 * owned it (hence we used a clone) but it has been freed up
2612 * and we're now recursing into it. It may or may not be "better"
2613 * to use the clone but at least CvDEPTH can be trusted.
2614 */
2615 if (CvOWNER(cv) == thr || CvXSUB(cv))
2616 MUTEX_UNLOCK(CvMUTEXP(cv));
11343788 2617 else {
3de9ffa1
MB
2618 /* Case (2) or (3) */
2619 SV **svp;
2620
11343788 2621 /*
3de9ffa1
MB
2622 * XXX Might it be better to release CvMUTEXP(cv) while we
2623 * do the hv_fetch? We might find someone has pinched it
2624 * when we look again, in which case we would be in case
2625 * (3) instead of (2) so we'd have to clone. Would the fact
2626 * that we released the mutex more quickly make up for this?
2627 */
b099ddc0 2628 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
6ee623d5 2629 {
3de9ffa1 2630 /* We already have a clone to use */
11343788 2631 MUTEX_UNLOCK(CvMUTEXP(cv));
3de9ffa1 2632 cv = *(CV**)svp;
bf49b057 2633 DEBUG_S(PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2634 "entersub: %p already has clone %p:%s\n",
2635 thr, cv, SvPEEK((SV*)cv)));
3de9ffa1
MB
2636 CvOWNER(cv) = thr;
2637 SvREFCNT_inc(cv);
2638 if (CvDEPTH(cv) == 0)
c76ac1ee 2639 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
3de9ffa1 2640 }
11343788 2641 else {
3de9ffa1
MB
2642 /* (2) => grab ownership of cv. (3) => make clone */
2643 if (!CvOWNER(cv)) {
2644 CvOWNER(cv) = thr;
2645 SvREFCNT_inc(cv);
11343788 2646 MUTEX_UNLOCK(CvMUTEXP(cv));
bf49b057 2647 DEBUG_S(PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2648 "entersub: %p grabbing %p:%s in stash %s\n",
2649 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
3de9ffa1 2650 HvNAME(CvSTASH(cv)) : "(none)"));
cd06dffe
GS
2651 }
2652 else {
3de9ffa1
MB
2653 /* Make a new clone. */
2654 CV *clonecv;
2655 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2656 MUTEX_UNLOCK(CvMUTEXP(cv));
bf49b057 2657 DEBUG_S((PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2658 "entersub: %p cloning %p:%s\n",
2659 thr, cv, SvPEEK((SV*)cv))));
3de9ffa1
MB
2660 /*
2661 * We're creating a new clone so there's no race
2662 * between the original MUTEX_UNLOCK and the
2663 * SvREFCNT_inc since no one will be trying to undef
2664 * it out from underneath us. At least, I don't think
2665 * there's a race...
2666 */
2667 clonecv = cv_clone(cv);
2668 SvREFCNT_dec(cv); /* finished with this */
199100c8 2669 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
3de9ffa1
MB
2670 CvOWNER(clonecv) = thr;
2671 cv = clonecv;
11343788 2672 SvREFCNT_inc(cv);
11343788 2673 }
8b73bbec 2674 DEBUG_S(if (CvDEPTH(cv) != 0)
bf49b057 2675 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
755b0776 2676 CvDEPTH(cv)));
c76ac1ee 2677 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
11343788 2678 }
3de9ffa1 2679 }
4d1ff10f 2680#endif /* USE_5005THREADS */
11343788 2681
a0d0e21e 2682 if (CvXSUB(cv)) {
67caa1fe 2683#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2684 if (CvOLDSTYLE(cv)) {
20ce7b12 2685 I32 (*fp3)(int,int,int);
a0d0e21e
LW
2686 dMARK;
2687 register I32 items = SP - MARK;
67955e0c 2688 /* We dont worry to copy from @_. */
924508f0
GS
2689 while (SP > mark) {
2690 SP[1] = SP[0];
2691 SP--;
a0d0e21e 2692 }
3280af22 2693 PL_stack_sp = mark + 1;
1d7c1841 2694 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
1c846c1f 2695 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2696 MARK - PL_stack_base + 1,
ecfc5424 2697 items);
3280af22 2698 PL_stack_sp = PL_stack_base + items;
a0d0e21e 2699 }
67caa1fe
GS
2700 else
2701#endif /* PERL_XSUB_OLDSTYLE */
2702 {
748a9306
LW
2703 I32 markix = TOPMARK;
2704
a0d0e21e 2705 PUTBACK;
67955e0c
PP
2706
2707 if (!hasargs) {
2708 /* Need to copy @_ to stack. Alternative may be to
2709 * switch stack to @_, and copy return values
2710 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
6d4ff0d2
MB
2711 AV* av;
2712 I32 items;
4d1ff10f 2713#ifdef USE_5005THREADS
533c011a 2714 av = (AV*)PL_curpad[0];
6d4ff0d2 2715#else
3280af22 2716 av = GvAV(PL_defgv);
4d1ff10f 2717#endif /* USE_5005THREADS */
93965878 2718 items = AvFILLp(av) + 1; /* @_ is not tieable */
67955e0c
PP
2719
2720 if (items) {
2721 /* Mark is at the end of the stack. */
924508f0
GS
2722 EXTEND(SP, items);
2723 Copy(AvARRAY(av), SP + 1, items, SV*);
2724 SP += items;
1c846c1f 2725 PUTBACK ;
67955e0c
PP
2726 }
2727 }
67caa1fe
GS
2728 /* We assume first XSUB in &DB::sub is the called one. */
2729 if (PL_curcopdb) {
1d7c1841 2730 SAVEVPTR(PL_curcop);
3280af22
NIS
2731 PL_curcop = PL_curcopdb;
2732 PL_curcopdb = NULL;
67955e0c
PP
2733 }
2734 /* Do we need to open block here? XXXX */
acfe0abc 2735 (void)(*CvXSUB(cv))(aTHX_ cv);
748a9306
LW
2736
2737 /* Enforce some sanity in scalar context. */
3280af22
NIS
2738 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2739 if (markix > PL_stack_sp - PL_stack_base)
2740 *(PL_stack_base + markix) = &PL_sv_undef;
748a9306 2741 else
3280af22
NIS
2742 *(PL_stack_base + markix) = *PL_stack_sp;
2743 PL_stack_sp = PL_stack_base + markix;
748a9306 2744 }
a0d0e21e
LW
2745 }
2746 LEAVE;
2747 return NORMAL;
2748 }
2749 else {
2750 dMARK;
2751 register I32 items = SP - MARK;
a0d0e21e
LW
2752 AV* padlist = CvPADLIST(cv);
2753 SV** svp = AvARRAY(padlist);
533c011a 2754 push_return(PL_op->op_next);
a0d0e21e
LW
2755 PUSHBLOCK(cx, CXt_SUB, MARK);
2756 PUSHSUB(cx);
2757 CvDEPTH(cv)++;
6b35e009
GS
2758 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2759 * that eval'' ops within this sub know the correct lexical space.
2760 * Owing the speed considerations, we choose to search for the cv
2761 * in doeval() instead.
2762 */
a0d0e21e
LW
2763 if (CvDEPTH(cv) < 2)
2764 (void)SvREFCNT_inc(cv);
2765 else { /* save temporaries on recursion? */
1d7c1841 2766 PERL_STACK_OVERFLOW_CHECK();
93965878 2767 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e
LW
2768 AV *av;
2769 AV *newpad = newAV();
4aa0a1f7 2770 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2771 I32 ix = AvFILLp((AV*)svp[1]);
1d7c1841 2772 I32 names_fill = AvFILLp((AV*)svp[0]);
a0d0e21e 2773 svp = AvARRAY(svp[0]);
748a9306 2774 for ( ;ix > 0; ix--) {
1d7c1841 2775 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
748a9306 2776 char *name = SvPVX(svp[ix]);
5f05dabc
PP
2777 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2778 || *name == '&') /* anonymous code? */
2779 {
2780 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
748a9306
LW
2781 }
2782 else { /* our own lexical */
2783 if (*name == '@')
2784 av_store(newpad, ix, sv = (SV*)newAV());
2785 else if (*name == '%')
2786 av_store(newpad, ix, sv = (SV*)newHV());
2787 else
2788 av_store(newpad, ix, sv = NEWSV(0,0));
2789 SvPADMY_on(sv);
2790 }
a0d0e21e 2791 }
1d7c1841
GS
2792 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2793 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2794 }
a0d0e21e 2795 else {
748a9306 2796 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW
2797 SvPADTMP_on(sv);
2798 }
2799 }
2800 av = newAV(); /* will be @_ */
2801 av_extend(av, 0);
2802 av_store(newpad, 0, (SV*)av);
2803 AvFLAGS(av) = AVf_REIFY;
2804 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2805 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW
2806 svp = AvARRAY(padlist);
2807 }
2808 }
4d1ff10f 2809#ifdef USE_5005THREADS
6d4ff0d2 2810 if (!hasargs) {
533c011a 2811 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2812
93965878 2813 items = AvFILLp(av) + 1;
6d4ff0d2
MB
2814 if (items) {
2815 /* Mark is at the end of the stack. */
924508f0
GS
2816 EXTEND(SP, items);
2817 Copy(AvARRAY(av), SP + 1, items, SV*);
2818 SP += items;
1c846c1f 2819 PUTBACK ;
6d4ff0d2
MB
2820 }
2821 }
4d1ff10f 2822#endif /* USE_5005THREADS */
1d7c1841 2823 SAVEVPTR(PL_curpad);
3280af22 2824 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
4d1ff10f 2825#ifndef USE_5005THREADS
6d4ff0d2 2826 if (hasargs)
4d1ff10f 2827#endif /* USE_5005THREADS */
6d4ff0d2
MB
2828 {
2829 AV* av;
a0d0e21e
LW
2830 SV** ary;
2831
77a005ab 2832#if 0
bf49b057 2833 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2834 "%p entersub preparing @_\n", thr));
77a005ab 2835#endif
3280af22 2836 av = (AV*)PL_curpad[0];
221373f0
GS
2837 if (AvREAL(av)) {
2838 /* @_ is normally not REAL--this should only ever
2839 * happen when DB::sub() calls things that modify @_ */
2840 av_clear(av);
2841 AvREAL_off(av);
2842 AvREIFY_on(av);
2843 }
4d1ff10f 2844#ifndef USE_5005THREADS
3280af22
NIS
2845 cx->blk_sub.savearray = GvAV(PL_defgv);
2846 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
4d1ff10f 2847#endif /* USE_5005THREADS */
7032098e 2848 cx->blk_sub.oldcurpad = PL_curpad;
6d4ff0d2 2849 cx->blk_sub.argarray = av;
a0d0e21e
LW
2850 ++MARK;
2851
2852 if (items > AvMAX(av) + 1) {
2853 ary = AvALLOC(av);
2854 if (AvARRAY(av) != ary) {
2855 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2856 SvPVX(av) = (char*)ary;
2857 }
2858 if (items > AvMAX(av) + 1) {
2859 AvMAX(av) = items - 1;
2860 Renew(ary,items,SV*);
2861 AvALLOC(av) = ary;
2862 SvPVX(av) = (char*)ary;
2863 }
2864 }
2865 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2866 AvFILLp(av) = items - 1;
1c846c1f 2867
a0d0e21e
LW
2868 while (items--) {
2869 if (*MARK)
2870 SvTEMP_off(*MARK);
2871 MARK++;
2872 }
2873 }
4a925ff6
GS
2874 /* warning must come *after* we fully set up the context
2875 * stuff so that __WARN__ handlers can safely dounwind()
2876 * if they want to
2877 */
2878 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2879 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2880 sub_crush_depth(cv);
77a005ab 2881#if 0
bf49b057 2882 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2883 "%p entersub returning %p\n", thr, CvSTART(cv)));
77a005ab 2884#endif
a0d0e21e
LW
2885 RETURNOP(CvSTART(cv));
2886 }
2887}
2888
44a8e56a 2889void
864dbfa3 2890Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a
PP
2891{
2892 if (CvANON(cv))
cea2e8a9 2893 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
44a8e56a
PP
2894 else {
2895 SV* tmpstr = sv_newmortal();
2896 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1c846c1f 2897 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
599cee73 2898 SvPVX(tmpstr));
44a8e56a
PP
2899 }
2900}
2901
a0d0e21e
LW
2902PP(pp_aelem)
2903{
39644a26 2904 dSP;
a0d0e21e 2905 SV** svp;
d804643f
SC
2906 SV* elemsv = POPs;
2907 IV elem = SvIV(elemsv);
68dc0745 2908 AV* av = (AV*)POPs;
78f9721b 2909 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
533c011a 2910 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
be6c24e0 2911 SV *sv;
a0d0e21e 2912
e35c1634 2913 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
d804643f 2914 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
748a9306 2915 if (elem > 0)
3280af22 2916 elem -= PL_curcop->cop_arybase;
a0d0e21e
LW
2917 if (SvTYPE(av) != SVt_PVAV)
2918 RETPUSHUNDEF;
68dc0745 2919 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2920 if (lval) {
3280af22 2921 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2922 SV* lv;
2923 if (!defer)
cea2e8a9 2924 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2925 lv = sv_newmortal();
2926 sv_upgrade(lv, SVt_PVLV);
2927 LvTYPE(lv) = 'y';
14befaf4 2928 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
2929 LvTARG(lv) = SvREFCNT_inc(av);
2930 LvTARGOFF(lv) = elem;
2931 LvTARGLEN(lv) = 1;
2932 PUSHs(lv);
2933 RETURN;
2934 }
533c011a 2935 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2936 save_aelem(av, elem, svp);
533c011a
NIS
2937 else if (PL_op->op_private & OPpDEREF)
2938 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 2939 }
3280af22 2940 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
2941 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2942 sv = sv_mortalcopy(sv);
2943 PUSHs(sv);
a0d0e21e
LW
2944 RETURN;
2945}
2946
02a9e968 2947void
864dbfa3 2948Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968
CS
2949{
2950 if (SvGMAGICAL(sv))
2951 mg_get(sv);
2952 if (!SvOK(sv)) {
2953 if (SvREADONLY(sv))
cea2e8a9 2954 Perl_croak(aTHX_ PL_no_modify);
5f05dabc
PP
2955 if (SvTYPE(sv) < SVt_RV)
2956 sv_upgrade(sv, SVt_RV);
2957 else if (SvTYPE(sv) >= SVt_PV) {
2958 (void)SvOOK_off(sv);
2959 Safefree(SvPVX(sv));
2960 SvLEN(sv) = SvCUR(sv) = 0;
2961 }
68dc0745 2962 switch (to_what) {
5f05dabc 2963 case OPpDEREF_SV:
8c52afec 2964 SvRV(sv) = NEWSV(355,0);
5f05dabc
PP
2965 break;
2966 case OPpDEREF_AV:
2967 SvRV(sv) = (SV*)newAV();
2968 break;
2969 case OPpDEREF_HV:
2970 SvRV(sv) = (SV*)newHV();
2971 break;
2972 }
02a9e968
CS
2973 SvROK_on(sv);
2974 SvSETMAGIC(sv);
2975 }
2976}
2977
a0d0e21e
LW
2978PP(pp_method)
2979{
39644a26 2980 dSP;
f5d5a27c
CS
2981 SV* sv = TOPs;
2982
2983 if (SvROK(sv)) {
eda383f2 2984 SV* rsv = SvRV(sv);
f5d5a27c
CS
2985 if (SvTYPE(rsv) == SVt_PVCV) {
2986 SETs(rsv);
2987 RETURN;
2988 }
2989 }
2990
2991 SETs(method_common(sv, Null(U32*)));
2992 RETURN;
2993}
2994
2995PP(pp_method_named)
2996{
39644a26 2997 dSP;
f5d5a27c
CS
2998 SV* sv = cSVOP->op_sv;
2999 U32 hash = SvUVX(sv);
3000
3001 XPUSHs(method_common(sv, &hash));
3002 RETURN;
3003}
3004
3005STATIC SV *
3006S_method_common(pTHX_ SV* meth, U32* hashp)
3007{
a0d0e21e
LW
3008 SV* sv;
3009 SV* ob;
3010 GV* gv;
56304f61
CS
3011 HV* stash;
3012 char* name;
f5d5a27c 3013 STRLEN namelen;
9c5ffd7c 3014 char* packname = 0;
ac91690f 3015 STRLEN packlen;
a0d0e21e 3016
f5d5a27c 3017 name = SvPV(meth, namelen);
3280af22 3018 sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 3019
4f1b7578
SC
3020 if (!sv)
3021 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3022
16d20bd9 3023 if (SvGMAGICAL(sv))
af09ea45 3024 mg_get(sv);
a0d0e21e 3025 if (SvROK(sv))
16d20bd9 3026 ob = (SV*)SvRV(sv);
a0d0e21e
LW
3027 else {
3028 GV* iogv;
a0d0e21e 3029
af09ea45 3030 /* this isn't a reference */
56304f61 3031 packname = Nullch;
a0d0e21e 3032 if (!SvOK(sv) ||
56304f61 3033 !(packname = SvPV(sv, packlen)) ||
a0d0e21e
LW
3034 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3035 !(ob=(SV*)GvIO(iogv)))
3036 {
af09ea45 3037 /* this isn't the name of a filehandle either */
1c846c1f 3038 if (!packname ||
fd400ab9 3039 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 3040 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW
3041 : !isIDFIRST(*packname)
3042 ))
3043 {
f5d5a27c
CS
3044 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3045 SvOK(sv) ? "without a package or object reference"
3046 : "on an undefined value");
834a4ddd 3047 }
af09ea45
IK
3048 /* assume it's a package name */
3049 stash = gv_stashpvn(packname, packlen, FALSE);
ac91690f 3050 goto fetch;
a0d0e21e 3051 }
af09ea45 3052 /* it _is_ a filehandle name -- replace with a reference */
3280af22 3053 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e
LW
3054 }
3055
af09ea45 3056 /* if we got here, ob should be a reference or a glob */
f0d43078
GS
3057 if (!ob || !(SvOBJECT(ob)
3058 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3059 && SvOBJECT(ob))))
3060 {
f5d5a27c
CS
3061 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3062 name);
f0d43078 3063 }
a0d0e21e 3064
56304f61 3065 stash = SvSTASH(ob);
a0d0e21e 3066
ac91690f 3067 fetch:
af09ea45
IK
3068 /* NOTE: stash may be null, hope hv_fetch_ent and
3069 gv_fetchmethod can cope (it seems they can) */
3070
f5d5a27c
CS
3071 /* shortcut for simple names */
3072 if (hashp) {
3073 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3074 if (he) {
3075 gv = (GV*)HeVAL(he);
3076 if (isGV(gv) && GvCV(gv) &&
3077 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3078 return (SV*)GvCV(gv);
3079 }
3080 }
3081
ac91690f 3082 gv = gv_fetchmethod(stash, name);
af09ea45 3083
56304f61 3084 if (!gv) {
af09ea45
IK
3085 /* This code tries to figure out just what went wrong with
3086 gv_fetchmethod. It therefore needs to duplicate a lot of
3087 the internals of that function. We can't move it inside
3088 Perl_gv_fetchmethod_autoload(), however, since that would
3089 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3090 don't want that.
3091 */
56304f61
CS
3092 char* leaf = name;
3093 char* sep = Nullch;
3094 char* p;
3095
3096 for (p = name; *p; p++) {
3097 if (*p == '\'')
3098 sep = p, leaf = p + 1;
3099 else if (*p == ':' && *(p + 1) == ':')
3100 sep = p, leaf = p + 2;
3101 }
3102 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
af09ea45
IK
3103 /* the method name is unqualified or starts with SUPER:: */
3104 packname = sep ? CopSTASHPV(PL_curcop) :
3105 stash ? HvNAME(stash) : packname;
56304f61
CS
3106 packlen = strlen(packname);
3107 }
3108 else {
af09ea45 3109 /* the method name is qualified */
56304f61
CS
3110 packname = name;
3111 packlen = sep - name;
3112 }
af09ea45
IK
3113
3114 /* we're relying on gv_fetchmethod not autovivifying the stash */
3115 if (gv_stashpvn(packname, packlen, FALSE)) {
c1899e02 3116 Perl_croak(aTHX_
af09ea45
IK
3117 "Can't locate object method \"%s\" via package \"%.*s\"",
3118 leaf, (int)packlen, packname);
c1899e02
GS
3119 }
3120 else {
3121 Perl_croak(aTHX_
af09ea45
IK
3122 "Can't locate object method \"%s\" via package \"%.*s\""
3123 " (perhaps you forgot to load \"%.*s\"?)",
3124 leaf, (int)packlen, packname, (int)packlen, packname);
c1899e02 3125 }
56304f61 3126 }
f5d5a27c 3127 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
a0d0e21e 3128}
22239a37 3129
4d1ff10f 3130#ifdef USE_5005THREADS
51371543 3131static void
acfe0abc 3132unset_cvowner(pTHX_ void *cvarg)
51371543
GS
3133{
3134 register CV* cv = (CV *) cvarg;
51371543 3135
bf49b057 3136 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
51371543
GS
3137 thr, cv, SvPEEK((SV*)cv))));
3138 MUTEX_LOCK(CvMUTEXP(cv));
3139 DEBUG_S(if (CvDEPTH(cv) != 0)
bf49b057 3140 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
755b0776 3141 CvDEPTH(cv)));
51371543
GS
3142 assert(thr == CvOWNER(cv));
3143 CvOWNER(cv) = 0;
3144 MUTEX_UNLOCK(CvMUTEXP(cv));
3145 SvREFCNT_dec(cv);
3146}
4d1ff10f 3147#endif /* USE_5005THREADS */