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