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