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