This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Loose the "Loading..." warning.
[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;
60aeb6fd
NIS
143 STRLEN len, llen, rlen;
144 U8 *s, *l, *r;
ed646e6e
SC
145 bool left_utf8;
146 bool right_utf8;
69b47968 147
60aeb6fd
NIS
148 r = (U8*)SvPV(right,rlen);
149
150 if (TARG != left)
151 l = (U8*)SvPV(left,llen);
152 else if (SvGMAGICAL(left))
82f2f503
SC
153 mg_get(left);
154
ed646e6e
SC
155 left_utf8 = DO_UTF8(left);
156 right_utf8 = DO_UTF8(right);
7889fe52 157
60aeb6fd 158 if (left_utf8 != right_utf8 && !IN_BYTE) {
ed646e6e 159 if (TARG == right && !right_utf8) {
37931a30
JH
160 sv_utf8_upgrade(TARG); /* Now straight binary copy */
161 SvUTF8_on(TARG);
162 }
163 else {
164 /* Set TARG to PV(left), then add right */
60aeb6fd 165 U8 *c, *olds = NULL;
37931a30 166 STRLEN targlen;
60aeb6fd 167 s = r; len = rlen;
37931a30 168 if (TARG == right) {
15bb2692 169 /* Take a copy since we're about to overwrite TARG */
b7018214 170 olds = s = (U8*)savepvn((char*)s, len);
37931a30 171 }
689440ec 172 if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) {
905d5022
JH
173 if (SvREADONLY(left))
174 left = sv_2mortal(newSVsv(left));
689440ec
JH
175 else
176 sv_setpv(left, ""); /* Suppress warning. */
177 }
37931a30 178 if (TARG != left)
60aeb6fd
NIS
179 sv_setpvn(TARG, (char*)l, llen);
180 if (!left_utf8) {
181 SvUTF8_off(TARG);
182 sv_utf8_upgrade(TARG);
183 }
37931a30
JH
184 /* Extend TARG to length of right (s) */
185 targlen = SvCUR(TARG) + len;
ed646e6e 186 if (!right_utf8) {
37931a30 187 /* plus one for each hi-byte char if we have to upgrade */
15bb2692 188 for (c = s; c < s + len; c++) {
ed646e6e 189 if (UTF8_IS_CONTINUED(*c))
37931a30
JH
190 targlen++;
191 }
192 }
193 SvGROW(TARG, targlen+1);
194 /* And now copy, maybe upgrading right to UTF8 on the fly */
ed646e6e
SC
195 if (right_utf8)
196 Copy(s, SvEND(TARG), len, U8);
197 else {
198 for (c = (U8*)SvEND(TARG); len--; s++)
199 c = uv_to_utf8(c, *s);
200 }
37931a30
JH
201 SvCUR_set(TARG, targlen);
202 *SvEND(TARG) = '\0';
203 SvUTF8_on(TARG);
204 SETs(TARG);
205 Safefree(olds);
206 RETURN;
207 }
208 }
209
a0d0e21e 210 if (TARG != left) {
69b47968 211 if (TARG == right) {
60aeb6fd 212 sv_insert(TARG, 0, 0, (char*)l, llen);
69b47968
GS
213 SETs(TARG);
214 RETURN;
215 }
60aeb6fd 216 sv_setpvn(TARG, (char *)l, llen);
a0d0e21e 217 }
37931a30 218 else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG)
748a9306 219 sv_setpv(TARG, ""); /* Suppress warning. */
60aeb6fd 220 s = r; len = rlen;
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 */
60aeb6fd 238 if (left_utf8 && !IN_BYTE)
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 }
60aeb6fd
NIS
1243 if (rx->reganch & RE_USE_INTUIT &&
1244 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
f722798b
IZ
1245 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1246
1247 if (!s)
1248 goto nope;
1249 if ( (rx->reganch & ROPT_CHECK_ALL)
1c846c1f 1250 && !PL_sawampersand
f722798b
IZ
1251 && ((rx->reganch & ROPT_NOSCAN)
1252 || !((rx->reganch & RE_INTUIT_TAIL)
05b4157f
GS
1253 && (r_flags & REXEC_SCREAM)))
1254 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
f722798b 1255 goto yup;
a0d0e21e 1256 }
cea2e8a9 1257 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
bbce6d69 1258 {
3280af22 1259 PL_curpm = pm;
a0d0e21e 1260 if (pm->op_pmflags & PMf_ONCE)
48c036b1 1261 pm->op_pmdynflags |= PMdf_USED;
a0d0e21e
LW
1262 goto gotcha;
1263 }
1264 else
1265 goto ret_no;
1266 /*NOTREACHED*/
1267
1268 gotcha:
72311751
GS
1269 if (rxtainted)
1270 RX_MATCH_TAINTED_on(rx);
1271 TAINT_IF(RX_MATCH_TAINTED(rx));
a0d0e21e 1272 if (gimme == G_ARRAY) {
ffc61ed2 1273 I32 nparens, i, len;
a0d0e21e 1274
ffc61ed2
JH
1275 nparens = rx->nparens;
1276 if (global && !nparens)
a0d0e21e
LW
1277 i = 1;
1278 else
1279 i = 0;
c277df42 1280 SPAGAIN; /* EVAL blocks could move the stack. */
ffc61ed2
JH
1281 EXTEND(SP, nparens + i);
1282 EXTEND_MORTAL(nparens + i);
1283 for (i = !i; i <= nparens; i++) {
a0d0e21e
LW
1284 PUSHs(sv_newmortal());
1285 /*SUPPRESS 560*/
cf93c79d
IZ
1286 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1287 len = rx->endp[i] - rx->startp[i];
1288 s = rx->startp[i] + truebase;
a0d0e21e 1289 sv_setpvn(*SP, s, len);
ffc61ed2 1290 if (DO_UTF8(TARG))
a197cbdd 1291 SvUTF8_on(*SP);
a0d0e21e
LW
1292 }
1293 }
1294 if (global) {
cf93c79d
IZ
1295 had_zerolen = (rx->startp[0] != -1
1296 && rx->startp[0] == rx->endp[0]);
c277df42 1297 PUTBACK; /* EVAL blocks may use stack */
cf93c79d 1298 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
1299 goto play_it_again;
1300 }
ffc61ed2 1301 else if (!nparens)
bde848c5 1302 XPUSHs(&PL_sv_yes);
4633a7c4 1303 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1304 RETURN;
1305 }
1306 else {
1307 if (global) {
1308 MAGIC* mg = 0;
1309 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1310 mg = mg_find(TARG, 'g');
1311 if (!mg) {
1312 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1313 mg = mg_find(TARG, 'g');
1314 }
cf93c79d
IZ
1315 if (rx->startp[0] != -1) {
1316 mg->mg_len = rx->endp[0];
d9f97599 1317 if (rx->startp[0] == rx->endp[0])
748a9306
LW
1318 mg->mg_flags |= MGf_MINMATCH;
1319 else
1320 mg->mg_flags &= ~MGf_MINMATCH;
1321 }
a0d0e21e 1322 }
4633a7c4 1323 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1324 RETPUSHYES;
1325 }
1326
f722798b 1327yup: /* Confirmed by INTUIT */
72311751
GS
1328 if (rxtainted)
1329 RX_MATCH_TAINTED_on(rx);
1330 TAINT_IF(RX_MATCH_TAINTED(rx));
3280af22 1331 PL_curpm = pm;
a0d0e21e 1332 if (pm->op_pmflags & PMf_ONCE)
48c036b1 1333 pm->op_pmdynflags |= PMdf_USED;
cf93c79d
IZ
1334 if (RX_MATCH_COPIED(rx))
1335 Safefree(rx->subbeg);
1336 RX_MATCH_COPIED_off(rx);
1337 rx->subbeg = Nullch;
a0d0e21e 1338 if (global) {
d9f97599 1339 rx->subbeg = truebase;
cf93c79d 1340 rx->startp[0] = s - truebase;
60aeb6fd
NIS
1341 if (DO_UTF8(PL_reg_sv)) {
1342 char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1343 rx->endp[0] = t - truebase;
1344 }
1345 else {
1346 rx->endp[0] = s - truebase + rx->minlen;
1347 }
cf93c79d 1348 rx->sublen = strend - truebase;
a0d0e21e 1349 goto gotcha;
1c846c1f 1350 }
3280af22 1351 if (PL_sawampersand) {
cf93c79d 1352 I32 off;
a0d0e21e 1353
cf93c79d
IZ
1354 rx->subbeg = savepvn(t, strend - t);
1355 rx->sublen = strend - t;
1356 RX_MATCH_COPIED_on(rx);
1357 off = rx->startp[0] = s - t;
f722798b 1358 rx->endp[0] = off + rx->minlen;
cf93c79d
IZ
1359 }
1360 else { /* startp/endp are used by @- @+. */
1361 rx->startp[0] = s - truebase;
f722798b 1362 rx->endp[0] = s - truebase + rx->minlen;
a0d0e21e 1363 }
fc19f8d0 1364 rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
4633a7c4 1365 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1366 RETPUSHYES;
1367
1368nope:
a0d0e21e 1369ret_no:
c90c0ff4 1370 if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
a0d0e21e
LW
1371 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1372 MAGIC* mg = mg_find(TARG, 'g');
1373 if (mg)
565764a8 1374 mg->mg_len = -1;
a0d0e21e
LW
1375 }
1376 }
4633a7c4 1377 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
1378 if (gimme == G_ARRAY)
1379 RETURN;
1380 RETPUSHNO;
1381}
1382
1383OP *
864dbfa3 1384Perl_do_readline(pTHX)
a0d0e21e
LW
1385{
1386 dSP; dTARGETSTACKED;
1387 register SV *sv;
1388 STRLEN tmplen = 0;
1389 STRLEN offset;
760ac839 1390 PerlIO *fp;
3280af22 1391 register IO *io = GvIO(PL_last_in_gv);
533c011a 1392 register I32 type = PL_op->op_type;
54310121 1393 I32 gimme = GIMME_V;
e79b0511 1394 MAGIC *mg;
a0d0e21e 1395
155aba94 1396 if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
e79b0511 1397 PUSHMARK(SP);
33c27489 1398 XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
e79b0511
PP
1399 PUTBACK;
1400 ENTER;
864dbfa3 1401 call_method("READLINE", gimme);
e79b0511
PP
1402 LEAVE;
1403 SPAGAIN;
54310121
PP
1404 if (gimme == G_SCALAR)
1405 SvSetMagicSV_nosteal(TARG, TOPs);
e79b0511
PP
1406 RETURN;
1407 }
a0d0e21e
LW
1408 fp = Nullfp;
1409 if (io) {
1410 fp = IoIFP(io);
1411 if (!fp) {
1412 if (IoFLAGS(io) & IOf_ARGV) {
1413 if (IoFLAGS(io) & IOf_START) {
a0d0e21e 1414 IoLINES(io) = 0;
3280af22 1415 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1d7c1841 1416 IoFLAGS(io) &= ~IOf_START;
9d116dd7 1417 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
3280af22
NIS
1418 sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1419 SvSETMAGIC(GvSV(PL_last_in_gv));
a2008d6d
GS
1420 fp = IoIFP(io);
1421 goto have_fp;
a0d0e21e
LW
1422 }
1423 }
3280af22 1424 fp = nextargv(PL_last_in_gv);
a0d0e21e 1425 if (!fp) { /* Note: fp != IoIFP(io) */
3280af22 1426 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
a0d0e21e
LW
1427 }
1428 }
0d44d22b
NC
1429 else if (type == OP_GLOB)
1430 fp = Perl_start_glob(aTHX_ POPs, io);
a0d0e21e
LW
1431 }
1432 else if (type == OP_GLOB)
1433 SP--;
af8c498a 1434 else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
9f37169a 1435 && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
af8c498a 1436 || fp == PerlIO_stderr()))
4c80c0b2 1437 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
a0d0e21e
LW
1438 }
1439 if (!fp) {
790090df
HS
1440 if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1441 && (!io || !(IoFLAGS(io) & IOf_START))) {
3f4520fe 1442 if (type == OP_GLOB)
e476b1b5 1443 Perl_warner(aTHX_ WARN_GLOB,
af8c498a
GS
1444 "glob failed (can't start child: %s)",
1445 Strerror(errno));
69282e91 1446 else
bc37a18f 1447 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
3f4520fe 1448 }
54310121 1449 if (gimme == G_SCALAR) {
a0d0e21e
LW
1450 (void)SvOK_off(TARG);
1451 PUSHTARG;
1452 }
1453 RETURN;
1454 }
a2008d6d 1455 have_fp:
54310121 1456 if (gimme == G_SCALAR) {
a0d0e21e 1457 sv = TARG;
9607fc9c
PP
1458 if (SvROK(sv))
1459 sv_unref(sv);
a0d0e21e
LW
1460 (void)SvUPGRADE(sv, SVt_PV);
1461 tmplen = SvLEN(sv); /* remember if already alloced */
1462 if (!tmplen)
1463 Sv_Grow(sv, 80); /* try short-buffering it */
1464 if (type == OP_RCATLINE)
1465 offset = SvCUR(sv);
1466 else
1467 offset = 0;
1468 }
54310121
PP
1469 else {
1470 sv = sv_2mortal(NEWSV(57, 80));
1471 offset = 0;
1472 }
fbad3eb5 1473
3887d568
AP
1474 /* This should not be marked tainted if the fp is marked clean */
1475#define MAYBE_TAINT_LINE(io, sv) \
1476 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1477 TAINT; \
1478 SvTAINTED_on(sv); \
1479 }
1480
684bef36 1481/* delay EOF state for a snarfed empty file */
fbad3eb5 1482#define SNARF_EOF(gimme,rs,io,sv) \
684bef36 1483 (gimme != G_SCALAR || SvCUR(sv) \
b9fee9ba 1484 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
fbad3eb5 1485
a0d0e21e 1486 for (;;) {
fbad3eb5
GS
1487 if (!sv_gets(sv, fp, offset)
1488 && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1489 {
760ac839 1490 PerlIO_clearerr(fp);
a0d0e21e 1491 if (IoFLAGS(io) & IOf_ARGV) {
3280af22 1492 fp = nextargv(PL_last_in_gv);
a0d0e21e
LW
1493 if (fp)
1494 continue;
3280af22 1495 (void)do_close(PL_last_in_gv, FALSE);
a0d0e21e
LW
1496 }
1497 else if (type == OP_GLOB) {
e476b1b5
GS
1498 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1499 Perl_warner(aTHX_ WARN_GLOB,
4eb79ab5 1500 "glob failed (child exited with status %d%s)",
894356b3 1501 (int)(STATUS_CURRENT >> 8),
cf494569 1502 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
4eb79ab5 1503 }
a0d0e21e 1504 }
54310121 1505 if (gimme == G_SCALAR) {
a0d0e21e
LW
1506 (void)SvOK_off(TARG);
1507 PUSHTARG;
1508 }
3887d568 1509 MAYBE_TAINT_LINE(io, sv);
a0d0e21e
LW
1510 RETURN;
1511 }
3887d568 1512 MAYBE_TAINT_LINE(io, sv);
a0d0e21e 1513 IoLINES(io)++;
b9fee9ba 1514 IoFLAGS(io) |= IOf_NOLINE;
71be2cbc 1515 SvSETMAGIC(sv);
a0d0e21e 1516 XPUSHs(sv);
a0d0e21e
LW
1517 if (type == OP_GLOB) {
1518 char *tmps;
1519
3280af22 1520 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
c07a80fd 1521 tmps = SvEND(sv) - 1;
3280af22 1522 if (*tmps == *SvPVX(PL_rs)) {
c07a80fd
PP
1523 *tmps = '\0';
1524 SvCUR(sv)--;
1525 }
1526 }
a0d0e21e
LW
1527 for (tmps = SvPVX(sv); *tmps; tmps++)
1528 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1529 strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1530 break;
43384a1a 1531 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
a0d0e21e
LW
1532 (void)POPs; /* Unmatched wildcard? Chuck it... */
1533 continue;
1534 }
1535 }
54310121 1536 if (gimme == G_ARRAY) {
a0d0e21e
LW
1537 if (SvLEN(sv) - SvCUR(sv) > 20) {
1538 SvLEN_set(sv, SvCUR(sv)+1);
1539 Renew(SvPVX(sv), SvLEN(sv), char);
1540 }
1541 sv = sv_2mortal(NEWSV(58, 80));
1542 continue;
1543 }
54310121 1544 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
a0d0e21e
LW
1545 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1546 if (SvCUR(sv) < 60)
1547 SvLEN_set(sv, 80);
1548 else
1549 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
1550 Renew(SvPVX(sv), SvLEN(sv), char);
1551 }
1552 RETURN;
1553 }
1554}
1555
1556PP(pp_enter)
1557{
4e35701f 1558 djSP;
c09156bb 1559 register PERL_CONTEXT *cx;
533c011a 1560 I32 gimme = OP_GIMME(PL_op, -1);
a0d0e21e 1561
54310121
PP
1562 if (gimme == -1) {
1563 if (cxstack_ix >= 0)
1564 gimme = cxstack[cxstack_ix].blk_gimme;
1565 else
1566 gimme = G_SCALAR;
1567 }
a0d0e21e
LW
1568
1569 ENTER;
1570
1571 SAVETMPS;
924508f0 1572 PUSHBLOCK(cx, CXt_BLOCK, SP);
a0d0e21e
LW
1573
1574 RETURN;
1575}
1576
1577PP(pp_helem)
1578{
4e35701f 1579 djSP;
760ac839 1580 HE* he;
ae77835f 1581 SV **svp;
a0d0e21e 1582 SV *keysv = POPs;
a0d0e21e 1583 HV *hv = (HV*)POPs;
533c011a
NIS
1584 U32 lval = PL_op->op_flags & OPf_MOD;
1585 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
be6c24e0 1586 SV *sv;
1c846c1f 1587 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1f5346dc 1588 I32 preeminent;
a0d0e21e 1589
ae77835f 1590 if (SvTYPE(hv) == SVt_PVHV) {
1f5346dc
SC
1591 if (PL_op->op_private & OPpLVAL_INTRO)
1592 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1c846c1f 1593 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
97fcbf96 1594 svp = he ? &HeVAL(he) : 0;
ae77835f
MB
1595 }
1596 else if (SvTYPE(hv) == SVt_PVAV) {
0ebe0038 1597 if (PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 1598 DIE(aTHX_ "Can't localize pseudo-hash element");
1c846c1f 1599 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
ae77835f 1600 }
c750a3ec 1601 else {
a0d0e21e 1602 RETPUSHUNDEF;
c750a3ec 1603 }
a0d0e21e 1604 if (lval) {
3280af22 1605 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
1606 SV* lv;
1607 SV* key2;
2d8e6c8d
GS
1608 if (!defer) {
1609 STRLEN n_a;
cea2e8a9 1610 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 1611 }
68dc0745
PP
1612 lv = sv_newmortal();
1613 sv_upgrade(lv, SVt_PVLV);
1614 LvTYPE(lv) = 'y';
1615 sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1616 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1617 LvTARG(lv) = SvREFCNT_inc(hv);
1618 LvTARGLEN(lv) = 1;
1619 PUSHs(lv);
1620 RETURN;
1621 }
533c011a 1622 if (PL_op->op_private & OPpLVAL_INTRO) {
ae77835f 1623 if (HvNAME(hv) && isGV(*svp))
533c011a 1624 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1f5346dc
SC
1625 else {
1626 if (!preeminent) {
1627 STRLEN keylen;
1628 char *key = SvPV(keysv, keylen);
1629 save_delete(hv, key, keylen);
1630 } else
1631 save_helem(hv, keysv, svp);
1632 }
5f05dabc 1633 }
533c011a
NIS
1634 else if (PL_op->op_private & OPpDEREF)
1635 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 1636 }
3280af22 1637 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
1638 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1639 * Pushing the magical RHS on to the stack is useless, since
1640 * that magic is soon destined to be misled by the local(),
1641 * and thus the later pp_sassign() will fail to mg_get() the
1642 * old value. This should also cure problems with delayed
1643 * mg_get()s. GSAR 98-07-03 */
1644 if (!lval && SvGMAGICAL(sv))
1645 sv = sv_mortalcopy(sv);
1646 PUSHs(sv);
a0d0e21e
LW
1647 RETURN;
1648}
1649
1650PP(pp_leave)
1651{
4e35701f 1652 djSP;
c09156bb 1653 register PERL_CONTEXT *cx;
a0d0e21e
LW
1654 register SV **mark;
1655 SV **newsp;
1656 PMOP *newpm;
1657 I32 gimme;
1658
533c011a 1659 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1660 cx = &cxstack[cxstack_ix];
3280af22 1661 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
a0d0e21e
LW
1662 }
1663
1664 POPBLOCK(cx,newpm);
1665
533c011a 1666 gimme = OP_GIMME(PL_op, -1);
54310121
PP
1667 if (gimme == -1) {
1668 if (cxstack_ix >= 0)
1669 gimme = cxstack[cxstack_ix].blk_gimme;
1670 else
1671 gimme = G_SCALAR;
1672 }
a0d0e21e 1673
a1f49e72 1674 TAINT_NOT;
54310121
PP
1675 if (gimme == G_VOID)
1676 SP = newsp;
1677 else if (gimme == G_SCALAR) {
1678 MARK = newsp + 1;
1679 if (MARK <= SP)
1680 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1681 *MARK = TOPs;
1682 else
1683 *MARK = sv_mortalcopy(TOPs);
a0d0e21e 1684 else {
54310121 1685 MEXTEND(mark,0);
3280af22 1686 *MARK = &PL_sv_undef;
a0d0e21e 1687 }
54310121 1688 SP = MARK;
a0d0e21e 1689 }
54310121 1690 else if (gimme == G_ARRAY) {
a1f49e72
CS
1691 /* in case LEAVE wipes old return values */
1692 for (mark = newsp + 1; mark <= SP; mark++) {
1693 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 1694 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
1695 TAINT_NOT; /* Each item is independent */
1696 }
1697 }
a0d0e21e 1698 }
3280af22 1699 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW
1700
1701 LEAVE;
1702
1703 RETURN;
1704}
1705
1706PP(pp_iter)
1707{
4e35701f 1708 djSP;
c09156bb 1709 register PERL_CONTEXT *cx;
5f05dabc 1710 SV* sv;
4633a7c4 1711 AV* av;
1d7c1841 1712 SV **itersvp;
a0d0e21e 1713
924508f0 1714 EXTEND(SP, 1);
a0d0e21e 1715 cx = &cxstack[cxstack_ix];
6b35e009 1716 if (CxTYPE(cx) != CXt_LOOP)
cea2e8a9 1717 DIE(aTHX_ "panic: pp_iter");
a0d0e21e 1718
1d7c1841 1719 itersvp = CxITERVAR(cx);
4633a7c4 1720 av = cx->blk_loop.iterary;
89ea2908
GA
1721 if (SvTYPE(av) != SVt_PVAV) {
1722 /* iterate ($min .. $max) */
1723 if (cx->blk_loop.iterlval) {
1724 /* string increment */
1725 register SV* cur = cx->blk_loop.iterlval;
1726 STRLEN maxlen;
1727 char *max = SvPV((SV*)av, maxlen);
1728 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
eaa5c2d6 1729#ifndef USE_THREADS /* don't risk potential race */
1d7c1841 1730 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1731 /* safe to reuse old SV */
1d7c1841 1732 sv_setsv(*itersvp, cur);
eaa5c2d6 1733 }
1c846c1f 1734 else
eaa5c2d6
GA
1735#endif
1736 {
1737 /* we need a fresh SV every time so that loop body sees a
1738 * completely new SV for closures/references to work as
1739 * they used to */
1d7c1841
GS
1740 SvREFCNT_dec(*itersvp);
1741 *itersvp = newSVsv(cur);
eaa5c2d6 1742 }
89ea2908
GA
1743 if (strEQ(SvPVX(cur), max))
1744 sv_setiv(cur, 0); /* terminate next time */
1745 else
1746 sv_inc(cur);
1747 RETPUSHYES;
1748 }
1749 RETPUSHNO;
1750 }
1751 /* integer increment */
1752 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1753 RETPUSHNO;
7f61b687 1754
eaa5c2d6 1755#ifndef USE_THREADS /* don't risk potential race */
1d7c1841 1756 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
eaa5c2d6 1757 /* safe to reuse old SV */
1d7c1841 1758 sv_setiv(*itersvp, cx->blk_loop.iterix++);
eaa5c2d6 1759 }
1c846c1f 1760 else
eaa5c2d6
GA
1761#endif
1762 {
1763 /* we need a fresh SV every time so that loop body sees a
1764 * completely new SV for closures/references to work as they
1765 * used to */
1d7c1841
GS
1766 SvREFCNT_dec(*itersvp);
1767 *itersvp = newSViv(cx->blk_loop.iterix++);
eaa5c2d6 1768 }
89ea2908
GA
1769 RETPUSHYES;
1770 }
1771
1772 /* iterate array */
3280af22 1773 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
4633a7c4 1774 RETPUSHNO;
a0d0e21e 1775
1d7c1841 1776 SvREFCNT_dec(*itersvp);
a0d0e21e 1777
155aba94 1778 if ((sv = SvMAGICAL(av)
1c846c1f 1779 ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
155aba94 1780 : AvARRAY(av)[++cx->blk_loop.iterix]))
a0d0e21e 1781 SvTEMP_off(sv);
a0d0e21e 1782 else
3280af22
NIS
1783 sv = &PL_sv_undef;
1784 if (av != PL_curstack && SvIMMORTAL(sv)) {
5f05dabc 1785 SV *lv = cx->blk_loop.iterlval;
71be2cbc
PP
1786 if (lv && SvREFCNT(lv) > 1) {
1787 SvREFCNT_dec(lv);
1788 lv = Nullsv;
1789 }
5f05dabc
PP
1790 if (lv)
1791 SvREFCNT_dec(LvTARG(lv));
1792 else {
68dc0745 1793 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
5f05dabc 1794 sv_upgrade(lv, SVt_PVLV);
5f05dabc 1795 LvTYPE(lv) = 'y';
68dc0745 1796 sv_magic(lv, Nullsv, 'y', Nullch, 0);
5f05dabc
PP
1797 }
1798 LvTARG(lv) = SvREFCNT_inc(av);
1799 LvTARGOFF(lv) = cx->blk_loop.iterix;
42718184 1800 LvTARGLEN(lv) = (STRLEN)UV_MAX;
5f05dabc
PP
1801 sv = (SV*)lv;
1802 }
a0d0e21e 1803
1d7c1841 1804 *itersvp = SvREFCNT_inc(sv);
a0d0e21e
LW
1805 RETPUSHYES;
1806}
1807
1808PP(pp_subst)
1809{
4e35701f 1810 djSP; dTARG;
a0d0e21e
LW
1811 register PMOP *pm = cPMOP;
1812 PMOP *rpm = pm;
1813 register SV *dstr;
1814 register char *s;
1815 char *strend;
1816 register char *m;
1817 char *c;
1818 register char *d;
1819 STRLEN clen;
1820 I32 iters = 0;
1821 I32 maxiters;
1822 register I32 i;
1823 bool once;
71be2cbc 1824 bool rxtainted;
a0d0e21e 1825 char *orig;
22e551b9 1826 I32 r_flags;
d9f97599 1827 register REGEXP *rx = pm->op_pmregexp;
a0d0e21e
LW
1828 STRLEN len;
1829 int force_on_match = 0;
3280af22 1830 I32 oldsave = PL_savestack_ix;
792b2c16
JH
1831 bool do_utf8;
1832 STRLEN slen;
a0d0e21e 1833
5cd24f17
PP
1834 /* known replacement string? */
1835 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
533c011a 1836 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1837 TARG = POPs;
1838 else {
54b9620d 1839 TARG = DEFSV;
a0d0e21e 1840 EXTEND(SP,1);
1c846c1f 1841 }
ffc61ed2 1842 PL_reg_sv = TARG;
792b2c16 1843 do_utf8 = DO_UTF8(PL_reg_sv);
eca06228
NIS
1844 if (SvFAKE(TARG) && SvREADONLY(TARG))
1845 sv_force_normal(TARG);
68dc0745
PP
1846 if (SvREADONLY(TARG)
1847 || (SvTYPE(TARG) > SVt_PVLV
1848 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
d470f89e 1849 DIE(aTHX_ PL_no_modify);
8ec5e241
NIS
1850 PUTBACK;
1851
a0d0e21e 1852 s = SvPV(TARG, len);
68dc0745 1853 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
a0d0e21e 1854 force_on_match = 1;
b3eb6a9b 1855 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
3280af22
NIS
1856 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1857 if (PL_tainted)
b3eb6a9b 1858 rxtainted |= 2;
9212bbba 1859 TAINT_NOT;
ffc61ed2 1860
a0d0e21e
LW
1861 force_it:
1862 if (!pm || !s)
2269b42e 1863 DIE(aTHX_ "panic: pp_subst");
a0d0e21e
LW
1864
1865 strend = s + len;
a7514e1e 1866 slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
792b2c16
JH
1867 maxiters = 2 * slen + 10; /* We can match twice at each
1868 position, once with zero-length,
1869 second time with non-zero. */
a0d0e21e 1870
3280af22
NIS
1871 if (!rx->prelen && PL_curpm) {
1872 pm = PL_curpm;
d9f97599 1873 rx = pm->op_pmregexp;
a0d0e21e 1874 }
22e551b9 1875 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
9d080a66 1876 ? REXEC_COPY_STR : 0;
f722798b 1877 if (SvSCREAM(TARG))
22e551b9 1878 r_flags |= REXEC_SCREAM;
a0d0e21e 1879 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS
1880 SAVEINT(PL_multiline);
1881 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
a0d0e21e
LW
1882 }
1883 orig = m = s;
f722798b
IZ
1884 if (rx->reganch & RE_USE_INTUIT) {
1885 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1886
1887 if (!s)
1888 goto nope;
1889 /* How to do it in subst? */
1890/* if ( (rx->reganch & ROPT_CHECK_ALL)
1c846c1f 1891 && !PL_sawampersand
f722798b
IZ
1892 && ((rx->reganch & ROPT_NOSCAN)
1893 || !((rx->reganch & RE_INTUIT_TAIL)
1894 && (r_flags & REXEC_SCREAM))))
1895 goto yup;
1896*/
a0d0e21e 1897 }
71be2cbc
PP
1898
1899 /* only replace once? */
a0d0e21e 1900 once = !(rpm->op_pmflags & PMf_GLOBAL);
71be2cbc
PP
1901
1902 /* known replacement string? */
5cd24f17 1903 c = dstr ? SvPV(dstr, clen) : Nullch;
71be2cbc
PP
1904
1905 /* can do inplace substitution? */
22e551b9 1906 if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
d9f97599 1907 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
f722798b
IZ
1908 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1909 r_flags | REXEC_CHECKED))
1910 {
8ec5e241 1911 SPAGAIN;
3280af22 1912 PUSHs(&PL_sv_no);
71be2cbc
PP
1913 LEAVE_SCOPE(oldsave);
1914 RETURN;
1915 }
1916 if (force_on_match) {
1917 force_on_match = 0;
1918 s = SvPV_force(TARG, len);
1919 goto force_it;
1920 }
71be2cbc 1921 d = s;
3280af22 1922 PL_curpm = pm;
71be2cbc
PP
1923 SvSCREAM_off(TARG); /* disable possible screamer */
1924 if (once) {
48c036b1 1925 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d
IZ
1926 m = orig + rx->startp[0];
1927 d = orig + rx->endp[0];
71be2cbc
PP
1928 s = orig;
1929 if (m - s > strend - d) { /* faster to shorten from end */
1930 if (clen) {
1931 Copy(c, m, clen, char);
1932 m += clen;
a0d0e21e 1933 }
71be2cbc
PP
1934 i = strend - d;
1935 if (i > 0) {
1936 Move(d, m, i, char);
1937 m += i;
a0d0e21e 1938 }
71be2cbc
PP
1939 *m = '\0';
1940 SvCUR_set(TARG, m - s);
1941 }
1942 /*SUPPRESS 560*/
155aba94 1943 else if ((i = m - s)) { /* faster from front */
71be2cbc
PP
1944 d -= clen;
1945 m = d;
1946 sv_chop(TARG, d-i);
1947 s += i;
1948 while (i--)
1949 *--d = *--s;
1950 if (clen)
1951 Copy(c, m, clen, char);
1952 }
1953 else if (clen) {
1954 d -= clen;
1955 sv_chop(TARG, d);
1956 Copy(c, d, clen, char);
1957 }
1958 else {
1959 sv_chop(TARG, d);
1960 }
48c036b1 1961 TAINT_IF(rxtainted & 1);
8ec5e241 1962 SPAGAIN;
3280af22 1963 PUSHs(&PL_sv_yes);
71be2cbc
PP
1964 }
1965 else {
71be2cbc
PP
1966 do {
1967 if (iters++ > maxiters)
cea2e8a9 1968 DIE(aTHX_ "Substitution loop");
d9f97599 1969 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 1970 m = rx->startp[0] + orig;
71be2cbc 1971 /*SUPPRESS 560*/
155aba94 1972 if ((i = m - s)) {
71be2cbc
PP
1973 if (s != d)
1974 Move(s, d, i, char);
1975 d += i;
a0d0e21e 1976 }
71be2cbc
PP
1977 if (clen) {
1978 Copy(c, d, clen, char);
1979 d += clen;
1980 }
cf93c79d 1981 s = rx->endp[0] + orig;
cea2e8a9 1982 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
f722798b
IZ
1983 TARG, NULL,
1984 /* don't match same null twice */
1985 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
71be2cbc
PP
1986 if (s != d) {
1987 i = strend - s;
1988 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1989 Move(s, d, i+1, char); /* include the NUL */
a0d0e21e 1990 }
48c036b1 1991 TAINT_IF(rxtainted & 1);
8ec5e241 1992 SPAGAIN;
71be2cbc 1993 PUSHs(sv_2mortal(newSViv((I32)iters)));
a0d0e21e 1994 }
80b498e0 1995 (void)SvPOK_only_UTF8(TARG);
48c036b1 1996 TAINT_IF(rxtainted);
8ec5e241
NIS
1997 if (SvSMAGICAL(TARG)) {
1998 PUTBACK;
1999 mg_set(TARG);
2000 SPAGAIN;
2001 }
9212bbba 2002 SvTAINT(TARG);
71be2cbc
PP
2003 LEAVE_SCOPE(oldsave);
2004 RETURN;
a0d0e21e 2005 }
71be2cbc 2006
f722798b
IZ
2007 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2008 r_flags | REXEC_CHECKED))
2009 {
60aeb6fd
NIS
2010 bool isutf8;
2011
a0d0e21e
LW
2012 if (force_on_match) {
2013 force_on_match = 0;
2014 s = SvPV_force(TARG, len);
2015 goto force_it;
2016 }
48c036b1 2017 rxtainted |= RX_MATCH_TAINTED(rx);
8ec5e241 2018 dstr = NEWSV(25, len);
a0d0e21e 2019 sv_setpvn(dstr, m, s-m);
ffc61ed2
JH
2020 if (DO_UTF8(TARG))
2021 SvUTF8_on(dstr);
3280af22 2022 PL_curpm = pm;
a0d0e21e 2023 if (!c) {
c09156bb 2024 register PERL_CONTEXT *cx;
8ec5e241 2025 SPAGAIN;
a0d0e21e
LW
2026 PUSHSUBST(cx);
2027 RETURNOP(cPMOP->op_pmreplroot);
2028 }
cf93c79d 2029 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
a0d0e21e
LW
2030 do {
2031 if (iters++ > maxiters)
cea2e8a9 2032 DIE(aTHX_ "Substitution loop");
d9f97599 2033 rxtainted |= RX_MATCH_TAINTED(rx);
cf93c79d 2034 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW
2035 m = s;
2036 s = orig;
cf93c79d 2037 orig = rx->subbeg;
a0d0e21e
LW
2038 s = orig + (m - s);
2039 strend = s + (strend - m);
2040 }
cf93c79d 2041 m = rx->startp[0] + orig;
a0d0e21e 2042 sv_catpvn(dstr, s, m-s);
cf93c79d 2043 s = rx->endp[0] + orig;
a0d0e21e
LW
2044 if (clen)
2045 sv_catpvn(dstr, c, clen);
2046 if (once)
2047 break;
ffc61ed2
JH
2048 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2049 TARG, NULL, r_flags));
a0d0e21e 2050 sv_catpvn(dstr, s, strend - s);
748a9306 2051
4633a7c4 2052 (void)SvOOK_off(TARG);
cb0b1708 2053 Safefree(SvPVX(TARG));
748a9306
LW
2054 SvPVX(TARG) = SvPVX(dstr);
2055 SvCUR_set(TARG, SvCUR(dstr));
2056 SvLEN_set(TARG, SvLEN(dstr));
60aeb6fd 2057 isutf8 = DO_UTF8(dstr);
748a9306
LW
2058 SvPVX(dstr) = 0;
2059 sv_free(dstr);
2060
48c036b1 2061 TAINT_IF(rxtainted & 1);
f878fbec 2062 SPAGAIN;
48c036b1
GS
2063 PUSHs(sv_2mortal(newSViv((I32)iters)));
2064
a0d0e21e 2065 (void)SvPOK_only(TARG);
60aeb6fd
NIS
2066 if (isutf8)
2067 SvUTF8_on(TARG);
48c036b1 2068 TAINT_IF(rxtainted);
a0d0e21e 2069 SvSETMAGIC(TARG);
9212bbba 2070 SvTAINT(TARG);
4633a7c4 2071 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2072 RETURN;
2073 }
5cd24f17 2074 goto ret_no;
a0d0e21e
LW
2075
2076nope:
1c846c1f 2077ret_no:
8ec5e241 2078 SPAGAIN;
3280af22 2079 PUSHs(&PL_sv_no);
4633a7c4 2080 LEAVE_SCOPE(oldsave);
a0d0e21e
LW
2081 RETURN;
2082}
2083
2084PP(pp_grepwhile)
2085{
4e35701f 2086 djSP;
a0d0e21e
LW
2087
2088 if (SvTRUEx(POPs))
3280af22
NIS
2089 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2090 ++*PL_markstack_ptr;
a0d0e21e
LW
2091 LEAVE; /* exit inner scope */
2092
2093 /* All done yet? */
3280af22 2094 if (PL_stack_base + *PL_markstack_ptr > SP) {
a0d0e21e 2095 I32 items;
54310121 2096 I32 gimme = GIMME_V;
a0d0e21e
LW
2097
2098 LEAVE; /* exit outer scope */
2099 (void)POPMARK; /* pop src */
3280af22 2100 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 2101 (void)POPMARK; /* pop dst */
3280af22 2102 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 2103 if (gimme == G_SCALAR) {
a0d0e21e
LW
2104 dTARGET;
2105 XPUSHi(items);
a0d0e21e 2106 }
54310121
PP
2107 else if (gimme == G_ARRAY)
2108 SP += items;
a0d0e21e
LW
2109 RETURN;
2110 }
2111 else {
2112 SV *src;
2113
2114 ENTER; /* enter inner scope */
1d7c1841 2115 SAVEVPTR(PL_curpm);
a0d0e21e 2116
3280af22 2117 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 2118 SvTEMP_off(src);
54b9620d 2119 DEFSV = src;
a0d0e21e
LW
2120
2121 RETURNOP(cLOGOP->op_other);
2122 }
2123}
2124
2125PP(pp_leavesub)
2126{
4e35701f 2127 djSP;
a0d0e21e
LW
2128 SV **mark;
2129 SV **newsp;
2130 PMOP *newpm;
2131 I32 gimme;
c09156bb 2132 register PERL_CONTEXT *cx;
b0d9ce38 2133 SV *sv;
a0d0e21e
LW
2134
2135 POPBLOCK(cx,newpm);
1c846c1f 2136
a1f49e72 2137 TAINT_NOT;
a0d0e21e
LW
2138 if (gimme == G_SCALAR) {
2139 MARK = newsp + 1;
a29cdaf0 2140 if (MARK <= SP) {
a8bba7fa 2141 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
2142 if (SvTEMP(TOPs)) {
2143 *MARK = SvREFCNT_inc(TOPs);
2144 FREETMPS;
2145 sv_2mortal(*MARK);
cd06dffe
GS
2146 }
2147 else {
959e3673 2148 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
a29cdaf0 2149 FREETMPS;
959e3673
GS
2150 *MARK = sv_mortalcopy(sv);
2151 SvREFCNT_dec(sv);
a29cdaf0 2152 }
cd06dffe
GS
2153 }
2154 else
a29cdaf0 2155 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
cd06dffe
GS
2156 }
2157 else {
f86702cc 2158 MEXTEND(MARK, 0);
3280af22 2159 *MARK = &PL_sv_undef;
a0d0e21e
LW
2160 }
2161 SP = MARK;
2162 }
54310121 2163 else if (gimme == G_ARRAY) {
f86702cc 2164 for (MARK = newsp + 1; MARK <= SP; MARK++) {
a1f49e72 2165 if (!SvTEMP(*MARK)) {
f86702cc 2166 *MARK = sv_mortalcopy(*MARK);
a1f49e72
CS
2167 TAINT_NOT; /* Each item is independent */
2168 }
f86702cc 2169 }
a0d0e21e 2170 }
f86702cc 2171 PUTBACK;
1c846c1f 2172
b0d9ce38 2173 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3280af22 2174 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW
2175
2176 LEAVE;
b0d9ce38 2177 LEAVESUB(sv);
a0d0e21e
LW
2178 return pop_return();
2179}
2180
cd06dffe
GS
2181/* This duplicates the above code because the above code must not
2182 * get any slower by more conditions */
2183PP(pp_leavesublv)
2184{
2185 djSP;
2186 SV **mark;
2187 SV **newsp;
2188 PMOP *newpm;
2189 I32 gimme;
2190 register PERL_CONTEXT *cx;
b0d9ce38 2191 SV *sv;
cd06dffe
GS
2192
2193 POPBLOCK(cx,newpm);
1c846c1f 2194
cd06dffe
GS
2195 TAINT_NOT;
2196
2197 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2198 /* We are an argument to a function or grep().
2199 * This kind of lvalueness was legal before lvalue
2200 * subroutines too, so be backward compatible:
2201 * cannot report errors. */
2202
2203 /* Scalar context *is* possible, on the LHS of -> only,
2204 * as in f()->meth(). But this is not an lvalue. */
2205 if (gimme == G_SCALAR)
2206 goto temporise;
2207 if (gimme == G_ARRAY) {
a8bba7fa 2208 if (!CvLVALUE(cx->blk_sub.cv))
cd06dffe
GS
2209 goto temporise_array;
2210 EXTEND_MORTAL(SP - newsp);
2211 for (mark = newsp + 1; mark <= SP; mark++) {
2212 if (SvTEMP(*mark))
2213 /* empty */ ;
2214 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2215 *mark = sv_mortalcopy(*mark);
2216 else {
2217 /* Can be a localized value subject to deletion. */
2218 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2219 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2220 }
2221 }
2222 }
2223 }
2224 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2225 /* Here we go for robustness, not for speed, so we change all
2226 * the refcounts so the caller gets a live guy. Cannot set
2227 * TEMP, so sv_2mortal is out of question. */
a8bba7fa 2228 if (!CvLVALUE(cx->blk_sub.cv)) {
b0d9ce38 2229 POPSUB(cx,sv);
d470f89e 2230 PL_curpm = newpm;
b0d9ce38
GS
2231 LEAVE;
2232 LEAVESUB(sv);
d470f89e
GS
2233 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2234 }
cd06dffe
GS
2235 if (gimme == G_SCALAR) {
2236 MARK = newsp + 1;
2237 EXTEND_MORTAL(1);
2238 if (MARK == SP) {
d470f89e 2239 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
b0d9ce38 2240 POPSUB(cx,sv);
d470f89e 2241 PL_curpm = newpm;
b0d9ce38
GS
2242 LEAVE;
2243 LEAVESUB(sv);
d470f89e 2244 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
cd06dffe 2245 SvREADONLY(TOPs) ? "readonly value" : "temporary");
d470f89e 2246 }
cd06dffe
GS
2247 else { /* Can be a localized value
2248 * subject to deletion. */
2249 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2250 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2251 }
2252 }
d470f89e 2253 else { /* Should not happen? */
b0d9ce38 2254 POPSUB(cx,sv);
d470f89e 2255 PL_curpm = newpm;
b0d9ce38
GS
2256 LEAVE;
2257 LEAVESUB(sv);
d470f89e 2258 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
cd06dffe 2259 (MARK > SP ? "Empty array" : "Array"));
d470f89e 2260 }
cd06dffe
GS
2261 SP = MARK;
2262 }
2263 else if (gimme == G_ARRAY) {
2264 EXTEND_MORTAL(SP - newsp);
2265 for (mark = newsp + 1; mark <= SP; mark++) {
d470f89e
GS
2266 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2267 /* Might be flattened array after $#array = */
2268 PUTBACK;
b0d9ce38 2269 POPSUB(cx,sv);
d470f89e 2270 PL_curpm = newpm;
b0d9ce38
GS
2271 LEAVE;
2272 LEAVESUB(sv);
d470f89e 2273 DIE(aTHX_ "Can't return %s from lvalue subroutine",
cd06dffe
GS
2274 (*mark != &PL_sv_undef)
2275 ? (SvREADONLY(TOPs)
2276 ? "a readonly value" : "a temporary")
2277 : "an uninitialized value");
d470f89e 2278 }
cd06dffe 2279 else {
cd06dffe
GS
2280 /* Can be a localized value subject to deletion. */
2281 PL_tmps_stack[++PL_tmps_ix] = *mark;
e1f15930 2282 (void)SvREFCNT_inc(*mark);
cd06dffe
GS
2283 }
2284 }
2285 }
2286 }
2287 else {
2288 if (gimme == G_SCALAR) {
2289 temporise:
2290 MARK = newsp + 1;
2291 if (MARK <= SP) {
a8bba7fa 2292 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
cd06dffe
GS
2293 if (SvTEMP(TOPs)) {
2294 *MARK = SvREFCNT_inc(TOPs);
2295 FREETMPS;
2296 sv_2mortal(*MARK);
2297 }
2298 else {
959e3673 2299 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
cd06dffe 2300 FREETMPS;
959e3673
GS
2301 *MARK = sv_mortalcopy(sv);
2302 SvREFCNT_dec(sv);
cd06dffe
GS
2303 }
2304 }
2305 else
2306 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2307 }
2308 else {
2309 MEXTEND(MARK, 0);
2310 *MARK = &PL_sv_undef;
2311 }
2312 SP = MARK;
2313 }
2314 else if (gimme == G_ARRAY) {
2315 temporise_array:
2316 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2317 if (!SvTEMP(*MARK)) {
2318 *MARK = sv_mortalcopy(*MARK);
2319 TAINT_NOT; /* Each item is independent */
2320 }
2321 }
2322 }
2323 }
2324 PUTBACK;
1c846c1f 2325
b0d9ce38 2326 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
cd06dffe
GS
2327 PL_curpm = newpm; /* ... and pop $1 et al */
2328
2329 LEAVE;
b0d9ce38 2330 LEAVESUB(sv);
cd06dffe
GS
2331 return pop_return();
2332}
2333
2334
76e3520e 2335STATIC CV *
cea2e8a9 2336S_get_db_sub(pTHX_ SV **svp, CV *cv)
3de9ffa1 2337{
3280af22 2338 SV *dbsv = GvSV(PL_DBsub);
491527d0
GS
2339
2340 if (!PERLDB_SUB_NN) {
2341 GV *gv = CvGV(cv);
2342
2343 save_item(dbsv);
2344 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1c846c1f 2345 || strEQ(GvNAME(gv), "END")
491527d0
GS
2346 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2347 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2348 && (gv = (GV*)*svp) ))) {
2349 /* Use GV from the stack as a fallback. */
2350 /* GV is potentially non-unique, or contain different CV. */
c2e66d9e
GS
2351 SV *tmp = newRV((SV*)cv);
2352 sv_setsv(dbsv, tmp);
2353 SvREFCNT_dec(tmp);
491527d0
GS
2354 }
2355 else {
2356 gv_efullname3(dbsv, gv, Nullch);
2357 }
3de9ffa1
MB
2358 }
2359 else {
155aba94
GS
2360 (void)SvUPGRADE(dbsv, SVt_PVIV);
2361 (void)SvIOK_on(dbsv);
491527d0 2362 SAVEIV(SvIVX(dbsv));
5bc28da9 2363 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
3de9ffa1 2364 }
491527d0 2365
3de9ffa1 2366 if (CvXSUB(cv))
3280af22
NIS
2367 PL_curcopdb = PL_curcop;
2368 cv = GvCV(PL_DBsub);
3de9ffa1
MB
2369 return cv;
2370}
2371
a0d0e21e
LW
2372PP(pp_entersub)
2373{
4e35701f 2374 djSP; dPOPss;
a0d0e21e
LW
2375 GV *gv;
2376 HV *stash;
2377 register CV *cv;
c09156bb 2378 register PERL_CONTEXT *cx;
5d94fbed 2379 I32 gimme;
533c011a 2380 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
a0d0e21e
LW
2381
2382 if (!sv)
cea2e8a9 2383 DIE(aTHX_ "Not a CODE reference");
a0d0e21e
LW
2384 switch (SvTYPE(sv)) {
2385 default:
2386 if (!SvROK(sv)) {
748a9306 2387 char *sym;
2d8e6c8d 2388 STRLEN n_a;
748a9306 2389
3280af22 2390 if (sv == &PL_sv_yes) { /* unfound import, ignore */
fb73857a 2391 if (hasargs)
3280af22 2392 SP = PL_stack_base + POPMARK;
a0d0e21e 2393 RETURN;
fb73857a 2394 }
15ff848f
CS
2395 if (SvGMAGICAL(sv)) {
2396 mg_get(sv);
2397 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2398 }
2399 else
2d8e6c8d 2400 sym = SvPV(sv, n_a);
15ff848f 2401 if (!sym)
cea2e8a9 2402 DIE(aTHX_ PL_no_usym, "a subroutine");
533c011a 2403 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 2404 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
864dbfa3 2405 cv = get_cv(sym, TRUE);
a0d0e21e
LW
2406 break;
2407 }
f5284f61
IZ
2408 {
2409 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2410 tryAMAGICunDEREF(to_cv);
2411 }
a0d0e21e
LW
2412 cv = (CV*)SvRV(sv);
2413 if (SvTYPE(cv) == SVt_PVCV)
2414 break;
2415 /* FALL THROUGH */
2416 case SVt_PVHV:
2417 case SVt_PVAV:
cea2e8a9 2418 DIE(aTHX_ "Not a CODE reference");
a0d0e21e
LW
2419 case SVt_PVCV:
2420 cv = (CV*)sv;
2421 break;
2422 case SVt_PVGV:
8ebc5c01 2423 if (!(cv = GvCVu((GV*)sv)))
f6ec51f7
GS
2424 cv = sv_2cv(sv, &stash, &gv, FALSE);
2425 if (!cv) {
2426 ENTER;
2427 SAVETMPS;
2428 goto try_autoload;
2429 }
2430 break;
a0d0e21e
LW
2431 }
2432
2433 ENTER;
2434 SAVETMPS;
2435
2436 retry:
a0d0e21e 2437 if (!CvROOT(cv) && !CvXSUB(cv)) {
44a8e56a 2438 GV* autogv;
22239a37 2439 SV* sub_name;
44a8e56a
PP
2440
2441 /* anonymous or undef'd function leaves us no recourse */
2442 if (CvANON(cv) || !(gv = CvGV(cv)))
cea2e8a9 2443 DIE(aTHX_ "Undefined subroutine called");
67caa1fe 2444
44a8e56a
PP
2445 /* autoloaded stub? */
2446 if (cv != GvCV(gv)) {
2447 cv = GvCV(gv);
a0d0e21e 2448 }
44a8e56a 2449 /* should call AUTOLOAD now? */
67caa1fe 2450 else {
f6ec51f7
GS
2451try_autoload:
2452 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2453 FALSE)))
2454 {
2455 cv = GvCV(autogv);
2456 }
2457 /* sorry */
2458 else {
2459 sub_name = sv_newmortal();
2460 gv_efullname3(sub_name, gv, Nullch);
cea2e8a9 2461 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
f6ec51f7 2462 }
67caa1fe
GS
2463 }
2464 if (!cv)
cea2e8a9 2465 DIE(aTHX_ "Not a CODE reference");
67caa1fe 2466 goto retry;
a0d0e21e
LW
2467 }
2468
54310121 2469 gimme = GIMME_V;
67caa1fe 2470 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
4f01c5a5 2471 cv = get_db_sub(&sv, cv);
67caa1fe 2472 if (!cv)
cea2e8a9 2473 DIE(aTHX_ "No DBsub routine");
67caa1fe 2474 }
a0d0e21e 2475
11343788 2476#ifdef USE_THREADS
3de9ffa1
MB
2477 /*
2478 * First we need to check if the sub or method requires locking.
458fb581
MB
2479 * If so, we gain a lock on the CV, the first argument or the
2480 * stash (for static methods), as appropriate. This has to be
2481 * inline because for FAKE_THREADS, COND_WAIT inlines code to
2482 * reschedule by returning a new op.
3de9ffa1 2483 */
11343788 2484 MUTEX_LOCK(CvMUTEXP(cv));
77a005ab
MB
2485 if (CvFLAGS(cv) & CVf_LOCKED) {
2486 MAGIC *mg;
2487 if (CvFLAGS(cv) & CVf_METHOD) {
533c011a
NIS
2488 if (SP > PL_stack_base + TOPMARK)
2489 sv = *(PL_stack_base + TOPMARK + 1);
77a005ab 2490 else {
13e08037
GS
2491 AV *av = (AV*)PL_curpad[0];
2492 if (hasargs || !av || AvFILLp(av) < 0
2493 || !(sv = AvARRAY(av)[0]))
2494 {
2495 MUTEX_UNLOCK(CvMUTEXP(cv));
d470f89e 2496 DIE(aTHX_ "no argument for locked method call");
13e08037 2497 }
77a005ab
MB
2498 }
2499 if (SvROK(sv))
2500 sv = SvRV(sv);
458fb581
MB
2501 else {
2502 STRLEN len;
2503 char *stashname = SvPV(sv, len);
2504 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2505 }
77a005ab
MB
2506 }
2507 else {
2508 sv = (SV*)cv;
2509 }
2510 MUTEX_UNLOCK(CvMUTEXP(cv));
2511 mg = condpair_magic(sv);
2512 MUTEX_LOCK(MgMUTEXP(mg));
2513 if (MgOWNER(mg) == thr)
2514 MUTEX_UNLOCK(MgMUTEXP(mg));
2515 else {
2516 while (MgOWNER(mg))
2517 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2518 MgOWNER(mg) = thr;
bf49b057 2519 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
1fd28e87 2520 thr, sv);)
77a005ab 2521 MUTEX_UNLOCK(MgMUTEXP(mg));
c76ac1ee 2522 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
11343788 2523 }
77a005ab 2524 MUTEX_LOCK(CvMUTEXP(cv));
11343788 2525 }
3de9ffa1
MB
2526 /*
2527 * Now we have permission to enter the sub, we must distinguish
2528 * four cases. (0) It's an XSUB (in which case we don't care
2529 * about ownership); (1) it's ours already (and we're recursing);
2530 * (2) it's free (but we may already be using a cached clone);
2531 * (3) another thread owns it. Case (1) is easy: we just use it.
2532 * Case (2) means we look for a clone--if we have one, use it
2533 * otherwise grab ownership of cv. Case (3) means we look for a
2534 * clone (for non-XSUBs) and have to create one if we don't
2535 * already have one.
2536 * Why look for a clone in case (2) when we could just grab
2537 * ownership of cv straight away? Well, we could be recursing,
2538 * i.e. we originally tried to enter cv while another thread
2539 * owned it (hence we used a clone) but it has been freed up
2540 * and we're now recursing into it. It may or may not be "better"
2541 * to use the clone but at least CvDEPTH can be trusted.
2542 */
2543 if (CvOWNER(cv) == thr || CvXSUB(cv))
2544 MUTEX_UNLOCK(CvMUTEXP(cv));
11343788 2545 else {
3de9ffa1
MB
2546 /* Case (2) or (3) */
2547 SV **svp;
2548
11343788 2549 /*
3de9ffa1
MB
2550 * XXX Might it be better to release CvMUTEXP(cv) while we
2551 * do the hv_fetch? We might find someone has pinched it
2552 * when we look again, in which case we would be in case
2553 * (3) instead of (2) so we'd have to clone. Would the fact
2554 * that we released the mutex more quickly make up for this?
2555 */
b099ddc0 2556 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
6ee623d5 2557 {
3de9ffa1 2558 /* We already have a clone to use */
11343788 2559 MUTEX_UNLOCK(CvMUTEXP(cv));
3de9ffa1 2560 cv = *(CV**)svp;
bf49b057 2561 DEBUG_S(PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2562 "entersub: %p already has clone %p:%s\n",
2563 thr, cv, SvPEEK((SV*)cv)));
3de9ffa1
MB
2564 CvOWNER(cv) = thr;
2565 SvREFCNT_inc(cv);
2566 if (CvDEPTH(cv) == 0)
c76ac1ee 2567 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
3de9ffa1 2568 }
11343788 2569 else {
3de9ffa1
MB
2570 /* (2) => grab ownership of cv. (3) => make clone */
2571 if (!CvOWNER(cv)) {
2572 CvOWNER(cv) = thr;
2573 SvREFCNT_inc(cv);
11343788 2574 MUTEX_UNLOCK(CvMUTEXP(cv));
bf49b057 2575 DEBUG_S(PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2576 "entersub: %p grabbing %p:%s in stash %s\n",
2577 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
3de9ffa1 2578 HvNAME(CvSTASH(cv)) : "(none)"));
cd06dffe
GS
2579 }
2580 else {
3de9ffa1
MB
2581 /* Make a new clone. */
2582 CV *clonecv;
2583 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2584 MUTEX_UNLOCK(CvMUTEXP(cv));
bf49b057 2585 DEBUG_S((PerlIO_printf(Perl_debug_log,
1fd28e87
MB
2586 "entersub: %p cloning %p:%s\n",
2587 thr, cv, SvPEEK((SV*)cv))));
3de9ffa1
MB
2588 /*
2589 * We're creating a new clone so there's no race
2590 * between the original MUTEX_UNLOCK and the
2591 * SvREFCNT_inc since no one will be trying to undef
2592 * it out from underneath us. At least, I don't think
2593 * there's a race...
2594 */
2595 clonecv = cv_clone(cv);
2596 SvREFCNT_dec(cv); /* finished with this */
199100c8 2597 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
3de9ffa1
MB
2598 CvOWNER(clonecv) = thr;
2599 cv = clonecv;
11343788 2600 SvREFCNT_inc(cv);
11343788 2601 }
8b73bbec 2602 DEBUG_S(if (CvDEPTH(cv) != 0)
bf49b057 2603 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3de9ffa1 2604 CvDEPTH(cv)););
c76ac1ee 2605 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
11343788 2606 }
3de9ffa1 2607 }
11343788
MB
2608#endif /* USE_THREADS */
2609
a0d0e21e 2610 if (CvXSUB(cv)) {
67caa1fe 2611#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2612 if (CvOLDSTYLE(cv)) {
20ce7b12 2613 I32 (*fp3)(int,int,int);
a0d0e21e
LW
2614 dMARK;
2615 register I32 items = SP - MARK;
67955e0c 2616 /* We dont worry to copy from @_. */
924508f0
GS
2617 while (SP > mark) {
2618 SP[1] = SP[0];
2619 SP--;
a0d0e21e 2620 }
3280af22 2621 PL_stack_sp = mark + 1;
1d7c1841 2622 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
1c846c1f 2623 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2624 MARK - PL_stack_base + 1,
ecfc5424 2625 items);
3280af22 2626 PL_stack_sp = PL_stack_base + items;
a0d0e21e 2627 }
67caa1fe
GS
2628 else
2629#endif /* PERL_XSUB_OLDSTYLE */
2630 {
748a9306
LW
2631 I32 markix = TOPMARK;
2632
a0d0e21e 2633 PUTBACK;
67955e0c
PP
2634
2635 if (!hasargs) {
2636 /* Need to copy @_ to stack. Alternative may be to
2637 * switch stack to @_, and copy return values
2638 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
6d4ff0d2
MB
2639 AV* av;
2640 I32 items;
2641#ifdef USE_THREADS
533c011a 2642 av = (AV*)PL_curpad[0];
6d4ff0d2 2643#else
3280af22 2644 av = GvAV(PL_defgv);
6d4ff0d2 2645#endif /* USE_THREADS */
93965878 2646 items = AvFILLp(av) + 1; /* @_ is not tieable */
67955e0c
PP
2647
2648 if (items) {
2649 /* Mark is at the end of the stack. */
924508f0
GS
2650 EXTEND(SP, items);
2651 Copy(AvARRAY(av), SP + 1, items, SV*);
2652 SP += items;
1c846c1f 2653 PUTBACK ;
67955e0c
PP
2654 }
2655 }
67caa1fe
GS
2656 /* We assume first XSUB in &DB::sub is the called one. */
2657 if (PL_curcopdb) {
1d7c1841 2658 SAVEVPTR(PL_curcop);
3280af22
NIS
2659 PL_curcop = PL_curcopdb;
2660 PL_curcopdb = NULL;
67955e0c
PP
2661 }
2662 /* Do we need to open block here? XXXX */
0cb96387 2663 (void)(*CvXSUB(cv))(aTHXo_ cv);
748a9306
LW
2664
2665 /* Enforce some sanity in scalar context. */
3280af22
NIS
2666 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2667 if (markix > PL_stack_sp - PL_stack_base)
2668 *(PL_stack_base + markix) = &PL_sv_undef;
748a9306 2669 else
3280af22
NIS
2670 *(PL_stack_base + markix) = *PL_stack_sp;
2671 PL_stack_sp = PL_stack_base + markix;
748a9306 2672 }
a0d0e21e
LW
2673 }
2674 LEAVE;
2675 return NORMAL;
2676 }
2677 else {
2678 dMARK;
2679 register I32 items = SP - MARK;
a0d0e21e
LW
2680 AV* padlist = CvPADLIST(cv);
2681 SV** svp = AvARRAY(padlist);
533c011a 2682 push_return(PL_op->op_next);
a0d0e21e
LW
2683 PUSHBLOCK(cx, CXt_SUB, MARK);
2684 PUSHSUB(cx);
2685 CvDEPTH(cv)++;
6b35e009
GS
2686 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2687 * that eval'' ops within this sub know the correct lexical space.
2688 * Owing the speed considerations, we choose to search for the cv
2689 * in doeval() instead.
2690 */
a0d0e21e
LW
2691 if (CvDEPTH(cv) < 2)
2692 (void)SvREFCNT_inc(cv);
2693 else { /* save temporaries on recursion? */
1d7c1841 2694 PERL_STACK_OVERFLOW_CHECK();
93965878 2695 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e
LW
2696 AV *av;
2697 AV *newpad = newAV();
4aa0a1f7 2698 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2699 I32 ix = AvFILLp((AV*)svp[1]);
1d7c1841 2700 I32 names_fill = AvFILLp((AV*)svp[0]);
a0d0e21e 2701 svp = AvARRAY(svp[0]);
748a9306 2702 for ( ;ix > 0; ix--) {
1d7c1841 2703 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
748a9306 2704 char *name = SvPVX(svp[ix]);
5f05dabc
PP
2705 if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2706 || *name == '&') /* anonymous code? */
2707 {
2708 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
748a9306
LW
2709 }
2710 else { /* our own lexical */
2711 if (*name == '@')
2712 av_store(newpad, ix, sv = (SV*)newAV());
2713 else if (*name == '%')
2714 av_store(newpad, ix, sv = (SV*)newHV());
2715 else
2716 av_store(newpad, ix, sv = NEWSV(0,0));
2717 SvPADMY_on(sv);
2718 }
a0d0e21e 2719 }
1d7c1841
GS
2720 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2721 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2722 }
a0d0e21e 2723 else {
748a9306 2724 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW
2725 SvPADTMP_on(sv);
2726 }
2727 }
2728 av = newAV(); /* will be @_ */
2729 av_extend(av, 0);
2730 av_store(newpad, 0, (SV*)av);
2731 AvFLAGS(av) = AVf_REIFY;
2732 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2733 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW
2734 svp = AvARRAY(padlist);
2735 }
2736 }
6d4ff0d2
MB
2737#ifdef USE_THREADS
2738 if (!hasargs) {
533c011a 2739 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2740
93965878 2741 items = AvFILLp(av) + 1;
6d4ff0d2
MB
2742 if (items) {
2743 /* Mark is at the end of the stack. */
924508f0
GS
2744 EXTEND(SP, items);
2745 Copy(AvARRAY(av), SP + 1, items, SV*);
2746 SP += items;
1c846c1f 2747 PUTBACK ;
6d4ff0d2
MB
2748 }
2749 }
2750#endif /* USE_THREADS */
1d7c1841 2751 SAVEVPTR(PL_curpad);
3280af22 2752 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB
2753#ifndef USE_THREADS
2754 if (hasargs)
2755#endif /* USE_THREADS */
2756 {
2757 AV* av;
a0d0e21e
LW
2758 SV** ary;
2759
77a005ab 2760#if 0
bf49b057 2761 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2762 "%p entersub preparing @_\n", thr));
77a005ab 2763#endif
3280af22 2764 av = (AV*)PL_curpad[0];
221373f0
GS
2765 if (AvREAL(av)) {
2766 /* @_ is normally not REAL--this should only ever
2767 * happen when DB::sub() calls things that modify @_ */
2768 av_clear(av);
2769 AvREAL_off(av);
2770 AvREIFY_on(av);
2771 }
6d4ff0d2 2772#ifndef USE_THREADS
3280af22
NIS
2773 cx->blk_sub.savearray = GvAV(PL_defgv);
2774 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2 2775#endif /* USE_THREADS */
7032098e 2776 cx->blk_sub.oldcurpad = PL_curpad;
6d4ff0d2 2777 cx->blk_sub.argarray = av;
a0d0e21e
LW
2778 ++MARK;
2779
2780 if (items > AvMAX(av) + 1) {
2781 ary = AvALLOC(av);
2782 if (AvARRAY(av) != ary) {
2783 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2784 SvPVX(av) = (char*)ary;
2785 }
2786 if (items > AvMAX(av) + 1) {
2787 AvMAX(av) = items - 1;
2788 Renew(ary,items,SV*);
2789 AvALLOC(av) = ary;
2790 SvPVX(av) = (char*)ary;
2791 }
2792 }
2793 Copy(MARK,AvARRAY(av),items,SV*);
93965878 2794 AvFILLp(av) = items - 1;
1c846c1f 2795
a0d0e21e
LW
2796 while (items--) {
2797 if (*MARK)
2798 SvTEMP_off(*MARK);
2799 MARK++;
2800 }
2801 }
4a925ff6
GS
2802 /* warning must come *after* we fully set up the context
2803 * stuff so that __WARN__ handlers can safely dounwind()
2804 * if they want to
2805 */
2806 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2807 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2808 sub_crush_depth(cv);
77a005ab 2809#if 0
bf49b057 2810 DEBUG_S(PerlIO_printf(Perl_debug_log,
0f15f207 2811 "%p entersub returning %p\n", thr, CvSTART(cv)));
77a005ab 2812#endif
a0d0e21e
LW
2813 RETURNOP(CvSTART(cv));
2814 }
2815}
2816
44a8e56a 2817void
864dbfa3 2818Perl_sub_crush_depth(pTHX_ CV *cv)
44a8e56a
PP
2819{
2820 if (CvANON(cv))
cea2e8a9 2821 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
44a8e56a
PP
2822 else {
2823 SV* tmpstr = sv_newmortal();
2824 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1c846c1f 2825 Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
599cee73 2826 SvPVX(tmpstr));
44a8e56a
PP
2827 }
2828}
2829
a0d0e21e
LW
2830PP(pp_aelem)
2831{
4e35701f 2832 djSP;
a0d0e21e 2833 SV** svp;
d804643f
SC
2834 SV* elemsv = POPs;
2835 IV elem = SvIV(elemsv);
68dc0745 2836 AV* av = (AV*)POPs;
533c011a
NIS
2837 U32 lval = PL_op->op_flags & OPf_MOD;
2838 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
be6c24e0 2839 SV *sv;
a0d0e21e 2840
d804643f
SC
2841 if (SvROK(elemsv) && ckWARN(WARN_MISC))
2842 Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
748a9306 2843 if (elem > 0)
3280af22 2844 elem -= PL_curcop->cop_arybase;
a0d0e21e
LW
2845 if (SvTYPE(av) != SVt_PVAV)
2846 RETPUSHUNDEF;
68dc0745 2847 svp = av_fetch(av, elem, lval && !defer);
a0d0e21e 2848 if (lval) {
3280af22 2849 if (!svp || *svp == &PL_sv_undef) {
68dc0745
PP
2850 SV* lv;
2851 if (!defer)
cea2e8a9 2852 DIE(aTHX_ PL_no_aelem, elem);
68dc0745
PP
2853 lv = sv_newmortal();
2854 sv_upgrade(lv, SVt_PVLV);
2855 LvTYPE(lv) = 'y';
2856 sv_magic(lv, Nullsv, 'y', Nullch, 0);
2857 LvTARG(lv) = SvREFCNT_inc(av);
2858 LvTARGOFF(lv) = elem;
2859 LvTARGLEN(lv) = 1;
2860 PUSHs(lv);
2861 RETURN;
2862 }
533c011a 2863 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2864 save_aelem(av, elem, svp);
533c011a
NIS
2865 else if (PL_op->op_private & OPpDEREF)
2866 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
a0d0e21e 2867 }
3280af22 2868 sv = (svp ? *svp : &PL_sv_undef);
be6c24e0
GS
2869 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2870 sv = sv_mortalcopy(sv);
2871 PUSHs(sv);
a0d0e21e
LW
2872 RETURN;
2873}
2874
02a9e968 2875void
864dbfa3 2876Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
02a9e968
CS
2877{
2878 if (SvGMAGICAL(sv))
2879 mg_get(sv);
2880 if (!SvOK(sv)) {
2881 if (SvREADONLY(sv))
cea2e8a9 2882 Perl_croak(aTHX_ PL_no_modify);
5f05dabc
PP
2883 if (SvTYPE(sv) < SVt_RV)
2884 sv_upgrade(sv, SVt_RV);
2885 else if (SvTYPE(sv) >= SVt_PV) {
2886 (void)SvOOK_off(sv);
2887 Safefree(SvPVX(sv));
2888 SvLEN(sv) = SvCUR(sv) = 0;
2889 }
68dc0745 2890 switch (to_what) {
5f05dabc 2891 case OPpDEREF_SV:
8c52afec 2892 SvRV(sv) = NEWSV(355,0);
5f05dabc
PP
2893 break;
2894 case OPpDEREF_AV:
2895 SvRV(sv) = (SV*)newAV();
2896 break;
2897 case OPpDEREF_HV:
2898 SvRV(sv) = (SV*)newHV();
2899 break;
2900 }
02a9e968
CS
2901 SvROK_on(sv);
2902 SvSETMAGIC(sv);
2903 }
2904}
2905
a0d0e21e
LW
2906PP(pp_method)
2907{
4e35701f 2908 djSP;
f5d5a27c
CS
2909 SV* sv = TOPs;
2910
2911 if (SvROK(sv)) {
eda383f2 2912 SV* rsv = SvRV(sv);
f5d5a27c
CS
2913 if (SvTYPE(rsv) == SVt_PVCV) {
2914 SETs(rsv);
2915 RETURN;
2916 }
2917 }
2918
2919 SETs(method_common(sv, Null(U32*)));
2920 RETURN;
2921}
2922
2923PP(pp_method_named)
2924{
2925 djSP;
2926 SV* sv = cSVOP->op_sv;
2927 U32 hash = SvUVX(sv);
2928
2929 XPUSHs(method_common(sv, &hash));
2930 RETURN;
2931}
2932
2933STATIC SV *
2934S_method_common(pTHX_ SV* meth, U32* hashp)
2935{
a0d0e21e
LW
2936 SV* sv;
2937 SV* ob;
2938 GV* gv;
56304f61
CS
2939 HV* stash;
2940 char* name;
f5d5a27c 2941 STRLEN namelen;
ac91690f
CS
2942 char* packname;
2943 STRLEN packlen;
a0d0e21e 2944
f5d5a27c 2945 name = SvPV(meth, namelen);
3280af22 2946 sv = *(PL_stack_base + TOPMARK + 1);
f5d5a27c 2947
4f1b7578
SC
2948 if (!sv)
2949 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2950
16d20bd9
AD
2951 if (SvGMAGICAL(sv))
2952 mg_get(sv);
a0d0e21e 2953 if (SvROK(sv))
16d20bd9 2954 ob = (SV*)SvRV(sv);
a0d0e21e
LW
2955 else {
2956 GV* iogv;
a0d0e21e 2957
56304f61 2958 packname = Nullch;
a0d0e21e 2959 if (!SvOK(sv) ||
56304f61 2960 !(packname = SvPV(sv, packlen)) ||
a0d0e21e
LW
2961 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2962 !(ob=(SV*)GvIO(iogv)))
2963 {
1c846c1f 2964 if (!packname ||
7e2040f0 2965 ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
b86a2fa7 2966 ? !isIDFIRST_utf8((U8*)packname)
834a4ddd
LW
2967 : !isIDFIRST(*packname)
2968 ))
2969 {
f5d5a27c
CS
2970 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2971 SvOK(sv) ? "without a package or object reference"
2972 : "on an undefined value");
834a4ddd 2973 }
56304f61 2974 stash = gv_stashpvn(packname, packlen, TRUE);
ac91690f 2975 goto fetch;
a0d0e21e 2976 }
3280af22 2977 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
a0d0e21e
LW
2978 }
2979
f0d43078
GS
2980 if (!ob || !(SvOBJECT(ob)
2981 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2982 && SvOBJECT(ob))))
2983 {
f5d5a27c
CS
2984 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2985 name);
f0d43078 2986 }
a0d0e21e 2987
56304f61 2988 stash = SvSTASH(ob);
a0d0e21e 2989
ac91690f 2990 fetch:
f5d5a27c
CS
2991 /* shortcut for simple names */
2992 if (hashp) {
2993 HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
2994 if (he) {
2995 gv = (GV*)HeVAL(he);
2996 if (isGV(gv) && GvCV(gv) &&
2997 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
2998 return (SV*)GvCV(gv);
2999 }
3000 }
3001
ac91690f 3002 gv = gv_fetchmethod(stash, name);
56304f61
CS
3003 if (!gv) {
3004 char* leaf = name;
3005 char* sep = Nullch;
3006 char* p;
c1899e02 3007 GV* gv;
56304f61
CS
3008
3009 for (p = name; *p; p++) {
3010 if (*p == '\'')
3011 sep = p, leaf = p + 1;
3012 else if (*p == ':' && *(p + 1) == ':')
3013 sep = p, leaf = p + 2;
3014 }
3015 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
1d7c1841 3016 packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
56304f61
CS
3017 packlen = strlen(packname);
3018 }
3019 else {
3020 packname = name;
3021 packlen = sep - name;
3022 }
c1899e02
GS
3023 gv = gv_fetchpv(packname, 0, SVt_PVHV);
3024 if (gv && isGV(gv)) {
3025 Perl_croak(aTHX_
3026 "Can't locate object method \"%s\" via package \"%s\"",
3027 leaf, packname);
3028 }
3029 else {
3030 Perl_croak(aTHX_
f6e565ef 3031 "Can't locate object method \"%s\" via package \"%s\""
c1899e02
GS
3032 " (perhaps you forgot to load \"%s\"?)",
3033 leaf, packname, packname);
3034 }
56304f61 3035 }
f5d5a27c 3036 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
a0d0e21e 3037}
22239a37 3038
51371543
GS
3039#ifdef USE_THREADS
3040static void
3041unset_cvowner(pTHXo_ void *cvarg)
3042{
3043 register CV* cv = (CV *) cvarg;
51371543 3044
bf49b057 3045 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
51371543
GS
3046 thr, cv, SvPEEK((SV*)cv))));
3047 MUTEX_LOCK(CvMUTEXP(cv));
3048 DEBUG_S(if (CvDEPTH(cv) != 0)
bf49b057 3049 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
51371543
GS
3050 CvDEPTH(cv)););
3051 assert(thr == CvOWNER(cv));
3052 CvOWNER(cv) = 0;
3053 MUTEX_UNLOCK(CvMUTEXP(cv));
3054 SvREFCNT_dec(cv);
3055}
3056#endif /* USE_THREADS */