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)
3200 if (id->op_type != OP_CONST)
3201 Perl_croak(aTHX_ "Module name must be constant");
3205 if (version != Nullop) {
3206 SV *vesv = ((SVOP*)version)->op_sv;
3208 if (arg == Nullop && !SvNIOKp(vesv)) {
3215 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3216 Perl_croak(aTHX_ "Version number must be constant number");
3218 /* Make copy of id so we don't free it twice */
3219 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3221 /* Fake up a method call to VERSION */
3222 meth = newSVpvn("VERSION",7);
3223 sv_upgrade(meth, SVt_PVIV);
3224 (void)SvIOK_on(meth);
3225 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3226 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3227 append_elem(OP_LIST,
3228 prepend_elem(OP_LIST, pack, list(version)),
3229 newSVOP(OP_METHOD_NAMED, 0, meth)));
3233 /* Fake up an import/unimport */
3234 if (arg && arg->op_type == OP_STUB)
3235 imop = arg; /* no import on explicit () */
3236 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3237 imop = Nullop; /* use 5.0; */
3242 /* Make copy of id so we don't free it twice */
3243 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3245 /* Fake up a method call to import/unimport */
3246 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3247 sv_upgrade(meth, SVt_PVIV);
3248 (void)SvIOK_on(meth);
3249 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3250 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3251 append_elem(OP_LIST,
3252 prepend_elem(OP_LIST, pack, list(arg)),
3253 newSVOP(OP_METHOD_NAMED, 0, meth)));
3256 /* Fake up a require, handle override, if any */
3257 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3258 if (!(gv && GvIMPORTED_CV(gv)))
3259 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3261 if (gv && GvIMPORTED_CV(gv)) {
3262 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3263 append_elem(OP_LIST, id,
3264 scalar(newUNOP(OP_RV2CV, 0,
3269 rqop = newUNOP(OP_REQUIRE, 0, id);
3272 /* Fake up the BEGIN {}, which does its thing immediately. */
3274 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3277 append_elem(OP_LINESEQ,
3278 append_elem(OP_LINESEQ,
3279 newSTATEOP(0, Nullch, rqop),
3280 newSTATEOP(0, Nullch, veop)),
3281 newSTATEOP(0, Nullch, imop) ));
3283 PL_hints |= HINT_BLOCK_SCOPE;
3284 PL_copline = NOLINE;
3289 =for apidoc load_module
3291 Loads the module whose name is pointed to by the string part of name.
3292 Note that the actual module name, not its filename, should be given.
3293 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3294 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3295 (or 0 for no flags). ver, if specified, provides version semantics
3296 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3297 arguments can be used to specify arguments to the module's import()
3298 method, similar to C<use Foo::Bar VERSION LIST>.
3303 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3306 va_start(args, ver);
3307 vload_module(flags, name, ver, &args);
3311 #ifdef PERL_IMPLICIT_CONTEXT
3313 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3317 va_start(args, ver);
3318 vload_module(flags, name, ver, &args);
3324 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3326 OP *modname, *veop, *imop;
3328 modname = newSVOP(OP_CONST, 0, name);
3329 modname->op_private |= OPpCONST_BARE;
3331 veop = newSVOP(OP_CONST, 0, ver);
3335 if (flags & PERL_LOADMOD_NOIMPORT) {
3336 imop = sawparens(newNULLLIST());
3338 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3339 imop = va_arg(*args, OP*);
3344 sv = va_arg(*args, SV*);
3346 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3347 sv = va_arg(*args, SV*);
3351 line_t ocopline = PL_copline;
3352 int oexpect = PL_expect;
3354 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3355 veop, modname, imop);
3356 PL_expect = oexpect;
3357 PL_copline = ocopline;
3362 Perl_dofile(pTHX_ OP *term)
3367 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3368 if (!(gv && GvIMPORTED_CV(gv)))
3369 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3371 if (gv && GvIMPORTED_CV(gv)) {
3372 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3373 append_elem(OP_LIST, term,
3374 scalar(newUNOP(OP_RV2CV, 0,
3379 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3385 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3387 return newBINOP(OP_LSLICE, flags,
3388 list(force_list(subscript)),
3389 list(force_list(listval)) );
3393 S_list_assignment(pTHX_ register OP *o)
3398 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3399 o = cUNOPo->op_first;
3401 if (o->op_type == OP_COND_EXPR) {
3402 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3403 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3408 yyerror("Assignment to both a list and a scalar");
3412 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3413 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3414 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3417 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3420 if (o->op_type == OP_RV2SV)
3427 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3432 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3433 return newLOGOP(optype, 0,
3434 mod(scalar(left), optype),
3435 newUNOP(OP_SASSIGN, 0, scalar(right)));
3438 return newBINOP(optype, OPf_STACKED,
3439 mod(scalar(left), optype), scalar(right));
3443 if (list_assignment(left)) {
3447 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3448 left = mod(left, OP_AASSIGN);
3456 curop = list(force_list(left));
3457 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3458 o->op_private = 0 | (flags >> 8);
3459 for (curop = ((LISTOP*)curop)->op_first;
3460 curop; curop = curop->op_sibling)
3462 if (curop->op_type == OP_RV2HV &&
3463 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3464 o->op_private |= OPpASSIGN_HASH;
3468 if (!(left->op_private & OPpLVAL_INTRO)) {
3471 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3472 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3473 if (curop->op_type == OP_GV) {
3474 GV *gv = cGVOPx_gv(curop);
3475 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3477 SvCUR(gv) = PL_generation;
3479 else if (curop->op_type == OP_PADSV ||
3480 curop->op_type == OP_PADAV ||
3481 curop->op_type == OP_PADHV ||
3482 curop->op_type == OP_PADANY) {
3483 SV **svp = AvARRAY(PL_comppad_name);
3484 SV *sv = svp[curop->op_targ];
3485 if (SvCUR(sv) == PL_generation)
3487 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3489 else if (curop->op_type == OP_RV2CV)
3491 else if (curop->op_type == OP_RV2SV ||
3492 curop->op_type == OP_RV2AV ||
3493 curop->op_type == OP_RV2HV ||
3494 curop->op_type == OP_RV2GV) {
3495 if (lastop->op_type != OP_GV) /* funny deref? */
3498 else if (curop->op_type == OP_PUSHRE) {
3499 if (((PMOP*)curop)->op_pmreplroot) {
3501 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3503 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3505 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3507 SvCUR(gv) = PL_generation;
3516 o->op_private |= OPpASSIGN_COMMON;
3518 if (right && right->op_type == OP_SPLIT) {
3520 if ((tmpop = ((LISTOP*)right)->op_first) &&
3521 tmpop->op_type == OP_PUSHRE)
3523 PMOP *pm = (PMOP*)tmpop;
3524 if (left->op_type == OP_RV2AV &&
3525 !(left->op_private & OPpLVAL_INTRO) &&
3526 !(o->op_private & OPpASSIGN_COMMON) )
3528 tmpop = ((UNOP*)left)->op_first;
3529 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3531 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3532 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3534 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3535 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3537 pm->op_pmflags |= PMf_ONCE;
3538 tmpop = cUNOPo->op_first; /* to list (nulled) */
3539 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3540 tmpop->op_sibling = Nullop; /* don't free split */
3541 right->op_next = tmpop->op_next; /* fix starting loc */
3542 op_free(o); /* blow off assign */
3543 right->op_flags &= ~OPf_WANT;
3544 /* "I don't know and I don't care." */
3549 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3550 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3552 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3554 sv_setiv(sv, PL_modcount+1);
3562 right = newOP(OP_UNDEF, 0);
3563 if (right->op_type == OP_READLINE) {
3564 right->op_flags |= OPf_STACKED;
3565 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3568 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3569 o = newBINOP(OP_SASSIGN, flags,
3570 scalar(right), mod(scalar(left), OP_SASSIGN) );
3582 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3584 U32 seq = intro_my();
3587 NewOp(1101, cop, 1, COP);
3588 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3589 cop->op_type = OP_DBSTATE;
3590 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3593 cop->op_type = OP_NEXTSTATE;
3594 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3596 cop->op_flags = flags;
3597 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3599 cop->op_private |= NATIVE_HINTS;
3601 PL_compiling.op_private = cop->op_private;
3602 cop->op_next = (OP*)cop;
3605 cop->cop_label = label;
3606 PL_hints |= HINT_BLOCK_SCOPE;
3609 cop->cop_arybase = PL_curcop->cop_arybase;
3610 if (specialWARN(PL_curcop->cop_warnings))
3611 cop->cop_warnings = PL_curcop->cop_warnings ;
3613 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3614 if (specialCopIO(PL_curcop->cop_io))
3615 cop->cop_io = PL_curcop->cop_io;
3617 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3620 if (PL_copline == NOLINE)
3621 CopLINE_set(cop, CopLINE(PL_curcop));
3623 CopLINE_set(cop, PL_copline);
3624 PL_copline = NOLINE;
3627 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3629 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3631 CopSTASH_set(cop, PL_curstash);
3633 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3634 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3635 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3636 (void)SvIOK_on(*svp);
3637 SvIVX(*svp) = PTR2IV(cop);
3641 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3644 /* "Introduce" my variables to visible status. */
3652 if (! PL_min_intro_pending)
3653 return PL_cop_seqmax;
3655 svp = AvARRAY(PL_comppad_name);
3656 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3657 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3658 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3659 SvNVX(sv) = (NV)PL_cop_seqmax;
3662 PL_min_intro_pending = 0;
3663 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3664 return PL_cop_seqmax++;
3668 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3670 return new_logop(type, flags, &first, &other);
3674 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3678 OP *first = *firstp;
3679 OP *other = *otherp;
3681 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3682 return newBINOP(type, flags, scalar(first), scalar(other));
3684 scalarboolean(first);
3685 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3686 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3687 if (type == OP_AND || type == OP_OR) {
3693 first = *firstp = cUNOPo->op_first;
3695 first->op_next = o->op_next;
3696 cUNOPo->op_first = Nullop;
3700 if (first->op_type == OP_CONST) {
3701 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3702 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3703 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3714 else if (first->op_type == OP_WANTARRAY) {
3720 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3721 OP *k1 = ((UNOP*)first)->op_first;
3722 OP *k2 = k1->op_sibling;
3724 switch (first->op_type)
3727 if (k2 && k2->op_type == OP_READLINE
3728 && (k2->op_flags & OPf_STACKED)
3729 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3731 warnop = k2->op_type;
3736 if (k1->op_type == OP_READDIR
3737 || k1->op_type == OP_GLOB
3738 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3739 || k1->op_type == OP_EACH)
3741 warnop = ((k1->op_type == OP_NULL)
3742 ? k1->op_targ : k1->op_type);
3747 line_t oldline = CopLINE(PL_curcop);
3748 CopLINE_set(PL_curcop, PL_copline);
3749 Perl_warner(aTHX_ WARN_MISC,
3750 "Value of %s%s can be \"0\"; test with defined()",
3752 ((warnop == OP_READLINE || warnop == OP_GLOB)
3753 ? " construct" : "() operator"));
3754 CopLINE_set(PL_curcop, oldline);
3761 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3762 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3764 NewOp(1101, logop, 1, LOGOP);
3766 logop->op_type = type;
3767 logop->op_ppaddr = PL_ppaddr[type];
3768 logop->op_first = first;
3769 logop->op_flags = flags | OPf_KIDS;
3770 logop->op_other = LINKLIST(other);
3771 logop->op_private = 1 | (flags >> 8);
3773 /* establish postfix order */
3774 logop->op_next = LINKLIST(first);
3775 first->op_next = (OP*)logop;
3776 first->op_sibling = other;
3778 o = newUNOP(OP_NULL, 0, (OP*)logop);
3785 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3792 return newLOGOP(OP_AND, 0, first, trueop);
3794 return newLOGOP(OP_OR, 0, first, falseop);
3796 scalarboolean(first);
3797 if (first->op_type == OP_CONST) {
3798 if (SvTRUE(((SVOP*)first)->op_sv)) {
3809 else if (first->op_type == OP_WANTARRAY) {
3813 NewOp(1101, logop, 1, LOGOP);
3814 logop->op_type = OP_COND_EXPR;
3815 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3816 logop->op_first = first;
3817 logop->op_flags = flags | OPf_KIDS;
3818 logop->op_private = 1 | (flags >> 8);
3819 logop->op_other = LINKLIST(trueop);
3820 logop->op_next = LINKLIST(falseop);
3823 /* establish postfix order */
3824 start = LINKLIST(first);
3825 first->op_next = (OP*)logop;
3827 first->op_sibling = trueop;
3828 trueop->op_sibling = falseop;
3829 o = newUNOP(OP_NULL, 0, (OP*)logop);
3831 trueop->op_next = falseop->op_next = o;
3838 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3846 NewOp(1101, range, 1, LOGOP);
3848 range->op_type = OP_RANGE;
3849 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3850 range->op_first = left;
3851 range->op_flags = OPf_KIDS;
3852 leftstart = LINKLIST(left);
3853 range->op_other = LINKLIST(right);
3854 range->op_private = 1 | (flags >> 8);
3856 left->op_sibling = right;
3858 range->op_next = (OP*)range;
3859 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3860 flop = newUNOP(OP_FLOP, 0, flip);
3861 o = newUNOP(OP_NULL, 0, flop);
3863 range->op_next = leftstart;
3865 left->op_next = flip;
3866 right->op_next = flop;
3868 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3869 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3870 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3871 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3873 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3874 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3877 if (!flip->op_private || !flop->op_private)
3878 linklist(o); /* blow off optimizer unless constant */
3884 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3888 int once = block && block->op_flags & OPf_SPECIAL &&
3889 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3892 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3893 return block; /* do {} while 0 does once */
3894 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3895 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3896 expr = newUNOP(OP_DEFINED, 0,
3897 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3898 } else if (expr->op_flags & OPf_KIDS) {
3899 OP *k1 = ((UNOP*)expr)->op_first;
3900 OP *k2 = (k1) ? k1->op_sibling : NULL;
3901 switch (expr->op_type) {
3903 if (k2 && k2->op_type == OP_READLINE
3904 && (k2->op_flags & OPf_STACKED)
3905 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3906 expr = newUNOP(OP_DEFINED, 0, expr);
3910 if (k1->op_type == OP_READDIR
3911 || k1->op_type == OP_GLOB
3912 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3913 || k1->op_type == OP_EACH)
3914 expr = newUNOP(OP_DEFINED, 0, expr);
3920 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3921 o = new_logop(OP_AND, 0, &expr, &listop);
3924 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3926 if (once && o != listop)
3927 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3930 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3932 o->op_flags |= flags;
3934 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3939 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3948 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3949 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3950 expr = newUNOP(OP_DEFINED, 0,
3951 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3952 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3953 OP *k1 = ((UNOP*)expr)->op_first;
3954 OP *k2 = (k1) ? k1->op_sibling : NULL;
3955 switch (expr->op_type) {
3957 if (k2 && k2->op_type == OP_READLINE
3958 && (k2->op_flags & OPf_STACKED)
3959 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3960 expr = newUNOP(OP_DEFINED, 0, expr);
3964 if (k1->op_type == OP_READDIR
3965 || k1->op_type == OP_GLOB
3966 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3967 || k1->op_type == OP_EACH)
3968 expr = newUNOP(OP_DEFINED, 0, expr);
3974 block = newOP(OP_NULL, 0);
3976 block = scope(block);
3980 next = LINKLIST(cont);
3983 OP *unstack = newOP(OP_UNSTACK, 0);
3986 cont = append_elem(OP_LINESEQ, cont, unstack);
3987 if ((line_t)whileline != NOLINE) {
3988 PL_copline = whileline;
3989 cont = append_elem(OP_LINESEQ, cont,
3990 newSTATEOP(0, Nullch, Nullop));
3994 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3995 redo = LINKLIST(listop);
3998 PL_copline = whileline;
4000 o = new_logop(OP_AND, 0, &expr, &listop);
4001 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4002 op_free(expr); /* oops, it's a while (0) */
4004 return Nullop; /* listop already freed by new_logop */
4007 ((LISTOP*)listop)->op_last->op_next = condop =
4008 (o == listop ? redo : LINKLIST(o));
4014 NewOp(1101,loop,1,LOOP);
4015 loop->op_type = OP_ENTERLOOP;
4016 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4017 loop->op_private = 0;
4018 loop->op_next = (OP*)loop;
4021 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4023 loop->op_redoop = redo;
4024 loop->op_lastop = o;
4025 o->op_private |= loopflags;
4028 loop->op_nextop = next;
4030 loop->op_nextop = o;
4032 o->op_flags |= flags;
4033 o->op_private |= (flags >> 8);
4038 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4046 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4047 sv->op_type = OP_RV2GV;
4048 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4050 else if (sv->op_type == OP_PADSV) { /* private variable */
4051 padoff = sv->op_targ;
4056 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4057 padoff = sv->op_targ;
4059 iterflags |= OPf_SPECIAL;
4064 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4068 padoff = find_threadsv("_");
4069 iterflags |= OPf_SPECIAL;
4071 sv = newGVOP(OP_GV, 0, PL_defgv);
4074 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4075 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4076 iterflags |= OPf_STACKED;
4078 else if (expr->op_type == OP_NULL &&
4079 (expr->op_flags & OPf_KIDS) &&
4080 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4082 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4083 * set the STACKED flag to indicate that these values are to be
4084 * treated as min/max values by 'pp_iterinit'.
4086 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4087 LOGOP* range = (LOGOP*) flip->op_first;
4088 OP* left = range->op_first;
4089 OP* right = left->op_sibling;
4092 range->op_flags &= ~OPf_KIDS;
4093 range->op_first = Nullop;
4095 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4096 listop->op_first->op_next = range->op_next;
4097 left->op_next = range->op_other;
4098 right->op_next = (OP*)listop;
4099 listop->op_next = listop->op_first;
4102 expr = (OP*)(listop);
4104 iterflags |= OPf_STACKED;
4107 expr = mod(force_list(expr), OP_GREPSTART);
4111 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4112 append_elem(OP_LIST, expr, scalar(sv))));
4113 assert(!loop->op_next);
4114 #ifdef PL_OP_SLAB_ALLOC
4117 NewOp(1234,tmp,1,LOOP);
4118 Copy(loop,tmp,1,LOOP);
4122 Renew(loop, 1, LOOP);
4124 loop->op_targ = padoff;
4125 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4126 PL_copline = forline;
4127 return newSTATEOP(0, label, wop);
4131 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4136 if (type != OP_GOTO || label->op_type == OP_CONST) {
4137 /* "last()" means "last" */
4138 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4139 o = newOP(type, OPf_SPECIAL);
4141 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4142 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4148 if (label->op_type == OP_ENTERSUB)
4149 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4150 o = newUNOP(type, OPf_STACKED, label);
4152 PL_hints |= HINT_BLOCK_SCOPE;
4157 Perl_cv_undef(pTHX_ CV *cv)
4161 MUTEX_DESTROY(CvMUTEXP(cv));
4162 Safefree(CvMUTEXP(cv));
4165 #endif /* USE_THREADS */
4167 if (!CvXSUB(cv) && CvROOT(cv)) {
4169 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4170 Perl_croak(aTHX_ "Can't undef active subroutine");
4173 Perl_croak(aTHX_ "Can't undef active subroutine");
4174 #endif /* USE_THREADS */
4177 SAVEVPTR(PL_curpad);
4180 op_free(CvROOT(cv));
4181 CvROOT(cv) = Nullop;
4184 SvPOK_off((SV*)cv); /* forget prototype */
4186 /* Since closure prototypes have the same lifetime as the containing
4187 * CV, they don't hold a refcount on the outside CV. This avoids
4188 * the refcount loop between the outer CV (which keeps a refcount to
4189 * the closure prototype in the pad entry for pp_anoncode()) and the
4190 * closure prototype, and the ensuing memory leak. --GSAR */
4191 if (!CvANON(cv) || CvCLONED(cv))
4192 SvREFCNT_dec(CvOUTSIDE(cv));
4193 CvOUTSIDE(cv) = Nullcv;
4195 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4198 if (CvPADLIST(cv)) {
4199 /* may be during global destruction */
4200 if (SvREFCNT(CvPADLIST(cv))) {
4201 I32 i = AvFILLp(CvPADLIST(cv));
4203 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4204 SV* sv = svp ? *svp : Nullsv;
4207 if (sv == (SV*)PL_comppad_name)
4208 PL_comppad_name = Nullav;
4209 else if (sv == (SV*)PL_comppad) {
4210 PL_comppad = Nullav;
4211 PL_curpad = Null(SV**);
4215 SvREFCNT_dec((SV*)CvPADLIST(cv));
4217 CvPADLIST(cv) = Nullav;
4225 #ifdef DEBUG_CLOSURES
4227 S_cv_dump(pTHX_ CV *cv)
4230 CV *outside = CvOUTSIDE(cv);
4231 AV* padlist = CvPADLIST(cv);
4238 PerlIO_printf(Perl_debug_log,
4239 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4241 (CvANON(cv) ? "ANON"
4242 : (cv == PL_main_cv) ? "MAIN"
4243 : CvUNIQUE(cv) ? "UNIQUE"
4244 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4247 : CvANON(outside) ? "ANON"
4248 : (outside == PL_main_cv) ? "MAIN"
4249 : CvUNIQUE(outside) ? "UNIQUE"
4250 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4255 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4256 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4257 pname = AvARRAY(pad_name);
4258 ppad = AvARRAY(pad);
4260 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4261 if (SvPOK(pname[ix]))
4262 PerlIO_printf(Perl_debug_log,
4263 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4264 (int)ix, PTR2UV(ppad[ix]),
4265 SvFAKE(pname[ix]) ? "FAKE " : "",
4267 (IV)I_32(SvNVX(pname[ix])),
4270 #endif /* DEBUGGING */
4272 #endif /* DEBUG_CLOSURES */
4275 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4279 AV* protopadlist = CvPADLIST(proto);
4280 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4281 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4282 SV** pname = AvARRAY(protopad_name);
4283 SV** ppad = AvARRAY(protopad);
4284 I32 fname = AvFILLp(protopad_name);
4285 I32 fpad = AvFILLp(protopad);
4289 assert(!CvUNIQUE(proto));
4293 SAVESPTR(PL_comppad_name);
4294 SAVESPTR(PL_compcv);
4296 cv = PL_compcv = (CV*)NEWSV(1104,0);
4297 sv_upgrade((SV *)cv, SvTYPE(proto));
4298 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4302 New(666, CvMUTEXP(cv), 1, perl_mutex);
4303 MUTEX_INIT(CvMUTEXP(cv));
4305 #endif /* USE_THREADS */
4306 CvFILE(cv) = CvFILE(proto);
4307 CvGV(cv) = CvGV(proto);
4308 CvSTASH(cv) = CvSTASH(proto);
4309 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4310 CvSTART(cv) = CvSTART(proto);
4312 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4315 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4317 PL_comppad_name = newAV();
4318 for (ix = fname; ix >= 0; ix--)
4319 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4321 PL_comppad = newAV();
4323 comppadlist = newAV();
4324 AvREAL_off(comppadlist);
4325 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4326 av_store(comppadlist, 1, (SV*)PL_comppad);
4327 CvPADLIST(cv) = comppadlist;
4328 av_fill(PL_comppad, AvFILLp(protopad));
4329 PL_curpad = AvARRAY(PL_comppad);
4331 av = newAV(); /* will be @_ */
4333 av_store(PL_comppad, 0, (SV*)av);
4334 AvFLAGS(av) = AVf_REIFY;
4336 for (ix = fpad; ix > 0; ix--) {
4337 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4338 if (namesv && namesv != &PL_sv_undef) {
4339 char *name = SvPVX(namesv); /* XXX */
4340 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4341 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4342 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4344 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4346 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4348 else { /* our own lexical */
4351 /* anon code -- we'll come back for it */
4352 sv = SvREFCNT_inc(ppad[ix]);
4354 else if (*name == '@')
4356 else if (*name == '%')
4365 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4366 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4369 SV* sv = NEWSV(0,0);
4375 /* Now that vars are all in place, clone nested closures. */
4377 for (ix = fpad; ix > 0; ix--) {
4378 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4380 && namesv != &PL_sv_undef
4381 && !(SvFLAGS(namesv) & SVf_FAKE)
4382 && *SvPVX(namesv) == '&'
4383 && CvCLONE(ppad[ix]))
4385 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4386 SvREFCNT_dec(ppad[ix]);
4389 PL_curpad[ix] = (SV*)kid;
4393 #ifdef DEBUG_CLOSURES
4394 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4396 PerlIO_printf(Perl_debug_log, " from:\n");
4398 PerlIO_printf(Perl_debug_log, " to:\n");
4405 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4407 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4409 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4416 Perl_cv_clone(pTHX_ CV *proto)
4419 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4420 cv = cv_clone2(proto, CvOUTSIDE(proto));
4421 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4426 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4428 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4429 SV* msg = sv_newmortal();
4433 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4434 sv_setpv(msg, "Prototype mismatch:");
4436 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4438 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4439 sv_catpv(msg, " vs ");
4441 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4443 sv_catpv(msg, "none");
4444 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4448 static void const_sv_xsub(pTHXo_ CV* cv);
4451 =for apidoc cv_const_sv
4453 If C<cv> is a constant sub eligible for inlining. returns the constant
4454 value returned by the sub. Otherwise, returns NULL.
4456 Constant subs can be created with C<newCONSTSUB> or as described in
4457 L<perlsub/"Constant Functions">.
4462 Perl_cv_const_sv(pTHX_ CV *cv)
4464 if (!cv || !CvCONST(cv))
4466 return (SV*)CvXSUBANY(cv).any_ptr;
4470 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4477 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4478 o = cLISTOPo->op_first->op_sibling;
4480 for (; o; o = o->op_next) {
4481 OPCODE type = o->op_type;
4483 if (sv && o->op_next == o)
4485 if (o->op_next != o) {
4486 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4488 if (type == OP_DBSTATE)
4491 if (type == OP_LEAVESUB || type == OP_RETURN)
4495 if (type == OP_CONST && cSVOPo->op_sv)
4497 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4498 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4499 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4503 /* We get here only from cv_clone2() while creating a closure.
4504 Copy the const value here instead of in cv_clone2 so that
4505 SvREADONLY_on doesn't lead to problems when leaving
4510 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4522 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4532 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4536 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4538 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4542 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4548 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4553 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4554 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4555 SV *sv = sv_newmortal();
4556 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4557 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4562 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4563 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4573 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4574 maximum a prototype before. */
4575 if (SvTYPE(gv) > SVt_NULL) {
4576 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4577 && ckWARN_d(WARN_PROTOTYPE))
4579 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4581 cv_ckproto((CV*)gv, NULL, ps);
4584 sv_setpv((SV*)gv, ps);
4586 sv_setiv((SV*)gv, -1);
4587 SvREFCNT_dec(PL_compcv);
4588 cv = PL_compcv = NULL;
4589 PL_sub_generation++;
4593 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4595 #ifdef GV_SHARED_CHECK
4596 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4597 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4601 if (!block || !ps || *ps || attrs)
4604 const_sv = op_const_sv(block, Nullcv);
4607 bool exists = CvROOT(cv) || CvXSUB(cv);
4609 #ifdef GV_SHARED_CHECK
4610 if (exists && GvSHARED(gv)) {
4611 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4615 /* if the subroutine doesn't exist and wasn't pre-declared
4616 * with a prototype, assume it will be AUTOLOADed,
4617 * skipping the prototype check
4619 if (exists || SvPOK(cv))
4620 cv_ckproto(cv, gv, ps);
4621 /* already defined (or promised)? */
4622 if (exists || GvASSUMECV(gv)) {
4623 if (!block && !attrs) {
4624 /* just a "sub foo;" when &foo is already defined */
4625 SAVEFREESV(PL_compcv);
4628 /* ahem, death to those who redefine active sort subs */
4629 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4630 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4632 if (ckWARN(WARN_REDEFINE)
4634 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4636 line_t oldline = CopLINE(PL_curcop);
4637 CopLINE_set(PL_curcop, PL_copline);
4638 Perl_warner(aTHX_ WARN_REDEFINE,
4639 CvCONST(cv) ? "Constant subroutine %s redefined"
4640 : "Subroutine %s redefined", name);
4641 CopLINE_set(PL_curcop, oldline);
4649 SvREFCNT_inc(const_sv);
4651 assert(!CvROOT(cv) && !CvCONST(cv));
4652 sv_setpv((SV*)cv, ""); /* prototype is "" */
4653 CvXSUBANY(cv).any_ptr = const_sv;
4654 CvXSUB(cv) = const_sv_xsub;
4659 cv = newCONSTSUB(NULL, name, const_sv);
4662 SvREFCNT_dec(PL_compcv);
4664 PL_sub_generation++;
4671 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4672 * before we clobber PL_compcv.
4676 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4677 stash = GvSTASH(CvGV(cv));
4678 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4679 stash = CvSTASH(cv);
4681 stash = PL_curstash;
4684 /* possibly about to re-define existing subr -- ignore old cv */
4685 rcv = (SV*)PL_compcv;
4686 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4687 stash = GvSTASH(gv);
4689 stash = PL_curstash;
4691 apply_attrs(stash, rcv, attrs);
4693 if (cv) { /* must reuse cv if autoloaded */
4695 /* got here with just attrs -- work done, so bug out */
4696 SAVEFREESV(PL_compcv);
4700 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4701 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4702 CvOUTSIDE(PL_compcv) = 0;
4703 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4704 CvPADLIST(PL_compcv) = 0;
4705 /* inner references to PL_compcv must be fixed up ... */
4707 AV *padlist = CvPADLIST(cv);
4708 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4709 AV *comppad = (AV*)AvARRAY(padlist)[1];
4710 SV **namepad = AvARRAY(comppad_name);
4711 SV **curpad = AvARRAY(comppad);
4712 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4713 SV *namesv = namepad[ix];
4714 if (namesv && namesv != &PL_sv_undef
4715 && *SvPVX(namesv) == '&')
4717 CV *innercv = (CV*)curpad[ix];
4718 if (CvOUTSIDE(innercv) == PL_compcv) {
4719 CvOUTSIDE(innercv) = cv;
4720 if (!CvANON(innercv) || CvCLONED(innercv)) {
4721 (void)SvREFCNT_inc(cv);
4722 SvREFCNT_dec(PL_compcv);
4728 /* ... before we throw it away */
4729 SvREFCNT_dec(PL_compcv);
4736 PL_sub_generation++;
4740 CvFILE(cv) = CopFILE(PL_curcop);
4741 CvSTASH(cv) = PL_curstash;
4744 if (!CvMUTEXP(cv)) {
4745 New(666, CvMUTEXP(cv), 1, perl_mutex);
4746 MUTEX_INIT(CvMUTEXP(cv));
4748 #endif /* USE_THREADS */
4751 sv_setpv((SV*)cv, ps);
4753 if (PL_error_count) {
4757 char *s = strrchr(name, ':');
4759 if (strEQ(s, "BEGIN")) {
4761 "BEGIN not safe after errors--compilation aborted";
4762 if (PL_in_eval & EVAL_KEEPERR)
4763 Perl_croak(aTHX_ not_safe);
4765 /* force display of errors found but not reported */
4766 sv_catpv(ERRSV, not_safe);
4767 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4775 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4776 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4779 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4780 mod(scalarseq(block), OP_LEAVESUBLV));
4783 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4785 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4786 OpREFCNT_set(CvROOT(cv), 1);
4787 CvSTART(cv) = LINKLIST(CvROOT(cv));
4788 CvROOT(cv)->op_next = 0;
4791 /* now that optimizer has done its work, adjust pad values */
4793 SV **namep = AvARRAY(PL_comppad_name);
4794 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4797 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4800 * The only things that a clonable function needs in its
4801 * pad are references to outer lexicals and anonymous subs.
4802 * The rest are created anew during cloning.
4804 if (!((namesv = namep[ix]) != Nullsv &&
4805 namesv != &PL_sv_undef &&
4807 *SvPVX(namesv) == '&')))
4809 SvREFCNT_dec(PL_curpad[ix]);
4810 PL_curpad[ix] = Nullsv;
4813 assert(!CvCONST(cv));
4814 if (ps && !*ps && op_const_sv(block, cv))
4818 AV *av = newAV(); /* Will be @_ */
4820 av_store(PL_comppad, 0, (SV*)av);
4821 AvFLAGS(av) = AVf_REIFY;
4823 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4824 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4826 if (!SvPADMY(PL_curpad[ix]))
4827 SvPADTMP_on(PL_curpad[ix]);
4831 /* If a potential closure prototype, don't keep a refcount on outer CV.
4832 * This is okay as the lifetime of the prototype is tied to the
4833 * lifetime of the outer CV. Avoids memory leak due to reference
4836 SvREFCNT_dec(CvOUTSIDE(cv));
4838 if (name || aname) {
4840 char *tname = (name ? name : aname);
4842 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4843 SV *sv = NEWSV(0,0);
4844 SV *tmpstr = sv_newmortal();
4845 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4849 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4851 (long)PL_subline, (long)CopLINE(PL_curcop));
4852 gv_efullname3(tmpstr, gv, Nullch);
4853 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4854 hv = GvHVn(db_postponed);
4855 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4856 && (pcv = GvCV(db_postponed)))
4862 call_sv((SV*)pcv, G_DISCARD);
4866 if ((s = strrchr(tname,':')))
4871 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4874 if (strEQ(s, "BEGIN")) {
4875 I32 oldscope = PL_scopestack_ix;
4877 SAVECOPFILE(&PL_compiling);
4878 SAVECOPLINE(&PL_compiling);
4880 sv_setsv(PL_rs, PL_nrs);
4883 PL_beginav = newAV();
4884 DEBUG_x( dump_sub(gv) );
4885 av_push(PL_beginav, (SV*)cv);
4886 GvCV(gv) = 0; /* cv has been hijacked */
4887 call_list(oldscope, PL_beginav);
4889 PL_curcop = &PL_compiling;
4890 PL_compiling.op_private = PL_hints;
4893 else if (strEQ(s, "END") && !PL_error_count) {
4896 DEBUG_x( dump_sub(gv) );
4897 av_unshift(PL_endav, 1);
4898 av_store(PL_endav, 0, (SV*)cv);
4899 GvCV(gv) = 0; /* cv has been hijacked */
4901 else if (strEQ(s, "CHECK") && !PL_error_count) {
4903 PL_checkav = newAV();
4904 DEBUG_x( dump_sub(gv) );
4905 if (PL_main_start && ckWARN(WARN_VOID))
4906 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4907 av_unshift(PL_checkav, 1);
4908 av_store(PL_checkav, 0, (SV*)cv);
4909 GvCV(gv) = 0; /* cv has been hijacked */
4911 else if (strEQ(s, "INIT") && !PL_error_count) {
4913 PL_initav = newAV();
4914 DEBUG_x( dump_sub(gv) );
4915 if (PL_main_start && ckWARN(WARN_VOID))
4916 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4917 av_push(PL_initav, (SV*)cv);
4918 GvCV(gv) = 0; /* cv has been hijacked */
4923 PL_copline = NOLINE;
4928 /* XXX unsafe for threads if eval_owner isn't held */
4930 =for apidoc newCONSTSUB
4932 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4933 eligible for inlining at compile-time.
4939 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4945 SAVECOPLINE(PL_curcop);
4946 CopLINE_set(PL_curcop, PL_copline);
4949 PL_hints &= ~HINT_BLOCK_SCOPE;
4952 SAVESPTR(PL_curstash);
4953 SAVECOPSTASH(PL_curcop);
4954 PL_curstash = stash;
4956 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4958 CopSTASH(PL_curcop) = stash;
4962 cv = newXS(name, const_sv_xsub, __FILE__);
4963 CvXSUBANY(cv).any_ptr = sv;
4965 sv_setpv((SV*)cv, ""); /* prototype is "" */
4973 =for apidoc U||newXS
4975 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4981 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4983 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4986 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4988 /* just a cached method */
4992 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4993 /* already defined (or promised) */
4994 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4995 && HvNAME(GvSTASH(CvGV(cv)))
4996 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4997 line_t oldline = CopLINE(PL_curcop);
4998 if (PL_copline != NOLINE)
4999 CopLINE_set(PL_curcop, PL_copline);
5000 Perl_warner(aTHX_ WARN_REDEFINE,
5001 CvCONST(cv) ? "Constant subroutine %s redefined"
5002 : "Subroutine %s redefined"
5004 CopLINE_set(PL_curcop, oldline);
5011 if (cv) /* must reuse cv if autoloaded */
5014 cv = (CV*)NEWSV(1105,0);
5015 sv_upgrade((SV *)cv, SVt_PVCV);
5019 PL_sub_generation++;
5024 New(666, CvMUTEXP(cv), 1, perl_mutex);
5025 MUTEX_INIT(CvMUTEXP(cv));
5027 #endif /* USE_THREADS */
5028 (void)gv_fetchfile(filename);
5029 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5030 an external constant string */
5031 CvXSUB(cv) = subaddr;
5034 char *s = strrchr(name,':');
5040 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5043 if (strEQ(s, "BEGIN")) {
5045 PL_beginav = newAV();
5046 av_push(PL_beginav, (SV*)cv);
5047 GvCV(gv) = 0; /* cv has been hijacked */
5049 else if (strEQ(s, "END")) {
5052 av_unshift(PL_endav, 1);
5053 av_store(PL_endav, 0, (SV*)cv);
5054 GvCV(gv) = 0; /* cv has been hijacked */
5056 else if (strEQ(s, "CHECK")) {
5058 PL_checkav = newAV();
5059 if (PL_main_start && ckWARN(WARN_VOID))
5060 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5061 av_unshift(PL_checkav, 1);
5062 av_store(PL_checkav, 0, (SV*)cv);
5063 GvCV(gv) = 0; /* cv has been hijacked */
5065 else if (strEQ(s, "INIT")) {
5067 PL_initav = newAV();
5068 if (PL_main_start && ckWARN(WARN_VOID))
5069 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5070 av_push(PL_initav, (SV*)cv);
5071 GvCV(gv) = 0; /* cv has been hijacked */
5082 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5091 name = SvPVx(cSVOPo->op_sv, n_a);
5094 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5095 #ifdef GV_SHARED_CHECK
5097 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5101 if ((cv = GvFORM(gv))) {
5102 if (ckWARN(WARN_REDEFINE)) {
5103 line_t oldline = CopLINE(PL_curcop);
5105 CopLINE_set(PL_curcop, PL_copline);
5106 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5107 CopLINE_set(PL_curcop, oldline);
5114 CvFILE(cv) = CopFILE(PL_curcop);
5116 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5117 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5118 SvPADTMP_on(PL_curpad[ix]);
5121 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5122 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5123 OpREFCNT_set(CvROOT(cv), 1);
5124 CvSTART(cv) = LINKLIST(CvROOT(cv));
5125 CvROOT(cv)->op_next = 0;
5128 PL_copline = NOLINE;
5133 Perl_newANONLIST(pTHX_ OP *o)
5135 return newUNOP(OP_REFGEN, 0,
5136 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5140 Perl_newANONHASH(pTHX_ OP *o)
5142 return newUNOP(OP_REFGEN, 0,
5143 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5147 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5149 return newANONATTRSUB(floor, proto, Nullop, block);
5153 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5155 return newUNOP(OP_REFGEN, 0,
5156 newSVOP(OP_ANONCODE, 0,
5157 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5161 Perl_oopsAV(pTHX_ OP *o)
5163 switch (o->op_type) {
5165 o->op_type = OP_PADAV;
5166 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5167 return ref(o, OP_RV2AV);
5170 o->op_type = OP_RV2AV;
5171 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5176 if (ckWARN_d(WARN_INTERNAL))
5177 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5184 Perl_oopsHV(pTHX_ OP *o)
5186 switch (o->op_type) {
5189 o->op_type = OP_PADHV;
5190 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5191 return ref(o, OP_RV2HV);
5195 o->op_type = OP_RV2HV;
5196 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5201 if (ckWARN_d(WARN_INTERNAL))
5202 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5209 Perl_newAVREF(pTHX_ OP *o)
5211 if (o->op_type == OP_PADANY) {
5212 o->op_type = OP_PADAV;
5213 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5216 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5217 && ckWARN(WARN_DEPRECATED)) {
5218 Perl_warner(aTHX_ WARN_DEPRECATED,
5219 "Using an array as a reference is deprecated");
5221 return newUNOP(OP_RV2AV, 0, scalar(o));
5225 Perl_newGVREF(pTHX_ I32 type, OP *o)
5227 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5228 return newUNOP(OP_NULL, 0, o);
5229 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5233 Perl_newHVREF(pTHX_ OP *o)
5235 if (o->op_type == OP_PADANY) {
5236 o->op_type = OP_PADHV;
5237 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5240 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5241 && ckWARN(WARN_DEPRECATED)) {
5242 Perl_warner(aTHX_ WARN_DEPRECATED,
5243 "Using a hash as a reference is deprecated");
5245 return newUNOP(OP_RV2HV, 0, scalar(o));
5249 Perl_oopsCV(pTHX_ OP *o)
5251 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5257 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5259 return newUNOP(OP_RV2CV, flags, scalar(o));
5263 Perl_newSVREF(pTHX_ OP *o)
5265 if (o->op_type == OP_PADANY) {
5266 o->op_type = OP_PADSV;
5267 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5270 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5271 o->op_flags |= OPpDONE_SVREF;
5274 return newUNOP(OP_RV2SV, 0, scalar(o));
5277 /* Check routines. */
5280 Perl_ck_anoncode(pTHX_ OP *o)
5285 name = NEWSV(1106,0);
5286 sv_upgrade(name, SVt_PVNV);
5287 sv_setpvn(name, "&", 1);
5290 ix = pad_alloc(o->op_type, SVs_PADMY);
5291 av_store(PL_comppad_name, ix, name);
5292 av_store(PL_comppad, ix, cSVOPo->op_sv);
5293 SvPADMY_on(cSVOPo->op_sv);
5294 cSVOPo->op_sv = Nullsv;
5295 cSVOPo->op_targ = ix;
5300 Perl_ck_bitop(pTHX_ OP *o)
5302 o->op_private = PL_hints;
5307 Perl_ck_concat(pTHX_ OP *o)
5309 if (cUNOPo->op_first->op_type == OP_CONCAT)
5310 o->op_flags |= OPf_STACKED;
5315 Perl_ck_spair(pTHX_ OP *o)
5317 if (o->op_flags & OPf_KIDS) {
5320 OPCODE type = o->op_type;
5321 o = modkids(ck_fun(o), type);
5322 kid = cUNOPo->op_first;
5323 newop = kUNOP->op_first->op_sibling;
5325 (newop->op_sibling ||
5326 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5327 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5328 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5332 op_free(kUNOP->op_first);
5333 kUNOP->op_first = newop;
5335 o->op_ppaddr = PL_ppaddr[++o->op_type];
5340 Perl_ck_delete(pTHX_ OP *o)
5344 if (o->op_flags & OPf_KIDS) {
5345 OP *kid = cUNOPo->op_first;
5346 switch (kid->op_type) {
5348 o->op_flags |= OPf_SPECIAL;
5351 o->op_private |= OPpSLICE;
5354 o->op_flags |= OPf_SPECIAL;
5359 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5360 PL_op_desc[o->op_type]);
5368 Perl_ck_eof(pTHX_ OP *o)
5370 I32 type = o->op_type;
5372 if (o->op_flags & OPf_KIDS) {
5373 if (cLISTOPo->op_first->op_type == OP_STUB) {
5375 o = newUNOP(type, OPf_SPECIAL,
5376 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5384 Perl_ck_eval(pTHX_ OP *o)
5386 PL_hints |= HINT_BLOCK_SCOPE;
5387 if (o->op_flags & OPf_KIDS) {
5388 SVOP *kid = (SVOP*)cUNOPo->op_first;
5391 o->op_flags &= ~OPf_KIDS;
5394 else if (kid->op_type == OP_LINESEQ) {
5397 kid->op_next = o->op_next;
5398 cUNOPo->op_first = 0;
5401 NewOp(1101, enter, 1, LOGOP);
5402 enter->op_type = OP_ENTERTRY;
5403 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5404 enter->op_private = 0;
5406 /* establish postfix order */
5407 enter->op_next = (OP*)enter;
5409 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5410 o->op_type = OP_LEAVETRY;
5411 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5412 enter->op_other = o;
5420 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5422 o->op_targ = (PADOFFSET)PL_hints;
5427 Perl_ck_exit(pTHX_ OP *o)
5430 HV *table = GvHV(PL_hintgv);
5432 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5433 if (svp && *svp && SvTRUE(*svp))
5434 o->op_private |= OPpEXIT_VMSISH;
5441 Perl_ck_exec(pTHX_ OP *o)
5444 if (o->op_flags & OPf_STACKED) {
5446 kid = cUNOPo->op_first->op_sibling;
5447 if (kid->op_type == OP_RV2GV)
5456 Perl_ck_exists(pTHX_ OP *o)
5459 if (o->op_flags & OPf_KIDS) {
5460 OP *kid = cUNOPo->op_first;
5461 if (kid->op_type == OP_ENTERSUB) {
5462 (void) ref(kid, o->op_type);
5463 if (kid->op_type != OP_RV2CV && !PL_error_count)
5464 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5465 PL_op_desc[o->op_type]);
5466 o->op_private |= OPpEXISTS_SUB;
5468 else if (kid->op_type == OP_AELEM)
5469 o->op_flags |= OPf_SPECIAL;
5470 else if (kid->op_type != OP_HELEM)
5471 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5472 PL_op_desc[o->op_type]);
5480 Perl_ck_gvconst(pTHX_ register OP *o)
5482 o = fold_constants(o);
5483 if (o->op_type == OP_CONST)
5490 Perl_ck_rvconst(pTHX_ register OP *o)
5492 SVOP *kid = (SVOP*)cUNOPo->op_first;
5494 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5495 if (kid->op_type == OP_CONST) {
5499 SV *kidsv = kid->op_sv;
5502 /* Is it a constant from cv_const_sv()? */
5503 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5504 SV *rsv = SvRV(kidsv);
5505 int svtype = SvTYPE(rsv);
5506 char *badtype = Nullch;
5508 switch (o->op_type) {
5510 if (svtype > SVt_PVMG)
5511 badtype = "a SCALAR";
5514 if (svtype != SVt_PVAV)
5515 badtype = "an ARRAY";
5518 if (svtype != SVt_PVHV) {
5519 if (svtype == SVt_PVAV) { /* pseudohash? */
5520 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5521 if (ksv && SvROK(*ksv)
5522 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5531 if (svtype != SVt_PVCV)
5536 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5539 name = SvPV(kidsv, n_a);
5540 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5541 char *badthing = Nullch;
5542 switch (o->op_type) {
5544 badthing = "a SCALAR";
5547 badthing = "an ARRAY";
5550 badthing = "a HASH";
5555 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5559 * This is a little tricky. We only want to add the symbol if we
5560 * didn't add it in the lexer. Otherwise we get duplicate strict
5561 * warnings. But if we didn't add it in the lexer, we must at
5562 * least pretend like we wanted to add it even if it existed before,
5563 * or we get possible typo warnings. OPpCONST_ENTERED says
5564 * whether the lexer already added THIS instance of this symbol.
5566 iscv = (o->op_type == OP_RV2CV) * 2;
5568 gv = gv_fetchpv(name,
5569 iscv | !(kid->op_private & OPpCONST_ENTERED),
5572 : o->op_type == OP_RV2SV
5574 : o->op_type == OP_RV2AV
5576 : o->op_type == OP_RV2HV
5579 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5581 kid->op_type = OP_GV;
5582 SvREFCNT_dec(kid->op_sv);
5584 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5585 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5586 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5588 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5590 kid->op_sv = SvREFCNT_inc(gv);
5592 kid->op_private = 0;
5593 kid->op_ppaddr = PL_ppaddr[OP_GV];
5600 Perl_ck_ftst(pTHX_ OP *o)
5602 I32 type = o->op_type;
5604 if (o->op_flags & OPf_REF) {
5607 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5608 SVOP *kid = (SVOP*)cUNOPo->op_first;
5610 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5612 OP *newop = newGVOP(type, OPf_REF,
5613 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5620 if (type == OP_FTTTY)
5621 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5624 o = newUNOP(type, 0, newDEFSVOP());
5627 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5629 if (PL_hints & HINT_LOCALE)
5630 o->op_private |= OPpLOCALE;
5637 Perl_ck_fun(pTHX_ OP *o)
5643 int type = o->op_type;
5644 register I32 oa = PL_opargs[type] >> OASHIFT;
5646 if (o->op_flags & OPf_STACKED) {
5647 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5650 return no_fh_allowed(o);
5653 if (o->op_flags & OPf_KIDS) {
5655 tokid = &cLISTOPo->op_first;
5656 kid = cLISTOPo->op_first;
5657 if (kid->op_type == OP_PUSHMARK ||
5658 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5660 tokid = &kid->op_sibling;
5661 kid = kid->op_sibling;
5663 if (!kid && PL_opargs[type] & OA_DEFGV)
5664 *tokid = kid = newDEFSVOP();
5668 sibl = kid->op_sibling;
5671 /* list seen where single (scalar) arg expected? */
5672 if (numargs == 1 && !(oa >> 4)
5673 && kid->op_type == OP_LIST && type != OP_SCALAR)
5675 return too_many_arguments(o,PL_op_desc[type]);
5688 if ((type == OP_PUSH || type == OP_UNSHIFT)
5689 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5690 Perl_warner(aTHX_ WARN_SYNTAX,
5691 "Useless use of %s with no values",
5694 if (kid->op_type == OP_CONST &&
5695 (kid->op_private & OPpCONST_BARE))
5697 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5698 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5699 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5700 if (ckWARN(WARN_DEPRECATED))
5701 Perl_warner(aTHX_ WARN_DEPRECATED,
5702 "Array @%s missing the @ in argument %"IVdf" of %s()",
5703 name, (IV)numargs, PL_op_desc[type]);
5706 kid->op_sibling = sibl;
5709 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5710 bad_type(numargs, "array", PL_op_desc[type], kid);
5714 if (kid->op_type == OP_CONST &&
5715 (kid->op_private & OPpCONST_BARE))
5717 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5718 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5719 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5720 if (ckWARN(WARN_DEPRECATED))
5721 Perl_warner(aTHX_ WARN_DEPRECATED,
5722 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5723 name, (IV)numargs, PL_op_desc[type]);
5726 kid->op_sibling = sibl;
5729 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5730 bad_type(numargs, "hash", PL_op_desc[type], kid);
5735 OP *newop = newUNOP(OP_NULL, 0, kid);
5736 kid->op_sibling = 0;
5738 newop->op_next = newop;
5740 kid->op_sibling = sibl;
5745 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5746 if (kid->op_type == OP_CONST &&
5747 (kid->op_private & OPpCONST_BARE))
5749 OP *newop = newGVOP(OP_GV, 0,
5750 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5755 else if (kid->op_type == OP_READLINE) {
5756 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5757 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5760 I32 flags = OPf_SPECIAL;
5764 /* is this op a FH constructor? */
5765 if (is_handle_constructor(o,numargs)) {
5766 char *name = Nullch;
5770 /* Set a flag to tell rv2gv to vivify
5771 * need to "prove" flag does not mean something
5772 * else already - NI-S 1999/05/07
5775 if (kid->op_type == OP_PADSV) {
5776 SV **namep = av_fetch(PL_comppad_name,
5778 if (namep && *namep)
5779 name = SvPV(*namep, len);
5781 else if (kid->op_type == OP_RV2SV
5782 && kUNOP->op_first->op_type == OP_GV)
5784 GV *gv = cGVOPx_gv(kUNOP->op_first);
5786 len = GvNAMELEN(gv);
5788 else if (kid->op_type == OP_AELEM
5789 || kid->op_type == OP_HELEM)
5791 name = "__ANONIO__";
5797 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5798 namesv = PL_curpad[targ];
5799 (void)SvUPGRADE(namesv, SVt_PV);
5801 sv_setpvn(namesv, "$", 1);
5802 sv_catpvn(namesv, name, len);
5805 kid->op_sibling = 0;
5806 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5807 kid->op_targ = targ;
5808 kid->op_private |= priv;
5810 kid->op_sibling = sibl;
5816 mod(scalar(kid), type);
5820 tokid = &kid->op_sibling;
5821 kid = kid->op_sibling;
5823 o->op_private |= numargs;
5825 return too_many_arguments(o,PL_op_desc[o->op_type]);
5828 else if (PL_opargs[type] & OA_DEFGV) {
5830 return newUNOP(type, 0, newDEFSVOP());
5834 while (oa & OA_OPTIONAL)
5836 if (oa && oa != OA_LIST)
5837 return too_few_arguments(o,PL_op_desc[o->op_type]);
5843 Perl_ck_glob(pTHX_ OP *o)
5848 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5849 append_elem(OP_GLOB, o, newDEFSVOP());
5851 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5852 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5854 #if !defined(PERL_EXTERNAL_GLOB)
5855 /* XXX this can be tightened up and made more failsafe. */
5859 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5861 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5862 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5863 GvCV(gv) = GvCV(glob_gv);
5864 SvREFCNT_inc((SV*)GvCV(gv));
5865 GvIMPORTED_CV_on(gv);
5868 #endif /* PERL_EXTERNAL_GLOB */
5870 if (gv && GvIMPORTED_CV(gv)) {
5871 append_elem(OP_GLOB, o,
5872 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5873 o->op_type = OP_LIST;
5874 o->op_ppaddr = PL_ppaddr[OP_LIST];
5875 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5876 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5877 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5878 append_elem(OP_LIST, o,
5879 scalar(newUNOP(OP_RV2CV, 0,
5880 newGVOP(OP_GV, 0, gv)))));
5881 o = newUNOP(OP_NULL, 0, ck_subr(o));
5882 o->op_targ = OP_GLOB; /* hint at what it used to be */
5885 gv = newGVgen("main");
5887 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5893 Perl_ck_grep(pTHX_ OP *o)
5897 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5899 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5900 NewOp(1101, gwop, 1, LOGOP);
5902 if (o->op_flags & OPf_STACKED) {
5905 kid = cLISTOPo->op_first->op_sibling;
5906 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5909 kid->op_next = (OP*)gwop;
5910 o->op_flags &= ~OPf_STACKED;
5912 kid = cLISTOPo->op_first->op_sibling;
5913 if (type == OP_MAPWHILE)
5920 kid = cLISTOPo->op_first->op_sibling;
5921 if (kid->op_type != OP_NULL)
5922 Perl_croak(aTHX_ "panic: ck_grep");
5923 kid = kUNOP->op_first;
5925 gwop->op_type = type;
5926 gwop->op_ppaddr = PL_ppaddr[type];
5927 gwop->op_first = listkids(o);
5928 gwop->op_flags |= OPf_KIDS;
5929 gwop->op_private = 1;
5930 gwop->op_other = LINKLIST(kid);
5931 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5932 kid->op_next = (OP*)gwop;
5934 kid = cLISTOPo->op_first->op_sibling;
5935 if (!kid || !kid->op_sibling)
5936 return too_few_arguments(o,PL_op_desc[o->op_type]);
5937 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5938 mod(kid, OP_GREPSTART);
5944 Perl_ck_index(pTHX_ OP *o)
5946 if (o->op_flags & OPf_KIDS) {
5947 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5949 kid = kid->op_sibling; /* get past "big" */
5950 if (kid && kid->op_type == OP_CONST)
5951 fbm_compile(((SVOP*)kid)->op_sv, 0);
5957 Perl_ck_lengthconst(pTHX_ OP *o)
5959 /* XXX length optimization goes here */
5964 Perl_ck_lfun(pTHX_ OP *o)
5966 OPCODE type = o->op_type;
5967 return modkids(ck_fun(o), type);
5971 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5973 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5974 switch (cUNOPo->op_first->op_type) {
5976 /* This is needed for
5977 if (defined %stash::)
5978 to work. Do not break Tk.
5980 break; /* Globals via GV can be undef */
5982 case OP_AASSIGN: /* Is this a good idea? */
5983 Perl_warner(aTHX_ WARN_DEPRECATED,
5984 "defined(@array) is deprecated");
5985 Perl_warner(aTHX_ WARN_DEPRECATED,
5986 "\t(Maybe you should just omit the defined()?)\n");
5989 /* This is needed for
5990 if (defined %stash::)
5991 to work. Do not break Tk.
5993 break; /* Globals via GV can be undef */
5995 Perl_warner(aTHX_ WARN_DEPRECATED,
5996 "defined(%%hash) is deprecated");
5997 Perl_warner(aTHX_ WARN_DEPRECATED,
5998 "\t(Maybe you should just omit the defined()?)\n");
6009 Perl_ck_rfun(pTHX_ OP *o)
6011 OPCODE type = o->op_type;
6012 return refkids(ck_fun(o), type);
6016 Perl_ck_listiob(pTHX_ OP *o)
6020 kid = cLISTOPo->op_first;
6023 kid = cLISTOPo->op_first;
6025 if (kid->op_type == OP_PUSHMARK)
6026 kid = kid->op_sibling;
6027 if (kid && o->op_flags & OPf_STACKED)
6028 kid = kid->op_sibling;
6029 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6030 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6031 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6032 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6033 cLISTOPo->op_first->op_sibling = kid;
6034 cLISTOPo->op_last = kid;
6035 kid = kid->op_sibling;
6040 append_elem(o->op_type, o, newDEFSVOP());
6046 if (PL_hints & HINT_LOCALE)
6047 o->op_private |= OPpLOCALE;
6054 Perl_ck_fun_locale(pTHX_ OP *o)
6060 if (PL_hints & HINT_LOCALE)
6061 o->op_private |= OPpLOCALE;
6068 Perl_ck_sassign(pTHX_ OP *o)
6070 OP *kid = cLISTOPo->op_first;
6071 /* has a disposable target? */
6072 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6073 && !(kid->op_flags & OPf_STACKED)
6074 /* Cannot steal the second time! */
6075 && !(kid->op_private & OPpTARGET_MY))
6077 OP *kkid = kid->op_sibling;
6079 /* Can just relocate the target. */
6080 if (kkid && kkid->op_type == OP_PADSV
6081 && !(kkid->op_private & OPpLVAL_INTRO))
6083 kid->op_targ = kkid->op_targ;
6085 /* Now we do not need PADSV and SASSIGN. */
6086 kid->op_sibling = o->op_sibling; /* NULL */
6087 cLISTOPo->op_first = NULL;
6090 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6098 Perl_ck_scmp(pTHX_ OP *o)
6102 if (PL_hints & HINT_LOCALE)
6103 o->op_private |= OPpLOCALE;
6110 Perl_ck_match(pTHX_ OP *o)
6112 o->op_private |= OPpRUNTIME;
6117 Perl_ck_method(pTHX_ OP *o)
6119 OP *kid = cUNOPo->op_first;
6120 if (kid->op_type == OP_CONST) {
6121 SV* sv = kSVOP->op_sv;
6122 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6124 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6125 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6128 kSVOP->op_sv = Nullsv;
6130 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6139 Perl_ck_null(pTHX_ OP *o)
6145 Perl_ck_open(pTHX_ OP *o)
6147 HV *table = GvHV(PL_hintgv);
6151 svp = hv_fetch(table, "open_IN", 7, FALSE);
6153 mode = mode_from_discipline(*svp);
6154 if (mode & O_BINARY)
6155 o->op_private |= OPpOPEN_IN_RAW;
6156 else if (mode & O_TEXT)
6157 o->op_private |= OPpOPEN_IN_CRLF;
6160 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6162 mode = mode_from_discipline(*svp);
6163 if (mode & O_BINARY)
6164 o->op_private |= OPpOPEN_OUT_RAW;
6165 else if (mode & O_TEXT)
6166 o->op_private |= OPpOPEN_OUT_CRLF;
6169 if (o->op_type == OP_BACKTICK)
6175 Perl_ck_repeat(pTHX_ OP *o)
6177 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6178 o->op_private |= OPpREPEAT_DOLIST;
6179 cBINOPo->op_first = force_list(cBINOPo->op_first);
6187 Perl_ck_require(pTHX_ OP *o)
6189 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6190 SVOP *kid = (SVOP*)cUNOPo->op_first;
6192 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6194 for (s = SvPVX(kid->op_sv); *s; s++) {
6195 if (*s == ':' && s[1] == ':') {
6197 Move(s+2, s+1, strlen(s+2)+1, char);
6198 --SvCUR(kid->op_sv);
6201 if (SvREADONLY(kid->op_sv)) {
6202 SvREADONLY_off(kid->op_sv);
6203 sv_catpvn(kid->op_sv, ".pm", 3);
6204 SvREADONLY_on(kid->op_sv);
6207 sv_catpvn(kid->op_sv, ".pm", 3);
6214 Perl_ck_return(pTHX_ OP *o)
6217 if (CvLVALUE(PL_compcv)) {
6218 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6219 mod(kid, OP_LEAVESUBLV);
6226 Perl_ck_retarget(pTHX_ OP *o)
6228 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6235 Perl_ck_select(pTHX_ OP *o)
6238 if (o->op_flags & OPf_KIDS) {
6239 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6240 if (kid && kid->op_sibling) {
6241 o->op_type = OP_SSELECT;
6242 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6244 return fold_constants(o);
6248 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6249 if (kid && kid->op_type == OP_RV2GV)
6250 kid->op_private &= ~HINT_STRICT_REFS;
6255 Perl_ck_shift(pTHX_ OP *o)
6257 I32 type = o->op_type;
6259 if (!(o->op_flags & OPf_KIDS)) {
6264 if (!CvUNIQUE(PL_compcv)) {
6265 argop = newOP(OP_PADAV, OPf_REF);
6266 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6269 argop = newUNOP(OP_RV2AV, 0,
6270 scalar(newGVOP(OP_GV, 0,
6271 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6274 argop = newUNOP(OP_RV2AV, 0,
6275 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6276 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6277 #endif /* USE_THREADS */
6278 return newUNOP(type, 0, scalar(argop));
6280 return scalar(modkids(ck_fun(o), type));
6284 Perl_ck_sort(pTHX_ OP *o)
6289 if (PL_hints & HINT_LOCALE)
6290 o->op_private |= OPpLOCALE;
6293 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6295 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6296 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6298 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6300 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6302 if (kid->op_type == OP_SCOPE) {
6306 else if (kid->op_type == OP_LEAVE) {
6307 if (o->op_type == OP_SORT) {
6308 op_null(kid); /* wipe out leave */
6311 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6312 if (k->op_next == kid)
6314 /* don't descend into loops */
6315 else if (k->op_type == OP_ENTERLOOP
6316 || k->op_type == OP_ENTERITER)
6318 k = cLOOPx(k)->op_lastop;
6323 kid->op_next = 0; /* just disconnect the leave */
6324 k = kLISTOP->op_first;
6329 if (o->op_type == OP_SORT) {
6330 /* provide scalar context for comparison function/block */
6336 o->op_flags |= OPf_SPECIAL;
6338 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6341 firstkid = firstkid->op_sibling;
6344 /* provide list context for arguments */
6345 if (o->op_type == OP_SORT)
6352 S_simplify_sort(pTHX_ OP *o)
6354 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6358 if (!(o->op_flags & OPf_STACKED))
6360 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6361 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6362 kid = kUNOP->op_first; /* get past null */
6363 if (kid->op_type != OP_SCOPE)
6365 kid = kLISTOP->op_last; /* get past scope */
6366 switch(kid->op_type) {
6374 k = kid; /* remember this node*/
6375 if (kBINOP->op_first->op_type != OP_RV2SV)
6377 kid = kBINOP->op_first; /* get past cmp */
6378 if (kUNOP->op_first->op_type != OP_GV)
6380 kid = kUNOP->op_first; /* get past rv2sv */
6382 if (GvSTASH(gv) != PL_curstash)
6384 if (strEQ(GvNAME(gv), "a"))
6386 else if (strEQ(GvNAME(gv), "b"))
6390 kid = k; /* back to cmp */
6391 if (kBINOP->op_last->op_type != OP_RV2SV)
6393 kid = kBINOP->op_last; /* down to 2nd arg */
6394 if (kUNOP->op_first->op_type != OP_GV)
6396 kid = kUNOP->op_first; /* get past rv2sv */
6398 if (GvSTASH(gv) != PL_curstash
6400 ? strNE(GvNAME(gv), "a")
6401 : strNE(GvNAME(gv), "b")))
6403 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6405 o->op_private |= OPpSORT_REVERSE;
6406 if (k->op_type == OP_NCMP)
6407 o->op_private |= OPpSORT_NUMERIC;
6408 if (k->op_type == OP_I_NCMP)
6409 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6410 kid = cLISTOPo->op_first->op_sibling;
6411 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6412 op_free(kid); /* then delete it */
6416 Perl_ck_split(pTHX_ OP *o)
6420 if (o->op_flags & OPf_STACKED)
6421 return no_fh_allowed(o);
6423 kid = cLISTOPo->op_first;
6424 if (kid->op_type != OP_NULL)
6425 Perl_croak(aTHX_ "panic: ck_split");
6426 kid = kid->op_sibling;
6427 op_free(cLISTOPo->op_first);
6428 cLISTOPo->op_first = kid;
6430 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6431 cLISTOPo->op_last = kid; /* There was only one element previously */
6434 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6435 OP *sibl = kid->op_sibling;
6436 kid->op_sibling = 0;
6437 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6438 if (cLISTOPo->op_first == cLISTOPo->op_last)
6439 cLISTOPo->op_last = kid;
6440 cLISTOPo->op_first = kid;
6441 kid->op_sibling = sibl;
6444 kid->op_type = OP_PUSHRE;
6445 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6448 if (!kid->op_sibling)
6449 append_elem(OP_SPLIT, o, newDEFSVOP());
6451 kid = kid->op_sibling;
6454 if (!kid->op_sibling)
6455 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6457 kid = kid->op_sibling;
6460 if (kid->op_sibling)
6461 return too_many_arguments(o,PL_op_desc[o->op_type]);
6467 Perl_ck_join(pTHX_ OP *o)
6469 if (ckWARN(WARN_SYNTAX)) {
6470 OP *kid = cLISTOPo->op_first->op_sibling;
6471 if (kid && kid->op_type == OP_MATCH) {
6472 char *pmstr = "STRING";
6473 if (kPMOP->op_pmregexp)
6474 pmstr = kPMOP->op_pmregexp->precomp;
6475 Perl_warner(aTHX_ WARN_SYNTAX,
6476 "/%s/ should probably be written as \"%s\"",
6484 Perl_ck_subr(pTHX_ OP *o)
6486 OP *prev = ((cUNOPo->op_first->op_sibling)
6487 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6488 OP *o2 = prev->op_sibling;
6497 o->op_private |= OPpENTERSUB_HASTARG;
6498 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6499 if (cvop->op_type == OP_RV2CV) {
6501 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6502 op_null(cvop); /* disable rv2cv */
6503 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6504 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6505 GV *gv = cGVOPx_gv(tmpop);
6508 tmpop->op_private |= OPpEARLY_CV;
6509 else if (SvPOK(cv)) {
6510 namegv = CvANON(cv) ? gv : CvGV(cv);
6511 proto = SvPV((SV*)cv, n_a);
6515 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6516 if (o2->op_type == OP_CONST)
6517 o2->op_private &= ~OPpCONST_STRICT;
6518 else if (o2->op_type == OP_LIST) {
6519 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6520 if (o && o->op_type == OP_CONST)
6521 o->op_private &= ~OPpCONST_STRICT;
6524 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6525 if (PERLDB_SUB && PL_curstash != PL_debstash)
6526 o->op_private |= OPpENTERSUB_DB;
6527 while (o2 != cvop) {
6531 return too_many_arguments(o, gv_ename(namegv));
6549 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6551 arg == 1 ? "block or sub {}" : "sub {}",
6552 gv_ename(namegv), o2);
6555 /* '*' allows any scalar type, including bareword */
6558 if (o2->op_type == OP_RV2GV)
6559 goto wrapref; /* autoconvert GLOB -> GLOBref */
6560 else if (o2->op_type == OP_CONST)
6561 o2->op_private &= ~OPpCONST_STRICT;
6562 else if (o2->op_type == OP_ENTERSUB) {
6563 /* accidental subroutine, revert to bareword */
6564 OP *gvop = ((UNOP*)o2)->op_first;
6565 if (gvop && gvop->op_type == OP_NULL) {
6566 gvop = ((UNOP*)gvop)->op_first;
6568 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6571 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6572 (gvop = ((UNOP*)gvop)->op_first) &&
6573 gvop->op_type == OP_GV)
6575 GV *gv = cGVOPx_gv(gvop);
6576 OP *sibling = o2->op_sibling;
6577 SV *n = newSVpvn("",0);
6579 gv_fullname3(n, gv, "");
6580 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6581 sv_chop(n, SvPVX(n)+6);
6582 o2 = newSVOP(OP_CONST, 0, n);
6583 prev->op_sibling = o2;
6584 o2->op_sibling = sibling;
6596 if (o2->op_type != OP_RV2GV)
6597 bad_type(arg, "symbol", gv_ename(namegv), o2);
6600 if (o2->op_type != OP_ENTERSUB)
6601 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6604 if (o2->op_type != OP_RV2SV
6605 && o2->op_type != OP_PADSV
6606 && o2->op_type != OP_HELEM
6607 && o2->op_type != OP_AELEM
6608 && o2->op_type != OP_THREADSV)
6610 bad_type(arg, "scalar", gv_ename(namegv), o2);
6614 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6615 bad_type(arg, "array", gv_ename(namegv), o2);
6618 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6619 bad_type(arg, "hash", gv_ename(namegv), o2);
6623 OP* sib = kid->op_sibling;
6624 kid->op_sibling = 0;
6625 o2 = newUNOP(OP_REFGEN, 0, kid);
6626 o2->op_sibling = sib;
6627 prev->op_sibling = o2;
6638 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6639 gv_ename(namegv), SvPV((SV*)cv, n_a));
6644 mod(o2, OP_ENTERSUB);
6646 o2 = o2->op_sibling;
6648 if (proto && !optional &&
6649 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6650 return too_few_arguments(o, gv_ename(namegv));
6655 Perl_ck_svconst(pTHX_ OP *o)
6657 SvREADONLY_on(cSVOPo->op_sv);
6662 Perl_ck_trunc(pTHX_ OP *o)
6664 if (o->op_flags & OPf_KIDS) {
6665 SVOP *kid = (SVOP*)cUNOPo->op_first;
6667 if (kid->op_type == OP_NULL)
6668 kid = (SVOP*)kid->op_sibling;
6669 if (kid && kid->op_type == OP_CONST &&
6670 (kid->op_private & OPpCONST_BARE))
6672 o->op_flags |= OPf_SPECIAL;
6673 kid->op_private &= ~OPpCONST_STRICT;
6680 Perl_ck_substr(pTHX_ OP *o)
6683 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6684 OP *kid = cLISTOPo->op_first;
6686 if (kid->op_type == OP_NULL)
6687 kid = kid->op_sibling;
6689 kid->op_flags |= OPf_MOD;
6695 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6698 Perl_peep(pTHX_ register OP *o)
6700 register OP* oldop = 0;
6703 if (!o || o->op_seq)
6707 SAVEVPTR(PL_curcop);
6708 for (; o; o = o->op_next) {
6714 switch (o->op_type) {
6718 PL_curcop = ((COP*)o); /* for warnings */
6719 o->op_seq = PL_op_seqmax++;
6723 if (cSVOPo->op_private & OPpCONST_STRICT)
6724 no_bareword_allowed(o);
6726 /* Relocate sv to the pad for thread safety.
6727 * Despite being a "constant", the SV is written to,
6728 * for reference counts, sv_upgrade() etc. */
6730 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6731 if (SvPADTMP(cSVOPo->op_sv)) {
6732 /* If op_sv is already a PADTMP then it is being used by
6733 * some pad, so make a copy. */
6734 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6735 SvREADONLY_on(PL_curpad[ix]);
6736 SvREFCNT_dec(cSVOPo->op_sv);
6739 SvREFCNT_dec(PL_curpad[ix]);
6740 SvPADTMP_on(cSVOPo->op_sv);
6741 PL_curpad[ix] = cSVOPo->op_sv;
6742 /* XXX I don't know how this isn't readonly already. */
6743 SvREADONLY_on(PL_curpad[ix]);
6745 cSVOPo->op_sv = Nullsv;
6749 o->op_seq = PL_op_seqmax++;
6753 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6754 if (o->op_next->op_private & OPpTARGET_MY) {
6755 if (o->op_flags & OPf_STACKED) /* chained concats */
6756 goto ignore_optimization;
6758 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6759 o->op_targ = o->op_next->op_targ;
6760 o->op_next->op_targ = 0;
6761 o->op_private |= OPpTARGET_MY;
6764 op_null(o->op_next);
6766 ignore_optimization:
6767 o->op_seq = PL_op_seqmax++;
6770 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6771 o->op_seq = PL_op_seqmax++;
6772 break; /* Scalar stub must produce undef. List stub is noop */
6776 if (o->op_targ == OP_NEXTSTATE
6777 || o->op_targ == OP_DBSTATE
6778 || o->op_targ == OP_SETSTATE)
6780 PL_curcop = ((COP*)o);
6787 if (oldop && o->op_next) {
6788 oldop->op_next = o->op_next;
6791 o->op_seq = PL_op_seqmax++;
6795 if (o->op_next->op_type == OP_RV2SV) {
6796 if (!(o->op_next->op_private & OPpDEREF)) {
6797 op_null(o->op_next);
6798 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6800 o->op_next = o->op_next->op_next;
6801 o->op_type = OP_GVSV;
6802 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6805 else if (o->op_next->op_type == OP_RV2AV) {
6806 OP* pop = o->op_next->op_next;
6808 if (pop->op_type == OP_CONST &&
6809 (PL_op = pop->op_next) &&
6810 pop->op_next->op_type == OP_AELEM &&
6811 !(pop->op_next->op_private &
6812 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6813 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6818 op_null(o->op_next);
6819 op_null(pop->op_next);
6821 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6822 o->op_next = pop->op_next->op_next;
6823 o->op_type = OP_AELEMFAST;
6824 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6825 o->op_private = (U8)i;
6830 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6832 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6833 /* XXX could check prototype here instead of just carping */
6834 SV *sv = sv_newmortal();
6835 gv_efullname3(sv, gv, Nullch);
6836 Perl_warner(aTHX_ WARN_PROTOTYPE,
6837 "%s() called too early to check prototype",
6842 o->op_seq = PL_op_seqmax++;
6853 o->op_seq = PL_op_seqmax++;
6854 while (cLOGOP->op_other->op_type == OP_NULL)
6855 cLOGOP->op_other = cLOGOP->op_other->op_next;
6856 peep(cLOGOP->op_other);
6861 o->op_seq = PL_op_seqmax++;
6862 while (cLOOP->op_redoop->op_type == OP_NULL)
6863 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6864 peep(cLOOP->op_redoop);
6865 while (cLOOP->op_nextop->op_type == OP_NULL)
6866 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6867 peep(cLOOP->op_nextop);
6868 while (cLOOP->op_lastop->op_type == OP_NULL)
6869 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6870 peep(cLOOP->op_lastop);
6876 o->op_seq = PL_op_seqmax++;
6877 while (cPMOP->op_pmreplstart &&
6878 cPMOP->op_pmreplstart->op_type == OP_NULL)
6879 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6880 peep(cPMOP->op_pmreplstart);
6884 o->op_seq = PL_op_seqmax++;
6885 if (ckWARN(WARN_SYNTAX) && o->op_next
6886 && o->op_next->op_type == OP_NEXTSTATE) {
6887 if (o->op_next->op_sibling &&
6888 o->op_next->op_sibling->op_type != OP_EXIT &&
6889 o->op_next->op_sibling->op_type != OP_WARN &&
6890 o->op_next->op_sibling->op_type != OP_DIE) {
6891 line_t oldline = CopLINE(PL_curcop);
6893 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6894 Perl_warner(aTHX_ WARN_EXEC,
6895 "Statement unlikely to be reached");
6896 Perl_warner(aTHX_ WARN_EXEC,
6897 "\t(Maybe you meant system() when you said exec()?)\n");
6898 CopLINE_set(PL_curcop, oldline);
6907 SV **svp, **indsvp, *sv;
6912 o->op_seq = PL_op_seqmax++;
6914 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6917 /* Make the CONST have a shared SV */
6918 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6919 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6920 key = SvPV(sv, keylen);
6923 lexname = newSVpvn_share(key, keylen, 0);
6928 if ((o->op_private & (OPpLVAL_INTRO)))
6931 rop = (UNOP*)((BINOP*)o)->op_first;
6932 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6934 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6935 if (!SvOBJECT(lexname))
6937 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6938 if (!fields || !GvHV(*fields))
6940 key = SvPV(*svp, keylen);
6943 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6945 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6946 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6948 ind = SvIV(*indsvp);
6950 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6951 rop->op_type = OP_RV2AV;
6952 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6953 o->op_type = OP_AELEM;
6954 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6956 if (SvREADONLY(*svp))
6958 SvFLAGS(sv) |= (SvFLAGS(*svp)
6959 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6969 SV **svp, **indsvp, *sv;
6973 SVOP *first_key_op, *key_op;
6975 o->op_seq = PL_op_seqmax++;
6976 if ((o->op_private & (OPpLVAL_INTRO))
6977 /* I bet there's always a pushmark... */
6978 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6979 /* hmmm, no optimization if list contains only one key. */
6981 rop = (UNOP*)((LISTOP*)o)->op_last;
6982 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6984 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6985 if (!SvOBJECT(lexname))
6987 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6988 if (!fields || !GvHV(*fields))
6990 /* Again guessing that the pushmark can be jumped over.... */
6991 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6992 ->op_first->op_sibling;
6993 /* Check that the key list contains only constants. */
6994 for (key_op = first_key_op; key_op;
6995 key_op = (SVOP*)key_op->op_sibling)
6996 if (key_op->op_type != OP_CONST)
7000 rop->op_type = OP_RV2AV;
7001 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7002 o->op_type = OP_ASLICE;
7003 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7004 for (key_op = first_key_op; key_op;
7005 key_op = (SVOP*)key_op->op_sibling) {
7006 svp = cSVOPx_svp(key_op);
7007 key = SvPV(*svp, keylen);
7010 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7012 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7013 "in variable %s of type %s",
7014 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7016 ind = SvIV(*indsvp);
7018 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7020 if (SvREADONLY(*svp))
7022 SvFLAGS(sv) |= (SvFLAGS(*svp)
7023 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7031 o->op_seq = PL_op_seqmax++;
7041 /* Efficient sub that returns a constant scalar value. */
7043 const_sv_xsub(pTHXo_ CV* cv)
7048 Perl_croak(aTHX_ "usage: %s::%s()",
7049 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7053 ST(0) = (SV*)XSANY.any_ptr;