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