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