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