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