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, PERL_MAGIC_sv, 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, PERL_MAGIC_sv, 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 Perl_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);
875 Perl_op_null(pTHX_ OP *o)
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 op_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_ARYBASE)))
1366 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1367 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1371 SAVEI32(PL_compiling.cop_arybase);
1372 PL_compiling.cop_arybase = 0;
1374 else if (type == OP_REFGEN)
1377 Perl_croak(aTHX_ "That use of $[ is unsupported");
1380 if (o->op_flags & OPf_PARENS)
1384 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1385 !(o->op_flags & OPf_STACKED)) {
1386 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1387 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1388 assert(cUNOPo->op_first->op_type == OP_NULL);
1389 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1392 else { /* lvalue subroutine call */
1393 o->op_private |= OPpLVAL_INTRO;
1394 PL_modcount = RETURN_UNLIMITED_NUMBER;
1395 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1396 /* Backward compatibility mode: */
1397 o->op_private |= OPpENTERSUB_INARGS;
1400 else { /* Compile-time error message: */
1401 OP *kid = cUNOPo->op_first;
1405 if (kid->op_type == OP_PUSHMARK)
1407 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1409 "panic: unexpected lvalue entersub "
1410 "args: type/targ %ld:%ld",
1411 (long)kid->op_type,kid->op_targ);
1412 kid = kLISTOP->op_first;
1414 while (kid->op_sibling)
1415 kid = kid->op_sibling;
1416 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1418 if (kid->op_type == OP_METHOD_NAMED
1419 || kid->op_type == OP_METHOD)
1423 if (kid->op_sibling || kid->op_next != kid) {
1424 yyerror("panic: unexpected optree near method call");
1428 NewOp(1101, newop, 1, UNOP);
1429 newop->op_type = OP_RV2CV;
1430 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1431 newop->op_first = Nullop;
1432 newop->op_next = (OP*)newop;
1433 kid->op_sibling = (OP*)newop;
1434 newop->op_private |= OPpLVAL_INTRO;
1438 if (kid->op_type != OP_RV2CV)
1440 "panic: unexpected lvalue entersub "
1441 "entry via type/targ %ld:%ld",
1442 (long)kid->op_type,kid->op_targ);
1443 kid->op_private |= OPpLVAL_INTRO;
1444 break; /* Postpone until runtime */
1448 kid = kUNOP->op_first;
1449 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1450 kid = kUNOP->op_first;
1451 if (kid->op_type == OP_NULL)
1453 "Unexpected constant lvalue entersub "
1454 "entry via type/targ %ld:%ld",
1455 (long)kid->op_type,kid->op_targ);
1456 if (kid->op_type != OP_GV) {
1457 /* Restore RV2CV to check lvalueness */
1459 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1460 okid->op_next = kid->op_next;
1461 kid->op_next = okid;
1464 okid->op_next = Nullop;
1465 okid->op_type = OP_RV2CV;
1467 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1468 okid->op_private |= OPpLVAL_INTRO;
1472 cv = GvCV(kGVOP_gv);
1482 /* grep, foreach, subcalls, refgen */
1483 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1485 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1486 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1488 : (o->op_type == OP_ENTERSUB
1489 ? "non-lvalue subroutine call"
1490 : PL_op_desc[o->op_type])),
1491 type ? PL_op_desc[type] : "local"));
1505 case OP_RIGHT_SHIFT:
1514 if (!(o->op_flags & OPf_STACKED))
1520 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1526 if (!type && cUNOPo->op_first->op_type != OP_GV)
1527 Perl_croak(aTHX_ "Can't localize through a reference");
1528 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1529 PL_modcount = RETURN_UNLIMITED_NUMBER;
1530 return o; /* Treat \(@foo) like ordinary list. */
1534 if (scalar_mod_type(o, type))
1536 ref(cUNOPo->op_first, o->op_type);
1540 if (type == OP_LEAVESUBLV)
1541 o->op_private |= OPpMAYBE_LVSUB;
1547 PL_modcount = RETURN_UNLIMITED_NUMBER;
1550 if (!type && cUNOPo->op_first->op_type != OP_GV)
1551 Perl_croak(aTHX_ "Can't localize through a reference");
1552 ref(cUNOPo->op_first, o->op_type);
1556 PL_hints |= HINT_BLOCK_SCOPE;
1566 PL_modcount = RETURN_UNLIMITED_NUMBER;
1567 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1568 return o; /* Treat \(@foo) like ordinary list. */
1569 if (scalar_mod_type(o, type))
1571 if (type == OP_LEAVESUBLV)
1572 o->op_private |= OPpMAYBE_LVSUB;
1577 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1578 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1583 PL_modcount++; /* XXX ??? */
1585 #endif /* USE_THREADS */
1591 if (type != OP_SASSIGN)
1595 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1600 if (type == OP_LEAVESUBLV)
1601 o->op_private |= OPpMAYBE_LVSUB;
1603 pad_free(o->op_targ);
1604 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1605 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1606 if (o->op_flags & OPf_KIDS)
1607 mod(cBINOPo->op_first->op_sibling, type);
1612 ref(cBINOPo->op_first, o->op_type);
1613 if (type == OP_ENTERSUB &&
1614 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1615 o->op_private |= OPpLVAL_DEFER;
1616 if (type == OP_LEAVESUBLV)
1617 o->op_private |= OPpMAYBE_LVSUB;
1625 if (o->op_flags & OPf_KIDS)
1626 mod(cLISTOPo->op_last, type);
1630 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1632 else if (!(o->op_flags & OPf_KIDS))
1634 if (o->op_targ != OP_LIST) {
1635 mod(cBINOPo->op_first, type);
1640 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1645 if (type != OP_LEAVESUBLV)
1647 break; /* mod()ing was handled by ck_return() */
1649 if (type != OP_LEAVESUBLV)
1650 o->op_flags |= OPf_MOD;
1652 if (type == OP_AASSIGN || type == OP_SASSIGN)
1653 o->op_flags |= OPf_SPECIAL|OPf_REF;
1655 o->op_private |= OPpLVAL_INTRO;
1656 o->op_flags &= ~OPf_SPECIAL;
1657 PL_hints |= HINT_BLOCK_SCOPE;
1659 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1660 && type != OP_LEAVESUBLV)
1661 o->op_flags |= OPf_REF;
1666 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1670 if (o->op_type == OP_RV2GV)
1694 case OP_RIGHT_SHIFT:
1713 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1715 switch (o->op_type) {
1723 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1736 Perl_refkids(pTHX_ OP *o, I32 type)
1739 if (o && o->op_flags & OPf_KIDS) {
1740 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1747 Perl_ref(pTHX_ OP *o, I32 type)
1751 if (!o || PL_error_count)
1754 switch (o->op_type) {
1756 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1757 !(o->op_flags & OPf_STACKED)) {
1758 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1759 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1760 assert(cUNOPo->op_first->op_type == OP_NULL);
1761 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1762 o->op_flags |= OPf_SPECIAL;
1767 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1771 if (type == OP_DEFINED)
1772 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1773 ref(cUNOPo->op_first, o->op_type);
1776 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1777 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1778 : type == OP_RV2HV ? OPpDEREF_HV
1780 o->op_flags |= OPf_MOD;
1785 o->op_flags |= OPf_MOD; /* XXX ??? */
1790 o->op_flags |= OPf_REF;
1793 if (type == OP_DEFINED)
1794 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1795 ref(cUNOPo->op_first, o->op_type);
1800 o->op_flags |= OPf_REF;
1805 if (!(o->op_flags & OPf_KIDS))
1807 ref(cBINOPo->op_first, type);
1811 ref(cBINOPo->op_first, o->op_type);
1812 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1813 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1814 : type == OP_RV2HV ? OPpDEREF_HV
1816 o->op_flags |= OPf_MOD;
1824 if (!(o->op_flags & OPf_KIDS))
1826 ref(cLISTOPo->op_last, type);
1836 S_dup_attrlist(pTHX_ OP *o)
1840 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1841 * where the first kid is OP_PUSHMARK and the remaining ones
1842 * are OP_CONST. We need to push the OP_CONST values.
1844 if (o->op_type == OP_CONST)
1845 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1847 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1848 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1849 if (o->op_type == OP_CONST)
1850 rop = append_elem(OP_LIST, rop,
1851 newSVOP(OP_CONST, o->op_flags,
1852 SvREFCNT_inc(cSVOPo->op_sv)));
1859 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1863 /* fake up C<use attributes $pkg,$rv,@attrs> */
1864 ENTER; /* need to protect against side-effects of 'use' */
1866 if (stash && HvNAME(stash))
1867 stashsv = newSVpv(HvNAME(stash), 0);
1869 stashsv = &PL_sv_no;
1871 #define ATTRSMODULE "attributes"
1873 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1874 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1876 prepend_elem(OP_LIST,
1877 newSVOP(OP_CONST, 0, stashsv),
1878 prepend_elem(OP_LIST,
1879 newSVOP(OP_CONST, 0,
1881 dup_attrlist(attrs))));
1886 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1887 char *attrstr, STRLEN len)
1892 len = strlen(attrstr);
1896 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1898 char *sstr = attrstr;
1899 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1900 attrs = append_elem(OP_LIST, attrs,
1901 newSVOP(OP_CONST, 0,
1902 newSVpvn(sstr, attrstr-sstr)));
1906 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1907 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1908 Nullsv, prepend_elem(OP_LIST,
1909 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1910 prepend_elem(OP_LIST,
1911 newSVOP(OP_CONST, 0,
1917 S_my_kid(pTHX_ OP *o, OP *attrs)
1922 if (!o || PL_error_count)
1926 if (type == OP_LIST) {
1927 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1929 } else if (type == OP_UNDEF) {
1931 } else if (type == OP_RV2SV || /* "our" declaration */
1933 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1935 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1937 PL_in_my_stash = Nullhv;
1938 apply_attrs(GvSTASH(gv),
1939 (type == OP_RV2SV ? GvSV(gv) :
1940 type == OP_RV2AV ? (SV*)GvAV(gv) :
1941 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1944 o->op_private |= OPpOUR_INTRO;
1946 } else if (type != OP_PADSV &&
1949 type != OP_PUSHMARK)
1951 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1952 PL_op_desc[o->op_type],
1953 PL_in_my == KEY_our ? "our" : "my"));
1956 else if (attrs && type != OP_PUSHMARK) {
1962 PL_in_my_stash = Nullhv;
1964 /* check for C<my Dog $spot> when deciding package */
1965 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1966 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1967 stash = SvSTASH(*namesvp);
1969 stash = PL_curstash;
1970 padsv = PAD_SV(o->op_targ);
1971 apply_attrs(stash, padsv, attrs);
1973 o->op_flags |= OPf_MOD;
1974 o->op_private |= OPpLVAL_INTRO;
1979 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1981 if (o->op_flags & OPf_PARENS)
1985 o = my_kid(o, attrs);
1987 PL_in_my_stash = Nullhv;
1992 Perl_my(pTHX_ OP *o)
1994 return my_kid(o, Nullop);
1998 Perl_sawparens(pTHX_ OP *o)
2001 o->op_flags |= OPf_PARENS;
2006 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2010 if (ckWARN(WARN_MISC) &&
2011 (left->op_type == OP_RV2AV ||
2012 left->op_type == OP_RV2HV ||
2013 left->op_type == OP_PADAV ||
2014 left->op_type == OP_PADHV)) {
2015 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2016 right->op_type == OP_TRANS)
2017 ? right->op_type : OP_MATCH];
2018 const char *sample = ((left->op_type == OP_RV2AV ||
2019 left->op_type == OP_PADAV)
2020 ? "@array" : "%hash");
2021 Perl_warner(aTHX_ WARN_MISC,
2022 "Applying %s to %s will act on scalar(%s)",
2023 desc, sample, sample);
2026 if (!(right->op_flags & OPf_STACKED) &&
2027 (right->op_type == OP_MATCH ||
2028 right->op_type == OP_SUBST ||
2029 right->op_type == OP_TRANS)) {
2030 right->op_flags |= OPf_STACKED;
2031 if (right->op_type != OP_MATCH &&
2032 ! (right->op_type == OP_TRANS &&
2033 right->op_private & OPpTRANS_IDENTICAL))
2034 left = mod(left, right->op_type);
2035 if (right->op_type == OP_TRANS)
2036 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2038 o = prepend_elem(right->op_type, scalar(left), right);
2040 return newUNOP(OP_NOT, 0, scalar(o));
2044 return bind_match(type, left,
2045 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2049 Perl_invert(pTHX_ OP *o)
2053 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2054 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2058 Perl_scope(pTHX_ OP *o)
2061 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2062 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2063 o->op_type = OP_LEAVE;
2064 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2067 if (o->op_type == OP_LINESEQ) {
2069 o->op_type = OP_SCOPE;
2070 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2071 kid = ((LISTOP*)o)->op_first;
2072 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2076 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2083 Perl_save_hints(pTHX)
2086 SAVESPTR(GvHV(PL_hintgv));
2087 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2088 SAVEFREESV(GvHV(PL_hintgv));
2092 Perl_block_start(pTHX_ int full)
2094 int retval = PL_savestack_ix;
2096 SAVEI32(PL_comppad_name_floor);
2097 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2099 PL_comppad_name_fill = PL_comppad_name_floor;
2100 if (PL_comppad_name_floor < 0)
2101 PL_comppad_name_floor = 0;
2102 SAVEI32(PL_min_intro_pending);
2103 SAVEI32(PL_max_intro_pending);
2104 PL_min_intro_pending = 0;
2105 SAVEI32(PL_comppad_name_fill);
2106 SAVEI32(PL_padix_floor);
2107 PL_padix_floor = PL_padix;
2108 PL_pad_reset_pending = FALSE;
2110 PL_hints &= ~HINT_BLOCK_SCOPE;
2111 SAVESPTR(PL_compiling.cop_warnings);
2112 if (! specialWARN(PL_compiling.cop_warnings)) {
2113 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2114 SAVEFREESV(PL_compiling.cop_warnings) ;
2116 SAVESPTR(PL_compiling.cop_io);
2117 if (! specialCopIO(PL_compiling.cop_io)) {
2118 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2119 SAVEFREESV(PL_compiling.cop_io) ;
2125 Perl_block_end(pTHX_ I32 floor, OP *seq)
2127 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2128 OP* retval = scalarseq(seq);
2130 PL_pad_reset_pending = FALSE;
2131 PL_compiling.op_private = PL_hints;
2133 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2134 pad_leavemy(PL_comppad_name_fill);
2143 OP *o = newOP(OP_THREADSV, 0);
2144 o->op_targ = find_threadsv("_");
2147 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2148 #endif /* USE_THREADS */
2152 Perl_newPROG(pTHX_ OP *o)
2157 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2158 ((PL_in_eval & EVAL_KEEPERR)
2159 ? OPf_SPECIAL : 0), o);
2160 PL_eval_start = linklist(PL_eval_root);
2161 PL_eval_root->op_private |= OPpREFCOUNTED;
2162 OpREFCNT_set(PL_eval_root, 1);
2163 PL_eval_root->op_next = 0;
2164 peep(PL_eval_start);
2169 PL_main_root = scope(sawparens(scalarvoid(o)));
2170 PL_curcop = &PL_compiling;
2171 PL_main_start = LINKLIST(PL_main_root);
2172 PL_main_root->op_private |= OPpREFCOUNTED;
2173 OpREFCNT_set(PL_main_root, 1);
2174 PL_main_root->op_next = 0;
2175 peep(PL_main_start);
2178 /* Register with debugger */
2180 CV *cv = get_cv("DB::postponed", FALSE);
2184 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2186 call_sv((SV*)cv, G_DISCARD);
2193 Perl_localize(pTHX_ OP *o, I32 lex)
2195 if (o->op_flags & OPf_PARENS)
2198 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2200 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2201 if (*s == ';' || *s == '=')
2202 Perl_warner(aTHX_ WARN_PARENTHESIS,
2203 "Parentheses missing around \"%s\" list",
2204 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2210 o = mod(o, OP_NULL); /* a bit kludgey */
2212 PL_in_my_stash = Nullhv;
2217 Perl_jmaybe(pTHX_ OP *o)
2219 if (o->op_type == OP_LIST) {
2222 o2 = newOP(OP_THREADSV, 0);
2223 o2->op_targ = find_threadsv(";");
2225 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2226 #endif /* USE_THREADS */
2227 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2233 Perl_fold_constants(pTHX_ register OP *o)
2236 I32 type = o->op_type;
2239 if (PL_opargs[type] & OA_RETSCALAR)
2241 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2242 o->op_targ = pad_alloc(type, SVs_PADTMP);
2244 /* integerize op, unless it happens to be C<-foo>.
2245 * XXX should pp_i_negate() do magic string negation instead? */
2246 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2247 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2248 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2250 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2253 if (!(PL_opargs[type] & OA_FOLDCONST))
2258 /* XXX might want a ck_negate() for this */
2259 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2272 if (o->op_private & OPpLOCALE)
2277 goto nope; /* Don't try to run w/ errors */
2279 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2280 if ((curop->op_type != OP_CONST ||
2281 (curop->op_private & OPpCONST_BARE)) &&
2282 curop->op_type != OP_LIST &&
2283 curop->op_type != OP_SCALAR &&
2284 curop->op_type != OP_NULL &&
2285 curop->op_type != OP_PUSHMARK)
2291 curop = LINKLIST(o);
2295 sv = *(PL_stack_sp--);
2296 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2297 pad_swipe(o->op_targ);
2298 else if (SvTEMP(sv)) { /* grab mortal temp? */
2299 (void)SvREFCNT_inc(sv);
2303 if (type == OP_RV2GV)
2304 return newGVOP(OP_GV, 0, (GV*)sv);
2306 /* try to smush double to int, but don't smush -2.0 to -2 */
2307 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2310 #ifdef PERL_PRESERVE_IVUV
2311 /* Only bother to attempt to fold to IV if
2312 most operators will benefit */
2316 return newSVOP(OP_CONST, 0, sv);
2320 if (!(PL_opargs[type] & OA_OTHERINT))
2323 if (!(PL_hints & HINT_INTEGER)) {
2324 if (type == OP_MODULO
2325 || type == OP_DIVIDE
2326 || !(o->op_flags & OPf_KIDS))
2331 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2332 if (curop->op_type == OP_CONST) {
2333 if (SvIOK(((SVOP*)curop)->op_sv))
2337 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2341 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2348 Perl_gen_constant_list(pTHX_ register OP *o)
2351 I32 oldtmps_floor = PL_tmps_floor;
2355 return o; /* Don't attempt to run with errors */
2357 PL_op = curop = LINKLIST(o);
2364 PL_tmps_floor = oldtmps_floor;
2366 o->op_type = OP_RV2AV;
2367 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2368 curop = ((UNOP*)o)->op_first;
2369 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2376 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2378 if (!o || o->op_type != OP_LIST)
2379 o = newLISTOP(OP_LIST, 0, o, Nullop);
2381 o->op_flags &= ~OPf_WANT;
2383 if (!(PL_opargs[type] & OA_MARK))
2384 op_null(cLISTOPo->op_first);
2387 o->op_ppaddr = PL_ppaddr[type];
2388 o->op_flags |= flags;
2390 o = CHECKOP(type, o);
2391 if (o->op_type != type)
2394 return fold_constants(o);
2397 /* List constructors */
2400 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2408 if (first->op_type != type
2409 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2411 return newLISTOP(type, 0, first, last);
2414 if (first->op_flags & OPf_KIDS)
2415 ((LISTOP*)first)->op_last->op_sibling = last;
2417 first->op_flags |= OPf_KIDS;
2418 ((LISTOP*)first)->op_first = last;
2420 ((LISTOP*)first)->op_last = last;
2425 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2433 if (first->op_type != type)
2434 return prepend_elem(type, (OP*)first, (OP*)last);
2436 if (last->op_type != type)
2437 return append_elem(type, (OP*)first, (OP*)last);
2439 first->op_last->op_sibling = last->op_first;
2440 first->op_last = last->op_last;
2441 first->op_flags |= (last->op_flags & OPf_KIDS);
2443 #ifdef PL_OP_SLAB_ALLOC
2451 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2459 if (last->op_type == type) {
2460 if (type == OP_LIST) { /* already a PUSHMARK there */
2461 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2462 ((LISTOP*)last)->op_first->op_sibling = first;
2463 if (!(first->op_flags & OPf_PARENS))
2464 last->op_flags &= ~OPf_PARENS;
2467 if (!(last->op_flags & OPf_KIDS)) {
2468 ((LISTOP*)last)->op_last = first;
2469 last->op_flags |= OPf_KIDS;
2471 first->op_sibling = ((LISTOP*)last)->op_first;
2472 ((LISTOP*)last)->op_first = first;
2474 last->op_flags |= OPf_KIDS;
2478 return newLISTOP(type, 0, first, last);
2484 Perl_newNULLLIST(pTHX)
2486 return newOP(OP_STUB, 0);
2490 Perl_force_list(pTHX_ OP *o)
2492 if (!o || o->op_type != OP_LIST)
2493 o = newLISTOP(OP_LIST, 0, o, Nullop);
2499 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2503 NewOp(1101, listop, 1, LISTOP);
2505 listop->op_type = type;
2506 listop->op_ppaddr = PL_ppaddr[type];
2509 listop->op_flags = flags;
2513 else if (!first && last)
2516 first->op_sibling = last;
2517 listop->op_first = first;
2518 listop->op_last = last;
2519 if (type == OP_LIST) {
2521 pushop = newOP(OP_PUSHMARK, 0);
2522 pushop->op_sibling = first;
2523 listop->op_first = pushop;
2524 listop->op_flags |= OPf_KIDS;
2526 listop->op_last = pushop;
2533 Perl_newOP(pTHX_ I32 type, I32 flags)
2536 NewOp(1101, o, 1, OP);
2538 o->op_ppaddr = PL_ppaddr[type];
2539 o->op_flags = flags;
2542 o->op_private = 0 + (flags >> 8);
2543 if (PL_opargs[type] & OA_RETSCALAR)
2545 if (PL_opargs[type] & OA_TARGET)
2546 o->op_targ = pad_alloc(type, SVs_PADTMP);
2547 return CHECKOP(type, o);
2551 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2556 first = newOP(OP_STUB, 0);
2557 if (PL_opargs[type] & OA_MARK)
2558 first = force_list(first);
2560 NewOp(1101, unop, 1, UNOP);
2561 unop->op_type = type;
2562 unop->op_ppaddr = PL_ppaddr[type];
2563 unop->op_first = first;
2564 unop->op_flags = flags | OPf_KIDS;
2565 unop->op_private = 1 | (flags >> 8);
2566 unop = (UNOP*) CHECKOP(type, unop);
2570 return fold_constants((OP *) unop);
2574 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2577 NewOp(1101, binop, 1, BINOP);
2580 first = newOP(OP_NULL, 0);
2582 binop->op_type = type;
2583 binop->op_ppaddr = PL_ppaddr[type];
2584 binop->op_first = first;
2585 binop->op_flags = flags | OPf_KIDS;
2588 binop->op_private = 1 | (flags >> 8);
2591 binop->op_private = 2 | (flags >> 8);
2592 first->op_sibling = last;
2595 binop = (BINOP*)CHECKOP(type, binop);
2596 if (binop->op_next || binop->op_type != type)
2599 binop->op_last = binop->op_first->op_sibling;
2601 return fold_constants((OP *)binop);
2605 uvcompare(const void *a, const void *b)
2607 if (*((UV *)a) < (*(UV *)b))
2609 if (*((UV *)a) > (*(UV *)b))
2611 if (*((UV *)a+1) < (*(UV *)b+1))
2613 if (*((UV *)a+1) > (*(UV *)b+1))
2619 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2621 SV *tstr = ((SVOP*)expr)->op_sv;
2622 SV *rstr = ((SVOP*)repl)->op_sv;
2625 U8 *t = (U8*)SvPV(tstr, tlen);
2626 U8 *r = (U8*)SvPV(rstr, rlen);
2633 register short *tbl;
2635 PL_hints |= HINT_BLOCK_SCOPE;
2636 complement = o->op_private & OPpTRANS_COMPLEMENT;
2637 del = o->op_private & OPpTRANS_DELETE;
2638 squash = o->op_private & OPpTRANS_SQUASH;
2641 o->op_private |= OPpTRANS_FROM_UTF;
2644 o->op_private |= OPpTRANS_TO_UTF;
2646 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2647 SV* listsv = newSVpvn("# comment\n",10);
2649 U8* tend = t + tlen;
2650 U8* rend = r + rlen;
2664 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2665 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2671 tsave = t = bytes_to_utf8(t, &len);
2674 if (!to_utf && rlen) {
2676 rsave = r = bytes_to_utf8(r, &len);
2680 /* There are several snags with this code on EBCDIC:
2681 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2682 2. scan_const() in toke.c has encoded chars in native encoding which makes
2683 ranges at least in EBCDIC 0..255 range the bottom odd.
2687 U8 tmpbuf[UTF8_MAXLEN+1];
2690 New(1109, cp, 2*tlen, UV);
2692 transv = newSVpvn("",0);
2694 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2696 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2698 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2702 cp[2*i+1] = cp[2*i];
2706 qsort(cp, i, 2*sizeof(UV), uvcompare);
2707 for (j = 0; j < i; j++) {
2709 diff = val - nextmin;
2711 t = uvuni_to_utf8(tmpbuf,nextmin);
2712 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2714 U8 range_mark = UTF_TO_NATIVE(0xff);
2715 t = uvuni_to_utf8(tmpbuf, val - 1);
2716 sv_catpvn(transv, (char *)&range_mark, 1);
2717 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2724 t = uvuni_to_utf8(tmpbuf,nextmin);
2725 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2727 U8 range_mark = UTF_TO_NATIVE(0xff);
2728 sv_catpvn(transv, (char *)&range_mark, 1);
2730 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2731 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2732 t = (U8*)SvPVX(transv);
2733 tlen = SvCUR(transv);
2737 else if (!rlen && !del) {
2738 r = t; rlen = tlen; rend = tend;
2741 if ((!rlen && !del) || t == r ||
2742 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2744 o->op_private |= OPpTRANS_IDENTICAL;
2748 while (t < tend || tfirst <= tlast) {
2749 /* see if we need more "t" chars */
2750 if (tfirst > tlast) {
2751 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2753 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2755 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2762 /* now see if we need more "r" chars */
2763 if (rfirst > rlast) {
2765 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2767 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2769 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2778 rfirst = rlast = 0xffffffff;
2782 /* now see which range will peter our first, if either. */
2783 tdiff = tlast - tfirst;
2784 rdiff = rlast - rfirst;
2791 if (rfirst == 0xffffffff) {
2792 diff = tdiff; /* oops, pretend rdiff is infinite */
2794 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2795 (long)tfirst, (long)tlast);
2797 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2801 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2802 (long)tfirst, (long)(tfirst + diff),
2805 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2806 (long)tfirst, (long)rfirst);
2808 if (rfirst + diff > max)
2809 max = rfirst + diff;
2811 grows = (tfirst < rfirst &&
2812 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2824 else if (max > 0xff)
2829 Safefree(cPVOPo->op_pv);
2830 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2831 SvREFCNT_dec(listsv);
2833 SvREFCNT_dec(transv);
2835 if (!del && havefinal && rlen)
2836 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2837 newSVuv((UV)final), 0);
2840 o->op_private |= OPpTRANS_GROWS;
2852 tbl = (short*)cPVOPo->op_pv;
2854 Zero(tbl, 256, short);
2855 for (i = 0; i < tlen; i++)
2857 for (i = 0, j = 0; i < 256; i++) {
2868 if (i < 128 && r[j] >= 128)
2878 o->op_private |= OPpTRANS_IDENTICAL;
2883 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2884 tbl[0x100] = rlen - j;
2885 for (i=0; i < rlen - j; i++)
2886 tbl[0x101+i] = r[j+i];
2890 if (!rlen && !del) {
2893 o->op_private |= OPpTRANS_IDENTICAL;
2895 for (i = 0; i < 256; i++)
2897 for (i = 0, j = 0; i < tlen; i++,j++) {
2900 if (tbl[t[i]] == -1)
2906 if (tbl[t[i]] == -1) {
2907 if (t[i] < 128 && r[j] >= 128)
2914 o->op_private |= OPpTRANS_GROWS;
2922 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2926 NewOp(1101, pmop, 1, PMOP);
2927 pmop->op_type = type;
2928 pmop->op_ppaddr = PL_ppaddr[type];
2929 pmop->op_flags = flags;
2930 pmop->op_private = 0 | (flags >> 8);
2932 if (PL_hints & HINT_RE_TAINT)
2933 pmop->op_pmpermflags |= PMf_RETAINT;
2934 if (PL_hints & HINT_LOCALE)
2935 pmop->op_pmpermflags |= PMf_LOCALE;
2936 pmop->op_pmflags = pmop->op_pmpermflags;
2938 /* link into pm list */
2939 if (type != OP_TRANS && PL_curstash) {
2940 pmop->op_pmnext = HvPMROOT(PL_curstash);
2941 HvPMROOT(PL_curstash) = pmop;
2942 PmopSTASH_set(pmop,PL_curstash);
2949 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2953 I32 repl_has_vars = 0;
2955 if (o->op_type == OP_TRANS)
2956 return pmtrans(o, expr, repl);
2958 PL_hints |= HINT_BLOCK_SCOPE;
2961 if (expr->op_type == OP_CONST) {
2963 SV *pat = ((SVOP*)expr)->op_sv;
2964 char *p = SvPV(pat, plen);
2965 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2966 sv_setpvn(pat, "\\s+", 3);
2967 p = SvPV(pat, plen);
2968 pm->op_pmflags |= PMf_SKIPWHITE;
2970 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2971 pm->op_pmdynflags |= PMdf_UTF8;
2972 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2973 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2974 pm->op_pmflags |= PMf_WHITE;
2978 if (PL_hints & HINT_UTF8)
2979 pm->op_pmdynflags |= PMdf_UTF8;
2980 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2981 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2983 : OP_REGCMAYBE),0,expr);
2985 NewOp(1101, rcop, 1, LOGOP);
2986 rcop->op_type = OP_REGCOMP;
2987 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2988 rcop->op_first = scalar(expr);
2989 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2990 ? (OPf_SPECIAL | OPf_KIDS)
2992 rcop->op_private = 1;
2995 /* establish postfix order */
2996 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2998 rcop->op_next = expr;
2999 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3002 rcop->op_next = LINKLIST(expr);
3003 expr->op_next = (OP*)rcop;
3006 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3011 if (pm->op_pmflags & PMf_EVAL) {
3013 if (CopLINE(PL_curcop) < PL_multi_end)
3014 CopLINE_set(PL_curcop, PL_multi_end);
3017 else if (repl->op_type == OP_THREADSV
3018 && strchr("&`'123456789+",
3019 PL_threadsv_names[repl->op_targ]))
3023 #endif /* USE_THREADS */
3024 else if (repl->op_type == OP_CONST)
3028 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3029 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3031 if (curop->op_type == OP_THREADSV) {
3033 if (strchr("&`'123456789+", curop->op_private))
3037 if (curop->op_type == OP_GV) {
3038 GV *gv = cGVOPx_gv(curop);
3040 if (strchr("&`'123456789+", *GvENAME(gv)))
3043 #endif /* USE_THREADS */
3044 else if (curop->op_type == OP_RV2CV)
3046 else if (curop->op_type == OP_RV2SV ||
3047 curop->op_type == OP_RV2AV ||
3048 curop->op_type == OP_RV2HV ||
3049 curop->op_type == OP_RV2GV) {
3050 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3053 else if (curop->op_type == OP_PADSV ||
3054 curop->op_type == OP_PADAV ||
3055 curop->op_type == OP_PADHV ||
3056 curop->op_type == OP_PADANY) {
3059 else if (curop->op_type == OP_PUSHRE)
3060 ; /* Okay here, dangerous in newASSIGNOP */
3069 && (!pm->op_pmregexp
3070 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3071 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3072 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3073 prepend_elem(o->op_type, scalar(repl), o);
3076 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3077 pm->op_pmflags |= PMf_MAYBE_CONST;
3078 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3080 NewOp(1101, rcop, 1, LOGOP);
3081 rcop->op_type = OP_SUBSTCONT;
3082 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3083 rcop->op_first = scalar(repl);
3084 rcop->op_flags |= OPf_KIDS;
3085 rcop->op_private = 1;
3088 /* establish postfix order */
3089 rcop->op_next = LINKLIST(repl);
3090 repl->op_next = (OP*)rcop;
3092 pm->op_pmreplroot = scalar((OP*)rcop);
3093 pm->op_pmreplstart = LINKLIST(rcop);
3102 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3105 NewOp(1101, svop, 1, SVOP);
3106 svop->op_type = type;
3107 svop->op_ppaddr = PL_ppaddr[type];
3109 svop->op_next = (OP*)svop;
3110 svop->op_flags = flags;
3111 if (PL_opargs[type] & OA_RETSCALAR)
3113 if (PL_opargs[type] & OA_TARGET)
3114 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3115 return CHECKOP(type, svop);
3119 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3122 NewOp(1101, padop, 1, PADOP);
3123 padop->op_type = type;
3124 padop->op_ppaddr = PL_ppaddr[type];
3125 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3126 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3127 PL_curpad[padop->op_padix] = sv;
3129 padop->op_next = (OP*)padop;
3130 padop->op_flags = flags;
3131 if (PL_opargs[type] & OA_RETSCALAR)
3133 if (PL_opargs[type] & OA_TARGET)
3134 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3135 return CHECKOP(type, padop);
3139 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3143 return newPADOP(type, flags, SvREFCNT_inc(gv));
3145 return newSVOP(type, flags, SvREFCNT_inc(gv));
3150 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3153 NewOp(1101, pvop, 1, PVOP);
3154 pvop->op_type = type;
3155 pvop->op_ppaddr = PL_ppaddr[type];
3157 pvop->op_next = (OP*)pvop;
3158 pvop->op_flags = flags;
3159 if (PL_opargs[type] & OA_RETSCALAR)
3161 if (PL_opargs[type] & OA_TARGET)
3162 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3163 return CHECKOP(type, pvop);
3167 Perl_package(pTHX_ OP *o)
3171 save_hptr(&PL_curstash);
3172 save_item(PL_curstname);
3177 name = SvPV(sv, len);
3178 PL_curstash = gv_stashpvn(name,len,TRUE);
3179 sv_setpvn(PL_curstname, name, len);
3183 sv_setpv(PL_curstname,"<none>");
3184 PL_curstash = Nullhv;
3186 PL_hints |= HINT_BLOCK_SCOPE;
3187 PL_copline = NOLINE;
3192 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3199 if (id->op_type != OP_CONST)
3200 Perl_croak(aTHX_ "Module name must be constant");
3204 if (version != Nullop) {
3205 SV *vesv = ((SVOP*)version)->op_sv;
3207 if (arg == Nullop && !SvNIOKp(vesv)) {
3214 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3215 Perl_croak(aTHX_ "Version number must be constant number");
3217 /* Make copy of id so we don't free it twice */
3218 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3220 /* Fake up a method call to VERSION */
3221 meth = newSVpvn("VERSION",7);
3222 sv_upgrade(meth, SVt_PVIV);
3223 (void)SvIOK_on(meth);
3224 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3225 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3226 append_elem(OP_LIST,
3227 prepend_elem(OP_LIST, pack, list(version)),
3228 newSVOP(OP_METHOD_NAMED, 0, meth)));
3232 /* Fake up an import/unimport */
3233 if (arg && arg->op_type == OP_STUB)
3234 imop = arg; /* no import on explicit () */
3235 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3236 imop = Nullop; /* use 5.0; */
3241 /* Make copy of id so we don't free it twice */
3242 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3244 /* Fake up a method call to import/unimport */
3245 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3246 sv_upgrade(meth, SVt_PVIV);
3247 (void)SvIOK_on(meth);
3248 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3249 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3250 append_elem(OP_LIST,
3251 prepend_elem(OP_LIST, pack, list(arg)),
3252 newSVOP(OP_METHOD_NAMED, 0, meth)));
3255 /* Fake up the BEGIN {}, which does its thing immediately. */
3257 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3260 append_elem(OP_LINESEQ,
3261 append_elem(OP_LINESEQ,
3262 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3263 newSTATEOP(0, Nullch, veop)),
3264 newSTATEOP(0, Nullch, imop) ));
3266 PL_hints |= HINT_BLOCK_SCOPE;
3267 PL_copline = NOLINE;
3272 =for apidoc load_module
3274 Loads the module whose name is pointed to by the string part of name.
3275 Note that the actual module name, not its filename, should be given.
3276 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3277 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3278 (or 0 for no flags). ver, if specified, provides version semantics
3279 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3280 arguments can be used to specify arguments to the module's import()
3281 method, similar to C<use Foo::Bar VERSION LIST>.
3286 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3289 va_start(args, ver);
3290 vload_module(flags, name, ver, &args);
3294 #ifdef PERL_IMPLICIT_CONTEXT
3296 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3300 va_start(args, ver);
3301 vload_module(flags, name, ver, &args);
3307 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3309 OP *modname, *veop, *imop;
3311 modname = newSVOP(OP_CONST, 0, name);
3312 modname->op_private |= OPpCONST_BARE;
3314 veop = newSVOP(OP_CONST, 0, ver);
3318 if (flags & PERL_LOADMOD_NOIMPORT) {
3319 imop = sawparens(newNULLLIST());
3321 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3322 imop = va_arg(*args, OP*);
3327 sv = va_arg(*args, SV*);
3329 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3330 sv = va_arg(*args, SV*);
3334 line_t ocopline = PL_copline;
3335 int oexpect = PL_expect;
3337 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3338 veop, modname, imop);
3339 PL_expect = oexpect;
3340 PL_copline = ocopline;
3345 Perl_dofile(pTHX_ OP *term)
3350 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3351 if (!(gv && GvIMPORTED_CV(gv)))
3352 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3354 if (gv && GvIMPORTED_CV(gv)) {
3355 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3356 append_elem(OP_LIST, term,
3357 scalar(newUNOP(OP_RV2CV, 0,
3362 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3368 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3370 return newBINOP(OP_LSLICE, flags,
3371 list(force_list(subscript)),
3372 list(force_list(listval)) );
3376 S_list_assignment(pTHX_ register OP *o)
3381 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3382 o = cUNOPo->op_first;
3384 if (o->op_type == OP_COND_EXPR) {
3385 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3386 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3391 yyerror("Assignment to both a list and a scalar");
3395 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3396 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3397 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3400 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3403 if (o->op_type == OP_RV2SV)
3410 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3415 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3416 return newLOGOP(optype, 0,
3417 mod(scalar(left), optype),
3418 newUNOP(OP_SASSIGN, 0, scalar(right)));
3421 return newBINOP(optype, OPf_STACKED,
3422 mod(scalar(left), optype), scalar(right));
3426 if (list_assignment(left)) {
3430 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3431 left = mod(left, OP_AASSIGN);
3439 curop = list(force_list(left));
3440 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3441 o->op_private = 0 | (flags >> 8);
3442 for (curop = ((LISTOP*)curop)->op_first;
3443 curop; curop = curop->op_sibling)
3445 if (curop->op_type == OP_RV2HV &&
3446 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3447 o->op_private |= OPpASSIGN_HASH;
3451 if (!(left->op_private & OPpLVAL_INTRO)) {
3454 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3455 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3456 if (curop->op_type == OP_GV) {
3457 GV *gv = cGVOPx_gv(curop);
3458 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3460 SvCUR(gv) = PL_generation;
3462 else if (curop->op_type == OP_PADSV ||
3463 curop->op_type == OP_PADAV ||
3464 curop->op_type == OP_PADHV ||
3465 curop->op_type == OP_PADANY) {
3466 SV **svp = AvARRAY(PL_comppad_name);
3467 SV *sv = svp[curop->op_targ];
3468 if (SvCUR(sv) == PL_generation)
3470 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3472 else if (curop->op_type == OP_RV2CV)
3474 else if (curop->op_type == OP_RV2SV ||
3475 curop->op_type == OP_RV2AV ||
3476 curop->op_type == OP_RV2HV ||
3477 curop->op_type == OP_RV2GV) {
3478 if (lastop->op_type != OP_GV) /* funny deref? */
3481 else if (curop->op_type == OP_PUSHRE) {
3482 if (((PMOP*)curop)->op_pmreplroot) {
3484 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3486 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3488 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3490 SvCUR(gv) = PL_generation;
3499 o->op_private |= OPpASSIGN_COMMON;
3501 if (right && right->op_type == OP_SPLIT) {
3503 if ((tmpop = ((LISTOP*)right)->op_first) &&
3504 tmpop->op_type == OP_PUSHRE)
3506 PMOP *pm = (PMOP*)tmpop;
3507 if (left->op_type == OP_RV2AV &&
3508 !(left->op_private & OPpLVAL_INTRO) &&
3509 !(o->op_private & OPpASSIGN_COMMON) )
3511 tmpop = ((UNOP*)left)->op_first;
3512 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3514 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3515 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3517 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3518 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3520 pm->op_pmflags |= PMf_ONCE;
3521 tmpop = cUNOPo->op_first; /* to list (nulled) */
3522 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3523 tmpop->op_sibling = Nullop; /* don't free split */
3524 right->op_next = tmpop->op_next; /* fix starting loc */
3525 op_free(o); /* blow off assign */
3526 right->op_flags &= ~OPf_WANT;
3527 /* "I don't know and I don't care." */
3532 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3533 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3535 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3537 sv_setiv(sv, PL_modcount+1);
3545 right = newOP(OP_UNDEF, 0);
3546 if (right->op_type == OP_READLINE) {
3547 right->op_flags |= OPf_STACKED;
3548 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3551 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3552 o = newBINOP(OP_SASSIGN, flags,
3553 scalar(right), mod(scalar(left), OP_SASSIGN) );
3565 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3567 U32 seq = intro_my();
3570 NewOp(1101, cop, 1, COP);
3571 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3572 cop->op_type = OP_DBSTATE;
3573 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3576 cop->op_type = OP_NEXTSTATE;
3577 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3579 cop->op_flags = flags;
3580 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3582 cop->op_private |= NATIVE_HINTS;
3584 PL_compiling.op_private = cop->op_private;
3585 cop->op_next = (OP*)cop;
3588 cop->cop_label = label;
3589 PL_hints |= HINT_BLOCK_SCOPE;
3592 cop->cop_arybase = PL_curcop->cop_arybase;
3593 if (specialWARN(PL_curcop->cop_warnings))
3594 cop->cop_warnings = PL_curcop->cop_warnings ;
3596 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3597 if (specialCopIO(PL_curcop->cop_io))
3598 cop->cop_io = PL_curcop->cop_io;
3600 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3603 if (PL_copline == NOLINE)
3604 CopLINE_set(cop, CopLINE(PL_curcop));
3606 CopLINE_set(cop, PL_copline);
3607 PL_copline = NOLINE;
3610 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3612 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3614 CopSTASH_set(cop, PL_curstash);
3616 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3617 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3618 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3619 (void)SvIOK_on(*svp);
3620 SvIVX(*svp) = PTR2IV(cop);
3624 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3627 /* "Introduce" my variables to visible status. */
3635 if (! PL_min_intro_pending)
3636 return PL_cop_seqmax;
3638 svp = AvARRAY(PL_comppad_name);
3639 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3640 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3641 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3642 SvNVX(sv) = (NV)PL_cop_seqmax;
3645 PL_min_intro_pending = 0;
3646 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3647 return PL_cop_seqmax++;
3651 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3653 return new_logop(type, flags, &first, &other);
3657 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3661 OP *first = *firstp;
3662 OP *other = *otherp;
3664 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3665 return newBINOP(type, flags, scalar(first), scalar(other));
3667 scalarboolean(first);
3668 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3669 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3670 if (type == OP_AND || type == OP_OR) {
3676 first = *firstp = cUNOPo->op_first;
3678 first->op_next = o->op_next;
3679 cUNOPo->op_first = Nullop;
3683 if (first->op_type == OP_CONST) {
3684 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3685 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3686 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3697 else if (first->op_type == OP_WANTARRAY) {
3703 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3704 OP *k1 = ((UNOP*)first)->op_first;
3705 OP *k2 = k1->op_sibling;
3707 switch (first->op_type)
3710 if (k2 && k2->op_type == OP_READLINE
3711 && (k2->op_flags & OPf_STACKED)
3712 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3714 warnop = k2->op_type;
3719 if (k1->op_type == OP_READDIR
3720 || k1->op_type == OP_GLOB
3721 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3722 || k1->op_type == OP_EACH)
3724 warnop = ((k1->op_type == OP_NULL)
3725 ? k1->op_targ : k1->op_type);
3730 line_t oldline = CopLINE(PL_curcop);
3731 CopLINE_set(PL_curcop, PL_copline);
3732 Perl_warner(aTHX_ WARN_MISC,
3733 "Value of %s%s can be \"0\"; test with defined()",
3735 ((warnop == OP_READLINE || warnop == OP_GLOB)
3736 ? " construct" : "() operator"));
3737 CopLINE_set(PL_curcop, oldline);
3744 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3745 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3747 NewOp(1101, logop, 1, LOGOP);
3749 logop->op_type = type;
3750 logop->op_ppaddr = PL_ppaddr[type];
3751 logop->op_first = first;
3752 logop->op_flags = flags | OPf_KIDS;
3753 logop->op_other = LINKLIST(other);
3754 logop->op_private = 1 | (flags >> 8);
3756 /* establish postfix order */
3757 logop->op_next = LINKLIST(first);
3758 first->op_next = (OP*)logop;
3759 first->op_sibling = other;
3761 o = newUNOP(OP_NULL, 0, (OP*)logop);
3768 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3775 return newLOGOP(OP_AND, 0, first, trueop);
3777 return newLOGOP(OP_OR, 0, first, falseop);
3779 scalarboolean(first);
3780 if (first->op_type == OP_CONST) {
3781 if (SvTRUE(((SVOP*)first)->op_sv)) {
3792 else if (first->op_type == OP_WANTARRAY) {
3796 NewOp(1101, logop, 1, LOGOP);
3797 logop->op_type = OP_COND_EXPR;
3798 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3799 logop->op_first = first;
3800 logop->op_flags = flags | OPf_KIDS;
3801 logop->op_private = 1 | (flags >> 8);
3802 logop->op_other = LINKLIST(trueop);
3803 logop->op_next = LINKLIST(falseop);
3806 /* establish postfix order */
3807 start = LINKLIST(first);
3808 first->op_next = (OP*)logop;
3810 first->op_sibling = trueop;
3811 trueop->op_sibling = falseop;
3812 o = newUNOP(OP_NULL, 0, (OP*)logop);
3814 trueop->op_next = falseop->op_next = o;
3821 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3829 NewOp(1101, range, 1, LOGOP);
3831 range->op_type = OP_RANGE;
3832 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3833 range->op_first = left;
3834 range->op_flags = OPf_KIDS;
3835 leftstart = LINKLIST(left);
3836 range->op_other = LINKLIST(right);
3837 range->op_private = 1 | (flags >> 8);
3839 left->op_sibling = right;
3841 range->op_next = (OP*)range;
3842 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3843 flop = newUNOP(OP_FLOP, 0, flip);
3844 o = newUNOP(OP_NULL, 0, flop);
3846 range->op_next = leftstart;
3848 left->op_next = flip;
3849 right->op_next = flop;
3851 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3852 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3853 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3854 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3856 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3857 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3860 if (!flip->op_private || !flop->op_private)
3861 linklist(o); /* blow off optimizer unless constant */
3867 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3871 int once = block && block->op_flags & OPf_SPECIAL &&
3872 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3875 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3876 return block; /* do {} while 0 does once */
3877 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3878 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3879 expr = newUNOP(OP_DEFINED, 0,
3880 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3881 } else if (expr->op_flags & OPf_KIDS) {
3882 OP *k1 = ((UNOP*)expr)->op_first;
3883 OP *k2 = (k1) ? k1->op_sibling : NULL;
3884 switch (expr->op_type) {
3886 if (k2 && k2->op_type == OP_READLINE
3887 && (k2->op_flags & OPf_STACKED)
3888 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3889 expr = newUNOP(OP_DEFINED, 0, expr);
3893 if (k1->op_type == OP_READDIR
3894 || k1->op_type == OP_GLOB
3895 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3896 || k1->op_type == OP_EACH)
3897 expr = newUNOP(OP_DEFINED, 0, expr);
3903 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3904 o = new_logop(OP_AND, 0, &expr, &listop);
3907 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3909 if (once && o != listop)
3910 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3913 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3915 o->op_flags |= flags;
3917 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3922 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3931 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3932 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3933 expr = newUNOP(OP_DEFINED, 0,
3934 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3935 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3936 OP *k1 = ((UNOP*)expr)->op_first;
3937 OP *k2 = (k1) ? k1->op_sibling : NULL;
3938 switch (expr->op_type) {
3940 if (k2 && k2->op_type == OP_READLINE
3941 && (k2->op_flags & OPf_STACKED)
3942 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3943 expr = newUNOP(OP_DEFINED, 0, expr);
3947 if (k1->op_type == OP_READDIR
3948 || k1->op_type == OP_GLOB
3949 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3950 || k1->op_type == OP_EACH)
3951 expr = newUNOP(OP_DEFINED, 0, expr);
3957 block = newOP(OP_NULL, 0);
3959 block = scope(block);
3963 next = LINKLIST(cont);
3966 OP *unstack = newOP(OP_UNSTACK, 0);
3969 cont = append_elem(OP_LINESEQ, cont, unstack);
3970 if ((line_t)whileline != NOLINE) {
3971 PL_copline = whileline;
3972 cont = append_elem(OP_LINESEQ, cont,
3973 newSTATEOP(0, Nullch, Nullop));
3977 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3978 redo = LINKLIST(listop);
3981 PL_copline = whileline;
3983 o = new_logop(OP_AND, 0, &expr, &listop);
3984 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3985 op_free(expr); /* oops, it's a while (0) */
3987 return Nullop; /* listop already freed by new_logop */
3990 ((LISTOP*)listop)->op_last->op_next = condop =
3991 (o == listop ? redo : LINKLIST(o));
3997 NewOp(1101,loop,1,LOOP);
3998 loop->op_type = OP_ENTERLOOP;
3999 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4000 loop->op_private = 0;
4001 loop->op_next = (OP*)loop;
4004 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4006 loop->op_redoop = redo;
4007 loop->op_lastop = o;
4008 o->op_private |= loopflags;
4011 loop->op_nextop = next;
4013 loop->op_nextop = o;
4015 o->op_flags |= flags;
4016 o->op_private |= (flags >> 8);
4021 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4029 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4030 sv->op_type = OP_RV2GV;
4031 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4033 else if (sv->op_type == OP_PADSV) { /* private variable */
4034 padoff = sv->op_targ;
4039 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4040 padoff = sv->op_targ;
4042 iterflags |= OPf_SPECIAL;
4047 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4051 padoff = find_threadsv("_");
4052 iterflags |= OPf_SPECIAL;
4054 sv = newGVOP(OP_GV, 0, PL_defgv);
4057 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4058 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4059 iterflags |= OPf_STACKED;
4061 else if (expr->op_type == OP_NULL &&
4062 (expr->op_flags & OPf_KIDS) &&
4063 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4065 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4066 * set the STACKED flag to indicate that these values are to be
4067 * treated as min/max values by 'pp_iterinit'.
4069 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4070 LOGOP* range = (LOGOP*) flip->op_first;
4071 OP* left = range->op_first;
4072 OP* right = left->op_sibling;
4075 range->op_flags &= ~OPf_KIDS;
4076 range->op_first = Nullop;
4078 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4079 listop->op_first->op_next = range->op_next;
4080 left->op_next = range->op_other;
4081 right->op_next = (OP*)listop;
4082 listop->op_next = listop->op_first;
4085 expr = (OP*)(listop);
4087 iterflags |= OPf_STACKED;
4090 expr = mod(force_list(expr), OP_GREPSTART);
4094 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4095 append_elem(OP_LIST, expr, scalar(sv))));
4096 assert(!loop->op_next);
4097 #ifdef PL_OP_SLAB_ALLOC
4100 NewOp(1234,tmp,1,LOOP);
4101 Copy(loop,tmp,1,LOOP);
4105 Renew(loop, 1, LOOP);
4107 loop->op_targ = padoff;
4108 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4109 PL_copline = forline;
4110 return newSTATEOP(0, label, wop);
4114 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4119 if (type != OP_GOTO || label->op_type == OP_CONST) {
4120 /* "last()" means "last" */
4121 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4122 o = newOP(type, OPf_SPECIAL);
4124 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4125 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4131 if (label->op_type == OP_ENTERSUB)
4132 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4133 o = newUNOP(type, OPf_STACKED, label);
4135 PL_hints |= HINT_BLOCK_SCOPE;
4140 Perl_cv_undef(pTHX_ CV *cv)
4144 MUTEX_DESTROY(CvMUTEXP(cv));
4145 Safefree(CvMUTEXP(cv));
4148 #endif /* USE_THREADS */
4150 if (!CvXSUB(cv) && CvROOT(cv)) {
4152 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4153 Perl_croak(aTHX_ "Can't undef active subroutine");
4156 Perl_croak(aTHX_ "Can't undef active subroutine");
4157 #endif /* USE_THREADS */
4160 SAVEVPTR(PL_curpad);
4163 op_free(CvROOT(cv));
4164 CvROOT(cv) = Nullop;
4167 SvPOK_off((SV*)cv); /* forget prototype */
4169 /* Since closure prototypes have the same lifetime as the containing
4170 * CV, they don't hold a refcount on the outside CV. This avoids
4171 * the refcount loop between the outer CV (which keeps a refcount to
4172 * the closure prototype in the pad entry for pp_anoncode()) and the
4173 * closure prototype, and the ensuing memory leak. --GSAR */
4174 if (!CvANON(cv) || CvCLONED(cv))
4175 SvREFCNT_dec(CvOUTSIDE(cv));
4176 CvOUTSIDE(cv) = Nullcv;
4178 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4181 if (CvPADLIST(cv)) {
4182 /* may be during global destruction */
4183 if (SvREFCNT(CvPADLIST(cv))) {
4184 I32 i = AvFILLp(CvPADLIST(cv));
4186 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4187 SV* sv = svp ? *svp : Nullsv;
4190 if (sv == (SV*)PL_comppad_name)
4191 PL_comppad_name = Nullav;
4192 else if (sv == (SV*)PL_comppad) {
4193 PL_comppad = Nullav;
4194 PL_curpad = Null(SV**);
4198 SvREFCNT_dec((SV*)CvPADLIST(cv));
4200 CvPADLIST(cv) = Nullav;
4208 #ifdef DEBUG_CLOSURES
4210 S_cv_dump(pTHX_ CV *cv)
4213 CV *outside = CvOUTSIDE(cv);
4214 AV* padlist = CvPADLIST(cv);
4221 PerlIO_printf(Perl_debug_log,
4222 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4224 (CvANON(cv) ? "ANON"
4225 : (cv == PL_main_cv) ? "MAIN"
4226 : CvUNIQUE(cv) ? "UNIQUE"
4227 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4230 : CvANON(outside) ? "ANON"
4231 : (outside == PL_main_cv) ? "MAIN"
4232 : CvUNIQUE(outside) ? "UNIQUE"
4233 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4238 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4239 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4240 pname = AvARRAY(pad_name);
4241 ppad = AvARRAY(pad);
4243 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4244 if (SvPOK(pname[ix]))
4245 PerlIO_printf(Perl_debug_log,
4246 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4247 (int)ix, PTR2UV(ppad[ix]),
4248 SvFAKE(pname[ix]) ? "FAKE " : "",
4250 (IV)I_32(SvNVX(pname[ix])),
4253 #endif /* DEBUGGING */
4255 #endif /* DEBUG_CLOSURES */
4258 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4262 AV* protopadlist = CvPADLIST(proto);
4263 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4264 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4265 SV** pname = AvARRAY(protopad_name);
4266 SV** ppad = AvARRAY(protopad);
4267 I32 fname = AvFILLp(protopad_name);
4268 I32 fpad = AvFILLp(protopad);
4272 assert(!CvUNIQUE(proto));
4276 SAVESPTR(PL_comppad_name);
4277 SAVESPTR(PL_compcv);
4279 cv = PL_compcv = (CV*)NEWSV(1104,0);
4280 sv_upgrade((SV *)cv, SvTYPE(proto));
4281 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4285 New(666, CvMUTEXP(cv), 1, perl_mutex);
4286 MUTEX_INIT(CvMUTEXP(cv));
4288 #endif /* USE_THREADS */
4289 CvFILE(cv) = CvFILE(proto);
4290 CvGV(cv) = CvGV(proto);
4291 CvSTASH(cv) = CvSTASH(proto);
4292 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4293 CvSTART(cv) = CvSTART(proto);
4295 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4298 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4300 PL_comppad_name = newAV();
4301 for (ix = fname; ix >= 0; ix--)
4302 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4304 PL_comppad = newAV();
4306 comppadlist = newAV();
4307 AvREAL_off(comppadlist);
4308 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4309 av_store(comppadlist, 1, (SV*)PL_comppad);
4310 CvPADLIST(cv) = comppadlist;
4311 av_fill(PL_comppad, AvFILLp(protopad));
4312 PL_curpad = AvARRAY(PL_comppad);
4314 av = newAV(); /* will be @_ */
4316 av_store(PL_comppad, 0, (SV*)av);
4317 AvFLAGS(av) = AVf_REIFY;
4319 for (ix = fpad; ix > 0; ix--) {
4320 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4321 if (namesv && namesv != &PL_sv_undef) {
4322 char *name = SvPVX(namesv); /* XXX */
4323 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4324 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4325 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4327 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4329 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4331 else { /* our own lexical */
4334 /* anon code -- we'll come back for it */
4335 sv = SvREFCNT_inc(ppad[ix]);
4337 else if (*name == '@')
4339 else if (*name == '%')
4348 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4349 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4352 SV* sv = NEWSV(0,0);
4358 /* Now that vars are all in place, clone nested closures. */
4360 for (ix = fpad; ix > 0; ix--) {
4361 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4363 && namesv != &PL_sv_undef
4364 && !(SvFLAGS(namesv) & SVf_FAKE)
4365 && *SvPVX(namesv) == '&'
4366 && CvCLONE(ppad[ix]))
4368 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4369 SvREFCNT_dec(ppad[ix]);
4372 PL_curpad[ix] = (SV*)kid;
4376 #ifdef DEBUG_CLOSURES
4377 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4379 PerlIO_printf(Perl_debug_log, " from:\n");
4381 PerlIO_printf(Perl_debug_log, " to:\n");
4388 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4390 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4392 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4399 Perl_cv_clone(pTHX_ CV *proto)
4402 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4403 cv = cv_clone2(proto, CvOUTSIDE(proto));
4404 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4409 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4411 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4412 SV* msg = sv_newmortal();
4416 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4417 sv_setpv(msg, "Prototype mismatch:");
4419 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4421 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4422 sv_catpv(msg, " vs ");
4424 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4426 sv_catpv(msg, "none");
4427 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4431 static void const_sv_xsub(pTHXo_ CV* cv);
4434 =for apidoc cv_const_sv
4436 If C<cv> is a constant sub eligible for inlining. returns the constant
4437 value returned by the sub. Otherwise, returns NULL.
4439 Constant subs can be created with C<newCONSTSUB> or as described in
4440 L<perlsub/"Constant Functions">.
4445 Perl_cv_const_sv(pTHX_ CV *cv)
4447 if (!cv || !CvCONST(cv))
4449 return (SV*)CvXSUBANY(cv).any_ptr;
4453 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4460 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4461 o = cLISTOPo->op_first->op_sibling;
4463 for (; o; o = o->op_next) {
4464 OPCODE type = o->op_type;
4466 if (sv && o->op_next == o)
4468 if (o->op_next != o) {
4469 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4471 if (type == OP_DBSTATE)
4474 if (type == OP_LEAVESUB || type == OP_RETURN)
4478 if (type == OP_CONST && cSVOPo->op_sv)
4480 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4481 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4482 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4486 /* We get here only from cv_clone2() while creating a closure.
4487 Copy the const value here instead of in cv_clone2 so that
4488 SvREADONLY_on doesn't lead to problems when leaving
4493 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4505 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4515 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4519 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4521 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4525 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4531 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4536 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4537 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4538 SV *sv = sv_newmortal();
4539 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4540 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4545 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4546 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4556 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4557 maximum a prototype before. */
4558 if (SvTYPE(gv) > SVt_NULL) {
4559 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4560 && ckWARN_d(WARN_PROTOTYPE))
4562 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4564 cv_ckproto((CV*)gv, NULL, ps);
4567 sv_setpv((SV*)gv, ps);
4569 sv_setiv((SV*)gv, -1);
4570 SvREFCNT_dec(PL_compcv);
4571 cv = PL_compcv = NULL;
4572 PL_sub_generation++;
4576 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4578 #ifdef GV_SHARED_CHECK
4579 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4580 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4584 if (!block || !ps || *ps || attrs)
4587 const_sv = op_const_sv(block, Nullcv);
4590 bool exists = CvROOT(cv) || CvXSUB(cv);
4592 #ifdef GV_SHARED_CHECK
4593 if (exists && GvSHARED(gv)) {
4594 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4598 /* if the subroutine doesn't exist and wasn't pre-declared
4599 * with a prototype, assume it will be AUTOLOADed,
4600 * skipping the prototype check
4602 if (exists || SvPOK(cv))
4603 cv_ckproto(cv, gv, ps);
4604 /* already defined (or promised)? */
4605 if (exists || GvASSUMECV(gv)) {
4606 if (!block && !attrs) {
4607 /* just a "sub foo;" when &foo is already defined */
4608 SAVEFREESV(PL_compcv);
4611 /* ahem, death to those who redefine active sort subs */
4612 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4613 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4615 if (ckWARN(WARN_REDEFINE)
4617 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4619 line_t oldline = CopLINE(PL_curcop);
4620 CopLINE_set(PL_curcop, PL_copline);
4621 Perl_warner(aTHX_ WARN_REDEFINE,
4622 CvCONST(cv) ? "Constant subroutine %s redefined"
4623 : "Subroutine %s redefined", name);
4624 CopLINE_set(PL_curcop, oldline);
4632 SvREFCNT_inc(const_sv);
4634 assert(!CvROOT(cv) && !CvCONST(cv));
4635 sv_setpv((SV*)cv, ""); /* prototype is "" */
4636 CvXSUBANY(cv).any_ptr = const_sv;
4637 CvXSUB(cv) = const_sv_xsub;
4642 cv = newCONSTSUB(NULL, name, const_sv);
4645 SvREFCNT_dec(PL_compcv);
4647 PL_sub_generation++;
4654 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4655 * before we clobber PL_compcv.
4659 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4660 stash = GvSTASH(CvGV(cv));
4661 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4662 stash = CvSTASH(cv);
4664 stash = PL_curstash;
4667 /* possibly about to re-define existing subr -- ignore old cv */
4668 rcv = (SV*)PL_compcv;
4669 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4670 stash = GvSTASH(gv);
4672 stash = PL_curstash;
4674 apply_attrs(stash, rcv, attrs);
4676 if (cv) { /* must reuse cv if autoloaded */
4678 /* got here with just attrs -- work done, so bug out */
4679 SAVEFREESV(PL_compcv);
4683 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4684 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4685 CvOUTSIDE(PL_compcv) = 0;
4686 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4687 CvPADLIST(PL_compcv) = 0;
4688 /* inner references to PL_compcv must be fixed up ... */
4690 AV *padlist = CvPADLIST(cv);
4691 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4692 AV *comppad = (AV*)AvARRAY(padlist)[1];
4693 SV **namepad = AvARRAY(comppad_name);
4694 SV **curpad = AvARRAY(comppad);
4695 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4696 SV *namesv = namepad[ix];
4697 if (namesv && namesv != &PL_sv_undef
4698 && *SvPVX(namesv) == '&')
4700 CV *innercv = (CV*)curpad[ix];
4701 if (CvOUTSIDE(innercv) == PL_compcv) {
4702 CvOUTSIDE(innercv) = cv;
4703 if (!CvANON(innercv) || CvCLONED(innercv)) {
4704 (void)SvREFCNT_inc(cv);
4705 SvREFCNT_dec(PL_compcv);
4711 /* ... before we throw it away */
4712 SvREFCNT_dec(PL_compcv);
4719 PL_sub_generation++;
4723 CvFILE(cv) = CopFILE(PL_curcop);
4724 CvSTASH(cv) = PL_curstash;
4727 if (!CvMUTEXP(cv)) {
4728 New(666, CvMUTEXP(cv), 1, perl_mutex);
4729 MUTEX_INIT(CvMUTEXP(cv));
4731 #endif /* USE_THREADS */
4734 sv_setpv((SV*)cv, ps);
4736 if (PL_error_count) {
4740 char *s = strrchr(name, ':');
4742 if (strEQ(s, "BEGIN")) {
4744 "BEGIN not safe after errors--compilation aborted";
4745 if (PL_in_eval & EVAL_KEEPERR)
4746 Perl_croak(aTHX_ not_safe);
4748 /* force display of errors found but not reported */
4749 sv_catpv(ERRSV, not_safe);
4750 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4758 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4759 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4762 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4763 mod(scalarseq(block), OP_LEAVESUBLV));
4766 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4768 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4769 OpREFCNT_set(CvROOT(cv), 1);
4770 CvSTART(cv) = LINKLIST(CvROOT(cv));
4771 CvROOT(cv)->op_next = 0;
4774 /* now that optimizer has done its work, adjust pad values */
4776 SV **namep = AvARRAY(PL_comppad_name);
4777 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4780 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4783 * The only things that a clonable function needs in its
4784 * pad are references to outer lexicals and anonymous subs.
4785 * The rest are created anew during cloning.
4787 if (!((namesv = namep[ix]) != Nullsv &&
4788 namesv != &PL_sv_undef &&
4790 *SvPVX(namesv) == '&')))
4792 SvREFCNT_dec(PL_curpad[ix]);
4793 PL_curpad[ix] = Nullsv;
4796 assert(!CvCONST(cv));
4797 if (ps && !*ps && op_const_sv(block, cv))
4801 AV *av = newAV(); /* Will be @_ */
4803 av_store(PL_comppad, 0, (SV*)av);
4804 AvFLAGS(av) = AVf_REIFY;
4806 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4807 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4809 if (!SvPADMY(PL_curpad[ix]))
4810 SvPADTMP_on(PL_curpad[ix]);
4814 /* If a potential closure prototype, don't keep a refcount on outer CV.
4815 * This is okay as the lifetime of the prototype is tied to the
4816 * lifetime of the outer CV. Avoids memory leak due to reference
4819 SvREFCNT_dec(CvOUTSIDE(cv));
4821 if (name || aname) {
4823 char *tname = (name ? name : aname);
4825 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4826 SV *sv = NEWSV(0,0);
4827 SV *tmpstr = sv_newmortal();
4828 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4832 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4834 (long)PL_subline, (long)CopLINE(PL_curcop));
4835 gv_efullname3(tmpstr, gv, Nullch);
4836 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4837 hv = GvHVn(db_postponed);
4838 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4839 && (pcv = GvCV(db_postponed)))
4845 call_sv((SV*)pcv, G_DISCARD);
4849 if ((s = strrchr(tname,':')))
4854 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4857 if (strEQ(s, "BEGIN")) {
4858 I32 oldscope = PL_scopestack_ix;
4860 SAVECOPFILE(&PL_compiling);
4861 SAVECOPLINE(&PL_compiling);
4863 sv_setsv(PL_rs, PL_nrs);
4866 PL_beginav = newAV();
4867 DEBUG_x( dump_sub(gv) );
4868 av_push(PL_beginav, (SV*)cv);
4869 GvCV(gv) = 0; /* cv has been hijacked */
4870 call_list(oldscope, PL_beginav);
4872 PL_curcop = &PL_compiling;
4873 PL_compiling.op_private = PL_hints;
4876 else if (strEQ(s, "END") && !PL_error_count) {
4879 DEBUG_x( dump_sub(gv) );
4880 av_unshift(PL_endav, 1);
4881 av_store(PL_endav, 0, (SV*)cv);
4882 GvCV(gv) = 0; /* cv has been hijacked */
4884 else if (strEQ(s, "CHECK") && !PL_error_count) {
4886 PL_checkav = newAV();
4887 DEBUG_x( dump_sub(gv) );
4888 if (PL_main_start && ckWARN(WARN_VOID))
4889 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4890 av_unshift(PL_checkav, 1);
4891 av_store(PL_checkav, 0, (SV*)cv);
4892 GvCV(gv) = 0; /* cv has been hijacked */
4894 else if (strEQ(s, "INIT") && !PL_error_count) {
4896 PL_initav = newAV();
4897 DEBUG_x( dump_sub(gv) );
4898 if (PL_main_start && ckWARN(WARN_VOID))
4899 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4900 av_push(PL_initav, (SV*)cv);
4901 GvCV(gv) = 0; /* cv has been hijacked */
4906 PL_copline = NOLINE;
4911 /* XXX unsafe for threads if eval_owner isn't held */
4913 =for apidoc newCONSTSUB
4915 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4916 eligible for inlining at compile-time.
4922 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4928 SAVECOPLINE(PL_curcop);
4929 CopLINE_set(PL_curcop, PL_copline);
4932 PL_hints &= ~HINT_BLOCK_SCOPE;
4935 SAVESPTR(PL_curstash);
4936 SAVECOPSTASH(PL_curcop);
4937 PL_curstash = stash;
4939 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4941 CopSTASH(PL_curcop) = stash;
4945 cv = newXS(name, const_sv_xsub, __FILE__);
4946 CvXSUBANY(cv).any_ptr = sv;
4948 sv_setpv((SV*)cv, ""); /* prototype is "" */
4956 =for apidoc U||newXS
4958 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4964 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4966 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4969 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4971 /* just a cached method */
4975 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4976 /* already defined (or promised) */
4977 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4978 && HvNAME(GvSTASH(CvGV(cv)))
4979 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4980 line_t oldline = CopLINE(PL_curcop);
4981 if (PL_copline != NOLINE)
4982 CopLINE_set(PL_curcop, PL_copline);
4983 Perl_warner(aTHX_ WARN_REDEFINE,
4984 CvCONST(cv) ? "Constant subroutine %s redefined"
4985 : "Subroutine %s redefined"
4987 CopLINE_set(PL_curcop, oldline);
4994 if (cv) /* must reuse cv if autoloaded */
4997 cv = (CV*)NEWSV(1105,0);
4998 sv_upgrade((SV *)cv, SVt_PVCV);
5002 PL_sub_generation++;
5007 New(666, CvMUTEXP(cv), 1, perl_mutex);
5008 MUTEX_INIT(CvMUTEXP(cv));
5010 #endif /* USE_THREADS */
5011 (void)gv_fetchfile(filename);
5012 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5013 an external constant string */
5014 CvXSUB(cv) = subaddr;
5017 char *s = strrchr(name,':');
5023 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5026 if (strEQ(s, "BEGIN")) {
5028 PL_beginav = newAV();
5029 av_push(PL_beginav, (SV*)cv);
5030 GvCV(gv) = 0; /* cv has been hijacked */
5032 else if (strEQ(s, "END")) {
5035 av_unshift(PL_endav, 1);
5036 av_store(PL_endav, 0, (SV*)cv);
5037 GvCV(gv) = 0; /* cv has been hijacked */
5039 else if (strEQ(s, "CHECK")) {
5041 PL_checkav = newAV();
5042 if (PL_main_start && ckWARN(WARN_VOID))
5043 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5044 av_unshift(PL_checkav, 1);
5045 av_store(PL_checkav, 0, (SV*)cv);
5046 GvCV(gv) = 0; /* cv has been hijacked */
5048 else if (strEQ(s, "INIT")) {
5050 PL_initav = newAV();
5051 if (PL_main_start && ckWARN(WARN_VOID))
5052 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5053 av_push(PL_initav, (SV*)cv);
5054 GvCV(gv) = 0; /* cv has been hijacked */
5065 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5074 name = SvPVx(cSVOPo->op_sv, n_a);
5077 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5078 #ifdef GV_SHARED_CHECK
5080 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5084 if ((cv = GvFORM(gv))) {
5085 if (ckWARN(WARN_REDEFINE)) {
5086 line_t oldline = CopLINE(PL_curcop);
5088 CopLINE_set(PL_curcop, PL_copline);
5089 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5090 CopLINE_set(PL_curcop, oldline);
5097 CvFILE(cv) = CopFILE(PL_curcop);
5099 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5100 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5101 SvPADTMP_on(PL_curpad[ix]);
5104 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5105 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5106 OpREFCNT_set(CvROOT(cv), 1);
5107 CvSTART(cv) = LINKLIST(CvROOT(cv));
5108 CvROOT(cv)->op_next = 0;
5111 PL_copline = NOLINE;
5116 Perl_newANONLIST(pTHX_ OP *o)
5118 return newUNOP(OP_REFGEN, 0,
5119 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5123 Perl_newANONHASH(pTHX_ OP *o)
5125 return newUNOP(OP_REFGEN, 0,
5126 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5130 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5132 return newANONATTRSUB(floor, proto, Nullop, block);
5136 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5138 return newUNOP(OP_REFGEN, 0,
5139 newSVOP(OP_ANONCODE, 0,
5140 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5144 Perl_oopsAV(pTHX_ OP *o)
5146 switch (o->op_type) {
5148 o->op_type = OP_PADAV;
5149 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5150 return ref(o, OP_RV2AV);
5153 o->op_type = OP_RV2AV;
5154 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5159 if (ckWARN_d(WARN_INTERNAL))
5160 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5167 Perl_oopsHV(pTHX_ OP *o)
5169 switch (o->op_type) {
5172 o->op_type = OP_PADHV;
5173 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5174 return ref(o, OP_RV2HV);
5178 o->op_type = OP_RV2HV;
5179 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5184 if (ckWARN_d(WARN_INTERNAL))
5185 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5192 Perl_newAVREF(pTHX_ OP *o)
5194 if (o->op_type == OP_PADANY) {
5195 o->op_type = OP_PADAV;
5196 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5199 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5200 && ckWARN(WARN_DEPRECATED)) {
5201 Perl_warner(aTHX_ WARN_DEPRECATED,
5202 "Using an array as a reference is deprecated");
5204 return newUNOP(OP_RV2AV, 0, scalar(o));
5208 Perl_newGVREF(pTHX_ I32 type, OP *o)
5210 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5211 return newUNOP(OP_NULL, 0, o);
5212 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5216 Perl_newHVREF(pTHX_ OP *o)
5218 if (o->op_type == OP_PADANY) {
5219 o->op_type = OP_PADHV;
5220 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5223 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5224 && ckWARN(WARN_DEPRECATED)) {
5225 Perl_warner(aTHX_ WARN_DEPRECATED,
5226 "Using a hash as a reference is deprecated");
5228 return newUNOP(OP_RV2HV, 0, scalar(o));
5232 Perl_oopsCV(pTHX_ OP *o)
5234 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5240 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5242 return newUNOP(OP_RV2CV, flags, scalar(o));
5246 Perl_newSVREF(pTHX_ OP *o)
5248 if (o->op_type == OP_PADANY) {
5249 o->op_type = OP_PADSV;
5250 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5253 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5254 o->op_flags |= OPpDONE_SVREF;
5257 return newUNOP(OP_RV2SV, 0, scalar(o));
5260 /* Check routines. */
5263 Perl_ck_anoncode(pTHX_ OP *o)
5268 name = NEWSV(1106,0);
5269 sv_upgrade(name, SVt_PVNV);
5270 sv_setpvn(name, "&", 1);
5273 ix = pad_alloc(o->op_type, SVs_PADMY);
5274 av_store(PL_comppad_name, ix, name);
5275 av_store(PL_comppad, ix, cSVOPo->op_sv);
5276 SvPADMY_on(cSVOPo->op_sv);
5277 cSVOPo->op_sv = Nullsv;
5278 cSVOPo->op_targ = ix;
5283 Perl_ck_bitop(pTHX_ OP *o)
5285 o->op_private = PL_hints;
5290 Perl_ck_concat(pTHX_ OP *o)
5292 if (cUNOPo->op_first->op_type == OP_CONCAT)
5293 o->op_flags |= OPf_STACKED;
5298 Perl_ck_spair(pTHX_ OP *o)
5300 if (o->op_flags & OPf_KIDS) {
5303 OPCODE type = o->op_type;
5304 o = modkids(ck_fun(o), type);
5305 kid = cUNOPo->op_first;
5306 newop = kUNOP->op_first->op_sibling;
5308 (newop->op_sibling ||
5309 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5310 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5311 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5315 op_free(kUNOP->op_first);
5316 kUNOP->op_first = newop;
5318 o->op_ppaddr = PL_ppaddr[++o->op_type];
5323 Perl_ck_delete(pTHX_ OP *o)
5327 if (o->op_flags & OPf_KIDS) {
5328 OP *kid = cUNOPo->op_first;
5329 switch (kid->op_type) {
5331 o->op_flags |= OPf_SPECIAL;
5334 o->op_private |= OPpSLICE;
5337 o->op_flags |= OPf_SPECIAL;
5342 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5343 PL_op_desc[o->op_type]);
5351 Perl_ck_eof(pTHX_ OP *o)
5353 I32 type = o->op_type;
5355 if (o->op_flags & OPf_KIDS) {
5356 if (cLISTOPo->op_first->op_type == OP_STUB) {
5358 o = newUNOP(type, OPf_SPECIAL,
5359 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5367 Perl_ck_eval(pTHX_ OP *o)
5369 PL_hints |= HINT_BLOCK_SCOPE;
5370 if (o->op_flags & OPf_KIDS) {
5371 SVOP *kid = (SVOP*)cUNOPo->op_first;
5374 o->op_flags &= ~OPf_KIDS;
5377 else if (kid->op_type == OP_LINESEQ) {
5380 kid->op_next = o->op_next;
5381 cUNOPo->op_first = 0;
5384 NewOp(1101, enter, 1, LOGOP);
5385 enter->op_type = OP_ENTERTRY;
5386 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5387 enter->op_private = 0;
5389 /* establish postfix order */
5390 enter->op_next = (OP*)enter;
5392 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5393 o->op_type = OP_LEAVETRY;
5394 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5395 enter->op_other = o;
5403 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5405 o->op_targ = (PADOFFSET)PL_hints;
5410 Perl_ck_exit(pTHX_ OP *o)
5413 HV *table = GvHV(PL_hintgv);
5415 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5416 if (svp && *svp && SvTRUE(*svp))
5417 o->op_private |= OPpEXIT_VMSISH;
5424 Perl_ck_exec(pTHX_ OP *o)
5427 if (o->op_flags & OPf_STACKED) {
5429 kid = cUNOPo->op_first->op_sibling;
5430 if (kid->op_type == OP_RV2GV)
5439 Perl_ck_exists(pTHX_ OP *o)
5442 if (o->op_flags & OPf_KIDS) {
5443 OP *kid = cUNOPo->op_first;
5444 if (kid->op_type == OP_ENTERSUB) {
5445 (void) ref(kid, o->op_type);
5446 if (kid->op_type != OP_RV2CV && !PL_error_count)
5447 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5448 PL_op_desc[o->op_type]);
5449 o->op_private |= OPpEXISTS_SUB;
5451 else if (kid->op_type == OP_AELEM)
5452 o->op_flags |= OPf_SPECIAL;
5453 else if (kid->op_type != OP_HELEM)
5454 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5455 PL_op_desc[o->op_type]);
5463 Perl_ck_gvconst(pTHX_ register OP *o)
5465 o = fold_constants(o);
5466 if (o->op_type == OP_CONST)
5473 Perl_ck_rvconst(pTHX_ register OP *o)
5475 SVOP *kid = (SVOP*)cUNOPo->op_first;
5477 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5478 if (kid->op_type == OP_CONST) {
5482 SV *kidsv = kid->op_sv;
5485 /* Is it a constant from cv_const_sv()? */
5486 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5487 SV *rsv = SvRV(kidsv);
5488 int svtype = SvTYPE(rsv);
5489 char *badtype = Nullch;
5491 switch (o->op_type) {
5493 if (svtype > SVt_PVMG)
5494 badtype = "a SCALAR";
5497 if (svtype != SVt_PVAV)
5498 badtype = "an ARRAY";
5501 if (svtype != SVt_PVHV) {
5502 if (svtype == SVt_PVAV) { /* pseudohash? */
5503 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5504 if (ksv && SvROK(*ksv)
5505 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5514 if (svtype != SVt_PVCV)
5519 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5522 name = SvPV(kidsv, n_a);
5523 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5524 char *badthing = Nullch;
5525 switch (o->op_type) {
5527 badthing = "a SCALAR";
5530 badthing = "an ARRAY";
5533 badthing = "a HASH";
5538 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5542 * This is a little tricky. We only want to add the symbol if we
5543 * didn't add it in the lexer. Otherwise we get duplicate strict
5544 * warnings. But if we didn't add it in the lexer, we must at
5545 * least pretend like we wanted to add it even if it existed before,
5546 * or we get possible typo warnings. OPpCONST_ENTERED says
5547 * whether the lexer already added THIS instance of this symbol.
5549 iscv = (o->op_type == OP_RV2CV) * 2;
5551 gv = gv_fetchpv(name,
5552 iscv | !(kid->op_private & OPpCONST_ENTERED),
5555 : o->op_type == OP_RV2SV
5557 : o->op_type == OP_RV2AV
5559 : o->op_type == OP_RV2HV
5562 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5564 kid->op_type = OP_GV;
5565 SvREFCNT_dec(kid->op_sv);
5567 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5568 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5569 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5571 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5573 kid->op_sv = SvREFCNT_inc(gv);
5575 kid->op_private = 0;
5576 kid->op_ppaddr = PL_ppaddr[OP_GV];
5583 Perl_ck_ftst(pTHX_ OP *o)
5585 I32 type = o->op_type;
5587 if (o->op_flags & OPf_REF) {
5590 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5591 SVOP *kid = (SVOP*)cUNOPo->op_first;
5593 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5595 OP *newop = newGVOP(type, OPf_REF,
5596 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5603 if (type == OP_FTTTY)
5604 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5607 o = newUNOP(type, 0, newDEFSVOP());
5610 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5612 if (PL_hints & HINT_LOCALE)
5613 o->op_private |= OPpLOCALE;
5620 Perl_ck_fun(pTHX_ OP *o)
5626 int type = o->op_type;
5627 register I32 oa = PL_opargs[type] >> OASHIFT;
5629 if (o->op_flags & OPf_STACKED) {
5630 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5633 return no_fh_allowed(o);
5636 if (o->op_flags & OPf_KIDS) {
5638 tokid = &cLISTOPo->op_first;
5639 kid = cLISTOPo->op_first;
5640 if (kid->op_type == OP_PUSHMARK ||
5641 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5643 tokid = &kid->op_sibling;
5644 kid = kid->op_sibling;
5646 if (!kid && PL_opargs[type] & OA_DEFGV)
5647 *tokid = kid = newDEFSVOP();
5651 sibl = kid->op_sibling;
5654 /* list seen where single (scalar) arg expected? */
5655 if (numargs == 1 && !(oa >> 4)
5656 && kid->op_type == OP_LIST && type != OP_SCALAR)
5658 return too_many_arguments(o,PL_op_desc[type]);
5671 if ((type == OP_PUSH || type == OP_UNSHIFT)
5672 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5673 Perl_warner(aTHX_ WARN_SYNTAX,
5674 "Useless use of %s with no values",
5677 if (kid->op_type == OP_CONST &&
5678 (kid->op_private & OPpCONST_BARE))
5680 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5681 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5682 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5683 if (ckWARN(WARN_DEPRECATED))
5684 Perl_warner(aTHX_ WARN_DEPRECATED,
5685 "Array @%s missing the @ in argument %"IVdf" of %s()",
5686 name, (IV)numargs, PL_op_desc[type]);
5689 kid->op_sibling = sibl;
5692 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5693 bad_type(numargs, "array", PL_op_desc[type], kid);
5697 if (kid->op_type == OP_CONST &&
5698 (kid->op_private & OPpCONST_BARE))
5700 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5701 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5702 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5703 if (ckWARN(WARN_DEPRECATED))
5704 Perl_warner(aTHX_ WARN_DEPRECATED,
5705 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5706 name, (IV)numargs, PL_op_desc[type]);
5709 kid->op_sibling = sibl;
5712 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5713 bad_type(numargs, "hash", PL_op_desc[type], kid);
5718 OP *newop = newUNOP(OP_NULL, 0, kid);
5719 kid->op_sibling = 0;
5721 newop->op_next = newop;
5723 kid->op_sibling = sibl;
5728 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5729 if (kid->op_type == OP_CONST &&
5730 (kid->op_private & OPpCONST_BARE))
5732 OP *newop = newGVOP(OP_GV, 0,
5733 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5738 else if (kid->op_type == OP_READLINE) {
5739 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5740 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5743 I32 flags = OPf_SPECIAL;
5747 /* is this op a FH constructor? */
5748 if (is_handle_constructor(o,numargs)) {
5749 char *name = Nullch;
5753 /* Set a flag to tell rv2gv to vivify
5754 * need to "prove" flag does not mean something
5755 * else already - NI-S 1999/05/07
5758 if (kid->op_type == OP_PADSV) {
5759 SV **namep = av_fetch(PL_comppad_name,
5761 if (namep && *namep)
5762 name = SvPV(*namep, len);
5764 else if (kid->op_type == OP_RV2SV
5765 && kUNOP->op_first->op_type == OP_GV)
5767 GV *gv = cGVOPx_gv(kUNOP->op_first);
5769 len = GvNAMELEN(gv);
5771 else if (kid->op_type == OP_AELEM
5772 || kid->op_type == OP_HELEM)
5774 name = "__ANONIO__";
5780 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5781 namesv = PL_curpad[targ];
5782 (void)SvUPGRADE(namesv, SVt_PV);
5784 sv_setpvn(namesv, "$", 1);
5785 sv_catpvn(namesv, name, len);
5788 kid->op_sibling = 0;
5789 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5790 kid->op_targ = targ;
5791 kid->op_private |= priv;
5793 kid->op_sibling = sibl;
5799 mod(scalar(kid), type);
5803 tokid = &kid->op_sibling;
5804 kid = kid->op_sibling;
5806 o->op_private |= numargs;
5808 return too_many_arguments(o,PL_op_desc[o->op_type]);
5811 else if (PL_opargs[type] & OA_DEFGV) {
5813 return newUNOP(type, 0, newDEFSVOP());
5817 while (oa & OA_OPTIONAL)
5819 if (oa && oa != OA_LIST)
5820 return too_few_arguments(o,PL_op_desc[o->op_type]);
5826 Perl_ck_glob(pTHX_ OP *o)
5831 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5832 append_elem(OP_GLOB, o, newDEFSVOP());
5834 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5835 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5837 #if !defined(PERL_EXTERNAL_GLOB)
5838 /* XXX this can be tightened up and made more failsafe. */
5842 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5844 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5845 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5846 GvCV(gv) = GvCV(glob_gv);
5847 SvREFCNT_inc((SV*)GvCV(gv));
5848 GvIMPORTED_CV_on(gv);
5851 #endif /* PERL_EXTERNAL_GLOB */
5853 if (gv && GvIMPORTED_CV(gv)) {
5854 append_elem(OP_GLOB, o,
5855 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5856 o->op_type = OP_LIST;
5857 o->op_ppaddr = PL_ppaddr[OP_LIST];
5858 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5859 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5860 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5861 append_elem(OP_LIST, o,
5862 scalar(newUNOP(OP_RV2CV, 0,
5863 newGVOP(OP_GV, 0, gv)))));
5864 o = newUNOP(OP_NULL, 0, ck_subr(o));
5865 o->op_targ = OP_GLOB; /* hint at what it used to be */
5868 gv = newGVgen("main");
5870 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5876 Perl_ck_grep(pTHX_ OP *o)
5880 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5882 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5883 NewOp(1101, gwop, 1, LOGOP);
5885 if (o->op_flags & OPf_STACKED) {
5888 kid = cLISTOPo->op_first->op_sibling;
5889 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5892 kid->op_next = (OP*)gwop;
5893 o->op_flags &= ~OPf_STACKED;
5895 kid = cLISTOPo->op_first->op_sibling;
5896 if (type == OP_MAPWHILE)
5903 kid = cLISTOPo->op_first->op_sibling;
5904 if (kid->op_type != OP_NULL)
5905 Perl_croak(aTHX_ "panic: ck_grep");
5906 kid = kUNOP->op_first;
5908 gwop->op_type = type;
5909 gwop->op_ppaddr = PL_ppaddr[type];
5910 gwop->op_first = listkids(o);
5911 gwop->op_flags |= OPf_KIDS;
5912 gwop->op_private = 1;
5913 gwop->op_other = LINKLIST(kid);
5914 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5915 kid->op_next = (OP*)gwop;
5917 kid = cLISTOPo->op_first->op_sibling;
5918 if (!kid || !kid->op_sibling)
5919 return too_few_arguments(o,PL_op_desc[o->op_type]);
5920 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5921 mod(kid, OP_GREPSTART);
5927 Perl_ck_index(pTHX_ OP *o)
5929 if (o->op_flags & OPf_KIDS) {
5930 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5932 kid = kid->op_sibling; /* get past "big" */
5933 if (kid && kid->op_type == OP_CONST)
5934 fbm_compile(((SVOP*)kid)->op_sv, 0);
5940 Perl_ck_lengthconst(pTHX_ OP *o)
5942 /* XXX length optimization goes here */
5947 Perl_ck_lfun(pTHX_ OP *o)
5949 OPCODE type = o->op_type;
5950 return modkids(ck_fun(o), type);
5954 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5956 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5957 switch (cUNOPo->op_first->op_type) {
5959 /* This is needed for
5960 if (defined %stash::)
5961 to work. Do not break Tk.
5963 break; /* Globals via GV can be undef */
5965 case OP_AASSIGN: /* Is this a good idea? */
5966 Perl_warner(aTHX_ WARN_DEPRECATED,
5967 "defined(@array) is deprecated");
5968 Perl_warner(aTHX_ WARN_DEPRECATED,
5969 "\t(Maybe you should just omit the defined()?)\n");
5972 /* This is needed for
5973 if (defined %stash::)
5974 to work. Do not break Tk.
5976 break; /* Globals via GV can be undef */
5978 Perl_warner(aTHX_ WARN_DEPRECATED,
5979 "defined(%%hash) is deprecated");
5980 Perl_warner(aTHX_ WARN_DEPRECATED,
5981 "\t(Maybe you should just omit the defined()?)\n");
5992 Perl_ck_rfun(pTHX_ OP *o)
5994 OPCODE type = o->op_type;
5995 return refkids(ck_fun(o), type);
5999 Perl_ck_listiob(pTHX_ OP *o)
6003 kid = cLISTOPo->op_first;
6006 kid = cLISTOPo->op_first;
6008 if (kid->op_type == OP_PUSHMARK)
6009 kid = kid->op_sibling;
6010 if (kid && o->op_flags & OPf_STACKED)
6011 kid = kid->op_sibling;
6012 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6013 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6014 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6015 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6016 cLISTOPo->op_first->op_sibling = kid;
6017 cLISTOPo->op_last = kid;
6018 kid = kid->op_sibling;
6023 append_elem(o->op_type, o, newDEFSVOP());
6029 if (PL_hints & HINT_LOCALE)
6030 o->op_private |= OPpLOCALE;
6037 Perl_ck_fun_locale(pTHX_ OP *o)
6043 if (PL_hints & HINT_LOCALE)
6044 o->op_private |= OPpLOCALE;
6051 Perl_ck_sassign(pTHX_ OP *o)
6053 OP *kid = cLISTOPo->op_first;
6054 /* has a disposable target? */
6055 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6056 && !(kid->op_flags & OPf_STACKED)
6057 /* Cannot steal the second time! */
6058 && !(kid->op_private & OPpTARGET_MY))
6060 OP *kkid = kid->op_sibling;
6062 /* Can just relocate the target. */
6063 if (kkid && kkid->op_type == OP_PADSV
6064 && !(kkid->op_private & OPpLVAL_INTRO))
6066 kid->op_targ = kkid->op_targ;
6068 /* Now we do not need PADSV and SASSIGN. */
6069 kid->op_sibling = o->op_sibling; /* NULL */
6070 cLISTOPo->op_first = NULL;
6073 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6081 Perl_ck_scmp(pTHX_ OP *o)
6085 if (PL_hints & HINT_LOCALE)
6086 o->op_private |= OPpLOCALE;
6093 Perl_ck_match(pTHX_ OP *o)
6095 o->op_private |= OPpRUNTIME;
6100 Perl_ck_method(pTHX_ OP *o)
6102 OP *kid = cUNOPo->op_first;
6103 if (kid->op_type == OP_CONST) {
6104 SV* sv = kSVOP->op_sv;
6105 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6107 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6108 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6111 kSVOP->op_sv = Nullsv;
6113 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6122 Perl_ck_null(pTHX_ OP *o)
6128 Perl_ck_open(pTHX_ OP *o)
6130 HV *table = GvHV(PL_hintgv);
6134 svp = hv_fetch(table, "open_IN", 7, FALSE);
6136 mode = mode_from_discipline(*svp);
6137 if (mode & O_BINARY)
6138 o->op_private |= OPpOPEN_IN_RAW;
6139 else if (mode & O_TEXT)
6140 o->op_private |= OPpOPEN_IN_CRLF;
6143 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6145 mode = mode_from_discipline(*svp);
6146 if (mode & O_BINARY)
6147 o->op_private |= OPpOPEN_OUT_RAW;
6148 else if (mode & O_TEXT)
6149 o->op_private |= OPpOPEN_OUT_CRLF;
6152 if (o->op_type == OP_BACKTICK)
6158 Perl_ck_repeat(pTHX_ OP *o)
6160 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6161 o->op_private |= OPpREPEAT_DOLIST;
6162 cBINOPo->op_first = force_list(cBINOPo->op_first);
6170 Perl_ck_require(pTHX_ OP *o)
6174 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6175 SVOP *kid = (SVOP*)cUNOPo->op_first;
6177 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6179 for (s = SvPVX(kid->op_sv); *s; s++) {
6180 if (*s == ':' && s[1] == ':') {
6182 Move(s+2, s+1, strlen(s+2)+1, char);
6183 --SvCUR(kid->op_sv);
6186 if (SvREADONLY(kid->op_sv)) {
6187 SvREADONLY_off(kid->op_sv);
6188 sv_catpvn(kid->op_sv, ".pm", 3);
6189 SvREADONLY_on(kid->op_sv);
6192 sv_catpvn(kid->op_sv, ".pm", 3);
6196 /* handle override, if any */
6197 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6198 if (!(gv && GvIMPORTED_CV(gv)))
6199 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6201 if (gv && GvIMPORTED_CV(gv)) {
6202 OP *kid = cUNOPo->op_first;
6203 cUNOPo->op_first = 0;
6205 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6206 append_elem(OP_LIST, kid,
6207 scalar(newUNOP(OP_RV2CV, 0,
6216 Perl_ck_return(pTHX_ OP *o)
6219 if (CvLVALUE(PL_compcv)) {
6220 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6221 mod(kid, OP_LEAVESUBLV);
6228 Perl_ck_retarget(pTHX_ OP *o)
6230 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6237 Perl_ck_select(pTHX_ OP *o)
6240 if (o->op_flags & OPf_KIDS) {
6241 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6242 if (kid && kid->op_sibling) {
6243 o->op_type = OP_SSELECT;
6244 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6246 return fold_constants(o);
6250 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6251 if (kid && kid->op_type == OP_RV2GV)
6252 kid->op_private &= ~HINT_STRICT_REFS;
6257 Perl_ck_shift(pTHX_ OP *o)
6259 I32 type = o->op_type;
6261 if (!(o->op_flags & OPf_KIDS)) {
6266 if (!CvUNIQUE(PL_compcv)) {
6267 argop = newOP(OP_PADAV, OPf_REF);
6268 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6271 argop = newUNOP(OP_RV2AV, 0,
6272 scalar(newGVOP(OP_GV, 0,
6273 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6276 argop = newUNOP(OP_RV2AV, 0,
6277 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6278 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6279 #endif /* USE_THREADS */
6280 return newUNOP(type, 0, scalar(argop));
6282 return scalar(modkids(ck_fun(o), type));
6286 Perl_ck_sort(pTHX_ OP *o)
6291 if (PL_hints & HINT_LOCALE)
6292 o->op_private |= OPpLOCALE;
6295 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6297 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6298 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6300 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6302 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6304 if (kid->op_type == OP_SCOPE) {
6308 else if (kid->op_type == OP_LEAVE) {
6309 if (o->op_type == OP_SORT) {
6310 op_null(kid); /* wipe out leave */
6313 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6314 if (k->op_next == kid)
6316 /* don't descend into loops */
6317 else if (k->op_type == OP_ENTERLOOP
6318 || k->op_type == OP_ENTERITER)
6320 k = cLOOPx(k)->op_lastop;
6325 kid->op_next = 0; /* just disconnect the leave */
6326 k = kLISTOP->op_first;
6331 if (o->op_type == OP_SORT) {
6332 /* provide scalar context for comparison function/block */
6338 o->op_flags |= OPf_SPECIAL;
6340 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6343 firstkid = firstkid->op_sibling;
6346 /* provide list context for arguments */
6347 if (o->op_type == OP_SORT)
6354 S_simplify_sort(pTHX_ OP *o)
6356 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6360 if (!(o->op_flags & OPf_STACKED))
6362 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6363 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6364 kid = kUNOP->op_first; /* get past null */
6365 if (kid->op_type != OP_SCOPE)
6367 kid = kLISTOP->op_last; /* get past scope */
6368 switch(kid->op_type) {
6376 k = kid; /* remember this node*/
6377 if (kBINOP->op_first->op_type != OP_RV2SV)
6379 kid = kBINOP->op_first; /* get past cmp */
6380 if (kUNOP->op_first->op_type != OP_GV)
6382 kid = kUNOP->op_first; /* get past rv2sv */
6384 if (GvSTASH(gv) != PL_curstash)
6386 if (strEQ(GvNAME(gv), "a"))
6388 else if (strEQ(GvNAME(gv), "b"))
6392 kid = k; /* back to cmp */
6393 if (kBINOP->op_last->op_type != OP_RV2SV)
6395 kid = kBINOP->op_last; /* down to 2nd arg */
6396 if (kUNOP->op_first->op_type != OP_GV)
6398 kid = kUNOP->op_first; /* get past rv2sv */
6400 if (GvSTASH(gv) != PL_curstash
6402 ? strNE(GvNAME(gv), "a")
6403 : strNE(GvNAME(gv), "b")))
6405 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6407 o->op_private |= OPpSORT_REVERSE;
6408 if (k->op_type == OP_NCMP)
6409 o->op_private |= OPpSORT_NUMERIC;
6410 if (k->op_type == OP_I_NCMP)
6411 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6412 kid = cLISTOPo->op_first->op_sibling;
6413 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6414 op_free(kid); /* then delete it */
6418 Perl_ck_split(pTHX_ OP *o)
6422 if (o->op_flags & OPf_STACKED)
6423 return no_fh_allowed(o);
6425 kid = cLISTOPo->op_first;
6426 if (kid->op_type != OP_NULL)
6427 Perl_croak(aTHX_ "panic: ck_split");
6428 kid = kid->op_sibling;
6429 op_free(cLISTOPo->op_first);
6430 cLISTOPo->op_first = kid;
6432 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6433 cLISTOPo->op_last = kid; /* There was only one element previously */
6436 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6437 OP *sibl = kid->op_sibling;
6438 kid->op_sibling = 0;
6439 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6440 if (cLISTOPo->op_first == cLISTOPo->op_last)
6441 cLISTOPo->op_last = kid;
6442 cLISTOPo->op_first = kid;
6443 kid->op_sibling = sibl;
6446 kid->op_type = OP_PUSHRE;
6447 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6450 if (!kid->op_sibling)
6451 append_elem(OP_SPLIT, o, newDEFSVOP());
6453 kid = kid->op_sibling;
6456 if (!kid->op_sibling)
6457 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6459 kid = kid->op_sibling;
6462 if (kid->op_sibling)
6463 return too_many_arguments(o,PL_op_desc[o->op_type]);
6469 Perl_ck_join(pTHX_ OP *o)
6471 if (ckWARN(WARN_SYNTAX)) {
6472 OP *kid = cLISTOPo->op_first->op_sibling;
6473 if (kid && kid->op_type == OP_MATCH) {
6474 char *pmstr = "STRING";
6475 if (kPMOP->op_pmregexp)
6476 pmstr = kPMOP->op_pmregexp->precomp;
6477 Perl_warner(aTHX_ WARN_SYNTAX,
6478 "/%s/ should probably be written as \"%s\"",
6486 Perl_ck_subr(pTHX_ OP *o)
6488 OP *prev = ((cUNOPo->op_first->op_sibling)
6489 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6490 OP *o2 = prev->op_sibling;
6499 o->op_private |= OPpENTERSUB_HASTARG;
6500 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6501 if (cvop->op_type == OP_RV2CV) {
6503 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6504 op_null(cvop); /* disable rv2cv */
6505 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6506 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6507 GV *gv = cGVOPx_gv(tmpop);
6510 tmpop->op_private |= OPpEARLY_CV;
6511 else if (SvPOK(cv)) {
6512 namegv = CvANON(cv) ? gv : CvGV(cv);
6513 proto = SvPV((SV*)cv, n_a);
6517 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6518 if (o2->op_type == OP_CONST)
6519 o2->op_private &= ~OPpCONST_STRICT;
6520 else if (o2->op_type == OP_LIST) {
6521 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6522 if (o && o->op_type == OP_CONST)
6523 o->op_private &= ~OPpCONST_STRICT;
6526 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6527 if (PERLDB_SUB && PL_curstash != PL_debstash)
6528 o->op_private |= OPpENTERSUB_DB;
6529 while (o2 != cvop) {
6533 return too_many_arguments(o, gv_ename(namegv));
6551 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6553 arg == 1 ? "block or sub {}" : "sub {}",
6554 gv_ename(namegv), o2);
6557 /* '*' allows any scalar type, including bareword */
6560 if (o2->op_type == OP_RV2GV)
6561 goto wrapref; /* autoconvert GLOB -> GLOBref */
6562 else if (o2->op_type == OP_CONST)
6563 o2->op_private &= ~OPpCONST_STRICT;
6564 else if (o2->op_type == OP_ENTERSUB) {
6565 /* accidental subroutine, revert to bareword */
6566 OP *gvop = ((UNOP*)o2)->op_first;
6567 if (gvop && gvop->op_type == OP_NULL) {
6568 gvop = ((UNOP*)gvop)->op_first;
6570 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6573 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6574 (gvop = ((UNOP*)gvop)->op_first) &&
6575 gvop->op_type == OP_GV)
6577 GV *gv = cGVOPx_gv(gvop);
6578 OP *sibling = o2->op_sibling;
6579 SV *n = newSVpvn("",0);
6581 gv_fullname3(n, gv, "");
6582 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6583 sv_chop(n, SvPVX(n)+6);
6584 o2 = newSVOP(OP_CONST, 0, n);
6585 prev->op_sibling = o2;
6586 o2->op_sibling = sibling;
6598 if (o2->op_type != OP_RV2GV)
6599 bad_type(arg, "symbol", gv_ename(namegv), o2);
6602 if (o2->op_type != OP_ENTERSUB)
6603 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6606 if (o2->op_type != OP_RV2SV
6607 && o2->op_type != OP_PADSV
6608 && o2->op_type != OP_HELEM
6609 && o2->op_type != OP_AELEM
6610 && o2->op_type != OP_THREADSV)
6612 bad_type(arg, "scalar", gv_ename(namegv), o2);
6616 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6617 bad_type(arg, "array", gv_ename(namegv), o2);
6620 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6621 bad_type(arg, "hash", gv_ename(namegv), o2);
6625 OP* sib = kid->op_sibling;
6626 kid->op_sibling = 0;
6627 o2 = newUNOP(OP_REFGEN, 0, kid);
6628 o2->op_sibling = sib;
6629 prev->op_sibling = o2;
6640 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6641 gv_ename(namegv), SvPV((SV*)cv, n_a));
6646 mod(o2, OP_ENTERSUB);
6648 o2 = o2->op_sibling;
6650 if (proto && !optional &&
6651 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6652 return too_few_arguments(o, gv_ename(namegv));
6657 Perl_ck_svconst(pTHX_ OP *o)
6659 SvREADONLY_on(cSVOPo->op_sv);
6664 Perl_ck_trunc(pTHX_ OP *o)
6666 if (o->op_flags & OPf_KIDS) {
6667 SVOP *kid = (SVOP*)cUNOPo->op_first;
6669 if (kid->op_type == OP_NULL)
6670 kid = (SVOP*)kid->op_sibling;
6671 if (kid && kid->op_type == OP_CONST &&
6672 (kid->op_private & OPpCONST_BARE))
6674 o->op_flags |= OPf_SPECIAL;
6675 kid->op_private &= ~OPpCONST_STRICT;
6682 Perl_ck_substr(pTHX_ OP *o)
6685 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6686 OP *kid = cLISTOPo->op_first;
6688 if (kid->op_type == OP_NULL)
6689 kid = kid->op_sibling;
6691 kid->op_flags |= OPf_MOD;
6697 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6700 Perl_peep(pTHX_ register OP *o)
6702 register OP* oldop = 0;
6705 if (!o || o->op_seq)
6709 SAVEVPTR(PL_curcop);
6710 for (; o; o = o->op_next) {
6716 switch (o->op_type) {
6720 PL_curcop = ((COP*)o); /* for warnings */
6721 o->op_seq = PL_op_seqmax++;
6725 if (cSVOPo->op_private & OPpCONST_STRICT)
6726 no_bareword_allowed(o);
6728 /* Relocate sv to the pad for thread safety.
6729 * Despite being a "constant", the SV is written to,
6730 * for reference counts, sv_upgrade() etc. */
6732 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6733 if (SvPADTMP(cSVOPo->op_sv)) {
6734 /* If op_sv is already a PADTMP then it is being used by
6735 * some pad, so make a copy. */
6736 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6737 SvREADONLY_on(PL_curpad[ix]);
6738 SvREFCNT_dec(cSVOPo->op_sv);
6741 SvREFCNT_dec(PL_curpad[ix]);
6742 SvPADTMP_on(cSVOPo->op_sv);
6743 PL_curpad[ix] = cSVOPo->op_sv;
6744 /* XXX I don't know how this isn't readonly already. */
6745 SvREADONLY_on(PL_curpad[ix]);
6747 cSVOPo->op_sv = Nullsv;
6751 o->op_seq = PL_op_seqmax++;
6755 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6756 if (o->op_next->op_private & OPpTARGET_MY) {
6757 if (o->op_flags & OPf_STACKED) /* chained concats */
6758 goto ignore_optimization;
6760 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6761 o->op_targ = o->op_next->op_targ;
6762 o->op_next->op_targ = 0;
6763 o->op_private |= OPpTARGET_MY;
6766 op_null(o->op_next);
6768 ignore_optimization:
6769 o->op_seq = PL_op_seqmax++;
6772 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6773 o->op_seq = PL_op_seqmax++;
6774 break; /* Scalar stub must produce undef. List stub is noop */
6778 if (o->op_targ == OP_NEXTSTATE
6779 || o->op_targ == OP_DBSTATE
6780 || o->op_targ == OP_SETSTATE)
6782 PL_curcop = ((COP*)o);
6789 if (oldop && o->op_next) {
6790 oldop->op_next = o->op_next;
6793 o->op_seq = PL_op_seqmax++;
6797 if (o->op_next->op_type == OP_RV2SV) {
6798 if (!(o->op_next->op_private & OPpDEREF)) {
6799 op_null(o->op_next);
6800 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6802 o->op_next = o->op_next->op_next;
6803 o->op_type = OP_GVSV;
6804 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6807 else if (o->op_next->op_type == OP_RV2AV) {
6808 OP* pop = o->op_next->op_next;
6810 if (pop->op_type == OP_CONST &&
6811 (PL_op = pop->op_next) &&
6812 pop->op_next->op_type == OP_AELEM &&
6813 !(pop->op_next->op_private &
6814 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6815 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6820 op_null(o->op_next);
6821 op_null(pop->op_next);
6823 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6824 o->op_next = pop->op_next->op_next;
6825 o->op_type = OP_AELEMFAST;
6826 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6827 o->op_private = (U8)i;
6832 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6834 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6835 /* XXX could check prototype here instead of just carping */
6836 SV *sv = sv_newmortal();
6837 gv_efullname3(sv, gv, Nullch);
6838 Perl_warner(aTHX_ WARN_PROTOTYPE,
6839 "%s() called too early to check prototype",
6844 o->op_seq = PL_op_seqmax++;
6855 o->op_seq = PL_op_seqmax++;
6856 while (cLOGOP->op_other->op_type == OP_NULL)
6857 cLOGOP->op_other = cLOGOP->op_other->op_next;
6858 peep(cLOGOP->op_other);
6863 o->op_seq = PL_op_seqmax++;
6864 while (cLOOP->op_redoop->op_type == OP_NULL)
6865 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6866 peep(cLOOP->op_redoop);
6867 while (cLOOP->op_nextop->op_type == OP_NULL)
6868 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6869 peep(cLOOP->op_nextop);
6870 while (cLOOP->op_lastop->op_type == OP_NULL)
6871 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6872 peep(cLOOP->op_lastop);
6878 o->op_seq = PL_op_seqmax++;
6879 while (cPMOP->op_pmreplstart &&
6880 cPMOP->op_pmreplstart->op_type == OP_NULL)
6881 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6882 peep(cPMOP->op_pmreplstart);
6886 o->op_seq = PL_op_seqmax++;
6887 if (ckWARN(WARN_SYNTAX) && o->op_next
6888 && o->op_next->op_type == OP_NEXTSTATE) {
6889 if (o->op_next->op_sibling &&
6890 o->op_next->op_sibling->op_type != OP_EXIT &&
6891 o->op_next->op_sibling->op_type != OP_WARN &&
6892 o->op_next->op_sibling->op_type != OP_DIE) {
6893 line_t oldline = CopLINE(PL_curcop);
6895 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6896 Perl_warner(aTHX_ WARN_EXEC,
6897 "Statement unlikely to be reached");
6898 Perl_warner(aTHX_ WARN_EXEC,
6899 "\t(Maybe you meant system() when you said exec()?)\n");
6900 CopLINE_set(PL_curcop, oldline);
6909 SV **svp, **indsvp, *sv;
6914 o->op_seq = PL_op_seqmax++;
6916 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6919 /* Make the CONST have a shared SV */
6920 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6921 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6922 key = SvPV(sv, keylen);
6925 lexname = newSVpvn_share(key, keylen, 0);
6930 if ((o->op_private & (OPpLVAL_INTRO)))
6933 rop = (UNOP*)((BINOP*)o)->op_first;
6934 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6936 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6937 if (!SvOBJECT(lexname))
6939 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6940 if (!fields || !GvHV(*fields))
6942 key = SvPV(*svp, keylen);
6945 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6947 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6948 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6950 ind = SvIV(*indsvp);
6952 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6953 rop->op_type = OP_RV2AV;
6954 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6955 o->op_type = OP_AELEM;
6956 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6958 if (SvREADONLY(*svp))
6960 SvFLAGS(sv) |= (SvFLAGS(*svp)
6961 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6971 SV **svp, **indsvp, *sv;
6975 SVOP *first_key_op, *key_op;
6977 o->op_seq = PL_op_seqmax++;
6978 if ((o->op_private & (OPpLVAL_INTRO))
6979 /* I bet there's always a pushmark... */
6980 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6981 /* hmmm, no optimization if list contains only one key. */
6983 rop = (UNOP*)((LISTOP*)o)->op_last;
6984 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6986 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6987 if (!SvOBJECT(lexname))
6989 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6990 if (!fields || !GvHV(*fields))
6992 /* Again guessing that the pushmark can be jumped over.... */
6993 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6994 ->op_first->op_sibling;
6995 /* Check that the key list contains only constants. */
6996 for (key_op = first_key_op; key_op;
6997 key_op = (SVOP*)key_op->op_sibling)
6998 if (key_op->op_type != OP_CONST)
7002 rop->op_type = OP_RV2AV;
7003 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7004 o->op_type = OP_ASLICE;
7005 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7006 for (key_op = first_key_op; key_op;
7007 key_op = (SVOP*)key_op->op_sibling) {
7008 svp = cSVOPx_svp(key_op);
7009 key = SvPV(*svp, keylen);
7012 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7014 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7015 "in variable %s of type %s",
7016 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7018 ind = SvIV(*indsvp);
7020 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7022 if (SvREADONLY(*svp))
7024 SvFLAGS(sv) |= (SvFLAGS(*svp)
7025 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7033 o->op_seq = PL_op_seqmax++;
7043 /* Efficient sub that returns a constant scalar value. */
7045 const_sv_xsub(pTHXo_ CV* cv)
7050 Perl_croak(aTHX_ "usage: %s::%s()",
7051 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7055 ST(0) = (SV*)XSANY.any_ptr;