This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ANSI-clean? (was Re: [PATCH] COW for ithreads)
[perl5.git] / pp_hot.c
CommitLineData
a0d0e21e
LW
1/* pp_hot.c
2 *
be3c0a43 3 * Copyright (c) 1991-2002, Larry Wall
a0d0e21e
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
12 * shaking the air.
13 *
14 * Awake! Awake! Fear, Fire, Foes! Awake!
15 * Fire, Foes! Awake!
16 */
17
18#include "EXTERN.h"
864dbfa3 19#define PERL_IN_PP_HOT_C
a0d0e21e
LW
20#include "perl.h"
21
22/* Hot code. */
23
4d1ff10f 24#ifdef USE_5005THREADS
acfe0abc 25static void unset_cvowner(pTHX_ void *cvarg);
4d1ff10f 26#endif /* USE_5005THREADS */
11343788 27
a0d0e21e
LW
28PP(pp_const)
29{
39644a26 30 dSP;
1d7c1841 31 XPUSHs(cSVOP_sv);
a0d0e21e
LW
32 RETURN;
33}
34
35PP(pp_nextstate)
36{
533c011a 37 PL_curcop = (COP*)PL_op;
a0d0e21e 38 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 39 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW
40 FREETMPS;
41 return NORMAL;
42}
43
44PP(pp_gvsv)
45{
39644a26 46 dSP;
924508f0 47 EXTEND(SP,1);
533c011a 48 if (PL_op->op_private & OPpLVAL_INTRO)
1d7c1841 49 PUSHs(save_scalar(cGVOP_gv));
a0d0e21e 50 else
1d7c1841 51 PUSHs(GvSV(cGVOP_gv));
a0d0e21e
LW
52 RETURN;
53}
54
55PP(pp_null)
56{
57 return NORMAL;
58}
59
7399586d
HS
60PP(pp_setstate)
61{
62 PL_curcop = (COP*)PL_op;
63 return NORMAL;
64}
65
a0d0e21e
LW
66PP(pp_pushmark)
67{
3280af22 68 PUSHMARK(PL_stack_sp);
a0d0e21e
LW
69 return NORMAL;
70}
71
72PP(pp_stringify)
73{
39644a26 74 dSP; dTARGET;
6050d10e 75 sv_copypv(TARG,TOPs);
a0d0e21e
LW
76 SETTARG;
77 RETURN;
78}
79
80PP(pp_gv)
81{
39644a26 82 dSP;
1d7c1841 83 XPUSHs((SV*)cGVOP_gv);
a0d0e21e
LW
84 RETURN;
85}
86
87PP(pp_and)
88{
39644a26 89 dSP;
a0d0e21e
LW
90 if (!SvTRUE(TOPs))
91 RETURN;
92 else {
93 --SP;
94 RETURNOP(cLOGOP->op_other);
95 }
96}
97
98PP(pp_sassign)
99{
39644a26 100 dSP; dPOPTOPssrl;
748a9306 101
533c011a 102 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
a0d0e21e
LW
103 SV *temp;
104 temp = left; left = right; right = temp;
105 }
3280af22 106 if (PL_tainting && PL_tainted && !SvTAINTED(left))
a0d0e21e 107 TAINT_NOT;
54310121 108 SvSetMagicSV(right, left);
a0d0e21e
LW
109 SETs(right);
110 RETURN;
111}
112
113PP(pp_cond_expr)
114{
39644a26 115 dSP;
a0d0e21e 116 if (SvTRUEx(POPs))
1a67a97c 117 RETURNOP(cLOGOP->op_other);
a0d0e21e 118 else
1a67a97c 119 RETURNOP(cLOGOP->op_next);
a0d0e21e
LW
120}
121
122PP(pp_unstack)
123{
124 I32 oldsave;
125 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 126 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 127 FREETMPS;
3280af22 128 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
129 LEAVE_SCOPE(oldsave);
130 return NORMAL;
131}
132
a0d0e21e
LW
133PP(pp_concat)
134{
39644a26 135 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
748a9306
LW
136 {
137 dPOPTOPssrl;
8d6d96c1
HS
138 STRLEN llen;
139 char* lpv;
140 bool lbyte;
141 STRLEN rlen;
142 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
143 bool rbyte = !SvUTF8(right);
144
145 if (TARG == right && right != left) {
146 right = sv_2mortal(newSVpvn(rpv, rlen));
147 rpv = SvPV(right, rlen); /* no point setting UTF8 here */
148 }
7889fe52 149
8d6d96c1
HS
150 if (TARG != left) {
151 lpv = SvPV(left, llen); /* mg_get(left) may happen here */
152 lbyte = !SvUTF8(left);
153 sv_setpvn(TARG, lpv, llen);
154 if (!lbyte)
155 SvUTF8_on(TARG);
156 else
157 SvUTF8_off(TARG);
158 }
159 else { /* TARG == left */
160 if (SvGMAGICAL(left))
161 mg_get(left); /* or mg_get(left) may happen here */
162 if (!SvOK(TARG))
163 sv_setpv(left, "");
164 lpv = SvPV_nomg(left, llen);
165 lbyte = !SvUTF8(left);
166 }
a12c0f56 167
fd15e783
PN
168#if defined(PERL_Y2KWARN)
169 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
8d6d96c1
HS
170 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
171 && (llen == 2 || !isDIGIT(lpv[llen - 3])))
172 {
9014280d 173 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
8d6d96c1
HS
174 "about to append an integer to '19'");
175 }
fd15e783
PN
176 }
177#endif
178
8d6d96c1
HS
179 if (lbyte != rbyte) {
180 if (lbyte)
181 sv_utf8_upgrade_nomg(TARG);
182 else {
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)
200 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
201 else if (PL_op->op_private & OPpDEREF) {
8ec5e241 202 PUTBACK;
533c011a 203 vivify_ref(PL_curpad[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);
91487cfc 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 }
91487cfc 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 }
a0d0e21e
LW
689 }
690 else {
691 if (SvTYPE(sv) == SVt_PVAV) {
692 av = (AV*)sv;
533c011a 693 if (PL_op->op_flags & OPf_REF) {
f5284f61 694 SETs((SV*)av);
a0d0e21e
LW
695 RETURN;
696 }
78f9721b
SM
697 else if (LVRET) {
698 if (GIMME == G_SCALAR)
699 Perl_croak(aTHX_ "Can't return array to lvalue"
700 " scalar context");
701 SETs((SV*)av);
702 RETURN;
703 }
a0d0e21e
LW
704 }
705 else {
67955e0c 706 GV *gv;
1c846c1f 707
a0d0e21e 708 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 709 char *sym;
c9d5ac95 710 STRLEN len;
748a9306 711
a0d0e21e
LW
712 if (SvGMAGICAL(sv)) {
713 mg_get(sv);
714 if (SvROK(sv))
715 goto wasref;
716 }
717 if (!SvOK(sv)) {
533c011a
NIS
718 if (PL_op->op_flags & OPf_REF ||
719 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 720 DIE(aTHX_ PL_no_usym, "an ARRAY");
599cee73 721 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 722 report_uninit();
f5284f61 723 if (GIMME == G_ARRAY) {
c2444246 724 (void)POPs;
4633a7c4 725 RETURN;
f5284f61
IZ
726 }
727 RETSETUNDEF;
a0d0e21e 728 }
c9d5ac95 729 sym = SvPV(sv,len);
35cd451c
GS
730 if ((PL_op->op_flags & OPf_SPECIAL) &&
731 !(PL_op->op_flags & OPf_MOD))
732 {
733 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
c9d5ac95
GS
734 if (!gv
735 && (!is_gv_magical(sym,len,0)
736 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
737 {
35cd451c 738 RETSETUNDEF;
c9d5ac95 739 }
35cd451c
GS
740 }
741 else {
742 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 743 DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
35cd451c
GS
744 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
745 }
746 }
747 else {
67955e0c 748 gv = (GV*)sv;
a0d0e21e 749 }
67955e0c 750 av = GvAVn(gv);
533c011a 751 if (PL_op->op_private & OPpLVAL_INTRO)
67955e0c 752 av = save_ary(gv);
533c011a 753 if (PL_op->op_flags & OPf_REF) {
f5284f61 754 SETs((SV*)av);
a0d0e21e
LW
755 RETURN;
756 }
78f9721b
SM
757 else if (LVRET) {
758 if (GIMME == G_SCALAR)
759 Perl_croak(aTHX_ "Can't return array to lvalue"
760 " scalar context");
761 SETs((SV*)av);
762 RETURN;
763 }
a0d0e21e
LW
764 }
765 }
766
767 if (GIMME == G_ARRAY) {
768 I32 maxarg = AvFILL(av) + 1;
c2444246 769 (void)POPs; /* XXXX May be optimized away? */
1c846c1f 770 EXTEND(SP, maxarg);
93965878 771 if (SvRMAGICAL(av)) {
1c846c1f 772 U32 i;
eb160463 773 for (i=0; i < (U32)maxarg; i++) {
93965878 774 SV **svp = av_fetch(av, i, FALSE);
3280af22 775 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878 776 }
1c846c1f 777 }
93965878
NIS
778 else {
779 Copy(AvARRAY(av), SP+1, maxarg, SV*);
780 }
a0d0e21e
LW
781 SP += maxarg;
782 }
783 else {
784 dTARGET;
785 I32 maxarg = AvFILL(av) + 1;
f5284f61 786 SETi(maxarg);
a0d0e21e
LW
787 }
788 RETURN;
789}
790
791PP(pp_rv2hv)
792{
39644a26 793 dSP; dTOPss;
a0d0e21e
LW
794 HV *hv;
795
796 if (SvROK(sv)) {
797 wasref:
f5284f61
IZ
798 tryAMAGICunDEREF(to_hv);
799
a0d0e21e 800 hv = (HV*)SvRV(sv);
6d822dc4 801 if (SvTYPE(hv) != SVt_PVHV)
cea2e8a9 802 DIE(aTHX_ "Not a HASH reference");
533c011a 803 if (PL_op->op_flags & OPf_REF) {
a0d0e21e
LW
804 SETs((SV*)hv);
805 RETURN;
806 }
78f9721b
SM
807 else if (LVRET) {
808 if (GIMME == G_SCALAR)
809 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
810 SETs((SV*)hv);
811 RETURN;
812 }
a0d0e21e
LW
813 }
814 else {
6d822dc4 815 if (SvTYPE(sv) == SVt_PVHV) {
a0d0e21e 816 hv = (HV*)sv;
533c011a 817 if (PL_op->op_flags & OPf_REF) {
a0d0e21e
LW
818 SETs((SV*)hv);
819 RETURN;
820 }
78f9721b
SM
821 else if (LVRET) {
822 if (GIMME == G_SCALAR)
823 Perl_croak(aTHX_ "Can't return hash to lvalue"
824 " scalar context");
825 SETs((SV*)hv);
826 RETURN;
827 }
a0d0e21e
LW
828 }
829 else {
67955e0c 830 GV *gv;
1c846c1f 831
a0d0e21e 832 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 833 char *sym;
c9d5ac95 834 STRLEN len;
748a9306 835
a0d0e21e
LW
836 if (SvGMAGICAL(sv)) {
837 mg_get(sv);
838 if (SvROK(sv))
839 goto wasref;
840 }
841 if (!SvOK(sv)) {
533c011a
NIS
842 if (PL_op->op_flags & OPf_REF ||
843 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 844 DIE(aTHX_ PL_no_usym, "a HASH");
599cee73 845 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 846 report_uninit();
4633a7c4
LW
847 if (GIMME == G_ARRAY) {
848 SP--;
849 RETURN;
850 }
a0d0e21e
LW
851 RETSETUNDEF;
852 }
c9d5ac95 853 sym = SvPV(sv,len);
35cd451c
GS
854 if ((PL_op->op_flags & OPf_SPECIAL) &&
855 !(PL_op->op_flags & OPf_MOD))
856 {
857 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
c9d5ac95
GS
858 if (!gv
859 && (!is_gv_magical(sym,len,0)
860 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
861 {
35cd451c 862 RETSETUNDEF;
c9d5ac95 863 }
35cd451c
GS
864 }
865 else {
866 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 867 DIE(aTHX_ PL_no_symref, sym, "a HASH");
35cd451c
GS
868 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
869 }
870 }
871 else {
67955e0c 872 gv = (GV*)sv;
a0d0e21e 873 }
67955e0c 874 hv = GvHVn(gv);
533c011a 875 if (PL_op->op_private & OPpLVAL_INTRO)
67955e0c 876 hv = save_hash(gv);
533c011a 877 if (PL_op->op_flags & OPf_REF) {
a0d0e21e
LW
878 SETs((SV*)hv);
879 RETURN;
880 }
78f9721b
SM
881 else if (LVRET) {
882 if (GIMME == G_SCALAR)
883 Perl_croak(aTHX_ "Can't return hash to lvalue"
884 " scalar context");
885 SETs((SV*)hv);
886 RETURN;
887 }
a0d0e21e
LW
888 }
889 }
890
891 if (GIMME == G_ARRAY) { /* array wanted */
3280af22 892 *PL_stack_sp = (SV*)hv;
cea2e8a9 893 return do_kv();
a0d0e21e
LW
894 }
895 else {
896 dTARGET;
b9c39e73 897 if (HvFILL(hv))
57def98f
JH
898 Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
899 (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
a0d0e21e
LW
900 else
901 sv_setiv(TARG, 0);
c750a3ec 902
a0d0e21e
LW
903 SETTARG;
904 RETURN;
905 }
906}
907
10c8fecd
GS
908STATIC void
909S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
910{
911 if (*relem) {
912 SV *tmpstr;
6d822dc4
MS
913 HE *didstore;
914
915 if (ckWARN(WARN_MISC)) {
10c8fecd
GS
916 if (relem == firstrelem &&
917 SvROK(*relem) &&
918 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
919 SvTYPE(SvRV(*relem)) == SVt_PVHV))
920 {
9014280d 921 Perl_warner(aTHX_ packWARN(WARN_MISC),
10c8fecd
GS
922 "Reference found where even-sized list expected");
923 }
924 else
9014280d 925 Perl_warner(aTHX_ packWARN(WARN_MISC),
10c8fecd
GS
926 "Odd number of elements in hash assignment");
927 }
6d822dc4
MS
928
929 tmpstr = NEWSV(29,0);
930 didstore = hv_store_ent(hash,*relem,tmpstr,0);
931 if (SvMAGICAL(hash)) {
932 if (SvSMAGICAL(tmpstr))
933 mg_set(tmpstr);
934 if (!didstore)
935 sv_2mortal(tmpstr);
936 }
937 TAINT_NOT;
10c8fecd
GS
938 }
939}
940
a0d0e21e
LW
941PP(pp_aassign)
942{
39644a26 943 dSP;
3280af22
NIS
944 SV **lastlelem = PL_stack_sp;
945 SV **lastrelem = PL_stack_base + POPMARK;
946 SV **firstrelem = PL_stack_base + POPMARK + 1;
a0d0e21e
LW
947 SV **firstlelem = lastrelem + 1;
948
949 register SV **relem;
950 register SV **lelem;
951
952 register SV *sv;
953 register AV *ary;
954
54310121 955 I32 gimme;
a0d0e21e
LW
956 HV *hash;
957 I32 i;
958 int magic;
959
3280af22 960 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
a0d0e21e
LW
961
962 /* If there's a common identifier on both sides we have to take
963 * special care that assigning the identifier on the left doesn't
964 * clobber a value on the right that's used later in the list.
965 */
10c8fecd 966 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
cc5e57d2 967 EXTEND_MORTAL(lastrelem - firstrelem + 1);
10c8fecd
GS
968 for (relem = firstrelem; relem <= lastrelem; relem++) {
969 /*SUPPRESS 560*/
155aba94 970 if ((sv = *relem)) {
a1f49e72 971 TAINT_NOT; /* Each item is independent */
10c8fecd 972 *relem = sv_mortalcopy(sv);
a1f49e72 973 }
10c8fecd 974 }
a0d0e21e
LW
975 }
976
977 relem = firstrelem;
978 lelem = firstlelem;
979 ary = Null(AV*);
980 hash = Null(HV*);
10c8fecd 981
a0d0e21e 982 while (lelem <= lastlelem) {
bbce6d69 983 TAINT_NOT; /* Each item stands on its own, taintwise. */
a0d0e21e
LW
984 sv = *lelem++;
985 switch (SvTYPE(sv)) {
986 case SVt_PVAV:
987 ary = (AV*)sv;
748a9306 988 magic = SvMAGICAL(ary) != 0;
a0d0e21e 989 av_clear(ary);
7e42bd57 990 av_extend(ary, lastrelem - relem);
a0d0e21e
LW
991 i = 0;
992 while (relem <= lastrelem) { /* gobble up all the rest */
5117ca91 993 SV **didstore;
a0d0e21e
LW
994 sv = NEWSV(28,0);
995 assert(*relem);
996 sv_setsv(sv,*relem);
997 *(relem++) = sv;
5117ca91
GS
998 didstore = av_store(ary,i++,sv);
999 if (magic) {
fb73857a
PP
1000 if (SvSMAGICAL(sv))
1001 mg_set(sv);
5117ca91 1002 if (!didstore)
8127e0e3 1003 sv_2mortal(sv);
5117ca91 1004 }
bbce6d69 1005 TAINT_NOT;
a0d0e21e
LW
1006 }
1007 break;
10c8fecd 1008 case SVt_PVHV: { /* normal hash */
a0d0e21e
LW
1009 SV *tmpstr;
1010
1011 hash = (HV*)sv;
748a9306 1012 magic = SvMAGICAL(hash) != 0;
a0d0e21e
LW
1013 hv_clear(hash);
1014
1015 while (relem < lastrelem) { /* gobble up all the rest */
5117ca91 1016 HE *didstore;
4633a7c4 1017 if (*relem)
a0d0e21e 1018 sv = *(relem++);
4633a7c4 1019 else
3280af22 1020 sv = &PL_sv_no, relem++;
a0d0e21e
LW
1021 tmpstr = NEWSV(29,0);
1022 if (*relem)
1023 sv_setsv(tmpstr,*relem); /* value */
1024 *(relem++) = tmpstr;
5117ca91
GS
1025 didstore = hv_store_ent(hash,sv,tmpstr,0);
1026 if (magic) {
fb73857a
PP
1027 if (SvSMAGICAL(tmpstr))
1028 mg_set(tmpstr);
5117ca91 1029 if (!didstore)
8127e0e3 1030 sv_2mortal(tmpstr);
5117ca91 1031 }
bbce6d69 1032 TAINT_NOT;
8e07c86e 1033 }
6a0deba8 1034 if (relem == lastrelem) {
10c8fecd 1035 do_oddball(hash, relem, firstrelem);
6a0deba8 1036 relem++;
1930e939 1037 }
a0d0e21e
LW
1038 }
1039 break;
1040 default:
6fc92669
GS
1041 if (SvIMMORTAL(sv)) {
1042 if (relem <= lastrelem)
1043 relem++;
1044 break;
a0d0e21e
LW
1045 }
1046 if (relem <= lastrelem) {
1047 sv_setsv(sv, *relem);
1048 *(relem++) = sv;
1049 }
1050 else
3280af22 1051 sv_setsv(sv, &PL_sv_undef);
a0d0e21e
LW
1052 SvSETMAGIC(sv);
1053 break;
1054 }
1055 }
3280af22
NIS
1056 if (PL_delaymagic & ~DM_DELAY) {
1057 if (PL_delaymagic & DM_UID) {
a0d0e21e 1058#ifdef HAS_SETRESUID
b28d0864 1059 (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
56febc5e
AD
1060#else
1061# ifdef HAS_SETREUID
3280af22 1062 (void)setreuid(PL_uid,PL_euid);
56febc5e
AD
1063# else
1064# ifdef HAS_SETRUID
b28d0864
NIS
1065 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1066 (void)setruid(PL_uid);
1067 PL_delaymagic &= ~DM_RUID;
a0d0e21e 1068 }
56febc5e
AD
1069# endif /* HAS_SETRUID */
1070# ifdef HAS_SETEUID
b28d0864
NIS
1071 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1072 (void)seteuid(PL_uid);
1073 PL_delaymagic &= ~DM_EUID;
a0d0e21e 1074 }
56febc5e 1075# endif /* HAS_SETEUID */
b28d0864
NIS
1076 if (PL_delaymagic & DM_UID) {
1077 if (PL_uid != PL_euid)
cea2e8a9 1078 DIE(aTHX_ "No setreuid available");
b28d0864 1079 (void)PerlProc_setuid(PL_uid);
a0d0e21e 1080 }
56febc5e
AD
1081# endif /* HAS_SETREUID */
1082#endif /* HAS_SETRESUID */
d8eceb89
JH
1083 PL_uid = PerlProc_getuid();
1084 PL_euid = PerlProc_geteuid();
a0d0e21e 1085 }
3280af22 1086 if (PL_delaymagic & DM_GID) {
a0d0e21e 1087#ifdef HAS_SETRESGID
b28d0864 1088 (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
56febc5e
AD
1089#else
1090# ifdef HAS_SETREGID
3280af22 1091 (void)setregid(PL_gid,PL_egid);
56febc5e
AD
1092# else
1093# ifdef HAS_SETRGID
b28d0864
NIS
1094 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1095 (void)setrgid(PL_gid);
1096 PL_delaymagic &= ~DM_RGID;
a0d0e21e 1097 }
56febc5e
AD
1098# endif /* HAS_SETRGID */
1099# ifdef HAS_SETEGID
b28d0864
NIS
1100 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1101 (void)setegid(PL_gid);
1102 PL_delaymagic &= ~DM_EGID;
a0d0e21e 1103 }
56febc5e 1104# endif /* HAS_SETEGID */
b28d0864
NIS
1105 if (PL_delaymagic & DM_GID) {
1106 if (PL_gid != PL_egid)
cea2e8a9 1107 DIE(aTHX_ "No setregid available");
b28d0864 1108 (void)PerlProc_setgid(PL_gid);
a0d0e21e 1109 }
56febc5e
AD
1110# endif /* HAS_SETREGID */
1111#endif /* HAS_SETRESGID */
d8eceb89
JH
1112 PL_gid = PerlProc_getgid();
1113 PL_egid = PerlProc_getegid();
a0d0e21e 1114 }
3280af22 1115 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
a0d0e21e 1116 }
3280af22 1117 PL_delaymagic = 0;
54310121
PP
1118
1119 gimme = GIMME_V;
1120 if (gimme == G_VOID)
1121 SP = firstrelem - 1;
1122 else if (gimme == G_SCALAR) {
1123 dTARGET;
1124 SP = firstrelem;
1125 SETi(lastrelem - firstrelem + 1);
1126 }
1127 else {
a0d0e21e
LW
1128 if (ary || hash)
1129 SP = lastrelem;
1130 else
1131 SP = firstrelem + (lastlelem - firstlelem);
0c8c7a05 1132 lelem = firstlelem + (relem - firstrelem);
5f05dabc 1133 while (relem <= SP)
3280af22 1134 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
a0d0e21e 1135 }
54310121 1136 RETURN;
a0d0e21e
LW
1137}
1138
8782bef2
GB
1139PP(pp_qr)
1140{
39644a26 1141 dSP;
8782bef2
GB
1142 register PMOP *pm = cPMOP;
1143 SV *rv = sv_newmortal();
57668c4d 1144 SV *sv = newSVrv(rv, "Regexp");
e08e52cf
AMS
1145 if (pm->op_pmdynflags & PMdf_TAINTED)
1146 SvTAINTED_on(rv);
aaa362c4 1147 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
8782bef2
GB
1148 RETURNX(PUSHs(rv));
1149}
1150
a0d0e21e
LW
1151PP(pp_match)
1152{
39644a26 1153 dSP; dTARG;
a0d0e21e 1154 register PMOP *pm = cPMOP;
d65afb4b 1155 PMOP *dynpm = pm;
a0d0e21e
LW
1156 register char *t;
1157 register char *s;
1158 char *strend;
1159 I32 global;
f722798b
IZ
1160 I32 r_flags = REXEC_CHECKED;
1161 char *truebase; /* Start of string */
aaa362c4 1162 register REGEXP *rx = PM_GETRE(pm);
b3eb6a9b 1163 bool rxtainted;
a0d0e21e
LW
1164 I32 gimme = GIMME;
1165 STRLEN len;
748a9306 1166 I32 minmatch = 0;
3280af22 1167 I32 oldsave = PL_savestack_ix;
f86702cc 1168 I32 update_minmatch = 1;
e60df1fa 1169 I32 had_zerolen = 0;
a0d0e21e 1170
533c011a 1171 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1172 TARG = POPs;
1173 else {
54b9620d 1174 TARG = DEFSV;
a0d0e21e
LW
1175 EXTEND(SP,1);
1176 }
d9f424b2 1177
c277df42 1178 PUTBACK; /* EVAL blocks need stack_sp. */
a0d0e21e
LW
1179 s = SvPV(TARG, len);
1180 strend = s + len;
1181 if (!s)
2269b42e 1182 DIE(aTHX_ "panic: pp_match");
b3eb6a9b 1183 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22 1184 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
9212bbba 1185 TAINT_NOT;
a0d0e21e 1186
53c4c00c 1187 PL_reg_match_utf8 = DO_UTF8(TARG);
d9f424b2 1188
d65afb4b 1189 /* PMdf_USED is set after a ?? matches once */
48c036b1 1190 if (pm->op_pmdynflags & PMdf_USED) {
c277df42 1191 failure:
a0d0e21e
LW
1192 if (gimme == G_ARRAY)
1193 RETURN;
1194 RETPUSHNO;
1195 }
1196
d65afb4b 1197 /* empty pattern special-cased to use last successful pattern if possible */
3280af22
NIS
1198 if (!rx->prelen && PL_curpm) {
1199 pm = PL_curpm;
aaa362c4 1200 rx = PM_GETRE(pm);
a0d0e21e 1201 }
d65afb4b 1202
eb160463 1203 if (rx->minlen > (I32)len)
d65afb4b 1204 goto failure;
c277df42 1205
a0d0e21e 1206 truebase = t = s;
ad94a511
IZ
1207
1208 /* XXXX What part of this is needed with true \G-support? */
d65afb4b 1209 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
cf93c79d 1210 rx->startp[0] = -1;
a0d0e21e 1211 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
14befaf4 1212 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
565764a8 1213 if (mg && mg->mg_len >= 0) {
b7a35066 1214 if (!(rx->reganch & ROPT_GPOS_SEEN))
1c846c1f 1215 rx->endp[0] = rx->startp[0] = mg->mg_len;
0ef3e39e
HS
1216 else if (rx->reganch & ROPT_ANCH_GPOS) {
1217 r_flags |= REXEC_IGNOREPOS;
1c846c1f 1218 rx->endp[0] = rx->startp[0] = mg->mg_len;
0ef3e39e 1219 }
748a9306 1220 minmatch = (mg->mg_flags & MGf_MINMATCH);
f86702cc 1221 update_minmatch = 0;
748a9306 1222 }
a0d0e21e
LW
1223 }
1224 }
14977893
JH
1225 if ((!global && rx->nparens)
1226 || SvTEMP(TARG) || PL_sawampersand)
1227 r_flags |= REXEC_COPY_STR;
1c846c1f 1228 if (SvSCREAM(TARG))
22e551b9
IZ
1229 r_flags |= REXEC_SCREAM;
1230
a0d0e21e 1231 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS
1232 SAVEINT(PL_multiline);
1233 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
a0d0e21e
LW
1234 }
1235
1236play_it_again:
cf93c79d
IZ
1237 if (global && rx->startp[0] != -1) {
1238 t = s = rx->endp[0] + truebase;
d9f97599 1239 if ((s + rx->minlen) > strend)
a0d0e21e 1240 goto nope;
f86702cc 1241 if (update_minmatch++)
e60df1fa 1242 minmatch = had_zerolen;
a0d0e21e 1243 }
60aeb6fd
NIS
1244 if (rx->reganch & RE_USE_INTUIT &&
1245 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
ee0b7718 1246 PL_bostr = truebase;
f722798b
IZ
1247 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1248
1249 if (!s)
1250 goto nope;
1251 if ( (rx->reganch & ROPT_CHECK_ALL)
14977893 1252 && !PL_sawampersand
f722798b
IZ
1253 && ((rx->reganch & ROPT_NOSCAN)
1254 || !((rx->reganch & RE_INTUIT_TAIL)
05b4157f
GS
1255 && (r_flags & REXEC_SCREAM)))
1256 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
f722798b 1257 goto yup;
a0d0e21e 1258 }
cea2e8a9 1259 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
bbce6d69 1260 {
3280af22 1261 PL_curpm = pm;
d65afb4b
HS
1262 if (dynpm->op_pmflags & PMf_ONCE)
1263 dynpm->op_pmdynflags |= PMdf_USED;
a0d0e21e
LW
1264 goto gotcha;
1265 }
1266 else
1267 goto ret_no;
1268 /*NOTREACHED*/
1269
1270 gotcha:
72311751
GS
1271 if (rxtainted)
1272 RX_MATCH_TAINTED_on(rx);
1273 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1274 if (gimme == G_ARRAY) {
ffc61ed2 1275 I32 nparens, i, len;
a0d0e21e 1276
ffc61ed2
JH
1277 nparens = rx->nparens;
1278 if (global && !nparens)
a0d0e21e
LW
1279 i = 1;
1280 else
1281 i = 0;
c277df42 1282 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1283 EXTEND(SP, nparens + i);
1284 EXTEND_MORTAL(nparens + i);
1285 for (i = !i; i <= nparens; i++) {
a0d0e21e
LW
1286 PUSHs(sv_newmortal());
1287 /*SUPPRESS 560*/
cf93c79d
IZ
1288 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1289 len = rx->endp[i] - rx->startp[i];
290deeac
A
1290 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1291 len < 0 || len > strend - s)
1292 DIE(aTHX_ "panic: pp_match start/end pointers");
cf93c79d 1293 s = rx->startp[i] + truebase;
a0d0e21e 1294 sv_setpvn(*SP, s, len);
cce850e4 1295 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
a197cbdd 1296 SvUTF8_on(*SP);
a0d0e21e
LW
1297 }
1298 }
1299 if (global) {
d65afb4b 1300 if (dynpm->op_pmflags & PMf_CONTINUE) {
0af80b60
HS
1301 MAGIC* mg = 0;
1302 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1303 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1304 if (!mg) {
1305 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1306 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1307 }
1308 if (rx->startp[0] != -1) {
1309 mg->mg_len = rx->endp[0];
1310 if (rx->startp[0] == rx->endp[0])
1311 mg->mg_flags |= MGf_MINMATCH;
1312 else
1313 mg->mg_flags &= ~MGf_MINMATCH;
1314 }
1315 }
cf93c79d
IZ
1316 had_zerolen = (rx->startp[0] != -1
1317 && rx->startp[0] == rx->endp[0]);
c277df42 1318 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1319 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1320 goto play_it_again;
1321 }
ffc61ed2 1322 else if (!nparens)
bde848c5 1323 XPUSHs(&PL_sv_yes);
4633a7c4 1324 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1325 RETURN;
1326 }
1327 else {
1328 if (global) {
1329 MAGIC* mg = 0;
1330 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
14befaf4 1331 mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1332 if (!mg) {
14befaf4
DM
1333 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1334 mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1335 }
cf93c79d
IZ
1336 if (rx->startp[0] != -1) {
1337 mg->mg_len = rx->endp[0];
d9f97599 1338 if (rx->startp[0] == rx->endp[0])
748a9306
LW
1339 mg->mg_flags |= MGf_MINMATCH;
1340 else
1341 mg->mg_flags &= ~MGf_MINMATCH;
1342 }
a0d0e21e 1343 }
4633a7c4 1344 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1345 RETPUSHYES;
1346 }
1347
f722798b 1348yup: /* Confirmed by INTUIT */
72311751
GS
1349 if (rxtainted)
1350 RX_MATCH_TAINTED_on(rx);
1351 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1352 PL_curpm = pm;
d65afb4b
HS
1353 if (dynpm->op_pmflags & PMf_ONCE)
1354 dynpm->op_pmdynflags |= PMdf_USED;
cf93c79d
IZ
1355 if (RX_MATCH_COPIED(rx))
1356 Safefree(rx->subbeg);
1357 RX_MATCH_COPIED_off(rx);
1358 rx->subbeg = Nullch;
a0d0e21e 1359 if (global) {
d9f97599 1360 rx->subbeg = truebase;
cf93c79d 1361 rx->startp[0] = s - truebase;
53c4c00c 1362 if (PL_reg_match_utf8) {
60aeb6fd
NIS
1363 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1364 rx->endp[0] = t - truebase;
1365 }
1366 else {
1367 rx->endp[0] = s - truebase + rx->minlen;
1368 }
cf93c79d 1369 rx->sublen = strend - truebase;
a0d0e21e 1370 goto gotcha;
1c846c1f 1371 }
14977893
JH
1372 if (PL_sawampersand) {
1373 I32 off;
1374
1375 rx->subbeg = savepvn(t, strend - t);
1376 rx->sublen = strend - t;
1377 RX_MATCH_COPIED_on(rx);
1378 off = rx->startp[0] = s - t;
1379 rx->endp[0] = off + rx->minlen;
1380 }
1381 else { /* startp/endp are used by @- @+. */
1382 rx->startp[0] = s - truebase;
1383 rx->endp[0] = s - truebase + rx->minlen;
1384 }
fc19f8d0 1385 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
4633a7c4 1386 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1387 RETPUSHYES;
1388
1389nope:
a0d0e21e 1390ret_no:
d65afb4b 1391 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e 1392 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
14befaf4 1393 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
a0d0e21e 1394 if (mg)
565764a8 1395 mg->mg_len = -1;
a0d0e21e
LW
1396 }
1397 }
4633a7c4 1398 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1399 if (gimme == G_ARRAY)
1400 RETURN;
1401 RETPUSHNO;
1402}
1403
1404OP *
864dbfa3 1405Perl_do_readline(pTHX)
a0d0e21e
LW
1406{
1407 dSP; dTARGETSTACKED;
1408 register SV *sv;
1409 STRLEN tmplen = 0;
1410 STRLEN offset;
760ac839 1411 PerlIO *fp;
3280af22 1412 register IO *io = GvIO(PL_last_in_gv);
533c011a 1413 register I32 type = PL_op->op_type;
54310121 1414 I32 gimme = GIMME_V;
e79b0511 1415 MAGIC *mg;
a0d0e21e 1416
5b468f54 1417 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
e79b0511 1418 PUSHMARK(SP);
5b468f54 1419 XPUSHs(SvTIED_obj((SV*)io, mg));
e79b0511
PP
1420 PUTBACK;
1421 ENTER;
864dbfa3 1422 call_method("READLINE", gimme);
e79b0511
PP
1423 LEAVE;
1424 SPAGAIN;
0b7c7b4f
HS
1425 if (gimme == G_SCALAR) {
1426 SV* result = POPs;
1427 SvSetSV_nosteal(TARG, result);
1428 PUSHTARG;
1429 }
e79b0511
PP
1430 RETURN;
1431 }
a0d0e21e
LW
1432 fp = Nullfp;
1433 if (io) {
1434 fp = IoIFP(io);
1435 if (!fp) {
1436 if (IoFLAGS(io) & IOf_ARGV) {
1437 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1438 IoLINES(io) = 0;
3280af22 1439 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1440 IoFLAGS(io) &= ~IOf_START;
9d116dd7 1441 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
3280af22
NIS
1442 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1443 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1444 fp = IoIFP(io);
1445 goto have_fp;
a0d0e21e
LW
1446 }
1447 }
3280af22 1448 fp = nextargv(PL_last_in_gv);
a0d0e21e 1449 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1450 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1451 }
1452 }
0d44d22b
NC
1453 else if (type == OP_GLOB)
1454 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1455 }
1456 else if (type == OP_GLOB)
1457 SP--;
a00b5bd3 1458 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
4c80c0b2 1459 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
a00b5bd3 1460 }
a0d0e21e
LW
1461 }
1462 if (!fp) {
790090df
HS
1463 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1464 && (!io || !(IoFLAGS(io) & IOf_START))) {
3f4520fe 1465 if (type == OP_GLOB)
9014280d 1466 Perl_warner(aTHX_ packWARN(WARN_GLOB),
af8c498a
GS
1467 "glob failed (can't start child: %s)",
1468 Strerror(errno));
69282e91 1469 else
bc37a18f 1470 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
3f4520fe 1471 }
54310121 1472 if (gimme == G_SCALAR) {
a0d0e21e
LW
1473 (void)SvOK_off(TARG);
1474 PUSHTARG;
1475 }
1476 RETURN;
1477 }
a2008d6d 1478 have_fp:
54310121 1479 if (gimme == G_SCALAR) {
a0d0e21e 1480 sv = TARG;
9607fc9c
PP
1481 if (SvROK(sv))
1482 sv_unref(sv);
a0d0e21e
LW
1483 (void)SvUPGRADE(sv, SVt_PV);
1484 tmplen = SvLEN(sv); /* remember if already alloced */
1485 if (!tmplen)
1486 Sv_Grow(sv, 80); /* try short-buffering it */
2b5e58c4
AMS
1487 offset = 0;
1488 if (type == OP_RCATLINE && SvOK(sv)) {
1489 if (!SvPOK(sv)) {
1490 STRLEN n_a;
1491 (void)SvPV_force(sv, n_a);
1492 }
a0d0e21e 1493 offset = SvCUR(sv);
2b5e58c4 1494 }
a0d0e21e 1495 }
54310121
PP
1496 else {
1497 sv = sv_2mortal(NEWSV(57, 80));
1498 offset = 0;
1499 }
fbad3eb5 1500
3887d568
AP
1501 /* This should not be marked tainted if the fp is marked clean */
1502#define MAYBE_TAINT_LINE(io, sv) \
1503 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1504 TAINT; \
1505 SvTAINTED_on(sv); \
1506 }
1507
684bef36 1508/* delay EOF state for a snarfed empty file */
fbad3eb5 1509#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1510 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1511 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1512
a0d0e21e 1513 for (;;) {
09e8efcc 1514 PUTBACK;
fbad3eb5
GS
1515 if (!sv_gets(sv, fp, offset)
1516 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1517 {
760ac839 1518 PerlIO_clearerr(fp);
a0d0e21e 1519 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1520 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW
1521 if (fp)
1522 continue;
3280af22 1523 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1524 }
1525 else if (type == OP_GLOB) {
e476b1b5 1526 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
9014280d 1527 Perl_warner(aTHX_ packWARN(WARN_GLOB),
4eb79ab5 1528 "glob failed (child exited with status %d%s)",
894356b3 1529 (int)(STATUS_CURRENT >> 8),
cf494569 1530 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1531 }
a0d0e21e 1532 }
54310121 1533 if (gimme == G_SCALAR) {
a0d0e21e 1534 (void)SvOK_off(TARG);
09e8efcc 1535 SPAGAIN;
a0d0e21e
LW
1536 PUSHTARG;
1537 }
3887d568 1538 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1539 RETURN;
1540 }
3887d568 1541 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1542 IoLINES(io)++;
b9fee9ba 1543 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1544 SvSETMAGIC(sv);
09e8efcc 1545 SPAGAIN;
a0d0e21e 1546 XPUSHs(sv);
a0d0e21e
LW
1547 if (type == OP_GLOB) {
1548 char *tmps;
1549
3280af22 1550 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
c07a80fd 1551 tmps = SvEND(sv) - 1;
3280af22 1552 if (*tmps == *SvPVX(PL_rs)) {
c07a80fd
PP
1553 *tmps = '\0';
1554 SvCUR(sv)--;
1555 }
1556 }
a0d0e21e
LW
1557 for (tmps = SvPVX(sv); *tmps; tmps++)
1558 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1559 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1560 break;
43384a1a 1561 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1562 (void)POPs; /* Unmatched wildcard? Chuck it... */
1563 continue;
1564 }
1565 }
54310121 1566 if (gimme == G_ARRAY) {
a0d0e21e
LW
1567 if (SvLEN(sv) - SvCUR(sv) > 20) {
1568 SvLEN_set(sv, SvCUR(sv)+1);
1569 Renew(SvPVX(sv), SvLEN(sv), char);
1570 }
1571 sv = sv_2mortal(NEWSV(58, 80));
1572 continue;
1573 }
54310121 1574 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e
LW
1575 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1576 if (SvCUR(sv) < 60)
1577 SvLEN_set(sv, 80);
1578 else
1579 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1580 Renew(SvPVX(sv), SvLEN(sv), char);
1581 }
1582 RETURN;
1583 }
1584}
1585
1586PP(pp_enter)
1587{
39644a26 1588 dSP;
c09156bb 1589 register PERL_CONTEXT *cx;
533c011a 1590 I32 gimme = OP_GIMME(PL_op, -1);
a0d0e21e 1591
54310121
PP
1592 if (gimme == -1) {
1593 if (cxstack_ix >= 0)
1594 gimme = cxstack[cxstack_ix].blk_gimme;
1595 else
1596 gimme = G_SCALAR;
1597 }
a0d0e21e
LW
1598
1599 ENTER;
1600
1601 SAVETMPS;
924508f0 1602 PUSHBLOCK(cx, CXt_BLOCK, SP);
a0d0e21e
LW
1603
1604 RETURN;
1605}
1606
1607PP(pp_helem)
1608{
39644a26 1609 dSP;
760ac839 1610 HE* he;
ae77835f 1611 SV **svp;
a0d0e21e 1612 SV *keysv = POPs;
a0d0e21e 1613 HV *hv = (HV*)POPs;
78f9721b 1614 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
533c011a 1615 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1616 SV *sv;
765f542d
NC
1617#ifdef PERL_COPY_ON_WRITE
1618 U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1619#else
1c846c1f 1620 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
765f542d 1621#endif
9c5ffd7c 1622 I32 preeminent = 0;
a0d0e21e 1623
ae77835f 1624 if (SvTYPE(hv) == SVt_PVHV) {
8d1f198f
DM
1625 if (PL_op->op_private & OPpLVAL_INTRO) {
1626 MAGIC *mg;
1627 HV *stash;
1628 /* does the element we're localizing already exist? */
c39e6ab0 1629 preeminent =
8d1f198f
DM
1630 /* can we determine whether it exists? */
1631 ( !SvRMAGICAL(hv)
1632 || mg_find((SV*)hv, PERL_MAGIC_env)
1633 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1634 /* Try to preserve the existenceness of a tied hash
1635 * element by using EXISTS and DELETE if possible.
1636 * Fallback to FETCH and STORE otherwise */
1637 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1638 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1639 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1640 )
1641 ) ? hv_exists_ent(hv, keysv, 0) : 1;
c39e6ab0 1642
8d1f198f 1643 }
1c846c1f 1644 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
97fcbf96 1645 svp = he ? &HeVAL(he) : 0;
ae77835f 1646 }
c750a3ec 1647 else {
a0d0e21e 1648 RETPUSHUNDEF;
c750a3ec 1649 }
a0d0e21e 1650 if (lval) {
3280af22 1651 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
1652 SV* lv;
1653 SV* key2;
2d8e6c8d
GS
1654 if (!defer) {
1655 STRLEN n_a;
cea2e8a9 1656 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 1657 }
68dc0745
PP
1658 lv = sv_newmortal();
1659 sv_upgrade(lv, SVt_PVLV);
1660 LvTYPE(lv) = 'y';
14befaf4 1661 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
1662 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1663 LvTARG(lv) = SvREFCNT_inc(hv);
1664 LvTARGLEN(lv) = 1;
1665 PUSHs(lv);
1666 RETURN;
1667 }
533c011a 1668 if (PL_op->op_private & OPpLVAL_INTRO) {
ae77835f 1669 if (HvNAME(hv) && isGV(*svp))
533c011a 1670 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1f5346dc
SC
1671 else {
1672 if (!preeminent) {
1673 STRLEN keylen;
1674 char *key = SvPV(keysv, keylen);
57813020 1675 SAVEDELETE(hv, savepvn(key,keylen), keylen);
bfc4de9f 1676 } else
1f5346dc
SC
1677 save_helem(hv, keysv, svp);
1678 }
5f05dabc 1679 }
533c011a
NIS
1680 else if (PL_op->op_private & OPpDEREF)
1681 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 1682 }
3280af22 1683 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
1684 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1685 * Pushing the magical RHS on to the stack is useless, since
1686 * that magic is soon destined to be misled by the local(),
1687 * and thus the later pp_sassign() will fail to mg_get() the
1688 * old value. This should also cure problems with delayed
1689 * mg_get()s. GSAR 98-07-03 */
1690 if (!lval && SvGMAGICAL(sv))
1691 sv = sv_mortalcopy(sv);
1692 PUSHs(sv);
a0d0e21e
LW
1693 RETURN;
1694}
1695
1696PP(pp_leave)
1697{
39644a26 1698 dSP;
c09156bb 1699 register PERL_CONTEXT *cx;
a0d0e21e
LW
1700 register SV **mark;
1701 SV **newsp;
1702 PMOP *newpm;
1703 I32 gimme;
1704
533c011a 1705 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1706 cx = &cxstack[cxstack_ix];
3280af22 1707 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
a0d0e21e
LW
1708 }
1709
1710 POPBLOCK(cx,newpm);
1711
533c011a 1712 gimme = OP_GIMME(PL_op, -1);
54310121
PP
1713 if (gimme == -1) {
1714 if (cxstack_ix >= 0)
1715 gimme = cxstack[cxstack_ix].blk_gimme;
1716 else
1717 gimme = G_SCALAR;
1718 }
a0d0e21e 1719
a1f49e72 1720 TAINT_NOT;
54310121
PP
1721 if (gimme == G_VOID)
1722 SP = newsp;
1723 else if (gimme == G_SCALAR) {
1724 MARK = newsp + 1;
09256e2f 1725 if (MARK <= SP) {
54310121
PP
1726 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1727 *MARK = TOPs;
1728 else
1729 *MARK = sv_mortalcopy(TOPs);
09256e2f 1730 } else {
54310121 1731 MEXTEND(mark,0);
3280af22 1732 *MARK = &PL_sv_undef;
a0d0e21e 1733 }
54310121 1734 SP = MARK;
a0d0e21e 1735 }
54310121 1736 else if (gimme == G_ARRAY) {
a1f49e72
CS
1737 /* in case LEAVE wipes old return values */
1738 for (mark = newsp + 1; mark <= SP; mark++) {
1739 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 1740 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
1741 TAINT_NOT; /* Each item is independent */
1742 }
1743 }
a0d0e21e 1744 }
3280af22 1745 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW
1746
1747 LEAVE;
1748
1749 RETURN;
1750}
1751
1752PP(pp_iter)
1753{
39644a26 1754 dSP;
c09156bb 1755 register PERL_CONTEXT *cx;
5f05dabc 1756 SV* sv;
4633a7c4 1757 AV* av;
1d7c1841 1758 SV **itersvp;
a0d0e21e 1759
924508f0 1760 EXTEND(SP, 1);
a0d0e21e 1761 cx = &cxstack[cxstack_ix];
6b35e009 1762 if (CxTYPE(cx) != CXt_LOOP)
cea2e8a9 1763 DIE(aTHX_ "panic: pp_iter");
a0d0e21e 1764
1d7c1841 1765 itersvp = CxITERVAR(cx);
4633a7c4 1766 av = cx->blk_loop.iterary;
89ea2908
GA
1767 if (SvTYPE(av) != SVt_PVAV) {
1768 /* iterate ($min .. $max) */
1769 if (cx->blk_loop.iterlval) {
1770 /* string increment */
1771 register SV* cur = cx->blk_loop.iterlval;
1772 STRLEN maxlen;
1773 char *max = SvPV((SV*)av, maxlen);
1774 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
4d1ff10f 1775#ifndef USE_5005THREADS /* don't risk potential race */
1d7c1841 1776 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1777 /* safe to reuse old SV */
1d7c1841 1778 sv_setsv(*itersvp, cur);
eaa5c2d6 1779 }
1c846c1f 1780 else
eaa5c2d6
GA
1781#endif
1782 {
1783 /* we need a fresh SV every time so that loop body sees a
1784 * completely new SV for closures/references to work as
1785 * they used to */
1d7c1841
GS
1786 SvREFCNT_dec(*itersvp);
1787 *itersvp = newSVsv(cur);
eaa5c2d6 1788 }
89ea2908
GA
1789 if (strEQ(SvPVX(cur), max))
1790 sv_setiv(cur, 0); /* terminate next time */
1791 else
1792 sv_inc(cur);
1793 RETPUSHYES;
1794 }
1795 RETPUSHNO;
1796 }
1797 /* integer increment */
1798 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1799 RETPUSHNO;
7f61b687 1800
4d1ff10f 1801#ifndef USE_5005THREADS /* don't risk potential race */
1d7c1841 1802 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1803 /* safe to reuse old SV */
1d7c1841 1804 sv_setiv(*itersvp, cx->blk_loop.iterix++);
eaa5c2d6 1805 }
1c846c1f 1806 else
eaa5c2d6
GA
1807#endif
1808 {
1809 /* we need a fresh SV every time so that loop body sees a
1810 * completely new SV for closures/references to work as they
1811 * used to */
1d7c1841
GS
1812 SvREFCNT_dec(*itersvp);
1813 *itersvp = newSViv(cx->blk_loop.iterix++);
eaa5c2d6 1814 }
89ea2908
GA
1815 RETPUSHYES;
1816 }
1817
1818 /* iterate array */
3280af22 1819 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
4633a7c4 1820 RETPUSHNO;
a0d0e21e 1821
1d7c1841 1822 SvREFCNT_dec(*itersvp);
a0d0e21e 1823
d42935ef
JH
1824 if (SvMAGICAL(av) || AvREIFY(av)) {
1825 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1826 if (svp)
1827 sv = *svp;
1828 else
1829 sv = Nullsv;
1830 }
1831 else {
1832 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1833 }
1834 if (sv)
a0d0e21e 1835 SvTEMP_off(sv);
a0d0e21e 1836 else
3280af22 1837 sv = &PL_sv_undef;
8b530633 1838 if (av != PL_curstack && sv == &PL_sv_undef) {
5f05dabc 1839 SV *lv = cx->blk_loop.iterlval;
71be2cbc
PP
1840 if (lv && SvREFCNT(lv) > 1) {
1841 SvREFCNT_dec(lv);
1842 lv = Nullsv;
1843 }
5f05dabc
PP
1844 if (lv)
1845 SvREFCNT_dec(LvTARG(lv));
1846 else {
68dc0745 1847 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
5f05dabc 1848 sv_upgrade(lv, SVt_PVLV);
5f05dabc 1849 LvTYPE(lv) = 'y';
14befaf4 1850 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
5f05dabc
PP
1851 }
1852 LvTARG(lv) = SvREFCNT_inc(av);
1853 LvTARGOFF(lv) = cx->blk_loop.iterix;
42718184 1854 LvTARGLEN(lv) = (STRLEN)UV_MAX;
5f05dabc
PP
1855 sv = (SV*)lv;
1856 }
a0d0e21e 1857
1d7c1841 1858 *itersvp = SvREFCNT_inc(sv);
a0d0e21e
LW
1859 RETPUSHYES;
1860}
1861
1862PP(pp_subst)
1863{
39644a26 1864 dSP; dTARG;
a0d0e21e
LW
1865 register PMOP *pm = cPMOP;
1866 PMOP *rpm = pm;
1867 register SV *dstr;
1868 register char *s;
1869 char *strend;
1870 register char *m;
1871 char *c;
1872 register char *d;
1873 STRLEN clen;
1874 I32 iters = 0;
1875 I32 maxiters;
1876 register I32 i;
1877 bool once;
71be2cbc 1878 bool rxtainted;
a0d0e21e 1879 char *orig;
22e551b9 1880 I32 r_flags;
aaa362c4 1881 register REGEXP *rx = PM_GETRE(pm);
a0d0e21e
LW
1882 STRLEN len;
1883 int force_on_match = 0;
3280af22 1884 I32 oldsave = PL_savestack_ix;
792b2c16 1885 STRLEN slen;
f272994b 1886 bool doutf8 = FALSE;
a0d0e21e 1887
5cd24f17
PP
1888 /* known replacement string? */
1889 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
533c011a 1890 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1891 TARG = POPs;
1892 else {
54b9620d 1893 TARG = DEFSV;
a0d0e21e 1894 EXTEND(SP,1);
1c846c1f 1895 }
d9f424b2 1896
765f542d
NC
1897 if (SvIsCOW(TARG))
1898 sv_force_normal_flags(TARG,0);
68dc0745
PP
1899 if (SvREADONLY(TARG)
1900 || (SvTYPE(TARG) > SVt_PVLV
1901 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
d470f89e 1902 DIE(aTHX_ PL_no_modify);
8ec5e241
NIS
1903 PUTBACK;
1904
a0d0e21e 1905 s = SvPV(TARG, len);
68dc0745 1906 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 1907 force_on_match = 1;
b3eb6a9b 1908 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22
NIS
1909 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1910 if (PL_tainted)
b3eb6a9b 1911 rxtainted |= 2;
9212bbba 1912 TAINT_NOT;
a12c0f56 1913
53c4c00c 1914 PL_reg_match_utf8 = DO_UTF8(TARG);
d9f424b2 1915
a0d0e21e
LW
1916 force_it:
1917 if (!pm || !s)
2269b42e 1918 DIE(aTHX_ "panic: pp_subst");
a0d0e21e
LW
1919
1920 strend = s + len;
53c4c00c 1921 slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
1922 maxiters = 2 * slen + 10; /* We can match twice at each
1923 position, once with zero-length,
1924 second time with non-zero. */
a0d0e21e 1925
3280af22
NIS
1926 if (!rx->prelen && PL_curpm) {
1927 pm = PL_curpm;
aaa362c4 1928 rx = PM_GETRE(pm);
a0d0e21e 1929 }
22e551b9 1930 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
9d080a66 1931 ? REXEC_COPY_STR : 0;
f722798b 1932 if (SvSCREAM(TARG))
22e551b9 1933 r_flags |= REXEC_SCREAM;
a0d0e21e 1934 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS
1935 SAVEINT(PL_multiline);
1936 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
a0d0e21e
LW
1937 }
1938 orig = m = s;
f722798b 1939 if (rx->reganch & RE_USE_INTUIT) {
ee0b7718 1940 PL_bostr = orig;
f722798b
IZ
1941 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1942
1943 if (!s)
1944 goto nope;
1945 /* How to do it in subst? */
1946/* if ( (rx->reganch & ROPT_CHECK_ALL)
1c846c1f 1947 && !PL_sawampersand
f722798b
IZ
1948 && ((rx->reganch & ROPT_NOSCAN)
1949 || !((rx->reganch & RE_INTUIT_TAIL)
1950 && (r_flags & REXEC_SCREAM))))
1951 goto yup;
1952*/
a0d0e21e 1953 }
71be2cbc
PP
1954
1955 /* only replace once? */
a0d0e21e 1956 once = !(rpm->op_pmflags & PMf_GLOBAL);
71be2cbc
PP
1957
1958 /* known replacement string? */
f272994b 1959 if (dstr) {
8514a05a
JH
1960 /* replacement needing upgrading? */
1961 if (DO_UTF8(TARG) && !doutf8) {
4a176938
JH
1962 SV *nsv = sv_newmortal();
1963 SvSetSV(nsv, dstr);
8514a05a
JH
1964 if (PL_encoding)
1965 sv_recode_to_utf8(nsv, PL_encoding);
1966 else
1967 sv_utf8_upgrade(nsv);
1968 c = SvPV(nsv, clen);
4a176938
JH
1969 doutf8 = TRUE;
1970 }
1971 else {
1972 c = SvPV(dstr, clen);
1973 doutf8 = DO_UTF8(dstr);
8514a05a 1974 }
f272994b
A
1975 }
1976 else {
1977 c = Nullch;
1978 doutf8 = FALSE;
1979 }
1980
71be2cbc 1981 /* can do inplace substitution? */
eb160463 1982 if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
d9f97599 1983 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
f722798b
IZ
1984 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1985 r_flags | REXEC_CHECKED))
1986 {
8ec5e241 1987 SPAGAIN;
3280af22 1988 PUSHs(&PL_sv_no);
71be2cbc
PP
1989 LEAVE_SCOPE(oldsave);
1990 RETURN;
1991 }
1992 if (force_on_match) {
1993 force_on_match = 0;
1994 s = SvPV_force(TARG, len);
1995 goto force_it;
1996 }
71be2cbc 1997 d = s;
3280af22 1998 PL_curpm = pm;
71be2cbc
PP
1999 SvSCREAM_off(TARG); /* disable possible screamer */
2000 if (once) {
48c036b1 2001 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d
IZ
2002 m = orig + rx->startp[0];
2003 d = orig + rx->endp[0];
71be2cbc
PP
2004 s = orig;
2005 if (m - s > strend - d) { /* faster to shorten from end */
2006 if (clen) {
2007 Copy(c, m, clen, char);
2008 m += clen;
a0d0e21e 2009 }
71be2cbc
PP
2010 i = strend - d;
2011 if (i > 0) {
2012 Move(d, m, i, char);
2013 m += i;
a0d0e21e 2014 }
71be2cbc
PP
2015 *m = '\0';
2016 SvCUR_set(TARG, m - s);
2017 }
2018 /*SUPPRESS 560*/
155aba94 2019 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
2020 d -= clen;
2021 m = d;
2022 sv_chop(TARG, d-i);
2023 s += i;
2024 while (i--)
2025 *--d = *--s;
2026 if (clen)
2027 Copy(c, m, clen, char);
2028 }
2029 else if (clen) {
2030 d -= clen;
2031 sv_chop(TARG, d);
2032 Copy(c, d, clen, char);
2033 }
2034 else {
2035 sv_chop(TARG, d);
2036 }
48c036b1 2037 TAINT_IF(rxtainted & 1);
8ec5e241 2038 SPAGAIN;
3280af22 2039 PUSHs(&PL_sv_yes);
71be2cbc
PP
2040 }
2041 else {
71be2cbc
PP
2042 do {
2043 if (iters++ > maxiters)
cea2e8a9 2044 DIE(aTHX_ "Substitution loop");
d9f97599 2045 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2046 m = rx->startp[0] + orig;
71be2cbc 2047 /*SUPPRESS 560*/
155aba94 2048 if ((i = m - s)) {
71be2cbc
PP
2049 if (s != d)
2050 Move(s, d, i, char);
2051 d += i;
a0d0e21e 2052 }
71be2cbc
PP
2053 if (clen) {
2054 Copy(c, d, clen, char);
2055 d += clen;
2056 }
cf93c79d 2057 s = rx->endp[0] + orig;
cea2e8a9 2058 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
f722798b
IZ
2059 TARG, NULL,
2060 /* don't match same null twice */
2061 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
2062 if (s != d) {
2063 i = strend - s;
2064 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2065 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 2066 }
48c036b1 2067 TAINT_IF(rxtainted & 1);
8ec5e241 2068 SPAGAIN;
71be2cbc 2069 PUSHs(sv_2mortal(newSViv((I32)iters)));
a0d0e21e 2070 }
80b498e0 2071 (void)SvPOK_only_UTF8(TARG);
48c036b1 2072 TAINT_IF(rxtainted);
8ec5e241
NIS
2073 if (SvSMAGICAL(TARG)) {
2074 PUTBACK;
2075 mg_set(TARG);
2076 SPAGAIN;
2077 }
9212bbba 2078 SvTAINT(TARG);
aefe6dfc
JH
2079 if (doutf8)
2080 SvUTF8_on(TARG);
71be2cbc
PP
2081 LEAVE_SCOPE(oldsave);
2082 RETURN;
a0d0e21e 2083 }
71be2cbc 2084
f722798b
IZ
2085 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2086 r_flags | REXEC_CHECKED))
2087 {
a0d0e21e
LW
2088 if (force_on_match) {
2089 force_on_match = 0;
2090 s = SvPV_force(TARG, len);
2091 goto force_it;
2092 }
48c036b1 2093 rxtainted |= RX_MATCH_TAINTED(rx);
8ec5e241 2094 dstr = NEWSV(25, len);
a0d0e21e 2095 sv_setpvn(dstr, m, s-m);
ffc61ed2
JH
2096 if (DO_UTF8(TARG))
2097 SvUTF8_on(dstr);
3280af22 2098 PL_curpm = pm;
a0d0e21e 2099 if (!c) {
c09156bb 2100 register PERL_CONTEXT *cx;
8ec5e241 2101 SPAGAIN;
a0d0e21e
LW
2102 PUSHSUBST(cx);
2103 RETURNOP(cPMOP->op_pmreplroot);
2104 }
cf93c79d 2105 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2106 do {
2107 if (iters++ > maxiters)
cea2e8a9 2108 DIE(aTHX_ "Substitution loop");
d9f97599 2109 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2110 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW
2111 m = s;
2112 s = orig;
cf93c79d 2113 orig = rx->subbeg;
a0d0e21e
LW
2114 s = orig + (m - s);
2115 strend = s + (strend - m);
2116 }
cf93c79d 2117 m = rx->startp[0] + orig;
a0d0e21e 2118 sv_catpvn(dstr, s, m-s);
cf93c79d 2119 s = rx->endp[0] + orig;
a0d0e21e
LW
2120 if (clen)
2121 sv_catpvn(dstr, c, clen);
2122 if (once)
2123 break;
ffc61ed2
JH
2124 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2125 TARG, NULL, r_flags));
89afcb60
A
2126 if (doutf8 && !DO_UTF8(dstr)) {
2127 SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
2128
2129 sv_utf8_upgrade(nsv);
2130 sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
2131 }
2132 else
2133 sv_catpvn(dstr, s, strend - s);
748a9306 2134
4633a7c4 2135 (void)SvOOK_off(TARG);
cb0b1708 2136 Safefree(SvPVX(TARG));
748a9306
LW
2137 SvPVX(TARG) = SvPVX(dstr);
2138 SvCUR_set(TARG, SvCUR(dstr));
2139 SvLEN_set(TARG, SvLEN(dstr));
f272994b 2140 doutf8 |= DO_UTF8(dstr);
748a9306
LW
2141 SvPVX(dstr) = 0;
2142 sv_free(dstr);
2143
48c036b1 2144 TAINT_IF(rxtainted & 1);
f878fbec 2145 SPAGAIN;
48c036b1
GS
2146 PUSHs(sv_2mortal(newSViv((I32)iters)));
2147
a0d0e21e 2148 (void)SvPOK_only(TARG);
f272994b 2149 if (doutf8)
60aeb6fd 2150 SvUTF8_on(TARG);
48c036b1 2151 TAINT_IF(rxtainted);
a0d0e21e 2152 SvSETMAGIC(TARG);
9212bbba 2153 SvTAINT(TARG);
4633a7c4 2154 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2155 RETURN;
2156 }
5cd24f17 2157 goto ret_no;
a0d0e21e
LW
2158
2159nope:
1c846c1f 2160ret_no:
8ec5e241 2161 SPAGAIN;
3280af22 2162 PUSHs(&PL_sv_no);
4633a7c4 2163 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2164 RETURN;
2165}
2166
2167PP(pp_grepwhile)
2168{
39644a26 2169 dSP;
a0d0e21e
LW
2170
2171 if (SvTRUEx(POPs))
3280af22
NIS
2172 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2173 ++*PL_markstack_ptr;
a0d0e21e
LW
2174 LEAVE; /* exit inner scope */
2175
2176 /* All done yet? */
3280af22 2177 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2178 I32 items;
54310121 2179 I32 gimme = GIMME_V;
a0d0e21e
LW
2180
2181 LEAVE; /* exit outer scope */
2182 (void)POPMARK; /* pop src */
3280af22 2183 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2184 (void)POPMARK; /* pop dst */
3280af22 2185 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2186 if (gimme == G_SCALAR) {
a0d0e21e
LW
2187 dTARGET;
2188 XPUSHi(items);
a0d0e21e 2189 }
54310121
PP
2190 else if (gimme == G_ARRAY)
2191 SP += items;
a0d0e21e
LW
2192 RETURN;
2193 }
2194 else {
2195 SV *src;
2196
2197 ENTER; /* enter inner scope */
1d7c1841 2198 SAVEVPTR(PL_curpm);
a0d0e21e 2199
3280af22 2200 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2201 SvTEMP_off(src);
54b9620d 2202 DEFSV = src;
a0d0e21e
LW
2203
2204 RETURNOP(cLOGOP->op_other);
2205 }
2206}
2207
2208PP(pp_leavesub)
2209{
39644a26 2210 dSP;
a0d0e21e
LW
2211 SV **mark;
2212 SV **newsp;
2213 PMOP *newpm;
2214 I32 gimme;
c09156bb 2215 register PERL_CONTEXT *cx;
b0d9ce38 2216 SV *sv;
a0d0e21e
LW
2217
2218 POPBLOCK(cx,newpm);
1c846c1f 2219
a1f49e72 2220 TAINT_NOT;
a0d0e21e
LW
2221 if (gimme == G_SCALAR) {
2222 MARK = newsp + 1;
a29cdaf0 2223 if (MARK <= SP) {
a8bba7fa 2224 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2225 if (SvTEMP(TOPs)) {
2226 *MARK = SvREFCNT_inc(TOPs);
2227 FREETMPS;
2228 sv_2mortal(*MARK);
cd06dffe
GS
2229 }
2230 else {
959e3673 2231 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2232 FREETMPS;
959e3673
GS
2233 *MARK = sv_mortalcopy(sv);
2234 SvREFCNT_dec(sv);
a29cdaf0 2235 }
cd06dffe
GS
2236 }
2237 else
a29cdaf0 2238 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS
2239 }
2240 else {
f86702cc 2241 MEXTEND(MARK, 0);
3280af22 2242 *MARK = &PL_sv_undef;
a0d0e21e
LW
2243 }
2244 SP = MARK;
2245 }
54310121 2246 else if (gimme == G_ARRAY) {
f86702cc 2247 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2248 if (!SvTEMP(*MARK)) {
f86702cc 2249 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2250 TAINT_NOT; /* Each item is independent */
2251 }
f86702cc 2252 }
a0d0e21e 2253 }
f86702cc 2254 PUTBACK;
1c846c1f 2255
b0d9ce38 2256 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2257 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW
2258
2259 LEAVE;
b0d9ce38 2260 LEAVESUB(sv);
a0d0e21e
LW
2261 return pop_return();
2262}
2263
cd06dffe
GS
2264/* This duplicates the above code because the above code must not
2265 * get any slower by more conditions */
2266PP(pp_leavesublv)
2267{
39644a26 2268 dSP;
cd06dffe
GS
2269 SV **mark;
2270 SV **newsp;
2271 PMOP *newpm;
2272 I32 gimme;
2273 register PERL_CONTEXT *cx;
b0d9ce38 2274 SV *sv;
cd06dffe
GS
2275
2276 POPBLOCK(cx,newpm);
1c846c1f 2277
cd06dffe
GS
2278 TAINT_NOT;
2279
2280 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2281 /* We are an argument to a function or grep().
2282 * This kind of lvalueness was legal before lvalue
2283 * subroutines too, so be backward compatible:
2284 * cannot report errors. */
2285
2286 /* Scalar context *is* possible, on the LHS of -> only,
2287 * as in f()->meth(). But this is not an lvalue. */
2288 if (gimme == G_SCALAR)
2289 goto temporise;
2290 if (gimme == G_ARRAY) {
a8bba7fa 2291 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS
2292 goto temporise_array;
2293 EXTEND_MORTAL(SP - newsp);
2294 for (mark = newsp + 1; mark <= SP; mark++) {
2295 if (SvTEMP(*mark))
2296 /* empty */ ;
2297 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2298 *mark = sv_mortalcopy(*mark);
2299 else {
2300 /* Can be a localized value subject to deletion. */
2301 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2302 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2303 }
2304 }
2305 }
2306 }
2307 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2308 /* Here we go for robustness, not for speed, so we change all
2309 * the refcounts so the caller gets a live guy. Cannot set
2310 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2311 if (!CvLVALUE(cx->blk_sub.cv)) {
b0d9ce38 2312 POPSUB(cx,sv);
d470f89e 2313 PL_curpm = newpm;
b0d9ce38
GS
2314 LEAVE;
2315 LEAVESUB(sv);
d470f89e
GS
2316 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2317 }
cd06dffe
GS
2318 if (gimme == G_SCALAR) {
2319 MARK = newsp + 1;
2320 EXTEND_MORTAL(1);
2321 if (MARK == SP) {
d470f89e 2322 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
b0d9ce38 2323 POPSUB(cx,sv);
d470f89e 2324 PL_curpm = newpm;
b0d9ce38
GS
2325 LEAVE;
2326 LEAVESUB(sv);
d470f89e 2327 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
cd06dffe 2328 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2329 }
cd06dffe
GS
2330 else { /* Can be a localized value
2331 * subject to deletion. */
2332 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2333 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2334 }
2335 }
d470f89e 2336 else { /* Should not happen? */
b0d9ce38 2337 POPSUB(cx,sv);
d470f89e 2338 PL_curpm = newpm;
b0d9ce38
GS
2339 LEAVE;
2340 LEAVESUB(sv);
d470f89e 2341 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
cd06dffe 2342 (MARK > SP ? "Empty array" : "Array"));
d470f89e 2343 }
cd06dffe
GS
2344 SP = MARK;
2345 }
2346 else if (gimme == G_ARRAY) {
2347 EXTEND_MORTAL(SP - newsp);
2348 for (mark = newsp + 1; mark <= SP; mark++) {
f206cdda
AMS
2349 if (*mark != &PL_sv_undef
2350 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
d470f89e
GS
2351 /* Might be flattened array after $#array = */
2352 PUTBACK;
b0d9ce38 2353 POPSUB(cx,sv);
d470f89e 2354 PL_curpm = newpm;
b0d9ce38
GS
2355 LEAVE;
2356 LEAVESUB(sv);
f206cdda
AMS
2357 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2358 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2359 }
cd06dffe 2360 else {
cd06dffe
GS
2361 /* Can be a localized value subject to deletion. */
2362 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2363 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2364 }
2365 }
2366 }
2367 }
2368 else {
2369 if (gimme == G_SCALAR) {
2370 temporise:
2371 MARK = newsp + 1;
2372 if (MARK <= SP) {
a8bba7fa 2373 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS
2374 if (SvTEMP(TOPs)) {
2375 *MARK = SvREFCNT_inc(TOPs);
2376 FREETMPS;
2377 sv_2mortal(*MARK);
2378 }
2379 else {
959e3673 2380 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2381 FREETMPS;
959e3673
GS
2382 *MARK = sv_mortalcopy(sv);
2383 SvREFCNT_dec(sv);
cd06dffe
GS
2384 }
2385 }
2386 else
2387 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2388 }
2389 else {
2390 MEXTEND(MARK, 0);
2391 *MARK = &PL_sv_undef;
2392 }
2393 SP = MARK;
2394 }
2395 else if (gimme == G_ARRAY) {
2396 temporise_array:
2397 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2398 if (!SvTEMP(*MARK)) {
2399 *MARK = sv_mortalcopy(*MARK);
2400 TAINT_NOT; /* Each item is independent */
2401 }
2402 }
2403 }
2404 }
2405 PUTBACK;
1c846c1f 2406
b0d9ce38 2407 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS
2408 PL_curpm = newpm; /* ... and pop $1 et al */
2409
2410 LEAVE;
b0d9ce38 2411 LEAVESUB(sv);
cd06dffe
GS
2412 return pop_return();
2413}
2414
2415
76e3520e 2416STATIC CV *
cea2e8a9 2417S_get_db_sub(pTHX_ SV **svp, CV *cv)
3de9ffa1 2418{
3280af22 2419 SV *dbsv = GvSV(PL_DBsub);
491527d0
GS
2420
2421 if (!PERLDB_SUB_NN) {
2422 GV *gv = CvGV(cv);
2423
2424 save_item(dbsv);
2425 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1c846c1f 2426 || strEQ(GvNAME(gv), "END")
491527d0
GS
2427 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2428 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2429 && (gv = (GV*)*svp) ))) {
2430 /* Use GV from the stack as a fallback. */
2431 /* GV is potentially non-unique, or contain different CV. */
c2e66d9e
GS
2432 SV *tmp = newRV((SV*)cv);
2433 sv_setsv(dbsv, tmp);
2434 SvREFCNT_dec(tmp);
491527d0
GS
2435 }
2436 else {
2437 gv_efullname3(dbsv, gv, Nullch);
2438 }
3de9ffa1
MB
2439 }
2440 else {
155aba94
GS
2441 (void)SvUPGRADE(dbsv, SVt_PVIV);
2442 (void)SvIOK_on(dbsv);
491527d0 2443 SAVEIV(SvIVX(dbsv));
5bc28da9 2444 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
3de9ffa1 2445 }
491527d0 2446
3de9ffa1 2447 if (CvXSUB(cv))
3280af22
NIS
2448 PL_curcopdb = PL_curcop;
2449 cv = GvCV(PL_DBsub);
3de9ffa1
MB
2450 return cv;
2451}
2452
a0d0e21e
LW
2453PP(pp_entersub)
2454{
39644a26 2455 dSP; dPOPss;
a0d0e21e
LW
2456 GV *gv;
2457 HV *stash;
2458 register CV *cv;
c09156bb 2459 register PERL_CONTEXT *cx;
5d94fbed 2460 I32 gimme;
533c011a 2461 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2462
2463 if (!sv)
cea2e8a9 2464 DIE(aTHX_ "Not a CODE reference");
a0d0e21e
LW
2465 switch (SvTYPE(sv)) {
2466 default:
2467 if (!SvROK(sv)) {
748a9306 2468 char *sym;
2d8e6c8d 2469 STRLEN n_a;
748a9306 2470
3280af22 2471 if (sv == &PL_sv_yes) { /* unfound import, ignore */
fb73857a 2472 if (hasargs)
3280af22 2473 SP = PL_stack_base + POPMARK;
a0d0e21e 2474 RETURN;
fb73857a 2475 }
15ff848f
CS
2476 if (SvGMAGICAL(sv)) {
2477 mg_get(sv);
f5f1d18e
AMS
2478 if (SvROK(sv))
2479 goto got_rv;
15ff848f
CS
2480 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2481 }
2482 else
2d8e6c8d 2483 sym = SvPV(sv, n_a);
15ff848f 2484 if (!sym)
cea2e8a9 2485 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2486 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 2487 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
864dbfa3 2488 cv = get_cv(sym, TRUE);
a0d0e21e
LW
2489 break;
2490 }
f5f1d18e 2491 got_rv:
f5284f61
IZ
2492 {
2493 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2494 tryAMAGICunDEREF(to_cv);
2495 }
a0d0e21e
LW
2496 cv = (CV*)SvRV(sv);
2497 if (SvTYPE(cv) == SVt_PVCV)
2498 break;
2499 /* FALL THROUGH */
2500 case SVt_PVHV:
2501 case SVt_PVAV:
cea2e8a9 2502 DIE(aTHX_ "Not a CODE reference");
a0d0e21e
LW
2503 case SVt_PVCV:
2504 cv = (CV*)sv;
2505 break;
2506 case SVt_PVGV:
8ebc5c01 2507 if (!(cv = GvCVu((GV*)sv)))
f6ec51f7
GS
2508 cv = sv_2cv(sv, &stash, &gv, FALSE);
2509 if (!cv) {
2510 ENTER;
2511 SAVETMPS;
2512 goto try_autoload;
2513 }
2514 break;
a0d0e21e
LW
2515 }
2516
2517 ENTER;
2518 SAVETMPS;
2519
2520 retry:
a0d0e21e 2521 if (!CvROOT(cv) && !CvXSUB(cv)) {
44a8e56a 2522 GV* autogv;
22239a37 2523 SV* sub_name;
44a8e56a
PP
2524
2525 /* anonymous or undef'd function leaves us no recourse */
2526 if (CvANON(cv) || !(gv = CvGV(cv)))
cea2e8a9 2527 DIE(aTHX_ "Undefined subroutine called");
67caa1fe 2528
44a8e56a
PP
2529 /* autoloaded stub? */
2530 if (cv != GvCV(gv)) {
2531 cv = GvCV(gv);
a0d0e21e 2532 }
44a8e56a 2533 /* should call AUTOLOAD now? */
67caa1fe 2534 else {
f6ec51f7
GS
2535try_autoload:
2536 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2537 FALSE)))
2538 {
2539 cv = GvCV(autogv);
2540 }
2541 /* sorry */
2542 else {
2543 sub_name = sv_newmortal();
2544 gv_efullname3(sub_name, gv, Nullch);
cea2e8a9 2545 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
f6ec51f7 2546 }
67caa1fe
GS
2547 }
2548 if (!cv)
cea2e8a9 2549 DIE(aTHX_ "Not a CODE reference");
67caa1fe 2550 goto retry;
a0d0e21e
LW
2551 }
2552
54310121 2553 gimme = GIMME_V;
67caa1fe 2554 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
4f01c5a5 2555 cv = get_db_sub(&sv, cv);
67caa1fe 2556 if (!cv)
cea2e8a9 2557 DIE(aTHX_ "No DBsub routine");
67caa1fe 2558 }
a0d0e21e 2559
4d1ff10f 2560#ifdef USE_5005THREADS
3de9ffa1
MB
2561 /*
2562 * First we need to check if the sub or method requires locking.
458fb581
MB
2563 * If so, we gain a lock on the CV, the first argument or the
2564 * stash (for static methods), as appropriate. This has to be
2565 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2566 * reschedule by returning a new op.
3de9ffa1 2567 */
11343788 2568 MUTEX_LOCK(CvMUTEXP(cv));
77a005ab
MB
2569 if (CvFLAGS(cv) & CVf_LOCKED) {
2570 MAGIC *mg;
2571 if (CvFLAGS(cv) & CVf_METHOD) {
533c011a
NIS
2572 if (SP > PL_stack_base + TOPMARK)
2573 sv = *(PL_stack_base + TOPMARK + 1);
77a005ab 2574 else {
13e08037
GS
2575 AV *av = (AV*)PL_curpad[0];
2576 if (hasargs || !av || AvFILLp(av) < 0
2577 || !(sv = AvARRAY(av)[0]))
2578 {
2579 MUTEX_UNLOCK(CvMUTEXP(cv));
d470f89e 2580 DIE(aTHX_ "no argument for locked method call");
13e08037 2581 }
77a005ab
MB
2582 }
2583 if (SvROK(sv))
2584 sv = SvRV(sv);
458fb581
MB
2585 else {
2586 STRLEN len;
2587 char *stashname = SvPV(sv, len);
2588 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2589 }
77a005ab
MB
2590 }
2591 else {
2592 sv = (SV*)cv;
2593 }
2594 MUTEX_UNLOCK(CvMUTEXP(cv));
2595 mg = condpair_magic(sv);
2596 MUTEX_LOCK(MgMUTEXP(mg));
2597 if (MgOWNER(mg) == thr)
2598 MUTEX_UNLOCK(MgMUTEXP(mg));
2599 else {
2600 while (MgOWNER(mg))
2601 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2602 MgOWNER(mg) = thr;
bf49b057 2603 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
a674cc95 2604 thr, sv));
77a005ab 2605 MUTEX_UNLOCK(MgMUTEXP(mg));
c76ac1ee 2606 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
11343788 2607 }
77a005ab 2608 MUTEX_LOCK(CvMUTEXP(cv));
11343788 2609 }
3de9ffa1
MB
2610 /*
2611 * Now we have permission to enter the sub, we must distinguish
2612 * four cases. (0) It's an XSUB (in which case we don't care
2613 * about ownership); (1) it's ours already (and we're recursing);
2614 * (2) it's free (but we may already be using a cached clone);
2615 * (3) another thread owns it. Case (1) is easy: we just use it.
2616 * Case (2) means we look for a clone--if we have one, use it
2617 * otherwise grab ownership of cv. Case (3) means we look for a
2618 * clone (for non-XSUBs) and have to create one if we don't
2619 * already have one.
2620 * Why look for a clone in case (2) when we could just grab
2621 * ownership of cv straight away? Well, we could be recursing,
2622 * i.e. we originally tried to enter cv while another thread
2623 * owned it (hence we used a clone) but it has been freed up
2624 * and we're now recursing into it. It may or may not be "better"
2625 * to use the clone but at least CvDEPTH can be trusted.
2626 */
2627 if (CvOWNER(cv) == thr || CvXSUB(cv))
2628 MUTEX_UNLOCK(CvMUTEXP(cv));
11343788 2629 else {
3de9ffa1
MB
2630 /* Case (2) or (3) */
2631 SV **svp;
2632
11343788 2633 /*
3de9ffa1
MB
2634 * XXX Might it be better to release CvMUTEXP(cv) while we
2635 * do the hv_fetch? We might find someone has pinched it
2636 * when we look again, in which case we would be in case
2637 * (3) instead of (2) so we'd have to clone. Would the fact
2638 * that we released the mutex more quickly make up for this?
2639 */
b099ddc0 2640 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
6ee623d5 2641 {
3de9ffa1 2642 /* We already have a clone to use */
11343788 2643 MUTEX_UNLOCK(CvMUTEXP(cv));
3de9ffa1 2644 cv = *(CV**)svp;
bf49b057 2645 DEBUG_S(PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2646 "entersub: %p already has clone %p:%s\n",
2647 thr, cv, SvPEEK((SV*)cv)));
3de9ffa1
MB
2648 CvOWNER(cv) = thr;
2649 SvREFCNT_inc(cv);
2650 if (CvDEPTH(cv) == 0)
c76ac1ee 2651 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
3de9ffa1 2652 }
11343788 2653 else {
3de9ffa1
MB
2654 /* (2) => grab ownership of cv. (3) => make clone */
2655 if (!CvOWNER(cv)) {
2656 CvOWNER(cv) = thr;
2657 SvREFCNT_inc(cv);
11343788 2658 MUTEX_UNLOCK(CvMUTEXP(cv));
bf49b057 2659 DEBUG_S(PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2660 "entersub: %p grabbing %p:%s in stash %s\n",
2661 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
3de9ffa1 2662 HvNAME(CvSTASH(cv)) : "(none)"));
cd06dffe
GS
2663 }
2664 else {
3de9ffa1
MB
2665 /* Make a new clone. */
2666 CV *clonecv;
2667 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2668 MUTEX_UNLOCK(CvMUTEXP(cv));
bf49b057 2669 DEBUG_S((PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2670 "entersub: %p cloning %p:%s\n",
2671 thr, cv, SvPEEK((SV*)cv))));
3de9ffa1
MB
2672 /*
2673 * We're creating a new clone so there's no race
2674 * between the original MUTEX_UNLOCK and the
2675 * SvREFCNT_inc since no one will be trying to undef
2676 * it out from underneath us. At least, I don't think
2677 * there's a race...
2678 */
2679 clonecv = cv_clone(cv);
2680 SvREFCNT_dec(cv); /* finished with this */
199100c8 2681 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
3de9ffa1
MB
2682 CvOWNER(clonecv) = thr;
2683 cv = clonecv;
11343788 2684 SvREFCNT_inc(cv);
11343788 2685 }
8b73bbec 2686 DEBUG_S(if (CvDEPTH(cv) != 0)
bf49b057 2687 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
755b0776 2688 CvDEPTH(cv)));
c76ac1ee 2689 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
11343788 2690 }
3de9ffa1 2691 }
4d1ff10f 2692#endif /* USE_5005THREADS */
11343788 2693
a0d0e21e 2694 if (CvXSUB(cv)) {
67caa1fe 2695#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2696 if (CvOLDSTYLE(cv)) {
20ce7b12 2697 I32 (*fp3)(int,int,int);
a0d0e21e
LW
2698 dMARK;
2699 register I32 items = SP - MARK;
67955e0c 2700 /* We dont worry to copy from @_. */
924508f0
GS
2701 while (SP > mark) {
2702 SP[1] = SP[0];
2703 SP--;
a0d0e21e 2704 }
3280af22 2705 PL_stack_sp = mark + 1;
1d7c1841 2706 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
1c846c1f 2707 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2708 MARK - PL_stack_base + 1,
ecfc5424 2709 items);
3280af22 2710 PL_stack_sp = PL_stack_base + items;
a0d0e21e 2711 }
67caa1fe
GS
2712 else
2713#endif /* PERL_XSUB_OLDSTYLE */
2714 {
748a9306
LW
2715 I32 markix = TOPMARK;
2716
a0d0e21e 2717 PUTBACK;
67955e0c
PP
2718
2719 if (!hasargs) {
2720 /* Need to copy @_ to stack. Alternative may be to
2721 * switch stack to @_, and copy return values
2722 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
6d4ff0d2
MB
2723 AV* av;
2724 I32 items;
4d1ff10f 2725#ifdef USE_5005THREADS
533c011a 2726 av = (AV*)PL_curpad[0];
6d4ff0d2 2727#else
3280af22 2728 av = GvAV(PL_defgv);
4d1ff10f 2729#endif /* USE_5005THREADS */
93965878 2730 items = AvFILLp(av) + 1; /* @_ is not tieable */
67955e0c
PP
2731
2732 if (items) {
2733 /* Mark is at the end of the stack. */
924508f0
GS
2734 EXTEND(SP, items);
2735 Copy(AvARRAY(av), SP + 1, items, SV*);
2736 SP += items;
1c846c1f 2737 PUTBACK ;
67955e0c
PP
2738 }
2739 }
67caa1fe
GS
2740 /* We assume first XSUB in &DB::sub is the called one. */
2741 if (PL_curcopdb) {
1d7c1841 2742 SAVEVPTR(PL_curcop);
3280af22
NIS
2743 PL_curcop = PL_curcopdb;
2744 PL_curcopdb = NULL;
67955e0c
PP
2745 }
2746 /* Do we need to open block here? XXXX */
acfe0abc 2747 (void)(*CvXSUB(cv))(aTHX_ cv);
748a9306
LW
2748
2749 /* Enforce some sanity in scalar context. */
3280af22
NIS
2750 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2751 if (markix > PL_stack_sp - PL_stack_base)
2752 *(PL_stack_base + markix) = &PL_sv_undef;
748a9306 2753 else
3280af22
NIS
2754 *(PL_stack_base + markix) = *PL_stack_sp;
2755 PL_stack_sp = PL_stack_base + markix;
748a9306 2756 }
a0d0e21e
LW
2757 }
2758 LEAVE;
2759 return NORMAL;
2760 }
2761 else {
2762 dMARK;
2763 register I32 items = SP - MARK;
a0d0e21e
LW
2764 AV* padlist = CvPADLIST(cv);
2765 SV** svp = AvARRAY(padlist);
533c011a 2766 push_return(PL_op->op_next);
a0d0e21e
LW
2767 PUSHBLOCK(cx, CXt_SUB, MARK);
2768 PUSHSUB(cx);
2769 CvDEPTH(cv)++;
6b35e009
GS
2770 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2771 * that eval'' ops within this sub know the correct lexical space.
2772 * Owing the speed considerations, we choose to search for the cv
2773 * in doeval() instead.
2774 */
a0d0e21e
LW
2775 if (CvDEPTH(cv) < 2)
2776 (void)SvREFCNT_inc(cv);
2777 else { /* save temporaries on recursion? */
1d7c1841 2778 PERL_STACK_OVERFLOW_CHECK();
93965878 2779 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e
LW
2780 AV *av;
2781 AV *newpad = newAV();
4aa0a1f7 2782 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2783 I32 ix = AvFILLp((AV*)svp[1]);
1d7c1841 2784 I32 names_fill = AvFILLp((AV*)svp[0]);
a0d0e21e 2785 svp = AvARRAY(svp[0]);
748a9306 2786 for ( ;ix > 0; ix--) {
1d7c1841 2787 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
748a9306 2788 char *name = SvPVX(svp[ix]);
5f05dabc
PP
2789 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2790 || *name == '&') /* anonymous code? */
2791 {
2792 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
748a9306
LW
2793 }
2794 else { /* our own lexical */
2795 if (*name == '@')
2796 av_store(newpad, ix, sv = (SV*)newAV());
2797 else if (*name == '%')
2798 av_store(newpad, ix, sv = (SV*)newHV());
2799 else
2800 av_store(newpad, ix, sv = NEWSV(0,0));
2801 SvPADMY_on(sv);
2802 }
a0d0e21e 2803 }
1d7c1841
GS
2804 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2805 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2806 }
a0d0e21e 2807 else {
748a9306 2808 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW
2809 SvPADTMP_on(sv);
2810 }
2811 }
2812 av = newAV(); /* will be @_ */
2813 av_extend(av, 0);
2814 av_store(newpad, 0, (SV*)av);
2815 AvFLAGS(av) = AVf_REIFY;
2816 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2817 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW
2818 svp = AvARRAY(padlist);
2819 }
2820 }
4d1ff10f 2821#ifdef USE_5005THREADS
6d4ff0d2 2822 if (!hasargs) {
533c011a 2823 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2824
93965878 2825 items = AvFILLp(av) + 1;
6d4ff0d2
MB
2826 if (items) {
2827 /* Mark is at the end of the stack. */
924508f0
GS
2828 EXTEND(SP, items);
2829 Copy(AvARRAY(av), SP + 1, items, SV*);
2830 SP += items;
1c846c1f 2831 PUTBACK ;
6d4ff0d2
MB
2832 }
2833 }
4d1ff10f 2834#endif /* USE_5005THREADS */
1d7c1841 2835 SAVEVPTR(PL_curpad);
3280af22 2836 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
4d1ff10f 2837#ifndef USE_5005THREADS
6d4ff0d2 2838 if (hasargs)
4d1ff10f 2839#endif /* USE_5005THREADS */
6d4ff0d2
MB
2840 {
2841 AV* av;
a0d0e21e
LW
2842 SV** ary;
2843
77a005ab 2844#if 0
bf49b057 2845 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2846 "%p entersub preparing @_\n", thr));
77a005ab 2847#endif
3280af22 2848 av = (AV*)PL_curpad[0];
221373f0
GS
2849 if (AvREAL(av)) {
2850 /* @_ is normally not REAL--this should only ever
2851 * happen when DB::sub() calls things that modify @_ */
2852 av_clear(av);
2853 AvREAL_off(av);
2854 AvREIFY_on(av);
2855 }
4d1ff10f 2856#ifndef USE_5005THREADS
3280af22
NIS
2857 cx->blk_sub.savearray = GvAV(PL_defgv);
2858 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
4d1ff10f 2859#endif /* USE_5005THREADS */
7032098e 2860 cx->blk_sub.oldcurpad = PL_curpad;
6d4ff0d2 2861 cx->blk_sub.argarray = av;
a0d0e21e
LW
2862 ++MARK;
2863
2864 if (items > AvMAX(av) + 1) {
2865 ary = AvALLOC(av);
2866 if (AvARRAY(av) != ary) {
2867 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2868 SvPVX(av) = (char*)ary;
2869 }
2870 if (items > AvMAX(av) + 1) {
2871 AvMAX(av) = items - 1;
2872 Renew(ary,items,SV*);
2873 AvALLOC(av) = ary;
2874 SvPVX(av) = (char*)ary;
2875 }
2876 }
2877 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2878 AvFILLp(av) = items - 1;
1c846c1f 2879
a0d0e21e
LW
2880 while (items--) {
2881 if (*MARK)
2882 SvTEMP_off(*MARK);
2883 MARK++;
2884 }
2885 }
4a925ff6
GS
2886 /* warning must come *after* we fully set up the context
2887 * stuff so that __WARN__ handlers can safely dounwind()
2888 * if they want to
2889 */
2890 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2891 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2892 sub_crush_depth(cv);
77a005ab 2893#if 0
bf49b057 2894 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2895 "%p entersub returning %p\n", thr, CvSTART(cv)));
77a005ab 2896#endif
a0d0e21e
LW
2897 RETURNOP(CvSTART(cv));
2898 }
2899}
2900
44a8e56a 2901void
864dbfa3 2902Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a
PP
2903{
2904 if (CvANON(cv))
9014280d 2905 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
44a8e56a
PP
2906 else {
2907 SV* tmpstr = sv_newmortal();
2908 gv_efullname3(tmpstr, CvGV(cv), Nullch);
9014280d 2909 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
599cee73 2910 SvPVX(tmpstr));
44a8e56a
PP
2911 }
2912}
2913
a0d0e21e
LW
2914PP(pp_aelem)
2915{
39644a26 2916 dSP;
a0d0e21e 2917 SV** svp;
d804643f
SC
2918 SV* elemsv = POPs;
2919 IV elem = SvIV(elemsv);
68dc0745 2920 AV* av = (AV*)POPs;
78f9721b 2921 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
533c011a 2922 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
be6c24e0 2923 SV *sv;
a0d0e21e 2924
e35c1634 2925 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
9014280d 2926 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
748a9306 2927 if (elem > 0)
3280af22 2928 elem -= PL_curcop->cop_arybase;
a0d0e21e
LW
2929 if (SvTYPE(av) != SVt_PVAV)
2930 RETPUSHUNDEF;
68dc0745 2931 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2932 if (lval) {
3280af22 2933 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2934 SV* lv;
2935 if (!defer)
cea2e8a9 2936 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2937 lv = sv_newmortal();
2938 sv_upgrade(lv, SVt_PVLV);
2939 LvTYPE(lv) = 'y';
14befaf4 2940 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
68dc0745
PP
2941 LvTARG(lv) = SvREFCNT_inc(av);
2942 LvTARGOFF(lv) = elem;
2943 LvTARGLEN(lv) = 1;
2944 PUSHs(lv);
2945 RETURN;
2946 }
bfc4de9f 2947 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2948 save_aelem(av, elem, svp);
533c011a
NIS
2949 else if (PL_op->op_private & OPpDEREF)
2950 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 2951 }
3280af22 2952 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
2953 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2954 sv = sv_mortalcopy(sv);
2955 PUSHs(sv);
a0d0e21e
LW
2956 RETURN;
2957}
2958
02a9e968 2959void
864dbfa3 2960Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968
CS
2961{
2962 if (SvGMAGICAL(sv))
2963 mg_get(sv);
2964 if (!SvOK(sv)) {
2965 if (SvREADONLY(sv))
cea2e8a9 2966 Perl_croak(aTHX_ PL_no_modify);
5f05dabc
PP
2967 if (SvTYPE(sv) < SVt_RV)
2968 sv_upgrade(sv, SVt_RV);
2969 else if (SvTYPE(sv) >= SVt_PV) {
2970 (void)SvOOK_off(sv);
2971 Safefree(SvPVX(sv));
2972 SvLEN(sv) = SvCUR(sv) = 0;
2973 }
68dc0745 2974 switch (to_what) {
5f05dabc 2975 case OPpDEREF_SV:
8c52afec 2976 SvRV(sv) = NEWSV(355,0);
5f05dabc
PP
2977 break;
2978 case OPpDEREF_AV:
2979 SvRV(sv) = (SV*)newAV();
2980 break;
2981 case OPpDEREF_HV:
2982 SvRV(sv) = (SV*)newHV();
2983 break;
2984 }
02a9e968
CS
2985 SvROK_on(sv);
2986 SvSETMAGIC(sv);
2987 }
2988}
2989
a0d0e21e
LW
2990PP(pp_method)
2991{
39644a26 2992 dSP;
f5d5a27c
CS
2993 SV* sv = TOPs;
2994
2995 if (SvROK(sv)) {
eda383f2 2996 SV* rsv = SvRV(sv);
f5d5a27c
CS
2997 if (SvTYPE(rsv) == SVt_PVCV) {
2998 SETs(rsv);
2999 RETURN;
3000 }
3001 }
3002
3003 SETs(method_common(sv, Null(U32*)));
3004 RETURN;
3005}
3006
3007PP(pp_method_named)
3008{
39644a26 3009 dSP;
f5d5a27c
CS
3010 SV* sv = cSVOP->op_sv;
3011 U32 hash = SvUVX(sv);
3012
3013 XPUSHs(method_common(sv, &hash));
3014 RETURN;
3015}
3016
3017STATIC SV *
3018S_method_common(pTHX_ SV* meth, U32* hashp)
3019{
a0d0e21e
LW
3020 SV* sv;
3021 SV* ob;
3022 GV* gv;
56304f61
CS
3023 HV* stash;
3024 char* name;
f5d5a27c 3025 STRLEN namelen;
9c5ffd7c 3026 char* packname = 0;
ac91690f 3027 STRLEN packlen;
a0d0e21e 3028
f5d5a27c 3029 name = SvPV(meth, namelen);
3280af22 3030 sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 3031
4f1b7578
SC
3032 if (!sv)
3033 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3034
16d20bd9 3035 if (SvGMAGICAL(sv))
af09ea45 3036 mg_get(sv);
a0d0e21e 3037 if (SvROK(sv))
16d20bd9 3038 ob = (SV*)SvRV(sv);
a0d0e21e
LW
3039 else {
3040 GV* iogv;
a0d0e21e 3041
af09ea45 3042 /* this isn't a reference */
56304f61 3043 packname = Nullch;
a0d0e21e 3044 if (!SvOK(sv) ||
56304f61 3045 !(packname = SvPV(sv, packlen)) ||
a0d0e21e
LW
3046 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3047 !(ob=(SV*)GvIO(iogv)))
3048 {
af09ea45 3049 /* this isn't the name of a filehandle either */
1c846c1f 3050 if (!packname ||
fd400ab9 3051 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
b86a2fa7 3052 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW
3053 : !isIDFIRST(*packname)
3054 ))
3055 {
f5d5a27c
CS
3056 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3057 SvOK(sv) ? "without a package or object reference"
3058 : "on an undefined value");
834a4ddd 3059 }
af09ea45
IK
3060 /* assume it's a package name */
3061 stash = gv_stashpvn(packname, packlen, FALSE);
ac91690f 3062 goto fetch;
a0d0e21e 3063 }
af09ea45 3064 /* it _is_ a filehandle name -- replace with a reference */
3280af22 3065 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e
LW
3066 }
3067
af09ea45 3068 /* if we got here, ob should be a reference or a glob */
f0d43078
GS
3069 if (!ob || !(SvOBJECT(ob)
3070 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3071 && SvOBJECT(ob))))
3072 {
f5d5a27c
CS
3073 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3074 name);
f0d43078 3075 }
a0d0e21e 3076
56304f61 3077 stash = SvSTASH(ob);
a0d0e21e 3078
ac91690f 3079 fetch:
af09ea45
IK
3080 /* NOTE: stash may be null, hope hv_fetch_ent and
3081 gv_fetchmethod can cope (it seems they can) */
3082
f5d5a27c
CS
3083 /* shortcut for simple names */
3084 if (hashp) {
3085 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3086 if (he) {
3087 gv = (GV*)HeVAL(he);
3088 if (isGV(gv) && GvCV(gv) &&
3089 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3090 return (SV*)GvCV(gv);
3091 }
3092 }
3093
ac91690f 3094 gv = gv_fetchmethod(stash, name);
af09ea45 3095
56304f61 3096 if (!gv) {
af09ea45
IK
3097 /* This code tries to figure out just what went wrong with
3098 gv_fetchmethod. It therefore needs to duplicate a lot of
3099 the internals of that function. We can't move it inside
3100 Perl_gv_fetchmethod_autoload(), however, since that would
3101 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3102 don't want that.
3103 */
56304f61
CS
3104 char* leaf = name;
3105 char* sep = Nullch;
3106 char* p;
3107
3108 for (p = name; *p; p++) {
3109 if (*p == '\'')
3110 sep = p, leaf = p + 1;
3111 else if (*p == ':' && *(p + 1) == ':')
3112 sep = p, leaf = p + 2;
3113 }
3114 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
af09ea45
IK
3115 /* the method name is unqualified or starts with SUPER:: */
3116 packname = sep ? CopSTASHPV(PL_curcop) :
3117 stash ? HvNAME(stash) : packname;
56304f61
CS
3118 packlen = strlen(packname);
3119 }
3120 else {
af09ea45 3121 /* the method name is qualified */
56304f61
CS
3122 packname = name;
3123 packlen = sep - name;
3124 }
af09ea45
IK
3125
3126 /* we're relying on gv_fetchmethod not autovivifying the stash */
3127 if (gv_stashpvn(packname, packlen, FALSE)) {
c1899e02 3128 Perl_croak(aTHX_
af09ea45
IK
3129 "Can't locate object method \"%s\" via package \"%.*s\"",
3130 leaf, (int)packlen, packname);
c1899e02
GS
3131 }
3132 else {
3133 Perl_croak(aTHX_
af09ea45
IK
3134 "Can't locate object method \"%s\" via package \"%.*s\""
3135 " (perhaps you forgot to load \"%.*s\"?)",
3136 leaf, (int)packlen, packname, (int)packlen, packname);
c1899e02 3137 }
56304f61 3138 }
f5d5a27c 3139 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
a0d0e21e 3140}
22239a37 3141
4d1ff10f 3142#ifdef USE_5005THREADS
51371543 3143static void
acfe0abc 3144unset_cvowner(pTHX_ void *cvarg)
51371543
GS
3145{
3146 register CV* cv = (CV *) cvarg;
51371543 3147
bf49b057 3148 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
51371543
GS
3149 thr, cv, SvPEEK((SV*)cv))));
3150 MUTEX_LOCK(CvMUTEXP(cv));
3151 DEBUG_S(if (CvDEPTH(cv) != 0)
bf49b057 3152 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
755b0776 3153 CvDEPTH(cv)));
51371543
GS
3154 assert(thr == CvOWNER(cv));
3155 CvOWNER(cv) = 0;
3156 MUTEX_UNLOCK(CvMUTEXP(cv));
3157 SvREFCNT_dec(cv);
3158}
4d1ff10f 3159#endif /* USE_5005THREADS */