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