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