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