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