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