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