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