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