This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make some panic messages a bit more logical.
[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;
a0d0e21e 1824
5cd24f17
PP
1825 /* known replacement string? */
1826 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
533c011a 1827 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1828 TARG = POPs;
1829 else {
54b9620d 1830 TARG = DEFSV;
a0d0e21e 1831 EXTEND(SP,1);
1c846c1f 1832 }
ffc61ed2 1833 PL_reg_sv = TARG;
eca06228
NIS
1834 if (SvFAKE(TARG) && SvREADONLY(TARG))
1835 sv_force_normal(TARG);
68dc0745
PP
1836 if (SvREADONLY(TARG)
1837 || (SvTYPE(TARG) > SVt_PVLV
1838 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
d470f89e 1839 DIE(aTHX_ PL_no_modify);
8ec5e241
NIS
1840 PUTBACK;
1841
a0d0e21e 1842 s = SvPV(TARG, len);
68dc0745 1843 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 1844 force_on_match = 1;
b3eb6a9b 1845 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22
NIS
1846 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1847 if (PL_tainted)
b3eb6a9b 1848 rxtainted |= 2;
9212bbba 1849 TAINT_NOT;
ffc61ed2 1850
a0d0e21e
LW
1851 force_it:
1852 if (!pm || !s)
2269b42e 1853 DIE(aTHX_ "panic: pp_subst");
a0d0e21e
LW
1854
1855 strend = s + len;
1c846c1f 1856 maxiters = 2*(strend - s) + 10; /* We can match twice at each
2beec16e
IZ
1857 position, once with zero-length,
1858 second time with non-zero. */
a0d0e21e 1859
3280af22
NIS
1860 if (!rx->prelen && PL_curpm) {
1861 pm = PL_curpm;
d9f97599 1862 rx = pm->op_pmregexp;
a0d0e21e 1863 }
22e551b9 1864 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
9d080a66 1865 ? REXEC_COPY_STR : 0;
f722798b 1866 if (SvSCREAM(TARG))
22e551b9 1867 r_flags |= REXEC_SCREAM;
a0d0e21e 1868 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS
1869 SAVEINT(PL_multiline);
1870 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
a0d0e21e
LW
1871 }
1872 orig = m = s;
f722798b
IZ
1873 if (rx->reganch & RE_USE_INTUIT) {
1874 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1875
1876 if (!s)
1877 goto nope;
1878 /* How to do it in subst? */
1879/* if ( (rx->reganch & ROPT_CHECK_ALL)
1c846c1f 1880 && !PL_sawampersand
f722798b
IZ
1881 && ((rx->reganch & ROPT_NOSCAN)
1882 || !((rx->reganch & RE_INTUIT_TAIL)
1883 && (r_flags & REXEC_SCREAM))))
1884 goto yup;
1885*/
a0d0e21e 1886 }
71be2cbc
PP
1887
1888 /* only replace once? */
a0d0e21e 1889 once = !(rpm->op_pmflags & PMf_GLOBAL);
71be2cbc
PP
1890
1891 /* known replacement string? */
5cd24f17 1892 c = dstr ? SvPV(dstr, clen) : Nullch;
71be2cbc
PP
1893
1894 /* can do inplace substitution? */
22e551b9 1895 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
d9f97599 1896 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
f722798b
IZ
1897 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1898 r_flags | REXEC_CHECKED))
1899 {
8ec5e241 1900 SPAGAIN;
3280af22 1901 PUSHs(&PL_sv_no);
71be2cbc
PP
1902 LEAVE_SCOPE(oldsave);
1903 RETURN;
1904 }
1905 if (force_on_match) {
1906 force_on_match = 0;
1907 s = SvPV_force(TARG, len);
1908 goto force_it;
1909 }
71be2cbc 1910 d = s;
3280af22 1911 PL_curpm = pm;
71be2cbc
PP
1912 SvSCREAM_off(TARG); /* disable possible screamer */
1913 if (once) {
48c036b1 1914 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d
IZ
1915 m = orig + rx->startp[0];
1916 d = orig + rx->endp[0];
71be2cbc
PP
1917 s = orig;
1918 if (m - s > strend - d) { /* faster to shorten from end */
1919 if (clen) {
1920 Copy(c, m, clen, char);
1921 m += clen;
a0d0e21e 1922 }
71be2cbc
PP
1923 i = strend - d;
1924 if (i > 0) {
1925 Move(d, m, i, char);
1926 m += i;
a0d0e21e 1927 }
71be2cbc
PP
1928 *m = '\0';
1929 SvCUR_set(TARG, m - s);
1930 }
1931 /*SUPPRESS 560*/
155aba94 1932 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
1933 d -= clen;
1934 m = d;
1935 sv_chop(TARG, d-i);
1936 s += i;
1937 while (i--)
1938 *--d = *--s;
1939 if (clen)
1940 Copy(c, m, clen, char);
1941 }
1942 else if (clen) {
1943 d -= clen;
1944 sv_chop(TARG, d);
1945 Copy(c, d, clen, char);
1946 }
1947 else {
1948 sv_chop(TARG, d);
1949 }
48c036b1 1950 TAINT_IF(rxtainted & 1);
8ec5e241 1951 SPAGAIN;
3280af22 1952 PUSHs(&PL_sv_yes);
71be2cbc
PP
1953 }
1954 else {
71be2cbc
PP
1955 do {
1956 if (iters++ > maxiters)
cea2e8a9 1957 DIE(aTHX_ "Substitution loop");
d9f97599 1958 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 1959 m = rx->startp[0] + orig;
71be2cbc 1960 /*SUPPRESS 560*/
155aba94 1961 if ((i = m - s)) {
71be2cbc
PP
1962 if (s != d)
1963 Move(s, d, i, char);
1964 d += i;
a0d0e21e 1965 }
71be2cbc
PP
1966 if (clen) {
1967 Copy(c, d, clen, char);
1968 d += clen;
1969 }
cf93c79d 1970 s = rx->endp[0] + orig;
cea2e8a9 1971 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
f722798b
IZ
1972 TARG, NULL,
1973 /* don't match same null twice */
1974 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
1975 if (s != d) {
1976 i = strend - s;
1977 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1978 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 1979 }
48c036b1 1980 TAINT_IF(rxtainted & 1);
8ec5e241 1981 SPAGAIN;
71be2cbc 1982 PUSHs(sv_2mortal(newSViv((I32)iters)));
a0d0e21e 1983 }
80b498e0 1984 (void)SvPOK_only_UTF8(TARG);
48c036b1 1985 TAINT_IF(rxtainted);
8ec5e241
NIS
1986 if (SvSMAGICAL(TARG)) {
1987 PUTBACK;
1988 mg_set(TARG);
1989 SPAGAIN;
1990 }
9212bbba 1991 SvTAINT(TARG);
71be2cbc
PP
1992 LEAVE_SCOPE(oldsave);
1993 RETURN;
a0d0e21e 1994 }
71be2cbc 1995
f722798b
IZ
1996 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1997 r_flags | REXEC_CHECKED))
1998 {
a0d0e21e
LW
1999 if (force_on_match) {
2000 force_on_match = 0;
2001 s = SvPV_force(TARG, len);
2002 goto force_it;
2003 }
48c036b1 2004 rxtainted |= RX_MATCH_TAINTED(rx);
8ec5e241 2005 dstr = NEWSV(25, len);
a0d0e21e 2006 sv_setpvn(dstr, m, s-m);
ffc61ed2
JH
2007 if (DO_UTF8(TARG))
2008 SvUTF8_on(dstr);
3280af22 2009 PL_curpm = pm;
a0d0e21e 2010 if (!c) {
c09156bb 2011 register PERL_CONTEXT *cx;
8ec5e241 2012 SPAGAIN;
a0d0e21e
LW
2013 PUSHSUBST(cx);
2014 RETURNOP(cPMOP->op_pmreplroot);
2015 }
cf93c79d 2016 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2017 do {
2018 if (iters++ > maxiters)
cea2e8a9 2019 DIE(aTHX_ "Substitution loop");
d9f97599 2020 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2021 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW
2022 m = s;
2023 s = orig;
cf93c79d 2024 orig = rx->subbeg;
a0d0e21e
LW
2025 s = orig + (m - s);
2026 strend = s + (strend - m);
2027 }
cf93c79d 2028 m = rx->startp[0] + orig;
a0d0e21e 2029 sv_catpvn(dstr, s, m-s);
cf93c79d 2030 s = rx->endp[0] + orig;
a0d0e21e
LW
2031 if (clen)
2032 sv_catpvn(dstr, c, clen);
2033 if (once)
2034 break;
ffc61ed2
JH
2035 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2036 TARG, NULL, r_flags));
a0d0e21e 2037 sv_catpvn(dstr, s, strend - s);
748a9306 2038
4633a7c4 2039 (void)SvOOK_off(TARG);
cb0b1708 2040 Safefree(SvPVX(TARG));
748a9306
LW
2041 SvPVX(TARG) = SvPVX(dstr);
2042 SvCUR_set(TARG, SvCUR(dstr));
2043 SvLEN_set(TARG, SvLEN(dstr));
2044 SvPVX(dstr) = 0;
2045 sv_free(dstr);
2046
48c036b1 2047 TAINT_IF(rxtainted & 1);
f878fbec 2048 SPAGAIN;
48c036b1
GS
2049 PUSHs(sv_2mortal(newSViv((I32)iters)));
2050
a0d0e21e 2051 (void)SvPOK_only(TARG);
48c036b1 2052 TAINT_IF(rxtainted);
a0d0e21e 2053 SvSETMAGIC(TARG);
9212bbba 2054 SvTAINT(TARG);
4633a7c4 2055 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2056 RETURN;
2057 }
5cd24f17 2058 goto ret_no;
a0d0e21e
LW
2059
2060nope:
1c846c1f 2061ret_no:
8ec5e241 2062 SPAGAIN;
3280af22 2063 PUSHs(&PL_sv_no);
4633a7c4 2064 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2065 RETURN;
2066}
2067
2068PP(pp_grepwhile)
2069{
4e35701f 2070 djSP;
a0d0e21e
LW
2071
2072 if (SvTRUEx(POPs))
3280af22
NIS
2073 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2074 ++*PL_markstack_ptr;
a0d0e21e
LW
2075 LEAVE; /* exit inner scope */
2076
2077 /* All done yet? */
3280af22 2078 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2079 I32 items;
54310121 2080 I32 gimme = GIMME_V;
a0d0e21e
LW
2081
2082 LEAVE; /* exit outer scope */
2083 (void)POPMARK; /* pop src */
3280af22 2084 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2085 (void)POPMARK; /* pop dst */
3280af22 2086 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2087 if (gimme == G_SCALAR) {
a0d0e21e
LW
2088 dTARGET;
2089 XPUSHi(items);
a0d0e21e 2090 }
54310121
PP
2091 else if (gimme == G_ARRAY)
2092 SP += items;
a0d0e21e
LW
2093 RETURN;
2094 }
2095 else {
2096 SV *src;
2097
2098 ENTER; /* enter inner scope */
1d7c1841 2099 SAVEVPTR(PL_curpm);
a0d0e21e 2100
3280af22 2101 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2102 SvTEMP_off(src);
54b9620d 2103 DEFSV = src;
a0d0e21e
LW
2104
2105 RETURNOP(cLOGOP->op_other);
2106 }
2107}
2108
2109PP(pp_leavesub)
2110{
4e35701f 2111 djSP;
a0d0e21e
LW
2112 SV **mark;
2113 SV **newsp;
2114 PMOP *newpm;
2115 I32 gimme;
c09156bb 2116 register PERL_CONTEXT *cx;
b0d9ce38 2117 SV *sv;
a0d0e21e
LW
2118
2119 POPBLOCK(cx,newpm);
1c846c1f 2120
a1f49e72 2121 TAINT_NOT;
a0d0e21e
LW
2122 if (gimme == G_SCALAR) {
2123 MARK = newsp + 1;
a29cdaf0 2124 if (MARK <= SP) {
a8bba7fa 2125 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2126 if (SvTEMP(TOPs)) {
2127 *MARK = SvREFCNT_inc(TOPs);
2128 FREETMPS;
2129 sv_2mortal(*MARK);
cd06dffe
GS
2130 }
2131 else {
959e3673 2132 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2133 FREETMPS;
959e3673
GS
2134 *MARK = sv_mortalcopy(sv);
2135 SvREFCNT_dec(sv);
a29cdaf0 2136 }
cd06dffe
GS
2137 }
2138 else
a29cdaf0 2139 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS
2140 }
2141 else {
f86702cc 2142 MEXTEND(MARK, 0);
3280af22 2143 *MARK = &PL_sv_undef;
a0d0e21e
LW
2144 }
2145 SP = MARK;
2146 }
54310121 2147 else if (gimme == G_ARRAY) {
f86702cc 2148 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2149 if (!SvTEMP(*MARK)) {
f86702cc 2150 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2151 TAINT_NOT; /* Each item is independent */
2152 }
f86702cc 2153 }
a0d0e21e 2154 }
f86702cc 2155 PUTBACK;
1c846c1f 2156
b0d9ce38 2157 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2158 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW
2159
2160 LEAVE;
b0d9ce38 2161 LEAVESUB(sv);
a0d0e21e
LW
2162 return pop_return();
2163}
2164
cd06dffe
GS
2165/* This duplicates the above code because the above code must not
2166 * get any slower by more conditions */
2167PP(pp_leavesublv)
2168{
2169 djSP;
2170 SV **mark;
2171 SV **newsp;
2172 PMOP *newpm;
2173 I32 gimme;
2174 register PERL_CONTEXT *cx;
b0d9ce38 2175 SV *sv;
cd06dffe
GS
2176
2177 POPBLOCK(cx,newpm);
1c846c1f 2178
cd06dffe
GS
2179 TAINT_NOT;
2180
2181 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2182 /* We are an argument to a function or grep().
2183 * This kind of lvalueness was legal before lvalue
2184 * subroutines too, so be backward compatible:
2185 * cannot report errors. */
2186
2187 /* Scalar context *is* possible, on the LHS of -> only,
2188 * as in f()->meth(). But this is not an lvalue. */
2189 if (gimme == G_SCALAR)
2190 goto temporise;
2191 if (gimme == G_ARRAY) {
a8bba7fa 2192 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS
2193 goto temporise_array;
2194 EXTEND_MORTAL(SP - newsp);
2195 for (mark = newsp + 1; mark <= SP; mark++) {
2196 if (SvTEMP(*mark))
2197 /* empty */ ;
2198 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2199 *mark = sv_mortalcopy(*mark);
2200 else {
2201 /* Can be a localized value subject to deletion. */
2202 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2203 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2204 }
2205 }
2206 }
2207 }
2208 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2209 /* Here we go for robustness, not for speed, so we change all
2210 * the refcounts so the caller gets a live guy. Cannot set
2211 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2212 if (!CvLVALUE(cx->blk_sub.cv)) {
b0d9ce38 2213 POPSUB(cx,sv);
d470f89e 2214 PL_curpm = newpm;
b0d9ce38
GS
2215 LEAVE;
2216 LEAVESUB(sv);
d470f89e
GS
2217 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2218 }
cd06dffe
GS
2219 if (gimme == G_SCALAR) {
2220 MARK = newsp + 1;
2221 EXTEND_MORTAL(1);
2222 if (MARK == SP) {
d470f89e 2223 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
b0d9ce38 2224 POPSUB(cx,sv);
d470f89e 2225 PL_curpm = newpm;
b0d9ce38
GS
2226 LEAVE;
2227 LEAVESUB(sv);
d470f89e 2228 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
cd06dffe 2229 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2230 }
cd06dffe
GS
2231 else { /* Can be a localized value
2232 * subject to deletion. */
2233 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2234 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2235 }
2236 }
d470f89e 2237 else { /* Should not happen? */
b0d9ce38 2238 POPSUB(cx,sv);
d470f89e 2239 PL_curpm = newpm;
b0d9ce38
GS
2240 LEAVE;
2241 LEAVESUB(sv);
d470f89e 2242 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
cd06dffe 2243 (MARK > SP ? "Empty array" : "Array"));
d470f89e 2244 }
cd06dffe
GS
2245 SP = MARK;
2246 }
2247 else if (gimme == G_ARRAY) {
2248 EXTEND_MORTAL(SP - newsp);
2249 for (mark = newsp + 1; mark <= SP; mark++) {
d470f89e
GS
2250 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2251 /* Might be flattened array after $#array = */
2252 PUTBACK;
b0d9ce38 2253 POPSUB(cx,sv);
d470f89e 2254 PL_curpm = newpm;
b0d9ce38
GS
2255 LEAVE;
2256 LEAVESUB(sv);
d470f89e 2257 DIE(aTHX_ "Can't return %s from lvalue subroutine",
cd06dffe
GS
2258 (*mark != &PL_sv_undef)
2259 ? (SvREADONLY(TOPs)
2260 ? "a readonly value" : "a temporary")
2261 : "an uninitialized value");
d470f89e 2262 }
cd06dffe 2263 else {
cd06dffe
GS
2264 /* Can be a localized value subject to deletion. */
2265 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2266 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2267 }
2268 }
2269 }
2270 }
2271 else {
2272 if (gimme == G_SCALAR) {
2273 temporise:
2274 MARK = newsp + 1;
2275 if (MARK <= SP) {
a8bba7fa 2276 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS
2277 if (SvTEMP(TOPs)) {
2278 *MARK = SvREFCNT_inc(TOPs);
2279 FREETMPS;
2280 sv_2mortal(*MARK);
2281 }
2282 else {
959e3673 2283 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2284 FREETMPS;
959e3673
GS
2285 *MARK = sv_mortalcopy(sv);
2286 SvREFCNT_dec(sv);
cd06dffe
GS
2287 }
2288 }
2289 else
2290 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2291 }
2292 else {
2293 MEXTEND(MARK, 0);
2294 *MARK = &PL_sv_undef;
2295 }
2296 SP = MARK;
2297 }
2298 else if (gimme == G_ARRAY) {
2299 temporise_array:
2300 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2301 if (!SvTEMP(*MARK)) {
2302 *MARK = sv_mortalcopy(*MARK);
2303 TAINT_NOT; /* Each item is independent */
2304 }
2305 }
2306 }
2307 }
2308 PUTBACK;
1c846c1f 2309
b0d9ce38 2310 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS
2311 PL_curpm = newpm; /* ... and pop $1 et al */
2312
2313 LEAVE;
b0d9ce38 2314 LEAVESUB(sv);
cd06dffe
GS
2315 return pop_return();
2316}
2317
2318
76e3520e 2319STATIC CV *
cea2e8a9 2320S_get_db_sub(pTHX_ SV **svp, CV *cv)
3de9ffa1 2321{
3280af22 2322 SV *dbsv = GvSV(PL_DBsub);
491527d0
GS
2323
2324 if (!PERLDB_SUB_NN) {
2325 GV *gv = CvGV(cv);
2326
2327 save_item(dbsv);
2328 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1c846c1f 2329 || strEQ(GvNAME(gv), "END")
491527d0
GS
2330 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2331 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2332 && (gv = (GV*)*svp) ))) {
2333 /* Use GV from the stack as a fallback. */
2334 /* GV is potentially non-unique, or contain different CV. */
c2e66d9e
GS
2335 SV *tmp = newRV((SV*)cv);
2336 sv_setsv(dbsv, tmp);
2337 SvREFCNT_dec(tmp);
491527d0
GS
2338 }
2339 else {
2340 gv_efullname3(dbsv, gv, Nullch);
2341 }
3de9ffa1
MB
2342 }
2343 else {
155aba94
GS
2344 (void)SvUPGRADE(dbsv, SVt_PVIV);
2345 (void)SvIOK_on(dbsv);
491527d0 2346 SAVEIV(SvIVX(dbsv));
5bc28da9 2347 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
3de9ffa1 2348 }
491527d0 2349
3de9ffa1 2350 if (CvXSUB(cv))
3280af22
NIS
2351 PL_curcopdb = PL_curcop;
2352 cv = GvCV(PL_DBsub);
3de9ffa1
MB
2353 return cv;
2354}
2355
a0d0e21e
LW
2356PP(pp_entersub)
2357{
4e35701f 2358 djSP; dPOPss;
a0d0e21e
LW
2359 GV *gv;
2360 HV *stash;
2361 register CV *cv;
c09156bb 2362 register PERL_CONTEXT *cx;
5d94fbed 2363 I32 gimme;
533c011a 2364 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2365
2366 if (!sv)
cea2e8a9 2367 DIE(aTHX_ "Not a CODE reference");
a0d0e21e
LW
2368 switch (SvTYPE(sv)) {
2369 default:
2370 if (!SvROK(sv)) {
748a9306 2371 char *sym;
2d8e6c8d 2372 STRLEN n_a;
748a9306 2373
3280af22 2374 if (sv == &PL_sv_yes) { /* unfound import, ignore */
fb73857a 2375 if (hasargs)
3280af22 2376 SP = PL_stack_base + POPMARK;
a0d0e21e 2377 RETURN;
fb73857a 2378 }
15ff848f
CS
2379 if (SvGMAGICAL(sv)) {
2380 mg_get(sv);
2381 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2382 }
2383 else
2d8e6c8d 2384 sym = SvPV(sv, n_a);
15ff848f 2385 if (!sym)
cea2e8a9 2386 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2387 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 2388 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
864dbfa3 2389 cv = get_cv(sym, TRUE);
a0d0e21e
LW
2390 break;
2391 }
f5284f61
IZ
2392 {
2393 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2394 tryAMAGICunDEREF(to_cv);
2395 }
a0d0e21e
LW
2396 cv = (CV*)SvRV(sv);
2397 if (SvTYPE(cv) == SVt_PVCV)
2398 break;
2399 /* FALL THROUGH */
2400 case SVt_PVHV:
2401 case SVt_PVAV:
cea2e8a9 2402 DIE(aTHX_ "Not a CODE reference");
a0d0e21e
LW
2403 case SVt_PVCV:
2404 cv = (CV*)sv;
2405 break;
2406 case SVt_PVGV:
8ebc5c01 2407 if (!(cv = GvCVu((GV*)sv)))
f6ec51f7
GS
2408 cv = sv_2cv(sv, &stash, &gv, FALSE);
2409 if (!cv) {
2410 ENTER;
2411 SAVETMPS;
2412 goto try_autoload;
2413 }
2414 break;
a0d0e21e
LW
2415 }
2416
2417 ENTER;
2418 SAVETMPS;
2419
2420 retry:
a0d0e21e 2421 if (!CvROOT(cv) && !CvXSUB(cv)) {
44a8e56a 2422 GV* autogv;
22239a37 2423 SV* sub_name;
44a8e56a
PP
2424
2425 /* anonymous or undef'd function leaves us no recourse */
2426 if (CvANON(cv) || !(gv = CvGV(cv)))
cea2e8a9 2427 DIE(aTHX_ "Undefined subroutine called");
67caa1fe 2428
44a8e56a
PP
2429 /* autoloaded stub? */
2430 if (cv != GvCV(gv)) {
2431 cv = GvCV(gv);
a0d0e21e 2432 }
44a8e56a 2433 /* should call AUTOLOAD now? */
67caa1fe 2434 else {
f6ec51f7
GS
2435try_autoload:
2436 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2437 FALSE)))
2438 {
2439 cv = GvCV(autogv);
2440 }
2441 /* sorry */
2442 else {
2443 sub_name = sv_newmortal();
2444 gv_efullname3(sub_name, gv, Nullch);
cea2e8a9 2445 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
f6ec51f7 2446 }
67caa1fe
GS
2447 }
2448 if (!cv)
cea2e8a9 2449 DIE(aTHX_ "Not a CODE reference");
67caa1fe 2450 goto retry;
a0d0e21e
LW
2451 }
2452
54310121 2453 gimme = GIMME_V;
67caa1fe 2454 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
4f01c5a5 2455 cv = get_db_sub(&sv, cv);
67caa1fe 2456 if (!cv)
cea2e8a9 2457 DIE(aTHX_ "No DBsub routine");
67caa1fe 2458 }
a0d0e21e 2459
11343788 2460#ifdef USE_THREADS
3de9ffa1
MB
2461 /*
2462 * First we need to check if the sub or method requires locking.
458fb581
MB
2463 * If so, we gain a lock on the CV, the first argument or the
2464 * stash (for static methods), as appropriate. This has to be
2465 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2466 * reschedule by returning a new op.
3de9ffa1 2467 */
11343788 2468 MUTEX_LOCK(CvMUTEXP(cv));
77a005ab
MB
2469 if (CvFLAGS(cv) & CVf_LOCKED) {
2470 MAGIC *mg;
2471 if (CvFLAGS(cv) & CVf_METHOD) {
533c011a
NIS
2472 if (SP > PL_stack_base + TOPMARK)
2473 sv = *(PL_stack_base + TOPMARK + 1);
77a005ab 2474 else {
13e08037
GS
2475 AV *av = (AV*)PL_curpad[0];
2476 if (hasargs || !av || AvFILLp(av) < 0
2477 || !(sv = AvARRAY(av)[0]))
2478 {
2479 MUTEX_UNLOCK(CvMUTEXP(cv));
d470f89e 2480 DIE(aTHX_ "no argument for locked method call");
13e08037 2481 }
77a005ab
MB
2482 }
2483 if (SvROK(sv))
2484 sv = SvRV(sv);
458fb581
MB
2485 else {
2486 STRLEN len;
2487 char *stashname = SvPV(sv, len);
2488 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2489 }
77a005ab
MB
2490 }
2491 else {
2492 sv = (SV*)cv;
2493 }
2494 MUTEX_UNLOCK(CvMUTEXP(cv));
2495 mg = condpair_magic(sv);
2496 MUTEX_LOCK(MgMUTEXP(mg));
2497 if (MgOWNER(mg) == thr)
2498 MUTEX_UNLOCK(MgMUTEXP(mg));
2499 else {
2500 while (MgOWNER(mg))
2501 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2502 MgOWNER(mg) = thr;
bf49b057 2503 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
1fd28e87 2504 thr, sv);)
77a005ab 2505 MUTEX_UNLOCK(MgMUTEXP(mg));
c76ac1ee 2506 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
11343788 2507 }
77a005ab 2508 MUTEX_LOCK(CvMUTEXP(cv));
11343788 2509 }
3de9ffa1
MB
2510 /*
2511 * Now we have permission to enter the sub, we must distinguish
2512 * four cases. (0) It's an XSUB (in which case we don't care
2513 * about ownership); (1) it's ours already (and we're recursing);
2514 * (2) it's free (but we may already be using a cached clone);
2515 * (3) another thread owns it. Case (1) is easy: we just use it.
2516 * Case (2) means we look for a clone--if we have one, use it
2517 * otherwise grab ownership of cv. Case (3) means we look for a
2518 * clone (for non-XSUBs) and have to create one if we don't
2519 * already have one.
2520 * Why look for a clone in case (2) when we could just grab
2521 * ownership of cv straight away? Well, we could be recursing,
2522 * i.e. we originally tried to enter cv while another thread
2523 * owned it (hence we used a clone) but it has been freed up
2524 * and we're now recursing into it. It may or may not be "better"
2525 * to use the clone but at least CvDEPTH can be trusted.
2526 */
2527 if (CvOWNER(cv) == thr || CvXSUB(cv))
2528 MUTEX_UNLOCK(CvMUTEXP(cv));
11343788 2529 else {
3de9ffa1
MB
2530 /* Case (2) or (3) */
2531 SV **svp;
2532
11343788 2533 /*
3de9ffa1
MB
2534 * XXX Might it be better to release CvMUTEXP(cv) while we
2535 * do the hv_fetch? We might find someone has pinched it
2536 * when we look again, in which case we would be in case
2537 * (3) instead of (2) so we'd have to clone. Would the fact
2538 * that we released the mutex more quickly make up for this?
2539 */
b099ddc0 2540 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
6ee623d5 2541 {
3de9ffa1 2542 /* We already have a clone to use */
11343788 2543 MUTEX_UNLOCK(CvMUTEXP(cv));
3de9ffa1 2544 cv = *(CV**)svp;
bf49b057 2545 DEBUG_S(PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2546 "entersub: %p already has clone %p:%s\n",
2547 thr, cv, SvPEEK((SV*)cv)));
3de9ffa1
MB
2548 CvOWNER(cv) = thr;
2549 SvREFCNT_inc(cv);
2550 if (CvDEPTH(cv) == 0)
c76ac1ee 2551 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
3de9ffa1 2552 }
11343788 2553 else {
3de9ffa1
MB
2554 /* (2) => grab ownership of cv. (3) => make clone */
2555 if (!CvOWNER(cv)) {
2556 CvOWNER(cv) = thr;
2557 SvREFCNT_inc(cv);
11343788 2558 MUTEX_UNLOCK(CvMUTEXP(cv));
bf49b057 2559 DEBUG_S(PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2560 "entersub: %p grabbing %p:%s in stash %s\n",
2561 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
3de9ffa1 2562 HvNAME(CvSTASH(cv)) : "(none)"));
cd06dffe
GS
2563 }
2564 else {
3de9ffa1
MB
2565 /* Make a new clone. */
2566 CV *clonecv;
2567 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2568 MUTEX_UNLOCK(CvMUTEXP(cv));
bf49b057 2569 DEBUG_S((PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2570 "entersub: %p cloning %p:%s\n",
2571 thr, cv, SvPEEK((SV*)cv))));
3de9ffa1
MB
2572 /*
2573 * We're creating a new clone so there's no race
2574 * between the original MUTEX_UNLOCK and the
2575 * SvREFCNT_inc since no one will be trying to undef
2576 * it out from underneath us. At least, I don't think
2577 * there's a race...
2578 */
2579 clonecv = cv_clone(cv);
2580 SvREFCNT_dec(cv); /* finished with this */
199100c8 2581 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
3de9ffa1
MB
2582 CvOWNER(clonecv) = thr;
2583 cv = clonecv;
11343788 2584 SvREFCNT_inc(cv);
11343788 2585 }
8b73bbec 2586 DEBUG_S(if (CvDEPTH(cv) != 0)
bf49b057 2587 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3de9ffa1 2588 CvDEPTH(cv)););
c76ac1ee 2589 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
11343788 2590 }
3de9ffa1 2591 }
11343788
MB
2592#endif /* USE_THREADS */
2593
a0d0e21e 2594 if (CvXSUB(cv)) {
67caa1fe 2595#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2596 if (CvOLDSTYLE(cv)) {
20ce7b12 2597 I32 (*fp3)(int,int,int);
a0d0e21e
LW
2598 dMARK;
2599 register I32 items = SP - MARK;
67955e0c 2600 /* We dont worry to copy from @_. */
924508f0
GS
2601 while (SP > mark) {
2602 SP[1] = SP[0];
2603 SP--;
a0d0e21e 2604 }
3280af22 2605 PL_stack_sp = mark + 1;
1d7c1841 2606 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
1c846c1f 2607 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2608 MARK - PL_stack_base + 1,
ecfc5424 2609 items);
3280af22 2610 PL_stack_sp = PL_stack_base + items;
a0d0e21e 2611 }
67caa1fe
GS
2612 else
2613#endif /* PERL_XSUB_OLDSTYLE */
2614 {
748a9306
LW
2615 I32 markix = TOPMARK;
2616
a0d0e21e 2617 PUTBACK;
67955e0c
PP
2618
2619 if (!hasargs) {
2620 /* Need to copy @_ to stack. Alternative may be to
2621 * switch stack to @_, and copy return values
2622 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
6d4ff0d2
MB
2623 AV* av;
2624 I32 items;
2625#ifdef USE_THREADS
533c011a 2626 av = (AV*)PL_curpad[0];
6d4ff0d2 2627#else
3280af22 2628 av = GvAV(PL_defgv);
6d4ff0d2 2629#endif /* USE_THREADS */
93965878 2630 items = AvFILLp(av) + 1; /* @_ is not tieable */
67955e0c
PP
2631
2632 if (items) {
2633 /* Mark is at the end of the stack. */
924508f0
GS
2634 EXTEND(SP, items);
2635 Copy(AvARRAY(av), SP + 1, items, SV*);
2636 SP += items;
1c846c1f 2637 PUTBACK ;
67955e0c
PP
2638 }
2639 }
67caa1fe
GS
2640 /* We assume first XSUB in &DB::sub is the called one. */
2641 if (PL_curcopdb) {
1d7c1841 2642 SAVEVPTR(PL_curcop);
3280af22
NIS
2643 PL_curcop = PL_curcopdb;
2644 PL_curcopdb = NULL;
67955e0c
PP
2645 }
2646 /* Do we need to open block here? XXXX */
0cb96387 2647 (void)(*CvXSUB(cv))(aTHXo_ cv);
748a9306
LW
2648
2649 /* Enforce some sanity in scalar context. */
3280af22
NIS
2650 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2651 if (markix > PL_stack_sp - PL_stack_base)
2652 *(PL_stack_base + markix) = &PL_sv_undef;
748a9306 2653 else
3280af22
NIS
2654 *(PL_stack_base + markix) = *PL_stack_sp;
2655 PL_stack_sp = PL_stack_base + markix;
748a9306 2656 }
a0d0e21e
LW
2657 }
2658 LEAVE;
2659 return NORMAL;
2660 }
2661 else {
2662 dMARK;
2663 register I32 items = SP - MARK;
a0d0e21e
LW
2664 AV* padlist = CvPADLIST(cv);
2665 SV** svp = AvARRAY(padlist);
533c011a 2666 push_return(PL_op->op_next);
a0d0e21e
LW
2667 PUSHBLOCK(cx, CXt_SUB, MARK);
2668 PUSHSUB(cx);
2669 CvDEPTH(cv)++;
6b35e009
GS
2670 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2671 * that eval'' ops within this sub know the correct lexical space.
2672 * Owing the speed considerations, we choose to search for the cv
2673 * in doeval() instead.
2674 */
a0d0e21e
LW
2675 if (CvDEPTH(cv) < 2)
2676 (void)SvREFCNT_inc(cv);
2677 else { /* save temporaries on recursion? */
1d7c1841 2678 PERL_STACK_OVERFLOW_CHECK();
93965878 2679 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e
LW
2680 AV *av;
2681 AV *newpad = newAV();
4aa0a1f7 2682 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2683 I32 ix = AvFILLp((AV*)svp[1]);
1d7c1841 2684 I32 names_fill = AvFILLp((AV*)svp[0]);
a0d0e21e 2685 svp = AvARRAY(svp[0]);
748a9306 2686 for ( ;ix > 0; ix--) {
1d7c1841 2687 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
748a9306 2688 char *name = SvPVX(svp[ix]);
5f05dabc
PP
2689 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2690 || *name == '&') /* anonymous code? */
2691 {
2692 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
748a9306
LW
2693 }
2694 else { /* our own lexical */
2695 if (*name == '@')
2696 av_store(newpad, ix, sv = (SV*)newAV());
2697 else if (*name == '%')
2698 av_store(newpad, ix, sv = (SV*)newHV());
2699 else
2700 av_store(newpad, ix, sv = NEWSV(0,0));
2701 SvPADMY_on(sv);
2702 }
a0d0e21e 2703 }
1d7c1841
GS
2704 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2705 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2706 }
a0d0e21e 2707 else {
748a9306 2708 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW
2709 SvPADTMP_on(sv);
2710 }
2711 }
2712 av = newAV(); /* will be @_ */
2713 av_extend(av, 0);
2714 av_store(newpad, 0, (SV*)av);
2715 AvFLAGS(av) = AVf_REIFY;
2716 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2717 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW
2718 svp = AvARRAY(padlist);
2719 }
2720 }
6d4ff0d2
MB
2721#ifdef USE_THREADS
2722 if (!hasargs) {
533c011a 2723 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2724
93965878 2725 items = AvFILLp(av) + 1;
6d4ff0d2
MB
2726 if (items) {
2727 /* Mark is at the end of the stack. */
924508f0
GS
2728 EXTEND(SP, items);
2729 Copy(AvARRAY(av), SP + 1, items, SV*);
2730 SP += items;
1c846c1f 2731 PUTBACK ;
6d4ff0d2
MB
2732 }
2733 }
2734#endif /* USE_THREADS */
1d7c1841 2735 SAVEVPTR(PL_curpad);
3280af22 2736 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB
2737#ifndef USE_THREADS
2738 if (hasargs)
2739#endif /* USE_THREADS */
2740 {
2741 AV* av;
a0d0e21e
LW
2742 SV** ary;
2743
77a005ab 2744#if 0
bf49b057 2745 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2746 "%p entersub preparing @_\n", thr));
77a005ab 2747#endif
3280af22 2748 av = (AV*)PL_curpad[0];
221373f0
GS
2749 if (AvREAL(av)) {
2750 /* @_ is normally not REAL--this should only ever
2751 * happen when DB::sub() calls things that modify @_ */
2752 av_clear(av);
2753 AvREAL_off(av);
2754 AvREIFY_on(av);
2755 }
6d4ff0d2 2756#ifndef USE_THREADS
3280af22
NIS
2757 cx->blk_sub.savearray = GvAV(PL_defgv);
2758 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2 2759#endif /* USE_THREADS */
7032098e 2760 cx->blk_sub.oldcurpad = PL_curpad;
6d4ff0d2 2761 cx->blk_sub.argarray = av;
a0d0e21e
LW
2762 ++MARK;
2763
2764 if (items > AvMAX(av) + 1) {
2765 ary = AvALLOC(av);
2766 if (AvARRAY(av) != ary) {
2767 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2768 SvPVX(av) = (char*)ary;
2769 }
2770 if (items > AvMAX(av) + 1) {
2771 AvMAX(av) = items - 1;
2772 Renew(ary,items,SV*);
2773 AvALLOC(av) = ary;
2774 SvPVX(av) = (char*)ary;
2775 }
2776 }
2777 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2778 AvFILLp(av) = items - 1;
1c846c1f 2779
a0d0e21e
LW
2780 while (items--) {
2781 if (*MARK)
2782 SvTEMP_off(*MARK);
2783 MARK++;
2784 }
2785 }
4a925ff6
GS
2786 /* warning must come *after* we fully set up the context
2787 * stuff so that __WARN__ handlers can safely dounwind()
2788 * if they want to
2789 */
2790 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2791 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2792 sub_crush_depth(cv);
77a005ab 2793#if 0
bf49b057 2794 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2795 "%p entersub returning %p\n", thr, CvSTART(cv)));
77a005ab 2796#endif
a0d0e21e
LW
2797 RETURNOP(CvSTART(cv));
2798 }
2799}
2800
44a8e56a 2801void
864dbfa3 2802Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a
PP
2803{
2804 if (CvANON(cv))
cea2e8a9 2805 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
44a8e56a
PP
2806 else {
2807 SV* tmpstr = sv_newmortal();
2808 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1c846c1f 2809 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
599cee73 2810 SvPVX(tmpstr));
44a8e56a
PP
2811 }
2812}
2813
a0d0e21e
LW
2814PP(pp_aelem)
2815{
4e35701f 2816 djSP;
a0d0e21e 2817 SV** svp;
d804643f
SC
2818 SV* elemsv = POPs;
2819 IV elem = SvIV(elemsv);
68dc0745 2820 AV* av = (AV*)POPs;
533c011a
NIS
2821 U32 lval = PL_op->op_flags & OPf_MOD;
2822 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
be6c24e0 2823 SV *sv;
a0d0e21e 2824
d804643f
SC
2825 if (SvROK(elemsv) && ckWARN(WARN_MISC))
2826 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
748a9306 2827 if (elem > 0)
3280af22 2828 elem -= PL_curcop->cop_arybase;
a0d0e21e
LW
2829 if (SvTYPE(av) != SVt_PVAV)
2830 RETPUSHUNDEF;
68dc0745 2831 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2832 if (lval) {
3280af22 2833 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2834 SV* lv;
2835 if (!defer)
cea2e8a9 2836 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2837 lv = sv_newmortal();
2838 sv_upgrade(lv, SVt_PVLV);
2839 LvTYPE(lv) = 'y';
2840 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2841 LvTARG(lv) = SvREFCNT_inc(av);
2842 LvTARGOFF(lv) = elem;
2843 LvTARGLEN(lv) = 1;
2844 PUSHs(lv);
2845 RETURN;
2846 }
533c011a 2847 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2848 save_aelem(av, elem, svp);
533c011a
NIS
2849 else if (PL_op->op_private & OPpDEREF)
2850 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 2851 }
3280af22 2852 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
2853 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2854 sv = sv_mortalcopy(sv);
2855 PUSHs(sv);
a0d0e21e
LW
2856 RETURN;
2857}
2858
02a9e968 2859void
864dbfa3 2860Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968
CS
2861{
2862 if (SvGMAGICAL(sv))
2863 mg_get(sv);
2864 if (!SvOK(sv)) {
2865 if (SvREADONLY(sv))
cea2e8a9 2866 Perl_croak(aTHX_ PL_no_modify);
5f05dabc
PP
2867 if (SvTYPE(sv) < SVt_RV)
2868 sv_upgrade(sv, SVt_RV);
2869 else if (SvTYPE(sv) >= SVt_PV) {
2870 (void)SvOOK_off(sv);
2871 Safefree(SvPVX(sv));
2872 SvLEN(sv) = SvCUR(sv) = 0;
2873 }
68dc0745 2874 switch (to_what) {
5f05dabc 2875 case OPpDEREF_SV:
8c52afec 2876 SvRV(sv) = NEWSV(355,0);
5f05dabc
PP
2877 break;
2878 case OPpDEREF_AV:
2879 SvRV(sv) = (SV*)newAV();
2880 break;
2881 case OPpDEREF_HV:
2882 SvRV(sv) = (SV*)newHV();
2883 break;
2884 }
02a9e968
CS
2885 SvROK_on(sv);
2886 SvSETMAGIC(sv);
2887 }
2888}
2889
a0d0e21e
LW
2890PP(pp_method)
2891{
4e35701f 2892 djSP;
f5d5a27c
CS
2893 SV* sv = TOPs;
2894
2895 if (SvROK(sv)) {
eda383f2 2896 SV* rsv = SvRV(sv);
f5d5a27c
CS
2897 if (SvTYPE(rsv) == SVt_PVCV) {
2898 SETs(rsv);
2899 RETURN;
2900 }
2901 }
2902
2903 SETs(method_common(sv, Null(U32*)));
2904 RETURN;
2905}
2906
2907PP(pp_method_named)
2908{
2909 djSP;
2910 SV* sv = cSVOP->op_sv;
2911 U32 hash = SvUVX(sv);
2912
2913 XPUSHs(method_common(sv, &hash));
2914 RETURN;
2915}
2916
2917STATIC SV *
2918S_method_common(pTHX_ SV* meth, U32* hashp)
2919{
a0d0e21e
LW
2920 SV* sv;
2921 SV* ob;
2922 GV* gv;
56304f61
CS
2923 HV* stash;
2924 char* name;
f5d5a27c 2925 STRLEN namelen;
ac91690f
CS
2926 char* packname;
2927 STRLEN packlen;
a0d0e21e 2928
f5d5a27c 2929 name = SvPV(meth, namelen);
3280af22 2930 sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 2931
4f1b7578
SC
2932 if (!sv)
2933 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2934
16d20bd9
AD
2935 if (SvGMAGICAL(sv))
2936 mg_get(sv);
a0d0e21e 2937 if (SvROK(sv))
16d20bd9 2938 ob = (SV*)SvRV(sv);
a0d0e21e
LW
2939 else {
2940 GV* iogv;
a0d0e21e 2941
56304f61 2942 packname = Nullch;
a0d0e21e 2943 if (!SvOK(sv) ||
56304f61 2944 !(packname = SvPV(sv, packlen)) ||
a0d0e21e
LW
2945 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2946 !(ob=(SV*)GvIO(iogv)))
2947 {
1c846c1f 2948 if (!packname ||
7e2040f0 2949 ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
b86a2fa7 2950 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW
2951 : !isIDFIRST(*packname)
2952 ))
2953 {
f5d5a27c
CS
2954 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2955 SvOK(sv) ? "without a package or object reference"
2956 : "on an undefined value");
834a4ddd 2957 }
56304f61 2958 stash = gv_stashpvn(packname, packlen, TRUE);
ac91690f 2959 goto fetch;
a0d0e21e 2960 }
3280af22 2961 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e
LW
2962 }
2963
f0d43078
GS
2964 if (!ob || !(SvOBJECT(ob)
2965 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2966 && SvOBJECT(ob))))
2967 {
f5d5a27c
CS
2968 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2969 name);
f0d43078 2970 }
a0d0e21e 2971
56304f61 2972 stash = SvSTASH(ob);
a0d0e21e 2973
ac91690f 2974 fetch:
f5d5a27c
CS
2975 /* shortcut for simple names */
2976 if (hashp) {
2977 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2978 if (he) {
2979 gv = (GV*)HeVAL(he);
2980 if (isGV(gv) && GvCV(gv) &&
2981 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2982 return (SV*)GvCV(gv);
2983 }
2984 }
2985
ac91690f 2986 gv = gv_fetchmethod(stash, name);
56304f61
CS
2987 if (!gv) {
2988 char* leaf = name;
2989 char* sep = Nullch;
2990 char* p;
c1899e02 2991 GV* gv;
56304f61
CS
2992
2993 for (p = name; *p; p++) {
2994 if (*p == '\'')
2995 sep = p, leaf = p + 1;
2996 else if (*p == ':' && *(p + 1) == ':')
2997 sep = p, leaf = p + 2;
2998 }
2999 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
1d7c1841 3000 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
56304f61
CS
3001 packlen = strlen(packname);
3002 }
3003 else {
3004 packname = name;
3005 packlen = sep - name;
3006 }
c1899e02
GS
3007 gv = gv_fetchpv(packname, 0, SVt_PVHV);
3008 if (gv && isGV(gv)) {
3009 Perl_croak(aTHX_
3010 "Can't locate object method \"%s\" via package \"%s\"",
3011 leaf, packname);
3012 }
3013 else {
3014 Perl_croak(aTHX_
f6e565ef 3015 "Can't locate object method \"%s\" via package \"%s\""
c1899e02
GS
3016 " (perhaps you forgot to load \"%s\"?)",
3017 leaf, packname, packname);
3018 }
56304f61 3019 }
f5d5a27c 3020 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
a0d0e21e 3021}
22239a37 3022
51371543
GS
3023#ifdef USE_THREADS
3024static void
3025unset_cvowner(pTHXo_ void *cvarg)
3026{
3027 register CV* cv = (CV *) cvarg;
51371543 3028
bf49b057 3029 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
51371543
GS
3030 thr, cv, SvPEEK((SV*)cv))));
3031 MUTEX_LOCK(CvMUTEXP(cv));
3032 DEBUG_S(if (CvDEPTH(cv) != 0)
bf49b057 3033 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
51371543
GS
3034 CvDEPTH(cv)););
3035 assert(thr == CvOWNER(cv));
3036 CvOWNER(cv) = 0;
3037 MUTEX_UNLOCK(CvMUTEXP(cv));
3038 SvREFCNT_dec(cv);
3039}
3040#endif /* USE_THREADS */