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