This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/test.pl additional functionality for runperl
[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;
93965878
NIS
737 for (i=0; i < maxarg; i++) {
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
LW
1186 register PMOP *pm = cPMOP;
1187 register char *t;
1188 register char *s;
1189 char *strend;
1190 I32 global;
f722798b
IZ
1191 I32 r_flags = REXEC_CHECKED;
1192 char *truebase; /* Start of string */
aaa362c4 1193 register REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1194 bool rxtainted;
a0d0e21e
LW
1195 I32 gimme = GIMME;
1196 STRLEN len;
748a9306 1197 I32 minmatch = 0;
3280af22 1198 I32 oldsave = PL_savestack_ix;
f86702cc 1199 I32 update_minmatch = 1;
e60df1fa 1200 I32 had_zerolen = 0;
a0d0e21e 1201
533c011a 1202 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1203 TARG = POPs;
1204 else {
54b9620d 1205 TARG = DEFSV;
a0d0e21e
LW
1206 EXTEND(SP,1);
1207 }
d9f424b2 1208
c277df42 1209 PUTBACK; /* EVAL blocks need stack_sp. */
a0d0e21e
LW
1210 s = SvPV(TARG, len);
1211 strend = s + len;
1212 if (!s)
2269b42e 1213 DIE(aTHX_ "panic: pp_match");
b3eb6a9b 1214 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22 1215 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1216 TAINT_NOT;
a0d0e21e 1217
53c4c00c 1218 PL_reg_match_utf8 = DO_UTF8(TARG);
d9f424b2 1219
48c036b1 1220 if (pm->op_pmdynflags & PMdf_USED) {
c277df42 1221 failure:
a0d0e21e
LW
1222 if (gimme == G_ARRAY)
1223 RETURN;
1224 RETPUSHNO;
1225 }
1226
3280af22
NIS
1227 if (!rx->prelen && PL_curpm) {
1228 pm = PL_curpm;
aaa362c4 1229 rx = PM_GETRE(pm);
a0d0e21e 1230 }
61a36c01 1231 if (rx->minlen > len)
9e55ce06 1232 goto failure;
c277df42 1233
a0d0e21e 1234 truebase = t = s;
ad94a511
IZ
1235
1236 /* XXXX What part of this is needed with true \G-support? */
155aba94 1237 if ((global = pm->op_pmflags & PMf_GLOBAL)) {
cf93c79d 1238 rx->startp[0] = -1;
a0d0e21e 1239 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
14befaf4 1240 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
565764a8 1241 if (mg && mg->mg_len >= 0) {
b7a35066 1242 if (!(rx->reganch & ROPT_GPOS_SEEN))
1c846c1f 1243 rx->endp[0] = rx->startp[0] = mg->mg_len;
0ef3e39e
HS
1244 else if (rx->reganch & ROPT_ANCH_GPOS) {
1245 r_flags |= REXEC_IGNOREPOS;
1c846c1f 1246 rx->endp[0] = rx->startp[0] = mg->mg_len;
0ef3e39e 1247 }
748a9306 1248 minmatch = (mg->mg_flags & MGf_MINMATCH);
f86702cc 1249 update_minmatch = 0;
748a9306 1250 }
a0d0e21e
LW
1251 }
1252 }
14977893
JH
1253 if ((!global && rx->nparens)
1254 || SvTEMP(TARG) || PL_sawampersand)
1255 r_flags |= REXEC_COPY_STR;
1c846c1f 1256 if (SvSCREAM(TARG))
22e551b9
IZ
1257 r_flags |= REXEC_SCREAM;
1258
a0d0e21e 1259 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS
1260 SAVEINT(PL_multiline);
1261 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
a0d0e21e
LW
1262 }
1263
1264play_it_again:
cf93c79d
IZ
1265 if (global && rx->startp[0] != -1) {
1266 t = s = rx->endp[0] + truebase;
d9f97599 1267 if ((s + rx->minlen) > strend)
a0d0e21e 1268 goto nope;
f86702cc 1269 if (update_minmatch++)
e60df1fa 1270 minmatch = had_zerolen;
a0d0e21e 1271 }
60aeb6fd
NIS
1272 if (rx->reganch & RE_USE_INTUIT &&
1273 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
ee0b7718 1274 PL_bostr = truebase;
f722798b
IZ
1275 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1276
1277 if (!s)
1278 goto nope;
1279 if ( (rx->reganch & ROPT_CHECK_ALL)
14977893 1280 && !PL_sawampersand
f722798b
IZ
1281 && ((rx->reganch & ROPT_NOSCAN)
1282 || !((rx->reganch & RE_INTUIT_TAIL)
05b4157f
GS
1283 && (r_flags & REXEC_SCREAM)))
1284 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
f722798b 1285 goto yup;
a0d0e21e 1286 }
cea2e8a9 1287 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
bbce6d69 1288 {
3280af22 1289 PL_curpm = pm;
a0d0e21e 1290 if (pm->op_pmflags & PMf_ONCE)
48c036b1 1291 pm->op_pmdynflags |= PMdf_USED;
a0d0e21e
LW
1292 goto gotcha;
1293 }
1294 else
1295 goto ret_no;
1296 /*NOTREACHED*/
1297
1298 gotcha:
72311751
GS
1299 if (rxtainted)
1300 RX_MATCH_TAINTED_on(rx);
1301 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1302 if (gimme == G_ARRAY) {
ffc61ed2 1303 I32 nparens, i, len;
a0d0e21e 1304
ffc61ed2
JH
1305 nparens = rx->nparens;
1306 if (global && !nparens)
a0d0e21e
LW
1307 i = 1;
1308 else
1309 i = 0;
c277df42 1310 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1311 EXTEND(SP, nparens + i);
1312 EXTEND_MORTAL(nparens + i);
1313 for (i = !i; i <= nparens; i++) {
a0d0e21e
LW
1314 PUSHs(sv_newmortal());
1315 /*SUPPRESS 560*/
cf93c79d
IZ
1316 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1317 len = rx->endp[i] - rx->startp[i];
290deeac
A
1318 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1319 len < 0 || len > strend - s)
1320 DIE(aTHX_ "panic: pp_match start/end pointers");
cf93c79d 1321 s = rx->startp[i] + truebase;
a0d0e21e 1322 sv_setpvn(*SP, s, len);
cce850e4 1323 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1324 SvUTF8_on(*SP);
a0d0e21e
LW
1325 }
1326 }
1327 if (global) {
0af80b60
HS
1328 if (pm->op_pmflags & PMf_CONTINUE) {
1329 MAGIC* mg = 0;
1330 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1331 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1332 if (!mg) {
1333 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1334 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1335 }
1336 if (rx->startp[0] != -1) {
1337 mg->mg_len = rx->endp[0];
1338 if (rx->startp[0] == rx->endp[0])
1339 mg->mg_flags |= MGf_MINMATCH;
1340 else
1341 mg->mg_flags &= ~MGf_MINMATCH;
1342 }
1343 }
cf93c79d
IZ
1344 had_zerolen = (rx->startp[0] != -1
1345 && rx->startp[0] == rx->endp[0]);
c277df42 1346 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1347 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1348 goto play_it_again;
1349 }
ffc61ed2 1350 else if (!nparens)
bde848c5 1351 XPUSHs(&PL_sv_yes);
4633a7c4 1352 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1353 RETURN;
1354 }
1355 else {
1356 if (global) {
1357 MAGIC* mg = 0;
1358 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
14befaf4 1359 mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1360 if (!mg) {
14befaf4
DM
1361 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1362 mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1363 }
cf93c79d
IZ
1364 if (rx->startp[0] != -1) {
1365 mg->mg_len = rx->endp[0];
d9f97599 1366 if (rx->startp[0] == rx->endp[0])
748a9306
LW
1367 mg->mg_flags |= MGf_MINMATCH;
1368 else
1369 mg->mg_flags &= ~MGf_MINMATCH;
1370 }
a0d0e21e 1371 }
4633a7c4 1372 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1373 RETPUSHYES;
1374 }
1375
f722798b 1376yup: /* Confirmed by INTUIT */
72311751
GS
1377 if (rxtainted)
1378 RX_MATCH_TAINTED_on(rx);
1379 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1380 PL_curpm = pm;
a0d0e21e 1381 if (pm->op_pmflags & PMf_ONCE)
48c036b1 1382 pm->op_pmdynflags |= PMdf_USED;
cf93c79d
IZ
1383 if (RX_MATCH_COPIED(rx))
1384 Safefree(rx->subbeg);
1385 RX_MATCH_COPIED_off(rx);
1386 rx->subbeg = Nullch;
a0d0e21e 1387 if (global) {
d9f97599 1388 rx->subbeg = truebase;
cf93c79d 1389 rx->startp[0] = s - truebase;
53c4c00c 1390 if (PL_reg_match_utf8) {
60aeb6fd
NIS
1391 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1392 rx->endp[0] = t - truebase;
1393 }
1394 else {
1395 rx->endp[0] = s - truebase + rx->minlen;
1396 }
cf93c79d 1397 rx->sublen = strend - truebase;
a0d0e21e 1398 goto gotcha;
1c846c1f 1399 }
14977893
JH
1400 if (PL_sawampersand) {
1401 I32 off;
1402
1403 rx->subbeg = savepvn(t, strend - t);
1404 rx->sublen = strend - t;
1405 RX_MATCH_COPIED_on(rx);
1406 off = rx->startp[0] = s - t;
1407 rx->endp[0] = off + rx->minlen;
1408 }
1409 else { /* startp/endp are used by @- @+. */
1410 rx->startp[0] = s - truebase;
1411 rx->endp[0] = s - truebase + rx->minlen;
1412 }
fc19f8d0 1413 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
4633a7c4 1414 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1415 RETPUSHYES;
1416
1417nope:
a0d0e21e 1418ret_no:
c90c0ff4 1419 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1420 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
14befaf4 1421 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1422 if (mg)
565764a8 1423 mg->mg_len = -1;
a0d0e21e
LW
1424 }
1425 }
4633a7c4 1426 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1427 if (gimme == G_ARRAY)
1428 RETURN;
1429 RETPUSHNO;
1430}
1431
1432OP *
864dbfa3 1433Perl_do_readline(pTHX)
a0d0e21e
LW
1434{
1435 dSP; dTARGETSTACKED;
1436 register SV *sv;
1437 STRLEN tmplen = 0;
1438 STRLEN offset;
760ac839 1439 PerlIO *fp;
3280af22 1440 register IO *io = GvIO(PL_last_in_gv);
533c011a 1441 register I32 type = PL_op->op_type;
54310121 1442 I32 gimme = GIMME_V;
e79b0511 1443 MAGIC *mg;
a0d0e21e 1444
5b468f54 1445 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
e79b0511 1446 PUSHMARK(SP);
5b468f54 1447 XPUSHs(SvTIED_obj((SV*)io, mg));
e79b0511
PP
1448 PUTBACK;
1449 ENTER;
864dbfa3 1450 call_method("READLINE", gimme);
e79b0511
PP
1451 LEAVE;
1452 SPAGAIN;
54310121
PP
1453 if (gimme == G_SCALAR)
1454 SvSetMagicSV_nosteal(TARG, TOPs);
e79b0511
PP
1455 RETURN;
1456 }
a0d0e21e
LW
1457 fp = Nullfp;
1458 if (io) {
1459 fp = IoIFP(io);
1460 if (!fp) {
1461 if (IoFLAGS(io) & IOf_ARGV) {
1462 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1463 IoLINES(io) = 0;
3280af22 1464 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1465 IoFLAGS(io) &= ~IOf_START;
9d116dd7 1466 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
3280af22
NIS
1467 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1468 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1469 fp = IoIFP(io);
1470 goto have_fp;
a0d0e21e
LW
1471 }
1472 }
3280af22 1473 fp = nextargv(PL_last_in_gv);
a0d0e21e 1474 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1475 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1476 }
1477 }
0d44d22b
NC
1478 else if (type == OP_GLOB)
1479 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1480 }
1481 else if (type == OP_GLOB)
1482 SP--;
a00b5bd3 1483 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
4c80c0b2 1484 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
a00b5bd3 1485 }
a0d0e21e
LW
1486 }
1487 if (!fp) {
790090df
HS
1488 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1489 && (!io || !(IoFLAGS(io) & IOf_START))) {
3f4520fe 1490 if (type == OP_GLOB)
9014280d 1491 Perl_warner(aTHX_ packWARN(WARN_GLOB),
af8c498a
GS
1492 "glob failed (can't start child: %s)",
1493 Strerror(errno));
69282e91 1494 else
bc37a18f 1495 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
3f4520fe 1496 }
54310121 1497 if (gimme == G_SCALAR) {
a0d0e21e
LW
1498 (void)SvOK_off(TARG);
1499 PUSHTARG;
1500 }
1501 RETURN;
1502 }
a2008d6d 1503 have_fp:
54310121 1504 if (gimme == G_SCALAR) {
a0d0e21e 1505 sv = TARG;
9607fc9c
PP
1506 if (SvROK(sv))
1507 sv_unref(sv);
a0d0e21e
LW
1508 (void)SvUPGRADE(sv, SVt_PV);
1509 tmplen = SvLEN(sv); /* remember if already alloced */
1510 if (!tmplen)
1511 Sv_Grow(sv, 80); /* try short-buffering it */
1512 if (type == OP_RCATLINE)
1513 offset = SvCUR(sv);
1514 else
1515 offset = 0;
1516 }
54310121
PP
1517 else {
1518 sv = sv_2mortal(NEWSV(57, 80));
1519 offset = 0;
1520 }
fbad3eb5 1521
3887d568
AP
1522 /* This should not be marked tainted if the fp is marked clean */
1523#define MAYBE_TAINT_LINE(io, sv) \
1524 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1525 TAINT; \
1526 SvTAINTED_on(sv); \
1527 }
1528
684bef36 1529/* delay EOF state for a snarfed empty file */
fbad3eb5 1530#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1531 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1532 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1533
a0d0e21e 1534 for (;;) {
09e8efcc 1535 PUTBACK;
fbad3eb5
GS
1536 if (!sv_gets(sv, fp, offset)
1537 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1538 {
760ac839 1539 PerlIO_clearerr(fp);
a0d0e21e 1540 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1541 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW
1542 if (fp)
1543 continue;
3280af22 1544 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1545 }
1546 else if (type == OP_GLOB) {
e476b1b5 1547 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
9014280d 1548 Perl_warner(aTHX_ packWARN(WARN_GLOB),
4eb79ab5 1549 "glob failed (child exited with status %d%s)",
894356b3 1550 (int)(STATUS_CURRENT >> 8),
cf494569 1551 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1552 }
a0d0e21e 1553 }
54310121 1554 if (gimme == G_SCALAR) {
a0d0e21e 1555 (void)SvOK_off(TARG);
09e8efcc 1556 SPAGAIN;
a0d0e21e
LW
1557 PUSHTARG;
1558 }
3887d568 1559 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1560 RETURN;
1561 }
3887d568 1562 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1563 IoLINES(io)++;
b9fee9ba 1564 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1565 SvSETMAGIC(sv);
09e8efcc 1566 SPAGAIN;
a0d0e21e 1567 XPUSHs(sv);
a0d0e21e
LW
1568 if (type == OP_GLOB) {
1569 char *tmps;
1570
3280af22 1571 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
c07a80fd 1572 tmps = SvEND(sv) - 1;
3280af22 1573 if (*tmps == *SvPVX(PL_rs)) {
c07a80fd
PP
1574 *tmps = '\0';
1575 SvCUR(sv)--;
1576 }
1577 }
a0d0e21e
LW
1578 for (tmps = SvPVX(sv); *tmps; tmps++)
1579 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1580 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1581 break;
43384a1a 1582 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1583 (void)POPs; /* Unmatched wildcard? Chuck it... */
1584 continue;
1585 }
1586 }
54310121 1587 if (gimme == G_ARRAY) {
a0d0e21e
LW
1588 if (SvLEN(sv) - SvCUR(sv) > 20) {
1589 SvLEN_set(sv, SvCUR(sv)+1);
1590 Renew(SvPVX(sv), SvLEN(sv), char);
1591 }
1592 sv = sv_2mortal(NEWSV(58, 80));
1593 continue;
1594 }
54310121 1595 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e
LW
1596 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1597 if (SvCUR(sv) < 60)
1598 SvLEN_set(sv, 80);
1599 else
1600 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1601 Renew(SvPVX(sv), SvLEN(sv), char);
1602 }
1603 RETURN;
1604 }
1605}
1606
1607PP(pp_enter)
1608{
39644a26 1609 dSP;
c09156bb 1610 register PERL_CONTEXT *cx;
533c011a 1611 I32 gimme = OP_GIMME(PL_op, -1);
a0d0e21e 1612
54310121
PP
1613 if (gimme == -1) {
1614 if (cxstack_ix >= 0)
1615 gimme = cxstack[cxstack_ix].blk_gimme;
1616 else
1617 gimme = G_SCALAR;
1618 }
a0d0e21e
LW
1619
1620 ENTER;
1621
1622 SAVETMPS;
924508f0 1623 PUSHBLOCK(cx, CXt_BLOCK, SP);
a0d0e21e
LW
1624
1625 RETURN;
1626}
1627
1628PP(pp_helem)
1629{
39644a26 1630 dSP;
760ac839 1631 HE* he;
ae77835f 1632 SV **svp;
a0d0e21e 1633 SV *keysv = POPs;
a0d0e21e 1634 HV *hv = (HV*)POPs;
78f9721b 1635 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
533c011a 1636 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1637 SV *sv;
1c846c1f 1638 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
9c5ffd7c 1639 I32 preeminent = 0;
a0d0e21e 1640
ae77835f 1641 if (SvTYPE(hv) == SVt_PVHV) {
1f5346dc
SC
1642 if (PL_op->op_private & OPpLVAL_INTRO)
1643 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1c846c1f 1644 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
97fcbf96 1645 svp = he ? &HeVAL(he) : 0;
ae77835f
MB
1646 }
1647 else if (SvTYPE(hv) == SVt_PVAV) {
0ebe0038 1648 if (PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 1649 DIE(aTHX_ "Can't localize pseudo-hash element");
1c846c1f 1650 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
ae77835f 1651 }
c750a3ec 1652 else {
a0d0e21e 1653 RETPUSHUNDEF;
c750a3ec 1654 }
a0d0e21e 1655 if (lval) {
3280af22 1656 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
1657 SV* lv;
1658 SV* key2;
2d8e6c8d
GS
1659 if (!defer) {
1660 STRLEN n_a;
cea2e8a9 1661 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 1662 }
68dc0745
PP
1663 lv = sv_newmortal();
1664 sv_upgrade(lv, SVt_PVLV);
1665 LvTYPE(lv) = 'y';
14befaf4 1666 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
1667 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1668 LvTARG(lv) = SvREFCNT_inc(hv);
1669 LvTARGLEN(lv) = 1;
1670 PUSHs(lv);
1671 RETURN;
1672 }
533c011a 1673 if (PL_op->op_private & OPpLVAL_INTRO) {
ae77835f 1674 if (HvNAME(hv) && isGV(*svp))
533c011a 1675 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1f5346dc
SC
1676 else {
1677 if (!preeminent) {
1678 STRLEN keylen;
1679 char *key = SvPV(keysv, keylen);
57813020 1680 SAVEDELETE(hv, savepvn(key,keylen), keylen);
a12c0f56 1681 } else
1f5346dc
SC
1682 save_helem(hv, keysv, svp);
1683 }
5f05dabc 1684 }
533c011a
NIS
1685 else if (PL_op->op_private & OPpDEREF)
1686 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 1687 }
3280af22 1688 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
1689 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1690 * Pushing the magical RHS on to the stack is useless, since
1691 * that magic is soon destined to be misled by the local(),
1692 * and thus the later pp_sassign() will fail to mg_get() the
1693 * old value. This should also cure problems with delayed
1694 * mg_get()s. GSAR 98-07-03 */
1695 if (!lval && SvGMAGICAL(sv))
1696 sv = sv_mortalcopy(sv);
1697 PUSHs(sv);
a0d0e21e
LW
1698 RETURN;
1699}
1700
1701PP(pp_leave)
1702{
39644a26 1703 dSP;
c09156bb 1704 register PERL_CONTEXT *cx;
a0d0e21e
LW
1705 register SV **mark;
1706 SV **newsp;
1707 PMOP *newpm;
1708 I32 gimme;
1709
533c011a 1710 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1711 cx = &cxstack[cxstack_ix];
3280af22 1712 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
a0d0e21e
LW
1713 }
1714
1715 POPBLOCK(cx,newpm);
1716
533c011a 1717 gimme = OP_GIMME(PL_op, -1);
54310121
PP
1718 if (gimme == -1) {
1719 if (cxstack_ix >= 0)
1720 gimme = cxstack[cxstack_ix].blk_gimme;
1721 else
1722 gimme = G_SCALAR;
1723 }
a0d0e21e 1724
a1f49e72 1725 TAINT_NOT;
54310121
PP
1726 if (gimme == G_VOID)
1727 SP = newsp;
1728 else if (gimme == G_SCALAR) {
1729 MARK = newsp + 1;
09256e2f 1730 if (MARK <= SP) {
54310121
PP
1731 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1732 *MARK = TOPs;
1733 else
1734 *MARK = sv_mortalcopy(TOPs);
09256e2f 1735 } else {
54310121 1736 MEXTEND(mark,0);
3280af22 1737 *MARK = &PL_sv_undef;
a0d0e21e 1738 }
54310121 1739 SP = MARK;
a0d0e21e 1740 }
54310121 1741 else if (gimme == G_ARRAY) {
a1f49e72
CS
1742 /* in case LEAVE wipes old return values */
1743 for (mark = newsp + 1; mark <= SP; mark++) {
1744 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 1745 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
1746 TAINT_NOT; /* Each item is independent */
1747 }
1748 }
a0d0e21e 1749 }
3280af22 1750 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW
1751
1752 LEAVE;
1753
1754 RETURN;
1755}
1756
1757PP(pp_iter)
1758{
39644a26 1759 dSP;
c09156bb 1760 register PERL_CONTEXT *cx;
5f05dabc 1761 SV* sv;
4633a7c4 1762 AV* av;
1d7c1841 1763 SV **itersvp;
a0d0e21e 1764
924508f0 1765 EXTEND(SP, 1);
a0d0e21e 1766 cx = &cxstack[cxstack_ix];
6b35e009 1767 if (CxTYPE(cx) != CXt_LOOP)
cea2e8a9 1768 DIE(aTHX_ "panic: pp_iter");
a0d0e21e 1769
1d7c1841 1770 itersvp = CxITERVAR(cx);
4633a7c4 1771 av = cx->blk_loop.iterary;
89ea2908
GA
1772 if (SvTYPE(av) != SVt_PVAV) {
1773 /* iterate ($min .. $max) */
1774 if (cx->blk_loop.iterlval) {
1775 /* string increment */
1776 register SV* cur = cx->blk_loop.iterlval;
1777 STRLEN maxlen;
1778 char *max = SvPV((SV*)av, maxlen);
1779 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
4d1ff10f 1780#ifndef USE_5005THREADS /* don't risk potential race */
1d7c1841 1781 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1782 /* safe to reuse old SV */
1d7c1841 1783 sv_setsv(*itersvp, cur);
eaa5c2d6 1784 }
1c846c1f 1785 else
eaa5c2d6
GA
1786#endif
1787 {
1788 /* we need a fresh SV every time so that loop body sees a
1789 * completely new SV for closures/references to work as
1790 * they used to */
1d7c1841
GS
1791 SvREFCNT_dec(*itersvp);
1792 *itersvp = newSVsv(cur);
eaa5c2d6 1793 }
89ea2908
GA
1794 if (strEQ(SvPVX(cur), max))
1795 sv_setiv(cur, 0); /* terminate next time */
1796 else
1797 sv_inc(cur);
1798 RETPUSHYES;
1799 }
1800 RETPUSHNO;
1801 }
1802 /* integer increment */
1803 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1804 RETPUSHNO;
7f61b687 1805
4d1ff10f 1806#ifndef USE_5005THREADS /* don't risk potential race */
1d7c1841 1807 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1808 /* safe to reuse old SV */
1d7c1841 1809 sv_setiv(*itersvp, cx->blk_loop.iterix++);
eaa5c2d6 1810 }
1c846c1f 1811 else
eaa5c2d6
GA
1812#endif
1813 {
1814 /* we need a fresh SV every time so that loop body sees a
1815 * completely new SV for closures/references to work as they
1816 * used to */
1d7c1841
GS
1817 SvREFCNT_dec(*itersvp);
1818 *itersvp = newSViv(cx->blk_loop.iterix++);
eaa5c2d6 1819 }
89ea2908
GA
1820 RETPUSHYES;
1821 }
1822
1823 /* iterate array */
3280af22 1824 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
4633a7c4 1825 RETPUSHNO;
a0d0e21e 1826
1d7c1841 1827 SvREFCNT_dec(*itersvp);
a0d0e21e 1828
d42935ef
JH
1829 if (SvMAGICAL(av) || AvREIFY(av)) {
1830 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1831 if (svp)
1832 sv = *svp;
1833 else
1834 sv = Nullsv;
1835 }
1836 else {
1837 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1838 }
1839 if (sv)
a0d0e21e 1840 SvTEMP_off(sv);
a0d0e21e 1841 else
3280af22 1842 sv = &PL_sv_undef;
8b530633 1843 if (av != PL_curstack && sv == &PL_sv_undef) {
5f05dabc 1844 SV *lv = cx->blk_loop.iterlval;
71be2cbc
PP
1845 if (lv && SvREFCNT(lv) > 1) {
1846 SvREFCNT_dec(lv);
1847 lv = Nullsv;
1848 }
5f05dabc
PP
1849 if (lv)
1850 SvREFCNT_dec(LvTARG(lv));
1851 else {
68dc0745 1852 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
5f05dabc 1853 sv_upgrade(lv, SVt_PVLV);
5f05dabc 1854 LvTYPE(lv) = 'y';
14befaf4 1855 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
5f05dabc
PP
1856 }
1857 LvTARG(lv) = SvREFCNT_inc(av);
1858 LvTARGOFF(lv) = cx->blk_loop.iterix;
42718184 1859 LvTARGLEN(lv) = (STRLEN)UV_MAX;
5f05dabc
PP
1860 sv = (SV*)lv;
1861 }
a0d0e21e 1862
1d7c1841 1863 *itersvp = SvREFCNT_inc(sv);
a0d0e21e
LW
1864 RETPUSHYES;
1865}
1866
1867PP(pp_subst)
1868{
39644a26 1869 dSP; dTARG;
a0d0e21e
LW
1870 register PMOP *pm = cPMOP;
1871 PMOP *rpm = pm;
1872 register SV *dstr;
1873 register char *s;
1874 char *strend;
1875 register char *m;
1876 char *c;
1877 register char *d;
1878 STRLEN clen;
1879 I32 iters = 0;
1880 I32 maxiters;
1881 register I32 i;
1882 bool once;
71be2cbc 1883 bool rxtainted;
a0d0e21e 1884 char *orig;
22e551b9 1885 I32 r_flags;
aaa362c4 1886 register REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
1887 STRLEN len;
1888 int force_on_match = 0;
3280af22 1889 I32 oldsave = PL_savestack_ix;
792b2c16 1890 STRLEN slen;
f272994b 1891 bool doutf8 = FALSE;
a0d0e21e 1892
5cd24f17
PP
1893 /* known replacement string? */
1894 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
533c011a 1895 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1896 TARG = POPs;
1897 else {
54b9620d 1898 TARG = DEFSV;
a0d0e21e 1899 EXTEND(SP,1);
1c846c1f 1900 }
d9f424b2 1901
eca06228
NIS
1902 if (SvFAKE(TARG) && SvREADONLY(TARG))
1903 sv_force_normal(TARG);
68dc0745
PP
1904 if (SvREADONLY(TARG)
1905 || (SvTYPE(TARG) > SVt_PVLV
1906 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
d470f89e 1907 DIE(aTHX_ PL_no_modify);
8ec5e241
NIS
1908 PUTBACK;
1909
a0d0e21e 1910 s = SvPV(TARG, len);
68dc0745 1911 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 1912 force_on_match = 1;
b3eb6a9b 1913 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22
NIS
1914 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1915 if (PL_tainted)
b3eb6a9b 1916 rxtainted |= 2;
9212bbba 1917 TAINT_NOT;
a12c0f56 1918
53c4c00c 1919 PL_reg_match_utf8 = DO_UTF8(TARG);
d9f424b2 1920
a0d0e21e
LW
1921 force_it:
1922 if (!pm || !s)
2269b42e 1923 DIE(aTHX_ "panic: pp_subst");
a0d0e21e
LW
1924
1925 strend = s + len;
53c4c00c 1926 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
1927 maxiters = 2 * slen + 10; /* We can match twice at each
1928 position, once with zero-length,
1929 second time with non-zero. */
a0d0e21e 1930
3280af22
NIS
1931 if (!rx->prelen && PL_curpm) {
1932 pm = PL_curpm;
aaa362c4 1933 rx = PM_GETRE(pm);
a0d0e21e 1934 }
22e551b9 1935 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
9d080a66 1936 ? REXEC_COPY_STR : 0;
f722798b 1937 if (SvSCREAM(TARG))
22e551b9 1938 r_flags |= REXEC_SCREAM;
a0d0e21e 1939 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS
1940 SAVEINT(PL_multiline);
1941 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
a0d0e21e
LW
1942 }
1943 orig = m = s;
f722798b 1944 if (rx->reganch & RE_USE_INTUIT) {
ee0b7718 1945 PL_bostr = orig;
f722798b
IZ
1946 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1947
1948 if (!s)
1949 goto nope;
1950 /* How to do it in subst? */
1951/* if ( (rx->reganch & ROPT_CHECK_ALL)
1c846c1f 1952 && !PL_sawampersand
f722798b
IZ
1953 && ((rx->reganch & ROPT_NOSCAN)
1954 || !((rx->reganch & RE_INTUIT_TAIL)
1955 && (r_flags & REXEC_SCREAM))))
1956 goto yup;
1957*/
a0d0e21e 1958 }
71be2cbc
PP
1959
1960 /* only replace once? */
a0d0e21e 1961 once = !(rpm->op_pmflags & PMf_GLOBAL);
71be2cbc
PP
1962
1963 /* known replacement string? */
f272994b
A
1964 if (dstr) {
1965 c = SvPV(dstr, clen);
1966 doutf8 = DO_UTF8(dstr);
1967 }
1968 else {
1969 c = Nullch;
1970 doutf8 = FALSE;
1971 }
1972
71be2cbc 1973 /* can do inplace substitution? */
22e551b9 1974 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
d9f97599 1975 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
f722798b
IZ
1976 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1977 r_flags | REXEC_CHECKED))
1978 {
8ec5e241 1979 SPAGAIN;
3280af22 1980 PUSHs(&PL_sv_no);
71be2cbc
PP
1981 LEAVE_SCOPE(oldsave);
1982 RETURN;
1983 }
1984 if (force_on_match) {
1985 force_on_match = 0;
1986 s = SvPV_force(TARG, len);
1987 goto force_it;
1988 }
71be2cbc 1989 d = s;
3280af22 1990 PL_curpm = pm;
71be2cbc
PP
1991 SvSCREAM_off(TARG); /* disable possible screamer */
1992 if (once) {
48c036b1 1993 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d
IZ
1994 m = orig + rx->startp[0];
1995 d = orig + rx->endp[0];
71be2cbc
PP
1996 s = orig;
1997 if (m - s > strend - d) { /* faster to shorten from end */
1998 if (clen) {
1999 Copy(c, m, clen, char);
2000 m += clen;
a0d0e21e 2001 }
71be2cbc
PP
2002 i = strend - d;
2003 if (i > 0) {
2004 Move(d, m, i, char);
2005 m += i;
a0d0e21e 2006 }
71be2cbc
PP
2007 *m = '\0';
2008 SvCUR_set(TARG, m - s);
2009 }
2010 /*SUPPRESS 560*/
155aba94 2011 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
2012 d -= clen;
2013 m = d;
2014 sv_chop(TARG, d-i);
2015 s += i;
2016 while (i--)
2017 *--d = *--s;
2018 if (clen)
2019 Copy(c, m, clen, char);
2020 }
2021 else if (clen) {
2022 d -= clen;
2023 sv_chop(TARG, d);
2024 Copy(c, d, clen, char);
2025 }
2026 else {
2027 sv_chop(TARG, d);
2028 }
48c036b1 2029 TAINT_IF(rxtainted & 1);
8ec5e241 2030 SPAGAIN;
3280af22 2031 PUSHs(&PL_sv_yes);
71be2cbc
PP
2032 }
2033 else {
71be2cbc
PP
2034 do {
2035 if (iters++ > maxiters)
cea2e8a9 2036 DIE(aTHX_ "Substitution loop");
d9f97599 2037 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2038 m = rx->startp[0] + orig;
71be2cbc 2039 /*SUPPRESS 560*/
155aba94 2040 if ((i = m - s)) {
71be2cbc
PP
2041 if (s != d)
2042 Move(s, d, i, char);
2043 d += i;
a0d0e21e 2044 }
71be2cbc
PP
2045 if (clen) {
2046 Copy(c, d, clen, char);
2047 d += clen;
2048 }
cf93c79d 2049 s = rx->endp[0] + orig;
cea2e8a9 2050 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
f722798b
IZ
2051 TARG, NULL,
2052 /* don't match same null twice */
2053 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
2054 if (s != d) {
2055 i = strend - s;
2056 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2057 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2058 }
48c036b1 2059 TAINT_IF(rxtainted & 1);
8ec5e241 2060 SPAGAIN;
71be2cbc 2061 PUSHs(sv_2mortal(newSViv((I32)iters)));
a0d0e21e 2062 }
80b498e0 2063 (void)SvPOK_only_UTF8(TARG);
48c036b1 2064 TAINT_IF(rxtainted);
8ec5e241
NIS
2065 if (SvSMAGICAL(TARG)) {
2066 PUTBACK;
2067 mg_set(TARG);
2068 SPAGAIN;
2069 }
9212bbba 2070 SvTAINT(TARG);
71be2cbc
PP
2071 LEAVE_SCOPE(oldsave);
2072 RETURN;
a0d0e21e 2073 }
71be2cbc 2074
f722798b
IZ
2075 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2076 r_flags | REXEC_CHECKED))
2077 {
a0d0e21e
LW
2078 if (force_on_match) {
2079 force_on_match = 0;
2080 s = SvPV_force(TARG, len);
2081 goto force_it;
2082 }
48c036b1 2083 rxtainted |= RX_MATCH_TAINTED(rx);
8ec5e241 2084 dstr = NEWSV(25, len);
a0d0e21e 2085 sv_setpvn(dstr, m, s-m);
ffc61ed2
JH
2086 if (DO_UTF8(TARG))
2087 SvUTF8_on(dstr);
3280af22 2088 PL_curpm = pm;
a0d0e21e 2089 if (!c) {
c09156bb 2090 register PERL_CONTEXT *cx;
8ec5e241 2091 SPAGAIN;
a0d0e21e
LW
2092 PUSHSUBST(cx);
2093 RETURNOP(cPMOP->op_pmreplroot);
2094 }
cf93c79d 2095 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2096 do {
2097 if (iters++ > maxiters)
cea2e8a9 2098 DIE(aTHX_ "Substitution loop");
d9f97599 2099 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2100 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW
2101 m = s;
2102 s = orig;
cf93c79d 2103 orig = rx->subbeg;
a0d0e21e
LW
2104 s = orig + (m - s);
2105 strend = s + (strend - m);
2106 }
cf93c79d 2107 m = rx->startp[0] + orig;
a0d0e21e 2108 sv_catpvn(dstr, s, m-s);
cf93c79d 2109 s = rx->endp[0] + orig;
a0d0e21e
LW
2110 if (clen)
2111 sv_catpvn(dstr, c, clen);
2112 if (once)
2113 break;
ffc61ed2
JH
2114 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2115 TARG, NULL, r_flags));
a0d0e21e 2116 sv_catpvn(dstr, s, strend - s);
748a9306 2117
4633a7c4 2118 (void)SvOOK_off(TARG);
cb0b1708 2119 Safefree(SvPVX(TARG));
748a9306
LW
2120 SvPVX(TARG) = SvPVX(dstr);
2121 SvCUR_set(TARG, SvCUR(dstr));
2122 SvLEN_set(TARG, SvLEN(dstr));
f272994b 2123 doutf8 |= DO_UTF8(dstr);
748a9306
LW
2124 SvPVX(dstr) = 0;
2125 sv_free(dstr);
2126
48c036b1 2127 TAINT_IF(rxtainted & 1);
f878fbec 2128 SPAGAIN;
48c036b1
GS
2129 PUSHs(sv_2mortal(newSViv((I32)iters)));
2130
a0d0e21e 2131 (void)SvPOK_only(TARG);
f272994b 2132 if (doutf8)
60aeb6fd 2133 SvUTF8_on(TARG);
48c036b1 2134 TAINT_IF(rxtainted);
a0d0e21e 2135 SvSETMAGIC(TARG);
9212bbba 2136 SvTAINT(TARG);
4633a7c4 2137 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2138 RETURN;
2139 }
5cd24f17 2140 goto ret_no;
a0d0e21e
LW
2141
2142nope:
1c846c1f 2143ret_no:
8ec5e241 2144 SPAGAIN;
3280af22 2145 PUSHs(&PL_sv_no);
4633a7c4 2146 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2147 RETURN;
2148}
2149
2150PP(pp_grepwhile)
2151{
39644a26 2152 dSP;
a0d0e21e
LW
2153
2154 if (SvTRUEx(POPs))
3280af22
NIS
2155 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2156 ++*PL_markstack_ptr;
a0d0e21e
LW
2157 LEAVE; /* exit inner scope */
2158
2159 /* All done yet? */
3280af22 2160 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2161 I32 items;
54310121 2162 I32 gimme = GIMME_V;
a0d0e21e
LW
2163
2164 LEAVE; /* exit outer scope */
2165 (void)POPMARK; /* pop src */
3280af22 2166 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2167 (void)POPMARK; /* pop dst */
3280af22 2168 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2169 if (gimme == G_SCALAR) {
a0d0e21e
LW
2170 dTARGET;
2171 XPUSHi(items);
a0d0e21e 2172 }
54310121
PP
2173 else if (gimme == G_ARRAY)
2174 SP += items;
a0d0e21e
LW
2175 RETURN;
2176 }
2177 else {
2178 SV *src;
2179
2180 ENTER; /* enter inner scope */
1d7c1841 2181 SAVEVPTR(PL_curpm);
a0d0e21e 2182
3280af22 2183 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2184 SvTEMP_off(src);
54b9620d 2185 DEFSV = src;
a0d0e21e
LW
2186
2187 RETURNOP(cLOGOP->op_other);
2188 }
2189}
2190
2191PP(pp_leavesub)
2192{
39644a26 2193 dSP;
a0d0e21e
LW
2194 SV **mark;
2195 SV **newsp;
2196 PMOP *newpm;
2197 I32 gimme;
c09156bb 2198 register PERL_CONTEXT *cx;
b0d9ce38 2199 SV *sv;
a0d0e21e
LW
2200
2201 POPBLOCK(cx,newpm);
1c846c1f 2202
a1f49e72 2203 TAINT_NOT;
a0d0e21e
LW
2204 if (gimme == G_SCALAR) {
2205 MARK = newsp + 1;
a29cdaf0 2206 if (MARK <= SP) {
a8bba7fa 2207 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2208 if (SvTEMP(TOPs)) {
2209 *MARK = SvREFCNT_inc(TOPs);
2210 FREETMPS;
2211 sv_2mortal(*MARK);
cd06dffe
GS
2212 }
2213 else {
959e3673 2214 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2215 FREETMPS;
959e3673
GS
2216 *MARK = sv_mortalcopy(sv);
2217 SvREFCNT_dec(sv);
a29cdaf0 2218 }
cd06dffe
GS
2219 }
2220 else
a29cdaf0 2221 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS
2222 }
2223 else {
f86702cc 2224 MEXTEND(MARK, 0);
3280af22 2225 *MARK = &PL_sv_undef;
a0d0e21e
LW
2226 }
2227 SP = MARK;
2228 }
54310121 2229 else if (gimme == G_ARRAY) {
f86702cc 2230 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2231 if (!SvTEMP(*MARK)) {
f86702cc 2232 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2233 TAINT_NOT; /* Each item is independent */
2234 }
f86702cc 2235 }
a0d0e21e 2236 }
f86702cc 2237 PUTBACK;
1c846c1f 2238
b0d9ce38 2239 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2240 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW
2241
2242 LEAVE;
b0d9ce38 2243 LEAVESUB(sv);
a0d0e21e
LW
2244 return pop_return();
2245}
2246
cd06dffe
GS
2247/* This duplicates the above code because the above code must not
2248 * get any slower by more conditions */
2249PP(pp_leavesublv)
2250{
39644a26 2251 dSP;
cd06dffe
GS
2252 SV **mark;
2253 SV **newsp;
2254 PMOP *newpm;
2255 I32 gimme;
2256 register PERL_CONTEXT *cx;
b0d9ce38 2257 SV *sv;
cd06dffe
GS
2258
2259 POPBLOCK(cx,newpm);
1c846c1f 2260
cd06dffe
GS
2261 TAINT_NOT;
2262
2263 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2264 /* We are an argument to a function or grep().
2265 * This kind of lvalueness was legal before lvalue
2266 * subroutines too, so be backward compatible:
2267 * cannot report errors. */
2268
2269 /* Scalar context *is* possible, on the LHS of -> only,
2270 * as in f()->meth(). But this is not an lvalue. */
2271 if (gimme == G_SCALAR)
2272 goto temporise;
2273 if (gimme == G_ARRAY) {
a8bba7fa 2274 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS
2275 goto temporise_array;
2276 EXTEND_MORTAL(SP - newsp);
2277 for (mark = newsp + 1; mark <= SP; mark++) {
2278 if (SvTEMP(*mark))
2279 /* empty */ ;
2280 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2281 *mark = sv_mortalcopy(*mark);
2282 else {
2283 /* Can be a localized value subject to deletion. */
2284 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2285 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2286 }
2287 }
2288 }
2289 }
2290 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2291 /* Here we go for robustness, not for speed, so we change all
2292 * the refcounts so the caller gets a live guy. Cannot set
2293 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2294 if (!CvLVALUE(cx->blk_sub.cv)) {
b0d9ce38 2295 POPSUB(cx,sv);
d470f89e 2296 PL_curpm = newpm;
b0d9ce38
GS
2297 LEAVE;
2298 LEAVESUB(sv);
d470f89e
GS
2299 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2300 }
cd06dffe
GS
2301 if (gimme == G_SCALAR) {
2302 MARK = newsp + 1;
2303 EXTEND_MORTAL(1);
2304 if (MARK == SP) {
d470f89e 2305 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
b0d9ce38 2306 POPSUB(cx,sv);
d470f89e 2307 PL_curpm = newpm;
b0d9ce38
GS
2308 LEAVE;
2309 LEAVESUB(sv);
d470f89e 2310 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
cd06dffe 2311 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2312 }
cd06dffe
GS
2313 else { /* Can be a localized value
2314 * subject to deletion. */
2315 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2316 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2317 }
2318 }
d470f89e 2319 else { /* Should not happen? */
b0d9ce38 2320 POPSUB(cx,sv);
d470f89e 2321 PL_curpm = newpm;
b0d9ce38
GS
2322 LEAVE;
2323 LEAVESUB(sv);
d470f89e 2324 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
cd06dffe 2325 (MARK > SP ? "Empty array" : "Array"));
d470f89e 2326 }
cd06dffe
GS
2327 SP = MARK;
2328 }
2329 else if (gimme == G_ARRAY) {
2330 EXTEND_MORTAL(SP - newsp);
2331 for (mark = newsp + 1; mark <= SP; mark++) {
f206cdda
AMS
2332 if (*mark != &PL_sv_undef
2333 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
d470f89e
GS
2334 /* Might be flattened array after $#array = */
2335 PUTBACK;
b0d9ce38 2336 POPSUB(cx,sv);
d470f89e 2337 PL_curpm = newpm;
b0d9ce38
GS
2338 LEAVE;
2339 LEAVESUB(sv);
f206cdda
AMS
2340 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2341 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2342 }
cd06dffe 2343 else {
cd06dffe
GS
2344 /* Can be a localized value subject to deletion. */
2345 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2346 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2347 }
2348 }
2349 }
2350 }
2351 else {
2352 if (gimme == G_SCALAR) {
2353 temporise:
2354 MARK = newsp + 1;
2355 if (MARK <= SP) {
a8bba7fa 2356 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS
2357 if (SvTEMP(TOPs)) {
2358 *MARK = SvREFCNT_inc(TOPs);
2359 FREETMPS;
2360 sv_2mortal(*MARK);
2361 }
2362 else {
959e3673 2363 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2364 FREETMPS;
959e3673
GS
2365 *MARK = sv_mortalcopy(sv);
2366 SvREFCNT_dec(sv);
cd06dffe
GS
2367 }
2368 }
2369 else
2370 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2371 }
2372 else {
2373 MEXTEND(MARK, 0);
2374 *MARK = &PL_sv_undef;
2375 }
2376 SP = MARK;
2377 }
2378 else if (gimme == G_ARRAY) {
2379 temporise_array:
2380 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2381 if (!SvTEMP(*MARK)) {
2382 *MARK = sv_mortalcopy(*MARK);
2383 TAINT_NOT; /* Each item is independent */
2384 }
2385 }
2386 }
2387 }
2388 PUTBACK;
1c846c1f 2389
b0d9ce38 2390 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS
2391 PL_curpm = newpm; /* ... and pop $1 et al */
2392
2393 LEAVE;
b0d9ce38 2394 LEAVESUB(sv);
cd06dffe
GS
2395 return pop_return();
2396}
2397
2398
76e3520e 2399STATIC CV *
cea2e8a9 2400S_get_db_sub(pTHX_ SV **svp, CV *cv)
3de9ffa1 2401{
3280af22 2402 SV *dbsv = GvSV(PL_DBsub);
491527d0
GS
2403
2404 if (!PERLDB_SUB_NN) {
2405 GV *gv = CvGV(cv);
2406
2407 save_item(dbsv);
2408 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1c846c1f 2409 || strEQ(GvNAME(gv), "END")
491527d0
GS
2410 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2411 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2412 && (gv = (GV*)*svp) ))) {
2413 /* Use GV from the stack as a fallback. */
2414 /* GV is potentially non-unique, or contain different CV. */
c2e66d9e
GS
2415 SV *tmp = newRV((SV*)cv);
2416 sv_setsv(dbsv, tmp);
2417 SvREFCNT_dec(tmp);
491527d0
GS
2418 }
2419 else {
2420 gv_efullname3(dbsv, gv, Nullch);
2421 }
3de9ffa1
MB
2422 }
2423 else {
155aba94
GS
2424 (void)SvUPGRADE(dbsv, SVt_PVIV);
2425 (void)SvIOK_on(dbsv);
491527d0 2426 SAVEIV(SvIVX(dbsv));
5bc28da9 2427 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
3de9ffa1 2428 }
491527d0 2429
3de9ffa1 2430 if (CvXSUB(cv))
3280af22
NIS
2431 PL_curcopdb = PL_curcop;
2432 cv = GvCV(PL_DBsub);
3de9ffa1
MB
2433 return cv;
2434}
2435
a0d0e21e
LW
2436PP(pp_entersub)
2437{
39644a26 2438 dSP; dPOPss;
a0d0e21e
LW
2439 GV *gv;
2440 HV *stash;
2441 register CV *cv;
c09156bb 2442 register PERL_CONTEXT *cx;
5d94fbed 2443 I32 gimme;
533c011a 2444 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2445
2446 if (!sv)
cea2e8a9 2447 DIE(aTHX_ "Not a CODE reference");
a0d0e21e
LW
2448 switch (SvTYPE(sv)) {
2449 default:
2450 if (!SvROK(sv)) {
748a9306 2451 char *sym;
2d8e6c8d 2452 STRLEN n_a;
748a9306 2453
3280af22 2454 if (sv == &PL_sv_yes) { /* unfound import, ignore */
fb73857a 2455 if (hasargs)
3280af22 2456 SP = PL_stack_base + POPMARK;
a0d0e21e 2457 RETURN;
fb73857a 2458 }
15ff848f
CS
2459 if (SvGMAGICAL(sv)) {
2460 mg_get(sv);
f5f1d18e
AMS
2461 if (SvROK(sv))
2462 goto got_rv;
15ff848f
CS
2463 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2464 }
2465 else
2d8e6c8d 2466 sym = SvPV(sv, n_a);
15ff848f 2467 if (!sym)
cea2e8a9 2468 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2469 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 2470 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
864dbfa3 2471 cv = get_cv(sym, TRUE);
a0d0e21e
LW
2472 break;
2473 }
f5f1d18e 2474 got_rv:
f5284f61
IZ
2475 {
2476 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2477 tryAMAGICunDEREF(to_cv);
2478 }
a0d0e21e
LW
2479 cv = (CV*)SvRV(sv);
2480 if (SvTYPE(cv) == SVt_PVCV)
2481 break;
2482 /* FALL THROUGH */
2483 case SVt_PVHV:
2484 case SVt_PVAV:
cea2e8a9 2485 DIE(aTHX_ "Not a CODE reference");
a0d0e21e
LW
2486 case SVt_PVCV:
2487 cv = (CV*)sv;
2488 break;
2489 case SVt_PVGV:
8ebc5c01 2490 if (!(cv = GvCVu((GV*)sv)))
f6ec51f7
GS
2491 cv = sv_2cv(sv, &stash, &gv, FALSE);
2492 if (!cv) {
2493 ENTER;
2494 SAVETMPS;
2495 goto try_autoload;
2496 }
2497 break;
a0d0e21e
LW
2498 }
2499
2500 ENTER;
2501 SAVETMPS;
2502
2503 retry:
a0d0e21e 2504 if (!CvROOT(cv) && !CvXSUB(cv)) {
44a8e56a 2505 GV* autogv;
22239a37 2506 SV* sub_name;
44a8e56a
PP
2507
2508 /* anonymous or undef'd function leaves us no recourse */
2509 if (CvANON(cv) || !(gv = CvGV(cv)))
cea2e8a9 2510 DIE(aTHX_ "Undefined subroutine called");
67caa1fe 2511
44a8e56a
PP
2512 /* autoloaded stub? */
2513 if (cv != GvCV(gv)) {
2514 cv = GvCV(gv);
a0d0e21e 2515 }
44a8e56a 2516 /* should call AUTOLOAD now? */
67caa1fe 2517 else {
f6ec51f7
GS
2518try_autoload:
2519 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2520 FALSE)))
2521 {
2522 cv = GvCV(autogv);
2523 }
2524 /* sorry */
2525 else {
2526 sub_name = sv_newmortal();
2527 gv_efullname3(sub_name, gv, Nullch);
cea2e8a9 2528 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
f6ec51f7 2529 }
67caa1fe
GS
2530 }
2531 if (!cv)
cea2e8a9 2532 DIE(aTHX_ "Not a CODE reference");
67caa1fe 2533 goto retry;
a0d0e21e
LW
2534 }
2535
54310121 2536 gimme = GIMME_V;
67caa1fe 2537 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
4f01c5a5 2538 cv = get_db_sub(&sv, cv);
67caa1fe 2539 if (!cv)
cea2e8a9 2540 DIE(aTHX_ "No DBsub routine");
67caa1fe 2541 }
a0d0e21e 2542
4d1ff10f 2543#ifdef USE_5005THREADS
3de9ffa1
MB
2544 /*
2545 * First we need to check if the sub or method requires locking.
458fb581
MB
2546 * If so, we gain a lock on the CV, the first argument or the
2547 * stash (for static methods), as appropriate. This has to be
2548 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2549 * reschedule by returning a new op.
3de9ffa1 2550 */
11343788 2551 MUTEX_LOCK(CvMUTEXP(cv));
77a005ab
MB
2552 if (CvFLAGS(cv) & CVf_LOCKED) {
2553 MAGIC *mg;
2554 if (CvFLAGS(cv) & CVf_METHOD) {
533c011a
NIS
2555 if (SP > PL_stack_base + TOPMARK)
2556 sv = *(PL_stack_base + TOPMARK + 1);
77a005ab 2557 else {
13e08037
GS
2558 AV *av = (AV*)PL_curpad[0];
2559 if (hasargs || !av || AvFILLp(av) < 0
2560 || !(sv = AvARRAY(av)[0]))
2561 {
2562 MUTEX_UNLOCK(CvMUTEXP(cv));
d470f89e 2563 DIE(aTHX_ "no argument for locked method call");
13e08037 2564 }
77a005ab
MB
2565 }
2566 if (SvROK(sv))
2567 sv = SvRV(sv);
458fb581
MB
2568 else {
2569 STRLEN len;
2570 char *stashname = SvPV(sv, len);
2571 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2572 }
77a005ab
MB
2573 }
2574 else {
2575 sv = (SV*)cv;
2576 }
2577 MUTEX_UNLOCK(CvMUTEXP(cv));
2578 mg = condpair_magic(sv);
2579 MUTEX_LOCK(MgMUTEXP(mg));
2580 if (MgOWNER(mg) == thr)
2581 MUTEX_UNLOCK(MgMUTEXP(mg));
2582 else {
2583 while (MgOWNER(mg))
2584 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2585 MgOWNER(mg) = thr;
bf49b057 2586 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
a674cc95 2587 thr, sv));
77a005ab 2588 MUTEX_UNLOCK(MgMUTEXP(mg));
c76ac1ee 2589 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
11343788 2590 }
77a005ab 2591 MUTEX_LOCK(CvMUTEXP(cv));
11343788 2592 }
3de9ffa1
MB
2593 /*
2594 * Now we have permission to enter the sub, we must distinguish
2595 * four cases. (0) It's an XSUB (in which case we don't care
2596 * about ownership); (1) it's ours already (and we're recursing);
2597 * (2) it's free (but we may already be using a cached clone);
2598 * (3) another thread owns it. Case (1) is easy: we just use it.
2599 * Case (2) means we look for a clone--if we have one, use it
2600 * otherwise grab ownership of cv. Case (3) means we look for a
2601 * clone (for non-XSUBs) and have to create one if we don't
2602 * already have one.
2603 * Why look for a clone in case (2) when we could just grab
2604 * ownership of cv straight away? Well, we could be recursing,
2605 * i.e. we originally tried to enter cv while another thread
2606 * owned it (hence we used a clone) but it has been freed up
2607 * and we're now recursing into it. It may or may not be "better"
2608 * to use the clone but at least CvDEPTH can be trusted.
2609 */
2610 if (CvOWNER(cv) == thr || CvXSUB(cv))
2611 MUTEX_UNLOCK(CvMUTEXP(cv));
11343788 2612 else {
3de9ffa1
MB
2613 /* Case (2) or (3) */
2614 SV **svp;
2615
11343788 2616 /*
3de9ffa1
MB
2617 * XXX Might it be better to release CvMUTEXP(cv) while we
2618 * do the hv_fetch? We might find someone has pinched it
2619 * when we look again, in which case we would be in case
2620 * (3) instead of (2) so we'd have to clone. Would the fact
2621 * that we released the mutex more quickly make up for this?
2622 */
b099ddc0 2623 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
6ee623d5 2624 {
3de9ffa1 2625 /* We already have a clone to use */
11343788 2626 MUTEX_UNLOCK(CvMUTEXP(cv));
3de9ffa1 2627 cv = *(CV**)svp;
bf49b057 2628 DEBUG_S(PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2629 "entersub: %p already has clone %p:%s\n",
2630 thr, cv, SvPEEK((SV*)cv)));
3de9ffa1
MB
2631 CvOWNER(cv) = thr;
2632 SvREFCNT_inc(cv);
2633 if (CvDEPTH(cv) == 0)
c76ac1ee 2634 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
3de9ffa1 2635 }
11343788 2636 else {
3de9ffa1
MB
2637 /* (2) => grab ownership of cv. (3) => make clone */
2638 if (!CvOWNER(cv)) {
2639 CvOWNER(cv) = thr;
2640 SvREFCNT_inc(cv);
11343788 2641 MUTEX_UNLOCK(CvMUTEXP(cv));
bf49b057 2642 DEBUG_S(PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2643 "entersub: %p grabbing %p:%s in stash %s\n",
2644 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
3de9ffa1 2645 HvNAME(CvSTASH(cv)) : "(none)"));
cd06dffe
GS
2646 }
2647 else {
3de9ffa1
MB
2648 /* Make a new clone. */
2649 CV *clonecv;
2650 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2651 MUTEX_UNLOCK(CvMUTEXP(cv));
bf49b057 2652 DEBUG_S((PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2653 "entersub: %p cloning %p:%s\n",
2654 thr, cv, SvPEEK((SV*)cv))));
3de9ffa1
MB
2655 /*
2656 * We're creating a new clone so there's no race
2657 * between the original MUTEX_UNLOCK and the
2658 * SvREFCNT_inc since no one will be trying to undef
2659 * it out from underneath us. At least, I don't think
2660 * there's a race...
2661 */
2662 clonecv = cv_clone(cv);
2663 SvREFCNT_dec(cv); /* finished with this */
199100c8 2664 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
3de9ffa1
MB
2665 CvOWNER(clonecv) = thr;
2666 cv = clonecv;
11343788 2667 SvREFCNT_inc(cv);
11343788 2668 }
8b73bbec 2669 DEBUG_S(if (CvDEPTH(cv) != 0)
bf49b057 2670 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
755b0776 2671 CvDEPTH(cv)));
c76ac1ee 2672 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
11343788 2673 }
3de9ffa1 2674 }
4d1ff10f 2675#endif /* USE_5005THREADS */
11343788 2676
a0d0e21e 2677 if (CvXSUB(cv)) {
67caa1fe 2678#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2679 if (CvOLDSTYLE(cv)) {
20ce7b12 2680 I32 (*fp3)(int,int,int);
a0d0e21e
LW
2681 dMARK;
2682 register I32 items = SP - MARK;
67955e0c 2683 /* We dont worry to copy from @_. */
924508f0
GS
2684 while (SP > mark) {
2685 SP[1] = SP[0];
2686 SP--;
a0d0e21e 2687 }
3280af22 2688 PL_stack_sp = mark + 1;
1d7c1841 2689 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
1c846c1f 2690 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2691 MARK - PL_stack_base + 1,
ecfc5424 2692 items);
3280af22 2693 PL_stack_sp = PL_stack_base + items;
a0d0e21e 2694 }
67caa1fe
GS
2695 else
2696#endif /* PERL_XSUB_OLDSTYLE */
2697 {
748a9306
LW
2698 I32 markix = TOPMARK;
2699
a0d0e21e 2700 PUTBACK;
67955e0c
PP
2701
2702 if (!hasargs) {
2703 /* Need to copy @_ to stack. Alternative may be to
2704 * switch stack to @_, and copy return values
2705 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
6d4ff0d2
MB
2706 AV* av;
2707 I32 items;
4d1ff10f 2708#ifdef USE_5005THREADS
533c011a 2709 av = (AV*)PL_curpad[0];
6d4ff0d2 2710#else
3280af22 2711 av = GvAV(PL_defgv);
4d1ff10f 2712#endif /* USE_5005THREADS */
93965878 2713 items = AvFILLp(av) + 1; /* @_ is not tieable */
67955e0c
PP
2714
2715 if (items) {
2716 /* Mark is at the end of the stack. */
924508f0
GS
2717 EXTEND(SP, items);
2718 Copy(AvARRAY(av), SP + 1, items, SV*);
2719 SP += items;
1c846c1f 2720 PUTBACK ;
67955e0c
PP
2721 }
2722 }
67caa1fe
GS
2723 /* We assume first XSUB in &DB::sub is the called one. */
2724 if (PL_curcopdb) {
1d7c1841 2725 SAVEVPTR(PL_curcop);
3280af22
NIS
2726 PL_curcop = PL_curcopdb;
2727 PL_curcopdb = NULL;
67955e0c
PP
2728 }
2729 /* Do we need to open block here? XXXX */
acfe0abc 2730 (void)(*CvXSUB(cv))(aTHX_ cv);
748a9306
LW
2731
2732 /* Enforce some sanity in scalar context. */
3280af22
NIS
2733 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2734 if (markix > PL_stack_sp - PL_stack_base)
2735 *(PL_stack_base + markix) = &PL_sv_undef;
748a9306 2736 else
3280af22
NIS
2737 *(PL_stack_base + markix) = *PL_stack_sp;
2738 PL_stack_sp = PL_stack_base + markix;
748a9306 2739 }
a0d0e21e
LW
2740 }
2741 LEAVE;
2742 return NORMAL;
2743 }
2744 else {
2745 dMARK;
2746 register I32 items = SP - MARK;
a0d0e21e
LW
2747 AV* padlist = CvPADLIST(cv);
2748 SV** svp = AvARRAY(padlist);
533c011a 2749 push_return(PL_op->op_next);
a0d0e21e
LW
2750 PUSHBLOCK(cx, CXt_SUB, MARK);
2751 PUSHSUB(cx);
2752 CvDEPTH(cv)++;
6b35e009
GS
2753 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2754 * that eval'' ops within this sub know the correct lexical space.
2755 * Owing the speed considerations, we choose to search for the cv
2756 * in doeval() instead.
2757 */
a0d0e21e
LW
2758 if (CvDEPTH(cv) < 2)
2759 (void)SvREFCNT_inc(cv);
2760 else { /* save temporaries on recursion? */
1d7c1841 2761 PERL_STACK_OVERFLOW_CHECK();
93965878 2762 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e
LW
2763 AV *av;
2764 AV *newpad = newAV();
4aa0a1f7 2765 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2766 I32 ix = AvFILLp((AV*)svp[1]);
1d7c1841 2767 I32 names_fill = AvFILLp((AV*)svp[0]);
a0d0e21e 2768 svp = AvARRAY(svp[0]);
748a9306 2769 for ( ;ix > 0; ix--) {
1d7c1841 2770 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
748a9306 2771 char *name = SvPVX(svp[ix]);
5f05dabc
PP
2772 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2773 || *name == '&') /* anonymous code? */
2774 {
2775 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
748a9306
LW
2776 }
2777 else { /* our own lexical */
2778 if (*name == '@')
2779 av_store(newpad, ix, sv = (SV*)newAV());
2780 else if (*name == '%')
2781 av_store(newpad, ix, sv = (SV*)newHV());
2782 else
2783 av_store(newpad, ix, sv = NEWSV(0,0));
2784 SvPADMY_on(sv);
2785 }
a0d0e21e 2786 }
1d7c1841
GS
2787 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2788 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2789 }
a0d0e21e 2790 else {
748a9306 2791 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW
2792 SvPADTMP_on(sv);
2793 }
2794 }
2795 av = newAV(); /* will be @_ */
2796 av_extend(av, 0);
2797 av_store(newpad, 0, (SV*)av);
2798 AvFLAGS(av) = AVf_REIFY;
2799 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2800 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW
2801 svp = AvARRAY(padlist);
2802 }
2803 }
4d1ff10f 2804#ifdef USE_5005THREADS
6d4ff0d2 2805 if (!hasargs) {
533c011a 2806 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2807
93965878 2808 items = AvFILLp(av) + 1;
6d4ff0d2
MB
2809 if (items) {
2810 /* Mark is at the end of the stack. */
924508f0
GS
2811 EXTEND(SP, items);
2812 Copy(AvARRAY(av), SP + 1, items, SV*);
2813 SP += items;
1c846c1f 2814 PUTBACK ;
6d4ff0d2
MB
2815 }
2816 }
4d1ff10f 2817#endif /* USE_5005THREADS */
1d7c1841 2818 SAVEVPTR(PL_curpad);
3280af22 2819 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
4d1ff10f 2820#ifndef USE_5005THREADS
6d4ff0d2 2821 if (hasargs)
4d1ff10f 2822#endif /* USE_5005THREADS */
6d4ff0d2
MB
2823 {
2824 AV* av;
a0d0e21e
LW
2825 SV** ary;
2826
77a005ab 2827#if 0
bf49b057 2828 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2829 "%p entersub preparing @_\n", thr));
77a005ab 2830#endif
3280af22 2831 av = (AV*)PL_curpad[0];
221373f0
GS
2832 if (AvREAL(av)) {
2833 /* @_ is normally not REAL--this should only ever
2834 * happen when DB::sub() calls things that modify @_ */
2835 av_clear(av);
2836 AvREAL_off(av);
2837 AvREIFY_on(av);
2838 }
4d1ff10f 2839#ifndef USE_5005THREADS
3280af22
NIS
2840 cx->blk_sub.savearray = GvAV(PL_defgv);
2841 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
4d1ff10f 2842#endif /* USE_5005THREADS */
7032098e 2843 cx->blk_sub.oldcurpad = PL_curpad;
6d4ff0d2 2844 cx->blk_sub.argarray = av;
a0d0e21e
LW
2845 ++MARK;
2846
2847 if (items > AvMAX(av) + 1) {
2848 ary = AvALLOC(av);
2849 if (AvARRAY(av) != ary) {
2850 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2851 SvPVX(av) = (char*)ary;
2852 }
2853 if (items > AvMAX(av) + 1) {
2854 AvMAX(av) = items - 1;
2855 Renew(ary,items,SV*);
2856 AvALLOC(av) = ary;
2857 SvPVX(av) = (char*)ary;
2858 }
2859 }
2860 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2861 AvFILLp(av) = items - 1;
1c846c1f 2862
a0d0e21e
LW
2863 while (items--) {
2864 if (*MARK)
2865 SvTEMP_off(*MARK);
2866 MARK++;
2867 }
2868 }
4a925ff6
GS
2869 /* warning must come *after* we fully set up the context
2870 * stuff so that __WARN__ handlers can safely dounwind()
2871 * if they want to
2872 */
2873 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2874 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2875 sub_crush_depth(cv);
77a005ab 2876#if 0
bf49b057 2877 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2878 "%p entersub returning %p\n", thr, CvSTART(cv)));
77a005ab 2879#endif
a0d0e21e
LW
2880 RETURNOP(CvSTART(cv));
2881 }
2882}
2883
44a8e56a 2884void
864dbfa3 2885Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a
PP
2886{
2887 if (CvANON(cv))
9014280d 2888 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a
PP
2889 else {
2890 SV* tmpstr = sv_newmortal();
2891 gv_efullname3(tmpstr, CvGV(cv), Nullch);
9014280d 2892 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
599cee73 2893 SvPVX(tmpstr));
44a8e56a
PP
2894 }
2895}
2896
a0d0e21e
LW
2897PP(pp_aelem)
2898{
39644a26 2899 dSP;
a0d0e21e 2900 SV** svp;
d804643f
SC
2901 SV* elemsv = POPs;
2902 IV elem = SvIV(elemsv);
68dc0745 2903 AV* av = (AV*)POPs;
78f9721b 2904 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
533c011a 2905 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
be6c24e0 2906 SV *sv;
a0d0e21e 2907
e35c1634 2908 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
9014280d 2909 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
748a9306 2910 if (elem > 0)
3280af22 2911 elem -= PL_curcop->cop_arybase;
a0d0e21e
LW
2912 if (SvTYPE(av) != SVt_PVAV)
2913 RETPUSHUNDEF;
68dc0745 2914 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2915 if (lval) {
3280af22 2916 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2917 SV* lv;
2918 if (!defer)
cea2e8a9 2919 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2920 lv = sv_newmortal();
2921 sv_upgrade(lv, SVt_PVLV);
2922 LvTYPE(lv) = 'y';
14befaf4 2923 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
2924 LvTARG(lv) = SvREFCNT_inc(av);
2925 LvTARGOFF(lv) = elem;
2926 LvTARGLEN(lv) = 1;
2927 PUSHs(lv);
2928 RETURN;
2929 }
533c011a 2930 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2931 save_aelem(av, elem, svp);
533c011a
NIS
2932 else if (PL_op->op_private & OPpDEREF)
2933 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 2934 }
3280af22 2935 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
2936 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2937 sv = sv_mortalcopy(sv);
2938 PUSHs(sv);
a0d0e21e
LW
2939 RETURN;
2940}
2941
02a9e968 2942void
864dbfa3 2943Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968
CS
2944{
2945 if (SvGMAGICAL(sv))
2946 mg_get(sv);
2947 if (!SvOK(sv)) {
2948 if (SvREADONLY(sv))
cea2e8a9 2949 Perl_croak(aTHX_ PL_no_modify);
5f05dabc
PP
2950 if (SvTYPE(sv) < SVt_RV)
2951 sv_upgrade(sv, SVt_RV);
2952 else if (SvTYPE(sv) >= SVt_PV) {
2953 (void)SvOOK_off(sv);
2954 Safefree(SvPVX(sv));
2955 SvLEN(sv) = SvCUR(sv) = 0;
2956 }
68dc0745 2957 switch (to_what) {
5f05dabc 2958 case OPpDEREF_SV:
8c52afec 2959 SvRV(sv) = NEWSV(355,0);
5f05dabc
PP
2960 break;
2961 case OPpDEREF_AV:
2962 SvRV(sv) = (SV*)newAV();
2963 break;
2964 case OPpDEREF_HV:
2965 SvRV(sv) = (SV*)newHV();
2966 break;
2967 }
02a9e968
CS
2968 SvROK_on(sv);
2969 SvSETMAGIC(sv);
2970 }
2971}
2972
a0d0e21e
LW
2973PP(pp_method)
2974{
39644a26 2975 dSP;
f5d5a27c
CS
2976 SV* sv = TOPs;
2977
2978 if (SvROK(sv)) {
eda383f2 2979 SV* rsv = SvRV(sv);
f5d5a27c
CS
2980 if (SvTYPE(rsv) == SVt_PVCV) {
2981 SETs(rsv);
2982 RETURN;
2983 }
2984 }
2985
2986 SETs(method_common(sv, Null(U32*)));
2987 RETURN;
2988}
2989
2990PP(pp_method_named)
2991{
39644a26 2992 dSP;
f5d5a27c
CS
2993 SV* sv = cSVOP->op_sv;
2994 U32 hash = SvUVX(sv);
2995
2996 XPUSHs(method_common(sv, &hash));
2997 RETURN;
2998}
2999
3000STATIC SV *
3001S_method_common(pTHX_ SV* meth, U32* hashp)
3002{
a0d0e21e
LW
3003 SV* sv;
3004 SV* ob;
3005 GV* gv;
56304f61
CS
3006 HV* stash;
3007 char* name;
f5d5a27c 3008 STRLEN namelen;
9c5ffd7c 3009 char* packname = 0;
ac91690f 3010 STRLEN packlen;
a0d0e21e 3011
f5d5a27c 3012 name = SvPV(meth, namelen);
3280af22 3013 sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 3014
4f1b7578
SC
3015 if (!sv)
3016 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3017
16d20bd9 3018 if (SvGMAGICAL(sv))
af09ea45 3019 mg_get(sv);
a0d0e21e 3020 if (SvROK(sv))
16d20bd9 3021 ob = (SV*)SvRV(sv);
a0d0e21e
LW
3022 else {
3023 GV* iogv;
a0d0e21e 3024
af09ea45 3025 /* this isn't a reference */
56304f61 3026 packname = Nullch;
a0d0e21e 3027 if (!SvOK(sv) ||
56304f61 3028 !(packname = SvPV(sv, packlen)) ||
a0d0e21e
LW
3029 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3030 !(ob=(SV*)GvIO(iogv)))
3031 {
af09ea45 3032 /* this isn't the name of a filehandle either */
1c846c1f 3033 if (!packname ||
fd400ab9 3034 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 3035 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW
3036 : !isIDFIRST(*packname)
3037 ))
3038 {
f5d5a27c
CS
3039 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3040 SvOK(sv) ? "without a package or object reference"
3041 : "on an undefined value");
834a4ddd 3042 }
af09ea45
IK
3043 /* assume it's a package name */
3044 stash = gv_stashpvn(packname, packlen, FALSE);
ac91690f 3045 goto fetch;
a0d0e21e 3046 }
af09ea45 3047 /* it _is_ a filehandle name -- replace with a reference */
3280af22 3048 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e
LW
3049 }
3050
af09ea45 3051 /* if we got here, ob should be a reference or a glob */
f0d43078
GS
3052 if (!ob || !(SvOBJECT(ob)
3053 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3054 && SvOBJECT(ob))))
3055 {
f5d5a27c
CS
3056 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3057 name);
f0d43078 3058 }
a0d0e21e 3059
56304f61 3060 stash = SvSTASH(ob);
a0d0e21e 3061
ac91690f 3062 fetch:
af09ea45
IK
3063 /* NOTE: stash may be null, hope hv_fetch_ent and
3064 gv_fetchmethod can cope (it seems they can) */
3065
f5d5a27c
CS
3066 /* shortcut for simple names */
3067 if (hashp) {
3068 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3069 if (he) {
3070 gv = (GV*)HeVAL(he);
3071 if (isGV(gv) && GvCV(gv) &&
3072 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3073 return (SV*)GvCV(gv);
3074 }
3075 }
3076
ac91690f 3077 gv = gv_fetchmethod(stash, name);
af09ea45 3078
56304f61 3079 if (!gv) {
af09ea45
IK
3080 /* This code tries to figure out just what went wrong with
3081 gv_fetchmethod. It therefore needs to duplicate a lot of
3082 the internals of that function. We can't move it inside
3083 Perl_gv_fetchmethod_autoload(), however, since that would
3084 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3085 don't want that.
3086 */
56304f61
CS
3087 char* leaf = name;
3088 char* sep = Nullch;
3089 char* p;
3090
3091 for (p = name; *p; p++) {
3092 if (*p == '\'')
3093 sep = p, leaf = p + 1;
3094 else if (*p == ':' && *(p + 1) == ':')
3095 sep = p, leaf = p + 2;
3096 }
3097 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
af09ea45
IK
3098 /* the method name is unqualified or starts with SUPER:: */
3099 packname = sep ? CopSTASHPV(PL_curcop) :
3100 stash ? HvNAME(stash) : packname;
56304f61
CS
3101 packlen = strlen(packname);
3102 }
3103 else {
af09ea45 3104 /* the method name is qualified */
56304f61
CS
3105 packname = name;
3106 packlen = sep - name;
3107 }
af09ea45
IK
3108
3109 /* we're relying on gv_fetchmethod not autovivifying the stash */
3110 if (gv_stashpvn(packname, packlen, FALSE)) {
c1899e02 3111 Perl_croak(aTHX_
af09ea45
IK
3112 "Can't locate object method \"%s\" via package \"%.*s\"",
3113 leaf, (int)packlen, packname);
c1899e02
GS
3114 }
3115 else {
3116 Perl_croak(aTHX_
af09ea45
IK
3117 "Can't locate object method \"%s\" via package \"%.*s\""
3118 " (perhaps you forgot to load \"%.*s\"?)",
3119 leaf, (int)packlen, packname, (int)packlen, packname);
c1899e02 3120 }
56304f61 3121 }
f5d5a27c 3122 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
a0d0e21e 3123}
22239a37 3124
4d1ff10f 3125#ifdef USE_5005THREADS
51371543 3126static void
acfe0abc 3127unset_cvowner(pTHX_ void *cvarg)
51371543
GS
3128{
3129 register CV* cv = (CV *) cvarg;
51371543 3130
bf49b057 3131 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
51371543
GS
3132 thr, cv, SvPEEK((SV*)cv))));
3133 MUTEX_LOCK(CvMUTEXP(cv));
3134 DEBUG_S(if (CvDEPTH(cv) != 0)
bf49b057 3135 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
755b0776 3136 CvDEPTH(cv)));
51371543
GS
3137 assert(thr == CvOWNER(cv));
3138 CvOWNER(cv) = 0;
3139 MUTEX_UNLOCK(CvMUTEXP(cv));
3140 SvREFCNT_dec(cv);
3141}
4d1ff10f 3142#endif /* USE_5005THREADS */