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