3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 /* #define PL_OP_SLAB_ALLOC */
25 #ifdef PL_OP_SLAB_ALLOC
26 #define SLAB_SIZE 8192
27 static char *PL_OpPtr = NULL;
28 static int PL_OpSpace = 0;
29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
30 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
32 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
36 S_Slab_Alloc(pTHX_ int m, size_t sz)
38 Newz(m,PL_OpPtr,SLAB_SIZE,char);
39 PL_OpSpace = SLAB_SIZE - sz;
40 return PL_OpPtr += PL_OpSpace;
44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
47 * In the following definition, the ", Nullop" is just to make the compiler
48 * think the expression is of the right type: croak actually does a Siglongjmp.
50 #define CHECKOP(type,o) \
51 ((PL_op_mask && PL_op_mask[type]) \
52 ? ( op_free((OP*)o), \
53 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
55 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
57 #define PAD_MAX 999999999
58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
61 S_gv_ename(pTHX_ GV *gv)
64 SV* tmpsv = sv_newmortal();
65 gv_efullname3(tmpsv, gv, Nullch);
66 return SvPV(tmpsv,n_a);
70 S_no_fh_allowed(pTHX_ OP *o)
72 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
73 PL_op_desc[o->op_type]));
78 S_too_few_arguments(pTHX_ OP *o, char *name)
80 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
85 S_too_many_arguments(pTHX_ OP *o, char *name)
87 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
94 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
95 (int)n, name, t, PL_op_desc[kid->op_type]));
99 S_no_bareword_allowed(pTHX_ OP *o)
101 qerror(Perl_mess(aTHX_
102 "Bareword \"%s\" not allowed while \"strict subs\" in use",
103 SvPV_nolen(cSVOPo_sv)));
106 /* "register" allocation */
109 Perl_pad_allocmy(pTHX_ char *name)
114 if (!(PL_in_my == KEY_our ||
116 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
117 (name[1] == '_' && (int)strlen(name) > 2)))
119 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
120 /* 1999-02-27 mjd@plover.com */
122 p = strchr(name, '\0');
123 /* The next block assumes the buffer is at least 205 chars
124 long. At present, it's always at least 256 chars. */
126 strcpy(name+200, "...");
132 /* Move everything else down one character */
133 for (; p-name > 2; p--)
135 name[2] = toCTRL(name[1]);
138 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
140 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
141 SV **svp = AvARRAY(PL_comppad_name);
142 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
143 PADOFFSET top = AvFILLp(PL_comppad_name);
144 for (off = top; off > PL_comppad_name_floor; off--) {
146 && sv != &PL_sv_undef
147 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
148 && (PL_in_my != KEY_our
149 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
150 && strEQ(name, SvPVX(sv)))
152 Perl_warner(aTHX_ WARN_MISC,
153 "\"%s\" variable %s masks earlier declaration in same %s",
154 (PL_in_my == KEY_our ? "our" : "my"),
156 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
161 if (PL_in_my == KEY_our) {
164 && sv != &PL_sv_undef
165 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
166 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
167 && strEQ(name, SvPVX(sv)))
169 Perl_warner(aTHX_ WARN_MISC,
170 "\"our\" variable %s redeclared", name);
171 Perl_warner(aTHX_ WARN_MISC,
172 "\t(Did you mean \"local\" instead of \"our\"?)\n");
175 } while ( off-- > 0 );
178 off = pad_alloc(OP_PADSV, SVs_PADMY);
180 sv_upgrade(sv, SVt_PVNV);
182 if (PL_in_my_stash) {
184 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
185 name, PL_in_my == KEY_our ? "our" : "my"));
187 (void)SvUPGRADE(sv, SVt_PVMG);
188 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
191 if (PL_in_my == KEY_our) {
192 (void)SvUPGRADE(sv, SVt_PVGV);
193 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
194 SvFLAGS(sv) |= SVpad_OUR;
196 av_store(PL_comppad_name, off, sv);
197 SvNVX(sv) = (NV)PAD_MAX;
198 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
199 if (!PL_min_intro_pending)
200 PL_min_intro_pending = off;
201 PL_max_intro_pending = off;
203 av_store(PL_comppad, off, (SV*)newAV());
204 else if (*name == '%')
205 av_store(PL_comppad, off, (SV*)newHV());
206 SvPADMY_on(PL_curpad[off]);
211 S_pad_addlex(pTHX_ SV *proto_namesv)
213 SV *namesv = NEWSV(1103,0);
214 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
215 sv_upgrade(namesv, SVt_PVNV);
216 sv_setpv(namesv, SvPVX(proto_namesv));
217 av_store(PL_comppad_name, newoff, namesv);
218 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
219 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
220 SvFAKE_on(namesv); /* A ref, not a real var */
221 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
222 SvFLAGS(namesv) |= SVpad_OUR;
223 (void)SvUPGRADE(namesv, SVt_PVGV);
224 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
226 if (SvOBJECT(proto_namesv)) { /* A typed var */
228 (void)SvUPGRADE(namesv, SVt_PVMG);
229 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
235 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
238 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
239 I32 cx_ix, I32 saweval, U32 flags)
245 register PERL_CONTEXT *cx;
247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
252 if (!svp || *svp == &PL_sv_undef)
255 svp = AvARRAY(curname);
256 for (off = AvFILLp(curname); off > 0; off--) {
257 if ((sv = svp[off]) &&
258 sv != &PL_sv_undef &&
260 seq > I_32(SvNVX(sv)) &&
261 strEQ(SvPVX(sv), name))
272 return 0; /* don't clone from inactive stack frame */
276 oldpad = (AV*)AvARRAY(curlist)[depth];
277 oldsv = *av_fetch(oldpad, off, TRUE);
278 if (!newoff) { /* Not a mere clone operation. */
279 newoff = pad_addlex(sv);
280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
281 /* "It's closures all the way down." */
282 CvCLONE_on(PL_compcv);
284 if (CvANON(PL_compcv))
285 oldsv = Nullsv; /* no need to keep ref */
290 bcv && bcv != cv && !CvCLONE(bcv);
291 bcv = CvOUTSIDE(bcv))
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
314 Perl_warner(aTHX_ WARN_CLOSURE,
315 "Variable \"%s\" may be unavailable",
323 else if (!CvUNIQUE(PL_compcv)) {
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
327 Perl_warner(aTHX_ WARN_CLOSURE,
328 "Variable \"%s\" will not stay shared", name);
332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
338 if (flags & FINDLEX_NOSEARCH)
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
346 for (i = cx_ix; i >= 0; i--) {
348 switch (CxTYPE(cx)) {
350 if (i == 0 && saweval) {
351 seq = cxstack[saweval].blk_oldcop->cop_seq;
352 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
356 switch (cx->blk_eval.old_op_type) {
363 /* require/do must have their own scope */
372 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
373 saweval = i; /* so we know where we were called from */
376 seq = cxstack[saweval].blk_oldcop->cop_seq;
377 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
385 Perl_pad_findmy(pTHX_ char *name)
390 SV **svp = AvARRAY(PL_comppad_name);
391 U32 seq = PL_cop_seqmax;
397 * Special case to get lexical (and hence per-thread) @_.
398 * XXX I need to find out how to tell at parse-time whether use
399 * of @_ should refer to a lexical (from a sub) or defgv (global
400 * scope and maybe weird sub-ish things like formats). See
401 * startsub in perly.y. It's possible that @_ could be lexical
402 * (at least from subs) even in non-threaded perl.
404 if (strEQ(name, "@_"))
405 return 0; /* success. (NOT_IN_PAD indicates failure) */
406 #endif /* USE_THREADS */
408 /* The one we're looking for is probably just before comppad_name_fill. */
409 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
410 if ((sv = svp[off]) &&
411 sv != &PL_sv_undef &&
414 seq > I_32(SvNVX(sv)))) &&
415 strEQ(SvPVX(sv), name))
417 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
418 return (PADOFFSET)off;
419 pendoff = off; /* this pending def. will override import */
423 outside = CvOUTSIDE(PL_compcv);
425 /* Check if if we're compiling an eval'', and adjust seq to be the
426 * eval's seq number. This depends on eval'' having a non-null
427 * CvOUTSIDE() while it is being compiled. The eval'' itself is
428 * identified by CvEVAL being true and CvGV being null. */
429 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
430 cx = &cxstack[cxstack_ix];
432 seq = cx->blk_oldcop->cop_seq;
435 /* See if it's in a nested scope */
436 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
438 /* If there is a pending local definition, this new alias must die */
440 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
441 return off; /* pad_findlex returns 0 for failure...*/
443 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
447 Perl_pad_leavemy(pTHX_ I32 fill)
450 SV **svp = AvARRAY(PL_comppad_name);
452 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
453 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
454 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
455 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
458 /* "Deintroduce" my variables that are leaving with this scope. */
459 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
460 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
461 SvIVX(sv) = PL_cop_seqmax;
466 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
471 if (AvARRAY(PL_comppad) != PL_curpad)
472 Perl_croak(aTHX_ "panic: pad_alloc");
473 if (PL_pad_reset_pending)
475 if (tmptype & SVs_PADMY) {
477 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
478 } while (SvPADBUSY(sv)); /* need a fresh one */
479 retval = AvFILLp(PL_comppad);
482 SV **names = AvARRAY(PL_comppad_name);
483 SSize_t names_fill = AvFILLp(PL_comppad_name);
486 * "foreach" index vars temporarily become aliases to non-"my"
487 * values. Thus we must skip, not just pad values that are
488 * marked as current pad values, but also those with names.
490 if (++PL_padix <= names_fill &&
491 (sv = names[PL_padix]) && sv != &PL_sv_undef)
493 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
494 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
495 !IS_PADGV(sv) && !IS_PADCONST(sv))
500 SvFLAGS(sv) |= tmptype;
501 PL_curpad = AvARRAY(PL_comppad);
503 DEBUG_X(PerlIO_printf(Perl_debug_log,
504 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
505 PTR2UV(thr), PTR2UV(PL_curpad),
506 (long) retval, PL_op_name[optype]));
508 DEBUG_X(PerlIO_printf(Perl_debug_log,
509 "Pad 0x%"UVxf" alloc %ld for %s\n",
511 (long) retval, PL_op_name[optype]));
512 #endif /* USE_THREADS */
513 return (PADOFFSET)retval;
517 Perl_pad_sv(pTHX_ PADOFFSET po)
520 DEBUG_X(PerlIO_printf(Perl_debug_log,
521 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
522 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
525 Perl_croak(aTHX_ "panic: pad_sv po");
526 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
527 PTR2UV(PL_curpad), (IV)po));
528 #endif /* USE_THREADS */
529 return PL_curpad[po]; /* eventually we'll turn this into a macro */
533 Perl_pad_free(pTHX_ PADOFFSET po)
537 if (AvARRAY(PL_comppad) != PL_curpad)
538 Perl_croak(aTHX_ "panic: pad_free curpad");
540 Perl_croak(aTHX_ "panic: pad_free po");
542 DEBUG_X(PerlIO_printf(Perl_debug_log,
543 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
544 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
546 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
547 PTR2UV(PL_curpad), (IV)po));
548 #endif /* USE_THREADS */
549 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
550 SvPADTMP_off(PL_curpad[po]);
552 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
555 if ((I32)po < PL_padix)
560 Perl_pad_swipe(pTHX_ PADOFFSET po)
562 if (AvARRAY(PL_comppad) != PL_curpad)
563 Perl_croak(aTHX_ "panic: pad_swipe curpad");
565 Perl_croak(aTHX_ "panic: pad_swipe po");
567 DEBUG_X(PerlIO_printf(Perl_debug_log,
568 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
569 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
571 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
572 PTR2UV(PL_curpad), (IV)po));
573 #endif /* USE_THREADS */
574 SvPADTMP_off(PL_curpad[po]);
575 PL_curpad[po] = NEWSV(1107,0);
576 SvPADTMP_on(PL_curpad[po]);
577 if ((I32)po < PL_padix)
581 /* XXX pad_reset() is currently disabled because it results in serious bugs.
582 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
583 * on the stack by OPs that use them, there are several ways to get an alias
584 * to a shared TARG. Such an alias will change randomly and unpredictably.
585 * We avoid doing this until we can think of a Better Way.
590 #ifdef USE_BROKEN_PAD_RESET
593 if (AvARRAY(PL_comppad) != PL_curpad)
594 Perl_croak(aTHX_ "panic: pad_reset curpad");
596 DEBUG_X(PerlIO_printf(Perl_debug_log,
597 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
598 PTR2UV(thr), PTR2UV(PL_curpad)));
600 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
602 #endif /* USE_THREADS */
603 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
604 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
605 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
606 SvPADTMP_off(PL_curpad[po]);
608 PL_padix = PL_padix_floor;
611 PL_pad_reset_pending = FALSE;
615 /* find_threadsv is not reentrant */
617 Perl_find_threadsv(pTHX_ const char *name)
622 /* We currently only handle names of a single character */
623 p = strchr(PL_threadsv_names, *name);
626 key = p - PL_threadsv_names;
627 MUTEX_LOCK(&thr->mutex);
628 svp = av_fetch(thr->threadsv, key, FALSE);
630 MUTEX_UNLOCK(&thr->mutex);
632 SV *sv = NEWSV(0, 0);
633 av_store(thr->threadsv, key, sv);
634 thr->threadsvp = AvARRAY(thr->threadsv);
635 MUTEX_UNLOCK(&thr->mutex);
637 * Some magic variables used to be automagically initialised
638 * in gv_fetchpv. Those which are now per-thread magicals get
639 * initialised here instead.
645 sv_setpv(sv, "\034");
646 sv_magic(sv, 0, 0, name, 1);
651 PL_sawampersand = TRUE;
665 /* XXX %! tied to Errno.pm needs to be added here.
666 * See gv_fetchpv(). */
670 sv_magic(sv, 0, 0, name, 1);
672 DEBUG_S(PerlIO_printf(Perl_error_log,
673 "find_threadsv: new SV %p for $%s%c\n",
674 sv, (*name < 32) ? "^" : "",
675 (*name < 32) ? toCTRL(*name) : *name));
679 #endif /* USE_THREADS */
684 Perl_op_free(pTHX_ OP *o)
686 register OP *kid, *nextkid;
689 if (!o || o->op_seq == (U16)-1)
692 if (o->op_private & OPpREFCOUNTED) {
693 switch (o->op_type) {
701 if (OpREFCNT_dec(o)) {
712 if (o->op_flags & OPf_KIDS) {
713 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
714 nextkid = kid->op_sibling; /* Get before next freeing kid */
722 /* COP* is not cleared by op_clear() so that we may track line
723 * numbers etc even after null() */
724 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
729 #ifdef PL_OP_SLAB_ALLOC
730 if ((char *) o == PL_OpPtr)
739 S_op_clear(pTHX_ OP *o)
741 switch (o->op_type) {
742 case OP_NULL: /* Was holding old type, if any. */
743 case OP_ENTEREVAL: /* Was holding hints. */
745 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
751 if (!(o->op_flags & OPf_SPECIAL))
754 #endif /* USE_THREADS */
756 if (!(o->op_flags & OPf_REF)
757 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
764 if (cPADOPo->op_padix > 0) {
767 pad_swipe(cPADOPo->op_padix);
768 /* No GvIN_PAD_off(gv) here, because other references may still
769 * exist on the pad */
772 cPADOPo->op_padix = 0;
775 SvREFCNT_dec(cSVOPo->op_sv);
776 cSVOPo->op_sv = Nullsv;
779 case OP_METHOD_NAMED:
781 SvREFCNT_dec(cSVOPo->op_sv);
782 cSVOPo->op_sv = Nullsv;
788 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
792 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
793 SvREFCNT_dec(cSVOPo->op_sv);
794 cSVOPo->op_sv = Nullsv;
797 Safefree(cPVOPo->op_pv);
798 cPVOPo->op_pv = Nullch;
802 op_free(cPMOPo->op_pmreplroot);
806 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
808 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
809 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
810 /* No GvIN_PAD_off(gv) here, because other references may still
811 * exist on the pad */
816 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
823 HV *pmstash = PmopSTASH(cPMOPo);
824 if (pmstash && SvREFCNT(pmstash)) {
825 PMOP *pmop = HvPMROOT(pmstash);
826 PMOP *lastpmop = NULL;
828 if (cPMOPo == pmop) {
830 lastpmop->op_pmnext = pmop->op_pmnext;
832 HvPMROOT(pmstash) = pmop->op_pmnext;
836 pmop = pmop->op_pmnext;
839 Safefree(PmopSTASHPV(cPMOPo));
841 /* NOTE: PMOP.op_pmstash is not refcounted */
845 cPMOPo->op_pmreplroot = Nullop;
846 ReREFCNT_dec(cPMOPo->op_pmregexp);
847 cPMOPo->op_pmregexp = (REGEXP*)NULL;
851 if (o->op_targ > 0) {
852 pad_free(o->op_targ);
858 S_cop_free(pTHX_ COP* cop)
860 Safefree(cop->cop_label);
862 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
863 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
865 /* NOTE: COP.cop_stash is not refcounted */
866 SvREFCNT_dec(CopFILEGV(cop));
868 if (! specialWARN(cop->cop_warnings))
869 SvREFCNT_dec(cop->cop_warnings);
870 if (! specialCopIO(cop->cop_io))
871 SvREFCNT_dec(cop->cop_io);
877 if (o->op_type == OP_NULL)
880 o->op_targ = o->op_type;
881 o->op_type = OP_NULL;
882 o->op_ppaddr = PL_ppaddr[OP_NULL];
885 /* Contextualizers */
887 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
890 Perl_linklist(pTHX_ OP *o)
897 /* establish postfix order */
898 if (cUNOPo->op_first) {
899 o->op_next = LINKLIST(cUNOPo->op_first);
900 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
902 kid->op_next = LINKLIST(kid->op_sibling);
914 Perl_scalarkids(pTHX_ OP *o)
917 if (o && o->op_flags & OPf_KIDS) {
918 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
925 S_scalarboolean(pTHX_ OP *o)
927 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
928 if (ckWARN(WARN_SYNTAX)) {
929 line_t oldline = CopLINE(PL_curcop);
931 if (PL_copline != NOLINE)
932 CopLINE_set(PL_curcop, PL_copline);
933 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
934 CopLINE_set(PL_curcop, oldline);
941 Perl_scalar(pTHX_ OP *o)
945 /* assumes no premature commitment */
946 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
947 || o->op_type == OP_RETURN)
952 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
954 switch (o->op_type) {
956 scalar(cBINOPo->op_first);
961 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
965 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
966 if (!kPMOP->op_pmreplroot)
967 deprecate("implicit split to @_");
975 if (o->op_flags & OPf_KIDS) {
976 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
982 kid = cLISTOPo->op_first;
984 while ((kid = kid->op_sibling)) {
990 WITH_THR(PL_curcop = &PL_compiling);
995 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1001 WITH_THR(PL_curcop = &PL_compiling);
1008 Perl_scalarvoid(pTHX_ OP *o)
1015 if (o->op_type == OP_NEXTSTATE
1016 || o->op_type == OP_SETSTATE
1017 || o->op_type == OP_DBSTATE
1018 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1019 || o->op_targ == OP_SETSTATE
1020 || o->op_targ == OP_DBSTATE)))
1021 PL_curcop = (COP*)o; /* for warning below */
1023 /* assumes no premature commitment */
1024 want = o->op_flags & OPf_WANT;
1025 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1026 || o->op_type == OP_RETURN)
1031 if ((o->op_private & OPpTARGET_MY)
1032 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1034 return scalar(o); /* As if inside SASSIGN */
1037 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1039 switch (o->op_type) {
1041 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1045 if (o->op_flags & OPf_STACKED)
1049 if (o->op_private == 4)
1091 case OP_GETSOCKNAME:
1092 case OP_GETPEERNAME:
1097 case OP_GETPRIORITY:
1120 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1121 useless = PL_op_desc[o->op_type];
1128 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1129 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1130 useless = "a variable";
1135 if (cSVOPo->op_private & OPpCONST_STRICT)
1136 no_bareword_allowed(o);
1138 if (ckWARN(WARN_VOID)) {
1139 useless = "a constant";
1140 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1142 else if (SvPOK(sv)) {
1143 /* perl4's way of mixing documentation and code
1144 (before the invention of POD) was based on a
1145 trick to mix nroff and perl code. The trick was
1146 built upon these three nroff macros being used in
1147 void context. The pink camel has the details in
1148 the script wrapman near page 319. */
1149 if (strnEQ(SvPVX(sv), "di", 2) ||
1150 strnEQ(SvPVX(sv), "ds", 2) ||
1151 strnEQ(SvPVX(sv), "ig", 2))
1156 null(o); /* don't execute or even remember it */
1160 o->op_type = OP_PREINC; /* pre-increment is faster */
1161 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1165 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1166 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1172 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1177 if (o->op_flags & OPf_STACKED)
1184 if (!(o->op_flags & OPf_KIDS))
1193 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1200 /* all requires must return a boolean value */
1201 o->op_flags &= ~OPf_WANT;
1206 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1207 if (!kPMOP->op_pmreplroot)
1208 deprecate("implicit split to @_");
1212 if (useless && ckWARN(WARN_VOID))
1213 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1218 Perl_listkids(pTHX_ OP *o)
1221 if (o && o->op_flags & OPf_KIDS) {
1222 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1229 Perl_list(pTHX_ OP *o)
1233 /* assumes no premature commitment */
1234 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1235 || o->op_type == OP_RETURN)
1240 if ((o->op_private & OPpTARGET_MY)
1241 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1243 return o; /* As if inside SASSIGN */
1246 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1248 switch (o->op_type) {
1251 list(cBINOPo->op_first);
1256 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1264 if (!(o->op_flags & OPf_KIDS))
1266 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1267 list(cBINOPo->op_first);
1268 return gen_constant_list(o);
1275 kid = cLISTOPo->op_first;
1277 while ((kid = kid->op_sibling)) {
1278 if (kid->op_sibling)
1283 WITH_THR(PL_curcop = &PL_compiling);
1287 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1288 if (kid->op_sibling)
1293 WITH_THR(PL_curcop = &PL_compiling);
1296 /* all requires must return a boolean value */
1297 o->op_flags &= ~OPf_WANT;
1304 Perl_scalarseq(pTHX_ OP *o)
1309 if (o->op_type == OP_LINESEQ ||
1310 o->op_type == OP_SCOPE ||
1311 o->op_type == OP_LEAVE ||
1312 o->op_type == OP_LEAVETRY)
1314 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1315 if (kid->op_sibling) {
1319 PL_curcop = &PL_compiling;
1321 o->op_flags &= ~OPf_PARENS;
1322 if (PL_hints & HINT_BLOCK_SCOPE)
1323 o->op_flags |= OPf_PARENS;
1326 o = newOP(OP_STUB, 0);
1331 S_modkids(pTHX_ OP *o, I32 type)
1334 if (o && o->op_flags & OPf_KIDS) {
1335 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1342 Perl_mod(pTHX_ OP *o, I32 type)
1347 if (!o || PL_error_count)
1350 if ((o->op_private & OPpTARGET_MY)
1351 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1356 switch (o->op_type) {
1361 if (o->op_private & (OPpCONST_BARE) &&
1362 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1363 SV *sv = ((SVOP*)o)->op_sv;
1366 /* Could be a filehandle */
1367 if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1368 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1372 /* OK, it's a sub */
1374 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1376 enter = newUNOP(OP_ENTERSUB,0,
1377 newUNOP(OP_RV2CV, 0,
1378 newGVOP(OP_GV, 0, gv)
1380 enter->op_private |= OPpLVAL_INTRO;
1386 if (!(o->op_private & (OPpCONST_ARYBASE)))
1388 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1389 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1393 SAVEI32(PL_compiling.cop_arybase);
1394 PL_compiling.cop_arybase = 0;
1396 else if (type == OP_REFGEN)
1399 Perl_croak(aTHX_ "That use of $[ is unsupported");
1402 if (o->op_flags & OPf_PARENS)
1406 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1407 !(o->op_flags & OPf_STACKED)) {
1408 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1409 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1410 assert(cUNOPo->op_first->op_type == OP_NULL);
1411 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1414 else { /* lvalue subroutine call */
1415 o->op_private |= OPpLVAL_INTRO;
1416 PL_modcount = RETURN_UNLIMITED_NUMBER;
1417 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1418 /* Backward compatibility mode: */
1419 o->op_private |= OPpENTERSUB_INARGS;
1422 else { /* Compile-time error message: */
1423 OP *kid = cUNOPo->op_first;
1427 if (kid->op_type == OP_PUSHMARK)
1429 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1431 "panic: unexpected lvalue entersub "
1432 "args: type/targ %ld:%ld",
1433 (long)kid->op_type,kid->op_targ);
1434 kid = kLISTOP->op_first;
1436 while (kid->op_sibling)
1437 kid = kid->op_sibling;
1438 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1440 if (kid->op_type == OP_METHOD_NAMED
1441 || kid->op_type == OP_METHOD)
1445 if (kid->op_sibling || kid->op_next != kid) {
1446 yyerror("panic: unexpected optree near method call");
1450 NewOp(1101, newop, 1, UNOP);
1451 newop->op_type = OP_RV2CV;
1452 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1453 newop->op_first = Nullop;
1454 newop->op_next = (OP*)newop;
1455 kid->op_sibling = (OP*)newop;
1456 newop->op_private |= OPpLVAL_INTRO;
1460 if (kid->op_type != OP_RV2CV)
1462 "panic: unexpected lvalue entersub "
1463 "entry via type/targ %ld:%ld",
1464 (long)kid->op_type,kid->op_targ);
1465 kid->op_private |= OPpLVAL_INTRO;
1466 break; /* Postpone until runtime */
1470 kid = kUNOP->op_first;
1471 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL)
1475 "Unexpected constant lvalue entersub "
1476 "entry via type/targ %ld:%ld",
1477 (long)kid->op_type,kid->op_targ);
1478 if (kid->op_type != OP_GV) {
1479 /* Restore RV2CV to check lvalueness */
1481 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1482 okid->op_next = kid->op_next;
1483 kid->op_next = okid;
1486 okid->op_next = Nullop;
1487 okid->op_type = OP_RV2CV;
1489 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1490 okid->op_private |= OPpLVAL_INTRO;
1494 cv = GvCV(kGVOP_gv);
1504 /* grep, foreach, subcalls, refgen */
1505 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1507 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1508 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1510 : (o->op_type == OP_ENTERSUB
1511 ? "non-lvalue subroutine call"
1512 : PL_op_desc[o->op_type])),
1513 type ? PL_op_desc[type] : "local"));
1527 case OP_RIGHT_SHIFT:
1536 if (!(o->op_flags & OPf_STACKED))
1542 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1548 if (!type && cUNOPo->op_first->op_type != OP_GV)
1549 Perl_croak(aTHX_ "Can't localize through a reference");
1550 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1551 PL_modcount = RETURN_UNLIMITED_NUMBER;
1552 return o; /* Treat \(@foo) like ordinary list. */
1556 if (scalar_mod_type(o, type))
1558 ref(cUNOPo->op_first, o->op_type);
1562 if (type == OP_LEAVESUBLV)
1563 o->op_private |= OPpMAYBE_LVSUB;
1569 PL_modcount = RETURN_UNLIMITED_NUMBER;
1572 if (!type && cUNOPo->op_first->op_type != OP_GV)
1573 Perl_croak(aTHX_ "Can't localize through a reference");
1574 ref(cUNOPo->op_first, o->op_type);
1578 PL_hints |= HINT_BLOCK_SCOPE;
1588 PL_modcount = RETURN_UNLIMITED_NUMBER;
1589 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1590 return o; /* Treat \(@foo) like ordinary list. */
1591 if (scalar_mod_type(o, type))
1593 if (type == OP_LEAVESUBLV)
1594 o->op_private |= OPpMAYBE_LVSUB;
1599 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1600 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1605 PL_modcount++; /* XXX ??? */
1607 #endif /* USE_THREADS */
1613 if (type != OP_SASSIGN)
1617 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1622 if (type == OP_LEAVESUBLV)
1623 o->op_private |= OPpMAYBE_LVSUB;
1625 pad_free(o->op_targ);
1626 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1627 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1628 if (o->op_flags & OPf_KIDS)
1629 mod(cBINOPo->op_first->op_sibling, type);
1634 ref(cBINOPo->op_first, o->op_type);
1635 if (type == OP_ENTERSUB &&
1636 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1637 o->op_private |= OPpLVAL_DEFER;
1638 if (type == OP_LEAVESUBLV)
1639 o->op_private |= OPpMAYBE_LVSUB;
1647 if (o->op_flags & OPf_KIDS)
1648 mod(cLISTOPo->op_last, type);
1652 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1654 else if (!(o->op_flags & OPf_KIDS))
1656 if (o->op_targ != OP_LIST) {
1657 mod(cBINOPo->op_first, type);
1662 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1667 if (type != OP_LEAVESUBLV)
1669 break; /* mod()ing was handled by ck_return() */
1671 if (type != OP_LEAVESUBLV)
1672 o->op_flags |= OPf_MOD;
1674 if (type == OP_AASSIGN || type == OP_SASSIGN)
1675 o->op_flags |= OPf_SPECIAL|OPf_REF;
1677 o->op_private |= OPpLVAL_INTRO;
1678 o->op_flags &= ~OPf_SPECIAL;
1679 PL_hints |= HINT_BLOCK_SCOPE;
1681 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1682 && type != OP_LEAVESUBLV)
1683 o->op_flags |= OPf_REF;
1688 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1692 if (o->op_type == OP_RV2GV)
1716 case OP_RIGHT_SHIFT:
1735 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1737 switch (o->op_type) {
1745 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1758 Perl_refkids(pTHX_ OP *o, I32 type)
1761 if (o && o->op_flags & OPf_KIDS) {
1762 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1769 Perl_ref(pTHX_ OP *o, I32 type)
1773 if (!o || PL_error_count)
1776 switch (o->op_type) {
1778 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1779 !(o->op_flags & OPf_STACKED)) {
1780 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1781 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1782 assert(cUNOPo->op_first->op_type == OP_NULL);
1783 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1784 o->op_flags |= OPf_SPECIAL;
1789 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1793 if (type == OP_DEFINED)
1794 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1795 ref(cUNOPo->op_first, o->op_type);
1798 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1799 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1800 : type == OP_RV2HV ? OPpDEREF_HV
1802 o->op_flags |= OPf_MOD;
1807 o->op_flags |= OPf_MOD; /* XXX ??? */
1812 o->op_flags |= OPf_REF;
1815 if (type == OP_DEFINED)
1816 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1817 ref(cUNOPo->op_first, o->op_type);
1822 o->op_flags |= OPf_REF;
1827 if (!(o->op_flags & OPf_KIDS))
1829 ref(cBINOPo->op_first, type);
1833 ref(cBINOPo->op_first, o->op_type);
1834 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1835 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1836 : type == OP_RV2HV ? OPpDEREF_HV
1838 o->op_flags |= OPf_MOD;
1846 if (!(o->op_flags & OPf_KIDS))
1848 ref(cLISTOPo->op_last, type);
1858 S_dup_attrlist(pTHX_ OP *o)
1862 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1863 * where the first kid is OP_PUSHMARK and the remaining ones
1864 * are OP_CONST. We need to push the OP_CONST values.
1866 if (o->op_type == OP_CONST)
1867 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1869 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1870 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1871 if (o->op_type == OP_CONST)
1872 rop = append_elem(OP_LIST, rop,
1873 newSVOP(OP_CONST, o->op_flags,
1874 SvREFCNT_inc(cSVOPo->op_sv)));
1881 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1885 /* fake up C<use attributes $pkg,$rv,@attrs> */
1886 ENTER; /* need to protect against side-effects of 'use' */
1888 if (stash && HvNAME(stash))
1889 stashsv = newSVpv(HvNAME(stash), 0);
1891 stashsv = &PL_sv_no;
1893 #define ATTRSMODULE "attributes"
1895 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1896 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1898 prepend_elem(OP_LIST,
1899 newSVOP(OP_CONST, 0, stashsv),
1900 prepend_elem(OP_LIST,
1901 newSVOP(OP_CONST, 0,
1903 dup_attrlist(attrs))));
1908 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1909 char *attrstr, STRLEN len)
1914 len = strlen(attrstr);
1918 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1920 char *sstr = attrstr;
1921 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1922 attrs = append_elem(OP_LIST, attrs,
1923 newSVOP(OP_CONST, 0,
1924 newSVpvn(sstr, attrstr-sstr)));
1928 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1929 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1930 Nullsv, prepend_elem(OP_LIST,
1931 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1932 prepend_elem(OP_LIST,
1933 newSVOP(OP_CONST, 0,
1939 S_my_kid(pTHX_ OP *o, OP *attrs)
1944 if (!o || PL_error_count)
1948 if (type == OP_LIST) {
1949 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1951 } else if (type == OP_UNDEF) {
1953 } else if (type == OP_RV2SV || /* "our" declaration */
1955 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1957 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1959 PL_in_my_stash = Nullhv;
1960 apply_attrs(GvSTASH(gv),
1961 (type == OP_RV2SV ? GvSV(gv) :
1962 type == OP_RV2AV ? (SV*)GvAV(gv) :
1963 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1966 o->op_private |= OPpOUR_INTRO;
1968 } else if (type != OP_PADSV &&
1971 type != OP_PUSHMARK)
1973 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1974 PL_op_desc[o->op_type],
1975 PL_in_my == KEY_our ? "our" : "my"));
1978 else if (attrs && type != OP_PUSHMARK) {
1984 PL_in_my_stash = Nullhv;
1986 /* check for C<my Dog $spot> when deciding package */
1987 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1988 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1989 stash = SvSTASH(*namesvp);
1991 stash = PL_curstash;
1992 padsv = PAD_SV(o->op_targ);
1993 apply_attrs(stash, padsv, attrs);
1995 o->op_flags |= OPf_MOD;
1996 o->op_private |= OPpLVAL_INTRO;
2001 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2003 if (o->op_flags & OPf_PARENS)
2007 o = my_kid(o, attrs);
2009 PL_in_my_stash = Nullhv;
2014 Perl_my(pTHX_ OP *o)
2016 return my_kid(o, Nullop);
2020 Perl_sawparens(pTHX_ OP *o)
2023 o->op_flags |= OPf_PARENS;
2028 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2032 if (ckWARN(WARN_MISC) &&
2033 (left->op_type == OP_RV2AV ||
2034 left->op_type == OP_RV2HV ||
2035 left->op_type == OP_PADAV ||
2036 left->op_type == OP_PADHV)) {
2037 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2038 right->op_type == OP_TRANS)
2039 ? right->op_type : OP_MATCH];
2040 const char *sample = ((left->op_type == OP_RV2AV ||
2041 left->op_type == OP_PADAV)
2042 ? "@array" : "%hash");
2043 Perl_warner(aTHX_ WARN_MISC,
2044 "Applying %s to %s will act on scalar(%s)",
2045 desc, sample, sample);
2048 if (!(right->op_flags & OPf_STACKED) &&
2049 (right->op_type == OP_MATCH ||
2050 right->op_type == OP_SUBST ||
2051 right->op_type == OP_TRANS)) {
2052 right->op_flags |= OPf_STACKED;
2053 if (right->op_type != OP_MATCH &&
2054 ! (right->op_type == OP_TRANS &&
2055 right->op_private & OPpTRANS_IDENTICAL))
2056 left = mod(left, right->op_type);
2057 if (right->op_type == OP_TRANS)
2058 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2060 o = prepend_elem(right->op_type, scalar(left), right);
2062 return newUNOP(OP_NOT, 0, scalar(o));
2066 return bind_match(type, left,
2067 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2071 Perl_invert(pTHX_ OP *o)
2075 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2076 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2080 Perl_scope(pTHX_ OP *o)
2083 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2084 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2085 o->op_type = OP_LEAVE;
2086 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2089 if (o->op_type == OP_LINESEQ) {
2091 o->op_type = OP_SCOPE;
2092 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2093 kid = ((LISTOP*)o)->op_first;
2094 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2098 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2105 Perl_save_hints(pTHX)
2108 SAVESPTR(GvHV(PL_hintgv));
2109 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2110 SAVEFREESV(GvHV(PL_hintgv));
2114 Perl_block_start(pTHX_ int full)
2116 int retval = PL_savestack_ix;
2118 SAVEI32(PL_comppad_name_floor);
2119 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2121 PL_comppad_name_fill = PL_comppad_name_floor;
2122 if (PL_comppad_name_floor < 0)
2123 PL_comppad_name_floor = 0;
2124 SAVEI32(PL_min_intro_pending);
2125 SAVEI32(PL_max_intro_pending);
2126 PL_min_intro_pending = 0;
2127 SAVEI32(PL_comppad_name_fill);
2128 SAVEI32(PL_padix_floor);
2129 PL_padix_floor = PL_padix;
2130 PL_pad_reset_pending = FALSE;
2132 PL_hints &= ~HINT_BLOCK_SCOPE;
2133 SAVESPTR(PL_compiling.cop_warnings);
2134 if (! specialWARN(PL_compiling.cop_warnings)) {
2135 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2136 SAVEFREESV(PL_compiling.cop_warnings) ;
2138 SAVESPTR(PL_compiling.cop_io);
2139 if (! specialCopIO(PL_compiling.cop_io)) {
2140 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2141 SAVEFREESV(PL_compiling.cop_io) ;
2147 Perl_block_end(pTHX_ I32 floor, OP *seq)
2149 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2150 OP* retval = scalarseq(seq);
2152 PL_pad_reset_pending = FALSE;
2153 PL_compiling.op_private = PL_hints;
2155 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2156 pad_leavemy(PL_comppad_name_fill);
2165 OP *o = newOP(OP_THREADSV, 0);
2166 o->op_targ = find_threadsv("_");
2169 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2170 #endif /* USE_THREADS */
2174 Perl_newPROG(pTHX_ OP *o)
2179 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2180 ((PL_in_eval & EVAL_KEEPERR)
2181 ? OPf_SPECIAL : 0), o);
2182 PL_eval_start = linklist(PL_eval_root);
2183 PL_eval_root->op_private |= OPpREFCOUNTED;
2184 OpREFCNT_set(PL_eval_root, 1);
2185 PL_eval_root->op_next = 0;
2186 peep(PL_eval_start);
2191 PL_main_root = scope(sawparens(scalarvoid(o)));
2192 PL_curcop = &PL_compiling;
2193 PL_main_start = LINKLIST(PL_main_root);
2194 PL_main_root->op_private |= OPpREFCOUNTED;
2195 OpREFCNT_set(PL_main_root, 1);
2196 PL_main_root->op_next = 0;
2197 peep(PL_main_start);
2200 /* Register with debugger */
2202 CV *cv = get_cv("DB::postponed", FALSE);
2206 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2208 call_sv((SV*)cv, G_DISCARD);
2215 Perl_localize(pTHX_ OP *o, I32 lex)
2217 if (o->op_flags & OPf_PARENS)
2220 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2222 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2223 if (*s == ';' || *s == '=')
2224 Perl_warner(aTHX_ WARN_PARENTHESIS,
2225 "Parentheses missing around \"%s\" list",
2226 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2232 o = mod(o, OP_NULL); /* a bit kludgey */
2234 PL_in_my_stash = Nullhv;
2239 Perl_jmaybe(pTHX_ OP *o)
2241 if (o->op_type == OP_LIST) {
2244 o2 = newOP(OP_THREADSV, 0);
2245 o2->op_targ = find_threadsv(";");
2247 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2248 #endif /* USE_THREADS */
2249 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2255 Perl_fold_constants(pTHX_ register OP *o)
2258 I32 type = o->op_type;
2261 if (PL_opargs[type] & OA_RETSCALAR)
2263 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2264 o->op_targ = pad_alloc(type, SVs_PADTMP);
2266 /* integerize op, unless it happens to be C<-foo>.
2267 * XXX should pp_i_negate() do magic string negation instead? */
2268 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2269 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2270 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2272 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2275 if (!(PL_opargs[type] & OA_FOLDCONST))
2280 /* XXX might want a ck_negate() for this */
2281 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2294 if (o->op_private & OPpLOCALE)
2299 goto nope; /* Don't try to run w/ errors */
2301 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2302 if ((curop->op_type != OP_CONST ||
2303 (curop->op_private & OPpCONST_BARE)) &&
2304 curop->op_type != OP_LIST &&
2305 curop->op_type != OP_SCALAR &&
2306 curop->op_type != OP_NULL &&
2307 curop->op_type != OP_PUSHMARK)
2313 curop = LINKLIST(o);
2317 sv = *(PL_stack_sp--);
2318 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2319 pad_swipe(o->op_targ);
2320 else if (SvTEMP(sv)) { /* grab mortal temp? */
2321 (void)SvREFCNT_inc(sv);
2325 if (type == OP_RV2GV)
2326 return newGVOP(OP_GV, 0, (GV*)sv);
2328 /* try to smush double to int, but don't smush -2.0 to -2 */
2329 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2332 #ifdef PERL_PRESERVE_IVUV
2333 /* Only bother to attempt to fold to IV if
2334 most operators will benefit */
2338 return newSVOP(OP_CONST, 0, sv);
2342 if (!(PL_opargs[type] & OA_OTHERINT))
2345 if (!(PL_hints & HINT_INTEGER)) {
2346 if (type == OP_MODULO
2347 || type == OP_DIVIDE
2348 || !(o->op_flags & OPf_KIDS))
2353 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2354 if (curop->op_type == OP_CONST) {
2355 if (SvIOK(((SVOP*)curop)->op_sv))
2359 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2363 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2370 Perl_gen_constant_list(pTHX_ register OP *o)
2373 I32 oldtmps_floor = PL_tmps_floor;
2377 return o; /* Don't attempt to run with errors */
2379 PL_op = curop = LINKLIST(o);
2386 PL_tmps_floor = oldtmps_floor;
2388 o->op_type = OP_RV2AV;
2389 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2390 curop = ((UNOP*)o)->op_first;
2391 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2398 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2400 if (!o || o->op_type != OP_LIST)
2401 o = newLISTOP(OP_LIST, 0, o, Nullop);
2403 o->op_flags &= ~OPf_WANT;
2405 if (!(PL_opargs[type] & OA_MARK))
2406 null(cLISTOPo->op_first);
2409 o->op_ppaddr = PL_ppaddr[type];
2410 o->op_flags |= flags;
2412 o = CHECKOP(type, o);
2413 if (o->op_type != type)
2416 return fold_constants(o);
2419 /* List constructors */
2422 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2430 if (first->op_type != type
2431 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2433 return newLISTOP(type, 0, first, last);
2436 if (first->op_flags & OPf_KIDS)
2437 ((LISTOP*)first)->op_last->op_sibling = last;
2439 first->op_flags |= OPf_KIDS;
2440 ((LISTOP*)first)->op_first = last;
2442 ((LISTOP*)first)->op_last = last;
2447 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2455 if (first->op_type != type)
2456 return prepend_elem(type, (OP*)first, (OP*)last);
2458 if (last->op_type != type)
2459 return append_elem(type, (OP*)first, (OP*)last);
2461 first->op_last->op_sibling = last->op_first;
2462 first->op_last = last->op_last;
2463 first->op_flags |= (last->op_flags & OPf_KIDS);
2465 #ifdef PL_OP_SLAB_ALLOC
2473 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2481 if (last->op_type == type) {
2482 if (type == OP_LIST) { /* already a PUSHMARK there */
2483 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2484 ((LISTOP*)last)->op_first->op_sibling = first;
2485 if (!(first->op_flags & OPf_PARENS))
2486 last->op_flags &= ~OPf_PARENS;
2489 if (!(last->op_flags & OPf_KIDS)) {
2490 ((LISTOP*)last)->op_last = first;
2491 last->op_flags |= OPf_KIDS;
2493 first->op_sibling = ((LISTOP*)last)->op_first;
2494 ((LISTOP*)last)->op_first = first;
2496 last->op_flags |= OPf_KIDS;
2500 return newLISTOP(type, 0, first, last);
2506 Perl_newNULLLIST(pTHX)
2508 return newOP(OP_STUB, 0);
2512 Perl_force_list(pTHX_ OP *o)
2514 if (!o || o->op_type != OP_LIST)
2515 o = newLISTOP(OP_LIST, 0, o, Nullop);
2521 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2525 NewOp(1101, listop, 1, LISTOP);
2527 listop->op_type = type;
2528 listop->op_ppaddr = PL_ppaddr[type];
2531 listop->op_flags = flags;
2535 else if (!first && last)
2538 first->op_sibling = last;
2539 listop->op_first = first;
2540 listop->op_last = last;
2541 if (type == OP_LIST) {
2543 pushop = newOP(OP_PUSHMARK, 0);
2544 pushop->op_sibling = first;
2545 listop->op_first = pushop;
2546 listop->op_flags |= OPf_KIDS;
2548 listop->op_last = pushop;
2555 Perl_newOP(pTHX_ I32 type, I32 flags)
2558 NewOp(1101, o, 1, OP);
2560 o->op_ppaddr = PL_ppaddr[type];
2561 o->op_flags = flags;
2564 o->op_private = 0 + (flags >> 8);
2565 if (PL_opargs[type] & OA_RETSCALAR)
2567 if (PL_opargs[type] & OA_TARGET)
2568 o->op_targ = pad_alloc(type, SVs_PADTMP);
2569 return CHECKOP(type, o);
2573 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2578 first = newOP(OP_STUB, 0);
2579 if (PL_opargs[type] & OA_MARK)
2580 first = force_list(first);
2582 NewOp(1101, unop, 1, UNOP);
2583 unop->op_type = type;
2584 unop->op_ppaddr = PL_ppaddr[type];
2585 unop->op_first = first;
2586 unop->op_flags = flags | OPf_KIDS;
2587 unop->op_private = 1 | (flags >> 8);
2588 unop = (UNOP*) CHECKOP(type, unop);
2592 return fold_constants((OP *) unop);
2596 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2599 NewOp(1101, binop, 1, BINOP);
2602 first = newOP(OP_NULL, 0);
2604 binop->op_type = type;
2605 binop->op_ppaddr = PL_ppaddr[type];
2606 binop->op_first = first;
2607 binop->op_flags = flags | OPf_KIDS;
2610 binop->op_private = 1 | (flags >> 8);
2613 binop->op_private = 2 | (flags >> 8);
2614 first->op_sibling = last;
2617 binop = (BINOP*)CHECKOP(type, binop);
2618 if (binop->op_next || binop->op_type != type)
2621 binop->op_last = binop->op_first->op_sibling;
2623 return fold_constants((OP *)binop);
2627 uvcompare(const void *a, const void *b)
2629 if (*((UV *)a) < (*(UV *)b))
2631 if (*((UV *)a) > (*(UV *)b))
2633 if (*((UV *)a+1) < (*(UV *)b+1))
2635 if (*((UV *)a+1) > (*(UV *)b+1))
2641 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2643 SV *tstr = ((SVOP*)expr)->op_sv;
2644 SV *rstr = ((SVOP*)repl)->op_sv;
2647 U8 *t = (U8*)SvPV(tstr, tlen);
2648 U8 *r = (U8*)SvPV(rstr, rlen);
2655 register short *tbl;
2657 complement = o->op_private & OPpTRANS_COMPLEMENT;
2658 del = o->op_private & OPpTRANS_DELETE;
2659 squash = o->op_private & OPpTRANS_SQUASH;
2662 o->op_private |= OPpTRANS_FROM_UTF;
2665 o->op_private |= OPpTRANS_TO_UTF;
2667 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2668 SV* listsv = newSVpvn("# comment\n",10);
2670 U8* tend = t + tlen;
2671 U8* rend = r + rlen;
2685 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2686 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2692 tsave = t = bytes_to_utf8(t, &len);
2695 if (!to_utf && rlen) {
2697 rsave = r = bytes_to_utf8(r, &len);
2701 /* There are several snags with this code on EBCDIC:
2702 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2703 2. scan_const() in toke.c has encoded chars in native encoding which makes
2704 ranges at least in EBCDIC 0..255 range the bottom odd.
2708 U8 tmpbuf[UTF8_MAXLEN+1];
2711 New(1109, cp, 2*tlen, UV);
2713 transv = newSVpvn("",0);
2715 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2717 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2719 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2723 cp[2*i+1] = cp[2*i];
2727 qsort(cp, i, 2*sizeof(UV), uvcompare);
2728 for (j = 0; j < i; j++) {
2730 diff = val - nextmin;
2732 t = uvuni_to_utf8(tmpbuf,nextmin);
2733 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2735 U8 range_mark = UTF_TO_NATIVE(0xff);
2736 t = uvuni_to_utf8(tmpbuf, val - 1);
2737 sv_catpvn(transv, (char *)&range_mark, 1);
2738 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2745 t = uvuni_to_utf8(tmpbuf,nextmin);
2746 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2748 U8 range_mark = UTF_TO_NATIVE(0xff);
2749 sv_catpvn(transv, (char *)&range_mark, 1);
2751 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2752 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2753 t = (U8*)SvPVX(transv);
2754 tlen = SvCUR(transv);
2758 else if (!rlen && !del) {
2759 r = t; rlen = tlen; rend = tend;
2762 if ((!rlen && !del) || t == r ||
2763 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2765 o->op_private |= OPpTRANS_IDENTICAL;
2769 while (t < tend || tfirst <= tlast) {
2770 /* see if we need more "t" chars */
2771 if (tfirst > tlast) {
2772 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2774 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2776 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2783 /* now see if we need more "r" chars */
2784 if (rfirst > rlast) {
2786 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2788 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2790 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2799 rfirst = rlast = 0xffffffff;
2803 /* now see which range will peter our first, if either. */
2804 tdiff = tlast - tfirst;
2805 rdiff = rlast - rfirst;
2812 if (rfirst == 0xffffffff) {
2813 diff = tdiff; /* oops, pretend rdiff is infinite */
2815 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2816 (long)tfirst, (long)tlast);
2818 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2822 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2823 (long)tfirst, (long)(tfirst + diff),
2826 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2827 (long)tfirst, (long)rfirst);
2829 if (rfirst + diff > max)
2830 max = rfirst + diff;
2832 grows = (tfirst < rfirst &&
2833 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2845 else if (max > 0xff)
2850 Safefree(cPVOPo->op_pv);
2851 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2852 SvREFCNT_dec(listsv);
2854 SvREFCNT_dec(transv);
2856 if (!del && havefinal && rlen)
2857 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2858 newSVuv((UV)final), 0);
2861 o->op_private |= OPpTRANS_GROWS;
2873 tbl = (short*)cPVOPo->op_pv;
2875 Zero(tbl, 256, short);
2876 for (i = 0; i < tlen; i++)
2878 for (i = 0, j = 0; i < 256; i++) {
2889 if (i < 128 && r[j] >= 128)
2899 o->op_private |= OPpTRANS_IDENTICAL;
2904 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2905 tbl[0x100] = rlen - j;
2906 for (i=0; i < rlen - j; i++)
2907 tbl[0x101+i] = r[j+i];
2911 if (!rlen && !del) {
2914 o->op_private |= OPpTRANS_IDENTICAL;
2916 for (i = 0; i < 256; i++)
2918 for (i = 0, j = 0; i < tlen; i++,j++) {
2921 if (tbl[t[i]] == -1)
2927 if (tbl[t[i]] == -1) {
2928 if (t[i] < 128 && r[j] >= 128)
2935 o->op_private |= OPpTRANS_GROWS;
2943 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2947 NewOp(1101, pmop, 1, PMOP);
2948 pmop->op_type = type;
2949 pmop->op_ppaddr = PL_ppaddr[type];
2950 pmop->op_flags = flags;
2951 pmop->op_private = 0 | (flags >> 8);
2953 if (PL_hints & HINT_RE_TAINT)
2954 pmop->op_pmpermflags |= PMf_RETAINT;
2955 if (PL_hints & HINT_LOCALE)
2956 pmop->op_pmpermflags |= PMf_LOCALE;
2957 pmop->op_pmflags = pmop->op_pmpermflags;
2959 /* link into pm list */
2960 if (type != OP_TRANS && PL_curstash) {
2961 pmop->op_pmnext = HvPMROOT(PL_curstash);
2962 HvPMROOT(PL_curstash) = pmop;
2963 PmopSTASH_set(pmop,PL_curstash);
2970 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2974 I32 repl_has_vars = 0;
2976 if (o->op_type == OP_TRANS)
2977 return pmtrans(o, expr, repl);
2979 PL_hints |= HINT_BLOCK_SCOPE;
2982 if (expr->op_type == OP_CONST) {
2984 SV *pat = ((SVOP*)expr)->op_sv;
2985 char *p = SvPV(pat, plen);
2986 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2987 sv_setpvn(pat, "\\s+", 3);
2988 p = SvPV(pat, plen);
2989 pm->op_pmflags |= PMf_SKIPWHITE;
2991 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2992 pm->op_pmdynflags |= PMdf_UTF8;
2993 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2994 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2995 pm->op_pmflags |= PMf_WHITE;
2999 if (PL_hints & HINT_UTF8)
3000 pm->op_pmdynflags |= PMdf_UTF8;
3001 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3002 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3004 : OP_REGCMAYBE),0,expr);
3006 NewOp(1101, rcop, 1, LOGOP);
3007 rcop->op_type = OP_REGCOMP;
3008 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3009 rcop->op_first = scalar(expr);
3010 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3011 ? (OPf_SPECIAL | OPf_KIDS)
3013 rcop->op_private = 1;
3016 /* establish postfix order */
3017 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3019 rcop->op_next = expr;
3020 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3023 rcop->op_next = LINKLIST(expr);
3024 expr->op_next = (OP*)rcop;
3027 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3032 if (pm->op_pmflags & PMf_EVAL) {
3034 if (CopLINE(PL_curcop) < PL_multi_end)
3035 CopLINE_set(PL_curcop, PL_multi_end);
3038 else if (repl->op_type == OP_THREADSV
3039 && strchr("&`'123456789+",
3040 PL_threadsv_names[repl->op_targ]))
3044 #endif /* USE_THREADS */
3045 else if (repl->op_type == OP_CONST)
3049 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3050 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3052 if (curop->op_type == OP_THREADSV) {
3054 if (strchr("&`'123456789+", curop->op_private))
3058 if (curop->op_type == OP_GV) {
3059 GV *gv = cGVOPx_gv(curop);
3061 if (strchr("&`'123456789+", *GvENAME(gv)))
3064 #endif /* USE_THREADS */
3065 else if (curop->op_type == OP_RV2CV)
3067 else if (curop->op_type == OP_RV2SV ||
3068 curop->op_type == OP_RV2AV ||
3069 curop->op_type == OP_RV2HV ||
3070 curop->op_type == OP_RV2GV) {
3071 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3074 else if (curop->op_type == OP_PADSV ||
3075 curop->op_type == OP_PADAV ||
3076 curop->op_type == OP_PADHV ||
3077 curop->op_type == OP_PADANY) {
3080 else if (curop->op_type == OP_PUSHRE)
3081 ; /* Okay here, dangerous in newASSIGNOP */
3090 && (!pm->op_pmregexp
3091 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3092 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3093 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3094 prepend_elem(o->op_type, scalar(repl), o);
3097 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3098 pm->op_pmflags |= PMf_MAYBE_CONST;
3099 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3101 NewOp(1101, rcop, 1, LOGOP);
3102 rcop->op_type = OP_SUBSTCONT;
3103 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3104 rcop->op_first = scalar(repl);
3105 rcop->op_flags |= OPf_KIDS;
3106 rcop->op_private = 1;
3109 /* establish postfix order */
3110 rcop->op_next = LINKLIST(repl);
3111 repl->op_next = (OP*)rcop;
3113 pm->op_pmreplroot = scalar((OP*)rcop);
3114 pm->op_pmreplstart = LINKLIST(rcop);
3123 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3126 NewOp(1101, svop, 1, SVOP);
3127 svop->op_type = type;
3128 svop->op_ppaddr = PL_ppaddr[type];
3130 svop->op_next = (OP*)svop;
3131 svop->op_flags = flags;
3132 if (PL_opargs[type] & OA_RETSCALAR)
3134 if (PL_opargs[type] & OA_TARGET)
3135 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3136 return CHECKOP(type, svop);
3140 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3143 NewOp(1101, padop, 1, PADOP);
3144 padop->op_type = type;
3145 padop->op_ppaddr = PL_ppaddr[type];
3146 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3147 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3148 PL_curpad[padop->op_padix] = sv;
3150 padop->op_next = (OP*)padop;
3151 padop->op_flags = flags;
3152 if (PL_opargs[type] & OA_RETSCALAR)
3154 if (PL_opargs[type] & OA_TARGET)
3155 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3156 return CHECKOP(type, padop);
3160 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3164 return newPADOP(type, flags, SvREFCNT_inc(gv));
3166 return newSVOP(type, flags, SvREFCNT_inc(gv));
3171 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3174 NewOp(1101, pvop, 1, PVOP);
3175 pvop->op_type = type;
3176 pvop->op_ppaddr = PL_ppaddr[type];
3178 pvop->op_next = (OP*)pvop;
3179 pvop->op_flags = flags;
3180 if (PL_opargs[type] & OA_RETSCALAR)
3182 if (PL_opargs[type] & OA_TARGET)
3183 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3184 return CHECKOP(type, pvop);
3188 Perl_package(pTHX_ OP *o)
3192 save_hptr(&PL_curstash);
3193 save_item(PL_curstname);
3198 name = SvPV(sv, len);
3199 PL_curstash = gv_stashpvn(name,len,TRUE);
3200 sv_setpvn(PL_curstname, name, len);
3204 sv_setpv(PL_curstname,"<none>");
3205 PL_curstash = Nullhv;
3207 PL_hints |= HINT_BLOCK_SCOPE;
3208 PL_copline = NOLINE;
3213 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3221 if (id->op_type != OP_CONST)
3222 Perl_croak(aTHX_ "Module name must be constant");
3226 if (version != Nullop) {
3227 SV *vesv = ((SVOP*)version)->op_sv;
3229 if (arg == Nullop && !SvNIOKp(vesv)) {
3236 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3237 Perl_croak(aTHX_ "Version number must be constant number");
3239 /* Make copy of id so we don't free it twice */
3240 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3242 /* Fake up a method call to VERSION */
3243 meth = newSVpvn("VERSION",7);
3244 sv_upgrade(meth, SVt_PVIV);
3245 (void)SvIOK_on(meth);
3246 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3247 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3248 append_elem(OP_LIST,
3249 prepend_elem(OP_LIST, pack, list(version)),
3250 newSVOP(OP_METHOD_NAMED, 0, meth)));
3254 /* Fake up an import/unimport */
3255 if (arg && arg->op_type == OP_STUB)
3256 imop = arg; /* no import on explicit () */
3257 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3258 imop = Nullop; /* use 5.0; */
3263 /* Make copy of id so we don't free it twice */
3264 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3266 /* Fake up a method call to import/unimport */
3267 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3268 sv_upgrade(meth, SVt_PVIV);
3269 (void)SvIOK_on(meth);
3270 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3271 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3272 append_elem(OP_LIST,
3273 prepend_elem(OP_LIST, pack, list(arg)),
3274 newSVOP(OP_METHOD_NAMED, 0, meth)));
3277 /* Fake up a require, handle override, if any */
3278 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3279 if (!(gv && GvIMPORTED_CV(gv)))
3280 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3282 if (gv && GvIMPORTED_CV(gv)) {
3283 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3284 append_elem(OP_LIST, id,
3285 scalar(newUNOP(OP_RV2CV, 0,
3290 rqop = newUNOP(OP_REQUIRE, 0, id);
3293 /* Fake up the BEGIN {}, which does its thing immediately. */
3295 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3298 append_elem(OP_LINESEQ,
3299 append_elem(OP_LINESEQ,
3300 newSTATEOP(0, Nullch, rqop),
3301 newSTATEOP(0, Nullch, veop)),
3302 newSTATEOP(0, Nullch, imop) ));
3304 PL_hints |= HINT_BLOCK_SCOPE;
3305 PL_copline = NOLINE;
3310 =for apidoc load_module
3312 Loads the module whose name is pointed to by the string part of name.
3313 Note that the actual module name, not its filename, should be given.
3314 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3315 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3316 (or 0 for no flags). ver, if specified, provides version semantics
3317 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3318 arguments can be used to specify arguments to the module's import()
3319 method, similar to C<use Foo::Bar VERSION LIST>.
3324 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3327 va_start(args, ver);
3328 vload_module(flags, name, ver, &args);
3332 #ifdef PERL_IMPLICIT_CONTEXT
3334 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3338 va_start(args, ver);
3339 vload_module(flags, name, ver, &args);
3345 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3347 OP *modname, *veop, *imop;
3349 modname = newSVOP(OP_CONST, 0, name);
3350 modname->op_private |= OPpCONST_BARE;
3352 veop = newSVOP(OP_CONST, 0, ver);
3356 if (flags & PERL_LOADMOD_NOIMPORT) {
3357 imop = sawparens(newNULLLIST());
3359 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3360 imop = va_arg(*args, OP*);
3365 sv = va_arg(*args, SV*);
3367 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3368 sv = va_arg(*args, SV*);
3372 line_t ocopline = PL_copline;
3373 int oexpect = PL_expect;
3375 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3376 veop, modname, imop);
3377 PL_expect = oexpect;
3378 PL_copline = ocopline;
3383 Perl_dofile(pTHX_ OP *term)
3388 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3389 if (!(gv && GvIMPORTED_CV(gv)))
3390 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3392 if (gv && GvIMPORTED_CV(gv)) {
3393 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3394 append_elem(OP_LIST, term,
3395 scalar(newUNOP(OP_RV2CV, 0,
3400 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3406 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3408 return newBINOP(OP_LSLICE, flags,
3409 list(force_list(subscript)),
3410 list(force_list(listval)) );
3414 S_list_assignment(pTHX_ register OP *o)
3419 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3420 o = cUNOPo->op_first;
3422 if (o->op_type == OP_COND_EXPR) {
3423 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3424 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3429 yyerror("Assignment to both a list and a scalar");
3433 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3434 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3435 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3438 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3441 if (o->op_type == OP_RV2SV)
3448 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3453 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3454 return newLOGOP(optype, 0,
3455 mod(scalar(left), optype),
3456 newUNOP(OP_SASSIGN, 0, scalar(right)));
3459 return newBINOP(optype, OPf_STACKED,
3460 mod(scalar(left), optype), scalar(right));
3464 if (list_assignment(left)) {
3468 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3469 left = mod(left, OP_AASSIGN);
3477 curop = list(force_list(left));
3478 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3479 o->op_private = 0 | (flags >> 8);
3480 for (curop = ((LISTOP*)curop)->op_first;
3481 curop; curop = curop->op_sibling)
3483 if (curop->op_type == OP_RV2HV &&
3484 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3485 o->op_private |= OPpASSIGN_HASH;
3489 if (!(left->op_private & OPpLVAL_INTRO)) {
3492 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3493 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3494 if (curop->op_type == OP_GV) {
3495 GV *gv = cGVOPx_gv(curop);
3496 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3498 SvCUR(gv) = PL_generation;
3500 else if (curop->op_type == OP_PADSV ||
3501 curop->op_type == OP_PADAV ||
3502 curop->op_type == OP_PADHV ||
3503 curop->op_type == OP_PADANY) {
3504 SV **svp = AvARRAY(PL_comppad_name);
3505 SV *sv = svp[curop->op_targ];
3506 if (SvCUR(sv) == PL_generation)
3508 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3510 else if (curop->op_type == OP_RV2CV)
3512 else if (curop->op_type == OP_RV2SV ||
3513 curop->op_type == OP_RV2AV ||
3514 curop->op_type == OP_RV2HV ||
3515 curop->op_type == OP_RV2GV) {
3516 if (lastop->op_type != OP_GV) /* funny deref? */
3519 else if (curop->op_type == OP_PUSHRE) {
3520 if (((PMOP*)curop)->op_pmreplroot) {
3522 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3524 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3526 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3528 SvCUR(gv) = PL_generation;
3537 o->op_private |= OPpASSIGN_COMMON;
3539 if (right && right->op_type == OP_SPLIT) {
3541 if ((tmpop = ((LISTOP*)right)->op_first) &&
3542 tmpop->op_type == OP_PUSHRE)
3544 PMOP *pm = (PMOP*)tmpop;
3545 if (left->op_type == OP_RV2AV &&
3546 !(left->op_private & OPpLVAL_INTRO) &&
3547 !(o->op_private & OPpASSIGN_COMMON) )
3549 tmpop = ((UNOP*)left)->op_first;
3550 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3552 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3553 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3555 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3556 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3558 pm->op_pmflags |= PMf_ONCE;
3559 tmpop = cUNOPo->op_first; /* to list (nulled) */
3560 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3561 tmpop->op_sibling = Nullop; /* don't free split */
3562 right->op_next = tmpop->op_next; /* fix starting loc */
3563 op_free(o); /* blow off assign */
3564 right->op_flags &= ~OPf_WANT;
3565 /* "I don't know and I don't care." */
3570 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3571 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3573 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3575 sv_setiv(sv, PL_modcount+1);
3583 right = newOP(OP_UNDEF, 0);
3584 if (right->op_type == OP_READLINE) {
3585 right->op_flags |= OPf_STACKED;
3586 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3589 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3590 o = newBINOP(OP_SASSIGN, flags,
3591 scalar(right), mod(scalar(left), OP_SASSIGN) );
3603 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3605 U32 seq = intro_my();
3608 NewOp(1101, cop, 1, COP);
3609 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3610 cop->op_type = OP_DBSTATE;
3611 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3614 cop->op_type = OP_NEXTSTATE;
3615 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3617 cop->op_flags = flags;
3618 cop->op_private = (PL_hints & HINT_BYTE);
3620 cop->op_private |= NATIVE_HINTS;
3622 PL_compiling.op_private = cop->op_private;
3623 cop->op_next = (OP*)cop;
3626 cop->cop_label = label;
3627 PL_hints |= HINT_BLOCK_SCOPE;
3630 cop->cop_arybase = PL_curcop->cop_arybase;
3631 if (specialWARN(PL_curcop->cop_warnings))
3632 cop->cop_warnings = PL_curcop->cop_warnings ;
3634 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3635 if (specialCopIO(PL_curcop->cop_io))
3636 cop->cop_io = PL_curcop->cop_io;
3638 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3641 if (PL_copline == NOLINE)
3642 CopLINE_set(cop, CopLINE(PL_curcop));
3644 CopLINE_set(cop, PL_copline);
3645 PL_copline = NOLINE;
3648 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3650 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3652 CopSTASH_set(cop, PL_curstash);
3654 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3655 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3656 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3657 (void)SvIOK_on(*svp);
3658 SvIVX(*svp) = PTR2IV(cop);
3662 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3665 /* "Introduce" my variables to visible status. */
3673 if (! PL_min_intro_pending)
3674 return PL_cop_seqmax;
3676 svp = AvARRAY(PL_comppad_name);
3677 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3678 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3679 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3680 SvNVX(sv) = (NV)PL_cop_seqmax;
3683 PL_min_intro_pending = 0;
3684 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3685 return PL_cop_seqmax++;
3689 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3691 return new_logop(type, flags, &first, &other);
3695 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3699 OP *first = *firstp;
3700 OP *other = *otherp;
3702 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3703 return newBINOP(type, flags, scalar(first), scalar(other));
3705 scalarboolean(first);
3706 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3707 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3708 if (type == OP_AND || type == OP_OR) {
3714 first = *firstp = cUNOPo->op_first;
3716 first->op_next = o->op_next;
3717 cUNOPo->op_first = Nullop;
3721 if (first->op_type == OP_CONST) {
3722 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3723 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3724 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3735 else if (first->op_type == OP_WANTARRAY) {
3741 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3742 OP *k1 = ((UNOP*)first)->op_first;
3743 OP *k2 = k1->op_sibling;
3745 switch (first->op_type)
3748 if (k2 && k2->op_type == OP_READLINE
3749 && (k2->op_flags & OPf_STACKED)
3750 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3752 warnop = k2->op_type;
3757 if (k1->op_type == OP_READDIR
3758 || k1->op_type == OP_GLOB
3759 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3760 || k1->op_type == OP_EACH)
3762 warnop = ((k1->op_type == OP_NULL)
3763 ? k1->op_targ : k1->op_type);
3768 line_t oldline = CopLINE(PL_curcop);
3769 CopLINE_set(PL_curcop, PL_copline);
3770 Perl_warner(aTHX_ WARN_MISC,
3771 "Value of %s%s can be \"0\"; test with defined()",
3773 ((warnop == OP_READLINE || warnop == OP_GLOB)
3774 ? " construct" : "() operator"));
3775 CopLINE_set(PL_curcop, oldline);
3782 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3783 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3785 NewOp(1101, logop, 1, LOGOP);
3787 logop->op_type = type;
3788 logop->op_ppaddr = PL_ppaddr[type];
3789 logop->op_first = first;
3790 logop->op_flags = flags | OPf_KIDS;
3791 logop->op_other = LINKLIST(other);
3792 logop->op_private = 1 | (flags >> 8);
3794 /* establish postfix order */
3795 logop->op_next = LINKLIST(first);
3796 first->op_next = (OP*)logop;
3797 first->op_sibling = other;
3799 o = newUNOP(OP_NULL, 0, (OP*)logop);
3806 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3813 return newLOGOP(OP_AND, 0, first, trueop);
3815 return newLOGOP(OP_OR, 0, first, falseop);
3817 scalarboolean(first);
3818 if (first->op_type == OP_CONST) {
3819 if (SvTRUE(((SVOP*)first)->op_sv)) {
3830 else if (first->op_type == OP_WANTARRAY) {
3834 NewOp(1101, logop, 1, LOGOP);
3835 logop->op_type = OP_COND_EXPR;
3836 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3837 logop->op_first = first;
3838 logop->op_flags = flags | OPf_KIDS;
3839 logop->op_private = 1 | (flags >> 8);
3840 logop->op_other = LINKLIST(trueop);
3841 logop->op_next = LINKLIST(falseop);
3844 /* establish postfix order */
3845 start = LINKLIST(first);
3846 first->op_next = (OP*)logop;
3848 first->op_sibling = trueop;
3849 trueop->op_sibling = falseop;
3850 o = newUNOP(OP_NULL, 0, (OP*)logop);
3852 trueop->op_next = falseop->op_next = o;
3859 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3867 NewOp(1101, range, 1, LOGOP);
3869 range->op_type = OP_RANGE;
3870 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3871 range->op_first = left;
3872 range->op_flags = OPf_KIDS;
3873 leftstart = LINKLIST(left);
3874 range->op_other = LINKLIST(right);
3875 range->op_private = 1 | (flags >> 8);
3877 left->op_sibling = right;
3879 range->op_next = (OP*)range;
3880 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3881 flop = newUNOP(OP_FLOP, 0, flip);
3882 o = newUNOP(OP_NULL, 0, flop);
3884 range->op_next = leftstart;
3886 left->op_next = flip;
3887 right->op_next = flop;
3889 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3890 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3891 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3892 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3894 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3895 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3898 if (!flip->op_private || !flop->op_private)
3899 linklist(o); /* blow off optimizer unless constant */
3905 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3909 int once = block && block->op_flags & OPf_SPECIAL &&
3910 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3913 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3914 return block; /* do {} while 0 does once */
3915 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3916 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3917 expr = newUNOP(OP_DEFINED, 0,
3918 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3919 } else if (expr->op_flags & OPf_KIDS) {
3920 OP *k1 = ((UNOP*)expr)->op_first;
3921 OP *k2 = (k1) ? k1->op_sibling : NULL;
3922 switch (expr->op_type) {
3924 if (k2 && k2->op_type == OP_READLINE
3925 && (k2->op_flags & OPf_STACKED)
3926 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3927 expr = newUNOP(OP_DEFINED, 0, expr);
3931 if (k1->op_type == OP_READDIR
3932 || k1->op_type == OP_GLOB
3933 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3934 || k1->op_type == OP_EACH)
3935 expr = newUNOP(OP_DEFINED, 0, expr);
3941 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3942 o = new_logop(OP_AND, 0, &expr, &listop);
3945 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3947 if (once && o != listop)
3948 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3951 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3953 o->op_flags |= flags;
3955 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3960 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3969 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3970 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3971 expr = newUNOP(OP_DEFINED, 0,
3972 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3973 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3974 OP *k1 = ((UNOP*)expr)->op_first;
3975 OP *k2 = (k1) ? k1->op_sibling : NULL;
3976 switch (expr->op_type) {
3978 if (k2 && k2->op_type == OP_READLINE
3979 && (k2->op_flags & OPf_STACKED)
3980 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3981 expr = newUNOP(OP_DEFINED, 0, expr);
3985 if (k1->op_type == OP_READDIR
3986 || k1->op_type == OP_GLOB
3987 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3988 || k1->op_type == OP_EACH)
3989 expr = newUNOP(OP_DEFINED, 0, expr);
3995 block = newOP(OP_NULL, 0);
3997 block = scope(block);
4001 next = LINKLIST(cont);
4004 OP *unstack = newOP(OP_UNSTACK, 0);
4007 cont = append_elem(OP_LINESEQ, cont, unstack);
4008 if ((line_t)whileline != NOLINE) {
4009 PL_copline = whileline;
4010 cont = append_elem(OP_LINESEQ, cont,
4011 newSTATEOP(0, Nullch, Nullop));
4015 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4016 redo = LINKLIST(listop);
4019 PL_copline = whileline;
4021 o = new_logop(OP_AND, 0, &expr, &listop);
4022 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4023 op_free(expr); /* oops, it's a while (0) */
4025 return Nullop; /* listop already freed by new_logop */
4028 ((LISTOP*)listop)->op_last->op_next = condop =
4029 (o == listop ? redo : LINKLIST(o));
4035 NewOp(1101,loop,1,LOOP);
4036 loop->op_type = OP_ENTERLOOP;
4037 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4038 loop->op_private = 0;
4039 loop->op_next = (OP*)loop;
4042 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4044 loop->op_redoop = redo;
4045 loop->op_lastop = o;
4046 o->op_private |= loopflags;
4049 loop->op_nextop = next;
4051 loop->op_nextop = o;
4053 o->op_flags |= flags;
4054 o->op_private |= (flags >> 8);
4059 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4067 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4068 sv->op_type = OP_RV2GV;
4069 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4071 else if (sv->op_type == OP_PADSV) { /* private variable */
4072 padoff = sv->op_targ;
4077 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4078 padoff = sv->op_targ;
4080 iterflags |= OPf_SPECIAL;
4085 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4089 padoff = find_threadsv("_");
4090 iterflags |= OPf_SPECIAL;
4092 sv = newGVOP(OP_GV, 0, PL_defgv);
4095 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4096 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4097 iterflags |= OPf_STACKED;
4099 else if (expr->op_type == OP_NULL &&
4100 (expr->op_flags & OPf_KIDS) &&
4101 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4103 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4104 * set the STACKED flag to indicate that these values are to be
4105 * treated as min/max values by 'pp_iterinit'.
4107 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4108 LOGOP* range = (LOGOP*) flip->op_first;
4109 OP* left = range->op_first;
4110 OP* right = left->op_sibling;
4113 range->op_flags &= ~OPf_KIDS;
4114 range->op_first = Nullop;
4116 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4117 listop->op_first->op_next = range->op_next;
4118 left->op_next = range->op_other;
4119 right->op_next = (OP*)listop;
4120 listop->op_next = listop->op_first;
4123 expr = (OP*)(listop);
4125 iterflags |= OPf_STACKED;
4128 expr = mod(force_list(expr), OP_GREPSTART);
4132 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4133 append_elem(OP_LIST, expr, scalar(sv))));
4134 assert(!loop->op_next);
4135 #ifdef PL_OP_SLAB_ALLOC
4138 NewOp(1234,tmp,1,LOOP);
4139 Copy(loop,tmp,1,LOOP);
4143 Renew(loop, 1, LOOP);
4145 loop->op_targ = padoff;
4146 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4147 PL_copline = forline;
4148 return newSTATEOP(0, label, wop);
4152 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4157 if (type != OP_GOTO || label->op_type == OP_CONST) {
4158 /* "last()" means "last" */
4159 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4160 o = newOP(type, OPf_SPECIAL);
4162 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4163 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4169 if (label->op_type == OP_ENTERSUB)
4170 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4171 o = newUNOP(type, OPf_STACKED, label);
4173 PL_hints |= HINT_BLOCK_SCOPE;
4178 Perl_cv_undef(pTHX_ CV *cv)
4182 MUTEX_DESTROY(CvMUTEXP(cv));
4183 Safefree(CvMUTEXP(cv));
4186 #endif /* USE_THREADS */
4188 if (!CvXSUB(cv) && CvROOT(cv)) {
4190 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4191 Perl_croak(aTHX_ "Can't undef active subroutine");
4194 Perl_croak(aTHX_ "Can't undef active subroutine");
4195 #endif /* USE_THREADS */
4198 SAVEVPTR(PL_curpad);
4201 op_free(CvROOT(cv));
4202 CvROOT(cv) = Nullop;
4205 SvPOK_off((SV*)cv); /* forget prototype */
4207 /* Since closure prototypes have the same lifetime as the containing
4208 * CV, they don't hold a refcount on the outside CV. This avoids
4209 * the refcount loop between the outer CV (which keeps a refcount to
4210 * the closure prototype in the pad entry for pp_anoncode()) and the
4211 * closure prototype, and the ensuing memory leak. --GSAR */
4212 if (!CvANON(cv) || CvCLONED(cv))
4213 SvREFCNT_dec(CvOUTSIDE(cv));
4214 CvOUTSIDE(cv) = Nullcv;
4216 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4219 if (CvPADLIST(cv)) {
4220 /* may be during global destruction */
4221 if (SvREFCNT(CvPADLIST(cv))) {
4222 I32 i = AvFILLp(CvPADLIST(cv));
4224 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4225 SV* sv = svp ? *svp : Nullsv;
4228 if (sv == (SV*)PL_comppad_name)
4229 PL_comppad_name = Nullav;
4230 else if (sv == (SV*)PL_comppad) {
4231 PL_comppad = Nullav;
4232 PL_curpad = Null(SV**);
4236 SvREFCNT_dec((SV*)CvPADLIST(cv));
4238 CvPADLIST(cv) = Nullav;
4243 #ifdef DEBUG_CLOSURES
4245 S_cv_dump(pTHX_ CV *cv)
4248 CV *outside = CvOUTSIDE(cv);
4249 AV* padlist = CvPADLIST(cv);
4256 PerlIO_printf(Perl_debug_log,
4257 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4259 (CvANON(cv) ? "ANON"
4260 : (cv == PL_main_cv) ? "MAIN"
4261 : CvUNIQUE(cv) ? "UNIQUE"
4262 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4265 : CvANON(outside) ? "ANON"
4266 : (outside == PL_main_cv) ? "MAIN"
4267 : CvUNIQUE(outside) ? "UNIQUE"
4268 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4273 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4274 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4275 pname = AvARRAY(pad_name);
4276 ppad = AvARRAY(pad);
4278 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4279 if (SvPOK(pname[ix]))
4280 PerlIO_printf(Perl_debug_log,
4281 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4282 (int)ix, PTR2UV(ppad[ix]),
4283 SvFAKE(pname[ix]) ? "FAKE " : "",
4285 (IV)I_32(SvNVX(pname[ix])),
4288 #endif /* DEBUGGING */
4290 #endif /* DEBUG_CLOSURES */
4293 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4297 AV* protopadlist = CvPADLIST(proto);
4298 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4299 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4300 SV** pname = AvARRAY(protopad_name);
4301 SV** ppad = AvARRAY(protopad);
4302 I32 fname = AvFILLp(protopad_name);
4303 I32 fpad = AvFILLp(protopad);
4307 assert(!CvUNIQUE(proto));
4311 SAVESPTR(PL_comppad_name);
4312 SAVESPTR(PL_compcv);
4314 cv = PL_compcv = (CV*)NEWSV(1104,0);
4315 sv_upgrade((SV *)cv, SvTYPE(proto));
4316 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4320 New(666, CvMUTEXP(cv), 1, perl_mutex);
4321 MUTEX_INIT(CvMUTEXP(cv));
4323 #endif /* USE_THREADS */
4324 CvFILE(cv) = CvFILE(proto);
4325 CvGV(cv) = CvGV(proto);
4326 CvSTASH(cv) = CvSTASH(proto);
4327 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4328 CvSTART(cv) = CvSTART(proto);
4330 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4333 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4335 PL_comppad_name = newAV();
4336 for (ix = fname; ix >= 0; ix--)
4337 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4339 PL_comppad = newAV();
4341 comppadlist = newAV();
4342 AvREAL_off(comppadlist);
4343 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4344 av_store(comppadlist, 1, (SV*)PL_comppad);
4345 CvPADLIST(cv) = comppadlist;
4346 av_fill(PL_comppad, AvFILLp(protopad));
4347 PL_curpad = AvARRAY(PL_comppad);
4349 av = newAV(); /* will be @_ */
4351 av_store(PL_comppad, 0, (SV*)av);
4352 AvFLAGS(av) = AVf_REIFY;
4354 for (ix = fpad; ix > 0; ix--) {
4355 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4356 if (namesv && namesv != &PL_sv_undef) {
4357 char *name = SvPVX(namesv); /* XXX */
4358 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4359 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4360 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4362 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4364 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4366 else { /* our own lexical */
4369 /* anon code -- we'll come back for it */
4370 sv = SvREFCNT_inc(ppad[ix]);
4372 else if (*name == '@')
4374 else if (*name == '%')
4383 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4384 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4387 SV* sv = NEWSV(0,0);
4393 /* Now that vars are all in place, clone nested closures. */
4395 for (ix = fpad; ix > 0; ix--) {
4396 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4398 && namesv != &PL_sv_undef
4399 && !(SvFLAGS(namesv) & SVf_FAKE)
4400 && *SvPVX(namesv) == '&'
4401 && CvCLONE(ppad[ix]))
4403 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4404 SvREFCNT_dec(ppad[ix]);
4407 PL_curpad[ix] = (SV*)kid;
4411 #ifdef DEBUG_CLOSURES
4412 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4414 PerlIO_printf(Perl_debug_log, " from:\n");
4416 PerlIO_printf(Perl_debug_log, " to:\n");
4423 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4425 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4427 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4434 Perl_cv_clone(pTHX_ CV *proto)
4437 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4438 cv = cv_clone2(proto, CvOUTSIDE(proto));
4439 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4444 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4446 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4447 SV* msg = sv_newmortal();
4451 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4452 sv_setpv(msg, "Prototype mismatch:");
4454 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4456 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4457 sv_catpv(msg, " vs ");
4459 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4461 sv_catpv(msg, "none");
4462 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4466 static void const_sv_xsub(pTHXo_ CV* cv);
4469 =for apidoc cv_const_sv
4471 If C<cv> is a constant sub eligible for inlining. returns the constant
4472 value returned by the sub. Otherwise, returns NULL.
4474 Constant subs can be created with C<newCONSTSUB> or as described in
4475 L<perlsub/"Constant Functions">.
4480 Perl_cv_const_sv(pTHX_ CV *cv)
4482 if (!cv || !CvCONST(cv))
4484 return (SV*)CvXSUBANY(cv).any_ptr;
4488 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4495 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4496 o = cLISTOPo->op_first->op_sibling;
4498 for (; o; o = o->op_next) {
4499 OPCODE type = o->op_type;
4501 if (sv && o->op_next == o)
4503 if (o->op_next != o) {
4504 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4506 if (type == OP_DBSTATE)
4509 if (type == OP_LEAVESUB || type == OP_RETURN)
4513 if (type == OP_CONST && cSVOPo->op_sv)
4515 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4516 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4517 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4521 /* We get here only from cv_clone2() while creating a closure.
4522 Copy the const value here instead of in cv_clone2 so that
4523 SvREADONLY_on doesn't lead to problems when leaving
4528 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4540 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4550 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4554 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4556 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4560 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4566 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4571 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4572 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4573 SV *sv = sv_newmortal();
4574 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4575 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4580 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4581 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4591 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4592 maximum a prototype before. */
4593 if (SvTYPE(gv) > SVt_NULL) {
4594 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4595 && ckWARN_d(WARN_PROTOTYPE))
4597 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4599 cv_ckproto((CV*)gv, NULL, ps);
4602 sv_setpv((SV*)gv, ps);
4604 sv_setiv((SV*)gv, -1);
4605 SvREFCNT_dec(PL_compcv);
4606 cv = PL_compcv = NULL;
4607 PL_sub_generation++;
4611 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4613 #ifdef GV_SHARED_CHECK
4614 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4615 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4619 if (!block || !ps || *ps || attrs)
4622 const_sv = op_const_sv(block, Nullcv);
4625 bool exists = CvROOT(cv) || CvXSUB(cv);
4627 #ifdef GV_SHARED_CHECK
4628 if (exists && GvSHARED(gv)) {
4629 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4633 /* if the subroutine doesn't exist and wasn't pre-declared
4634 * with a prototype, assume it will be AUTOLOADed,
4635 * skipping the prototype check
4637 if (exists || SvPOK(cv))
4638 cv_ckproto(cv, gv, ps);
4639 /* already defined (or promised)? */
4640 if (exists || GvASSUMECV(gv)) {
4641 if (!block && !attrs) {
4642 /* just a "sub foo;" when &foo is already defined */
4643 SAVEFREESV(PL_compcv);
4646 /* ahem, death to those who redefine active sort subs */
4647 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4648 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4650 if (ckWARN(WARN_REDEFINE)
4652 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4654 line_t oldline = CopLINE(PL_curcop);
4655 CopLINE_set(PL_curcop, PL_copline);
4656 Perl_warner(aTHX_ WARN_REDEFINE,
4657 CvCONST(cv) ? "Constant subroutine %s redefined"
4658 : "Subroutine %s redefined", name);
4659 CopLINE_set(PL_curcop, oldline);
4667 SvREFCNT_inc(const_sv);
4669 assert(!CvROOT(cv) && !CvCONST(cv));
4670 sv_setpv((SV*)cv, ""); /* prototype is "" */
4671 CvXSUBANY(cv).any_ptr = const_sv;
4672 CvXSUB(cv) = const_sv_xsub;
4677 cv = newCONSTSUB(NULL, name, const_sv);
4680 SvREFCNT_dec(PL_compcv);
4682 PL_sub_generation++;
4689 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4690 * before we clobber PL_compcv.
4694 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4695 stash = GvSTASH(CvGV(cv));
4696 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4697 stash = CvSTASH(cv);
4699 stash = PL_curstash;
4702 /* possibly about to re-define existing subr -- ignore old cv */
4703 rcv = (SV*)PL_compcv;
4704 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4705 stash = GvSTASH(gv);
4707 stash = PL_curstash;
4709 apply_attrs(stash, rcv, attrs);
4711 if (cv) { /* must reuse cv if autoloaded */
4713 /* got here with just attrs -- work done, so bug out */
4714 SAVEFREESV(PL_compcv);
4718 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4719 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4720 CvOUTSIDE(PL_compcv) = 0;
4721 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4722 CvPADLIST(PL_compcv) = 0;
4723 /* inner references to PL_compcv must be fixed up ... */
4725 AV *padlist = CvPADLIST(cv);
4726 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4727 AV *comppad = (AV*)AvARRAY(padlist)[1];
4728 SV **namepad = AvARRAY(comppad_name);
4729 SV **curpad = AvARRAY(comppad);
4730 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4731 SV *namesv = namepad[ix];
4732 if (namesv && namesv != &PL_sv_undef
4733 && *SvPVX(namesv) == '&')
4735 CV *innercv = (CV*)curpad[ix];
4736 if (CvOUTSIDE(innercv) == PL_compcv) {
4737 CvOUTSIDE(innercv) = cv;
4738 if (!CvANON(innercv) || CvCLONED(innercv)) {
4739 (void)SvREFCNT_inc(cv);
4740 SvREFCNT_dec(PL_compcv);
4746 /* ... before we throw it away */
4747 SvREFCNT_dec(PL_compcv);
4754 PL_sub_generation++;
4758 CvFILE(cv) = CopFILE(PL_curcop);
4759 CvSTASH(cv) = PL_curstash;
4762 if (!CvMUTEXP(cv)) {
4763 New(666, CvMUTEXP(cv), 1, perl_mutex);
4764 MUTEX_INIT(CvMUTEXP(cv));
4766 #endif /* USE_THREADS */
4769 sv_setpv((SV*)cv, ps);
4771 if (PL_error_count) {
4775 char *s = strrchr(name, ':');
4777 if (strEQ(s, "BEGIN")) {
4779 "BEGIN not safe after errors--compilation aborted";
4780 if (PL_in_eval & EVAL_KEEPERR)
4781 Perl_croak(aTHX_ not_safe);
4783 /* force display of errors found but not reported */
4784 sv_catpv(ERRSV, not_safe);
4785 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4793 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4794 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4797 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4798 mod(scalarseq(block), OP_LEAVESUBLV));
4801 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4803 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4804 OpREFCNT_set(CvROOT(cv), 1);
4805 CvSTART(cv) = LINKLIST(CvROOT(cv));
4806 CvROOT(cv)->op_next = 0;
4809 /* now that optimizer has done its work, adjust pad values */
4811 SV **namep = AvARRAY(PL_comppad_name);
4812 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4815 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4818 * The only things that a clonable function needs in its
4819 * pad are references to outer lexicals and anonymous subs.
4820 * The rest are created anew during cloning.
4822 if (!((namesv = namep[ix]) != Nullsv &&
4823 namesv != &PL_sv_undef &&
4825 *SvPVX(namesv) == '&')))
4827 SvREFCNT_dec(PL_curpad[ix]);
4828 PL_curpad[ix] = Nullsv;
4831 assert(!CvCONST(cv));
4832 if (ps && !*ps && op_const_sv(block, cv))
4836 AV *av = newAV(); /* Will be @_ */
4838 av_store(PL_comppad, 0, (SV*)av);
4839 AvFLAGS(av) = AVf_REIFY;
4841 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4842 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4844 if (!SvPADMY(PL_curpad[ix]))
4845 SvPADTMP_on(PL_curpad[ix]);
4849 /* If a potential closure prototype, don't keep a refcount on outer CV.
4850 * This is okay as the lifetime of the prototype is tied to the
4851 * lifetime of the outer CV. Avoids memory leak due to reference
4854 SvREFCNT_dec(CvOUTSIDE(cv));
4856 if (name || aname) {
4858 char *tname = (name ? name : aname);
4860 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4861 SV *sv = NEWSV(0,0);
4862 SV *tmpstr = sv_newmortal();
4863 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4867 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4869 (long)PL_subline, (long)CopLINE(PL_curcop));
4870 gv_efullname3(tmpstr, gv, Nullch);
4871 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4872 hv = GvHVn(db_postponed);
4873 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4874 && (pcv = GvCV(db_postponed)))
4880 call_sv((SV*)pcv, G_DISCARD);
4884 if ((s = strrchr(tname,':')))
4889 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4892 if (strEQ(s, "BEGIN")) {
4893 I32 oldscope = PL_scopestack_ix;
4895 SAVECOPFILE(&PL_compiling);
4896 SAVECOPLINE(&PL_compiling);
4898 sv_setsv(PL_rs, PL_nrs);
4901 PL_beginav = newAV();
4902 DEBUG_x( dump_sub(gv) );
4903 av_push(PL_beginav, (SV*)cv);
4904 GvCV(gv) = 0; /* cv has been hijacked */
4905 call_list(oldscope, PL_beginav);
4907 PL_curcop = &PL_compiling;
4908 PL_compiling.op_private = PL_hints;
4911 else if (strEQ(s, "END") && !PL_error_count) {
4914 DEBUG_x( dump_sub(gv) );
4915 av_unshift(PL_endav, 1);
4916 av_store(PL_endav, 0, (SV*)cv);
4917 GvCV(gv) = 0; /* cv has been hijacked */
4919 else if (strEQ(s, "CHECK") && !PL_error_count) {
4921 PL_checkav = newAV();
4922 DEBUG_x( dump_sub(gv) );
4923 if (PL_main_start && ckWARN(WARN_VOID))
4924 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4925 av_unshift(PL_checkav, 1);
4926 av_store(PL_checkav, 0, (SV*)cv);
4927 GvCV(gv) = 0; /* cv has been hijacked */
4929 else if (strEQ(s, "INIT") && !PL_error_count) {
4931 PL_initav = newAV();
4932 DEBUG_x( dump_sub(gv) );
4933 if (PL_main_start && ckWARN(WARN_VOID))
4934 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4935 av_push(PL_initav, (SV*)cv);
4936 GvCV(gv) = 0; /* cv has been hijacked */
4941 PL_copline = NOLINE;
4946 /* XXX unsafe for threads if eval_owner isn't held */
4948 =for apidoc newCONSTSUB
4950 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4951 eligible for inlining at compile-time.
4957 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4963 SAVECOPLINE(PL_curcop);
4964 CopLINE_set(PL_curcop, PL_copline);
4967 PL_hints &= ~HINT_BLOCK_SCOPE;
4970 SAVESPTR(PL_curstash);
4971 SAVECOPSTASH(PL_curcop);
4972 PL_curstash = stash;
4974 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4976 CopSTASH(PL_curcop) = stash;
4980 cv = newXS(name, const_sv_xsub, __FILE__);
4981 CvXSUBANY(cv).any_ptr = sv;
4983 sv_setpv((SV*)cv, ""); /* prototype is "" */
4991 =for apidoc U||newXS
4993 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4999 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5001 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5004 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5006 /* just a cached method */
5010 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5011 /* already defined (or promised) */
5012 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5013 && HvNAME(GvSTASH(CvGV(cv)))
5014 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5015 line_t oldline = CopLINE(PL_curcop);
5016 if (PL_copline != NOLINE)
5017 CopLINE_set(PL_curcop, PL_copline);
5018 Perl_warner(aTHX_ WARN_REDEFINE,
5019 CvCONST(cv) ? "Constant subroutine %s redefined"
5020 : "Subroutine %s redefined"
5022 CopLINE_set(PL_curcop, oldline);
5029 if (cv) /* must reuse cv if autoloaded */
5032 cv = (CV*)NEWSV(1105,0);
5033 sv_upgrade((SV *)cv, SVt_PVCV);
5037 PL_sub_generation++;
5042 New(666, CvMUTEXP(cv), 1, perl_mutex);
5043 MUTEX_INIT(CvMUTEXP(cv));
5045 #endif /* USE_THREADS */
5046 (void)gv_fetchfile(filename);
5047 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5048 an external constant string */
5049 CvXSUB(cv) = subaddr;
5052 char *s = strrchr(name,':');
5058 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5061 if (strEQ(s, "BEGIN")) {
5063 PL_beginav = newAV();
5064 av_push(PL_beginav, (SV*)cv);
5065 GvCV(gv) = 0; /* cv has been hijacked */
5067 else if (strEQ(s, "END")) {
5070 av_unshift(PL_endav, 1);
5071 av_store(PL_endav, 0, (SV*)cv);
5072 GvCV(gv) = 0; /* cv has been hijacked */
5074 else if (strEQ(s, "CHECK")) {
5076 PL_checkav = newAV();
5077 if (PL_main_start && ckWARN(WARN_VOID))
5078 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5079 av_unshift(PL_checkav, 1);
5080 av_store(PL_checkav, 0, (SV*)cv);
5081 GvCV(gv) = 0; /* cv has been hijacked */
5083 else if (strEQ(s, "INIT")) {
5085 PL_initav = newAV();
5086 if (PL_main_start && ckWARN(WARN_VOID))
5087 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5088 av_push(PL_initav, (SV*)cv);
5089 GvCV(gv) = 0; /* cv has been hijacked */
5100 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5109 name = SvPVx(cSVOPo->op_sv, n_a);
5112 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5113 #ifdef GV_SHARED_CHECK
5115 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5119 if ((cv = GvFORM(gv))) {
5120 if (ckWARN(WARN_REDEFINE)) {
5121 line_t oldline = CopLINE(PL_curcop);
5123 CopLINE_set(PL_curcop, PL_copline);
5124 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5125 CopLINE_set(PL_curcop, oldline);
5132 CvFILE(cv) = CopFILE(PL_curcop);
5134 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5135 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5136 SvPADTMP_on(PL_curpad[ix]);
5139 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5140 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5141 OpREFCNT_set(CvROOT(cv), 1);
5142 CvSTART(cv) = LINKLIST(CvROOT(cv));
5143 CvROOT(cv)->op_next = 0;
5146 PL_copline = NOLINE;
5151 Perl_newANONLIST(pTHX_ OP *o)
5153 return newUNOP(OP_REFGEN, 0,
5154 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5158 Perl_newANONHASH(pTHX_ OP *o)
5160 return newUNOP(OP_REFGEN, 0,
5161 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5165 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5167 return newANONATTRSUB(floor, proto, Nullop, block);
5171 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5173 return newUNOP(OP_REFGEN, 0,
5174 newSVOP(OP_ANONCODE, 0,
5175 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5179 Perl_oopsAV(pTHX_ OP *o)
5181 switch (o->op_type) {
5183 o->op_type = OP_PADAV;
5184 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5185 return ref(o, OP_RV2AV);
5188 o->op_type = OP_RV2AV;
5189 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5194 if (ckWARN_d(WARN_INTERNAL))
5195 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5202 Perl_oopsHV(pTHX_ OP *o)
5204 switch (o->op_type) {
5207 o->op_type = OP_PADHV;
5208 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5209 return ref(o, OP_RV2HV);
5213 o->op_type = OP_RV2HV;
5214 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5219 if (ckWARN_d(WARN_INTERNAL))
5220 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5227 Perl_newAVREF(pTHX_ OP *o)
5229 if (o->op_type == OP_PADANY) {
5230 o->op_type = OP_PADAV;
5231 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5234 return newUNOP(OP_RV2AV, 0, scalar(o));
5238 Perl_newGVREF(pTHX_ I32 type, OP *o)
5240 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5241 return newUNOP(OP_NULL, 0, o);
5242 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5246 Perl_newHVREF(pTHX_ OP *o)
5248 if (o->op_type == OP_PADANY) {
5249 o->op_type = OP_PADHV;
5250 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5253 return newUNOP(OP_RV2HV, 0, scalar(o));
5257 Perl_oopsCV(pTHX_ OP *o)
5259 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5265 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5267 return newUNOP(OP_RV2CV, flags, scalar(o));
5271 Perl_newSVREF(pTHX_ OP *o)
5273 if (o->op_type == OP_PADANY) {
5274 o->op_type = OP_PADSV;
5275 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5278 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5279 o->op_flags |= OPpDONE_SVREF;
5282 return newUNOP(OP_RV2SV, 0, scalar(o));
5285 /* Check routines. */
5288 Perl_ck_anoncode(pTHX_ OP *o)
5293 name = NEWSV(1106,0);
5294 sv_upgrade(name, SVt_PVNV);
5295 sv_setpvn(name, "&", 1);
5298 ix = pad_alloc(o->op_type, SVs_PADMY);
5299 av_store(PL_comppad_name, ix, name);
5300 av_store(PL_comppad, ix, cSVOPo->op_sv);
5301 SvPADMY_on(cSVOPo->op_sv);
5302 cSVOPo->op_sv = Nullsv;
5303 cSVOPo->op_targ = ix;
5308 Perl_ck_bitop(pTHX_ OP *o)
5310 o->op_private = PL_hints;
5315 Perl_ck_concat(pTHX_ OP *o)
5317 if (cUNOPo->op_first->op_type == OP_CONCAT)
5318 o->op_flags |= OPf_STACKED;
5323 Perl_ck_spair(pTHX_ OP *o)
5325 if (o->op_flags & OPf_KIDS) {
5328 OPCODE type = o->op_type;
5329 o = modkids(ck_fun(o), type);
5330 kid = cUNOPo->op_first;
5331 newop = kUNOP->op_first->op_sibling;
5333 (newop->op_sibling ||
5334 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5335 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5336 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5340 op_free(kUNOP->op_first);
5341 kUNOP->op_first = newop;
5343 o->op_ppaddr = PL_ppaddr[++o->op_type];
5348 Perl_ck_delete(pTHX_ OP *o)
5352 if (o->op_flags & OPf_KIDS) {
5353 OP *kid = cUNOPo->op_first;
5354 switch (kid->op_type) {
5356 o->op_flags |= OPf_SPECIAL;
5359 o->op_private |= OPpSLICE;
5362 o->op_flags |= OPf_SPECIAL;
5367 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5368 PL_op_desc[o->op_type]);
5376 Perl_ck_eof(pTHX_ OP *o)
5378 I32 type = o->op_type;
5380 if (o->op_flags & OPf_KIDS) {
5381 if (cLISTOPo->op_first->op_type == OP_STUB) {
5383 o = newUNOP(type, OPf_SPECIAL,
5384 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5392 Perl_ck_eval(pTHX_ OP *o)
5394 PL_hints |= HINT_BLOCK_SCOPE;
5395 if (o->op_flags & OPf_KIDS) {
5396 SVOP *kid = (SVOP*)cUNOPo->op_first;
5399 o->op_flags &= ~OPf_KIDS;
5402 else if (kid->op_type == OP_LINESEQ) {
5405 kid->op_next = o->op_next;
5406 cUNOPo->op_first = 0;
5409 NewOp(1101, enter, 1, LOGOP);
5410 enter->op_type = OP_ENTERTRY;
5411 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5412 enter->op_private = 0;
5414 /* establish postfix order */
5415 enter->op_next = (OP*)enter;
5417 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5418 o->op_type = OP_LEAVETRY;
5419 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5420 enter->op_other = o;
5428 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5430 o->op_targ = (PADOFFSET)PL_hints;
5435 Perl_ck_exit(pTHX_ OP *o)
5438 HV *table = GvHV(PL_hintgv);
5440 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5441 if (svp && *svp && SvTRUE(*svp))
5442 o->op_private |= OPpEXIT_VMSISH;
5449 Perl_ck_exec(pTHX_ OP *o)
5452 if (o->op_flags & OPf_STACKED) {
5454 kid = cUNOPo->op_first->op_sibling;
5455 if (kid->op_type == OP_RV2GV)
5464 Perl_ck_exists(pTHX_ OP *o)
5467 if (o->op_flags & OPf_KIDS) {
5468 OP *kid = cUNOPo->op_first;
5469 if (kid->op_type == OP_ENTERSUB) {
5470 (void) ref(kid, o->op_type);
5471 if (kid->op_type != OP_RV2CV && !PL_error_count)
5472 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5473 PL_op_desc[o->op_type]);
5474 o->op_private |= OPpEXISTS_SUB;
5476 else if (kid->op_type == OP_AELEM)
5477 o->op_flags |= OPf_SPECIAL;
5478 else if (kid->op_type != OP_HELEM)
5479 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5480 PL_op_desc[o->op_type]);
5488 Perl_ck_gvconst(pTHX_ register OP *o)
5490 o = fold_constants(o);
5491 if (o->op_type == OP_CONST)
5498 Perl_ck_rvconst(pTHX_ register OP *o)
5500 SVOP *kid = (SVOP*)cUNOPo->op_first;
5502 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5503 if (kid->op_type == OP_CONST) {
5507 SV *kidsv = kid->op_sv;
5510 /* Is it a constant from cv_const_sv()? */
5511 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5512 SV *rsv = SvRV(kidsv);
5513 int svtype = SvTYPE(rsv);
5514 char *badtype = Nullch;
5516 switch (o->op_type) {
5518 if (svtype > SVt_PVMG)
5519 badtype = "a SCALAR";
5522 if (svtype != SVt_PVAV)
5523 badtype = "an ARRAY";
5526 if (svtype != SVt_PVHV) {
5527 if (svtype == SVt_PVAV) { /* pseudohash? */
5528 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5529 if (ksv && SvROK(*ksv)
5530 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5539 if (svtype != SVt_PVCV)
5544 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5547 name = SvPV(kidsv, n_a);
5548 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5549 char *badthing = Nullch;
5550 switch (o->op_type) {
5552 badthing = "a SCALAR";
5555 badthing = "an ARRAY";
5558 badthing = "a HASH";
5563 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5567 * This is a little tricky. We only want to add the symbol if we
5568 * didn't add it in the lexer. Otherwise we get duplicate strict
5569 * warnings. But if we didn't add it in the lexer, we must at
5570 * least pretend like we wanted to add it even if it existed before,
5571 * or we get possible typo warnings. OPpCONST_ENTERED says
5572 * whether the lexer already added THIS instance of this symbol.
5574 iscv = (o->op_type == OP_RV2CV) * 2;
5576 gv = gv_fetchpv(name,
5577 iscv | !(kid->op_private & OPpCONST_ENTERED),
5580 : o->op_type == OP_RV2SV
5582 : o->op_type == OP_RV2AV
5584 : o->op_type == OP_RV2HV
5587 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5589 kid->op_type = OP_GV;
5590 SvREFCNT_dec(kid->op_sv);
5592 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5593 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5594 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5596 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5598 kid->op_sv = SvREFCNT_inc(gv);
5600 kid->op_private = 0;
5601 kid->op_ppaddr = PL_ppaddr[OP_GV];
5608 Perl_ck_ftst(pTHX_ OP *o)
5610 I32 type = o->op_type;
5612 if (o->op_flags & OPf_REF) {
5615 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5616 SVOP *kid = (SVOP*)cUNOPo->op_first;
5618 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5620 OP *newop = newGVOP(type, OPf_REF,
5621 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5628 if (type == OP_FTTTY)
5629 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5632 o = newUNOP(type, 0, newDEFSVOP());
5635 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5637 if (PL_hints & HINT_LOCALE)
5638 o->op_private |= OPpLOCALE;
5645 Perl_ck_fun(pTHX_ OP *o)
5651 int type = o->op_type;
5652 register I32 oa = PL_opargs[type] >> OASHIFT;
5654 if (o->op_flags & OPf_STACKED) {
5655 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5658 return no_fh_allowed(o);
5661 if (o->op_flags & OPf_KIDS) {
5663 tokid = &cLISTOPo->op_first;
5664 kid = cLISTOPo->op_first;
5665 if (kid->op_type == OP_PUSHMARK ||
5666 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5668 tokid = &kid->op_sibling;
5669 kid = kid->op_sibling;
5671 if (!kid && PL_opargs[type] & OA_DEFGV)
5672 *tokid = kid = newDEFSVOP();
5676 sibl = kid->op_sibling;
5679 /* list seen where single (scalar) arg expected? */
5680 if (numargs == 1 && !(oa >> 4)
5681 && kid->op_type == OP_LIST && type != OP_SCALAR)
5683 return too_many_arguments(o,PL_op_desc[type]);
5696 if ((type == OP_PUSH || type == OP_UNSHIFT)
5697 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5698 Perl_warner(aTHX_ WARN_SYNTAX,
5699 "Useless use of %s with no values",
5702 if (kid->op_type == OP_CONST &&
5703 (kid->op_private & OPpCONST_BARE))
5705 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5706 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5707 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5708 if (ckWARN(WARN_DEPRECATED))
5709 Perl_warner(aTHX_ WARN_DEPRECATED,
5710 "Array @%s missing the @ in argument %"IVdf" of %s()",
5711 name, (IV)numargs, PL_op_desc[type]);
5714 kid->op_sibling = sibl;
5717 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5718 bad_type(numargs, "array", PL_op_desc[type], kid);
5722 if (kid->op_type == OP_CONST &&
5723 (kid->op_private & OPpCONST_BARE))
5725 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5726 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5727 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5728 if (ckWARN(WARN_DEPRECATED))
5729 Perl_warner(aTHX_ WARN_DEPRECATED,
5730 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5731 name, (IV)numargs, PL_op_desc[type]);
5734 kid->op_sibling = sibl;
5737 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5738 bad_type(numargs, "hash", PL_op_desc[type], kid);
5743 OP *newop = newUNOP(OP_NULL, 0, kid);
5744 kid->op_sibling = 0;
5746 newop->op_next = newop;
5748 kid->op_sibling = sibl;
5753 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5754 if (kid->op_type == OP_CONST &&
5755 (kid->op_private & OPpCONST_BARE))
5757 OP *newop = newGVOP(OP_GV, 0,
5758 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5763 else if (kid->op_type == OP_READLINE) {
5764 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5765 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5768 I32 flags = OPf_SPECIAL;
5772 /* is this op a FH constructor? */
5773 if (is_handle_constructor(o,numargs)) {
5774 char *name = Nullch;
5778 /* Set a flag to tell rv2gv to vivify
5779 * need to "prove" flag does not mean something
5780 * else already - NI-S 1999/05/07
5783 if (kid->op_type == OP_PADSV) {
5784 SV **namep = av_fetch(PL_comppad_name,
5786 if (namep && *namep)
5787 name = SvPV(*namep, len);
5789 else if (kid->op_type == OP_RV2SV
5790 && kUNOP->op_first->op_type == OP_GV)
5792 GV *gv = cGVOPx_gv(kUNOP->op_first);
5794 len = GvNAMELEN(gv);
5796 else if (kid->op_type == OP_AELEM
5797 || kid->op_type == OP_HELEM)
5799 name = "__ANONIO__";
5805 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5806 namesv = PL_curpad[targ];
5807 (void)SvUPGRADE(namesv, SVt_PV);
5809 sv_setpvn(namesv, "$", 1);
5810 sv_catpvn(namesv, name, len);
5813 kid->op_sibling = 0;
5814 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5815 kid->op_targ = targ;
5816 kid->op_private |= priv;
5818 kid->op_sibling = sibl;
5824 mod(scalar(kid), type);
5828 tokid = &kid->op_sibling;
5829 kid = kid->op_sibling;
5831 o->op_private |= numargs;
5833 return too_many_arguments(o,PL_op_desc[o->op_type]);
5836 else if (PL_opargs[type] & OA_DEFGV) {
5838 return newUNOP(type, 0, newDEFSVOP());
5842 while (oa & OA_OPTIONAL)
5844 if (oa && oa != OA_LIST)
5845 return too_few_arguments(o,PL_op_desc[o->op_type]);
5851 Perl_ck_glob(pTHX_ OP *o)
5856 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5857 append_elem(OP_GLOB, o, newDEFSVOP());
5859 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5860 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5862 #if !defined(PERL_EXTERNAL_GLOB)
5863 /* XXX this can be tightened up and made more failsafe. */
5867 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5869 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5870 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5871 GvCV(gv) = GvCV(glob_gv);
5872 GvIMPORTED_CV_on(gv);
5875 #endif /* PERL_EXTERNAL_GLOB */
5877 if (gv && GvIMPORTED_CV(gv)) {
5878 append_elem(OP_GLOB, o,
5879 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5880 o->op_type = OP_LIST;
5881 o->op_ppaddr = PL_ppaddr[OP_LIST];
5882 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5883 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5884 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5885 append_elem(OP_LIST, o,
5886 scalar(newUNOP(OP_RV2CV, 0,
5887 newGVOP(OP_GV, 0, gv)))));
5888 o = newUNOP(OP_NULL, 0, ck_subr(o));
5889 o->op_targ = OP_GLOB; /* hint at what it used to be */
5892 gv = newGVgen("main");
5894 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5900 Perl_ck_grep(pTHX_ OP *o)
5904 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5906 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5907 NewOp(1101, gwop, 1, LOGOP);
5909 if (o->op_flags & OPf_STACKED) {
5912 kid = cLISTOPo->op_first->op_sibling;
5913 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5916 kid->op_next = (OP*)gwop;
5917 o->op_flags &= ~OPf_STACKED;
5919 kid = cLISTOPo->op_first->op_sibling;
5920 if (type == OP_MAPWHILE)
5927 kid = cLISTOPo->op_first->op_sibling;
5928 if (kid->op_type != OP_NULL)
5929 Perl_croak(aTHX_ "panic: ck_grep");
5930 kid = kUNOP->op_first;
5932 gwop->op_type = type;
5933 gwop->op_ppaddr = PL_ppaddr[type];
5934 gwop->op_first = listkids(o);
5935 gwop->op_flags |= OPf_KIDS;
5936 gwop->op_private = 1;
5937 gwop->op_other = LINKLIST(kid);
5938 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5939 kid->op_next = (OP*)gwop;
5941 kid = cLISTOPo->op_first->op_sibling;
5942 if (!kid || !kid->op_sibling)
5943 return too_few_arguments(o,PL_op_desc[o->op_type]);
5944 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5945 mod(kid, OP_GREPSTART);
5951 Perl_ck_index(pTHX_ OP *o)
5953 if (o->op_flags & OPf_KIDS) {
5954 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5956 kid = kid->op_sibling; /* get past "big" */
5957 if (kid && kid->op_type == OP_CONST)
5958 fbm_compile(((SVOP*)kid)->op_sv, 0);
5964 Perl_ck_lengthconst(pTHX_ OP *o)
5966 /* XXX length optimization goes here */
5971 Perl_ck_lfun(pTHX_ OP *o)
5973 OPCODE type = o->op_type;
5974 return modkids(ck_fun(o), type);
5978 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5980 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5981 switch (cUNOPo->op_first->op_type) {
5983 /* This is needed for
5984 if (defined %stash::)
5985 to work. Do not break Tk.
5987 break; /* Globals via GV can be undef */
5989 case OP_AASSIGN: /* Is this a good idea? */
5990 Perl_warner(aTHX_ WARN_DEPRECATED,
5991 "defined(@array) is deprecated");
5992 Perl_warner(aTHX_ WARN_DEPRECATED,
5993 "\t(Maybe you should just omit the defined()?)\n");
5996 /* This is needed for
5997 if (defined %stash::)
5998 to work. Do not break Tk.
6000 break; /* Globals via GV can be undef */
6002 Perl_warner(aTHX_ WARN_DEPRECATED,
6003 "defined(%%hash) is deprecated");
6004 Perl_warner(aTHX_ WARN_DEPRECATED,
6005 "\t(Maybe you should just omit the defined()?)\n");
6016 Perl_ck_rfun(pTHX_ OP *o)
6018 OPCODE type = o->op_type;
6019 return refkids(ck_fun(o), type);
6023 Perl_ck_listiob(pTHX_ OP *o)
6027 kid = cLISTOPo->op_first;
6030 kid = cLISTOPo->op_first;
6032 if (kid->op_type == OP_PUSHMARK)
6033 kid = kid->op_sibling;
6034 if (kid && o->op_flags & OPf_STACKED)
6035 kid = kid->op_sibling;
6036 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6037 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6038 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6039 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6040 cLISTOPo->op_first->op_sibling = kid;
6041 cLISTOPo->op_last = kid;
6042 kid = kid->op_sibling;
6047 append_elem(o->op_type, o, newDEFSVOP());
6053 if (PL_hints & HINT_LOCALE)
6054 o->op_private |= OPpLOCALE;
6061 Perl_ck_fun_locale(pTHX_ OP *o)
6067 if (PL_hints & HINT_LOCALE)
6068 o->op_private |= OPpLOCALE;
6075 Perl_ck_sassign(pTHX_ OP *o)
6077 OP *kid = cLISTOPo->op_first;
6078 /* has a disposable target? */
6079 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6080 && !(kid->op_flags & OPf_STACKED)
6081 /* Cannot steal the second time! */
6082 && !(kid->op_private & OPpTARGET_MY))
6084 OP *kkid = kid->op_sibling;
6086 /* Can just relocate the target. */
6087 if (kkid && kkid->op_type == OP_PADSV
6088 && !(kkid->op_private & OPpLVAL_INTRO))
6090 kid->op_targ = kkid->op_targ;
6092 /* Now we do not need PADSV and SASSIGN. */
6093 kid->op_sibling = o->op_sibling; /* NULL */
6094 cLISTOPo->op_first = NULL;
6097 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6105 Perl_ck_scmp(pTHX_ OP *o)
6109 if (PL_hints & HINT_LOCALE)
6110 o->op_private |= OPpLOCALE;
6117 Perl_ck_match(pTHX_ OP *o)
6119 o->op_private |= OPpRUNTIME;
6124 Perl_ck_method(pTHX_ OP *o)
6126 OP *kid = cUNOPo->op_first;
6127 if (kid->op_type == OP_CONST) {
6128 SV* sv = kSVOP->op_sv;
6129 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6131 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6132 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6135 kSVOP->op_sv = Nullsv;
6137 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6146 Perl_ck_null(pTHX_ OP *o)
6152 Perl_ck_open(pTHX_ OP *o)
6154 HV *table = GvHV(PL_hintgv);
6158 svp = hv_fetch(table, "open_IN", 7, FALSE);
6160 mode = mode_from_discipline(*svp);
6161 if (mode & O_BINARY)
6162 o->op_private |= OPpOPEN_IN_RAW;
6163 else if (mode & O_TEXT)
6164 o->op_private |= OPpOPEN_IN_CRLF;
6167 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6169 mode = mode_from_discipline(*svp);
6170 if (mode & O_BINARY)
6171 o->op_private |= OPpOPEN_OUT_RAW;
6172 else if (mode & O_TEXT)
6173 o->op_private |= OPpOPEN_OUT_CRLF;
6176 if (o->op_type == OP_BACKTICK)
6182 Perl_ck_repeat(pTHX_ OP *o)
6184 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6185 o->op_private |= OPpREPEAT_DOLIST;
6186 cBINOPo->op_first = force_list(cBINOPo->op_first);
6194 Perl_ck_require(pTHX_ OP *o)
6196 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6197 SVOP *kid = (SVOP*)cUNOPo->op_first;
6199 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6201 for (s = SvPVX(kid->op_sv); *s; s++) {
6202 if (*s == ':' && s[1] == ':') {
6204 Move(s+2, s+1, strlen(s+2)+1, char);
6205 --SvCUR(kid->op_sv);
6208 if (SvREADONLY(kid->op_sv)) {
6209 SvREADONLY_off(kid->op_sv);
6210 sv_catpvn(kid->op_sv, ".pm", 3);
6211 SvREADONLY_on(kid->op_sv);
6214 sv_catpvn(kid->op_sv, ".pm", 3);
6221 Perl_ck_return(pTHX_ OP *o)
6224 if (CvLVALUE(PL_compcv)) {
6225 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6226 mod(kid, OP_LEAVESUBLV);
6233 Perl_ck_retarget(pTHX_ OP *o)
6235 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6242 Perl_ck_select(pTHX_ OP *o)
6245 if (o->op_flags & OPf_KIDS) {
6246 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6247 if (kid && kid->op_sibling) {
6248 o->op_type = OP_SSELECT;
6249 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6251 return fold_constants(o);
6255 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6256 if (kid && kid->op_type == OP_RV2GV)
6257 kid->op_private &= ~HINT_STRICT_REFS;
6262 Perl_ck_shift(pTHX_ OP *o)
6264 I32 type = o->op_type;
6266 if (!(o->op_flags & OPf_KIDS)) {
6271 if (!CvUNIQUE(PL_compcv)) {
6272 argop = newOP(OP_PADAV, OPf_REF);
6273 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6276 argop = newUNOP(OP_RV2AV, 0,
6277 scalar(newGVOP(OP_GV, 0,
6278 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6281 argop = newUNOP(OP_RV2AV, 0,
6282 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6283 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6284 #endif /* USE_THREADS */
6285 return newUNOP(type, 0, scalar(argop));
6287 return scalar(modkids(ck_fun(o), type));
6291 Perl_ck_sort(pTHX_ OP *o)
6296 if (PL_hints & HINT_LOCALE)
6297 o->op_private |= OPpLOCALE;
6300 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6302 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6303 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6305 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6307 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6309 if (kid->op_type == OP_SCOPE) {
6313 else if (kid->op_type == OP_LEAVE) {
6314 if (o->op_type == OP_SORT) {
6315 null(kid); /* wipe out leave */
6318 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6319 if (k->op_next == kid)
6321 /* don't descend into loops */
6322 else if (k->op_type == OP_ENTERLOOP
6323 || k->op_type == OP_ENTERITER)
6325 k = cLOOPx(k)->op_lastop;
6330 kid->op_next = 0; /* just disconnect the leave */
6331 k = kLISTOP->op_first;
6336 if (o->op_type == OP_SORT) {
6337 /* provide scalar context for comparison function/block */
6343 o->op_flags |= OPf_SPECIAL;
6345 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6348 firstkid = firstkid->op_sibling;
6351 /* provide list context for arguments */
6352 if (o->op_type == OP_SORT)
6359 S_simplify_sort(pTHX_ OP *o)
6361 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6365 if (!(o->op_flags & OPf_STACKED))
6367 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6368 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6369 kid = kUNOP->op_first; /* get past null */
6370 if (kid->op_type != OP_SCOPE)
6372 kid = kLISTOP->op_last; /* get past scope */
6373 switch(kid->op_type) {
6381 k = kid; /* remember this node*/
6382 if (kBINOP->op_first->op_type != OP_RV2SV)
6384 kid = kBINOP->op_first; /* get past cmp */
6385 if (kUNOP->op_first->op_type != OP_GV)
6387 kid = kUNOP->op_first; /* get past rv2sv */
6389 if (GvSTASH(gv) != PL_curstash)
6391 if (strEQ(GvNAME(gv), "a"))
6393 else if (strEQ(GvNAME(gv), "b"))
6397 kid = k; /* back to cmp */
6398 if (kBINOP->op_last->op_type != OP_RV2SV)
6400 kid = kBINOP->op_last; /* down to 2nd arg */
6401 if (kUNOP->op_first->op_type != OP_GV)
6403 kid = kUNOP->op_first; /* get past rv2sv */
6405 if (GvSTASH(gv) != PL_curstash
6407 ? strNE(GvNAME(gv), "a")
6408 : strNE(GvNAME(gv), "b")))
6410 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6412 o->op_private |= OPpSORT_REVERSE;
6413 if (k->op_type == OP_NCMP)
6414 o->op_private |= OPpSORT_NUMERIC;
6415 if (k->op_type == OP_I_NCMP)
6416 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6417 kid = cLISTOPo->op_first->op_sibling;
6418 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6419 op_free(kid); /* then delete it */
6423 Perl_ck_split(pTHX_ OP *o)
6427 if (o->op_flags & OPf_STACKED)
6428 return no_fh_allowed(o);
6430 kid = cLISTOPo->op_first;
6431 if (kid->op_type != OP_NULL)
6432 Perl_croak(aTHX_ "panic: ck_split");
6433 kid = kid->op_sibling;
6434 op_free(cLISTOPo->op_first);
6435 cLISTOPo->op_first = kid;
6437 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6438 cLISTOPo->op_last = kid; /* There was only one element previously */
6441 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6442 OP *sibl = kid->op_sibling;
6443 kid->op_sibling = 0;
6444 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6445 if (cLISTOPo->op_first == cLISTOPo->op_last)
6446 cLISTOPo->op_last = kid;
6447 cLISTOPo->op_first = kid;
6448 kid->op_sibling = sibl;
6451 kid->op_type = OP_PUSHRE;
6452 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6455 if (!kid->op_sibling)
6456 append_elem(OP_SPLIT, o, newDEFSVOP());
6458 kid = kid->op_sibling;
6461 if (!kid->op_sibling)
6462 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6464 kid = kid->op_sibling;
6467 if (kid->op_sibling)
6468 return too_many_arguments(o,PL_op_desc[o->op_type]);
6474 Perl_ck_join(pTHX_ OP *o)
6476 if (ckWARN(WARN_SYNTAX)) {
6477 OP *kid = cLISTOPo->op_first->op_sibling;
6478 if (kid && kid->op_type == OP_MATCH) {
6479 char *pmstr = "STRING";
6480 if (kPMOP->op_pmregexp)
6481 pmstr = kPMOP->op_pmregexp->precomp;
6482 Perl_warner(aTHX_ WARN_SYNTAX,
6483 "/%s/ should probably be written as \"%s\"",
6491 Perl_ck_subr(pTHX_ OP *o)
6493 OP *prev = ((cUNOPo->op_first->op_sibling)
6494 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6495 OP *o2 = prev->op_sibling;
6504 o->op_private |= OPpENTERSUB_HASTARG;
6505 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6506 if (cvop->op_type == OP_RV2CV) {
6508 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6509 null(cvop); /* disable rv2cv */
6510 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6511 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6512 GV *gv = cGVOPx_gv(tmpop);
6515 tmpop->op_private |= OPpEARLY_CV;
6516 else if (SvPOK(cv)) {
6517 namegv = CvANON(cv) ? gv : CvGV(cv);
6518 proto = SvPV((SV*)cv, n_a);
6522 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6523 if (o2->op_type == OP_CONST)
6524 o2->op_private &= ~OPpCONST_STRICT;
6525 else if (o2->op_type == OP_LIST) {
6526 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6527 if (o && o->op_type == OP_CONST)
6528 o->op_private &= ~OPpCONST_STRICT;
6531 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6532 if (PERLDB_SUB && PL_curstash != PL_debstash)
6533 o->op_private |= OPpENTERSUB_DB;
6534 while (o2 != cvop) {
6538 return too_many_arguments(o, gv_ename(namegv));
6556 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6558 arg == 1 ? "block or sub {}" : "sub {}",
6559 gv_ename(namegv), o2);
6562 /* '*' allows any scalar type, including bareword */
6565 if (o2->op_type == OP_RV2GV)
6566 goto wrapref; /* autoconvert GLOB -> GLOBref */
6567 else if (o2->op_type == OP_CONST)
6568 o2->op_private &= ~OPpCONST_STRICT;
6569 else if (o2->op_type == OP_ENTERSUB) {
6570 /* accidental subroutine, revert to bareword */
6571 OP *gvop = ((UNOP*)o2)->op_first;
6572 if (gvop && gvop->op_type == OP_NULL) {
6573 gvop = ((UNOP*)gvop)->op_first;
6575 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6578 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6579 (gvop = ((UNOP*)gvop)->op_first) &&
6580 gvop->op_type == OP_GV)
6582 GV *gv = cGVOPx_gv(gvop);
6583 OP *sibling = o2->op_sibling;
6584 SV *n = newSVpvn("",0);
6586 gv_fullname3(n, gv, "");
6587 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6588 sv_chop(n, SvPVX(n)+6);
6589 o2 = newSVOP(OP_CONST, 0, n);
6590 prev->op_sibling = o2;
6591 o2->op_sibling = sibling;
6603 if (o2->op_type != OP_RV2GV)
6604 bad_type(arg, "symbol", gv_ename(namegv), o2);
6607 if (o2->op_type != OP_ENTERSUB)
6608 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6611 if (o2->op_type != OP_RV2SV
6612 && o2->op_type != OP_PADSV
6613 && o2->op_type != OP_HELEM
6614 && o2->op_type != OP_AELEM
6615 && o2->op_type != OP_THREADSV)
6617 bad_type(arg, "scalar", gv_ename(namegv), o2);
6621 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6622 bad_type(arg, "array", gv_ename(namegv), o2);
6625 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6626 bad_type(arg, "hash", gv_ename(namegv), o2);
6630 OP* sib = kid->op_sibling;
6631 kid->op_sibling = 0;
6632 o2 = newUNOP(OP_REFGEN, 0, kid);
6633 o2->op_sibling = sib;
6634 prev->op_sibling = o2;
6645 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6646 gv_ename(namegv), SvPV((SV*)cv, n_a));
6651 mod(o2, OP_ENTERSUB);
6653 o2 = o2->op_sibling;
6655 if (proto && !optional &&
6656 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6657 return too_few_arguments(o, gv_ename(namegv));
6662 Perl_ck_svconst(pTHX_ OP *o)
6664 SvREADONLY_on(cSVOPo->op_sv);
6669 Perl_ck_trunc(pTHX_ OP *o)
6671 if (o->op_flags & OPf_KIDS) {
6672 SVOP *kid = (SVOP*)cUNOPo->op_first;
6674 if (kid->op_type == OP_NULL)
6675 kid = (SVOP*)kid->op_sibling;
6676 if (kid && kid->op_type == OP_CONST &&
6677 (kid->op_private & OPpCONST_BARE))
6679 o->op_flags |= OPf_SPECIAL;
6680 kid->op_private &= ~OPpCONST_STRICT;
6687 Perl_ck_substr(pTHX_ OP *o)
6690 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6691 OP *kid = cLISTOPo->op_first;
6693 if (kid->op_type == OP_NULL)
6694 kid = kid->op_sibling;
6696 kid->op_flags |= OPf_MOD;
6702 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6705 Perl_peep(pTHX_ register OP *o)
6707 register OP* oldop = 0;
6710 if (!o || o->op_seq)
6714 SAVEVPTR(PL_curcop);
6715 for (; o; o = o->op_next) {
6721 switch (o->op_type) {
6725 PL_curcop = ((COP*)o); /* for warnings */
6726 o->op_seq = PL_op_seqmax++;
6730 if (cSVOPo->op_private & OPpCONST_STRICT)
6731 no_bareword_allowed(o);
6733 /* Relocate sv to the pad for thread safety.
6734 * Despite being a "constant", the SV is written to,
6735 * for reference counts, sv_upgrade() etc. */
6737 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6738 if (SvPADTMP(cSVOPo->op_sv)) {
6739 /* If op_sv is already a PADTMP then it is being used by
6740 * some pad, so make a copy. */
6741 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6742 SvREADONLY_on(PL_curpad[ix]);
6743 SvREFCNT_dec(cSVOPo->op_sv);
6746 SvREFCNT_dec(PL_curpad[ix]);
6747 SvPADTMP_on(cSVOPo->op_sv);
6748 PL_curpad[ix] = cSVOPo->op_sv;
6749 /* XXX I don't know how this isn't readonly already. */
6750 SvREADONLY_on(PL_curpad[ix]);
6752 cSVOPo->op_sv = Nullsv;
6756 o->op_seq = PL_op_seqmax++;
6760 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6761 if (o->op_next->op_private & OPpTARGET_MY) {
6762 if (o->op_flags & OPf_STACKED) /* chained concats */
6763 goto ignore_optimization;
6765 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6766 o->op_targ = o->op_next->op_targ;
6767 o->op_next->op_targ = 0;
6768 o->op_private |= OPpTARGET_MY;
6773 ignore_optimization:
6774 o->op_seq = PL_op_seqmax++;
6777 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6778 o->op_seq = PL_op_seqmax++;
6779 break; /* Scalar stub must produce undef. List stub is noop */
6783 if (o->op_targ == OP_NEXTSTATE
6784 || o->op_targ == OP_DBSTATE
6785 || o->op_targ == OP_SETSTATE)
6787 PL_curcop = ((COP*)o);
6794 if (oldop && o->op_next) {
6795 oldop->op_next = o->op_next;
6798 o->op_seq = PL_op_seqmax++;
6802 if (o->op_next->op_type == OP_RV2SV) {
6803 if (!(o->op_next->op_private & OPpDEREF)) {
6805 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6807 o->op_next = o->op_next->op_next;
6808 o->op_type = OP_GVSV;
6809 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6812 else if (o->op_next->op_type == OP_RV2AV) {
6813 OP* pop = o->op_next->op_next;
6815 if (pop->op_type == OP_CONST &&
6816 (PL_op = pop->op_next) &&
6817 pop->op_next->op_type == OP_AELEM &&
6818 !(pop->op_next->op_private &
6819 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6820 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6828 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6829 o->op_next = pop->op_next->op_next;
6830 o->op_type = OP_AELEMFAST;
6831 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6832 o->op_private = (U8)i;
6837 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6839 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6840 /* XXX could check prototype here instead of just carping */
6841 SV *sv = sv_newmortal();
6842 gv_efullname3(sv, gv, Nullch);
6843 Perl_warner(aTHX_ WARN_PROTOTYPE,
6844 "%s() called too early to check prototype",
6849 o->op_seq = PL_op_seqmax++;
6860 o->op_seq = PL_op_seqmax++;
6861 while (cLOGOP->op_other->op_type == OP_NULL)
6862 cLOGOP->op_other = cLOGOP->op_other->op_next;
6863 peep(cLOGOP->op_other);
6868 o->op_seq = PL_op_seqmax++;
6869 while (cLOOP->op_redoop->op_type == OP_NULL)
6870 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6871 peep(cLOOP->op_redoop);
6872 while (cLOOP->op_nextop->op_type == OP_NULL)
6873 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6874 peep(cLOOP->op_nextop);
6875 while (cLOOP->op_lastop->op_type == OP_NULL)
6876 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6877 peep(cLOOP->op_lastop);
6883 o->op_seq = PL_op_seqmax++;
6884 while (cPMOP->op_pmreplstart &&
6885 cPMOP->op_pmreplstart->op_type == OP_NULL)
6886 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6887 peep(cPMOP->op_pmreplstart);
6891 o->op_seq = PL_op_seqmax++;
6892 if (ckWARN(WARN_SYNTAX) && o->op_next
6893 && o->op_next->op_type == OP_NEXTSTATE) {
6894 if (o->op_next->op_sibling &&
6895 o->op_next->op_sibling->op_type != OP_EXIT &&
6896 o->op_next->op_sibling->op_type != OP_WARN &&
6897 o->op_next->op_sibling->op_type != OP_DIE) {
6898 line_t oldline = CopLINE(PL_curcop);
6900 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6901 Perl_warner(aTHX_ WARN_EXEC,
6902 "Statement unlikely to be reached");
6903 Perl_warner(aTHX_ WARN_EXEC,
6904 "\t(Maybe you meant system() when you said exec()?)\n");
6905 CopLINE_set(PL_curcop, oldline);
6914 SV **svp, **indsvp, *sv;
6919 o->op_seq = PL_op_seqmax++;
6921 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6924 /* Make the CONST have a shared SV */
6925 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6926 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6927 key = SvPV(sv, keylen);
6930 lexname = newSVpvn_share(key, keylen, 0);
6935 if ((o->op_private & (OPpLVAL_INTRO)))
6938 rop = (UNOP*)((BINOP*)o)->op_first;
6939 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6941 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6942 if (!SvOBJECT(lexname))
6944 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6945 if (!fields || !GvHV(*fields))
6947 key = SvPV(*svp, keylen);
6950 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6952 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6953 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6955 ind = SvIV(*indsvp);
6957 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6958 rop->op_type = OP_RV2AV;
6959 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6960 o->op_type = OP_AELEM;
6961 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6963 if (SvREADONLY(*svp))
6965 SvFLAGS(sv) |= (SvFLAGS(*svp)
6966 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6976 SV **svp, **indsvp, *sv;
6980 SVOP *first_key_op, *key_op;
6982 o->op_seq = PL_op_seqmax++;
6983 if ((o->op_private & (OPpLVAL_INTRO))
6984 /* I bet there's always a pushmark... */
6985 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6986 /* hmmm, no optimization if list contains only one key. */
6988 rop = (UNOP*)((LISTOP*)o)->op_last;
6989 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6991 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6992 if (!SvOBJECT(lexname))
6994 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6995 if (!fields || !GvHV(*fields))
6997 /* Again guessing that the pushmark can be jumped over.... */
6998 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6999 ->op_first->op_sibling;
7000 /* Check that the key list contains only constants. */
7001 for (key_op = first_key_op; key_op;
7002 key_op = (SVOP*)key_op->op_sibling)
7003 if (key_op->op_type != OP_CONST)
7007 rop->op_type = OP_RV2AV;
7008 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7009 o->op_type = OP_ASLICE;
7010 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7011 for (key_op = first_key_op; key_op;
7012 key_op = (SVOP*)key_op->op_sibling) {
7013 svp = cSVOPx_svp(key_op);
7014 key = SvPV(*svp, keylen);
7017 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7019 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7020 "in variable %s of type %s",
7021 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7023 ind = SvIV(*indsvp);
7025 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7027 if (SvREADONLY(*svp))
7029 SvFLAGS(sv) |= (SvFLAGS(*svp)
7030 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7038 o->op_seq = PL_op_seqmax++;
7048 /* Efficient sub that returns a constant scalar value. */
7050 const_sv_xsub(pTHXo_ CV* cv)
7055 Perl_croak(aTHX_ "usage: %s::%s()",
7056 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7060 ST(0) = (SV*)XSANY.any_ptr;