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