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