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