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