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