3 * Copyright (c) 1991-2001, Larry Wall
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.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 /* #define PL_OP_SLAB_ALLOC */
25 #ifdef PL_OP_SLAB_ALLOC
26 #define SLAB_SIZE 8192
27 static char *PL_OpPtr = NULL;
28 static int PL_OpSpace = 0;
29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
30 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
32 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
36 S_Slab_Alloc(pTHX_ int m, size_t sz)
38 Newz(m,PL_OpPtr,SLAB_SIZE,char);
39 PL_OpSpace = SLAB_SIZE - sz;
40 return PL_OpPtr += PL_OpSpace;
44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
47 * In the following definition, the ", Nullop" is just to make the compiler
48 * think the expression is of the right type: croak actually does a Siglongjmp.
50 #define CHECKOP(type,o) \
51 ((PL_op_mask && PL_op_mask[type]) \
52 ? ( op_free((OP*)o), \
53 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
55 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
57 #define PAD_MAX 999999999
58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
61 S_gv_ename(pTHX_ GV *gv)
64 SV* tmpsv = sv_newmortal();
65 gv_efullname3(tmpsv, gv, Nullch);
66 return SvPV(tmpsv,n_a);
70 S_no_fh_allowed(pTHX_ OP *o)
72 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
73 PL_op_desc[o->op_type]));
78 S_too_few_arguments(pTHX_ OP *o, char *name)
80 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
85 S_too_many_arguments(pTHX_ OP *o, char *name)
87 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
94 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
95 (int)n, name, t, PL_op_desc[kid->op_type]));
99 S_no_bareword_allowed(pTHX_ OP *o)
101 qerror(Perl_mess(aTHX_
102 "Bareword \"%s\" not allowed while \"strict subs\" in use",
103 SvPV_nolen(cSVOPo_sv)));
106 /* "register" allocation */
109 Perl_pad_allocmy(pTHX_ char *name)
114 if (!(PL_in_my == KEY_our ||
116 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
117 (name[1] == '_' && (int)strlen(name) > 2)))
119 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
120 /* 1999-02-27 mjd@plover.com */
122 p = strchr(name, '\0');
123 /* The next block assumes the buffer is at least 205 chars
124 long. At present, it's always at least 256 chars. */
126 strcpy(name+200, "...");
132 /* Move everything else down one character */
133 for (; p-name > 2; p--)
135 name[2] = toCTRL(name[1]);
138 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
140 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
141 SV **svp = AvARRAY(PL_comppad_name);
142 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
143 PADOFFSET top = AvFILLp(PL_comppad_name);
144 for (off = top; off > PL_comppad_name_floor; off--) {
146 && sv != &PL_sv_undef
147 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
148 && (PL_in_my != KEY_our
149 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
150 && strEQ(name, SvPVX(sv)))
152 Perl_warner(aTHX_ WARN_MISC,
153 "\"%s\" variable %s masks earlier declaration in same %s",
154 (PL_in_my == KEY_our ? "our" : "my"),
156 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
161 if (PL_in_my == KEY_our) {
164 && sv != &PL_sv_undef
165 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
166 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
167 && strEQ(name, SvPVX(sv)))
169 Perl_warner(aTHX_ WARN_MISC,
170 "\"our\" variable %s redeclared", name);
171 Perl_warner(aTHX_ WARN_MISC,
172 "\t(Did you mean \"local\" instead of \"our\"?)\n");
175 } while ( off-- > 0 );
178 off = pad_alloc(OP_PADSV, SVs_PADMY);
180 sv_upgrade(sv, SVt_PVNV);
182 if (PL_in_my_stash) {
184 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
185 name, PL_in_my == KEY_our ? "our" : "my"));
187 (void)SvUPGRADE(sv, SVt_PVMG);
188 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
191 if (PL_in_my == KEY_our) {
192 (void)SvUPGRADE(sv, SVt_PVGV);
193 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
194 SvFLAGS(sv) |= SVpad_OUR;
196 av_store(PL_comppad_name, off, sv);
197 SvNVX(sv) = (NV)PAD_MAX;
198 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
199 if (!PL_min_intro_pending)
200 PL_min_intro_pending = off;
201 PL_max_intro_pending = off;
203 av_store(PL_comppad, off, (SV*)newAV());
204 else if (*name == '%')
205 av_store(PL_comppad, off, (SV*)newHV());
206 SvPADMY_on(PL_curpad[off]);
211 S_pad_addlex(pTHX_ SV *proto_namesv)
213 SV *namesv = NEWSV(1103,0);
214 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
215 sv_upgrade(namesv, SVt_PVNV);
216 sv_setpv(namesv, SvPVX(proto_namesv));
217 av_store(PL_comppad_name, newoff, namesv);
218 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
219 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
220 SvFAKE_on(namesv); /* A ref, not a real var */
221 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
222 SvFLAGS(namesv) |= SVpad_OUR;
223 (void)SvUPGRADE(namesv, SVt_PVGV);
224 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
226 if (SvOBJECT(proto_namesv)) { /* A typed var */
228 (void)SvUPGRADE(namesv, SVt_PVMG);
229 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
235 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
238 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
239 I32 cx_ix, I32 saweval, U32 flags)
245 register PERL_CONTEXT *cx;
247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
252 if (!svp || *svp == &PL_sv_undef)
255 svp = AvARRAY(curname);
256 for (off = AvFILLp(curname); off > 0; off--) {
257 if ((sv = svp[off]) &&
258 sv != &PL_sv_undef &&
260 seq > I_32(SvNVX(sv)) &&
261 strEQ(SvPVX(sv), name))
272 return 0; /* don't clone from inactive stack frame */
276 oldpad = (AV*)AvARRAY(curlist)[depth];
277 oldsv = *av_fetch(oldpad, off, TRUE);
278 if (!newoff) { /* Not a mere clone operation. */
279 newoff = pad_addlex(sv);
280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
281 /* "It's closures all the way down." */
282 CvCLONE_on(PL_compcv);
284 if (CvANON(PL_compcv))
285 oldsv = Nullsv; /* no need to keep ref */
290 bcv && bcv != cv && !CvCLONE(bcv);
291 bcv = CvOUTSIDE(bcv))
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
314 Perl_warner(aTHX_ WARN_CLOSURE,
315 "Variable \"%s\" may be unavailable",
323 else if (!CvUNIQUE(PL_compcv)) {
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
327 Perl_warner(aTHX_ WARN_CLOSURE,
328 "Variable \"%s\" will not stay shared", name);
332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
338 if (flags & FINDLEX_NOSEARCH)
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
346 for (i = cx_ix; i >= 0; i--) {
348 switch (CxTYPE(cx)) {
350 if (i == 0 && saweval) {
351 seq = cxstack[saweval].blk_oldcop->cop_seq;
352 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
356 switch (cx->blk_eval.old_op_type) {
363 /* require/do must have their own scope */
372 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
373 saweval = i; /* so we know where we were called from */
376 seq = cxstack[saweval].blk_oldcop->cop_seq;
377 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
385 Perl_pad_findmy(pTHX_ char *name)
390 SV **svp = AvARRAY(PL_comppad_name);
391 U32 seq = PL_cop_seqmax;
397 * Special case to get lexical (and hence per-thread) @_.
398 * XXX I need to find out how to tell at parse-time whether use
399 * of @_ should refer to a lexical (from a sub) or defgv (global
400 * scope and maybe weird sub-ish things like formats). See
401 * startsub in perly.y. It's possible that @_ could be lexical
402 * (at least from subs) even in non-threaded perl.
404 if (strEQ(name, "@_"))
405 return 0; /* success. (NOT_IN_PAD indicates failure) */
406 #endif /* USE_THREADS */
408 /* The one we're looking for is probably just before comppad_name_fill. */
409 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
410 if ((sv = svp[off]) &&
411 sv != &PL_sv_undef &&
414 seq > I_32(SvNVX(sv)))) &&
415 strEQ(SvPVX(sv), name))
417 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
418 return (PADOFFSET)off;
419 pendoff = off; /* this pending def. will override import */
423 outside = CvOUTSIDE(PL_compcv);
425 /* Check if if we're compiling an eval'', and adjust seq to be the
426 * eval's seq number. This depends on eval'' having a non-null
427 * CvOUTSIDE() while it is being compiled. The eval'' itself is
428 * identified by CvEVAL being true and CvGV being null. */
429 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
430 cx = &cxstack[cxstack_ix];
432 seq = cx->blk_oldcop->cop_seq;
435 /* See if it's in a nested scope */
436 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
438 /* If there is a pending local definition, this new alias must die */
440 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
441 return off; /* pad_findlex returns 0 for failure...*/
443 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
447 Perl_pad_leavemy(pTHX_ I32 fill)
450 SV **svp = AvARRAY(PL_comppad_name);
452 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
453 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
454 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
455 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
458 /* "Deintroduce" my variables that are leaving with this scope. */
459 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
460 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
461 SvIVX(sv) = PL_cop_seqmax;
466 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
471 if (AvARRAY(PL_comppad) != PL_curpad)
472 Perl_croak(aTHX_ "panic: pad_alloc");
473 if (PL_pad_reset_pending)
475 if (tmptype & SVs_PADMY) {
477 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
478 } while (SvPADBUSY(sv)); /* need a fresh one */
479 retval = AvFILLp(PL_comppad);
482 SV **names = AvARRAY(PL_comppad_name);
483 SSize_t names_fill = AvFILLp(PL_comppad_name);
486 * "foreach" index vars temporarily become aliases to non-"my"
487 * values. Thus we must skip, not just pad values that are
488 * marked as current pad values, but also those with names.
490 if (++PL_padix <= names_fill &&
491 (sv = names[PL_padix]) && sv != &PL_sv_undef)
493 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
494 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
495 !IS_PADGV(sv) && !IS_PADCONST(sv))
500 SvFLAGS(sv) |= tmptype;
501 PL_curpad = AvARRAY(PL_comppad);
503 DEBUG_X(PerlIO_printf(Perl_debug_log,
504 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
505 PTR2UV(thr), PTR2UV(PL_curpad),
506 (long) retval, PL_op_name[optype]));
508 DEBUG_X(PerlIO_printf(Perl_debug_log,
509 "Pad 0x%"UVxf" alloc %ld for %s\n",
511 (long) retval, PL_op_name[optype]));
512 #endif /* USE_THREADS */
513 return (PADOFFSET)retval;
517 Perl_pad_sv(pTHX_ PADOFFSET po)
520 DEBUG_X(PerlIO_printf(Perl_debug_log,
521 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
522 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
525 Perl_croak(aTHX_ "panic: pad_sv po");
526 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
527 PTR2UV(PL_curpad), (IV)po));
528 #endif /* USE_THREADS */
529 return PL_curpad[po]; /* eventually we'll turn this into a macro */
533 Perl_pad_free(pTHX_ PADOFFSET po)
537 if (AvARRAY(PL_comppad) != PL_curpad)
538 Perl_croak(aTHX_ "panic: pad_free curpad");
540 Perl_croak(aTHX_ "panic: pad_free po");
542 DEBUG_X(PerlIO_printf(Perl_debug_log,
543 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
544 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
546 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
547 PTR2UV(PL_curpad), (IV)po));
548 #endif /* USE_THREADS */
549 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
550 SvPADTMP_off(PL_curpad[po]);
552 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
555 if ((I32)po < PL_padix)
560 Perl_pad_swipe(pTHX_ PADOFFSET po)
562 if (AvARRAY(PL_comppad) != PL_curpad)
563 Perl_croak(aTHX_ "panic: pad_swipe curpad");
565 Perl_croak(aTHX_ "panic: pad_swipe po");
567 DEBUG_X(PerlIO_printf(Perl_debug_log,
568 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
569 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
571 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
572 PTR2UV(PL_curpad), (IV)po));
573 #endif /* USE_THREADS */
574 SvPADTMP_off(PL_curpad[po]);
575 PL_curpad[po] = NEWSV(1107,0);
576 SvPADTMP_on(PL_curpad[po]);
577 if ((I32)po < PL_padix)
581 /* XXX pad_reset() is currently disabled because it results in serious bugs.
582 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
583 * on the stack by OPs that use them, there are several ways to get an alias
584 * to a shared TARG. Such an alias will change randomly and unpredictably.
585 * We avoid doing this until we can think of a Better Way.
590 #ifdef USE_BROKEN_PAD_RESET
593 if (AvARRAY(PL_comppad) != PL_curpad)
594 Perl_croak(aTHX_ "panic: pad_reset curpad");
596 DEBUG_X(PerlIO_printf(Perl_debug_log,
597 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
598 PTR2UV(thr), PTR2UV(PL_curpad)));
600 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
602 #endif /* USE_THREADS */
603 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
604 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
605 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
606 SvPADTMP_off(PL_curpad[po]);
608 PL_padix = PL_padix_floor;
611 PL_pad_reset_pending = FALSE;
615 /* find_threadsv is not reentrant */
617 Perl_find_threadsv(pTHX_ const char *name)
622 /* We currently only handle names of a single character */
623 p = strchr(PL_threadsv_names, *name);
626 key = p - PL_threadsv_names;
627 MUTEX_LOCK(&thr->mutex);
628 svp = av_fetch(thr->threadsv, key, FALSE);
630 MUTEX_UNLOCK(&thr->mutex);
632 SV *sv = NEWSV(0, 0);
633 av_store(thr->threadsv, key, sv);
634 thr->threadsvp = AvARRAY(thr->threadsv);
635 MUTEX_UNLOCK(&thr->mutex);
637 * Some magic variables used to be automagically initialised
638 * in gv_fetchpv. Those which are now per-thread magicals get
639 * initialised here instead.
645 sv_setpv(sv, "\034");
646 sv_magic(sv, 0, 0, name, 1);
651 PL_sawampersand = TRUE;
665 /* XXX %! tied to Errno.pm needs to be added here.
666 * See gv_fetchpv(). */
670 sv_magic(sv, 0, 0, name, 1);
672 DEBUG_S(PerlIO_printf(Perl_error_log,
673 "find_threadsv: new SV %p for $%s%c\n",
674 sv, (*name < 32) ? "^" : "",
675 (*name < 32) ? toCTRL(*name) : *name));
679 #endif /* USE_THREADS */
684 Perl_op_free(pTHX_ OP *o)
686 register OP *kid, *nextkid;
689 if (!o || o->op_seq == (U16)-1)
692 if (o->op_private & OPpREFCOUNTED) {
693 switch (o->op_type) {
701 if (OpREFCNT_dec(o)) {
712 if (o->op_flags & OPf_KIDS) {
713 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
714 nextkid = kid->op_sibling; /* Get before next freeing kid */
722 /* COP* is not cleared by op_clear() so that we may track line
723 * numbers etc even after null() */
724 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
729 #ifdef PL_OP_SLAB_ALLOC
730 if ((char *) o == PL_OpPtr)
739 S_op_clear(pTHX_ OP *o)
741 switch (o->op_type) {
742 case OP_NULL: /* Was holding old type, if any. */
743 case OP_ENTEREVAL: /* Was holding hints. */
745 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
751 if (!(o->op_flags & OPf_SPECIAL))
754 #endif /* USE_THREADS */
756 if (!(o->op_flags & OPf_REF)
757 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
764 if (cPADOPo->op_padix > 0) {
767 pad_swipe(cPADOPo->op_padix);
768 /* No GvIN_PAD_off(gv) here, because other references may still
769 * exist on the pad */
772 cPADOPo->op_padix = 0;
775 SvREFCNT_dec(cSVOPo->op_sv);
776 cSVOPo->op_sv = Nullsv;
779 case OP_METHOD_NAMED:
781 SvREFCNT_dec(cSVOPo->op_sv);
782 cSVOPo->op_sv = Nullsv;
788 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
792 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
793 SvREFCNT_dec(cSVOPo->op_sv);
794 cSVOPo->op_sv = Nullsv;
797 Safefree(cPVOPo->op_pv);
798 cPVOPo->op_pv = Nullch;
802 op_free(cPMOPo->op_pmreplroot);
806 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
808 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
809 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
810 /* No GvIN_PAD_off(gv) here, because other references may still
811 * exist on the pad */
816 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
823 HV *pmstash = PmopSTASH(cPMOPo);
824 if (pmstash && SvREFCNT(pmstash)) {
825 PMOP *pmop = HvPMROOT(pmstash);
826 PMOP *lastpmop = NULL;
828 if (cPMOPo == pmop) {
830 lastpmop->op_pmnext = pmop->op_pmnext;
832 HvPMROOT(pmstash) = pmop->op_pmnext;
836 pmop = pmop->op_pmnext;
839 Safefree(PmopSTASHPV(cPMOPo));
841 /* NOTE: PMOP.op_pmstash is not refcounted */
845 cPMOPo->op_pmreplroot = Nullop;
846 ReREFCNT_dec(cPMOPo->op_pmregexp);
847 cPMOPo->op_pmregexp = (REGEXP*)NULL;
851 if (o->op_targ > 0) {
852 pad_free(o->op_targ);
858 S_cop_free(pTHX_ COP* cop)
860 Safefree(cop->cop_label);
862 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
863 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
865 /* NOTE: COP.cop_stash is not refcounted */
866 SvREFCNT_dec(CopFILEGV(cop));
868 if (! specialWARN(cop->cop_warnings))
869 SvREFCNT_dec(cop->cop_warnings);
870 if (! specialCopIO(cop->cop_io))
871 SvREFCNT_dec(cop->cop_io);
877 if (o->op_type == OP_NULL)
880 o->op_targ = o->op_type;
881 o->op_type = OP_NULL;
882 o->op_ppaddr = PL_ppaddr[OP_NULL];
885 /* Contextualizers */
887 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
890 Perl_linklist(pTHX_ OP *o)
897 /* establish postfix order */
898 if (cUNOPo->op_first) {
899 o->op_next = LINKLIST(cUNOPo->op_first);
900 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
902 kid->op_next = LINKLIST(kid->op_sibling);
914 Perl_scalarkids(pTHX_ OP *o)
917 if (o && o->op_flags & OPf_KIDS) {
918 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
925 S_scalarboolean(pTHX_ OP *o)
927 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
928 if (ckWARN(WARN_SYNTAX)) {
929 line_t oldline = CopLINE(PL_curcop);
931 if (PL_copline != NOLINE)
932 CopLINE_set(PL_curcop, PL_copline);
933 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
934 CopLINE_set(PL_curcop, oldline);
941 Perl_scalar(pTHX_ OP *o)
945 /* assumes no premature commitment */
946 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
947 || o->op_type == OP_RETURN)
952 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
954 switch (o->op_type) {
956 scalar(cBINOPo->op_first);
961 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
965 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
966 if (!kPMOP->op_pmreplroot)
967 deprecate("implicit split to @_");
975 if (o->op_flags & OPf_KIDS) {
976 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
982 kid = cLISTOPo->op_first;
984 while ((kid = kid->op_sibling)) {
990 WITH_THR(PL_curcop = &PL_compiling);
995 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1001 WITH_THR(PL_curcop = &PL_compiling);
1008 Perl_scalarvoid(pTHX_ OP *o)
1015 if (o->op_type == OP_NEXTSTATE
1016 || o->op_type == OP_SETSTATE
1017 || o->op_type == OP_DBSTATE
1018 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1019 || o->op_targ == OP_SETSTATE
1020 || o->op_targ == OP_DBSTATE)))
1021 PL_curcop = (COP*)o; /* for warning below */
1023 /* assumes no premature commitment */
1024 want = o->op_flags & OPf_WANT;
1025 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1026 || o->op_type == OP_RETURN)
1031 if ((o->op_private & OPpTARGET_MY)
1032 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1034 return scalar(o); /* As if inside SASSIGN */
1037 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1039 switch (o->op_type) {
1041 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1045 if (o->op_flags & OPf_STACKED)
1049 if (o->op_private == 4)
1091 case OP_GETSOCKNAME:
1092 case OP_GETPEERNAME:
1097 case OP_GETPRIORITY:
1120 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1121 useless = PL_op_desc[o->op_type];
1128 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1129 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1130 useless = "a variable";
1135 if (cSVOPo->op_private & OPpCONST_STRICT)
1136 no_bareword_allowed(o);
1138 if (ckWARN(WARN_VOID)) {
1139 useless = "a constant";
1140 /* the constants 0 and 1 are permitted as they are
1141 conventionally used as dummies in constructs like
1142 1 while some_condition_with_side_effects; */
1143 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1145 else if (SvPOK(sv)) {
1146 /* perl4's way of mixing documentation and code
1147 (before the invention of POD) was based on a
1148 trick to mix nroff and perl code. The trick was
1149 built upon these three nroff macros being used in
1150 void context. The pink camel has the details in
1151 the script wrapman near page 319. */
1152 if (strnEQ(SvPVX(sv), "di", 2) ||
1153 strnEQ(SvPVX(sv), "ds", 2) ||
1154 strnEQ(SvPVX(sv), "ig", 2))
1159 null(o); /* don't execute or even remember it */
1163 o->op_type = OP_PREINC; /* pre-increment is faster */
1164 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1168 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1169 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1175 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1180 if (o->op_flags & OPf_STACKED)
1187 if (!(o->op_flags & OPf_KIDS))
1196 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1203 /* all requires must return a boolean value */
1204 o->op_flags &= ~OPf_WANT;
1209 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1210 if (!kPMOP->op_pmreplroot)
1211 deprecate("implicit split to @_");
1215 if (useless && ckWARN(WARN_VOID))
1216 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1221 Perl_listkids(pTHX_ OP *o)
1224 if (o && o->op_flags & OPf_KIDS) {
1225 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1232 Perl_list(pTHX_ OP *o)
1236 /* assumes no premature commitment */
1237 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1238 || o->op_type == OP_RETURN)
1243 if ((o->op_private & OPpTARGET_MY)
1244 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1246 return o; /* As if inside SASSIGN */
1249 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1251 switch (o->op_type) {
1254 list(cBINOPo->op_first);
1259 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1267 if (!(o->op_flags & OPf_KIDS))
1269 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1270 list(cBINOPo->op_first);
1271 return gen_constant_list(o);
1278 kid = cLISTOPo->op_first;
1280 while ((kid = kid->op_sibling)) {
1281 if (kid->op_sibling)
1286 WITH_THR(PL_curcop = &PL_compiling);
1290 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1291 if (kid->op_sibling)
1296 WITH_THR(PL_curcop = &PL_compiling);
1299 /* all requires must return a boolean value */
1300 o->op_flags &= ~OPf_WANT;
1307 Perl_scalarseq(pTHX_ OP *o)
1312 if (o->op_type == OP_LINESEQ ||
1313 o->op_type == OP_SCOPE ||
1314 o->op_type == OP_LEAVE ||
1315 o->op_type == OP_LEAVETRY)
1317 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1318 if (kid->op_sibling) {
1322 PL_curcop = &PL_compiling;
1324 o->op_flags &= ~OPf_PARENS;
1325 if (PL_hints & HINT_BLOCK_SCOPE)
1326 o->op_flags |= OPf_PARENS;
1329 o = newOP(OP_STUB, 0);
1334 S_modkids(pTHX_ OP *o, I32 type)
1337 if (o && o->op_flags & OPf_KIDS) {
1338 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1345 Perl_mod(pTHX_ OP *o, I32 type)
1350 if (!o || PL_error_count)
1353 if ((o->op_private & OPpTARGET_MY)
1354 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1359 switch (o->op_type) {
1364 if (o->op_private & (OPpCONST_BARE) &&
1365 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1366 SV *sv = ((SVOP*)o)->op_sv;
1369 /* Could be a filehandle */
1370 if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1371 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1375 /* OK, it's a sub */
1377 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1379 enter = newUNOP(OP_ENTERSUB,0,
1380 newUNOP(OP_RV2CV, 0,
1381 newGVOP(OP_GV, 0, gv)
1383 enter->op_private |= OPpLVAL_INTRO;
1389 if (!(o->op_private & (OPpCONST_ARYBASE)))
1391 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1392 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1396 SAVEI32(PL_compiling.cop_arybase);
1397 PL_compiling.cop_arybase = 0;
1399 else if (type == OP_REFGEN)
1402 Perl_croak(aTHX_ "That use of $[ is unsupported");
1405 if (o->op_flags & OPf_PARENS)
1409 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1410 !(o->op_flags & OPf_STACKED)) {
1411 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1412 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1413 assert(cUNOPo->op_first->op_type == OP_NULL);
1414 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1417 else { /* lvalue subroutine call */
1418 o->op_private |= OPpLVAL_INTRO;
1419 PL_modcount = RETURN_UNLIMITED_NUMBER;
1420 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1421 /* Backward compatibility mode: */
1422 o->op_private |= OPpENTERSUB_INARGS;
1425 else { /* Compile-time error message: */
1426 OP *kid = cUNOPo->op_first;
1430 if (kid->op_type == OP_PUSHMARK)
1432 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1434 "panic: unexpected lvalue entersub "
1435 "args: type/targ %ld:%ld",
1436 (long)kid->op_type,kid->op_targ);
1437 kid = kLISTOP->op_first;
1439 while (kid->op_sibling)
1440 kid = kid->op_sibling;
1441 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1443 if (kid->op_type == OP_METHOD_NAMED
1444 || kid->op_type == OP_METHOD)
1448 if (kid->op_sibling || kid->op_next != kid) {
1449 yyerror("panic: unexpected optree near method call");
1453 NewOp(1101, newop, 1, UNOP);
1454 newop->op_type = OP_RV2CV;
1455 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456 newop->op_first = Nullop;
1457 newop->op_next = (OP*)newop;
1458 kid->op_sibling = (OP*)newop;
1459 newop->op_private |= OPpLVAL_INTRO;
1463 if (kid->op_type != OP_RV2CV)
1465 "panic: unexpected lvalue entersub "
1466 "entry via type/targ %ld:%ld",
1467 (long)kid->op_type,kid->op_targ);
1468 kid->op_private |= OPpLVAL_INTRO;
1469 break; /* Postpone until runtime */
1473 kid = kUNOP->op_first;
1474 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1475 kid = kUNOP->op_first;
1476 if (kid->op_type == OP_NULL)
1478 "Unexpected constant lvalue entersub "
1479 "entry via type/targ %ld:%ld",
1480 (long)kid->op_type,kid->op_targ);
1481 if (kid->op_type != OP_GV) {
1482 /* Restore RV2CV to check lvalueness */
1484 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1485 okid->op_next = kid->op_next;
1486 kid->op_next = okid;
1489 okid->op_next = Nullop;
1490 okid->op_type = OP_RV2CV;
1492 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1493 okid->op_private |= OPpLVAL_INTRO;
1497 cv = GvCV(kGVOP_gv);
1507 /* grep, foreach, subcalls, refgen */
1508 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1510 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1511 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1513 : (o->op_type == OP_ENTERSUB
1514 ? "non-lvalue subroutine call"
1515 : PL_op_desc[o->op_type])),
1516 type ? PL_op_desc[type] : "local"));
1530 case OP_RIGHT_SHIFT:
1539 if (!(o->op_flags & OPf_STACKED))
1545 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1551 if (!type && cUNOPo->op_first->op_type != OP_GV)
1552 Perl_croak(aTHX_ "Can't localize through a reference");
1553 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1554 PL_modcount = RETURN_UNLIMITED_NUMBER;
1555 return o; /* Treat \(@foo) like ordinary list. */
1559 if (scalar_mod_type(o, type))
1561 ref(cUNOPo->op_first, o->op_type);
1565 if (type == OP_LEAVESUBLV)
1566 o->op_private |= OPpMAYBE_LVSUB;
1572 PL_modcount = RETURN_UNLIMITED_NUMBER;
1575 if (!type && cUNOPo->op_first->op_type != OP_GV)
1576 Perl_croak(aTHX_ "Can't localize through a reference");
1577 ref(cUNOPo->op_first, o->op_type);
1581 PL_hints |= HINT_BLOCK_SCOPE;
1591 PL_modcount = RETURN_UNLIMITED_NUMBER;
1592 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1593 return o; /* Treat \(@foo) like ordinary list. */
1594 if (scalar_mod_type(o, type))
1596 if (type == OP_LEAVESUBLV)
1597 o->op_private |= OPpMAYBE_LVSUB;
1602 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1603 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1608 PL_modcount++; /* XXX ??? */
1610 #endif /* USE_THREADS */
1616 if (type != OP_SASSIGN)
1620 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1628 pad_free(o->op_targ);
1629 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1630 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1631 if (o->op_flags & OPf_KIDS)
1632 mod(cBINOPo->op_first->op_sibling, type);
1637 ref(cBINOPo->op_first, o->op_type);
1638 if (type == OP_ENTERSUB &&
1639 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1640 o->op_private |= OPpLVAL_DEFER;
1641 if (type == OP_LEAVESUBLV)
1642 o->op_private |= OPpMAYBE_LVSUB;
1650 if (o->op_flags & OPf_KIDS)
1651 mod(cLISTOPo->op_last, type);
1655 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1657 else if (!(o->op_flags & OPf_KIDS))
1659 if (o->op_targ != OP_LIST) {
1660 mod(cBINOPo->op_first, type);
1665 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1670 if (type != OP_LEAVESUBLV)
1672 break; /* mod()ing was handled by ck_return() */
1674 if (type != OP_LEAVESUBLV)
1675 o->op_flags |= OPf_MOD;
1677 if (type == OP_AASSIGN || type == OP_SASSIGN)
1678 o->op_flags |= OPf_SPECIAL|OPf_REF;
1680 o->op_private |= OPpLVAL_INTRO;
1681 o->op_flags &= ~OPf_SPECIAL;
1682 PL_hints |= HINT_BLOCK_SCOPE;
1684 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1685 && type != OP_LEAVESUBLV)
1686 o->op_flags |= OPf_REF;
1691 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1695 if (o->op_type == OP_RV2GV)
1719 case OP_RIGHT_SHIFT:
1738 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1740 switch (o->op_type) {
1748 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1761 Perl_refkids(pTHX_ OP *o, I32 type)
1764 if (o && o->op_flags & OPf_KIDS) {
1765 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1772 Perl_ref(pTHX_ OP *o, I32 type)
1776 if (!o || PL_error_count)
1779 switch (o->op_type) {
1781 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1782 !(o->op_flags & OPf_STACKED)) {
1783 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1784 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1785 assert(cUNOPo->op_first->op_type == OP_NULL);
1786 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1787 o->op_flags |= OPf_SPECIAL;
1792 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1796 if (type == OP_DEFINED)
1797 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1798 ref(cUNOPo->op_first, o->op_type);
1801 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1802 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1803 : type == OP_RV2HV ? OPpDEREF_HV
1805 o->op_flags |= OPf_MOD;
1810 o->op_flags |= OPf_MOD; /* XXX ??? */
1815 o->op_flags |= OPf_REF;
1818 if (type == OP_DEFINED)
1819 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1820 ref(cUNOPo->op_first, o->op_type);
1825 o->op_flags |= OPf_REF;
1830 if (!(o->op_flags & OPf_KIDS))
1832 ref(cBINOPo->op_first, type);
1836 ref(cBINOPo->op_first, o->op_type);
1837 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1838 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1839 : type == OP_RV2HV ? OPpDEREF_HV
1841 o->op_flags |= OPf_MOD;
1849 if (!(o->op_flags & OPf_KIDS))
1851 ref(cLISTOPo->op_last, type);
1861 S_dup_attrlist(pTHX_ OP *o)
1865 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1866 * where the first kid is OP_PUSHMARK and the remaining ones
1867 * are OP_CONST. We need to push the OP_CONST values.
1869 if (o->op_type == OP_CONST)
1870 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1872 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1873 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1874 if (o->op_type == OP_CONST)
1875 rop = append_elem(OP_LIST, rop,
1876 newSVOP(OP_CONST, o->op_flags,
1877 SvREFCNT_inc(cSVOPo->op_sv)));
1884 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1888 /* fake up C<use attributes $pkg,$rv,@attrs> */
1889 ENTER; /* need to protect against side-effects of 'use' */
1891 if (stash && HvNAME(stash))
1892 stashsv = newSVpv(HvNAME(stash), 0);
1894 stashsv = &PL_sv_no;
1896 #define ATTRSMODULE "attributes"
1898 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1899 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1901 prepend_elem(OP_LIST,
1902 newSVOP(OP_CONST, 0, stashsv),
1903 prepend_elem(OP_LIST,
1904 newSVOP(OP_CONST, 0,
1906 dup_attrlist(attrs))));
1911 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1912 char *attrstr, STRLEN len)
1917 len = strlen(attrstr);
1921 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1923 char *sstr = attrstr;
1924 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1925 attrs = append_elem(OP_LIST, attrs,
1926 newSVOP(OP_CONST, 0,
1927 newSVpvn(sstr, attrstr-sstr)));
1931 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1932 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1933 Nullsv, prepend_elem(OP_LIST,
1934 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1935 prepend_elem(OP_LIST,
1936 newSVOP(OP_CONST, 0,
1942 S_my_kid(pTHX_ OP *o, OP *attrs)
1947 if (!o || PL_error_count)
1951 if (type == OP_LIST) {
1952 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1954 } else if (type == OP_UNDEF) {
1956 } else if (type == OP_RV2SV || /* "our" declaration */
1958 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1960 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1962 PL_in_my_stash = Nullhv;
1963 apply_attrs(GvSTASH(gv),
1964 (type == OP_RV2SV ? GvSV(gv) :
1965 type == OP_RV2AV ? (SV*)GvAV(gv) :
1966 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1969 o->op_private |= OPpOUR_INTRO;
1971 } else if (type != OP_PADSV &&
1974 type != OP_PUSHMARK)
1976 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1977 PL_op_desc[o->op_type],
1978 PL_in_my == KEY_our ? "our" : "my"));
1981 else if (attrs && type != OP_PUSHMARK) {
1987 PL_in_my_stash = Nullhv;
1989 /* check for C<my Dog $spot> when deciding package */
1990 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1991 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1992 stash = SvSTASH(*namesvp);
1994 stash = PL_curstash;
1995 padsv = PAD_SV(o->op_targ);
1996 apply_attrs(stash, padsv, attrs);
1998 o->op_flags |= OPf_MOD;
1999 o->op_private |= OPpLVAL_INTRO;
2004 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2006 if (o->op_flags & OPf_PARENS)
2010 o = my_kid(o, attrs);
2012 PL_in_my_stash = Nullhv;
2017 Perl_my(pTHX_ OP *o)
2019 return my_kid(o, Nullop);
2023 Perl_sawparens(pTHX_ OP *o)
2026 o->op_flags |= OPf_PARENS;
2031 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2035 if (ckWARN(WARN_MISC) &&
2036 (left->op_type == OP_RV2AV ||
2037 left->op_type == OP_RV2HV ||
2038 left->op_type == OP_PADAV ||
2039 left->op_type == OP_PADHV)) {
2040 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2041 right->op_type == OP_TRANS)
2042 ? right->op_type : OP_MATCH];
2043 const char *sample = ((left->op_type == OP_RV2AV ||
2044 left->op_type == OP_PADAV)
2045 ? "@array" : "%hash");
2046 Perl_warner(aTHX_ WARN_MISC,
2047 "Applying %s to %s will act on scalar(%s)",
2048 desc, sample, sample);
2051 if (!(right->op_flags & OPf_STACKED) &&
2052 (right->op_type == OP_MATCH ||
2053 right->op_type == OP_SUBST ||
2054 right->op_type == OP_TRANS)) {
2055 right->op_flags |= OPf_STACKED;
2056 if (right->op_type != OP_MATCH &&
2057 ! (right->op_type == OP_TRANS &&
2058 right->op_private & OPpTRANS_IDENTICAL))
2059 left = mod(left, right->op_type);
2060 if (right->op_type == OP_TRANS)
2061 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2063 o = prepend_elem(right->op_type, scalar(left), right);
2065 return newUNOP(OP_NOT, 0, scalar(o));
2069 return bind_match(type, left,
2070 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2074 Perl_invert(pTHX_ OP *o)
2078 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2079 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2083 Perl_scope(pTHX_ OP *o)
2086 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2087 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2088 o->op_type = OP_LEAVE;
2089 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2092 if (o->op_type == OP_LINESEQ) {
2094 o->op_type = OP_SCOPE;
2095 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2096 kid = ((LISTOP*)o)->op_first;
2097 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2101 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2108 Perl_save_hints(pTHX)
2111 SAVESPTR(GvHV(PL_hintgv));
2112 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2113 SAVEFREESV(GvHV(PL_hintgv));
2117 Perl_block_start(pTHX_ int full)
2119 int retval = PL_savestack_ix;
2121 SAVEI32(PL_comppad_name_floor);
2122 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2124 PL_comppad_name_fill = PL_comppad_name_floor;
2125 if (PL_comppad_name_floor < 0)
2126 PL_comppad_name_floor = 0;
2127 SAVEI32(PL_min_intro_pending);
2128 SAVEI32(PL_max_intro_pending);
2129 PL_min_intro_pending = 0;
2130 SAVEI32(PL_comppad_name_fill);
2131 SAVEI32(PL_padix_floor);
2132 PL_padix_floor = PL_padix;
2133 PL_pad_reset_pending = FALSE;
2135 PL_hints &= ~HINT_BLOCK_SCOPE;
2136 SAVESPTR(PL_compiling.cop_warnings);
2137 if (! specialWARN(PL_compiling.cop_warnings)) {
2138 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2139 SAVEFREESV(PL_compiling.cop_warnings) ;
2141 SAVESPTR(PL_compiling.cop_io);
2142 if (! specialCopIO(PL_compiling.cop_io)) {
2143 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2144 SAVEFREESV(PL_compiling.cop_io) ;
2150 Perl_block_end(pTHX_ I32 floor, OP *seq)
2152 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2153 OP* retval = scalarseq(seq);
2155 PL_pad_reset_pending = FALSE;
2156 PL_compiling.op_private = PL_hints;
2158 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2159 pad_leavemy(PL_comppad_name_fill);
2168 OP *o = newOP(OP_THREADSV, 0);
2169 o->op_targ = find_threadsv("_");
2172 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2173 #endif /* USE_THREADS */
2177 Perl_newPROG(pTHX_ OP *o)
2182 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2183 ((PL_in_eval & EVAL_KEEPERR)
2184 ? OPf_SPECIAL : 0), o);
2185 PL_eval_start = linklist(PL_eval_root);
2186 PL_eval_root->op_private |= OPpREFCOUNTED;
2187 OpREFCNT_set(PL_eval_root, 1);
2188 PL_eval_root->op_next = 0;
2189 peep(PL_eval_start);
2194 PL_main_root = scope(sawparens(scalarvoid(o)));
2195 PL_curcop = &PL_compiling;
2196 PL_main_start = LINKLIST(PL_main_root);
2197 PL_main_root->op_private |= OPpREFCOUNTED;
2198 OpREFCNT_set(PL_main_root, 1);
2199 PL_main_root->op_next = 0;
2200 peep(PL_main_start);
2203 /* Register with debugger */
2205 CV *cv = get_cv("DB::postponed", FALSE);
2209 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2211 call_sv((SV*)cv, G_DISCARD);
2218 Perl_localize(pTHX_ OP *o, I32 lex)
2220 if (o->op_flags & OPf_PARENS)
2223 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2225 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2226 if (*s == ';' || *s == '=')
2227 Perl_warner(aTHX_ WARN_PARENTHESIS,
2228 "Parentheses missing around \"%s\" list",
2229 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2235 o = mod(o, OP_NULL); /* a bit kludgey */
2237 PL_in_my_stash = Nullhv;
2242 Perl_jmaybe(pTHX_ OP *o)
2244 if (o->op_type == OP_LIST) {
2247 o2 = newOP(OP_THREADSV, 0);
2248 o2->op_targ = find_threadsv(";");
2250 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2251 #endif /* USE_THREADS */
2252 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2258 Perl_fold_constants(pTHX_ register OP *o)
2261 I32 type = o->op_type;
2264 if (PL_opargs[type] & OA_RETSCALAR)
2266 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2267 o->op_targ = pad_alloc(type, SVs_PADTMP);
2269 /* integerize op, unless it happens to be C<-foo>.
2270 * XXX should pp_i_negate() do magic string negation instead? */
2271 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2272 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2273 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2275 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2278 if (!(PL_opargs[type] & OA_FOLDCONST))
2283 /* XXX might want a ck_negate() for this */
2284 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2297 if (o->op_private & OPpLOCALE)
2302 goto nope; /* Don't try to run w/ errors */
2304 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2305 if ((curop->op_type != OP_CONST ||
2306 (curop->op_private & OPpCONST_BARE)) &&
2307 curop->op_type != OP_LIST &&
2308 curop->op_type != OP_SCALAR &&
2309 curop->op_type != OP_NULL &&
2310 curop->op_type != OP_PUSHMARK)
2316 curop = LINKLIST(o);
2320 sv = *(PL_stack_sp--);
2321 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2322 pad_swipe(o->op_targ);
2323 else if (SvTEMP(sv)) { /* grab mortal temp? */
2324 (void)SvREFCNT_inc(sv);
2328 if (type == OP_RV2GV)
2329 return newGVOP(OP_GV, 0, (GV*)sv);
2331 /* try to smush double to int, but don't smush -2.0 to -2 */
2332 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2335 #ifdef PERL_PRESERVE_IVUV
2336 /* Only bother to attempt to fold to IV if
2337 most operators will benefit */
2341 return newSVOP(OP_CONST, 0, sv);
2345 if (!(PL_opargs[type] & OA_OTHERINT))
2348 if (!(PL_hints & HINT_INTEGER)) {
2349 if (type == OP_MODULO
2350 || type == OP_DIVIDE
2351 || !(o->op_flags & OPf_KIDS))
2356 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2357 if (curop->op_type == OP_CONST) {
2358 if (SvIOK(((SVOP*)curop)->op_sv))
2362 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2366 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2373 Perl_gen_constant_list(pTHX_ register OP *o)
2376 I32 oldtmps_floor = PL_tmps_floor;
2380 return o; /* Don't attempt to run with errors */
2382 PL_op = curop = LINKLIST(o);
2389 PL_tmps_floor = oldtmps_floor;
2391 o->op_type = OP_RV2AV;
2392 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2393 curop = ((UNOP*)o)->op_first;
2394 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2401 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2403 if (!o || o->op_type != OP_LIST)
2404 o = newLISTOP(OP_LIST, 0, o, Nullop);
2406 o->op_flags &= ~OPf_WANT;
2408 if (!(PL_opargs[type] & OA_MARK))
2409 null(cLISTOPo->op_first);
2412 o->op_ppaddr = PL_ppaddr[type];
2413 o->op_flags |= flags;
2415 o = CHECKOP(type, o);
2416 if (o->op_type != type)
2419 return fold_constants(o);
2422 /* List constructors */
2425 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2433 if (first->op_type != type
2434 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2436 return newLISTOP(type, 0, first, last);
2439 if (first->op_flags & OPf_KIDS)
2440 ((LISTOP*)first)->op_last->op_sibling = last;
2442 first->op_flags |= OPf_KIDS;
2443 ((LISTOP*)first)->op_first = last;
2445 ((LISTOP*)first)->op_last = last;
2450 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2458 if (first->op_type != type)
2459 return prepend_elem(type, (OP*)first, (OP*)last);
2461 if (last->op_type != type)
2462 return append_elem(type, (OP*)first, (OP*)last);
2464 first->op_last->op_sibling = last->op_first;
2465 first->op_last = last->op_last;
2466 first->op_flags |= (last->op_flags & OPf_KIDS);
2468 #ifdef PL_OP_SLAB_ALLOC
2476 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2484 if (last->op_type == type) {
2485 if (type == OP_LIST) { /* already a PUSHMARK there */
2486 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2487 ((LISTOP*)last)->op_first->op_sibling = first;
2488 if (!(first->op_flags & OPf_PARENS))
2489 last->op_flags &= ~OPf_PARENS;
2492 if (!(last->op_flags & OPf_KIDS)) {
2493 ((LISTOP*)last)->op_last = first;
2494 last->op_flags |= OPf_KIDS;
2496 first->op_sibling = ((LISTOP*)last)->op_first;
2497 ((LISTOP*)last)->op_first = first;
2499 last->op_flags |= OPf_KIDS;
2503 return newLISTOP(type, 0, first, last);
2509 Perl_newNULLLIST(pTHX)
2511 return newOP(OP_STUB, 0);
2515 Perl_force_list(pTHX_ OP *o)
2517 if (!o || o->op_type != OP_LIST)
2518 o = newLISTOP(OP_LIST, 0, o, Nullop);
2524 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2528 NewOp(1101, listop, 1, LISTOP);
2530 listop->op_type = type;
2531 listop->op_ppaddr = PL_ppaddr[type];
2534 listop->op_flags = flags;
2538 else if (!first && last)
2541 first->op_sibling = last;
2542 listop->op_first = first;
2543 listop->op_last = last;
2544 if (type == OP_LIST) {
2546 pushop = newOP(OP_PUSHMARK, 0);
2547 pushop->op_sibling = first;
2548 listop->op_first = pushop;
2549 listop->op_flags |= OPf_KIDS;
2551 listop->op_last = pushop;
2558 Perl_newOP(pTHX_ I32 type, I32 flags)
2561 NewOp(1101, o, 1, OP);
2563 o->op_ppaddr = PL_ppaddr[type];
2564 o->op_flags = flags;
2567 o->op_private = 0 + (flags >> 8);
2568 if (PL_opargs[type] & OA_RETSCALAR)
2570 if (PL_opargs[type] & OA_TARGET)
2571 o->op_targ = pad_alloc(type, SVs_PADTMP);
2572 return CHECKOP(type, o);
2576 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2581 first = newOP(OP_STUB, 0);
2582 if (PL_opargs[type] & OA_MARK)
2583 first = force_list(first);
2585 NewOp(1101, unop, 1, UNOP);
2586 unop->op_type = type;
2587 unop->op_ppaddr = PL_ppaddr[type];
2588 unop->op_first = first;
2589 unop->op_flags = flags | OPf_KIDS;
2590 unop->op_private = 1 | (flags >> 8);
2591 unop = (UNOP*) CHECKOP(type, unop);
2595 return fold_constants((OP *) unop);
2599 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2602 NewOp(1101, binop, 1, BINOP);
2605 first = newOP(OP_NULL, 0);
2607 binop->op_type = type;
2608 binop->op_ppaddr = PL_ppaddr[type];
2609 binop->op_first = first;
2610 binop->op_flags = flags | OPf_KIDS;
2613 binop->op_private = 1 | (flags >> 8);
2616 binop->op_private = 2 | (flags >> 8);
2617 first->op_sibling = last;
2620 binop = (BINOP*)CHECKOP(type, binop);
2621 if (binop->op_next || binop->op_type != type)
2624 binop->op_last = binop->op_first->op_sibling;
2626 return fold_constants((OP *)binop);
2630 uvcompare(const void *a, const void *b)
2632 if (*((UV *)a) < (*(UV *)b))
2634 if (*((UV *)a) > (*(UV *)b))
2636 if (*((UV *)a+1) < (*(UV *)b+1))
2638 if (*((UV *)a+1) > (*(UV *)b+1))
2644 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2646 SV *tstr = ((SVOP*)expr)->op_sv;
2647 SV *rstr = ((SVOP*)repl)->op_sv;
2650 U8 *t = (U8*)SvPV(tstr, tlen);
2651 U8 *r = (U8*)SvPV(rstr, rlen);
2658 register short *tbl;
2660 PL_hints |= HINT_BLOCK_SCOPE;
2661 complement = o->op_private & OPpTRANS_COMPLEMENT;
2662 del = o->op_private & OPpTRANS_DELETE;
2663 squash = o->op_private & OPpTRANS_SQUASH;
2666 o->op_private |= OPpTRANS_FROM_UTF;
2669 o->op_private |= OPpTRANS_TO_UTF;
2671 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2672 SV* listsv = newSVpvn("# comment\n",10);
2674 U8* tend = t + tlen;
2675 U8* rend = r + rlen;
2689 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2690 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2696 tsave = t = bytes_to_utf8(t, &len);
2699 if (!to_utf && rlen) {
2701 rsave = r = bytes_to_utf8(r, &len);
2705 /* There are several snags with this code on EBCDIC:
2706 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2707 2. scan_const() in toke.c has encoded chars in native encoding which makes
2708 ranges at least in EBCDIC 0..255 range the bottom odd.
2712 U8 tmpbuf[UTF8_MAXLEN+1];
2715 New(1109, cp, 2*tlen, UV);
2717 transv = newSVpvn("",0);
2719 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2721 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2723 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2727 cp[2*i+1] = cp[2*i];
2731 qsort(cp, i, 2*sizeof(UV), uvcompare);
2732 for (j = 0; j < i; j++) {
2734 diff = val - nextmin;
2736 t = uvuni_to_utf8(tmpbuf,nextmin);
2737 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2739 U8 range_mark = UTF_TO_NATIVE(0xff);
2740 t = uvuni_to_utf8(tmpbuf, val - 1);
2741 sv_catpvn(transv, (char *)&range_mark, 1);
2742 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2749 t = uvuni_to_utf8(tmpbuf,nextmin);
2750 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2752 U8 range_mark = UTF_TO_NATIVE(0xff);
2753 sv_catpvn(transv, (char *)&range_mark, 1);
2755 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2756 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2757 t = (U8*)SvPVX(transv);
2758 tlen = SvCUR(transv);
2762 else if (!rlen && !del) {
2763 r = t; rlen = tlen; rend = tend;
2766 if ((!rlen && !del) || t == r ||
2767 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2769 o->op_private |= OPpTRANS_IDENTICAL;
2773 while (t < tend || tfirst <= tlast) {
2774 /* see if we need more "t" chars */
2775 if (tfirst > tlast) {
2776 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2778 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2780 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2787 /* now see if we need more "r" chars */
2788 if (rfirst > rlast) {
2790 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2792 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2794 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2803 rfirst = rlast = 0xffffffff;
2807 /* now see which range will peter our first, if either. */
2808 tdiff = tlast - tfirst;
2809 rdiff = rlast - rfirst;
2816 if (rfirst == 0xffffffff) {
2817 diff = tdiff; /* oops, pretend rdiff is infinite */
2819 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2820 (long)tfirst, (long)tlast);
2822 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2826 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2827 (long)tfirst, (long)(tfirst + diff),
2830 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2831 (long)tfirst, (long)rfirst);
2833 if (rfirst + diff > max)
2834 max = rfirst + diff;
2836 grows = (tfirst < rfirst &&
2837 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2849 else if (max > 0xff)
2854 Safefree(cPVOPo->op_pv);
2855 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2856 SvREFCNT_dec(listsv);
2858 SvREFCNT_dec(transv);
2860 if (!del && havefinal && rlen)
2861 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2862 newSVuv((UV)final), 0);
2865 o->op_private |= OPpTRANS_GROWS;
2877 tbl = (short*)cPVOPo->op_pv;
2879 Zero(tbl, 256, short);
2880 for (i = 0; i < tlen; i++)
2882 for (i = 0, j = 0; i < 256; i++) {
2893 if (i < 128 && r[j] >= 128)
2903 o->op_private |= OPpTRANS_IDENTICAL;
2908 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2909 tbl[0x100] = rlen - j;
2910 for (i=0; i < rlen - j; i++)
2911 tbl[0x101+i] = r[j+i];
2915 if (!rlen && !del) {
2918 o->op_private |= OPpTRANS_IDENTICAL;
2920 for (i = 0; i < 256; i++)
2922 for (i = 0, j = 0; i < tlen; i++,j++) {
2925 if (tbl[t[i]] == -1)
2931 if (tbl[t[i]] == -1) {
2932 if (t[i] < 128 && r[j] >= 128)
2939 o->op_private |= OPpTRANS_GROWS;
2947 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2951 NewOp(1101, pmop, 1, PMOP);
2952 pmop->op_type = type;
2953 pmop->op_ppaddr = PL_ppaddr[type];
2954 pmop->op_flags = flags;
2955 pmop->op_private = 0 | (flags >> 8);
2957 if (PL_hints & HINT_RE_TAINT)
2958 pmop->op_pmpermflags |= PMf_RETAINT;
2959 if (PL_hints & HINT_LOCALE)
2960 pmop->op_pmpermflags |= PMf_LOCALE;
2961 pmop->op_pmflags = pmop->op_pmpermflags;
2963 /* link into pm list */
2964 if (type != OP_TRANS && PL_curstash) {
2965 pmop->op_pmnext = HvPMROOT(PL_curstash);
2966 HvPMROOT(PL_curstash) = pmop;
2967 PmopSTASH_set(pmop,PL_curstash);
2974 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2978 I32 repl_has_vars = 0;
2980 if (o->op_type == OP_TRANS)
2981 return pmtrans(o, expr, repl);
2983 PL_hints |= HINT_BLOCK_SCOPE;
2986 if (expr->op_type == OP_CONST) {
2988 SV *pat = ((SVOP*)expr)->op_sv;
2989 char *p = SvPV(pat, plen);
2990 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2991 sv_setpvn(pat, "\\s+", 3);
2992 p = SvPV(pat, plen);
2993 pm->op_pmflags |= PMf_SKIPWHITE;
2995 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2996 pm->op_pmdynflags |= PMdf_UTF8;
2997 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2998 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2999 pm->op_pmflags |= PMf_WHITE;
3003 if (PL_hints & HINT_UTF8)
3004 pm->op_pmdynflags |= PMdf_UTF8;
3005 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3006 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3008 : OP_REGCMAYBE),0,expr);
3010 NewOp(1101, rcop, 1, LOGOP);
3011 rcop->op_type = OP_REGCOMP;
3012 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3013 rcop->op_first = scalar(expr);
3014 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3015 ? (OPf_SPECIAL | OPf_KIDS)
3017 rcop->op_private = 1;
3020 /* establish postfix order */
3021 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3023 rcop->op_next = expr;
3024 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3027 rcop->op_next = LINKLIST(expr);
3028 expr->op_next = (OP*)rcop;
3031 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3036 if (pm->op_pmflags & PMf_EVAL) {
3038 if (CopLINE(PL_curcop) < PL_multi_end)
3039 CopLINE_set(PL_curcop, PL_multi_end);
3042 else if (repl->op_type == OP_THREADSV
3043 && strchr("&`'123456789+",
3044 PL_threadsv_names[repl->op_targ]))
3048 #endif /* USE_THREADS */
3049 else if (repl->op_type == OP_CONST)
3053 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3054 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3056 if (curop->op_type == OP_THREADSV) {
3058 if (strchr("&`'123456789+", curop->op_private))
3062 if (curop->op_type == OP_GV) {
3063 GV *gv = cGVOPx_gv(curop);
3065 if (strchr("&`'123456789+", *GvENAME(gv)))
3068 #endif /* USE_THREADS */
3069 else if (curop->op_type == OP_RV2CV)
3071 else if (curop->op_type == OP_RV2SV ||
3072 curop->op_type == OP_RV2AV ||
3073 curop->op_type == OP_RV2HV ||
3074 curop->op_type == OP_RV2GV) {
3075 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3078 else if (curop->op_type == OP_PADSV ||
3079 curop->op_type == OP_PADAV ||
3080 curop->op_type == OP_PADHV ||
3081 curop->op_type == OP_PADANY) {
3084 else if (curop->op_type == OP_PUSHRE)
3085 ; /* Okay here, dangerous in newASSIGNOP */
3094 && (!pm->op_pmregexp
3095 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3096 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3097 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3098 prepend_elem(o->op_type, scalar(repl), o);
3101 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3102 pm->op_pmflags |= PMf_MAYBE_CONST;
3103 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3105 NewOp(1101, rcop, 1, LOGOP);
3106 rcop->op_type = OP_SUBSTCONT;
3107 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3108 rcop->op_first = scalar(repl);
3109 rcop->op_flags |= OPf_KIDS;
3110 rcop->op_private = 1;
3113 /* establish postfix order */
3114 rcop->op_next = LINKLIST(repl);
3115 repl->op_next = (OP*)rcop;
3117 pm->op_pmreplroot = scalar((OP*)rcop);
3118 pm->op_pmreplstart = LINKLIST(rcop);
3127 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3130 NewOp(1101, svop, 1, SVOP);
3131 svop->op_type = type;
3132 svop->op_ppaddr = PL_ppaddr[type];
3134 svop->op_next = (OP*)svop;
3135 svop->op_flags = flags;
3136 if (PL_opargs[type] & OA_RETSCALAR)
3138 if (PL_opargs[type] & OA_TARGET)
3139 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3140 return CHECKOP(type, svop);
3144 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3147 NewOp(1101, padop, 1, PADOP);
3148 padop->op_type = type;
3149 padop->op_ppaddr = PL_ppaddr[type];
3150 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3151 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3152 PL_curpad[padop->op_padix] = sv;
3154 padop->op_next = (OP*)padop;
3155 padop->op_flags = flags;
3156 if (PL_opargs[type] & OA_RETSCALAR)
3158 if (PL_opargs[type] & OA_TARGET)
3159 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3160 return CHECKOP(type, padop);
3164 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3168 return newPADOP(type, flags, SvREFCNT_inc(gv));
3170 return newSVOP(type, flags, SvREFCNT_inc(gv));
3175 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3178 NewOp(1101, pvop, 1, PVOP);
3179 pvop->op_type = type;
3180 pvop->op_ppaddr = PL_ppaddr[type];
3182 pvop->op_next = (OP*)pvop;
3183 pvop->op_flags = flags;
3184 if (PL_opargs[type] & OA_RETSCALAR)
3186 if (PL_opargs[type] & OA_TARGET)
3187 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3188 return CHECKOP(type, pvop);
3192 Perl_package(pTHX_ OP *o)
3196 save_hptr(&PL_curstash);
3197 save_item(PL_curstname);
3202 name = SvPV(sv, len);
3203 PL_curstash = gv_stashpvn(name,len,TRUE);
3204 sv_setpvn(PL_curstname, name, len);
3208 sv_setpv(PL_curstname,"<none>");
3209 PL_curstash = Nullhv;
3211 PL_hints |= HINT_BLOCK_SCOPE;
3212 PL_copline = NOLINE;
3217 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3225 if (id->op_type != OP_CONST)
3226 Perl_croak(aTHX_ "Module name must be constant");
3230 if (version != Nullop) {
3231 SV *vesv = ((SVOP*)version)->op_sv;
3233 if (arg == Nullop && !SvNIOKp(vesv)) {
3240 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3241 Perl_croak(aTHX_ "Version number must be constant number");
3243 /* Make copy of id so we don't free it twice */
3244 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3246 /* Fake up a method call to VERSION */
3247 meth = newSVpvn("VERSION",7);
3248 sv_upgrade(meth, SVt_PVIV);
3249 (void)SvIOK_on(meth);
3250 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3251 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3252 append_elem(OP_LIST,
3253 prepend_elem(OP_LIST, pack, list(version)),
3254 newSVOP(OP_METHOD_NAMED, 0, meth)));
3258 /* Fake up an import/unimport */
3259 if (arg && arg->op_type == OP_STUB)
3260 imop = arg; /* no import on explicit () */
3261 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3262 imop = Nullop; /* use 5.0; */
3267 /* Make copy of id so we don't free it twice */
3268 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3270 /* Fake up a method call to import/unimport */
3271 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3272 sv_upgrade(meth, SVt_PVIV);
3273 (void)SvIOK_on(meth);
3274 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3275 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3276 append_elem(OP_LIST,
3277 prepend_elem(OP_LIST, pack, list(arg)),
3278 newSVOP(OP_METHOD_NAMED, 0, meth)));
3281 /* Fake up a require, handle override, if any */
3282 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3283 if (!(gv && GvIMPORTED_CV(gv)))
3284 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3286 if (gv && GvIMPORTED_CV(gv)) {
3287 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3288 append_elem(OP_LIST, id,
3289 scalar(newUNOP(OP_RV2CV, 0,
3294 rqop = newUNOP(OP_REQUIRE, 0, id);
3297 /* Fake up the BEGIN {}, which does its thing immediately. */
3299 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3302 append_elem(OP_LINESEQ,
3303 append_elem(OP_LINESEQ,
3304 newSTATEOP(0, Nullch, rqop),
3305 newSTATEOP(0, Nullch, veop)),
3306 newSTATEOP(0, Nullch, imop) ));
3308 PL_hints |= HINT_BLOCK_SCOPE;
3309 PL_copline = NOLINE;
3314 =for apidoc load_module
3316 Loads the module whose name is pointed to by the string part of name.
3317 Note that the actual module name, not its filename, should be given.
3318 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3319 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3320 (or 0 for no flags). ver, if specified, provides version semantics
3321 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3322 arguments can be used to specify arguments to the module's import()
3323 method, similar to C<use Foo::Bar VERSION LIST>.
3328 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3331 va_start(args, ver);
3332 vload_module(flags, name, ver, &args);
3336 #ifdef PERL_IMPLICIT_CONTEXT
3338 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3342 va_start(args, ver);
3343 vload_module(flags, name, ver, &args);
3349 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3351 OP *modname, *veop, *imop;
3353 modname = newSVOP(OP_CONST, 0, name);
3354 modname->op_private |= OPpCONST_BARE;
3356 veop = newSVOP(OP_CONST, 0, ver);
3360 if (flags & PERL_LOADMOD_NOIMPORT) {
3361 imop = sawparens(newNULLLIST());
3363 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3364 imop = va_arg(*args, OP*);
3369 sv = va_arg(*args, SV*);
3371 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3372 sv = va_arg(*args, SV*);
3376 line_t ocopline = PL_copline;
3377 int oexpect = PL_expect;
3379 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3380 veop, modname, imop);
3381 PL_expect = oexpect;
3382 PL_copline = ocopline;
3387 Perl_dofile(pTHX_ OP *term)
3392 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3393 if (!(gv && GvIMPORTED_CV(gv)))
3394 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3396 if (gv && GvIMPORTED_CV(gv)) {
3397 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3398 append_elem(OP_LIST, term,
3399 scalar(newUNOP(OP_RV2CV, 0,
3404 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3410 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3412 return newBINOP(OP_LSLICE, flags,
3413 list(force_list(subscript)),
3414 list(force_list(listval)) );
3418 S_list_assignment(pTHX_ register OP *o)
3423 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3424 o = cUNOPo->op_first;
3426 if (o->op_type == OP_COND_EXPR) {
3427 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3428 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3433 yyerror("Assignment to both a list and a scalar");
3437 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3438 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3439 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3442 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3445 if (o->op_type == OP_RV2SV)
3452 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3457 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3458 return newLOGOP(optype, 0,
3459 mod(scalar(left), optype),
3460 newUNOP(OP_SASSIGN, 0, scalar(right)));
3463 return newBINOP(optype, OPf_STACKED,
3464 mod(scalar(left), optype), scalar(right));
3468 if (list_assignment(left)) {
3472 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3473 left = mod(left, OP_AASSIGN);
3481 curop = list(force_list(left));
3482 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3483 o->op_private = 0 | (flags >> 8);
3484 for (curop = ((LISTOP*)curop)->op_first;
3485 curop; curop = curop->op_sibling)
3487 if (curop->op_type == OP_RV2HV &&
3488 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3489 o->op_private |= OPpASSIGN_HASH;
3493 if (!(left->op_private & OPpLVAL_INTRO)) {
3496 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3497 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3498 if (curop->op_type == OP_GV) {
3499 GV *gv = cGVOPx_gv(curop);
3500 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3502 SvCUR(gv) = PL_generation;
3504 else if (curop->op_type == OP_PADSV ||
3505 curop->op_type == OP_PADAV ||
3506 curop->op_type == OP_PADHV ||
3507 curop->op_type == OP_PADANY) {
3508 SV **svp = AvARRAY(PL_comppad_name);
3509 SV *sv = svp[curop->op_targ];
3510 if (SvCUR(sv) == PL_generation)
3512 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3514 else if (curop->op_type == OP_RV2CV)
3516 else if (curop->op_type == OP_RV2SV ||
3517 curop->op_type == OP_RV2AV ||
3518 curop->op_type == OP_RV2HV ||
3519 curop->op_type == OP_RV2GV) {
3520 if (lastop->op_type != OP_GV) /* funny deref? */
3523 else if (curop->op_type == OP_PUSHRE) {
3524 if (((PMOP*)curop)->op_pmreplroot) {
3526 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3528 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3530 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3532 SvCUR(gv) = PL_generation;
3541 o->op_private |= OPpASSIGN_COMMON;
3543 if (right && right->op_type == OP_SPLIT) {
3545 if ((tmpop = ((LISTOP*)right)->op_first) &&
3546 tmpop->op_type == OP_PUSHRE)
3548 PMOP *pm = (PMOP*)tmpop;
3549 if (left->op_type == OP_RV2AV &&
3550 !(left->op_private & OPpLVAL_INTRO) &&
3551 !(o->op_private & OPpASSIGN_COMMON) )
3553 tmpop = ((UNOP*)left)->op_first;
3554 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3556 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3557 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3559 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3560 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3562 pm->op_pmflags |= PMf_ONCE;
3563 tmpop = cUNOPo->op_first; /* to list (nulled) */
3564 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3565 tmpop->op_sibling = Nullop; /* don't free split */
3566 right->op_next = tmpop->op_next; /* fix starting loc */
3567 op_free(o); /* blow off assign */
3568 right->op_flags &= ~OPf_WANT;
3569 /* "I don't know and I don't care." */
3574 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3575 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3577 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3579 sv_setiv(sv, PL_modcount+1);
3587 right = newOP(OP_UNDEF, 0);
3588 if (right->op_type == OP_READLINE) {
3589 right->op_flags |= OPf_STACKED;
3590 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3593 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3594 o = newBINOP(OP_SASSIGN, flags,
3595 scalar(right), mod(scalar(left), OP_SASSIGN) );
3607 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3609 U32 seq = intro_my();
3612 NewOp(1101, cop, 1, COP);
3613 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3614 cop->op_type = OP_DBSTATE;
3615 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3618 cop->op_type = OP_NEXTSTATE;
3619 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3621 cop->op_flags = flags;
3622 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3624 cop->op_private |= NATIVE_HINTS;
3626 PL_compiling.op_private = cop->op_private;
3627 cop->op_next = (OP*)cop;
3630 cop->cop_label = label;
3631 PL_hints |= HINT_BLOCK_SCOPE;
3634 cop->cop_arybase = PL_curcop->cop_arybase;
3635 if (specialWARN(PL_curcop->cop_warnings))
3636 cop->cop_warnings = PL_curcop->cop_warnings ;
3638 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3639 if (specialCopIO(PL_curcop->cop_io))
3640 cop->cop_io = PL_curcop->cop_io;
3642 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3645 if (PL_copline == NOLINE)
3646 CopLINE_set(cop, CopLINE(PL_curcop));
3648 CopLINE_set(cop, PL_copline);
3649 PL_copline = NOLINE;
3652 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3654 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3656 CopSTASH_set(cop, PL_curstash);
3658 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3659 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3660 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3661 (void)SvIOK_on(*svp);
3662 SvIVX(*svp) = PTR2IV(cop);
3666 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3669 /* "Introduce" my variables to visible status. */
3677 if (! PL_min_intro_pending)
3678 return PL_cop_seqmax;
3680 svp = AvARRAY(PL_comppad_name);
3681 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3682 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3683 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3684 SvNVX(sv) = (NV)PL_cop_seqmax;
3687 PL_min_intro_pending = 0;
3688 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3689 return PL_cop_seqmax++;
3693 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3695 return new_logop(type, flags, &first, &other);
3699 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3703 OP *first = *firstp;
3704 OP *other = *otherp;
3706 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3707 return newBINOP(type, flags, scalar(first), scalar(other));
3709 scalarboolean(first);
3710 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3711 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3712 if (type == OP_AND || type == OP_OR) {
3718 first = *firstp = cUNOPo->op_first;
3720 first->op_next = o->op_next;
3721 cUNOPo->op_first = Nullop;
3725 if (first->op_type == OP_CONST) {
3726 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3727 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3728 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3739 else if (first->op_type == OP_WANTARRAY) {
3745 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3746 OP *k1 = ((UNOP*)first)->op_first;
3747 OP *k2 = k1->op_sibling;
3749 switch (first->op_type)
3752 if (k2 && k2->op_type == OP_READLINE
3753 && (k2->op_flags & OPf_STACKED)
3754 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3756 warnop = k2->op_type;
3761 if (k1->op_type == OP_READDIR
3762 || k1->op_type == OP_GLOB
3763 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3764 || k1->op_type == OP_EACH)
3766 warnop = ((k1->op_type == OP_NULL)
3767 ? k1->op_targ : k1->op_type);
3772 line_t oldline = CopLINE(PL_curcop);
3773 CopLINE_set(PL_curcop, PL_copline);
3774 Perl_warner(aTHX_ WARN_MISC,
3775 "Value of %s%s can be \"0\"; test with defined()",
3777 ((warnop == OP_READLINE || warnop == OP_GLOB)
3778 ? " construct" : "() operator"));
3779 CopLINE_set(PL_curcop, oldline);
3786 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3787 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3789 NewOp(1101, logop, 1, LOGOP);
3791 logop->op_type = type;
3792 logop->op_ppaddr = PL_ppaddr[type];
3793 logop->op_first = first;
3794 logop->op_flags = flags | OPf_KIDS;
3795 logop->op_other = LINKLIST(other);
3796 logop->op_private = 1 | (flags >> 8);
3798 /* establish postfix order */
3799 logop->op_next = LINKLIST(first);
3800 first->op_next = (OP*)logop;
3801 first->op_sibling = other;
3803 o = newUNOP(OP_NULL, 0, (OP*)logop);
3810 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3817 return newLOGOP(OP_AND, 0, first, trueop);
3819 return newLOGOP(OP_OR, 0, first, falseop);
3821 scalarboolean(first);
3822 if (first->op_type == OP_CONST) {
3823 if (SvTRUE(((SVOP*)first)->op_sv)) {
3834 else if (first->op_type == OP_WANTARRAY) {
3838 NewOp(1101, logop, 1, LOGOP);
3839 logop->op_type = OP_COND_EXPR;
3840 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3841 logop->op_first = first;
3842 logop->op_flags = flags | OPf_KIDS;
3843 logop->op_private = 1 | (flags >> 8);
3844 logop->op_other = LINKLIST(trueop);
3845 logop->op_next = LINKLIST(falseop);
3848 /* establish postfix order */
3849 start = LINKLIST(first);
3850 first->op_next = (OP*)logop;
3852 first->op_sibling = trueop;
3853 trueop->op_sibling = falseop;
3854 o = newUNOP(OP_NULL, 0, (OP*)logop);
3856 trueop->op_next = falseop->op_next = o;
3863 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3871 NewOp(1101, range, 1, LOGOP);
3873 range->op_type = OP_RANGE;
3874 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3875 range->op_first = left;
3876 range->op_flags = OPf_KIDS;
3877 leftstart = LINKLIST(left);
3878 range->op_other = LINKLIST(right);
3879 range->op_private = 1 | (flags >> 8);
3881 left->op_sibling = right;
3883 range->op_next = (OP*)range;
3884 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3885 flop = newUNOP(OP_FLOP, 0, flip);
3886 o = newUNOP(OP_NULL, 0, flop);
3888 range->op_next = leftstart;
3890 left->op_next = flip;
3891 right->op_next = flop;
3893 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3894 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3895 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3896 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3898 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3899 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3902 if (!flip->op_private || !flop->op_private)
3903 linklist(o); /* blow off optimizer unless constant */
3909 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3913 int once = block && block->op_flags & OPf_SPECIAL &&
3914 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3917 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3918 return block; /* do {} while 0 does once */
3919 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3920 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3921 expr = newUNOP(OP_DEFINED, 0,
3922 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3923 } else if (expr->op_flags & OPf_KIDS) {
3924 OP *k1 = ((UNOP*)expr)->op_first;
3925 OP *k2 = (k1) ? k1->op_sibling : NULL;
3926 switch (expr->op_type) {
3928 if (k2 && k2->op_type == OP_READLINE
3929 && (k2->op_flags & OPf_STACKED)
3930 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3931 expr = newUNOP(OP_DEFINED, 0, expr);
3935 if (k1->op_type == OP_READDIR
3936 || k1->op_type == OP_GLOB
3937 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3938 || k1->op_type == OP_EACH)
3939 expr = newUNOP(OP_DEFINED, 0, expr);
3945 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3946 o = new_logop(OP_AND, 0, &expr, &listop);
3949 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3951 if (once && o != listop)
3952 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3955 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3957 o->op_flags |= flags;
3959 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3964 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3973 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3974 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3975 expr = newUNOP(OP_DEFINED, 0,
3976 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3977 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3978 OP *k1 = ((UNOP*)expr)->op_first;
3979 OP *k2 = (k1) ? k1->op_sibling : NULL;
3980 switch (expr->op_type) {
3982 if (k2 && k2->op_type == OP_READLINE
3983 && (k2->op_flags & OPf_STACKED)
3984 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3985 expr = newUNOP(OP_DEFINED, 0, expr);
3989 if (k1->op_type == OP_READDIR
3990 || k1->op_type == OP_GLOB
3991 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3992 || k1->op_type == OP_EACH)
3993 expr = newUNOP(OP_DEFINED, 0, expr);
3999 block = newOP(OP_NULL, 0);
4001 block = scope(block);
4005 next = LINKLIST(cont);
4008 OP *unstack = newOP(OP_UNSTACK, 0);
4011 cont = append_elem(OP_LINESEQ, cont, unstack);
4012 if ((line_t)whileline != NOLINE) {
4013 PL_copline = whileline;
4014 cont = append_elem(OP_LINESEQ, cont,
4015 newSTATEOP(0, Nullch, Nullop));
4019 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4020 redo = LINKLIST(listop);
4023 PL_copline = whileline;
4025 o = new_logop(OP_AND, 0, &expr, &listop);
4026 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4027 op_free(expr); /* oops, it's a while (0) */
4029 return Nullop; /* listop already freed by new_logop */
4032 ((LISTOP*)listop)->op_last->op_next = condop =
4033 (o == listop ? redo : LINKLIST(o));
4039 NewOp(1101,loop,1,LOOP);
4040 loop->op_type = OP_ENTERLOOP;
4041 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4042 loop->op_private = 0;
4043 loop->op_next = (OP*)loop;
4046 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4048 loop->op_redoop = redo;
4049 loop->op_lastop = o;
4050 o->op_private |= loopflags;
4053 loop->op_nextop = next;
4055 loop->op_nextop = o;
4057 o->op_flags |= flags;
4058 o->op_private |= (flags >> 8);
4063 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4071 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4072 sv->op_type = OP_RV2GV;
4073 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4075 else if (sv->op_type == OP_PADSV) { /* private variable */
4076 padoff = sv->op_targ;
4081 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4082 padoff = sv->op_targ;
4084 iterflags |= OPf_SPECIAL;
4089 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4093 padoff = find_threadsv("_");
4094 iterflags |= OPf_SPECIAL;
4096 sv = newGVOP(OP_GV, 0, PL_defgv);
4099 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4100 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4101 iterflags |= OPf_STACKED;
4103 else if (expr->op_type == OP_NULL &&
4104 (expr->op_flags & OPf_KIDS) &&
4105 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4107 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4108 * set the STACKED flag to indicate that these values are to be
4109 * treated as min/max values by 'pp_iterinit'.
4111 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4112 LOGOP* range = (LOGOP*) flip->op_first;
4113 OP* left = range->op_first;
4114 OP* right = left->op_sibling;
4117 range->op_flags &= ~OPf_KIDS;
4118 range->op_first = Nullop;
4120 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4121 listop->op_first->op_next = range->op_next;
4122 left->op_next = range->op_other;
4123 right->op_next = (OP*)listop;
4124 listop->op_next = listop->op_first;
4127 expr = (OP*)(listop);
4129 iterflags |= OPf_STACKED;
4132 expr = mod(force_list(expr), OP_GREPSTART);
4136 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4137 append_elem(OP_LIST, expr, scalar(sv))));
4138 assert(!loop->op_next);
4139 #ifdef PL_OP_SLAB_ALLOC
4142 NewOp(1234,tmp,1,LOOP);
4143 Copy(loop,tmp,1,LOOP);
4147 Renew(loop, 1, LOOP);
4149 loop->op_targ = padoff;
4150 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4151 PL_copline = forline;
4152 return newSTATEOP(0, label, wop);
4156 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4161 if (type != OP_GOTO || label->op_type == OP_CONST) {
4162 /* "last()" means "last" */
4163 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4164 o = newOP(type, OPf_SPECIAL);
4166 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4167 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4173 if (label->op_type == OP_ENTERSUB)
4174 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4175 o = newUNOP(type, OPf_STACKED, label);
4177 PL_hints |= HINT_BLOCK_SCOPE;
4182 Perl_cv_undef(pTHX_ CV *cv)
4186 MUTEX_DESTROY(CvMUTEXP(cv));
4187 Safefree(CvMUTEXP(cv));
4190 #endif /* USE_THREADS */
4192 if (!CvXSUB(cv) && CvROOT(cv)) {
4194 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4195 Perl_croak(aTHX_ "Can't undef active subroutine");
4198 Perl_croak(aTHX_ "Can't undef active subroutine");
4199 #endif /* USE_THREADS */
4202 SAVEVPTR(PL_curpad);
4205 op_free(CvROOT(cv));
4206 CvROOT(cv) = Nullop;
4209 SvPOK_off((SV*)cv); /* forget prototype */
4211 /* Since closure prototypes have the same lifetime as the containing
4212 * CV, they don't hold a refcount on the outside CV. This avoids
4213 * the refcount loop between the outer CV (which keeps a refcount to
4214 * the closure prototype in the pad entry for pp_anoncode()) and the
4215 * closure prototype, and the ensuing memory leak. --GSAR */
4216 if (!CvANON(cv) || CvCLONED(cv))
4217 SvREFCNT_dec(CvOUTSIDE(cv));
4218 CvOUTSIDE(cv) = Nullcv;
4220 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4223 if (CvPADLIST(cv)) {
4224 /* may be during global destruction */
4225 if (SvREFCNT(CvPADLIST(cv))) {
4226 I32 i = AvFILLp(CvPADLIST(cv));
4228 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4229 SV* sv = svp ? *svp : Nullsv;
4232 if (sv == (SV*)PL_comppad_name)
4233 PL_comppad_name = Nullav;
4234 else if (sv == (SV*)PL_comppad) {
4235 PL_comppad = Nullav;
4236 PL_curpad = Null(SV**);
4240 SvREFCNT_dec((SV*)CvPADLIST(cv));
4242 CvPADLIST(cv) = Nullav;
4247 #ifdef DEBUG_CLOSURES
4249 S_cv_dump(pTHX_ CV *cv)
4252 CV *outside = CvOUTSIDE(cv);
4253 AV* padlist = CvPADLIST(cv);
4260 PerlIO_printf(Perl_debug_log,
4261 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4263 (CvANON(cv) ? "ANON"
4264 : (cv == PL_main_cv) ? "MAIN"
4265 : CvUNIQUE(cv) ? "UNIQUE"
4266 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4269 : CvANON(outside) ? "ANON"
4270 : (outside == PL_main_cv) ? "MAIN"
4271 : CvUNIQUE(outside) ? "UNIQUE"
4272 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4277 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4278 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4279 pname = AvARRAY(pad_name);
4280 ppad = AvARRAY(pad);
4282 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4283 if (SvPOK(pname[ix]))
4284 PerlIO_printf(Perl_debug_log,
4285 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4286 (int)ix, PTR2UV(ppad[ix]),
4287 SvFAKE(pname[ix]) ? "FAKE " : "",
4289 (IV)I_32(SvNVX(pname[ix])),
4292 #endif /* DEBUGGING */
4294 #endif /* DEBUG_CLOSURES */
4297 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4301 AV* protopadlist = CvPADLIST(proto);
4302 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4303 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4304 SV** pname = AvARRAY(protopad_name);
4305 SV** ppad = AvARRAY(protopad);
4306 I32 fname = AvFILLp(protopad_name);
4307 I32 fpad = AvFILLp(protopad);
4311 assert(!CvUNIQUE(proto));
4315 SAVESPTR(PL_comppad_name);
4316 SAVESPTR(PL_compcv);
4318 cv = PL_compcv = (CV*)NEWSV(1104,0);
4319 sv_upgrade((SV *)cv, SvTYPE(proto));
4320 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4324 New(666, CvMUTEXP(cv), 1, perl_mutex);
4325 MUTEX_INIT(CvMUTEXP(cv));
4327 #endif /* USE_THREADS */
4328 CvFILE(cv) = CvFILE(proto);
4329 CvGV(cv) = CvGV(proto);
4330 CvSTASH(cv) = CvSTASH(proto);
4331 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4332 CvSTART(cv) = CvSTART(proto);
4334 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4337 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4339 PL_comppad_name = newAV();
4340 for (ix = fname; ix >= 0; ix--)
4341 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4343 PL_comppad = newAV();
4345 comppadlist = newAV();
4346 AvREAL_off(comppadlist);
4347 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4348 av_store(comppadlist, 1, (SV*)PL_comppad);
4349 CvPADLIST(cv) = comppadlist;
4350 av_fill(PL_comppad, AvFILLp(protopad));
4351 PL_curpad = AvARRAY(PL_comppad);
4353 av = newAV(); /* will be @_ */
4355 av_store(PL_comppad, 0, (SV*)av);
4356 AvFLAGS(av) = AVf_REIFY;
4358 for (ix = fpad; ix > 0; ix--) {
4359 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4360 if (namesv && namesv != &PL_sv_undef) {
4361 char *name = SvPVX(namesv); /* XXX */
4362 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4363 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4364 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4366 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4368 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4370 else { /* our own lexical */
4373 /* anon code -- we'll come back for it */
4374 sv = SvREFCNT_inc(ppad[ix]);
4376 else if (*name == '@')
4378 else if (*name == '%')
4387 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4388 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4391 SV* sv = NEWSV(0,0);
4397 /* Now that vars are all in place, clone nested closures. */
4399 for (ix = fpad; ix > 0; ix--) {
4400 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4402 && namesv != &PL_sv_undef
4403 && !(SvFLAGS(namesv) & SVf_FAKE)
4404 && *SvPVX(namesv) == '&'
4405 && CvCLONE(ppad[ix]))
4407 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4408 SvREFCNT_dec(ppad[ix]);
4411 PL_curpad[ix] = (SV*)kid;
4415 #ifdef DEBUG_CLOSURES
4416 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4418 PerlIO_printf(Perl_debug_log, " from:\n");
4420 PerlIO_printf(Perl_debug_log, " to:\n");
4427 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4429 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4431 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4438 Perl_cv_clone(pTHX_ CV *proto)
4441 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4442 cv = cv_clone2(proto, CvOUTSIDE(proto));
4443 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4448 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4450 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4451 SV* msg = sv_newmortal();
4455 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4456 sv_setpv(msg, "Prototype mismatch:");
4458 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4460 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4461 sv_catpv(msg, " vs ");
4463 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4465 sv_catpv(msg, "none");
4466 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4470 static void const_sv_xsub(pTHXo_ CV* cv);
4473 =for apidoc cv_const_sv
4475 If C<cv> is a constant sub eligible for inlining. returns the constant
4476 value returned by the sub. Otherwise, returns NULL.
4478 Constant subs can be created with C<newCONSTSUB> or as described in
4479 L<perlsub/"Constant Functions">.
4484 Perl_cv_const_sv(pTHX_ CV *cv)
4486 if (!cv || !CvCONST(cv))
4488 return (SV*)CvXSUBANY(cv).any_ptr;
4492 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4499 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4500 o = cLISTOPo->op_first->op_sibling;
4502 for (; o; o = o->op_next) {
4503 OPCODE type = o->op_type;
4505 if (sv && o->op_next == o)
4507 if (o->op_next != o) {
4508 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4510 if (type == OP_DBSTATE)
4513 if (type == OP_LEAVESUB || type == OP_RETURN)
4517 if (type == OP_CONST && cSVOPo->op_sv)
4519 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4520 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4521 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4525 /* We get here only from cv_clone2() while creating a closure.
4526 Copy the const value here instead of in cv_clone2 so that
4527 SvREADONLY_on doesn't lead to problems when leaving
4532 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4544 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4554 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4558 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4560 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4564 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4570 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4575 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4576 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4577 SV *sv = sv_newmortal();
4578 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4579 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4584 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4585 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4595 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4596 maximum a prototype before. */
4597 if (SvTYPE(gv) > SVt_NULL) {
4598 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4599 && ckWARN_d(WARN_PROTOTYPE))
4601 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4603 cv_ckproto((CV*)gv, NULL, ps);
4606 sv_setpv((SV*)gv, ps);
4608 sv_setiv((SV*)gv, -1);
4609 SvREFCNT_dec(PL_compcv);
4610 cv = PL_compcv = NULL;
4611 PL_sub_generation++;
4615 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4617 #ifdef GV_SHARED_CHECK
4618 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4619 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4623 if (!block || !ps || *ps || attrs)
4626 const_sv = op_const_sv(block, Nullcv);
4629 bool exists = CvROOT(cv) || CvXSUB(cv);
4631 #ifdef GV_SHARED_CHECK
4632 if (exists && GvSHARED(gv)) {
4633 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4637 /* if the subroutine doesn't exist and wasn't pre-declared
4638 * with a prototype, assume it will be AUTOLOADed,
4639 * skipping the prototype check
4641 if (exists || SvPOK(cv))
4642 cv_ckproto(cv, gv, ps);
4643 /* already defined (or promised)? */
4644 if (exists || GvASSUMECV(gv)) {
4645 if (!block && !attrs) {
4646 /* just a "sub foo;" when &foo is already defined */
4647 SAVEFREESV(PL_compcv);
4650 /* ahem, death to those who redefine active sort subs */
4651 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4652 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4654 if (ckWARN(WARN_REDEFINE)
4656 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4658 line_t oldline = CopLINE(PL_curcop);
4659 CopLINE_set(PL_curcop, PL_copline);
4660 Perl_warner(aTHX_ WARN_REDEFINE,
4661 CvCONST(cv) ? "Constant subroutine %s redefined"
4662 : "Subroutine %s redefined", name);
4663 CopLINE_set(PL_curcop, oldline);
4671 SvREFCNT_inc(const_sv);
4673 assert(!CvROOT(cv) && !CvCONST(cv));
4674 sv_setpv((SV*)cv, ""); /* prototype is "" */
4675 CvXSUBANY(cv).any_ptr = const_sv;
4676 CvXSUB(cv) = const_sv_xsub;
4681 cv = newCONSTSUB(NULL, name, const_sv);
4684 SvREFCNT_dec(PL_compcv);
4686 PL_sub_generation++;
4693 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4694 * before we clobber PL_compcv.
4698 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4699 stash = GvSTASH(CvGV(cv));
4700 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4701 stash = CvSTASH(cv);
4703 stash = PL_curstash;
4706 /* possibly about to re-define existing subr -- ignore old cv */
4707 rcv = (SV*)PL_compcv;
4708 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4709 stash = GvSTASH(gv);
4711 stash = PL_curstash;
4713 apply_attrs(stash, rcv, attrs);
4715 if (cv) { /* must reuse cv if autoloaded */
4717 /* got here with just attrs -- work done, so bug out */
4718 SAVEFREESV(PL_compcv);
4722 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4723 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4724 CvOUTSIDE(PL_compcv) = 0;
4725 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4726 CvPADLIST(PL_compcv) = 0;
4727 /* inner references to PL_compcv must be fixed up ... */
4729 AV *padlist = CvPADLIST(cv);
4730 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4731 AV *comppad = (AV*)AvARRAY(padlist)[1];
4732 SV **namepad = AvARRAY(comppad_name);
4733 SV **curpad = AvARRAY(comppad);
4734 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4735 SV *namesv = namepad[ix];
4736 if (namesv && namesv != &PL_sv_undef
4737 && *SvPVX(namesv) == '&')
4739 CV *innercv = (CV*)curpad[ix];
4740 if (CvOUTSIDE(innercv) == PL_compcv) {
4741 CvOUTSIDE(innercv) = cv;
4742 if (!CvANON(innercv) || CvCLONED(innercv)) {
4743 (void)SvREFCNT_inc(cv);
4744 SvREFCNT_dec(PL_compcv);
4750 /* ... before we throw it away */
4751 SvREFCNT_dec(PL_compcv);
4758 PL_sub_generation++;
4762 CvFILE(cv) = CopFILE(PL_curcop);
4763 CvSTASH(cv) = PL_curstash;
4766 if (!CvMUTEXP(cv)) {
4767 New(666, CvMUTEXP(cv), 1, perl_mutex);
4768 MUTEX_INIT(CvMUTEXP(cv));
4770 #endif /* USE_THREADS */
4773 sv_setpv((SV*)cv, ps);
4775 if (PL_error_count) {
4779 char *s = strrchr(name, ':');
4781 if (strEQ(s, "BEGIN")) {
4783 "BEGIN not safe after errors--compilation aborted";
4784 if (PL_in_eval & EVAL_KEEPERR)
4785 Perl_croak(aTHX_ not_safe);
4787 /* force display of errors found but not reported */
4788 sv_catpv(ERRSV, not_safe);
4789 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4797 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4798 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4801 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4802 mod(scalarseq(block), OP_LEAVESUBLV));
4805 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4807 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4808 OpREFCNT_set(CvROOT(cv), 1);
4809 CvSTART(cv) = LINKLIST(CvROOT(cv));
4810 CvROOT(cv)->op_next = 0;
4813 /* now that optimizer has done its work, adjust pad values */
4815 SV **namep = AvARRAY(PL_comppad_name);
4816 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4819 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4822 * The only things that a clonable function needs in its
4823 * pad are references to outer lexicals and anonymous subs.
4824 * The rest are created anew during cloning.
4826 if (!((namesv = namep[ix]) != Nullsv &&
4827 namesv != &PL_sv_undef &&
4829 *SvPVX(namesv) == '&')))
4831 SvREFCNT_dec(PL_curpad[ix]);
4832 PL_curpad[ix] = Nullsv;
4835 assert(!CvCONST(cv));
4836 if (ps && !*ps && op_const_sv(block, cv))
4840 AV *av = newAV(); /* Will be @_ */
4842 av_store(PL_comppad, 0, (SV*)av);
4843 AvFLAGS(av) = AVf_REIFY;
4845 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4846 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4848 if (!SvPADMY(PL_curpad[ix]))
4849 SvPADTMP_on(PL_curpad[ix]);
4853 /* If a potential closure prototype, don't keep a refcount on outer CV.
4854 * This is okay as the lifetime of the prototype is tied to the
4855 * lifetime of the outer CV. Avoids memory leak due to reference
4858 SvREFCNT_dec(CvOUTSIDE(cv));
4860 if (name || aname) {
4862 char *tname = (name ? name : aname);
4864 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4865 SV *sv = NEWSV(0,0);
4866 SV *tmpstr = sv_newmortal();
4867 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4871 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4873 (long)PL_subline, (long)CopLINE(PL_curcop));
4874 gv_efullname3(tmpstr, gv, Nullch);
4875 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4876 hv = GvHVn(db_postponed);
4877 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4878 && (pcv = GvCV(db_postponed)))
4884 call_sv((SV*)pcv, G_DISCARD);
4888 if ((s = strrchr(tname,':')))
4893 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4896 if (strEQ(s, "BEGIN")) {
4897 I32 oldscope = PL_scopestack_ix;
4899 SAVECOPFILE(&PL_compiling);
4900 SAVECOPLINE(&PL_compiling);
4902 sv_setsv(PL_rs, PL_nrs);
4905 PL_beginav = newAV();
4906 DEBUG_x( dump_sub(gv) );
4907 av_push(PL_beginav, (SV*)cv);
4908 GvCV(gv) = 0; /* cv has been hijacked */
4909 call_list(oldscope, PL_beginav);
4911 PL_curcop = &PL_compiling;
4912 PL_compiling.op_private = PL_hints;
4915 else if (strEQ(s, "END") && !PL_error_count) {
4918 DEBUG_x( dump_sub(gv) );
4919 av_unshift(PL_endav, 1);
4920 av_store(PL_endav, 0, (SV*)cv);
4921 GvCV(gv) = 0; /* cv has been hijacked */
4923 else if (strEQ(s, "CHECK") && !PL_error_count) {
4925 PL_checkav = newAV();
4926 DEBUG_x( dump_sub(gv) );
4927 if (PL_main_start && ckWARN(WARN_VOID))
4928 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4929 av_unshift(PL_checkav, 1);
4930 av_store(PL_checkav, 0, (SV*)cv);
4931 GvCV(gv) = 0; /* cv has been hijacked */
4933 else if (strEQ(s, "INIT") && !PL_error_count) {
4935 PL_initav = newAV();
4936 DEBUG_x( dump_sub(gv) );
4937 if (PL_main_start && ckWARN(WARN_VOID))
4938 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4939 av_push(PL_initav, (SV*)cv);
4940 GvCV(gv) = 0; /* cv has been hijacked */
4945 PL_copline = NOLINE;
4950 /* XXX unsafe for threads if eval_owner isn't held */
4952 =for apidoc newCONSTSUB
4954 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4955 eligible for inlining at compile-time.
4961 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4967 SAVECOPLINE(PL_curcop);
4968 CopLINE_set(PL_curcop, PL_copline);
4971 PL_hints &= ~HINT_BLOCK_SCOPE;
4974 SAVESPTR(PL_curstash);
4975 SAVECOPSTASH(PL_curcop);
4976 PL_curstash = stash;
4978 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4980 CopSTASH(PL_curcop) = stash;
4984 cv = newXS(name, const_sv_xsub, __FILE__);
4985 CvXSUBANY(cv).any_ptr = sv;
4987 sv_setpv((SV*)cv, ""); /* prototype is "" */
4995 =for apidoc U||newXS
4997 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5003 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5005 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5008 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5010 /* just a cached method */
5014 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5015 /* already defined (or promised) */
5016 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5017 && HvNAME(GvSTASH(CvGV(cv)))
5018 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5019 line_t oldline = CopLINE(PL_curcop);
5020 if (PL_copline != NOLINE)
5021 CopLINE_set(PL_curcop, PL_copline);
5022 Perl_warner(aTHX_ WARN_REDEFINE,
5023 CvCONST(cv) ? "Constant subroutine %s redefined"
5024 : "Subroutine %s redefined"
5026 CopLINE_set(PL_curcop, oldline);
5033 if (cv) /* must reuse cv if autoloaded */
5036 cv = (CV*)NEWSV(1105,0);
5037 sv_upgrade((SV *)cv, SVt_PVCV);
5041 PL_sub_generation++;
5046 New(666, CvMUTEXP(cv), 1, perl_mutex);
5047 MUTEX_INIT(CvMUTEXP(cv));
5049 #endif /* USE_THREADS */
5050 (void)gv_fetchfile(filename);
5051 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5052 an external constant string */
5053 CvXSUB(cv) = subaddr;
5056 char *s = strrchr(name,':');
5062 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5065 if (strEQ(s, "BEGIN")) {
5067 PL_beginav = newAV();
5068 av_push(PL_beginav, (SV*)cv);
5069 GvCV(gv) = 0; /* cv has been hijacked */
5071 else if (strEQ(s, "END")) {
5074 av_unshift(PL_endav, 1);
5075 av_store(PL_endav, 0, (SV*)cv);
5076 GvCV(gv) = 0; /* cv has been hijacked */
5078 else if (strEQ(s, "CHECK")) {
5080 PL_checkav = newAV();
5081 if (PL_main_start && ckWARN(WARN_VOID))
5082 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5083 av_unshift(PL_checkav, 1);
5084 av_store(PL_checkav, 0, (SV*)cv);
5085 GvCV(gv) = 0; /* cv has been hijacked */
5087 else if (strEQ(s, "INIT")) {
5089 PL_initav = newAV();
5090 if (PL_main_start && ckWARN(WARN_VOID))
5091 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5092 av_push(PL_initav, (SV*)cv);
5093 GvCV(gv) = 0; /* cv has been hijacked */
5104 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5113 name = SvPVx(cSVOPo->op_sv, n_a);
5116 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5117 #ifdef GV_SHARED_CHECK
5119 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5123 if ((cv = GvFORM(gv))) {
5124 if (ckWARN(WARN_REDEFINE)) {
5125 line_t oldline = CopLINE(PL_curcop);
5127 CopLINE_set(PL_curcop, PL_copline);
5128 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5129 CopLINE_set(PL_curcop, oldline);
5136 CvFILE(cv) = CopFILE(PL_curcop);
5138 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5139 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5140 SvPADTMP_on(PL_curpad[ix]);
5143 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5144 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5145 OpREFCNT_set(CvROOT(cv), 1);
5146 CvSTART(cv) = LINKLIST(CvROOT(cv));
5147 CvROOT(cv)->op_next = 0;
5150 PL_copline = NOLINE;
5155 Perl_newANONLIST(pTHX_ OP *o)
5157 return newUNOP(OP_REFGEN, 0,
5158 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5162 Perl_newANONHASH(pTHX_ OP *o)
5164 return newUNOP(OP_REFGEN, 0,
5165 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5169 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5171 return newANONATTRSUB(floor, proto, Nullop, block);
5175 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5177 return newUNOP(OP_REFGEN, 0,
5178 newSVOP(OP_ANONCODE, 0,
5179 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5183 Perl_oopsAV(pTHX_ OP *o)
5185 switch (o->op_type) {
5187 o->op_type = OP_PADAV;
5188 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5189 return ref(o, OP_RV2AV);
5192 o->op_type = OP_RV2AV;
5193 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5198 if (ckWARN_d(WARN_INTERNAL))
5199 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5206 Perl_oopsHV(pTHX_ OP *o)
5208 switch (o->op_type) {
5211 o->op_type = OP_PADHV;
5212 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5213 return ref(o, OP_RV2HV);
5217 o->op_type = OP_RV2HV;
5218 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5223 if (ckWARN_d(WARN_INTERNAL))
5224 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5231 Perl_newAVREF(pTHX_ OP *o)
5233 if (o->op_type == OP_PADANY) {
5234 o->op_type = OP_PADAV;
5235 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5238 return newUNOP(OP_RV2AV, 0, scalar(o));
5242 Perl_newGVREF(pTHX_ I32 type, OP *o)
5244 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5245 return newUNOP(OP_NULL, 0, o);
5246 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5250 Perl_newHVREF(pTHX_ OP *o)
5252 if (o->op_type == OP_PADANY) {
5253 o->op_type = OP_PADHV;
5254 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5257 return newUNOP(OP_RV2HV, 0, scalar(o));
5261 Perl_oopsCV(pTHX_ OP *o)
5263 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5269 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5271 return newUNOP(OP_RV2CV, flags, scalar(o));
5275 Perl_newSVREF(pTHX_ OP *o)
5277 if (o->op_type == OP_PADANY) {
5278 o->op_type = OP_PADSV;
5279 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5282 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5283 o->op_flags |= OPpDONE_SVREF;
5286 return newUNOP(OP_RV2SV, 0, scalar(o));
5289 /* Check routines. */
5292 Perl_ck_anoncode(pTHX_ OP *o)
5297 name = NEWSV(1106,0);
5298 sv_upgrade(name, SVt_PVNV);
5299 sv_setpvn(name, "&", 1);
5302 ix = pad_alloc(o->op_type, SVs_PADMY);
5303 av_store(PL_comppad_name, ix, name);
5304 av_store(PL_comppad, ix, cSVOPo->op_sv);
5305 SvPADMY_on(cSVOPo->op_sv);
5306 cSVOPo->op_sv = Nullsv;
5307 cSVOPo->op_targ = ix;
5312 Perl_ck_bitop(pTHX_ OP *o)
5314 o->op_private = PL_hints;
5319 Perl_ck_concat(pTHX_ OP *o)
5321 if (cUNOPo->op_first->op_type == OP_CONCAT)
5322 o->op_flags |= OPf_STACKED;
5327 Perl_ck_spair(pTHX_ OP *o)
5329 if (o->op_flags & OPf_KIDS) {
5332 OPCODE type = o->op_type;
5333 o = modkids(ck_fun(o), type);
5334 kid = cUNOPo->op_first;
5335 newop = kUNOP->op_first->op_sibling;
5337 (newop->op_sibling ||
5338 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5339 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5340 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5344 op_free(kUNOP->op_first);
5345 kUNOP->op_first = newop;
5347 o->op_ppaddr = PL_ppaddr[++o->op_type];
5352 Perl_ck_delete(pTHX_ OP *o)
5356 if (o->op_flags & OPf_KIDS) {
5357 OP *kid = cUNOPo->op_first;
5358 switch (kid->op_type) {
5360 o->op_flags |= OPf_SPECIAL;
5363 o->op_private |= OPpSLICE;
5366 o->op_flags |= OPf_SPECIAL;
5371 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5372 PL_op_desc[o->op_type]);
5380 Perl_ck_eof(pTHX_ OP *o)
5382 I32 type = o->op_type;
5384 if (o->op_flags & OPf_KIDS) {
5385 if (cLISTOPo->op_first->op_type == OP_STUB) {
5387 o = newUNOP(type, OPf_SPECIAL,
5388 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5396 Perl_ck_eval(pTHX_ OP *o)
5398 PL_hints |= HINT_BLOCK_SCOPE;
5399 if (o->op_flags & OPf_KIDS) {
5400 SVOP *kid = (SVOP*)cUNOPo->op_first;
5403 o->op_flags &= ~OPf_KIDS;
5406 else if (kid->op_type == OP_LINESEQ) {
5409 kid->op_next = o->op_next;
5410 cUNOPo->op_first = 0;
5413 NewOp(1101, enter, 1, LOGOP);
5414 enter->op_type = OP_ENTERTRY;
5415 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5416 enter->op_private = 0;
5418 /* establish postfix order */
5419 enter->op_next = (OP*)enter;
5421 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5422 o->op_type = OP_LEAVETRY;
5423 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5424 enter->op_other = o;
5432 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5434 o->op_targ = (PADOFFSET)PL_hints;
5439 Perl_ck_exit(pTHX_ OP *o)
5442 HV *table = GvHV(PL_hintgv);
5444 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5445 if (svp && *svp && SvTRUE(*svp))
5446 o->op_private |= OPpEXIT_VMSISH;
5453 Perl_ck_exec(pTHX_ OP *o)
5456 if (o->op_flags & OPf_STACKED) {
5458 kid = cUNOPo->op_first->op_sibling;
5459 if (kid->op_type == OP_RV2GV)
5468 Perl_ck_exists(pTHX_ OP *o)
5471 if (o->op_flags & OPf_KIDS) {
5472 OP *kid = cUNOPo->op_first;
5473 if (kid->op_type == OP_ENTERSUB) {
5474 (void) ref(kid, o->op_type);
5475 if (kid->op_type != OP_RV2CV && !PL_error_count)
5476 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5477 PL_op_desc[o->op_type]);
5478 o->op_private |= OPpEXISTS_SUB;
5480 else if (kid->op_type == OP_AELEM)
5481 o->op_flags |= OPf_SPECIAL;
5482 else if (kid->op_type != OP_HELEM)
5483 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5484 PL_op_desc[o->op_type]);
5492 Perl_ck_gvconst(pTHX_ register OP *o)
5494 o = fold_constants(o);
5495 if (o->op_type == OP_CONST)
5502 Perl_ck_rvconst(pTHX_ register OP *o)
5504 SVOP *kid = (SVOP*)cUNOPo->op_first;
5506 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5507 if (kid->op_type == OP_CONST) {
5511 SV *kidsv = kid->op_sv;
5514 /* Is it a constant from cv_const_sv()? */
5515 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5516 SV *rsv = SvRV(kidsv);
5517 int svtype = SvTYPE(rsv);
5518 char *badtype = Nullch;
5520 switch (o->op_type) {
5522 if (svtype > SVt_PVMG)
5523 badtype = "a SCALAR";
5526 if (svtype != SVt_PVAV)
5527 badtype = "an ARRAY";
5530 if (svtype != SVt_PVHV) {
5531 if (svtype == SVt_PVAV) { /* pseudohash? */
5532 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5533 if (ksv && SvROK(*ksv)
5534 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5543 if (svtype != SVt_PVCV)
5548 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5551 name = SvPV(kidsv, n_a);
5552 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5553 char *badthing = Nullch;
5554 switch (o->op_type) {
5556 badthing = "a SCALAR";
5559 badthing = "an ARRAY";
5562 badthing = "a HASH";
5567 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5571 * This is a little tricky. We only want to add the symbol if we
5572 * didn't add it in the lexer. Otherwise we get duplicate strict
5573 * warnings. But if we didn't add it in the lexer, we must at
5574 * least pretend like we wanted to add it even if it existed before,
5575 * or we get possible typo warnings. OPpCONST_ENTERED says
5576 * whether the lexer already added THIS instance of this symbol.
5578 iscv = (o->op_type == OP_RV2CV) * 2;
5580 gv = gv_fetchpv(name,
5581 iscv | !(kid->op_private & OPpCONST_ENTERED),
5584 : o->op_type == OP_RV2SV
5586 : o->op_type == OP_RV2AV
5588 : o->op_type == OP_RV2HV
5591 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5593 kid->op_type = OP_GV;
5594 SvREFCNT_dec(kid->op_sv);
5596 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5597 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5598 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5600 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5602 kid->op_sv = SvREFCNT_inc(gv);
5604 kid->op_private = 0;
5605 kid->op_ppaddr = PL_ppaddr[OP_GV];
5612 Perl_ck_ftst(pTHX_ OP *o)
5614 I32 type = o->op_type;
5616 if (o->op_flags & OPf_REF) {
5619 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5620 SVOP *kid = (SVOP*)cUNOPo->op_first;
5622 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5624 OP *newop = newGVOP(type, OPf_REF,
5625 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5632 if (type == OP_FTTTY)
5633 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5636 o = newUNOP(type, 0, newDEFSVOP());
5639 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5641 if (PL_hints & HINT_LOCALE)
5642 o->op_private |= OPpLOCALE;
5649 Perl_ck_fun(pTHX_ OP *o)
5655 int type = o->op_type;
5656 register I32 oa = PL_opargs[type] >> OASHIFT;
5658 if (o->op_flags & OPf_STACKED) {
5659 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5662 return no_fh_allowed(o);
5665 if (o->op_flags & OPf_KIDS) {
5667 tokid = &cLISTOPo->op_first;
5668 kid = cLISTOPo->op_first;
5669 if (kid->op_type == OP_PUSHMARK ||
5670 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5672 tokid = &kid->op_sibling;
5673 kid = kid->op_sibling;
5675 if (!kid && PL_opargs[type] & OA_DEFGV)
5676 *tokid = kid = newDEFSVOP();
5680 sibl = kid->op_sibling;
5683 /* list seen where single (scalar) arg expected? */
5684 if (numargs == 1 && !(oa >> 4)
5685 && kid->op_type == OP_LIST && type != OP_SCALAR)
5687 return too_many_arguments(o,PL_op_desc[type]);
5700 if ((type == OP_PUSH || type == OP_UNSHIFT)
5701 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5702 Perl_warner(aTHX_ WARN_SYNTAX,
5703 "Useless use of %s with no values",
5706 if (kid->op_type == OP_CONST &&
5707 (kid->op_private & OPpCONST_BARE))
5709 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5710 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5711 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5712 if (ckWARN(WARN_DEPRECATED))
5713 Perl_warner(aTHX_ WARN_DEPRECATED,
5714 "Array @%s missing the @ in argument %"IVdf" of %s()",
5715 name, (IV)numargs, PL_op_desc[type]);
5718 kid->op_sibling = sibl;
5721 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5722 bad_type(numargs, "array", PL_op_desc[type], kid);
5726 if (kid->op_type == OP_CONST &&
5727 (kid->op_private & OPpCONST_BARE))
5729 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5730 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5731 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5732 if (ckWARN(WARN_DEPRECATED))
5733 Perl_warner(aTHX_ WARN_DEPRECATED,
5734 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5735 name, (IV)numargs, PL_op_desc[type]);
5738 kid->op_sibling = sibl;
5741 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5742 bad_type(numargs, "hash", PL_op_desc[type], kid);
5747 OP *newop = newUNOP(OP_NULL, 0, kid);
5748 kid->op_sibling = 0;
5750 newop->op_next = newop;
5752 kid->op_sibling = sibl;
5757 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5758 if (kid->op_type == OP_CONST &&
5759 (kid->op_private & OPpCONST_BARE))
5761 OP *newop = newGVOP(OP_GV, 0,
5762 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5767 else if (kid->op_type == OP_READLINE) {
5768 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5769 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5772 I32 flags = OPf_SPECIAL;
5776 /* is this op a FH constructor? */
5777 if (is_handle_constructor(o,numargs)) {
5778 char *name = Nullch;
5782 /* Set a flag to tell rv2gv to vivify
5783 * need to "prove" flag does not mean something
5784 * else already - NI-S 1999/05/07
5787 if (kid->op_type == OP_PADSV) {
5788 SV **namep = av_fetch(PL_comppad_name,
5790 if (namep && *namep)
5791 name = SvPV(*namep, len);
5793 else if (kid->op_type == OP_RV2SV
5794 && kUNOP->op_first->op_type == OP_GV)
5796 GV *gv = cGVOPx_gv(kUNOP->op_first);
5798 len = GvNAMELEN(gv);
5800 else if (kid->op_type == OP_AELEM
5801 || kid->op_type == OP_HELEM)
5803 name = "__ANONIO__";
5809 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5810 namesv = PL_curpad[targ];
5811 (void)SvUPGRADE(namesv, SVt_PV);
5813 sv_setpvn(namesv, "$", 1);
5814 sv_catpvn(namesv, name, len);
5817 kid->op_sibling = 0;
5818 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5819 kid->op_targ = targ;
5820 kid->op_private |= priv;
5822 kid->op_sibling = sibl;
5828 mod(scalar(kid), type);
5832 tokid = &kid->op_sibling;
5833 kid = kid->op_sibling;
5835 o->op_private |= numargs;
5837 return too_many_arguments(o,PL_op_desc[o->op_type]);
5840 else if (PL_opargs[type] & OA_DEFGV) {
5842 return newUNOP(type, 0, newDEFSVOP());
5846 while (oa & OA_OPTIONAL)
5848 if (oa && oa != OA_LIST)
5849 return too_few_arguments(o,PL_op_desc[o->op_type]);
5855 Perl_ck_glob(pTHX_ OP *o)
5860 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5861 append_elem(OP_GLOB, o, newDEFSVOP());
5863 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5864 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5866 #if !defined(PERL_EXTERNAL_GLOB)
5867 /* XXX this can be tightened up and made more failsafe. */
5871 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5873 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5874 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5875 GvCV(gv) = GvCV(glob_gv);
5876 SvREFCNT_inc((SV*)GvCV(gv));
5877 GvIMPORTED_CV_on(gv);
5880 #endif /* PERL_EXTERNAL_GLOB */
5882 if (gv && GvIMPORTED_CV(gv)) {
5883 append_elem(OP_GLOB, o,
5884 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5885 o->op_type = OP_LIST;
5886 o->op_ppaddr = PL_ppaddr[OP_LIST];
5887 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5888 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5889 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5890 append_elem(OP_LIST, o,
5891 scalar(newUNOP(OP_RV2CV, 0,
5892 newGVOP(OP_GV, 0, gv)))));
5893 o = newUNOP(OP_NULL, 0, ck_subr(o));
5894 o->op_targ = OP_GLOB; /* hint at what it used to be */
5897 gv = newGVgen("main");
5899 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5905 Perl_ck_grep(pTHX_ OP *o)
5909 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5911 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5912 NewOp(1101, gwop, 1, LOGOP);
5914 if (o->op_flags & OPf_STACKED) {
5917 kid = cLISTOPo->op_first->op_sibling;
5918 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5921 kid->op_next = (OP*)gwop;
5922 o->op_flags &= ~OPf_STACKED;
5924 kid = cLISTOPo->op_first->op_sibling;
5925 if (type == OP_MAPWHILE)
5932 kid = cLISTOPo->op_first->op_sibling;
5933 if (kid->op_type != OP_NULL)
5934 Perl_croak(aTHX_ "panic: ck_grep");
5935 kid = kUNOP->op_first;
5937 gwop->op_type = type;
5938 gwop->op_ppaddr = PL_ppaddr[type];
5939 gwop->op_first = listkids(o);
5940 gwop->op_flags |= OPf_KIDS;
5941 gwop->op_private = 1;
5942 gwop->op_other = LINKLIST(kid);
5943 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5944 kid->op_next = (OP*)gwop;
5946 kid = cLISTOPo->op_first->op_sibling;
5947 if (!kid || !kid->op_sibling)
5948 return too_few_arguments(o,PL_op_desc[o->op_type]);
5949 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5950 mod(kid, OP_GREPSTART);
5956 Perl_ck_index(pTHX_ OP *o)
5958 if (o->op_flags & OPf_KIDS) {
5959 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5961 kid = kid->op_sibling; /* get past "big" */
5962 if (kid && kid->op_type == OP_CONST)
5963 fbm_compile(((SVOP*)kid)->op_sv, 0);
5969 Perl_ck_lengthconst(pTHX_ OP *o)
5971 /* XXX length optimization goes here */
5976 Perl_ck_lfun(pTHX_ OP *o)
5978 OPCODE type = o->op_type;
5979 return modkids(ck_fun(o), type);
5983 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5985 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5986 switch (cUNOPo->op_first->op_type) {
5988 /* This is needed for
5989 if (defined %stash::)
5990 to work. Do not break Tk.
5992 break; /* Globals via GV can be undef */
5994 case OP_AASSIGN: /* Is this a good idea? */
5995 Perl_warner(aTHX_ WARN_DEPRECATED,
5996 "defined(@array) is deprecated");
5997 Perl_warner(aTHX_ WARN_DEPRECATED,
5998 "\t(Maybe you should just omit the defined()?)\n");
6001 /* This is needed for
6002 if (defined %stash::)
6003 to work. Do not break Tk.
6005 break; /* Globals via GV can be undef */
6007 Perl_warner(aTHX_ WARN_DEPRECATED,
6008 "defined(%%hash) is deprecated");
6009 Perl_warner(aTHX_ WARN_DEPRECATED,
6010 "\t(Maybe you should just omit the defined()?)\n");
6021 Perl_ck_rfun(pTHX_ OP *o)
6023 OPCODE type = o->op_type;
6024 return refkids(ck_fun(o), type);
6028 Perl_ck_listiob(pTHX_ OP *o)
6032 kid = cLISTOPo->op_first;
6035 kid = cLISTOPo->op_first;
6037 if (kid->op_type == OP_PUSHMARK)
6038 kid = kid->op_sibling;
6039 if (kid && o->op_flags & OPf_STACKED)
6040 kid = kid->op_sibling;
6041 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6042 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6043 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6044 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6045 cLISTOPo->op_first->op_sibling = kid;
6046 cLISTOPo->op_last = kid;
6047 kid = kid->op_sibling;
6052 append_elem(o->op_type, o, newDEFSVOP());
6058 if (PL_hints & HINT_LOCALE)
6059 o->op_private |= OPpLOCALE;
6066 Perl_ck_fun_locale(pTHX_ OP *o)
6072 if (PL_hints & HINT_LOCALE)
6073 o->op_private |= OPpLOCALE;
6080 Perl_ck_sassign(pTHX_ OP *o)
6082 OP *kid = cLISTOPo->op_first;
6083 /* has a disposable target? */
6084 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6085 && !(kid->op_flags & OPf_STACKED)
6086 /* Cannot steal the second time! */
6087 && !(kid->op_private & OPpTARGET_MY))
6089 OP *kkid = kid->op_sibling;
6091 /* Can just relocate the target. */
6092 if (kkid && kkid->op_type == OP_PADSV
6093 && !(kkid->op_private & OPpLVAL_INTRO))
6095 kid->op_targ = kkid->op_targ;
6097 /* Now we do not need PADSV and SASSIGN. */
6098 kid->op_sibling = o->op_sibling; /* NULL */
6099 cLISTOPo->op_first = NULL;
6102 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6110 Perl_ck_scmp(pTHX_ OP *o)
6114 if (PL_hints & HINT_LOCALE)
6115 o->op_private |= OPpLOCALE;
6122 Perl_ck_match(pTHX_ OP *o)
6124 o->op_private |= OPpRUNTIME;
6129 Perl_ck_method(pTHX_ OP *o)
6131 OP *kid = cUNOPo->op_first;
6132 if (kid->op_type == OP_CONST) {
6133 SV* sv = kSVOP->op_sv;
6134 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6136 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6137 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6140 kSVOP->op_sv = Nullsv;
6142 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6151 Perl_ck_null(pTHX_ OP *o)
6157 Perl_ck_open(pTHX_ OP *o)
6159 HV *table = GvHV(PL_hintgv);
6163 svp = hv_fetch(table, "open_IN", 7, FALSE);
6165 mode = mode_from_discipline(*svp);
6166 if (mode & O_BINARY)
6167 o->op_private |= OPpOPEN_IN_RAW;
6168 else if (mode & O_TEXT)
6169 o->op_private |= OPpOPEN_IN_CRLF;
6172 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6174 mode = mode_from_discipline(*svp);
6175 if (mode & O_BINARY)
6176 o->op_private |= OPpOPEN_OUT_RAW;
6177 else if (mode & O_TEXT)
6178 o->op_private |= OPpOPEN_OUT_CRLF;
6181 if (o->op_type == OP_BACKTICK)
6187 Perl_ck_repeat(pTHX_ OP *o)
6189 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6190 o->op_private |= OPpREPEAT_DOLIST;
6191 cBINOPo->op_first = force_list(cBINOPo->op_first);
6199 Perl_ck_require(pTHX_ OP *o)
6201 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6202 SVOP *kid = (SVOP*)cUNOPo->op_first;
6204 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6206 for (s = SvPVX(kid->op_sv); *s; s++) {
6207 if (*s == ':' && s[1] == ':') {
6209 Move(s+2, s+1, strlen(s+2)+1, char);
6210 --SvCUR(kid->op_sv);
6213 if (SvREADONLY(kid->op_sv)) {
6214 SvREADONLY_off(kid->op_sv);
6215 sv_catpvn(kid->op_sv, ".pm", 3);
6216 SvREADONLY_on(kid->op_sv);
6219 sv_catpvn(kid->op_sv, ".pm", 3);
6226 Perl_ck_return(pTHX_ OP *o)
6229 if (CvLVALUE(PL_compcv)) {
6230 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6231 mod(kid, OP_LEAVESUBLV);
6238 Perl_ck_retarget(pTHX_ OP *o)
6240 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6247 Perl_ck_select(pTHX_ OP *o)
6250 if (o->op_flags & OPf_KIDS) {
6251 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6252 if (kid && kid->op_sibling) {
6253 o->op_type = OP_SSELECT;
6254 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6256 return fold_constants(o);
6260 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6261 if (kid && kid->op_type == OP_RV2GV)
6262 kid->op_private &= ~HINT_STRICT_REFS;
6267 Perl_ck_shift(pTHX_ OP *o)
6269 I32 type = o->op_type;
6271 if (!(o->op_flags & OPf_KIDS)) {
6276 if (!CvUNIQUE(PL_compcv)) {
6277 argop = newOP(OP_PADAV, OPf_REF);
6278 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6281 argop = newUNOP(OP_RV2AV, 0,
6282 scalar(newGVOP(OP_GV, 0,
6283 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6286 argop = newUNOP(OP_RV2AV, 0,
6287 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6288 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6289 #endif /* USE_THREADS */
6290 return newUNOP(type, 0, scalar(argop));
6292 return scalar(modkids(ck_fun(o), type));
6296 Perl_ck_sort(pTHX_ OP *o)
6301 if (PL_hints & HINT_LOCALE)
6302 o->op_private |= OPpLOCALE;
6305 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6307 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6308 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6310 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6312 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6314 if (kid->op_type == OP_SCOPE) {
6318 else if (kid->op_type == OP_LEAVE) {
6319 if (o->op_type == OP_SORT) {
6320 null(kid); /* wipe out leave */
6323 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6324 if (k->op_next == kid)
6326 /* don't descend into loops */
6327 else if (k->op_type == OP_ENTERLOOP
6328 || k->op_type == OP_ENTERITER)
6330 k = cLOOPx(k)->op_lastop;
6335 kid->op_next = 0; /* just disconnect the leave */
6336 k = kLISTOP->op_first;
6341 if (o->op_type == OP_SORT) {
6342 /* provide scalar context for comparison function/block */
6348 o->op_flags |= OPf_SPECIAL;
6350 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6353 firstkid = firstkid->op_sibling;
6356 /* provide list context for arguments */
6357 if (o->op_type == OP_SORT)
6364 S_simplify_sort(pTHX_ OP *o)
6366 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6370 if (!(o->op_flags & OPf_STACKED))
6372 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6373 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6374 kid = kUNOP->op_first; /* get past null */
6375 if (kid->op_type != OP_SCOPE)
6377 kid = kLISTOP->op_last; /* get past scope */
6378 switch(kid->op_type) {
6386 k = kid; /* remember this node*/
6387 if (kBINOP->op_first->op_type != OP_RV2SV)
6389 kid = kBINOP->op_first; /* get past cmp */
6390 if (kUNOP->op_first->op_type != OP_GV)
6392 kid = kUNOP->op_first; /* get past rv2sv */
6394 if (GvSTASH(gv) != PL_curstash)
6396 if (strEQ(GvNAME(gv), "a"))
6398 else if (strEQ(GvNAME(gv), "b"))
6402 kid = k; /* back to cmp */
6403 if (kBINOP->op_last->op_type != OP_RV2SV)
6405 kid = kBINOP->op_last; /* down to 2nd arg */
6406 if (kUNOP->op_first->op_type != OP_GV)
6408 kid = kUNOP->op_first; /* get past rv2sv */
6410 if (GvSTASH(gv) != PL_curstash
6412 ? strNE(GvNAME(gv), "a")
6413 : strNE(GvNAME(gv), "b")))
6415 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6417 o->op_private |= OPpSORT_REVERSE;
6418 if (k->op_type == OP_NCMP)
6419 o->op_private |= OPpSORT_NUMERIC;
6420 if (k->op_type == OP_I_NCMP)
6421 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6422 kid = cLISTOPo->op_first->op_sibling;
6423 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6424 op_free(kid); /* then delete it */
6428 Perl_ck_split(pTHX_ OP *o)
6432 if (o->op_flags & OPf_STACKED)
6433 return no_fh_allowed(o);
6435 kid = cLISTOPo->op_first;
6436 if (kid->op_type != OP_NULL)
6437 Perl_croak(aTHX_ "panic: ck_split");
6438 kid = kid->op_sibling;
6439 op_free(cLISTOPo->op_first);
6440 cLISTOPo->op_first = kid;
6442 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6443 cLISTOPo->op_last = kid; /* There was only one element previously */
6446 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6447 OP *sibl = kid->op_sibling;
6448 kid->op_sibling = 0;
6449 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6450 if (cLISTOPo->op_first == cLISTOPo->op_last)
6451 cLISTOPo->op_last = kid;
6452 cLISTOPo->op_first = kid;
6453 kid->op_sibling = sibl;
6456 kid->op_type = OP_PUSHRE;
6457 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6460 if (!kid->op_sibling)
6461 append_elem(OP_SPLIT, o, newDEFSVOP());
6463 kid = kid->op_sibling;
6466 if (!kid->op_sibling)
6467 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6469 kid = kid->op_sibling;
6472 if (kid->op_sibling)
6473 return too_many_arguments(o,PL_op_desc[o->op_type]);
6479 Perl_ck_join(pTHX_ OP *o)
6481 if (ckWARN(WARN_SYNTAX)) {
6482 OP *kid = cLISTOPo->op_first->op_sibling;
6483 if (kid && kid->op_type == OP_MATCH) {
6484 char *pmstr = "STRING";
6485 if (kPMOP->op_pmregexp)
6486 pmstr = kPMOP->op_pmregexp->precomp;
6487 Perl_warner(aTHX_ WARN_SYNTAX,
6488 "/%s/ should probably be written as \"%s\"",
6496 Perl_ck_subr(pTHX_ OP *o)
6498 OP *prev = ((cUNOPo->op_first->op_sibling)
6499 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6500 OP *o2 = prev->op_sibling;
6509 o->op_private |= OPpENTERSUB_HASTARG;
6510 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6511 if (cvop->op_type == OP_RV2CV) {
6513 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6514 null(cvop); /* disable rv2cv */
6515 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6516 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6517 GV *gv = cGVOPx_gv(tmpop);
6520 tmpop->op_private |= OPpEARLY_CV;
6521 else if (SvPOK(cv)) {
6522 namegv = CvANON(cv) ? gv : CvGV(cv);
6523 proto = SvPV((SV*)cv, n_a);
6527 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6528 if (o2->op_type == OP_CONST)
6529 o2->op_private &= ~OPpCONST_STRICT;
6530 else if (o2->op_type == OP_LIST) {
6531 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6532 if (o && o->op_type == OP_CONST)
6533 o->op_private &= ~OPpCONST_STRICT;
6536 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6537 if (PERLDB_SUB && PL_curstash != PL_debstash)
6538 o->op_private |= OPpENTERSUB_DB;
6539 while (o2 != cvop) {
6543 return too_many_arguments(o, gv_ename(namegv));
6561 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6563 arg == 1 ? "block or sub {}" : "sub {}",
6564 gv_ename(namegv), o2);
6567 /* '*' allows any scalar type, including bareword */
6570 if (o2->op_type == OP_RV2GV)
6571 goto wrapref; /* autoconvert GLOB -> GLOBref */
6572 else if (o2->op_type == OP_CONST)
6573 o2->op_private &= ~OPpCONST_STRICT;
6574 else if (o2->op_type == OP_ENTERSUB) {
6575 /* accidental subroutine, revert to bareword */
6576 OP *gvop = ((UNOP*)o2)->op_first;
6577 if (gvop && gvop->op_type == OP_NULL) {
6578 gvop = ((UNOP*)gvop)->op_first;
6580 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6583 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6584 (gvop = ((UNOP*)gvop)->op_first) &&
6585 gvop->op_type == OP_GV)
6587 GV *gv = cGVOPx_gv(gvop);
6588 OP *sibling = o2->op_sibling;
6589 SV *n = newSVpvn("",0);
6591 gv_fullname3(n, gv, "");
6592 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6593 sv_chop(n, SvPVX(n)+6);
6594 o2 = newSVOP(OP_CONST, 0, n);
6595 prev->op_sibling = o2;
6596 o2->op_sibling = sibling;
6608 if (o2->op_type != OP_RV2GV)
6609 bad_type(arg, "symbol", gv_ename(namegv), o2);
6612 if (o2->op_type != OP_ENTERSUB)
6613 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6616 if (o2->op_type != OP_RV2SV
6617 && o2->op_type != OP_PADSV
6618 && o2->op_type != OP_HELEM
6619 && o2->op_type != OP_AELEM
6620 && o2->op_type != OP_THREADSV)
6622 bad_type(arg, "scalar", gv_ename(namegv), o2);
6626 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6627 bad_type(arg, "array", gv_ename(namegv), o2);
6630 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6631 bad_type(arg, "hash", gv_ename(namegv), o2);
6635 OP* sib = kid->op_sibling;
6636 kid->op_sibling = 0;
6637 o2 = newUNOP(OP_REFGEN, 0, kid);
6638 o2->op_sibling = sib;
6639 prev->op_sibling = o2;
6650 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6651 gv_ename(namegv), SvPV((SV*)cv, n_a));
6656 mod(o2, OP_ENTERSUB);
6658 o2 = o2->op_sibling;
6660 if (proto && !optional &&
6661 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6662 return too_few_arguments(o, gv_ename(namegv));
6667 Perl_ck_svconst(pTHX_ OP *o)
6669 SvREADONLY_on(cSVOPo->op_sv);
6674 Perl_ck_trunc(pTHX_ OP *o)
6676 if (o->op_flags & OPf_KIDS) {
6677 SVOP *kid = (SVOP*)cUNOPo->op_first;
6679 if (kid->op_type == OP_NULL)
6680 kid = (SVOP*)kid->op_sibling;
6681 if (kid && kid->op_type == OP_CONST &&
6682 (kid->op_private & OPpCONST_BARE))
6684 o->op_flags |= OPf_SPECIAL;
6685 kid->op_private &= ~OPpCONST_STRICT;
6692 Perl_ck_substr(pTHX_ OP *o)
6695 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6696 OP *kid = cLISTOPo->op_first;
6698 if (kid->op_type == OP_NULL)
6699 kid = kid->op_sibling;
6701 kid->op_flags |= OPf_MOD;
6707 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6710 Perl_peep(pTHX_ register OP *o)
6712 register OP* oldop = 0;
6715 if (!o || o->op_seq)
6719 SAVEVPTR(PL_curcop);
6720 for (; o; o = o->op_next) {
6726 switch (o->op_type) {
6730 PL_curcop = ((COP*)o); /* for warnings */
6731 o->op_seq = PL_op_seqmax++;
6735 if (cSVOPo->op_private & OPpCONST_STRICT)
6736 no_bareword_allowed(o);
6738 /* Relocate sv to the pad for thread safety.
6739 * Despite being a "constant", the SV is written to,
6740 * for reference counts, sv_upgrade() etc. */
6742 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6743 if (SvPADTMP(cSVOPo->op_sv)) {
6744 /* If op_sv is already a PADTMP then it is being used by
6745 * some pad, so make a copy. */
6746 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6747 SvREADONLY_on(PL_curpad[ix]);
6748 SvREFCNT_dec(cSVOPo->op_sv);
6751 SvREFCNT_dec(PL_curpad[ix]);
6752 SvPADTMP_on(cSVOPo->op_sv);
6753 PL_curpad[ix] = cSVOPo->op_sv;
6754 /* XXX I don't know how this isn't readonly already. */
6755 SvREADONLY_on(PL_curpad[ix]);
6757 cSVOPo->op_sv = Nullsv;
6761 o->op_seq = PL_op_seqmax++;
6765 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6766 if (o->op_next->op_private & OPpTARGET_MY) {
6767 if (o->op_flags & OPf_STACKED) /* chained concats */
6768 goto ignore_optimization;
6770 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6771 o->op_targ = o->op_next->op_targ;
6772 o->op_next->op_targ = 0;
6773 o->op_private |= OPpTARGET_MY;
6778 ignore_optimization:
6779 o->op_seq = PL_op_seqmax++;
6782 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6783 o->op_seq = PL_op_seqmax++;
6784 break; /* Scalar stub must produce undef. List stub is noop */
6788 if (o->op_targ == OP_NEXTSTATE
6789 || o->op_targ == OP_DBSTATE
6790 || o->op_targ == OP_SETSTATE)
6792 PL_curcop = ((COP*)o);
6799 if (oldop && o->op_next) {
6800 oldop->op_next = o->op_next;
6803 o->op_seq = PL_op_seqmax++;
6807 if (o->op_next->op_type == OP_RV2SV) {
6808 if (!(o->op_next->op_private & OPpDEREF)) {
6810 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6812 o->op_next = o->op_next->op_next;
6813 o->op_type = OP_GVSV;
6814 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6817 else if (o->op_next->op_type == OP_RV2AV) {
6818 OP* pop = o->op_next->op_next;
6820 if (pop->op_type == OP_CONST &&
6821 (PL_op = pop->op_next) &&
6822 pop->op_next->op_type == OP_AELEM &&
6823 !(pop->op_next->op_private &
6824 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6825 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6833 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6834 o->op_next = pop->op_next->op_next;
6835 o->op_type = OP_AELEMFAST;
6836 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6837 o->op_private = (U8)i;
6842 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6844 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6845 /* XXX could check prototype here instead of just carping */
6846 SV *sv = sv_newmortal();
6847 gv_efullname3(sv, gv, Nullch);
6848 Perl_warner(aTHX_ WARN_PROTOTYPE,
6849 "%s() called too early to check prototype",
6854 o->op_seq = PL_op_seqmax++;
6865 o->op_seq = PL_op_seqmax++;
6866 while (cLOGOP->op_other->op_type == OP_NULL)
6867 cLOGOP->op_other = cLOGOP->op_other->op_next;
6868 peep(cLOGOP->op_other);
6873 o->op_seq = PL_op_seqmax++;
6874 while (cLOOP->op_redoop->op_type == OP_NULL)
6875 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6876 peep(cLOOP->op_redoop);
6877 while (cLOOP->op_nextop->op_type == OP_NULL)
6878 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6879 peep(cLOOP->op_nextop);
6880 while (cLOOP->op_lastop->op_type == OP_NULL)
6881 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6882 peep(cLOOP->op_lastop);
6888 o->op_seq = PL_op_seqmax++;
6889 while (cPMOP->op_pmreplstart &&
6890 cPMOP->op_pmreplstart->op_type == OP_NULL)
6891 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6892 peep(cPMOP->op_pmreplstart);
6896 o->op_seq = PL_op_seqmax++;
6897 if (ckWARN(WARN_SYNTAX) && o->op_next
6898 && o->op_next->op_type == OP_NEXTSTATE) {
6899 if (o->op_next->op_sibling &&
6900 o->op_next->op_sibling->op_type != OP_EXIT &&
6901 o->op_next->op_sibling->op_type != OP_WARN &&
6902 o->op_next->op_sibling->op_type != OP_DIE) {
6903 line_t oldline = CopLINE(PL_curcop);
6905 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6906 Perl_warner(aTHX_ WARN_EXEC,
6907 "Statement unlikely to be reached");
6908 Perl_warner(aTHX_ WARN_EXEC,
6909 "\t(Maybe you meant system() when you said exec()?)\n");
6910 CopLINE_set(PL_curcop, oldline);
6919 SV **svp, **indsvp, *sv;
6924 o->op_seq = PL_op_seqmax++;
6926 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6929 /* Make the CONST have a shared SV */
6930 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6931 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6932 key = SvPV(sv, keylen);
6935 lexname = newSVpvn_share(key, keylen, 0);
6940 if ((o->op_private & (OPpLVAL_INTRO)))
6943 rop = (UNOP*)((BINOP*)o)->op_first;
6944 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6946 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6947 if (!SvOBJECT(lexname))
6949 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6950 if (!fields || !GvHV(*fields))
6952 key = SvPV(*svp, keylen);
6955 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6957 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6958 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6960 ind = SvIV(*indsvp);
6962 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6963 rop->op_type = OP_RV2AV;
6964 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6965 o->op_type = OP_AELEM;
6966 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6968 if (SvREADONLY(*svp))
6970 SvFLAGS(sv) |= (SvFLAGS(*svp)
6971 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6981 SV **svp, **indsvp, *sv;
6985 SVOP *first_key_op, *key_op;
6987 o->op_seq = PL_op_seqmax++;
6988 if ((o->op_private & (OPpLVAL_INTRO))
6989 /* I bet there's always a pushmark... */
6990 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6991 /* hmmm, no optimization if list contains only one key. */
6993 rop = (UNOP*)((LISTOP*)o)->op_last;
6994 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6996 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6997 if (!SvOBJECT(lexname))
6999 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7000 if (!fields || !GvHV(*fields))
7002 /* Again guessing that the pushmark can be jumped over.... */
7003 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7004 ->op_first->op_sibling;
7005 /* Check that the key list contains only constants. */
7006 for (key_op = first_key_op; key_op;
7007 key_op = (SVOP*)key_op->op_sibling)
7008 if (key_op->op_type != OP_CONST)
7012 rop->op_type = OP_RV2AV;
7013 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7014 o->op_type = OP_ASLICE;
7015 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7016 for (key_op = first_key_op; key_op;
7017 key_op = (SVOP*)key_op->op_sibling) {
7018 svp = cSVOPx_svp(key_op);
7019 key = SvPV(*svp, keylen);
7022 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7024 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7025 "in variable %s of type %s",
7026 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7028 ind = SvIV(*indsvp);
7030 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7032 if (SvREADONLY(*svp))
7034 SvFLAGS(sv) |= (SvFLAGS(*svp)
7035 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7043 o->op_seq = PL_op_seqmax++;
7053 /* Efficient sub that returns a constant scalar value. */
7055 const_sv_xsub(pTHXo_ CV* cv)
7060 Perl_croak(aTHX_ "usage: %s::%s()",
7061 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7065 ST(0) = (SV*)XSANY.any_ptr;