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