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