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