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