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