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