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)
3198 if (id->op_type != OP_CONST)
3199 Perl_croak(aTHX_ "Module name must be constant");
3203 if (version != Nullop) {
3204 SV *vesv = ((SVOP*)version)->op_sv;
3206 if (arg == Nullop && !SvNIOKp(vesv)) {
3213 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3214 Perl_croak(aTHX_ "Version number must be constant number");
3216 /* Make copy of id so we don't free it twice */
3217 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3219 /* Fake up a method call to VERSION */
3220 meth = newSVpvn("VERSION",7);
3221 sv_upgrade(meth, SVt_PVIV);
3222 (void)SvIOK_on(meth);
3223 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3224 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3225 append_elem(OP_LIST,
3226 prepend_elem(OP_LIST, pack, list(version)),
3227 newSVOP(OP_METHOD_NAMED, 0, meth)));
3231 /* Fake up an import/unimport */
3232 if (arg && arg->op_type == OP_STUB)
3233 imop = arg; /* no import on explicit () */
3234 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3235 imop = Nullop; /* use 5.0; */
3240 /* Make copy of id so we don't free it twice */
3241 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3243 /* Fake up a method call to import/unimport */
3244 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3245 sv_upgrade(meth, SVt_PVIV);
3246 (void)SvIOK_on(meth);
3247 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3248 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3249 append_elem(OP_LIST,
3250 prepend_elem(OP_LIST, pack, list(arg)),
3251 newSVOP(OP_METHOD_NAMED, 0, meth)));
3254 /* Fake up the BEGIN {}, which does its thing immediately. */
3256 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3259 append_elem(OP_LINESEQ,
3260 append_elem(OP_LINESEQ,
3261 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3262 newSTATEOP(0, Nullch, veop)),
3263 newSTATEOP(0, Nullch, imop) ));
3265 PL_hints |= HINT_BLOCK_SCOPE;
3266 PL_copline = NOLINE;
3271 =for apidoc load_module
3273 Loads the module whose name is pointed to by the string part of name.
3274 Note that the actual module name, not its filename, should be given.
3275 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3276 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3277 (or 0 for no flags). ver, if specified, provides version semantics
3278 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3279 arguments can be used to specify arguments to the module's import()
3280 method, similar to C<use Foo::Bar VERSION LIST>.
3285 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3288 va_start(args, ver);
3289 vload_module(flags, name, ver, &args);
3293 #ifdef PERL_IMPLICIT_CONTEXT
3295 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3299 va_start(args, ver);
3300 vload_module(flags, name, ver, &args);
3306 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3308 OP *modname, *veop, *imop;
3310 modname = newSVOP(OP_CONST, 0, name);
3311 modname->op_private |= OPpCONST_BARE;
3313 veop = newSVOP(OP_CONST, 0, ver);
3317 if (flags & PERL_LOADMOD_NOIMPORT) {
3318 imop = sawparens(newNULLLIST());
3320 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3321 imop = va_arg(*args, OP*);
3326 sv = va_arg(*args, SV*);
3328 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3329 sv = va_arg(*args, SV*);
3333 line_t ocopline = PL_copline;
3334 int oexpect = PL_expect;
3336 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3337 veop, modname, imop);
3338 PL_expect = oexpect;
3339 PL_copline = ocopline;
3344 Perl_dofile(pTHX_ OP *term)
3349 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3350 if (!(gv && GvIMPORTED_CV(gv)))
3351 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3353 if (gv && GvIMPORTED_CV(gv)) {
3354 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3355 append_elem(OP_LIST, term,
3356 scalar(newUNOP(OP_RV2CV, 0,
3361 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3367 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3369 return newBINOP(OP_LSLICE, flags,
3370 list(force_list(subscript)),
3371 list(force_list(listval)) );
3375 S_list_assignment(pTHX_ register OP *o)
3380 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3381 o = cUNOPo->op_first;
3383 if (o->op_type == OP_COND_EXPR) {
3384 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3385 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3390 yyerror("Assignment to both a list and a scalar");
3394 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3395 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3396 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3399 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3402 if (o->op_type == OP_RV2SV)
3409 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3414 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3415 return newLOGOP(optype, 0,
3416 mod(scalar(left), optype),
3417 newUNOP(OP_SASSIGN, 0, scalar(right)));
3420 return newBINOP(optype, OPf_STACKED,
3421 mod(scalar(left), optype), scalar(right));
3425 if (list_assignment(left)) {
3429 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3430 left = mod(left, OP_AASSIGN);
3438 curop = list(force_list(left));
3439 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3440 o->op_private = 0 | (flags >> 8);
3441 for (curop = ((LISTOP*)curop)->op_first;
3442 curop; curop = curop->op_sibling)
3444 if (curop->op_type == OP_RV2HV &&
3445 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3446 o->op_private |= OPpASSIGN_HASH;
3450 if (!(left->op_private & OPpLVAL_INTRO)) {
3453 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3454 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3455 if (curop->op_type == OP_GV) {
3456 GV *gv = cGVOPx_gv(curop);
3457 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3459 SvCUR(gv) = PL_generation;
3461 else if (curop->op_type == OP_PADSV ||
3462 curop->op_type == OP_PADAV ||
3463 curop->op_type == OP_PADHV ||
3464 curop->op_type == OP_PADANY) {
3465 SV **svp = AvARRAY(PL_comppad_name);
3466 SV *sv = svp[curop->op_targ];
3467 if (SvCUR(sv) == PL_generation)
3469 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3471 else if (curop->op_type == OP_RV2CV)
3473 else if (curop->op_type == OP_RV2SV ||
3474 curop->op_type == OP_RV2AV ||
3475 curop->op_type == OP_RV2HV ||
3476 curop->op_type == OP_RV2GV) {
3477 if (lastop->op_type != OP_GV) /* funny deref? */
3480 else if (curop->op_type == OP_PUSHRE) {
3481 if (((PMOP*)curop)->op_pmreplroot) {
3483 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3485 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3487 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3489 SvCUR(gv) = PL_generation;
3498 o->op_private |= OPpASSIGN_COMMON;
3500 if (right && right->op_type == OP_SPLIT) {
3502 if ((tmpop = ((LISTOP*)right)->op_first) &&
3503 tmpop->op_type == OP_PUSHRE)
3505 PMOP *pm = (PMOP*)tmpop;
3506 if (left->op_type == OP_RV2AV &&
3507 !(left->op_private & OPpLVAL_INTRO) &&
3508 !(o->op_private & OPpASSIGN_COMMON) )
3510 tmpop = ((UNOP*)left)->op_first;
3511 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3513 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3514 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3516 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3517 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3519 pm->op_pmflags |= PMf_ONCE;
3520 tmpop = cUNOPo->op_first; /* to list (nulled) */
3521 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3522 tmpop->op_sibling = Nullop; /* don't free split */
3523 right->op_next = tmpop->op_next; /* fix starting loc */
3524 op_free(o); /* blow off assign */
3525 right->op_flags &= ~OPf_WANT;
3526 /* "I don't know and I don't care." */
3531 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3532 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3534 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3536 sv_setiv(sv, PL_modcount+1);
3544 right = newOP(OP_UNDEF, 0);
3545 if (right->op_type == OP_READLINE) {
3546 right->op_flags |= OPf_STACKED;
3547 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3550 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3551 o = newBINOP(OP_SASSIGN, flags,
3552 scalar(right), mod(scalar(left), OP_SASSIGN) );
3564 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3566 U32 seq = intro_my();
3569 NewOp(1101, cop, 1, COP);
3570 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3571 cop->op_type = OP_DBSTATE;
3572 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3575 cop->op_type = OP_NEXTSTATE;
3576 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3578 cop->op_flags = flags;
3579 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3581 cop->op_private |= NATIVE_HINTS;
3583 PL_compiling.op_private = cop->op_private;
3584 cop->op_next = (OP*)cop;
3587 cop->cop_label = label;
3588 PL_hints |= HINT_BLOCK_SCOPE;
3591 cop->cop_arybase = PL_curcop->cop_arybase;
3592 if (specialWARN(PL_curcop->cop_warnings))
3593 cop->cop_warnings = PL_curcop->cop_warnings ;
3595 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3596 if (specialCopIO(PL_curcop->cop_io))
3597 cop->cop_io = PL_curcop->cop_io;
3599 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3602 if (PL_copline == NOLINE)
3603 CopLINE_set(cop, CopLINE(PL_curcop));
3605 CopLINE_set(cop, PL_copline);
3606 PL_copline = NOLINE;
3609 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3611 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3613 CopSTASH_set(cop, PL_curstash);
3615 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3616 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3617 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3618 (void)SvIOK_on(*svp);
3619 SvIVX(*svp) = PTR2IV(cop);
3623 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3626 /* "Introduce" my variables to visible status. */
3634 if (! PL_min_intro_pending)
3635 return PL_cop_seqmax;
3637 svp = AvARRAY(PL_comppad_name);
3638 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3639 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3640 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3641 SvNVX(sv) = (NV)PL_cop_seqmax;
3644 PL_min_intro_pending = 0;
3645 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3646 return PL_cop_seqmax++;
3650 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3652 return new_logop(type, flags, &first, &other);
3656 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3660 OP *first = *firstp;
3661 OP *other = *otherp;
3663 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3664 return newBINOP(type, flags, scalar(first), scalar(other));
3666 scalarboolean(first);
3667 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3668 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3669 if (type == OP_AND || type == OP_OR) {
3675 first = *firstp = cUNOPo->op_first;
3677 first->op_next = o->op_next;
3678 cUNOPo->op_first = Nullop;
3682 if (first->op_type == OP_CONST) {
3683 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3684 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3685 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3696 else if (first->op_type == OP_WANTARRAY) {
3702 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3703 OP *k1 = ((UNOP*)first)->op_first;
3704 OP *k2 = k1->op_sibling;
3706 switch (first->op_type)
3709 if (k2 && k2->op_type == OP_READLINE
3710 && (k2->op_flags & OPf_STACKED)
3711 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3713 warnop = k2->op_type;
3718 if (k1->op_type == OP_READDIR
3719 || k1->op_type == OP_GLOB
3720 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3721 || k1->op_type == OP_EACH)
3723 warnop = ((k1->op_type == OP_NULL)
3724 ? k1->op_targ : k1->op_type);
3729 line_t oldline = CopLINE(PL_curcop);
3730 CopLINE_set(PL_curcop, PL_copline);
3731 Perl_warner(aTHX_ WARN_MISC,
3732 "Value of %s%s can be \"0\"; test with defined()",
3734 ((warnop == OP_READLINE || warnop == OP_GLOB)
3735 ? " construct" : "() operator"));
3736 CopLINE_set(PL_curcop, oldline);
3743 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3744 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3746 NewOp(1101, logop, 1, LOGOP);
3748 logop->op_type = type;
3749 logop->op_ppaddr = PL_ppaddr[type];
3750 logop->op_first = first;
3751 logop->op_flags = flags | OPf_KIDS;
3752 logop->op_other = LINKLIST(other);
3753 logop->op_private = 1 | (flags >> 8);
3755 /* establish postfix order */
3756 logop->op_next = LINKLIST(first);
3757 first->op_next = (OP*)logop;
3758 first->op_sibling = other;
3760 o = newUNOP(OP_NULL, 0, (OP*)logop);
3767 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3774 return newLOGOP(OP_AND, 0, first, trueop);
3776 return newLOGOP(OP_OR, 0, first, falseop);
3778 scalarboolean(first);
3779 if (first->op_type == OP_CONST) {
3780 if (SvTRUE(((SVOP*)first)->op_sv)) {
3791 else if (first->op_type == OP_WANTARRAY) {
3795 NewOp(1101, logop, 1, LOGOP);
3796 logop->op_type = OP_COND_EXPR;
3797 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3798 logop->op_first = first;
3799 logop->op_flags = flags | OPf_KIDS;
3800 logop->op_private = 1 | (flags >> 8);
3801 logop->op_other = LINKLIST(trueop);
3802 logop->op_next = LINKLIST(falseop);
3805 /* establish postfix order */
3806 start = LINKLIST(first);
3807 first->op_next = (OP*)logop;
3809 first->op_sibling = trueop;
3810 trueop->op_sibling = falseop;
3811 o = newUNOP(OP_NULL, 0, (OP*)logop);
3813 trueop->op_next = falseop->op_next = o;
3820 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3828 NewOp(1101, range, 1, LOGOP);
3830 range->op_type = OP_RANGE;
3831 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3832 range->op_first = left;
3833 range->op_flags = OPf_KIDS;
3834 leftstart = LINKLIST(left);
3835 range->op_other = LINKLIST(right);
3836 range->op_private = 1 | (flags >> 8);
3838 left->op_sibling = right;
3840 range->op_next = (OP*)range;
3841 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3842 flop = newUNOP(OP_FLOP, 0, flip);
3843 o = newUNOP(OP_NULL, 0, flop);
3845 range->op_next = leftstart;
3847 left->op_next = flip;
3848 right->op_next = flop;
3850 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3851 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3852 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3853 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3855 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3856 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3859 if (!flip->op_private || !flop->op_private)
3860 linklist(o); /* blow off optimizer unless constant */
3866 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3870 int once = block && block->op_flags & OPf_SPECIAL &&
3871 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3874 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3875 return block; /* do {} while 0 does once */
3876 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3877 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3878 expr = newUNOP(OP_DEFINED, 0,
3879 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3880 } else if (expr->op_flags & OPf_KIDS) {
3881 OP *k1 = ((UNOP*)expr)->op_first;
3882 OP *k2 = (k1) ? k1->op_sibling : NULL;
3883 switch (expr->op_type) {
3885 if (k2 && k2->op_type == OP_READLINE
3886 && (k2->op_flags & OPf_STACKED)
3887 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3888 expr = newUNOP(OP_DEFINED, 0, expr);
3892 if (k1->op_type == OP_READDIR
3893 || k1->op_type == OP_GLOB
3894 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3895 || k1->op_type == OP_EACH)
3896 expr = newUNOP(OP_DEFINED, 0, expr);
3902 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3903 o = new_logop(OP_AND, 0, &expr, &listop);
3906 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3908 if (once && o != listop)
3909 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3912 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3914 o->op_flags |= flags;
3916 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3921 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3930 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3931 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3932 expr = newUNOP(OP_DEFINED, 0,
3933 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3934 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3935 OP *k1 = ((UNOP*)expr)->op_first;
3936 OP *k2 = (k1) ? k1->op_sibling : NULL;
3937 switch (expr->op_type) {
3939 if (k2 && k2->op_type == OP_READLINE
3940 && (k2->op_flags & OPf_STACKED)
3941 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3942 expr = newUNOP(OP_DEFINED, 0, expr);
3946 if (k1->op_type == OP_READDIR
3947 || k1->op_type == OP_GLOB
3948 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3949 || k1->op_type == OP_EACH)
3950 expr = newUNOP(OP_DEFINED, 0, expr);
3956 block = newOP(OP_NULL, 0);
3958 block = scope(block);
3962 next = LINKLIST(cont);
3965 OP *unstack = newOP(OP_UNSTACK, 0);
3968 cont = append_elem(OP_LINESEQ, cont, unstack);
3969 if ((line_t)whileline != NOLINE) {
3970 PL_copline = whileline;
3971 cont = append_elem(OP_LINESEQ, cont,
3972 newSTATEOP(0, Nullch, Nullop));
3976 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3977 redo = LINKLIST(listop);
3980 PL_copline = whileline;
3982 o = new_logop(OP_AND, 0, &expr, &listop);
3983 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3984 op_free(expr); /* oops, it's a while (0) */
3986 return Nullop; /* listop already freed by new_logop */
3989 ((LISTOP*)listop)->op_last->op_next = condop =
3990 (o == listop ? redo : LINKLIST(o));
3996 NewOp(1101,loop,1,LOOP);
3997 loop->op_type = OP_ENTERLOOP;
3998 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3999 loop->op_private = 0;
4000 loop->op_next = (OP*)loop;
4003 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4005 loop->op_redoop = redo;
4006 loop->op_lastop = o;
4007 o->op_private |= loopflags;
4010 loop->op_nextop = next;
4012 loop->op_nextop = o;
4014 o->op_flags |= flags;
4015 o->op_private |= (flags >> 8);
4020 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4028 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4029 sv->op_type = OP_RV2GV;
4030 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4032 else if (sv->op_type == OP_PADSV) { /* private variable */
4033 padoff = sv->op_targ;
4038 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4039 padoff = sv->op_targ;
4041 iterflags |= OPf_SPECIAL;
4046 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4050 padoff = find_threadsv("_");
4051 iterflags |= OPf_SPECIAL;
4053 sv = newGVOP(OP_GV, 0, PL_defgv);
4056 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4057 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4058 iterflags |= OPf_STACKED;
4060 else if (expr->op_type == OP_NULL &&
4061 (expr->op_flags & OPf_KIDS) &&
4062 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4064 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4065 * set the STACKED flag to indicate that these values are to be
4066 * treated as min/max values by 'pp_iterinit'.
4068 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4069 LOGOP* range = (LOGOP*) flip->op_first;
4070 OP* left = range->op_first;
4071 OP* right = left->op_sibling;
4074 range->op_flags &= ~OPf_KIDS;
4075 range->op_first = Nullop;
4077 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4078 listop->op_first->op_next = range->op_next;
4079 left->op_next = range->op_other;
4080 right->op_next = (OP*)listop;
4081 listop->op_next = listop->op_first;
4084 expr = (OP*)(listop);
4086 iterflags |= OPf_STACKED;
4089 expr = mod(force_list(expr), OP_GREPSTART);
4093 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4094 append_elem(OP_LIST, expr, scalar(sv))));
4095 assert(!loop->op_next);
4096 #ifdef PL_OP_SLAB_ALLOC
4099 NewOp(1234,tmp,1,LOOP);
4100 Copy(loop,tmp,1,LOOP);
4104 Renew(loop, 1, LOOP);
4106 loop->op_targ = padoff;
4107 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4108 PL_copline = forline;
4109 return newSTATEOP(0, label, wop);
4113 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4118 if (type != OP_GOTO || label->op_type == OP_CONST) {
4119 /* "last()" means "last" */
4120 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4121 o = newOP(type, OPf_SPECIAL);
4123 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4124 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4130 if (label->op_type == OP_ENTERSUB)
4131 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4132 o = newUNOP(type, OPf_STACKED, label);
4134 PL_hints |= HINT_BLOCK_SCOPE;
4139 Perl_cv_undef(pTHX_ CV *cv)
4143 MUTEX_DESTROY(CvMUTEXP(cv));
4144 Safefree(CvMUTEXP(cv));
4147 #endif /* USE_THREADS */
4149 if (!CvXSUB(cv) && CvROOT(cv)) {
4151 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4152 Perl_croak(aTHX_ "Can't undef active subroutine");
4155 Perl_croak(aTHX_ "Can't undef active subroutine");
4156 #endif /* USE_THREADS */
4159 SAVEVPTR(PL_curpad);
4162 op_free(CvROOT(cv));
4163 CvROOT(cv) = Nullop;
4166 SvPOK_off((SV*)cv); /* forget prototype */
4168 /* Since closure prototypes have the same lifetime as the containing
4169 * CV, they don't hold a refcount on the outside CV. This avoids
4170 * the refcount loop between the outer CV (which keeps a refcount to
4171 * the closure prototype in the pad entry for pp_anoncode()) and the
4172 * closure prototype, and the ensuing memory leak. --GSAR */
4173 if (!CvANON(cv) || CvCLONED(cv))
4174 SvREFCNT_dec(CvOUTSIDE(cv));
4175 CvOUTSIDE(cv) = Nullcv;
4177 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4180 if (CvPADLIST(cv)) {
4181 /* may be during global destruction */
4182 if (SvREFCNT(CvPADLIST(cv))) {
4183 I32 i = AvFILLp(CvPADLIST(cv));
4185 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4186 SV* sv = svp ? *svp : Nullsv;
4189 if (sv == (SV*)PL_comppad_name)
4190 PL_comppad_name = Nullav;
4191 else if (sv == (SV*)PL_comppad) {
4192 PL_comppad = Nullav;
4193 PL_curpad = Null(SV**);
4197 SvREFCNT_dec((SV*)CvPADLIST(cv));
4199 CvPADLIST(cv) = Nullav;
4207 #ifdef DEBUG_CLOSURES
4209 S_cv_dump(pTHX_ CV *cv)
4212 CV *outside = CvOUTSIDE(cv);
4213 AV* padlist = CvPADLIST(cv);
4220 PerlIO_printf(Perl_debug_log,
4221 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4223 (CvANON(cv) ? "ANON"
4224 : (cv == PL_main_cv) ? "MAIN"
4225 : CvUNIQUE(cv) ? "UNIQUE"
4226 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4229 : CvANON(outside) ? "ANON"
4230 : (outside == PL_main_cv) ? "MAIN"
4231 : CvUNIQUE(outside) ? "UNIQUE"
4232 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4237 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4238 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4239 pname = AvARRAY(pad_name);
4240 ppad = AvARRAY(pad);
4242 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4243 if (SvPOK(pname[ix]))
4244 PerlIO_printf(Perl_debug_log,
4245 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4246 (int)ix, PTR2UV(ppad[ix]),
4247 SvFAKE(pname[ix]) ? "FAKE " : "",
4249 (IV)I_32(SvNVX(pname[ix])),
4252 #endif /* DEBUGGING */
4254 #endif /* DEBUG_CLOSURES */
4257 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4261 AV* protopadlist = CvPADLIST(proto);
4262 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4263 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4264 SV** pname = AvARRAY(protopad_name);
4265 SV** ppad = AvARRAY(protopad);
4266 I32 fname = AvFILLp(protopad_name);
4267 I32 fpad = AvFILLp(protopad);
4271 assert(!CvUNIQUE(proto));
4275 SAVESPTR(PL_comppad_name);
4276 SAVESPTR(PL_compcv);
4278 cv = PL_compcv = (CV*)NEWSV(1104,0);
4279 sv_upgrade((SV *)cv, SvTYPE(proto));
4280 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4284 New(666, CvMUTEXP(cv), 1, perl_mutex);
4285 MUTEX_INIT(CvMUTEXP(cv));
4287 #endif /* USE_THREADS */
4288 CvFILE(cv) = CvFILE(proto);
4289 CvGV(cv) = CvGV(proto);
4290 CvSTASH(cv) = CvSTASH(proto);
4291 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4292 CvSTART(cv) = CvSTART(proto);
4294 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4297 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4299 PL_comppad_name = newAV();
4300 for (ix = fname; ix >= 0; ix--)
4301 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4303 PL_comppad = newAV();
4305 comppadlist = newAV();
4306 AvREAL_off(comppadlist);
4307 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4308 av_store(comppadlist, 1, (SV*)PL_comppad);
4309 CvPADLIST(cv) = comppadlist;
4310 av_fill(PL_comppad, AvFILLp(protopad));
4311 PL_curpad = AvARRAY(PL_comppad);
4313 av = newAV(); /* will be @_ */
4315 av_store(PL_comppad, 0, (SV*)av);
4316 AvFLAGS(av) = AVf_REIFY;
4318 for (ix = fpad; ix > 0; ix--) {
4319 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4320 if (namesv && namesv != &PL_sv_undef) {
4321 char *name = SvPVX(namesv); /* XXX */
4322 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4323 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4324 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4326 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4328 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4330 else { /* our own lexical */
4333 /* anon code -- we'll come back for it */
4334 sv = SvREFCNT_inc(ppad[ix]);
4336 else if (*name == '@')
4338 else if (*name == '%')
4347 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4348 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4351 SV* sv = NEWSV(0,0);
4357 /* Now that vars are all in place, clone nested closures. */
4359 for (ix = fpad; ix > 0; ix--) {
4360 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4362 && namesv != &PL_sv_undef
4363 && !(SvFLAGS(namesv) & SVf_FAKE)
4364 && *SvPVX(namesv) == '&'
4365 && CvCLONE(ppad[ix]))
4367 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4368 SvREFCNT_dec(ppad[ix]);
4371 PL_curpad[ix] = (SV*)kid;
4375 #ifdef DEBUG_CLOSURES
4376 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4378 PerlIO_printf(Perl_debug_log, " from:\n");
4380 PerlIO_printf(Perl_debug_log, " to:\n");
4387 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4389 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4391 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4398 Perl_cv_clone(pTHX_ CV *proto)
4401 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4402 cv = cv_clone2(proto, CvOUTSIDE(proto));
4403 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4408 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4410 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4411 SV* msg = sv_newmortal();
4415 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4416 sv_setpv(msg, "Prototype mismatch:");
4418 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4420 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4421 sv_catpv(msg, " vs ");
4423 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4425 sv_catpv(msg, "none");
4426 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4430 static void const_sv_xsub(pTHXo_ CV* cv);
4433 =for apidoc cv_const_sv
4435 If C<cv> is a constant sub eligible for inlining. returns the constant
4436 value returned by the sub. Otherwise, returns NULL.
4438 Constant subs can be created with C<newCONSTSUB> or as described in
4439 L<perlsub/"Constant Functions">.
4444 Perl_cv_const_sv(pTHX_ CV *cv)
4446 if (!cv || !CvCONST(cv))
4448 return (SV*)CvXSUBANY(cv).any_ptr;
4452 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4459 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4460 o = cLISTOPo->op_first->op_sibling;
4462 for (; o; o = o->op_next) {
4463 OPCODE type = o->op_type;
4465 if (sv && o->op_next == o)
4467 if (o->op_next != o) {
4468 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4470 if (type == OP_DBSTATE)
4473 if (type == OP_LEAVESUB || type == OP_RETURN)
4477 if (type == OP_CONST && cSVOPo->op_sv)
4479 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4480 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4481 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4485 /* We get here only from cv_clone2() while creating a closure.
4486 Copy the const value here instead of in cv_clone2 so that
4487 SvREADONLY_on doesn't lead to problems when leaving
4492 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4504 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4514 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4518 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4520 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4524 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4530 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4535 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4536 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4537 SV *sv = sv_newmortal();
4538 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4539 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4544 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4545 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4555 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4556 maximum a prototype before. */
4557 if (SvTYPE(gv) > SVt_NULL) {
4558 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4559 && ckWARN_d(WARN_PROTOTYPE))
4561 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4563 cv_ckproto((CV*)gv, NULL, ps);
4566 sv_setpv((SV*)gv, ps);
4568 sv_setiv((SV*)gv, -1);
4569 SvREFCNT_dec(PL_compcv);
4570 cv = PL_compcv = NULL;
4571 PL_sub_generation++;
4575 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4577 #ifdef GV_SHARED_CHECK
4578 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4579 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4583 if (!block || !ps || *ps || attrs)
4586 const_sv = op_const_sv(block, Nullcv);
4589 bool exists = CvROOT(cv) || CvXSUB(cv);
4591 #ifdef GV_SHARED_CHECK
4592 if (exists && GvSHARED(gv)) {
4593 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4597 /* if the subroutine doesn't exist and wasn't pre-declared
4598 * with a prototype, assume it will be AUTOLOADed,
4599 * skipping the prototype check
4601 if (exists || SvPOK(cv))
4602 cv_ckproto(cv, gv, ps);
4603 /* already defined (or promised)? */
4604 if (exists || GvASSUMECV(gv)) {
4605 if (!block && !attrs) {
4606 /* just a "sub foo;" when &foo is already defined */
4607 SAVEFREESV(PL_compcv);
4610 /* ahem, death to those who redefine active sort subs */
4611 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4612 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4614 if (ckWARN(WARN_REDEFINE)
4616 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4618 line_t oldline = CopLINE(PL_curcop);
4619 CopLINE_set(PL_curcop, PL_copline);
4620 Perl_warner(aTHX_ WARN_REDEFINE,
4621 CvCONST(cv) ? "Constant subroutine %s redefined"
4622 : "Subroutine %s redefined", name);
4623 CopLINE_set(PL_curcop, oldline);
4631 SvREFCNT_inc(const_sv);
4633 assert(!CvROOT(cv) && !CvCONST(cv));
4634 sv_setpv((SV*)cv, ""); /* prototype is "" */
4635 CvXSUBANY(cv).any_ptr = const_sv;
4636 CvXSUB(cv) = const_sv_xsub;
4641 cv = newCONSTSUB(NULL, name, const_sv);
4644 SvREFCNT_dec(PL_compcv);
4646 PL_sub_generation++;
4653 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4654 * before we clobber PL_compcv.
4658 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4659 stash = GvSTASH(CvGV(cv));
4660 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4661 stash = CvSTASH(cv);
4663 stash = PL_curstash;
4666 /* possibly about to re-define existing subr -- ignore old cv */
4667 rcv = (SV*)PL_compcv;
4668 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4669 stash = GvSTASH(gv);
4671 stash = PL_curstash;
4673 apply_attrs(stash, rcv, attrs);
4675 if (cv) { /* must reuse cv if autoloaded */
4677 /* got here with just attrs -- work done, so bug out */
4678 SAVEFREESV(PL_compcv);
4682 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4683 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4684 CvOUTSIDE(PL_compcv) = 0;
4685 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4686 CvPADLIST(PL_compcv) = 0;
4687 /* inner references to PL_compcv must be fixed up ... */
4689 AV *padlist = CvPADLIST(cv);
4690 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4691 AV *comppad = (AV*)AvARRAY(padlist)[1];
4692 SV **namepad = AvARRAY(comppad_name);
4693 SV **curpad = AvARRAY(comppad);
4694 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4695 SV *namesv = namepad[ix];
4696 if (namesv && namesv != &PL_sv_undef
4697 && *SvPVX(namesv) == '&')
4699 CV *innercv = (CV*)curpad[ix];
4700 if (CvOUTSIDE(innercv) == PL_compcv) {
4701 CvOUTSIDE(innercv) = cv;
4702 if (!CvANON(innercv) || CvCLONED(innercv)) {
4703 (void)SvREFCNT_inc(cv);
4704 SvREFCNT_dec(PL_compcv);
4710 /* ... before we throw it away */
4711 SvREFCNT_dec(PL_compcv);
4718 PL_sub_generation++;
4722 CvFILE(cv) = CopFILE(PL_curcop);
4723 CvSTASH(cv) = PL_curstash;
4726 if (!CvMUTEXP(cv)) {
4727 New(666, CvMUTEXP(cv), 1, perl_mutex);
4728 MUTEX_INIT(CvMUTEXP(cv));
4730 #endif /* USE_THREADS */
4733 sv_setpv((SV*)cv, ps);
4735 if (PL_error_count) {
4739 char *s = strrchr(name, ':');
4741 if (strEQ(s, "BEGIN")) {
4743 "BEGIN not safe after errors--compilation aborted";
4744 if (PL_in_eval & EVAL_KEEPERR)
4745 Perl_croak(aTHX_ not_safe);
4747 /* force display of errors found but not reported */
4748 sv_catpv(ERRSV, not_safe);
4749 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4757 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4758 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4761 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4762 mod(scalarseq(block), OP_LEAVESUBLV));
4765 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4767 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4768 OpREFCNT_set(CvROOT(cv), 1);
4769 CvSTART(cv) = LINKLIST(CvROOT(cv));
4770 CvROOT(cv)->op_next = 0;
4773 /* now that optimizer has done its work, adjust pad values */
4775 SV **namep = AvARRAY(PL_comppad_name);
4776 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4779 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4782 * The only things that a clonable function needs in its
4783 * pad are references to outer lexicals and anonymous subs.
4784 * The rest are created anew during cloning.
4786 if (!((namesv = namep[ix]) != Nullsv &&
4787 namesv != &PL_sv_undef &&
4789 *SvPVX(namesv) == '&')))
4791 SvREFCNT_dec(PL_curpad[ix]);
4792 PL_curpad[ix] = Nullsv;
4795 assert(!CvCONST(cv));
4796 if (ps && !*ps && op_const_sv(block, cv))
4800 AV *av = newAV(); /* Will be @_ */
4802 av_store(PL_comppad, 0, (SV*)av);
4803 AvFLAGS(av) = AVf_REIFY;
4805 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4806 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4808 if (!SvPADMY(PL_curpad[ix]))
4809 SvPADTMP_on(PL_curpad[ix]);
4813 /* If a potential closure prototype, don't keep a refcount on outer CV.
4814 * This is okay as the lifetime of the prototype is tied to the
4815 * lifetime of the outer CV. Avoids memory leak due to reference
4818 SvREFCNT_dec(CvOUTSIDE(cv));
4820 if (name || aname) {
4822 char *tname = (name ? name : aname);
4824 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4825 SV *sv = NEWSV(0,0);
4826 SV *tmpstr = sv_newmortal();
4827 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4831 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4833 (long)PL_subline, (long)CopLINE(PL_curcop));
4834 gv_efullname3(tmpstr, gv, Nullch);
4835 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4836 hv = GvHVn(db_postponed);
4837 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4838 && (pcv = GvCV(db_postponed)))
4844 call_sv((SV*)pcv, G_DISCARD);
4848 if ((s = strrchr(tname,':')))
4853 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4856 if (strEQ(s, "BEGIN")) {
4857 I32 oldscope = PL_scopestack_ix;
4859 SAVECOPFILE(&PL_compiling);
4860 SAVECOPLINE(&PL_compiling);
4862 sv_setsv(PL_rs, PL_nrs);
4865 PL_beginav = newAV();
4866 DEBUG_x( dump_sub(gv) );
4867 av_push(PL_beginav, (SV*)cv);
4868 GvCV(gv) = 0; /* cv has been hijacked */
4869 call_list(oldscope, PL_beginav);
4871 PL_curcop = &PL_compiling;
4872 PL_compiling.op_private = PL_hints;
4875 else if (strEQ(s, "END") && !PL_error_count) {
4878 DEBUG_x( dump_sub(gv) );
4879 av_unshift(PL_endav, 1);
4880 av_store(PL_endav, 0, (SV*)cv);
4881 GvCV(gv) = 0; /* cv has been hijacked */
4883 else if (strEQ(s, "CHECK") && !PL_error_count) {
4885 PL_checkav = newAV();
4886 DEBUG_x( dump_sub(gv) );
4887 if (PL_main_start && ckWARN(WARN_VOID))
4888 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4889 av_unshift(PL_checkav, 1);
4890 av_store(PL_checkav, 0, (SV*)cv);
4891 GvCV(gv) = 0; /* cv has been hijacked */
4893 else if (strEQ(s, "INIT") && !PL_error_count) {
4895 PL_initav = newAV();
4896 DEBUG_x( dump_sub(gv) );
4897 if (PL_main_start && ckWARN(WARN_VOID))
4898 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4899 av_push(PL_initav, (SV*)cv);
4900 GvCV(gv) = 0; /* cv has been hijacked */
4905 PL_copline = NOLINE;
4910 /* XXX unsafe for threads if eval_owner isn't held */
4912 =for apidoc newCONSTSUB
4914 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4915 eligible for inlining at compile-time.
4921 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4927 SAVECOPLINE(PL_curcop);
4928 CopLINE_set(PL_curcop, PL_copline);
4931 PL_hints &= ~HINT_BLOCK_SCOPE;
4934 SAVESPTR(PL_curstash);
4935 SAVECOPSTASH(PL_curcop);
4936 PL_curstash = stash;
4938 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4940 CopSTASH(PL_curcop) = stash;
4944 cv = newXS(name, const_sv_xsub, __FILE__);
4945 CvXSUBANY(cv).any_ptr = sv;
4947 sv_setpv((SV*)cv, ""); /* prototype is "" */
4955 =for apidoc U||newXS
4957 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4963 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4965 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4968 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4970 /* just a cached method */
4974 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4975 /* already defined (or promised) */
4976 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4977 && HvNAME(GvSTASH(CvGV(cv)))
4978 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4979 line_t oldline = CopLINE(PL_curcop);
4980 if (PL_copline != NOLINE)
4981 CopLINE_set(PL_curcop, PL_copline);
4982 Perl_warner(aTHX_ WARN_REDEFINE,
4983 CvCONST(cv) ? "Constant subroutine %s redefined"
4984 : "Subroutine %s redefined"
4986 CopLINE_set(PL_curcop, oldline);
4993 if (cv) /* must reuse cv if autoloaded */
4996 cv = (CV*)NEWSV(1105,0);
4997 sv_upgrade((SV *)cv, SVt_PVCV);
5001 PL_sub_generation++;
5006 New(666, CvMUTEXP(cv), 1, perl_mutex);
5007 MUTEX_INIT(CvMUTEXP(cv));
5009 #endif /* USE_THREADS */
5010 (void)gv_fetchfile(filename);
5011 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5012 an external constant string */
5013 CvXSUB(cv) = subaddr;
5016 char *s = strrchr(name,':');
5022 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5025 if (strEQ(s, "BEGIN")) {
5027 PL_beginav = newAV();
5028 av_push(PL_beginav, (SV*)cv);
5029 GvCV(gv) = 0; /* cv has been hijacked */
5031 else if (strEQ(s, "END")) {
5034 av_unshift(PL_endav, 1);
5035 av_store(PL_endav, 0, (SV*)cv);
5036 GvCV(gv) = 0; /* cv has been hijacked */
5038 else if (strEQ(s, "CHECK")) {
5040 PL_checkav = newAV();
5041 if (PL_main_start && ckWARN(WARN_VOID))
5042 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5043 av_unshift(PL_checkav, 1);
5044 av_store(PL_checkav, 0, (SV*)cv);
5045 GvCV(gv) = 0; /* cv has been hijacked */
5047 else if (strEQ(s, "INIT")) {
5049 PL_initav = newAV();
5050 if (PL_main_start && ckWARN(WARN_VOID))
5051 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5052 av_push(PL_initav, (SV*)cv);
5053 GvCV(gv) = 0; /* cv has been hijacked */
5064 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5073 name = SvPVx(cSVOPo->op_sv, n_a);
5076 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5077 #ifdef GV_SHARED_CHECK
5079 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5083 if ((cv = GvFORM(gv))) {
5084 if (ckWARN(WARN_REDEFINE)) {
5085 line_t oldline = CopLINE(PL_curcop);
5087 CopLINE_set(PL_curcop, PL_copline);
5088 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5089 CopLINE_set(PL_curcop, oldline);
5096 CvFILE(cv) = CopFILE(PL_curcop);
5098 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5099 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5100 SvPADTMP_on(PL_curpad[ix]);
5103 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5104 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5105 OpREFCNT_set(CvROOT(cv), 1);
5106 CvSTART(cv) = LINKLIST(CvROOT(cv));
5107 CvROOT(cv)->op_next = 0;
5110 PL_copline = NOLINE;
5115 Perl_newANONLIST(pTHX_ OP *o)
5117 return newUNOP(OP_REFGEN, 0,
5118 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5122 Perl_newANONHASH(pTHX_ OP *o)
5124 return newUNOP(OP_REFGEN, 0,
5125 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5129 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5131 return newANONATTRSUB(floor, proto, Nullop, block);
5135 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5137 return newUNOP(OP_REFGEN, 0,
5138 newSVOP(OP_ANONCODE, 0,
5139 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5143 Perl_oopsAV(pTHX_ OP *o)
5145 switch (o->op_type) {
5147 o->op_type = OP_PADAV;
5148 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5149 return ref(o, OP_RV2AV);
5152 o->op_type = OP_RV2AV;
5153 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5158 if (ckWARN_d(WARN_INTERNAL))
5159 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5166 Perl_oopsHV(pTHX_ OP *o)
5168 switch (o->op_type) {
5171 o->op_type = OP_PADHV;
5172 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5173 return ref(o, OP_RV2HV);
5177 o->op_type = OP_RV2HV;
5178 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5183 if (ckWARN_d(WARN_INTERNAL))
5184 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5191 Perl_newAVREF(pTHX_ OP *o)
5193 if (o->op_type == OP_PADANY) {
5194 o->op_type = OP_PADAV;
5195 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5198 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5199 && ckWARN(WARN_DEPRECATED)) {
5200 Perl_warner(aTHX_ WARN_DEPRECATED,
5201 "Using an array as a reference is deprecated");
5203 return newUNOP(OP_RV2AV, 0, scalar(o));
5207 Perl_newGVREF(pTHX_ I32 type, OP *o)
5209 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5210 return newUNOP(OP_NULL, 0, o);
5211 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5215 Perl_newHVREF(pTHX_ OP *o)
5217 if (o->op_type == OP_PADANY) {
5218 o->op_type = OP_PADHV;
5219 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5222 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5223 && ckWARN(WARN_DEPRECATED)) {
5224 Perl_warner(aTHX_ WARN_DEPRECATED,
5225 "Using a hash as a reference is deprecated");
5227 return newUNOP(OP_RV2HV, 0, scalar(o));
5231 Perl_oopsCV(pTHX_ OP *o)
5233 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5239 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5241 return newUNOP(OP_RV2CV, flags, scalar(o));
5245 Perl_newSVREF(pTHX_ OP *o)
5247 if (o->op_type == OP_PADANY) {
5248 o->op_type = OP_PADSV;
5249 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5252 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5253 o->op_flags |= OPpDONE_SVREF;
5256 return newUNOP(OP_RV2SV, 0, scalar(o));
5259 /* Check routines. */
5262 Perl_ck_anoncode(pTHX_ OP *o)
5267 name = NEWSV(1106,0);
5268 sv_upgrade(name, SVt_PVNV);
5269 sv_setpvn(name, "&", 1);
5272 ix = pad_alloc(o->op_type, SVs_PADMY);
5273 av_store(PL_comppad_name, ix, name);
5274 av_store(PL_comppad, ix, cSVOPo->op_sv);
5275 SvPADMY_on(cSVOPo->op_sv);
5276 cSVOPo->op_sv = Nullsv;
5277 cSVOPo->op_targ = ix;
5282 Perl_ck_bitop(pTHX_ OP *o)
5284 o->op_private = PL_hints;
5289 Perl_ck_concat(pTHX_ OP *o)
5291 if (cUNOPo->op_first->op_type == OP_CONCAT)
5292 o->op_flags |= OPf_STACKED;
5297 Perl_ck_spair(pTHX_ OP *o)
5299 if (o->op_flags & OPf_KIDS) {
5302 OPCODE type = o->op_type;
5303 o = modkids(ck_fun(o), type);
5304 kid = cUNOPo->op_first;
5305 newop = kUNOP->op_first->op_sibling;
5307 (newop->op_sibling ||
5308 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5309 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5310 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5314 op_free(kUNOP->op_first);
5315 kUNOP->op_first = newop;
5317 o->op_ppaddr = PL_ppaddr[++o->op_type];
5322 Perl_ck_delete(pTHX_ OP *o)
5326 if (o->op_flags & OPf_KIDS) {
5327 OP *kid = cUNOPo->op_first;
5328 switch (kid->op_type) {
5330 o->op_flags |= OPf_SPECIAL;
5333 o->op_private |= OPpSLICE;
5336 o->op_flags |= OPf_SPECIAL;
5341 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5342 PL_op_desc[o->op_type]);
5350 Perl_ck_eof(pTHX_ OP *o)
5352 I32 type = o->op_type;
5354 if (o->op_flags & OPf_KIDS) {
5355 if (cLISTOPo->op_first->op_type == OP_STUB) {
5357 o = newUNOP(type, OPf_SPECIAL,
5358 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5366 Perl_ck_eval(pTHX_ OP *o)
5368 PL_hints |= HINT_BLOCK_SCOPE;
5369 if (o->op_flags & OPf_KIDS) {
5370 SVOP *kid = (SVOP*)cUNOPo->op_first;
5373 o->op_flags &= ~OPf_KIDS;
5376 else if (kid->op_type == OP_LINESEQ) {
5379 kid->op_next = o->op_next;
5380 cUNOPo->op_first = 0;
5383 NewOp(1101, enter, 1, LOGOP);
5384 enter->op_type = OP_ENTERTRY;
5385 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5386 enter->op_private = 0;
5388 /* establish postfix order */
5389 enter->op_next = (OP*)enter;
5391 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5392 o->op_type = OP_LEAVETRY;
5393 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5394 enter->op_other = o;
5402 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5404 o->op_targ = (PADOFFSET)PL_hints;
5409 Perl_ck_exit(pTHX_ OP *o)
5412 HV *table = GvHV(PL_hintgv);
5414 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5415 if (svp && *svp && SvTRUE(*svp))
5416 o->op_private |= OPpEXIT_VMSISH;
5423 Perl_ck_exec(pTHX_ OP *o)
5426 if (o->op_flags & OPf_STACKED) {
5428 kid = cUNOPo->op_first->op_sibling;
5429 if (kid->op_type == OP_RV2GV)
5438 Perl_ck_exists(pTHX_ OP *o)
5441 if (o->op_flags & OPf_KIDS) {
5442 OP *kid = cUNOPo->op_first;
5443 if (kid->op_type == OP_ENTERSUB) {
5444 (void) ref(kid, o->op_type);
5445 if (kid->op_type != OP_RV2CV && !PL_error_count)
5446 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5447 PL_op_desc[o->op_type]);
5448 o->op_private |= OPpEXISTS_SUB;
5450 else if (kid->op_type == OP_AELEM)
5451 o->op_flags |= OPf_SPECIAL;
5452 else if (kid->op_type != OP_HELEM)
5453 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5454 PL_op_desc[o->op_type]);
5462 Perl_ck_gvconst(pTHX_ register OP *o)
5464 o = fold_constants(o);
5465 if (o->op_type == OP_CONST)
5472 Perl_ck_rvconst(pTHX_ register OP *o)
5474 SVOP *kid = (SVOP*)cUNOPo->op_first;
5476 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5477 if (kid->op_type == OP_CONST) {
5481 SV *kidsv = kid->op_sv;
5484 /* Is it a constant from cv_const_sv()? */
5485 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5486 SV *rsv = SvRV(kidsv);
5487 int svtype = SvTYPE(rsv);
5488 char *badtype = Nullch;
5490 switch (o->op_type) {
5492 if (svtype > SVt_PVMG)
5493 badtype = "a SCALAR";
5496 if (svtype != SVt_PVAV)
5497 badtype = "an ARRAY";
5500 if (svtype != SVt_PVHV) {
5501 if (svtype == SVt_PVAV) { /* pseudohash? */
5502 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5503 if (ksv && SvROK(*ksv)
5504 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5513 if (svtype != SVt_PVCV)
5518 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5521 name = SvPV(kidsv, n_a);
5522 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5523 char *badthing = Nullch;
5524 switch (o->op_type) {
5526 badthing = "a SCALAR";
5529 badthing = "an ARRAY";
5532 badthing = "a HASH";
5537 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5541 * This is a little tricky. We only want to add the symbol if we
5542 * didn't add it in the lexer. Otherwise we get duplicate strict
5543 * warnings. But if we didn't add it in the lexer, we must at
5544 * least pretend like we wanted to add it even if it existed before,
5545 * or we get possible typo warnings. OPpCONST_ENTERED says
5546 * whether the lexer already added THIS instance of this symbol.
5548 iscv = (o->op_type == OP_RV2CV) * 2;
5550 gv = gv_fetchpv(name,
5551 iscv | !(kid->op_private & OPpCONST_ENTERED),
5554 : o->op_type == OP_RV2SV
5556 : o->op_type == OP_RV2AV
5558 : o->op_type == OP_RV2HV
5561 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5563 kid->op_type = OP_GV;
5564 SvREFCNT_dec(kid->op_sv);
5566 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5567 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5568 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5570 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5572 kid->op_sv = SvREFCNT_inc(gv);
5574 kid->op_private = 0;
5575 kid->op_ppaddr = PL_ppaddr[OP_GV];
5582 Perl_ck_ftst(pTHX_ OP *o)
5584 I32 type = o->op_type;
5586 if (o->op_flags & OPf_REF) {
5589 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5590 SVOP *kid = (SVOP*)cUNOPo->op_first;
5592 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5594 OP *newop = newGVOP(type, OPf_REF,
5595 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5602 if (type == OP_FTTTY)
5603 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5606 o = newUNOP(type, 0, newDEFSVOP());
5609 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5611 if (PL_hints & HINT_LOCALE)
5612 o->op_private |= OPpLOCALE;
5619 Perl_ck_fun(pTHX_ OP *o)
5625 int type = o->op_type;
5626 register I32 oa = PL_opargs[type] >> OASHIFT;
5628 if (o->op_flags & OPf_STACKED) {
5629 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5632 return no_fh_allowed(o);
5635 if (o->op_flags & OPf_KIDS) {
5637 tokid = &cLISTOPo->op_first;
5638 kid = cLISTOPo->op_first;
5639 if (kid->op_type == OP_PUSHMARK ||
5640 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5642 tokid = &kid->op_sibling;
5643 kid = kid->op_sibling;
5645 if (!kid && PL_opargs[type] & OA_DEFGV)
5646 *tokid = kid = newDEFSVOP();
5650 sibl = kid->op_sibling;
5653 /* list seen where single (scalar) arg expected? */
5654 if (numargs == 1 && !(oa >> 4)
5655 && kid->op_type == OP_LIST && type != OP_SCALAR)
5657 return too_many_arguments(o,PL_op_desc[type]);
5670 if ((type == OP_PUSH || type == OP_UNSHIFT)
5671 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5672 Perl_warner(aTHX_ WARN_SYNTAX,
5673 "Useless use of %s with no values",
5676 if (kid->op_type == OP_CONST &&
5677 (kid->op_private & OPpCONST_BARE))
5679 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5680 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5681 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5682 if (ckWARN(WARN_DEPRECATED))
5683 Perl_warner(aTHX_ WARN_DEPRECATED,
5684 "Array @%s missing the @ in argument %"IVdf" of %s()",
5685 name, (IV)numargs, PL_op_desc[type]);
5688 kid->op_sibling = sibl;
5691 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5692 bad_type(numargs, "array", PL_op_desc[type], kid);
5696 if (kid->op_type == OP_CONST &&
5697 (kid->op_private & OPpCONST_BARE))
5699 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5700 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5701 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5702 if (ckWARN(WARN_DEPRECATED))
5703 Perl_warner(aTHX_ WARN_DEPRECATED,
5704 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5705 name, (IV)numargs, PL_op_desc[type]);
5708 kid->op_sibling = sibl;
5711 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5712 bad_type(numargs, "hash", PL_op_desc[type], kid);
5717 OP *newop = newUNOP(OP_NULL, 0, kid);
5718 kid->op_sibling = 0;
5720 newop->op_next = newop;
5722 kid->op_sibling = sibl;
5727 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5728 if (kid->op_type == OP_CONST &&
5729 (kid->op_private & OPpCONST_BARE))
5731 OP *newop = newGVOP(OP_GV, 0,
5732 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5737 else if (kid->op_type == OP_READLINE) {
5738 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5739 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5742 I32 flags = OPf_SPECIAL;
5746 /* is this op a FH constructor? */
5747 if (is_handle_constructor(o,numargs)) {
5748 char *name = Nullch;
5752 /* Set a flag to tell rv2gv to vivify
5753 * need to "prove" flag does not mean something
5754 * else already - NI-S 1999/05/07
5757 if (kid->op_type == OP_PADSV) {
5758 SV **namep = av_fetch(PL_comppad_name,
5760 if (namep && *namep)
5761 name = SvPV(*namep, len);
5763 else if (kid->op_type == OP_RV2SV
5764 && kUNOP->op_first->op_type == OP_GV)
5766 GV *gv = cGVOPx_gv(kUNOP->op_first);
5768 len = GvNAMELEN(gv);
5770 else if (kid->op_type == OP_AELEM
5771 || kid->op_type == OP_HELEM)
5773 name = "__ANONIO__";
5779 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5780 namesv = PL_curpad[targ];
5781 (void)SvUPGRADE(namesv, SVt_PV);
5783 sv_setpvn(namesv, "$", 1);
5784 sv_catpvn(namesv, name, len);
5787 kid->op_sibling = 0;
5788 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5789 kid->op_targ = targ;
5790 kid->op_private |= priv;
5792 kid->op_sibling = sibl;
5798 mod(scalar(kid), type);
5802 tokid = &kid->op_sibling;
5803 kid = kid->op_sibling;
5805 o->op_private |= numargs;
5807 return too_many_arguments(o,PL_op_desc[o->op_type]);
5810 else if (PL_opargs[type] & OA_DEFGV) {
5812 return newUNOP(type, 0, newDEFSVOP());
5816 while (oa & OA_OPTIONAL)
5818 if (oa && oa != OA_LIST)
5819 return too_few_arguments(o,PL_op_desc[o->op_type]);
5825 Perl_ck_glob(pTHX_ OP *o)
5830 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5831 append_elem(OP_GLOB, o, newDEFSVOP());
5833 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5834 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5836 #if !defined(PERL_EXTERNAL_GLOB)
5837 /* XXX this can be tightened up and made more failsafe. */
5841 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5843 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5844 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5845 GvCV(gv) = GvCV(glob_gv);
5846 SvREFCNT_inc((SV*)GvCV(gv));
5847 GvIMPORTED_CV_on(gv);
5850 #endif /* PERL_EXTERNAL_GLOB */
5852 if (gv && GvIMPORTED_CV(gv)) {
5853 append_elem(OP_GLOB, o,
5854 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5855 o->op_type = OP_LIST;
5856 o->op_ppaddr = PL_ppaddr[OP_LIST];
5857 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5858 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5859 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5860 append_elem(OP_LIST, o,
5861 scalar(newUNOP(OP_RV2CV, 0,
5862 newGVOP(OP_GV, 0, gv)))));
5863 o = newUNOP(OP_NULL, 0, ck_subr(o));
5864 o->op_targ = OP_GLOB; /* hint at what it used to be */
5867 gv = newGVgen("main");
5869 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5875 Perl_ck_grep(pTHX_ OP *o)
5879 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5881 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5882 NewOp(1101, gwop, 1, LOGOP);
5884 if (o->op_flags & OPf_STACKED) {
5887 kid = cLISTOPo->op_first->op_sibling;
5888 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5891 kid->op_next = (OP*)gwop;
5892 o->op_flags &= ~OPf_STACKED;
5894 kid = cLISTOPo->op_first->op_sibling;
5895 if (type == OP_MAPWHILE)
5902 kid = cLISTOPo->op_first->op_sibling;
5903 if (kid->op_type != OP_NULL)
5904 Perl_croak(aTHX_ "panic: ck_grep");
5905 kid = kUNOP->op_first;
5907 gwop->op_type = type;
5908 gwop->op_ppaddr = PL_ppaddr[type];
5909 gwop->op_first = listkids(o);
5910 gwop->op_flags |= OPf_KIDS;
5911 gwop->op_private = 1;
5912 gwop->op_other = LINKLIST(kid);
5913 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5914 kid->op_next = (OP*)gwop;
5916 kid = cLISTOPo->op_first->op_sibling;
5917 if (!kid || !kid->op_sibling)
5918 return too_few_arguments(o,PL_op_desc[o->op_type]);
5919 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5920 mod(kid, OP_GREPSTART);
5926 Perl_ck_index(pTHX_ OP *o)
5928 if (o->op_flags & OPf_KIDS) {
5929 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5931 kid = kid->op_sibling; /* get past "big" */
5932 if (kid && kid->op_type == OP_CONST)
5933 fbm_compile(((SVOP*)kid)->op_sv, 0);
5939 Perl_ck_lengthconst(pTHX_ OP *o)
5941 /* XXX length optimization goes here */
5946 Perl_ck_lfun(pTHX_ OP *o)
5948 OPCODE type = o->op_type;
5949 return modkids(ck_fun(o), type);
5953 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5955 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5956 switch (cUNOPo->op_first->op_type) {
5958 /* This is needed for
5959 if (defined %stash::)
5960 to work. Do not break Tk.
5962 break; /* Globals via GV can be undef */
5964 case OP_AASSIGN: /* Is this a good idea? */
5965 Perl_warner(aTHX_ WARN_DEPRECATED,
5966 "defined(@array) is deprecated");
5967 Perl_warner(aTHX_ WARN_DEPRECATED,
5968 "\t(Maybe you should just omit the defined()?)\n");
5971 /* This is needed for
5972 if (defined %stash::)
5973 to work. Do not break Tk.
5975 break; /* Globals via GV can be undef */
5977 Perl_warner(aTHX_ WARN_DEPRECATED,
5978 "defined(%%hash) is deprecated");
5979 Perl_warner(aTHX_ WARN_DEPRECATED,
5980 "\t(Maybe you should just omit the defined()?)\n");
5991 Perl_ck_rfun(pTHX_ OP *o)
5993 OPCODE type = o->op_type;
5994 return refkids(ck_fun(o), type);
5998 Perl_ck_listiob(pTHX_ OP *o)
6002 kid = cLISTOPo->op_first;
6005 kid = cLISTOPo->op_first;
6007 if (kid->op_type == OP_PUSHMARK)
6008 kid = kid->op_sibling;
6009 if (kid && o->op_flags & OPf_STACKED)
6010 kid = kid->op_sibling;
6011 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6012 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6013 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6014 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6015 cLISTOPo->op_first->op_sibling = kid;
6016 cLISTOPo->op_last = kid;
6017 kid = kid->op_sibling;
6022 append_elem(o->op_type, o, newDEFSVOP());
6028 if (PL_hints & HINT_LOCALE)
6029 o->op_private |= OPpLOCALE;
6036 Perl_ck_fun_locale(pTHX_ OP *o)
6042 if (PL_hints & HINT_LOCALE)
6043 o->op_private |= OPpLOCALE;
6050 Perl_ck_sassign(pTHX_ OP *o)
6052 OP *kid = cLISTOPo->op_first;
6053 /* has a disposable target? */
6054 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6055 && !(kid->op_flags & OPf_STACKED)
6056 /* Cannot steal the second time! */
6057 && !(kid->op_private & OPpTARGET_MY))
6059 OP *kkid = kid->op_sibling;
6061 /* Can just relocate the target. */
6062 if (kkid && kkid->op_type == OP_PADSV
6063 && !(kkid->op_private & OPpLVAL_INTRO))
6065 kid->op_targ = kkid->op_targ;
6067 /* Now we do not need PADSV and SASSIGN. */
6068 kid->op_sibling = o->op_sibling; /* NULL */
6069 cLISTOPo->op_first = NULL;
6072 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6080 Perl_ck_scmp(pTHX_ OP *o)
6084 if (PL_hints & HINT_LOCALE)
6085 o->op_private |= OPpLOCALE;
6092 Perl_ck_match(pTHX_ OP *o)
6094 o->op_private |= OPpRUNTIME;
6099 Perl_ck_method(pTHX_ OP *o)
6101 OP *kid = cUNOPo->op_first;
6102 if (kid->op_type == OP_CONST) {
6103 SV* sv = kSVOP->op_sv;
6104 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6106 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6107 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6110 kSVOP->op_sv = Nullsv;
6112 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6121 Perl_ck_null(pTHX_ OP *o)
6127 Perl_ck_open(pTHX_ OP *o)
6129 HV *table = GvHV(PL_hintgv);
6133 svp = hv_fetch(table, "open_IN", 7, FALSE);
6135 mode = mode_from_discipline(*svp);
6136 if (mode & O_BINARY)
6137 o->op_private |= OPpOPEN_IN_RAW;
6138 else if (mode & O_TEXT)
6139 o->op_private |= OPpOPEN_IN_CRLF;
6142 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6144 mode = mode_from_discipline(*svp);
6145 if (mode & O_BINARY)
6146 o->op_private |= OPpOPEN_OUT_RAW;
6147 else if (mode & O_TEXT)
6148 o->op_private |= OPpOPEN_OUT_CRLF;
6151 if (o->op_type == OP_BACKTICK)
6157 Perl_ck_repeat(pTHX_ OP *o)
6159 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6160 o->op_private |= OPpREPEAT_DOLIST;
6161 cBINOPo->op_first = force_list(cBINOPo->op_first);
6169 Perl_ck_require(pTHX_ OP *o)
6173 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6174 SVOP *kid = (SVOP*)cUNOPo->op_first;
6176 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6178 for (s = SvPVX(kid->op_sv); *s; s++) {
6179 if (*s == ':' && s[1] == ':') {
6181 Move(s+2, s+1, strlen(s+2)+1, char);
6182 --SvCUR(kid->op_sv);
6185 if (SvREADONLY(kid->op_sv)) {
6186 SvREADONLY_off(kid->op_sv);
6187 sv_catpvn(kid->op_sv, ".pm", 3);
6188 SvREADONLY_on(kid->op_sv);
6191 sv_catpvn(kid->op_sv, ".pm", 3);
6195 /* handle override, if any */
6196 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6197 if (!(gv && GvIMPORTED_CV(gv)))
6198 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6200 if (gv && GvIMPORTED_CV(gv)) {
6201 OP *kid = cUNOPo->op_first;
6202 cUNOPo->op_first = 0;
6204 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6205 append_elem(OP_LIST, kid,
6206 scalar(newUNOP(OP_RV2CV, 0,
6215 Perl_ck_return(pTHX_ OP *o)
6218 if (CvLVALUE(PL_compcv)) {
6219 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6220 mod(kid, OP_LEAVESUBLV);
6227 Perl_ck_retarget(pTHX_ OP *o)
6229 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6236 Perl_ck_select(pTHX_ OP *o)
6239 if (o->op_flags & OPf_KIDS) {
6240 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6241 if (kid && kid->op_sibling) {
6242 o->op_type = OP_SSELECT;
6243 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6245 return fold_constants(o);
6249 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6250 if (kid && kid->op_type == OP_RV2GV)
6251 kid->op_private &= ~HINT_STRICT_REFS;
6256 Perl_ck_shift(pTHX_ OP *o)
6258 I32 type = o->op_type;
6260 if (!(o->op_flags & OPf_KIDS)) {
6265 if (!CvUNIQUE(PL_compcv)) {
6266 argop = newOP(OP_PADAV, OPf_REF);
6267 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6270 argop = newUNOP(OP_RV2AV, 0,
6271 scalar(newGVOP(OP_GV, 0,
6272 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6275 argop = newUNOP(OP_RV2AV, 0,
6276 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6277 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6278 #endif /* USE_THREADS */
6279 return newUNOP(type, 0, scalar(argop));
6281 return scalar(modkids(ck_fun(o), type));
6285 Perl_ck_sort(pTHX_ OP *o)
6290 if (PL_hints & HINT_LOCALE)
6291 o->op_private |= OPpLOCALE;
6294 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6296 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6297 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6299 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6301 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6303 if (kid->op_type == OP_SCOPE) {
6307 else if (kid->op_type == OP_LEAVE) {
6308 if (o->op_type == OP_SORT) {
6309 op_null(kid); /* wipe out leave */
6312 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6313 if (k->op_next == kid)
6315 /* don't descend into loops */
6316 else if (k->op_type == OP_ENTERLOOP
6317 || k->op_type == OP_ENTERITER)
6319 k = cLOOPx(k)->op_lastop;
6324 kid->op_next = 0; /* just disconnect the leave */
6325 k = kLISTOP->op_first;
6330 if (o->op_type == OP_SORT) {
6331 /* provide scalar context for comparison function/block */
6337 o->op_flags |= OPf_SPECIAL;
6339 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6342 firstkid = firstkid->op_sibling;
6345 /* provide list context for arguments */
6346 if (o->op_type == OP_SORT)
6353 S_simplify_sort(pTHX_ OP *o)
6355 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6359 if (!(o->op_flags & OPf_STACKED))
6361 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6362 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6363 kid = kUNOP->op_first; /* get past null */
6364 if (kid->op_type != OP_SCOPE)
6366 kid = kLISTOP->op_last; /* get past scope */
6367 switch(kid->op_type) {
6375 k = kid; /* remember this node*/
6376 if (kBINOP->op_first->op_type != OP_RV2SV)
6378 kid = kBINOP->op_first; /* get past cmp */
6379 if (kUNOP->op_first->op_type != OP_GV)
6381 kid = kUNOP->op_first; /* get past rv2sv */
6383 if (GvSTASH(gv) != PL_curstash)
6385 if (strEQ(GvNAME(gv), "a"))
6387 else if (strEQ(GvNAME(gv), "b"))
6391 kid = k; /* back to cmp */
6392 if (kBINOP->op_last->op_type != OP_RV2SV)
6394 kid = kBINOP->op_last; /* down to 2nd arg */
6395 if (kUNOP->op_first->op_type != OP_GV)
6397 kid = kUNOP->op_first; /* get past rv2sv */
6399 if (GvSTASH(gv) != PL_curstash
6401 ? strNE(GvNAME(gv), "a")
6402 : strNE(GvNAME(gv), "b")))
6404 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6406 o->op_private |= OPpSORT_REVERSE;
6407 if (k->op_type == OP_NCMP)
6408 o->op_private |= OPpSORT_NUMERIC;
6409 if (k->op_type == OP_I_NCMP)
6410 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6411 kid = cLISTOPo->op_first->op_sibling;
6412 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6413 op_free(kid); /* then delete it */
6417 Perl_ck_split(pTHX_ OP *o)
6421 if (o->op_flags & OPf_STACKED)
6422 return no_fh_allowed(o);
6424 kid = cLISTOPo->op_first;
6425 if (kid->op_type != OP_NULL)
6426 Perl_croak(aTHX_ "panic: ck_split");
6427 kid = kid->op_sibling;
6428 op_free(cLISTOPo->op_first);
6429 cLISTOPo->op_first = kid;
6431 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6432 cLISTOPo->op_last = kid; /* There was only one element previously */
6435 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6436 OP *sibl = kid->op_sibling;
6437 kid->op_sibling = 0;
6438 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6439 if (cLISTOPo->op_first == cLISTOPo->op_last)
6440 cLISTOPo->op_last = kid;
6441 cLISTOPo->op_first = kid;
6442 kid->op_sibling = sibl;
6445 kid->op_type = OP_PUSHRE;
6446 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6449 if (!kid->op_sibling)
6450 append_elem(OP_SPLIT, o, newDEFSVOP());
6452 kid = kid->op_sibling;
6455 if (!kid->op_sibling)
6456 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6458 kid = kid->op_sibling;
6461 if (kid->op_sibling)
6462 return too_many_arguments(o,PL_op_desc[o->op_type]);
6468 Perl_ck_join(pTHX_ OP *o)
6470 if (ckWARN(WARN_SYNTAX)) {
6471 OP *kid = cLISTOPo->op_first->op_sibling;
6472 if (kid && kid->op_type == OP_MATCH) {
6473 char *pmstr = "STRING";
6474 if (kPMOP->op_pmregexp)
6475 pmstr = kPMOP->op_pmregexp->precomp;
6476 Perl_warner(aTHX_ WARN_SYNTAX,
6477 "/%s/ should probably be written as \"%s\"",
6485 Perl_ck_subr(pTHX_ OP *o)
6487 OP *prev = ((cUNOPo->op_first->op_sibling)
6488 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6489 OP *o2 = prev->op_sibling;
6498 o->op_private |= OPpENTERSUB_HASTARG;
6499 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6500 if (cvop->op_type == OP_RV2CV) {
6502 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6503 op_null(cvop); /* disable rv2cv */
6504 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6505 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6506 GV *gv = cGVOPx_gv(tmpop);
6509 tmpop->op_private |= OPpEARLY_CV;
6510 else if (SvPOK(cv)) {
6511 namegv = CvANON(cv) ? gv : CvGV(cv);
6512 proto = SvPV((SV*)cv, n_a);
6516 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6517 if (o2->op_type == OP_CONST)
6518 o2->op_private &= ~OPpCONST_STRICT;
6519 else if (o2->op_type == OP_LIST) {
6520 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6521 if (o && o->op_type == OP_CONST)
6522 o->op_private &= ~OPpCONST_STRICT;
6525 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6526 if (PERLDB_SUB && PL_curstash != PL_debstash)
6527 o->op_private |= OPpENTERSUB_DB;
6528 while (o2 != cvop) {
6532 return too_many_arguments(o, gv_ename(namegv));
6550 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6552 arg == 1 ? "block or sub {}" : "sub {}",
6553 gv_ename(namegv), o2);
6556 /* '*' allows any scalar type, including bareword */
6559 if (o2->op_type == OP_RV2GV)
6560 goto wrapref; /* autoconvert GLOB -> GLOBref */
6561 else if (o2->op_type == OP_CONST)
6562 o2->op_private &= ~OPpCONST_STRICT;
6563 else if (o2->op_type == OP_ENTERSUB) {
6564 /* accidental subroutine, revert to bareword */
6565 OP *gvop = ((UNOP*)o2)->op_first;
6566 if (gvop && gvop->op_type == OP_NULL) {
6567 gvop = ((UNOP*)gvop)->op_first;
6569 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6572 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6573 (gvop = ((UNOP*)gvop)->op_first) &&
6574 gvop->op_type == OP_GV)
6576 GV *gv = cGVOPx_gv(gvop);
6577 OP *sibling = o2->op_sibling;
6578 SV *n = newSVpvn("",0);
6580 gv_fullname3(n, gv, "");
6581 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6582 sv_chop(n, SvPVX(n)+6);
6583 o2 = newSVOP(OP_CONST, 0, n);
6584 prev->op_sibling = o2;
6585 o2->op_sibling = sibling;
6597 if (o2->op_type != OP_RV2GV)
6598 bad_type(arg, "symbol", gv_ename(namegv), o2);
6601 if (o2->op_type != OP_ENTERSUB)
6602 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6605 if (o2->op_type != OP_RV2SV
6606 && o2->op_type != OP_PADSV
6607 && o2->op_type != OP_HELEM
6608 && o2->op_type != OP_AELEM
6609 && o2->op_type != OP_THREADSV)
6611 bad_type(arg, "scalar", gv_ename(namegv), o2);
6615 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6616 bad_type(arg, "array", gv_ename(namegv), o2);
6619 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6620 bad_type(arg, "hash", gv_ename(namegv), o2);
6624 OP* sib = kid->op_sibling;
6625 kid->op_sibling = 0;
6626 o2 = newUNOP(OP_REFGEN, 0, kid);
6627 o2->op_sibling = sib;
6628 prev->op_sibling = o2;
6639 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6640 gv_ename(namegv), SvPV((SV*)cv, n_a));
6645 mod(o2, OP_ENTERSUB);
6647 o2 = o2->op_sibling;
6649 if (proto && !optional &&
6650 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6651 return too_few_arguments(o, gv_ename(namegv));
6656 Perl_ck_svconst(pTHX_ OP *o)
6658 SvREADONLY_on(cSVOPo->op_sv);
6663 Perl_ck_trunc(pTHX_ OP *o)
6665 if (o->op_flags & OPf_KIDS) {
6666 SVOP *kid = (SVOP*)cUNOPo->op_first;
6668 if (kid->op_type == OP_NULL)
6669 kid = (SVOP*)kid->op_sibling;
6670 if (kid && kid->op_type == OP_CONST &&
6671 (kid->op_private & OPpCONST_BARE))
6673 o->op_flags |= OPf_SPECIAL;
6674 kid->op_private &= ~OPpCONST_STRICT;
6681 Perl_ck_substr(pTHX_ OP *o)
6684 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6685 OP *kid = cLISTOPo->op_first;
6687 if (kid->op_type == OP_NULL)
6688 kid = kid->op_sibling;
6690 kid->op_flags |= OPf_MOD;
6696 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6699 Perl_peep(pTHX_ register OP *o)
6701 register OP* oldop = 0;
6704 if (!o || o->op_seq)
6708 SAVEVPTR(PL_curcop);
6709 for (; o; o = o->op_next) {
6715 switch (o->op_type) {
6719 PL_curcop = ((COP*)o); /* for warnings */
6720 o->op_seq = PL_op_seqmax++;
6724 if (cSVOPo->op_private & OPpCONST_STRICT)
6725 no_bareword_allowed(o);
6727 /* Relocate sv to the pad for thread safety.
6728 * Despite being a "constant", the SV is written to,
6729 * for reference counts, sv_upgrade() etc. */
6731 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6732 if (SvPADTMP(cSVOPo->op_sv)) {
6733 /* If op_sv is already a PADTMP then it is being used by
6734 * some pad, so make a copy. */
6735 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6736 SvREADONLY_on(PL_curpad[ix]);
6737 SvREFCNT_dec(cSVOPo->op_sv);
6740 SvREFCNT_dec(PL_curpad[ix]);
6741 SvPADTMP_on(cSVOPo->op_sv);
6742 PL_curpad[ix] = cSVOPo->op_sv;
6743 /* XXX I don't know how this isn't readonly already. */
6744 SvREADONLY_on(PL_curpad[ix]);
6746 cSVOPo->op_sv = Nullsv;
6750 o->op_seq = PL_op_seqmax++;
6754 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6755 if (o->op_next->op_private & OPpTARGET_MY) {
6756 if (o->op_flags & OPf_STACKED) /* chained concats */
6757 goto ignore_optimization;
6759 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6760 o->op_targ = o->op_next->op_targ;
6761 o->op_next->op_targ = 0;
6762 o->op_private |= OPpTARGET_MY;
6765 op_null(o->op_next);
6767 ignore_optimization:
6768 o->op_seq = PL_op_seqmax++;
6771 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6772 o->op_seq = PL_op_seqmax++;
6773 break; /* Scalar stub must produce undef. List stub is noop */
6777 if (o->op_targ == OP_NEXTSTATE
6778 || o->op_targ == OP_DBSTATE
6779 || o->op_targ == OP_SETSTATE)
6781 PL_curcop = ((COP*)o);
6788 if (oldop && o->op_next) {
6789 oldop->op_next = o->op_next;
6792 o->op_seq = PL_op_seqmax++;
6796 if (o->op_next->op_type == OP_RV2SV) {
6797 if (!(o->op_next->op_private & OPpDEREF)) {
6798 op_null(o->op_next);
6799 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6801 o->op_next = o->op_next->op_next;
6802 o->op_type = OP_GVSV;
6803 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6806 else if (o->op_next->op_type == OP_RV2AV) {
6807 OP* pop = o->op_next->op_next;
6809 if (pop->op_type == OP_CONST &&
6810 (PL_op = pop->op_next) &&
6811 pop->op_next->op_type == OP_AELEM &&
6812 !(pop->op_next->op_private &
6813 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6814 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6819 op_null(o->op_next);
6820 op_null(pop->op_next);
6822 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6823 o->op_next = pop->op_next->op_next;
6824 o->op_type = OP_AELEMFAST;
6825 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6826 o->op_private = (U8)i;
6831 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6833 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6834 /* XXX could check prototype here instead of just carping */
6835 SV *sv = sv_newmortal();
6836 gv_efullname3(sv, gv, Nullch);
6837 Perl_warner(aTHX_ WARN_PROTOTYPE,
6838 "%s() called too early to check prototype",
6843 o->op_seq = PL_op_seqmax++;
6854 o->op_seq = PL_op_seqmax++;
6855 while (cLOGOP->op_other->op_type == OP_NULL)
6856 cLOGOP->op_other = cLOGOP->op_other->op_next;
6857 peep(cLOGOP->op_other);
6862 o->op_seq = PL_op_seqmax++;
6863 while (cLOOP->op_redoop->op_type == OP_NULL)
6864 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6865 peep(cLOOP->op_redoop);
6866 while (cLOOP->op_nextop->op_type == OP_NULL)
6867 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6868 peep(cLOOP->op_nextop);
6869 while (cLOOP->op_lastop->op_type == OP_NULL)
6870 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6871 peep(cLOOP->op_lastop);
6877 o->op_seq = PL_op_seqmax++;
6878 while (cPMOP->op_pmreplstart &&
6879 cPMOP->op_pmreplstart->op_type == OP_NULL)
6880 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6881 peep(cPMOP->op_pmreplstart);
6885 o->op_seq = PL_op_seqmax++;
6886 if (ckWARN(WARN_SYNTAX) && o->op_next
6887 && o->op_next->op_type == OP_NEXTSTATE) {
6888 if (o->op_next->op_sibling &&
6889 o->op_next->op_sibling->op_type != OP_EXIT &&
6890 o->op_next->op_sibling->op_type != OP_WARN &&
6891 o->op_next->op_sibling->op_type != OP_DIE) {
6892 line_t oldline = CopLINE(PL_curcop);
6894 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6895 Perl_warner(aTHX_ WARN_EXEC,
6896 "Statement unlikely to be reached");
6897 Perl_warner(aTHX_ WARN_EXEC,
6898 "\t(Maybe you meant system() when you said exec()?)\n");
6899 CopLINE_set(PL_curcop, oldline);
6908 SV **svp, **indsvp, *sv;
6913 o->op_seq = PL_op_seqmax++;
6915 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6918 /* Make the CONST have a shared SV */
6919 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6920 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6921 key = SvPV(sv, keylen);
6924 lexname = newSVpvn_share(key, keylen, 0);
6929 if ((o->op_private & (OPpLVAL_INTRO)))
6932 rop = (UNOP*)((BINOP*)o)->op_first;
6933 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6935 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6936 if (!SvOBJECT(lexname))
6938 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6939 if (!fields || !GvHV(*fields))
6941 key = SvPV(*svp, keylen);
6944 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6946 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6947 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6949 ind = SvIV(*indsvp);
6951 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6952 rop->op_type = OP_RV2AV;
6953 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6954 o->op_type = OP_AELEM;
6955 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6957 if (SvREADONLY(*svp))
6959 SvFLAGS(sv) |= (SvFLAGS(*svp)
6960 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6970 SV **svp, **indsvp, *sv;
6974 SVOP *first_key_op, *key_op;
6976 o->op_seq = PL_op_seqmax++;
6977 if ((o->op_private & (OPpLVAL_INTRO))
6978 /* I bet there's always a pushmark... */
6979 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6980 /* hmmm, no optimization if list contains only one key. */
6982 rop = (UNOP*)((LISTOP*)o)->op_last;
6983 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6985 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6986 if (!SvOBJECT(lexname))
6988 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6989 if (!fields || !GvHV(*fields))
6991 /* Again guessing that the pushmark can be jumped over.... */
6992 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6993 ->op_first->op_sibling;
6994 /* Check that the key list contains only constants. */
6995 for (key_op = first_key_op; key_op;
6996 key_op = (SVOP*)key_op->op_sibling)
6997 if (key_op->op_type != OP_CONST)
7001 rop->op_type = OP_RV2AV;
7002 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7003 o->op_type = OP_ASLICE;
7004 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7005 for (key_op = first_key_op; key_op;
7006 key_op = (SVOP*)key_op->op_sibling) {
7007 svp = cSVOPx_svp(key_op);
7008 key = SvPV(*svp, keylen);
7011 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7013 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7014 "in variable %s of type %s",
7015 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7017 ind = SvIV(*indsvp);
7019 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7021 if (SvREADONLY(*svp))
7023 SvFLAGS(sv) |= (SvFLAGS(*svp)
7024 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7032 o->op_seq = PL_op_seqmax++;
7042 /* Efficient sub that returns a constant scalar value. */
7044 const_sv_xsub(pTHXo_ CV* cv)
7049 Perl_croak(aTHX_ "usage: %s::%s()",
7050 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7054 ST(0) = (SV*)XSANY.any_ptr;