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 PL_hints |= HINT_BLOCK_SCOPE;
2658 complement = o->op_private & OPpTRANS_COMPLEMENT;
2659 del = o->op_private & OPpTRANS_DELETE;
2660 squash = o->op_private & OPpTRANS_SQUASH;
2663 o->op_private |= OPpTRANS_FROM_UTF;
2666 o->op_private |= OPpTRANS_TO_UTF;
2668 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2669 SV* listsv = newSVpvn("# comment\n",10);
2671 U8* tend = t + tlen;
2672 U8* rend = r + rlen;
2686 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2687 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2693 tsave = t = bytes_to_utf8(t, &len);
2696 if (!to_utf && rlen) {
2698 rsave = r = bytes_to_utf8(r, &len);
2702 /* There are several snags with this code on EBCDIC:
2703 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2704 2. scan_const() in toke.c has encoded chars in native encoding which makes
2705 ranges at least in EBCDIC 0..255 range the bottom odd.
2709 U8 tmpbuf[UTF8_MAXLEN+1];
2712 New(1109, cp, 2*tlen, UV);
2714 transv = newSVpvn("",0);
2716 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2718 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2720 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2724 cp[2*i+1] = cp[2*i];
2728 qsort(cp, i, 2*sizeof(UV), uvcompare);
2729 for (j = 0; j < i; j++) {
2731 diff = val - nextmin;
2733 t = uvuni_to_utf8(tmpbuf,nextmin);
2734 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2736 U8 range_mark = UTF_TO_NATIVE(0xff);
2737 t = uvuni_to_utf8(tmpbuf, val - 1);
2738 sv_catpvn(transv, (char *)&range_mark, 1);
2739 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2746 t = uvuni_to_utf8(tmpbuf,nextmin);
2747 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2749 U8 range_mark = UTF_TO_NATIVE(0xff);
2750 sv_catpvn(transv, (char *)&range_mark, 1);
2752 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2753 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2754 t = (U8*)SvPVX(transv);
2755 tlen = SvCUR(transv);
2759 else if (!rlen && !del) {
2760 r = t; rlen = tlen; rend = tend;
2763 if ((!rlen && !del) || t == r ||
2764 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2766 o->op_private |= OPpTRANS_IDENTICAL;
2770 while (t < tend || tfirst <= tlast) {
2771 /* see if we need more "t" chars */
2772 if (tfirst > tlast) {
2773 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2775 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2777 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2784 /* now see if we need more "r" chars */
2785 if (rfirst > rlast) {
2787 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2789 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2791 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2800 rfirst = rlast = 0xffffffff;
2804 /* now see which range will peter our first, if either. */
2805 tdiff = tlast - tfirst;
2806 rdiff = rlast - rfirst;
2813 if (rfirst == 0xffffffff) {
2814 diff = tdiff; /* oops, pretend rdiff is infinite */
2816 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2817 (long)tfirst, (long)tlast);
2819 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2823 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2824 (long)tfirst, (long)(tfirst + diff),
2827 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2828 (long)tfirst, (long)rfirst);
2830 if (rfirst + diff > max)
2831 max = rfirst + diff;
2833 grows = (tfirst < rfirst &&
2834 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2846 else if (max > 0xff)
2851 Safefree(cPVOPo->op_pv);
2852 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2853 SvREFCNT_dec(listsv);
2855 SvREFCNT_dec(transv);
2857 if (!del && havefinal && rlen)
2858 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2859 newSVuv((UV)final), 0);
2862 o->op_private |= OPpTRANS_GROWS;
2874 tbl = (short*)cPVOPo->op_pv;
2876 Zero(tbl, 256, short);
2877 for (i = 0; i < tlen; i++)
2879 for (i = 0, j = 0; i < 256; i++) {
2890 if (i < 128 && r[j] >= 128)
2900 o->op_private |= OPpTRANS_IDENTICAL;
2905 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2906 tbl[0x100] = rlen - j;
2907 for (i=0; i < rlen - j; i++)
2908 tbl[0x101+i] = r[j+i];
2912 if (!rlen && !del) {
2915 o->op_private |= OPpTRANS_IDENTICAL;
2917 for (i = 0; i < 256; i++)
2919 for (i = 0, j = 0; i < tlen; i++,j++) {
2922 if (tbl[t[i]] == -1)
2928 if (tbl[t[i]] == -1) {
2929 if (t[i] < 128 && r[j] >= 128)
2936 o->op_private |= OPpTRANS_GROWS;
2944 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2948 NewOp(1101, pmop, 1, PMOP);
2949 pmop->op_type = type;
2950 pmop->op_ppaddr = PL_ppaddr[type];
2951 pmop->op_flags = flags;
2952 pmop->op_private = 0 | (flags >> 8);
2954 if (PL_hints & HINT_RE_TAINT)
2955 pmop->op_pmpermflags |= PMf_RETAINT;
2956 if (PL_hints & HINT_LOCALE)
2957 pmop->op_pmpermflags |= PMf_LOCALE;
2958 pmop->op_pmflags = pmop->op_pmpermflags;
2960 /* link into pm list */
2961 if (type != OP_TRANS && PL_curstash) {
2962 pmop->op_pmnext = HvPMROOT(PL_curstash);
2963 HvPMROOT(PL_curstash) = pmop;
2964 PmopSTASH_set(pmop,PL_curstash);
2971 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2975 I32 repl_has_vars = 0;
2977 if (o->op_type == OP_TRANS)
2978 return pmtrans(o, expr, repl);
2980 PL_hints |= HINT_BLOCK_SCOPE;
2983 if (expr->op_type == OP_CONST) {
2985 SV *pat = ((SVOP*)expr)->op_sv;
2986 char *p = SvPV(pat, plen);
2987 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2988 sv_setpvn(pat, "\\s+", 3);
2989 p = SvPV(pat, plen);
2990 pm->op_pmflags |= PMf_SKIPWHITE;
2992 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2993 pm->op_pmdynflags |= PMdf_UTF8;
2994 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2995 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2996 pm->op_pmflags |= PMf_WHITE;
3000 if (PL_hints & HINT_UTF8)
3001 pm->op_pmdynflags |= PMdf_UTF8;
3002 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3003 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3005 : OP_REGCMAYBE),0,expr);
3007 NewOp(1101, rcop, 1, LOGOP);
3008 rcop->op_type = OP_REGCOMP;
3009 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3010 rcop->op_first = scalar(expr);
3011 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3012 ? (OPf_SPECIAL | OPf_KIDS)
3014 rcop->op_private = 1;
3017 /* establish postfix order */
3018 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3020 rcop->op_next = expr;
3021 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3024 rcop->op_next = LINKLIST(expr);
3025 expr->op_next = (OP*)rcop;
3028 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3033 if (pm->op_pmflags & PMf_EVAL) {
3035 if (CopLINE(PL_curcop) < PL_multi_end)
3036 CopLINE_set(PL_curcop, PL_multi_end);
3039 else if (repl->op_type == OP_THREADSV
3040 && strchr("&`'123456789+",
3041 PL_threadsv_names[repl->op_targ]))
3045 #endif /* USE_THREADS */
3046 else if (repl->op_type == OP_CONST)
3050 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3051 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3053 if (curop->op_type == OP_THREADSV) {
3055 if (strchr("&`'123456789+", curop->op_private))
3059 if (curop->op_type == OP_GV) {
3060 GV *gv = cGVOPx_gv(curop);
3062 if (strchr("&`'123456789+", *GvENAME(gv)))
3065 #endif /* USE_THREADS */
3066 else if (curop->op_type == OP_RV2CV)
3068 else if (curop->op_type == OP_RV2SV ||
3069 curop->op_type == OP_RV2AV ||
3070 curop->op_type == OP_RV2HV ||
3071 curop->op_type == OP_RV2GV) {
3072 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3075 else if (curop->op_type == OP_PADSV ||
3076 curop->op_type == OP_PADAV ||
3077 curop->op_type == OP_PADHV ||
3078 curop->op_type == OP_PADANY) {
3081 else if (curop->op_type == OP_PUSHRE)
3082 ; /* Okay here, dangerous in newASSIGNOP */
3091 && (!pm->op_pmregexp
3092 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3093 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3094 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3095 prepend_elem(o->op_type, scalar(repl), o);
3098 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3099 pm->op_pmflags |= PMf_MAYBE_CONST;
3100 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3102 NewOp(1101, rcop, 1, LOGOP);
3103 rcop->op_type = OP_SUBSTCONT;
3104 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3105 rcop->op_first = scalar(repl);
3106 rcop->op_flags |= OPf_KIDS;
3107 rcop->op_private = 1;
3110 /* establish postfix order */
3111 rcop->op_next = LINKLIST(repl);
3112 repl->op_next = (OP*)rcop;
3114 pm->op_pmreplroot = scalar((OP*)rcop);
3115 pm->op_pmreplstart = LINKLIST(rcop);
3124 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3127 NewOp(1101, svop, 1, SVOP);
3128 svop->op_type = type;
3129 svop->op_ppaddr = PL_ppaddr[type];
3131 svop->op_next = (OP*)svop;
3132 svop->op_flags = flags;
3133 if (PL_opargs[type] & OA_RETSCALAR)
3135 if (PL_opargs[type] & OA_TARGET)
3136 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3137 return CHECKOP(type, svop);
3141 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3144 NewOp(1101, padop, 1, PADOP);
3145 padop->op_type = type;
3146 padop->op_ppaddr = PL_ppaddr[type];
3147 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3148 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3149 PL_curpad[padop->op_padix] = sv;
3151 padop->op_next = (OP*)padop;
3152 padop->op_flags = flags;
3153 if (PL_opargs[type] & OA_RETSCALAR)
3155 if (PL_opargs[type] & OA_TARGET)
3156 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3157 return CHECKOP(type, padop);
3161 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3165 return newPADOP(type, flags, SvREFCNT_inc(gv));
3167 return newSVOP(type, flags, SvREFCNT_inc(gv));
3172 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3175 NewOp(1101, pvop, 1, PVOP);
3176 pvop->op_type = type;
3177 pvop->op_ppaddr = PL_ppaddr[type];
3179 pvop->op_next = (OP*)pvop;
3180 pvop->op_flags = flags;
3181 if (PL_opargs[type] & OA_RETSCALAR)
3183 if (PL_opargs[type] & OA_TARGET)
3184 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3185 return CHECKOP(type, pvop);
3189 Perl_package(pTHX_ OP *o)
3193 save_hptr(&PL_curstash);
3194 save_item(PL_curstname);
3199 name = SvPV(sv, len);
3200 PL_curstash = gv_stashpvn(name,len,TRUE);
3201 sv_setpvn(PL_curstname, name, len);
3205 sv_setpv(PL_curstname,"<none>");
3206 PL_curstash = Nullhv;
3208 PL_hints |= HINT_BLOCK_SCOPE;
3209 PL_copline = NOLINE;
3214 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3222 if (id->op_type != OP_CONST)
3223 Perl_croak(aTHX_ "Module name must be constant");
3227 if (version != Nullop) {
3228 SV *vesv = ((SVOP*)version)->op_sv;
3230 if (arg == Nullop && !SvNIOKp(vesv)) {
3237 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3238 Perl_croak(aTHX_ "Version number must be constant number");
3240 /* Make copy of id so we don't free it twice */
3241 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3243 /* Fake up a method call to VERSION */
3244 meth = newSVpvn("VERSION",7);
3245 sv_upgrade(meth, SVt_PVIV);
3246 (void)SvIOK_on(meth);
3247 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3248 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3249 append_elem(OP_LIST,
3250 prepend_elem(OP_LIST, pack, list(version)),
3251 newSVOP(OP_METHOD_NAMED, 0, meth)));
3255 /* Fake up an import/unimport */
3256 if (arg && arg->op_type == OP_STUB)
3257 imop = arg; /* no import on explicit () */
3258 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3259 imop = Nullop; /* use 5.0; */
3264 /* Make copy of id so we don't free it twice */
3265 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3267 /* Fake up a method call to import/unimport */
3268 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3269 sv_upgrade(meth, SVt_PVIV);
3270 (void)SvIOK_on(meth);
3271 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3272 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3273 append_elem(OP_LIST,
3274 prepend_elem(OP_LIST, pack, list(arg)),
3275 newSVOP(OP_METHOD_NAMED, 0, meth)));
3278 /* Fake up a require, handle override, if any */
3279 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3280 if (!(gv && GvIMPORTED_CV(gv)))
3281 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3283 if (gv && GvIMPORTED_CV(gv)) {
3284 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3285 append_elem(OP_LIST, id,
3286 scalar(newUNOP(OP_RV2CV, 0,
3291 rqop = newUNOP(OP_REQUIRE, 0, id);
3294 /* Fake up the BEGIN {}, which does its thing immediately. */
3296 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3299 append_elem(OP_LINESEQ,
3300 append_elem(OP_LINESEQ,
3301 newSTATEOP(0, Nullch, rqop),
3302 newSTATEOP(0, Nullch, veop)),
3303 newSTATEOP(0, Nullch, imop) ));
3305 PL_hints |= HINT_BLOCK_SCOPE;
3306 PL_copline = NOLINE;
3311 =for apidoc load_module
3313 Loads the module whose name is pointed to by the string part of name.
3314 Note that the actual module name, not its filename, should be given.
3315 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3316 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3317 (or 0 for no flags). ver, if specified, provides version semantics
3318 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3319 arguments can be used to specify arguments to the module's import()
3320 method, similar to C<use Foo::Bar VERSION LIST>.
3325 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3328 va_start(args, ver);
3329 vload_module(flags, name, ver, &args);
3333 #ifdef PERL_IMPLICIT_CONTEXT
3335 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3339 va_start(args, ver);
3340 vload_module(flags, name, ver, &args);
3346 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3348 OP *modname, *veop, *imop;
3350 modname = newSVOP(OP_CONST, 0, name);
3351 modname->op_private |= OPpCONST_BARE;
3353 veop = newSVOP(OP_CONST, 0, ver);
3357 if (flags & PERL_LOADMOD_NOIMPORT) {
3358 imop = sawparens(newNULLLIST());
3360 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3361 imop = va_arg(*args, OP*);
3366 sv = va_arg(*args, SV*);
3368 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3369 sv = va_arg(*args, SV*);
3373 line_t ocopline = PL_copline;
3374 int oexpect = PL_expect;
3376 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3377 veop, modname, imop);
3378 PL_expect = oexpect;
3379 PL_copline = ocopline;
3384 Perl_dofile(pTHX_ OP *term)
3389 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3390 if (!(gv && GvIMPORTED_CV(gv)))
3391 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3393 if (gv && GvIMPORTED_CV(gv)) {
3394 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3395 append_elem(OP_LIST, term,
3396 scalar(newUNOP(OP_RV2CV, 0,
3401 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3407 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3409 return newBINOP(OP_LSLICE, flags,
3410 list(force_list(subscript)),
3411 list(force_list(listval)) );
3415 S_list_assignment(pTHX_ register OP *o)
3420 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3421 o = cUNOPo->op_first;
3423 if (o->op_type == OP_COND_EXPR) {
3424 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3425 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3430 yyerror("Assignment to both a list and a scalar");
3434 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3435 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3436 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3439 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3442 if (o->op_type == OP_RV2SV)
3449 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3454 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3455 return newLOGOP(optype, 0,
3456 mod(scalar(left), optype),
3457 newUNOP(OP_SASSIGN, 0, scalar(right)));
3460 return newBINOP(optype, OPf_STACKED,
3461 mod(scalar(left), optype), scalar(right));
3465 if (list_assignment(left)) {
3469 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3470 left = mod(left, OP_AASSIGN);
3478 curop = list(force_list(left));
3479 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3480 o->op_private = 0 | (flags >> 8);
3481 for (curop = ((LISTOP*)curop)->op_first;
3482 curop; curop = curop->op_sibling)
3484 if (curop->op_type == OP_RV2HV &&
3485 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3486 o->op_private |= OPpASSIGN_HASH;
3490 if (!(left->op_private & OPpLVAL_INTRO)) {
3493 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3494 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3495 if (curop->op_type == OP_GV) {
3496 GV *gv = cGVOPx_gv(curop);
3497 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3499 SvCUR(gv) = PL_generation;
3501 else if (curop->op_type == OP_PADSV ||
3502 curop->op_type == OP_PADAV ||
3503 curop->op_type == OP_PADHV ||
3504 curop->op_type == OP_PADANY) {
3505 SV **svp = AvARRAY(PL_comppad_name);
3506 SV *sv = svp[curop->op_targ];
3507 if (SvCUR(sv) == PL_generation)
3509 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3511 else if (curop->op_type == OP_RV2CV)
3513 else if (curop->op_type == OP_RV2SV ||
3514 curop->op_type == OP_RV2AV ||
3515 curop->op_type == OP_RV2HV ||
3516 curop->op_type == OP_RV2GV) {
3517 if (lastop->op_type != OP_GV) /* funny deref? */
3520 else if (curop->op_type == OP_PUSHRE) {
3521 if (((PMOP*)curop)->op_pmreplroot) {
3523 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3525 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3527 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3529 SvCUR(gv) = PL_generation;
3538 o->op_private |= OPpASSIGN_COMMON;
3540 if (right && right->op_type == OP_SPLIT) {
3542 if ((tmpop = ((LISTOP*)right)->op_first) &&
3543 tmpop->op_type == OP_PUSHRE)
3545 PMOP *pm = (PMOP*)tmpop;
3546 if (left->op_type == OP_RV2AV &&
3547 !(left->op_private & OPpLVAL_INTRO) &&
3548 !(o->op_private & OPpASSIGN_COMMON) )
3550 tmpop = ((UNOP*)left)->op_first;
3551 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3553 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3554 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3556 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3557 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3559 pm->op_pmflags |= PMf_ONCE;
3560 tmpop = cUNOPo->op_first; /* to list (nulled) */
3561 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3562 tmpop->op_sibling = Nullop; /* don't free split */
3563 right->op_next = tmpop->op_next; /* fix starting loc */
3564 op_free(o); /* blow off assign */
3565 right->op_flags &= ~OPf_WANT;
3566 /* "I don't know and I don't care." */
3571 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3572 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3574 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3576 sv_setiv(sv, PL_modcount+1);
3584 right = newOP(OP_UNDEF, 0);
3585 if (right->op_type == OP_READLINE) {
3586 right->op_flags |= OPf_STACKED;
3587 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3590 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3591 o = newBINOP(OP_SASSIGN, flags,
3592 scalar(right), mod(scalar(left), OP_SASSIGN) );
3604 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3606 U32 seq = intro_my();
3609 NewOp(1101, cop, 1, COP);
3610 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3611 cop->op_type = OP_DBSTATE;
3612 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3615 cop->op_type = OP_NEXTSTATE;
3616 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3618 cop->op_flags = flags;
3619 cop->op_private = (PL_hints & HINT_BYTE);
3621 cop->op_private |= NATIVE_HINTS;
3623 PL_compiling.op_private = cop->op_private;
3624 cop->op_next = (OP*)cop;
3627 cop->cop_label = label;
3628 PL_hints |= HINT_BLOCK_SCOPE;
3631 cop->cop_arybase = PL_curcop->cop_arybase;
3632 if (specialWARN(PL_curcop->cop_warnings))
3633 cop->cop_warnings = PL_curcop->cop_warnings ;
3635 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3636 if (specialCopIO(PL_curcop->cop_io))
3637 cop->cop_io = PL_curcop->cop_io;
3639 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3642 if (PL_copline == NOLINE)
3643 CopLINE_set(cop, CopLINE(PL_curcop));
3645 CopLINE_set(cop, PL_copline);
3646 PL_copline = NOLINE;
3649 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3651 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3653 CopSTASH_set(cop, PL_curstash);
3655 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3656 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3657 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3658 (void)SvIOK_on(*svp);
3659 SvIVX(*svp) = PTR2IV(cop);
3663 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3666 /* "Introduce" my variables to visible status. */
3674 if (! PL_min_intro_pending)
3675 return PL_cop_seqmax;
3677 svp = AvARRAY(PL_comppad_name);
3678 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3679 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3680 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3681 SvNVX(sv) = (NV)PL_cop_seqmax;
3684 PL_min_intro_pending = 0;
3685 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3686 return PL_cop_seqmax++;
3690 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3692 return new_logop(type, flags, &first, &other);
3696 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3700 OP *first = *firstp;
3701 OP *other = *otherp;
3703 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3704 return newBINOP(type, flags, scalar(first), scalar(other));
3706 scalarboolean(first);
3707 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3708 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3709 if (type == OP_AND || type == OP_OR) {
3715 first = *firstp = cUNOPo->op_first;
3717 first->op_next = o->op_next;
3718 cUNOPo->op_first = Nullop;
3722 if (first->op_type == OP_CONST) {
3723 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3724 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3725 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3736 else if (first->op_type == OP_WANTARRAY) {
3742 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3743 OP *k1 = ((UNOP*)first)->op_first;
3744 OP *k2 = k1->op_sibling;
3746 switch (first->op_type)
3749 if (k2 && k2->op_type == OP_READLINE
3750 && (k2->op_flags & OPf_STACKED)
3751 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3753 warnop = k2->op_type;
3758 if (k1->op_type == OP_READDIR
3759 || k1->op_type == OP_GLOB
3760 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3761 || k1->op_type == OP_EACH)
3763 warnop = ((k1->op_type == OP_NULL)
3764 ? k1->op_targ : k1->op_type);
3769 line_t oldline = CopLINE(PL_curcop);
3770 CopLINE_set(PL_curcop, PL_copline);
3771 Perl_warner(aTHX_ WARN_MISC,
3772 "Value of %s%s can be \"0\"; test with defined()",
3774 ((warnop == OP_READLINE || warnop == OP_GLOB)
3775 ? " construct" : "() operator"));
3776 CopLINE_set(PL_curcop, oldline);
3783 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3784 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3786 NewOp(1101, logop, 1, LOGOP);
3788 logop->op_type = type;
3789 logop->op_ppaddr = PL_ppaddr[type];
3790 logop->op_first = first;
3791 logop->op_flags = flags | OPf_KIDS;
3792 logop->op_other = LINKLIST(other);
3793 logop->op_private = 1 | (flags >> 8);
3795 /* establish postfix order */
3796 logop->op_next = LINKLIST(first);
3797 first->op_next = (OP*)logop;
3798 first->op_sibling = other;
3800 o = newUNOP(OP_NULL, 0, (OP*)logop);
3807 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3814 return newLOGOP(OP_AND, 0, first, trueop);
3816 return newLOGOP(OP_OR, 0, first, falseop);
3818 scalarboolean(first);
3819 if (first->op_type == OP_CONST) {
3820 if (SvTRUE(((SVOP*)first)->op_sv)) {
3831 else if (first->op_type == OP_WANTARRAY) {
3835 NewOp(1101, logop, 1, LOGOP);
3836 logop->op_type = OP_COND_EXPR;
3837 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3838 logop->op_first = first;
3839 logop->op_flags = flags | OPf_KIDS;
3840 logop->op_private = 1 | (flags >> 8);
3841 logop->op_other = LINKLIST(trueop);
3842 logop->op_next = LINKLIST(falseop);
3845 /* establish postfix order */
3846 start = LINKLIST(first);
3847 first->op_next = (OP*)logop;
3849 first->op_sibling = trueop;
3850 trueop->op_sibling = falseop;
3851 o = newUNOP(OP_NULL, 0, (OP*)logop);
3853 trueop->op_next = falseop->op_next = o;
3860 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3868 NewOp(1101, range, 1, LOGOP);
3870 range->op_type = OP_RANGE;
3871 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3872 range->op_first = left;
3873 range->op_flags = OPf_KIDS;
3874 leftstart = LINKLIST(left);
3875 range->op_other = LINKLIST(right);
3876 range->op_private = 1 | (flags >> 8);
3878 left->op_sibling = right;
3880 range->op_next = (OP*)range;
3881 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3882 flop = newUNOP(OP_FLOP, 0, flip);
3883 o = newUNOP(OP_NULL, 0, flop);
3885 range->op_next = leftstart;
3887 left->op_next = flip;
3888 right->op_next = flop;
3890 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3891 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3892 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3893 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3895 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3896 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3899 if (!flip->op_private || !flop->op_private)
3900 linklist(o); /* blow off optimizer unless constant */
3906 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3910 int once = block && block->op_flags & OPf_SPECIAL &&
3911 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3914 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3915 return block; /* do {} while 0 does once */
3916 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3917 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3918 expr = newUNOP(OP_DEFINED, 0,
3919 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3920 } else if (expr->op_flags & OPf_KIDS) {
3921 OP *k1 = ((UNOP*)expr)->op_first;
3922 OP *k2 = (k1) ? k1->op_sibling : NULL;
3923 switch (expr->op_type) {
3925 if (k2 && k2->op_type == OP_READLINE
3926 && (k2->op_flags & OPf_STACKED)
3927 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3928 expr = newUNOP(OP_DEFINED, 0, expr);
3932 if (k1->op_type == OP_READDIR
3933 || k1->op_type == OP_GLOB
3934 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3935 || k1->op_type == OP_EACH)
3936 expr = newUNOP(OP_DEFINED, 0, expr);
3942 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3943 o = new_logop(OP_AND, 0, &expr, &listop);
3946 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3948 if (once && o != listop)
3949 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3952 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3954 o->op_flags |= flags;
3956 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3961 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3970 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3971 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3972 expr = newUNOP(OP_DEFINED, 0,
3973 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3974 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3975 OP *k1 = ((UNOP*)expr)->op_first;
3976 OP *k2 = (k1) ? k1->op_sibling : NULL;
3977 switch (expr->op_type) {
3979 if (k2 && k2->op_type == OP_READLINE
3980 && (k2->op_flags & OPf_STACKED)
3981 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3982 expr = newUNOP(OP_DEFINED, 0, expr);
3986 if (k1->op_type == OP_READDIR
3987 || k1->op_type == OP_GLOB
3988 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3989 || k1->op_type == OP_EACH)
3990 expr = newUNOP(OP_DEFINED, 0, expr);
3996 block = newOP(OP_NULL, 0);
3998 block = scope(block);
4002 next = LINKLIST(cont);
4005 OP *unstack = newOP(OP_UNSTACK, 0);
4008 cont = append_elem(OP_LINESEQ, cont, unstack);
4009 if ((line_t)whileline != NOLINE) {
4010 PL_copline = whileline;
4011 cont = append_elem(OP_LINESEQ, cont,
4012 newSTATEOP(0, Nullch, Nullop));
4016 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4017 redo = LINKLIST(listop);
4020 PL_copline = whileline;
4022 o = new_logop(OP_AND, 0, &expr, &listop);
4023 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4024 op_free(expr); /* oops, it's a while (0) */
4026 return Nullop; /* listop already freed by new_logop */
4029 ((LISTOP*)listop)->op_last->op_next = condop =
4030 (o == listop ? redo : LINKLIST(o));
4036 NewOp(1101,loop,1,LOOP);
4037 loop->op_type = OP_ENTERLOOP;
4038 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4039 loop->op_private = 0;
4040 loop->op_next = (OP*)loop;
4043 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4045 loop->op_redoop = redo;
4046 loop->op_lastop = o;
4047 o->op_private |= loopflags;
4050 loop->op_nextop = next;
4052 loop->op_nextop = o;
4054 o->op_flags |= flags;
4055 o->op_private |= (flags >> 8);
4060 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4068 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4069 sv->op_type = OP_RV2GV;
4070 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4072 else if (sv->op_type == OP_PADSV) { /* private variable */
4073 padoff = sv->op_targ;
4078 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4079 padoff = sv->op_targ;
4081 iterflags |= OPf_SPECIAL;
4086 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4090 padoff = find_threadsv("_");
4091 iterflags |= OPf_SPECIAL;
4093 sv = newGVOP(OP_GV, 0, PL_defgv);
4096 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4097 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4098 iterflags |= OPf_STACKED;
4100 else if (expr->op_type == OP_NULL &&
4101 (expr->op_flags & OPf_KIDS) &&
4102 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4104 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4105 * set the STACKED flag to indicate that these values are to be
4106 * treated as min/max values by 'pp_iterinit'.
4108 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4109 LOGOP* range = (LOGOP*) flip->op_first;
4110 OP* left = range->op_first;
4111 OP* right = left->op_sibling;
4114 range->op_flags &= ~OPf_KIDS;
4115 range->op_first = Nullop;
4117 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4118 listop->op_first->op_next = range->op_next;
4119 left->op_next = range->op_other;
4120 right->op_next = (OP*)listop;
4121 listop->op_next = listop->op_first;
4124 expr = (OP*)(listop);
4126 iterflags |= OPf_STACKED;
4129 expr = mod(force_list(expr), OP_GREPSTART);
4133 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4134 append_elem(OP_LIST, expr, scalar(sv))));
4135 assert(!loop->op_next);
4136 #ifdef PL_OP_SLAB_ALLOC
4139 NewOp(1234,tmp,1,LOOP);
4140 Copy(loop,tmp,1,LOOP);
4144 Renew(loop, 1, LOOP);
4146 loop->op_targ = padoff;
4147 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4148 PL_copline = forline;
4149 return newSTATEOP(0, label, wop);
4153 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4158 if (type != OP_GOTO || label->op_type == OP_CONST) {
4159 /* "last()" means "last" */
4160 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4161 o = newOP(type, OPf_SPECIAL);
4163 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4164 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4170 if (label->op_type == OP_ENTERSUB)
4171 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4172 o = newUNOP(type, OPf_STACKED, label);
4174 PL_hints |= HINT_BLOCK_SCOPE;
4179 Perl_cv_undef(pTHX_ CV *cv)
4183 MUTEX_DESTROY(CvMUTEXP(cv));
4184 Safefree(CvMUTEXP(cv));
4187 #endif /* USE_THREADS */
4189 if (!CvXSUB(cv) && CvROOT(cv)) {
4191 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4192 Perl_croak(aTHX_ "Can't undef active subroutine");
4195 Perl_croak(aTHX_ "Can't undef active subroutine");
4196 #endif /* USE_THREADS */
4199 SAVEVPTR(PL_curpad);
4202 op_free(CvROOT(cv));
4203 CvROOT(cv) = Nullop;
4206 SvPOK_off((SV*)cv); /* forget prototype */
4208 /* Since closure prototypes have the same lifetime as the containing
4209 * CV, they don't hold a refcount on the outside CV. This avoids
4210 * the refcount loop between the outer CV (which keeps a refcount to
4211 * the closure prototype in the pad entry for pp_anoncode()) and the
4212 * closure prototype, and the ensuing memory leak. --GSAR */
4213 if (!CvANON(cv) || CvCLONED(cv))
4214 SvREFCNT_dec(CvOUTSIDE(cv));
4215 CvOUTSIDE(cv) = Nullcv;
4217 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4220 if (CvPADLIST(cv)) {
4221 /* may be during global destruction */
4222 if (SvREFCNT(CvPADLIST(cv))) {
4223 I32 i = AvFILLp(CvPADLIST(cv));
4225 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4226 SV* sv = svp ? *svp : Nullsv;
4229 if (sv == (SV*)PL_comppad_name)
4230 PL_comppad_name = Nullav;
4231 else if (sv == (SV*)PL_comppad) {
4232 PL_comppad = Nullav;
4233 PL_curpad = Null(SV**);
4237 SvREFCNT_dec((SV*)CvPADLIST(cv));
4239 CvPADLIST(cv) = Nullav;
4244 #ifdef DEBUG_CLOSURES
4246 S_cv_dump(pTHX_ CV *cv)
4249 CV *outside = CvOUTSIDE(cv);
4250 AV* padlist = CvPADLIST(cv);
4257 PerlIO_printf(Perl_debug_log,
4258 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4260 (CvANON(cv) ? "ANON"
4261 : (cv == PL_main_cv) ? "MAIN"
4262 : CvUNIQUE(cv) ? "UNIQUE"
4263 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4266 : CvANON(outside) ? "ANON"
4267 : (outside == PL_main_cv) ? "MAIN"
4268 : CvUNIQUE(outside) ? "UNIQUE"
4269 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4274 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4275 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4276 pname = AvARRAY(pad_name);
4277 ppad = AvARRAY(pad);
4279 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4280 if (SvPOK(pname[ix]))
4281 PerlIO_printf(Perl_debug_log,
4282 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4283 (int)ix, PTR2UV(ppad[ix]),
4284 SvFAKE(pname[ix]) ? "FAKE " : "",
4286 (IV)I_32(SvNVX(pname[ix])),
4289 #endif /* DEBUGGING */
4291 #endif /* DEBUG_CLOSURES */
4294 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4298 AV* protopadlist = CvPADLIST(proto);
4299 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4300 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4301 SV** pname = AvARRAY(protopad_name);
4302 SV** ppad = AvARRAY(protopad);
4303 I32 fname = AvFILLp(protopad_name);
4304 I32 fpad = AvFILLp(protopad);
4308 assert(!CvUNIQUE(proto));
4312 SAVESPTR(PL_comppad_name);
4313 SAVESPTR(PL_compcv);
4315 cv = PL_compcv = (CV*)NEWSV(1104,0);
4316 sv_upgrade((SV *)cv, SvTYPE(proto));
4317 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4321 New(666, CvMUTEXP(cv), 1, perl_mutex);
4322 MUTEX_INIT(CvMUTEXP(cv));
4324 #endif /* USE_THREADS */
4325 CvFILE(cv) = CvFILE(proto);
4326 CvGV(cv) = CvGV(proto);
4327 CvSTASH(cv) = CvSTASH(proto);
4328 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4329 CvSTART(cv) = CvSTART(proto);
4331 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4334 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4336 PL_comppad_name = newAV();
4337 for (ix = fname; ix >= 0; ix--)
4338 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4340 PL_comppad = newAV();
4342 comppadlist = newAV();
4343 AvREAL_off(comppadlist);
4344 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4345 av_store(comppadlist, 1, (SV*)PL_comppad);
4346 CvPADLIST(cv) = comppadlist;
4347 av_fill(PL_comppad, AvFILLp(protopad));
4348 PL_curpad = AvARRAY(PL_comppad);
4350 av = newAV(); /* will be @_ */
4352 av_store(PL_comppad, 0, (SV*)av);
4353 AvFLAGS(av) = AVf_REIFY;
4355 for (ix = fpad; ix > 0; ix--) {
4356 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4357 if (namesv && namesv != &PL_sv_undef) {
4358 char *name = SvPVX(namesv); /* XXX */
4359 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4360 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4361 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4363 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4365 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4367 else { /* our own lexical */
4370 /* anon code -- we'll come back for it */
4371 sv = SvREFCNT_inc(ppad[ix]);
4373 else if (*name == '@')
4375 else if (*name == '%')
4384 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4385 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4388 SV* sv = NEWSV(0,0);
4394 /* Now that vars are all in place, clone nested closures. */
4396 for (ix = fpad; ix > 0; ix--) {
4397 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4399 && namesv != &PL_sv_undef
4400 && !(SvFLAGS(namesv) & SVf_FAKE)
4401 && *SvPVX(namesv) == '&'
4402 && CvCLONE(ppad[ix]))
4404 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4405 SvREFCNT_dec(ppad[ix]);
4408 PL_curpad[ix] = (SV*)kid;
4412 #ifdef DEBUG_CLOSURES
4413 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4415 PerlIO_printf(Perl_debug_log, " from:\n");
4417 PerlIO_printf(Perl_debug_log, " to:\n");
4424 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4426 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4428 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4435 Perl_cv_clone(pTHX_ CV *proto)
4438 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4439 cv = cv_clone2(proto, CvOUTSIDE(proto));
4440 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4445 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4447 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4448 SV* msg = sv_newmortal();
4452 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4453 sv_setpv(msg, "Prototype mismatch:");
4455 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4457 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4458 sv_catpv(msg, " vs ");
4460 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4462 sv_catpv(msg, "none");
4463 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4467 static void const_sv_xsub(pTHXo_ CV* cv);
4470 =for apidoc cv_const_sv
4472 If C<cv> is a constant sub eligible for inlining. returns the constant
4473 value returned by the sub. Otherwise, returns NULL.
4475 Constant subs can be created with C<newCONSTSUB> or as described in
4476 L<perlsub/"Constant Functions">.
4481 Perl_cv_const_sv(pTHX_ CV *cv)
4483 if (!cv || !CvCONST(cv))
4485 return (SV*)CvXSUBANY(cv).any_ptr;
4489 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4496 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4497 o = cLISTOPo->op_first->op_sibling;
4499 for (; o; o = o->op_next) {
4500 OPCODE type = o->op_type;
4502 if (sv && o->op_next == o)
4504 if (o->op_next != o) {
4505 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4507 if (type == OP_DBSTATE)
4510 if (type == OP_LEAVESUB || type == OP_RETURN)
4514 if (type == OP_CONST && cSVOPo->op_sv)
4516 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4517 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4518 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4522 /* We get here only from cv_clone2() while creating a closure.
4523 Copy the const value here instead of in cv_clone2 so that
4524 SvREADONLY_on doesn't lead to problems when leaving
4529 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4541 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4551 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4555 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4557 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4561 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4567 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4572 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4573 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4574 SV *sv = sv_newmortal();
4575 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4576 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4581 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4582 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4592 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4593 maximum a prototype before. */
4594 if (SvTYPE(gv) > SVt_NULL) {
4595 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4596 && ckWARN_d(WARN_PROTOTYPE))
4598 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4600 cv_ckproto((CV*)gv, NULL, ps);
4603 sv_setpv((SV*)gv, ps);
4605 sv_setiv((SV*)gv, -1);
4606 SvREFCNT_dec(PL_compcv);
4607 cv = PL_compcv = NULL;
4608 PL_sub_generation++;
4612 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4614 #ifdef GV_SHARED_CHECK
4615 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4616 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4620 if (!block || !ps || *ps || attrs)
4623 const_sv = op_const_sv(block, Nullcv);
4626 bool exists = CvROOT(cv) || CvXSUB(cv);
4628 #ifdef GV_SHARED_CHECK
4629 if (exists && GvSHARED(gv)) {
4630 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4634 /* if the subroutine doesn't exist and wasn't pre-declared
4635 * with a prototype, assume it will be AUTOLOADed,
4636 * skipping the prototype check
4638 if (exists || SvPOK(cv))
4639 cv_ckproto(cv, gv, ps);
4640 /* already defined (or promised)? */
4641 if (exists || GvASSUMECV(gv)) {
4642 if (!block && !attrs) {
4643 /* just a "sub foo;" when &foo is already defined */
4644 SAVEFREESV(PL_compcv);
4647 /* ahem, death to those who redefine active sort subs */
4648 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4649 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4651 if (ckWARN(WARN_REDEFINE)
4653 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4655 line_t oldline = CopLINE(PL_curcop);
4656 CopLINE_set(PL_curcop, PL_copline);
4657 Perl_warner(aTHX_ WARN_REDEFINE,
4658 CvCONST(cv) ? "Constant subroutine %s redefined"
4659 : "Subroutine %s redefined", name);
4660 CopLINE_set(PL_curcop, oldline);
4668 SvREFCNT_inc(const_sv);
4670 assert(!CvROOT(cv) && !CvCONST(cv));
4671 sv_setpv((SV*)cv, ""); /* prototype is "" */
4672 CvXSUBANY(cv).any_ptr = const_sv;
4673 CvXSUB(cv) = const_sv_xsub;
4678 cv = newCONSTSUB(NULL, name, const_sv);
4681 SvREFCNT_dec(PL_compcv);
4683 PL_sub_generation++;
4690 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4691 * before we clobber PL_compcv.
4695 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4696 stash = GvSTASH(CvGV(cv));
4697 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4698 stash = CvSTASH(cv);
4700 stash = PL_curstash;
4703 /* possibly about to re-define existing subr -- ignore old cv */
4704 rcv = (SV*)PL_compcv;
4705 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4706 stash = GvSTASH(gv);
4708 stash = PL_curstash;
4710 apply_attrs(stash, rcv, attrs);
4712 if (cv) { /* must reuse cv if autoloaded */
4714 /* got here with just attrs -- work done, so bug out */
4715 SAVEFREESV(PL_compcv);
4719 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4720 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4721 CvOUTSIDE(PL_compcv) = 0;
4722 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4723 CvPADLIST(PL_compcv) = 0;
4724 /* inner references to PL_compcv must be fixed up ... */
4726 AV *padlist = CvPADLIST(cv);
4727 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4728 AV *comppad = (AV*)AvARRAY(padlist)[1];
4729 SV **namepad = AvARRAY(comppad_name);
4730 SV **curpad = AvARRAY(comppad);
4731 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4732 SV *namesv = namepad[ix];
4733 if (namesv && namesv != &PL_sv_undef
4734 && *SvPVX(namesv) == '&')
4736 CV *innercv = (CV*)curpad[ix];
4737 if (CvOUTSIDE(innercv) == PL_compcv) {
4738 CvOUTSIDE(innercv) = cv;
4739 if (!CvANON(innercv) || CvCLONED(innercv)) {
4740 (void)SvREFCNT_inc(cv);
4741 SvREFCNT_dec(PL_compcv);
4747 /* ... before we throw it away */
4748 SvREFCNT_dec(PL_compcv);
4755 PL_sub_generation++;
4759 CvFILE(cv) = CopFILE(PL_curcop);
4760 CvSTASH(cv) = PL_curstash;
4763 if (!CvMUTEXP(cv)) {
4764 New(666, CvMUTEXP(cv), 1, perl_mutex);
4765 MUTEX_INIT(CvMUTEXP(cv));
4767 #endif /* USE_THREADS */
4770 sv_setpv((SV*)cv, ps);
4772 if (PL_error_count) {
4776 char *s = strrchr(name, ':');
4778 if (strEQ(s, "BEGIN")) {
4780 "BEGIN not safe after errors--compilation aborted";
4781 if (PL_in_eval & EVAL_KEEPERR)
4782 Perl_croak(aTHX_ not_safe);
4784 /* force display of errors found but not reported */
4785 sv_catpv(ERRSV, not_safe);
4786 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4794 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4795 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4798 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4799 mod(scalarseq(block), OP_LEAVESUBLV));
4802 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4804 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4805 OpREFCNT_set(CvROOT(cv), 1);
4806 CvSTART(cv) = LINKLIST(CvROOT(cv));
4807 CvROOT(cv)->op_next = 0;
4810 /* now that optimizer has done its work, adjust pad values */
4812 SV **namep = AvARRAY(PL_comppad_name);
4813 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4816 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4819 * The only things that a clonable function needs in its
4820 * pad are references to outer lexicals and anonymous subs.
4821 * The rest are created anew during cloning.
4823 if (!((namesv = namep[ix]) != Nullsv &&
4824 namesv != &PL_sv_undef &&
4826 *SvPVX(namesv) == '&')))
4828 SvREFCNT_dec(PL_curpad[ix]);
4829 PL_curpad[ix] = Nullsv;
4832 assert(!CvCONST(cv));
4833 if (ps && !*ps && op_const_sv(block, cv))
4837 AV *av = newAV(); /* Will be @_ */
4839 av_store(PL_comppad, 0, (SV*)av);
4840 AvFLAGS(av) = AVf_REIFY;
4842 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4843 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4845 if (!SvPADMY(PL_curpad[ix]))
4846 SvPADTMP_on(PL_curpad[ix]);
4850 /* If a potential closure prototype, don't keep a refcount on outer CV.
4851 * This is okay as the lifetime of the prototype is tied to the
4852 * lifetime of the outer CV. Avoids memory leak due to reference
4855 SvREFCNT_dec(CvOUTSIDE(cv));
4857 if (name || aname) {
4859 char *tname = (name ? name : aname);
4861 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4862 SV *sv = NEWSV(0,0);
4863 SV *tmpstr = sv_newmortal();
4864 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4868 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4870 (long)PL_subline, (long)CopLINE(PL_curcop));
4871 gv_efullname3(tmpstr, gv, Nullch);
4872 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4873 hv = GvHVn(db_postponed);
4874 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4875 && (pcv = GvCV(db_postponed)))
4881 call_sv((SV*)pcv, G_DISCARD);
4885 if ((s = strrchr(tname,':')))
4890 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4893 if (strEQ(s, "BEGIN")) {
4894 I32 oldscope = PL_scopestack_ix;
4896 SAVECOPFILE(&PL_compiling);
4897 SAVECOPLINE(&PL_compiling);
4899 sv_setsv(PL_rs, PL_nrs);
4902 PL_beginav = newAV();
4903 DEBUG_x( dump_sub(gv) );
4904 av_push(PL_beginav, (SV*)cv);
4905 GvCV(gv) = 0; /* cv has been hijacked */
4906 call_list(oldscope, PL_beginav);
4908 PL_curcop = &PL_compiling;
4909 PL_compiling.op_private = PL_hints;
4912 else if (strEQ(s, "END") && !PL_error_count) {
4915 DEBUG_x( dump_sub(gv) );
4916 av_unshift(PL_endav, 1);
4917 av_store(PL_endav, 0, (SV*)cv);
4918 GvCV(gv) = 0; /* cv has been hijacked */
4920 else if (strEQ(s, "CHECK") && !PL_error_count) {
4922 PL_checkav = newAV();
4923 DEBUG_x( dump_sub(gv) );
4924 if (PL_main_start && ckWARN(WARN_VOID))
4925 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4926 av_unshift(PL_checkav, 1);
4927 av_store(PL_checkav, 0, (SV*)cv);
4928 GvCV(gv) = 0; /* cv has been hijacked */
4930 else if (strEQ(s, "INIT") && !PL_error_count) {
4932 PL_initav = newAV();
4933 DEBUG_x( dump_sub(gv) );
4934 if (PL_main_start && ckWARN(WARN_VOID))
4935 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4936 av_push(PL_initav, (SV*)cv);
4937 GvCV(gv) = 0; /* cv has been hijacked */
4942 PL_copline = NOLINE;
4947 /* XXX unsafe for threads if eval_owner isn't held */
4949 =for apidoc newCONSTSUB
4951 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4952 eligible for inlining at compile-time.
4958 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4964 SAVECOPLINE(PL_curcop);
4965 CopLINE_set(PL_curcop, PL_copline);
4968 PL_hints &= ~HINT_BLOCK_SCOPE;
4971 SAVESPTR(PL_curstash);
4972 SAVECOPSTASH(PL_curcop);
4973 PL_curstash = stash;
4975 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4977 CopSTASH(PL_curcop) = stash;
4981 cv = newXS(name, const_sv_xsub, __FILE__);
4982 CvXSUBANY(cv).any_ptr = sv;
4984 sv_setpv((SV*)cv, ""); /* prototype is "" */
4992 =for apidoc U||newXS
4994 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5000 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5002 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5005 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5007 /* just a cached method */
5011 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5012 /* already defined (or promised) */
5013 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5014 && HvNAME(GvSTASH(CvGV(cv)))
5015 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5016 line_t oldline = CopLINE(PL_curcop);
5017 if (PL_copline != NOLINE)
5018 CopLINE_set(PL_curcop, PL_copline);
5019 Perl_warner(aTHX_ WARN_REDEFINE,
5020 CvCONST(cv) ? "Constant subroutine %s redefined"
5021 : "Subroutine %s redefined"
5023 CopLINE_set(PL_curcop, oldline);
5030 if (cv) /* must reuse cv if autoloaded */
5033 cv = (CV*)NEWSV(1105,0);
5034 sv_upgrade((SV *)cv, SVt_PVCV);
5038 PL_sub_generation++;
5043 New(666, CvMUTEXP(cv), 1, perl_mutex);
5044 MUTEX_INIT(CvMUTEXP(cv));
5046 #endif /* USE_THREADS */
5047 (void)gv_fetchfile(filename);
5048 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5049 an external constant string */
5050 CvXSUB(cv) = subaddr;
5053 char *s = strrchr(name,':');
5059 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5062 if (strEQ(s, "BEGIN")) {
5064 PL_beginav = newAV();
5065 av_push(PL_beginav, (SV*)cv);
5066 GvCV(gv) = 0; /* cv has been hijacked */
5068 else if (strEQ(s, "END")) {
5071 av_unshift(PL_endav, 1);
5072 av_store(PL_endav, 0, (SV*)cv);
5073 GvCV(gv) = 0; /* cv has been hijacked */
5075 else if (strEQ(s, "CHECK")) {
5077 PL_checkav = newAV();
5078 if (PL_main_start && ckWARN(WARN_VOID))
5079 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5080 av_unshift(PL_checkav, 1);
5081 av_store(PL_checkav, 0, (SV*)cv);
5082 GvCV(gv) = 0; /* cv has been hijacked */
5084 else if (strEQ(s, "INIT")) {
5086 PL_initav = newAV();
5087 if (PL_main_start && ckWARN(WARN_VOID))
5088 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5089 av_push(PL_initav, (SV*)cv);
5090 GvCV(gv) = 0; /* cv has been hijacked */
5101 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5110 name = SvPVx(cSVOPo->op_sv, n_a);
5113 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5114 #ifdef GV_SHARED_CHECK
5116 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5120 if ((cv = GvFORM(gv))) {
5121 if (ckWARN(WARN_REDEFINE)) {
5122 line_t oldline = CopLINE(PL_curcop);
5124 CopLINE_set(PL_curcop, PL_copline);
5125 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5126 CopLINE_set(PL_curcop, oldline);
5133 CvFILE(cv) = CopFILE(PL_curcop);
5135 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5136 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5137 SvPADTMP_on(PL_curpad[ix]);
5140 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5141 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5142 OpREFCNT_set(CvROOT(cv), 1);
5143 CvSTART(cv) = LINKLIST(CvROOT(cv));
5144 CvROOT(cv)->op_next = 0;
5147 PL_copline = NOLINE;
5152 Perl_newANONLIST(pTHX_ OP *o)
5154 return newUNOP(OP_REFGEN, 0,
5155 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5159 Perl_newANONHASH(pTHX_ OP *o)
5161 return newUNOP(OP_REFGEN, 0,
5162 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5166 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5168 return newANONATTRSUB(floor, proto, Nullop, block);
5172 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5174 return newUNOP(OP_REFGEN, 0,
5175 newSVOP(OP_ANONCODE, 0,
5176 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5180 Perl_oopsAV(pTHX_ OP *o)
5182 switch (o->op_type) {
5184 o->op_type = OP_PADAV;
5185 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5186 return ref(o, OP_RV2AV);
5189 o->op_type = OP_RV2AV;
5190 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5195 if (ckWARN_d(WARN_INTERNAL))
5196 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5203 Perl_oopsHV(pTHX_ OP *o)
5205 switch (o->op_type) {
5208 o->op_type = OP_PADHV;
5209 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5210 return ref(o, OP_RV2HV);
5214 o->op_type = OP_RV2HV;
5215 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5220 if (ckWARN_d(WARN_INTERNAL))
5221 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5228 Perl_newAVREF(pTHX_ OP *o)
5230 if (o->op_type == OP_PADANY) {
5231 o->op_type = OP_PADAV;
5232 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5235 return newUNOP(OP_RV2AV, 0, scalar(o));
5239 Perl_newGVREF(pTHX_ I32 type, OP *o)
5241 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5242 return newUNOP(OP_NULL, 0, o);
5243 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5247 Perl_newHVREF(pTHX_ OP *o)
5249 if (o->op_type == OP_PADANY) {
5250 o->op_type = OP_PADHV;
5251 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5254 return newUNOP(OP_RV2HV, 0, scalar(o));
5258 Perl_oopsCV(pTHX_ OP *o)
5260 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5266 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5268 return newUNOP(OP_RV2CV, flags, scalar(o));
5272 Perl_newSVREF(pTHX_ OP *o)
5274 if (o->op_type == OP_PADANY) {
5275 o->op_type = OP_PADSV;
5276 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5279 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5280 o->op_flags |= OPpDONE_SVREF;
5283 return newUNOP(OP_RV2SV, 0, scalar(o));
5286 /* Check routines. */
5289 Perl_ck_anoncode(pTHX_ OP *o)
5294 name = NEWSV(1106,0);
5295 sv_upgrade(name, SVt_PVNV);
5296 sv_setpvn(name, "&", 1);
5299 ix = pad_alloc(o->op_type, SVs_PADMY);
5300 av_store(PL_comppad_name, ix, name);
5301 av_store(PL_comppad, ix, cSVOPo->op_sv);
5302 SvPADMY_on(cSVOPo->op_sv);
5303 cSVOPo->op_sv = Nullsv;
5304 cSVOPo->op_targ = ix;
5309 Perl_ck_bitop(pTHX_ OP *o)
5311 o->op_private = PL_hints;
5316 Perl_ck_concat(pTHX_ OP *o)
5318 if (cUNOPo->op_first->op_type == OP_CONCAT)
5319 o->op_flags |= OPf_STACKED;
5324 Perl_ck_spair(pTHX_ OP *o)
5326 if (o->op_flags & OPf_KIDS) {
5329 OPCODE type = o->op_type;
5330 o = modkids(ck_fun(o), type);
5331 kid = cUNOPo->op_first;
5332 newop = kUNOP->op_first->op_sibling;
5334 (newop->op_sibling ||
5335 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5336 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5337 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5341 op_free(kUNOP->op_first);
5342 kUNOP->op_first = newop;
5344 o->op_ppaddr = PL_ppaddr[++o->op_type];
5349 Perl_ck_delete(pTHX_ OP *o)
5353 if (o->op_flags & OPf_KIDS) {
5354 OP *kid = cUNOPo->op_first;
5355 switch (kid->op_type) {
5357 o->op_flags |= OPf_SPECIAL;
5360 o->op_private |= OPpSLICE;
5363 o->op_flags |= OPf_SPECIAL;
5368 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5369 PL_op_desc[o->op_type]);
5377 Perl_ck_eof(pTHX_ OP *o)
5379 I32 type = o->op_type;
5381 if (o->op_flags & OPf_KIDS) {
5382 if (cLISTOPo->op_first->op_type == OP_STUB) {
5384 o = newUNOP(type, OPf_SPECIAL,
5385 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5393 Perl_ck_eval(pTHX_ OP *o)
5395 PL_hints |= HINT_BLOCK_SCOPE;
5396 if (o->op_flags & OPf_KIDS) {
5397 SVOP *kid = (SVOP*)cUNOPo->op_first;
5400 o->op_flags &= ~OPf_KIDS;
5403 else if (kid->op_type == OP_LINESEQ) {
5406 kid->op_next = o->op_next;
5407 cUNOPo->op_first = 0;
5410 NewOp(1101, enter, 1, LOGOP);
5411 enter->op_type = OP_ENTERTRY;
5412 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5413 enter->op_private = 0;
5415 /* establish postfix order */
5416 enter->op_next = (OP*)enter;
5418 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5419 o->op_type = OP_LEAVETRY;
5420 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5421 enter->op_other = o;
5429 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5431 o->op_targ = (PADOFFSET)PL_hints;
5436 Perl_ck_exit(pTHX_ OP *o)
5439 HV *table = GvHV(PL_hintgv);
5441 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5442 if (svp && *svp && SvTRUE(*svp))
5443 o->op_private |= OPpEXIT_VMSISH;
5450 Perl_ck_exec(pTHX_ OP *o)
5453 if (o->op_flags & OPf_STACKED) {
5455 kid = cUNOPo->op_first->op_sibling;
5456 if (kid->op_type == OP_RV2GV)
5465 Perl_ck_exists(pTHX_ OP *o)
5468 if (o->op_flags & OPf_KIDS) {
5469 OP *kid = cUNOPo->op_first;
5470 if (kid->op_type == OP_ENTERSUB) {
5471 (void) ref(kid, o->op_type);
5472 if (kid->op_type != OP_RV2CV && !PL_error_count)
5473 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5474 PL_op_desc[o->op_type]);
5475 o->op_private |= OPpEXISTS_SUB;
5477 else if (kid->op_type == OP_AELEM)
5478 o->op_flags |= OPf_SPECIAL;
5479 else if (kid->op_type != OP_HELEM)
5480 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5481 PL_op_desc[o->op_type]);
5489 Perl_ck_gvconst(pTHX_ register OP *o)
5491 o = fold_constants(o);
5492 if (o->op_type == OP_CONST)
5499 Perl_ck_rvconst(pTHX_ register OP *o)
5501 SVOP *kid = (SVOP*)cUNOPo->op_first;
5503 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5504 if (kid->op_type == OP_CONST) {
5508 SV *kidsv = kid->op_sv;
5511 /* Is it a constant from cv_const_sv()? */
5512 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5513 SV *rsv = SvRV(kidsv);
5514 int svtype = SvTYPE(rsv);
5515 char *badtype = Nullch;
5517 switch (o->op_type) {
5519 if (svtype > SVt_PVMG)
5520 badtype = "a SCALAR";
5523 if (svtype != SVt_PVAV)
5524 badtype = "an ARRAY";
5527 if (svtype != SVt_PVHV) {
5528 if (svtype == SVt_PVAV) { /* pseudohash? */
5529 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5530 if (ksv && SvROK(*ksv)
5531 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5540 if (svtype != SVt_PVCV)
5545 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5548 name = SvPV(kidsv, n_a);
5549 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5550 char *badthing = Nullch;
5551 switch (o->op_type) {
5553 badthing = "a SCALAR";
5556 badthing = "an ARRAY";
5559 badthing = "a HASH";
5564 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5568 * This is a little tricky. We only want to add the symbol if we
5569 * didn't add it in the lexer. Otherwise we get duplicate strict
5570 * warnings. But if we didn't add it in the lexer, we must at
5571 * least pretend like we wanted to add it even if it existed before,
5572 * or we get possible typo warnings. OPpCONST_ENTERED says
5573 * whether the lexer already added THIS instance of this symbol.
5575 iscv = (o->op_type == OP_RV2CV) * 2;
5577 gv = gv_fetchpv(name,
5578 iscv | !(kid->op_private & OPpCONST_ENTERED),
5581 : o->op_type == OP_RV2SV
5583 : o->op_type == OP_RV2AV
5585 : o->op_type == OP_RV2HV
5588 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5590 kid->op_type = OP_GV;
5591 SvREFCNT_dec(kid->op_sv);
5593 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5594 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5595 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5597 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5599 kid->op_sv = SvREFCNT_inc(gv);
5601 kid->op_private = 0;
5602 kid->op_ppaddr = PL_ppaddr[OP_GV];
5609 Perl_ck_ftst(pTHX_ OP *o)
5611 I32 type = o->op_type;
5613 if (o->op_flags & OPf_REF) {
5616 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5617 SVOP *kid = (SVOP*)cUNOPo->op_first;
5619 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5621 OP *newop = newGVOP(type, OPf_REF,
5622 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5629 if (type == OP_FTTTY)
5630 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5633 o = newUNOP(type, 0, newDEFSVOP());
5636 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5638 if (PL_hints & HINT_LOCALE)
5639 o->op_private |= OPpLOCALE;
5646 Perl_ck_fun(pTHX_ OP *o)
5652 int type = o->op_type;
5653 register I32 oa = PL_opargs[type] >> OASHIFT;
5655 if (o->op_flags & OPf_STACKED) {
5656 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5659 return no_fh_allowed(o);
5662 if (o->op_flags & OPf_KIDS) {
5664 tokid = &cLISTOPo->op_first;
5665 kid = cLISTOPo->op_first;
5666 if (kid->op_type == OP_PUSHMARK ||
5667 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5669 tokid = &kid->op_sibling;
5670 kid = kid->op_sibling;
5672 if (!kid && PL_opargs[type] & OA_DEFGV)
5673 *tokid = kid = newDEFSVOP();
5677 sibl = kid->op_sibling;
5680 /* list seen where single (scalar) arg expected? */
5681 if (numargs == 1 && !(oa >> 4)
5682 && kid->op_type == OP_LIST && type != OP_SCALAR)
5684 return too_many_arguments(o,PL_op_desc[type]);
5697 if ((type == OP_PUSH || type == OP_UNSHIFT)
5698 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5699 Perl_warner(aTHX_ WARN_SYNTAX,
5700 "Useless use of %s with no values",
5703 if (kid->op_type == OP_CONST &&
5704 (kid->op_private & OPpCONST_BARE))
5706 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5707 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5708 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5709 if (ckWARN(WARN_DEPRECATED))
5710 Perl_warner(aTHX_ WARN_DEPRECATED,
5711 "Array @%s missing the @ in argument %"IVdf" of %s()",
5712 name, (IV)numargs, PL_op_desc[type]);
5715 kid->op_sibling = sibl;
5718 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5719 bad_type(numargs, "array", PL_op_desc[type], kid);
5723 if (kid->op_type == OP_CONST &&
5724 (kid->op_private & OPpCONST_BARE))
5726 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5727 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5728 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5729 if (ckWARN(WARN_DEPRECATED))
5730 Perl_warner(aTHX_ WARN_DEPRECATED,
5731 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5732 name, (IV)numargs, PL_op_desc[type]);
5735 kid->op_sibling = sibl;
5738 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5739 bad_type(numargs, "hash", PL_op_desc[type], kid);
5744 OP *newop = newUNOP(OP_NULL, 0, kid);
5745 kid->op_sibling = 0;
5747 newop->op_next = newop;
5749 kid->op_sibling = sibl;
5754 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5755 if (kid->op_type == OP_CONST &&
5756 (kid->op_private & OPpCONST_BARE))
5758 OP *newop = newGVOP(OP_GV, 0,
5759 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5764 else if (kid->op_type == OP_READLINE) {
5765 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5766 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5769 I32 flags = OPf_SPECIAL;
5773 /* is this op a FH constructor? */
5774 if (is_handle_constructor(o,numargs)) {
5775 char *name = Nullch;
5779 /* Set a flag to tell rv2gv to vivify
5780 * need to "prove" flag does not mean something
5781 * else already - NI-S 1999/05/07
5784 if (kid->op_type == OP_PADSV) {
5785 SV **namep = av_fetch(PL_comppad_name,
5787 if (namep && *namep)
5788 name = SvPV(*namep, len);
5790 else if (kid->op_type == OP_RV2SV
5791 && kUNOP->op_first->op_type == OP_GV)
5793 GV *gv = cGVOPx_gv(kUNOP->op_first);
5795 len = GvNAMELEN(gv);
5797 else if (kid->op_type == OP_AELEM
5798 || kid->op_type == OP_HELEM)
5800 name = "__ANONIO__";
5806 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5807 namesv = PL_curpad[targ];
5808 (void)SvUPGRADE(namesv, SVt_PV);
5810 sv_setpvn(namesv, "$", 1);
5811 sv_catpvn(namesv, name, len);
5814 kid->op_sibling = 0;
5815 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5816 kid->op_targ = targ;
5817 kid->op_private |= priv;
5819 kid->op_sibling = sibl;
5825 mod(scalar(kid), type);
5829 tokid = &kid->op_sibling;
5830 kid = kid->op_sibling;
5832 o->op_private |= numargs;
5834 return too_many_arguments(o,PL_op_desc[o->op_type]);
5837 else if (PL_opargs[type] & OA_DEFGV) {
5839 return newUNOP(type, 0, newDEFSVOP());
5843 while (oa & OA_OPTIONAL)
5845 if (oa && oa != OA_LIST)
5846 return too_few_arguments(o,PL_op_desc[o->op_type]);
5852 Perl_ck_glob(pTHX_ OP *o)
5857 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5858 append_elem(OP_GLOB, o, newDEFSVOP());
5860 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5861 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5863 #if !defined(PERL_EXTERNAL_GLOB)
5864 /* XXX this can be tightened up and made more failsafe. */
5868 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5870 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5871 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5872 GvCV(gv) = GvCV(glob_gv);
5873 GvIMPORTED_CV_on(gv);
5876 #endif /* PERL_EXTERNAL_GLOB */
5878 if (gv && GvIMPORTED_CV(gv)) {
5879 append_elem(OP_GLOB, o,
5880 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5881 o->op_type = OP_LIST;
5882 o->op_ppaddr = PL_ppaddr[OP_LIST];
5883 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5884 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5885 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5886 append_elem(OP_LIST, o,
5887 scalar(newUNOP(OP_RV2CV, 0,
5888 newGVOP(OP_GV, 0, gv)))));
5889 o = newUNOP(OP_NULL, 0, ck_subr(o));
5890 o->op_targ = OP_GLOB; /* hint at what it used to be */
5893 gv = newGVgen("main");
5895 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5901 Perl_ck_grep(pTHX_ OP *o)
5905 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5907 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5908 NewOp(1101, gwop, 1, LOGOP);
5910 if (o->op_flags & OPf_STACKED) {
5913 kid = cLISTOPo->op_first->op_sibling;
5914 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5917 kid->op_next = (OP*)gwop;
5918 o->op_flags &= ~OPf_STACKED;
5920 kid = cLISTOPo->op_first->op_sibling;
5921 if (type == OP_MAPWHILE)
5928 kid = cLISTOPo->op_first->op_sibling;
5929 if (kid->op_type != OP_NULL)
5930 Perl_croak(aTHX_ "panic: ck_grep");
5931 kid = kUNOP->op_first;
5933 gwop->op_type = type;
5934 gwop->op_ppaddr = PL_ppaddr[type];
5935 gwop->op_first = listkids(o);
5936 gwop->op_flags |= OPf_KIDS;
5937 gwop->op_private = 1;
5938 gwop->op_other = LINKLIST(kid);
5939 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5940 kid->op_next = (OP*)gwop;
5942 kid = cLISTOPo->op_first->op_sibling;
5943 if (!kid || !kid->op_sibling)
5944 return too_few_arguments(o,PL_op_desc[o->op_type]);
5945 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5946 mod(kid, OP_GREPSTART);
5952 Perl_ck_index(pTHX_ OP *o)
5954 if (o->op_flags & OPf_KIDS) {
5955 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5957 kid = kid->op_sibling; /* get past "big" */
5958 if (kid && kid->op_type == OP_CONST)
5959 fbm_compile(((SVOP*)kid)->op_sv, 0);
5965 Perl_ck_lengthconst(pTHX_ OP *o)
5967 /* XXX length optimization goes here */
5972 Perl_ck_lfun(pTHX_ OP *o)
5974 OPCODE type = o->op_type;
5975 return modkids(ck_fun(o), type);
5979 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5981 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5982 switch (cUNOPo->op_first->op_type) {
5984 /* This is needed for
5985 if (defined %stash::)
5986 to work. Do not break Tk.
5988 break; /* Globals via GV can be undef */
5990 case OP_AASSIGN: /* Is this a good idea? */
5991 Perl_warner(aTHX_ WARN_DEPRECATED,
5992 "defined(@array) is deprecated");
5993 Perl_warner(aTHX_ WARN_DEPRECATED,
5994 "\t(Maybe you should just omit the defined()?)\n");
5997 /* This is needed for
5998 if (defined %stash::)
5999 to work. Do not break Tk.
6001 break; /* Globals via GV can be undef */
6003 Perl_warner(aTHX_ WARN_DEPRECATED,
6004 "defined(%%hash) is deprecated");
6005 Perl_warner(aTHX_ WARN_DEPRECATED,
6006 "\t(Maybe you should just omit the defined()?)\n");
6017 Perl_ck_rfun(pTHX_ OP *o)
6019 OPCODE type = o->op_type;
6020 return refkids(ck_fun(o), type);
6024 Perl_ck_listiob(pTHX_ OP *o)
6028 kid = cLISTOPo->op_first;
6031 kid = cLISTOPo->op_first;
6033 if (kid->op_type == OP_PUSHMARK)
6034 kid = kid->op_sibling;
6035 if (kid && o->op_flags & OPf_STACKED)
6036 kid = kid->op_sibling;
6037 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6038 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6039 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6040 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6041 cLISTOPo->op_first->op_sibling = kid;
6042 cLISTOPo->op_last = kid;
6043 kid = kid->op_sibling;
6048 append_elem(o->op_type, o, newDEFSVOP());
6054 if (PL_hints & HINT_LOCALE)
6055 o->op_private |= OPpLOCALE;
6062 Perl_ck_fun_locale(pTHX_ OP *o)
6068 if (PL_hints & HINT_LOCALE)
6069 o->op_private |= OPpLOCALE;
6076 Perl_ck_sassign(pTHX_ OP *o)
6078 OP *kid = cLISTOPo->op_first;
6079 /* has a disposable target? */
6080 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6081 && !(kid->op_flags & OPf_STACKED)
6082 /* Cannot steal the second time! */
6083 && !(kid->op_private & OPpTARGET_MY))
6085 OP *kkid = kid->op_sibling;
6087 /* Can just relocate the target. */
6088 if (kkid && kkid->op_type == OP_PADSV
6089 && !(kkid->op_private & OPpLVAL_INTRO))
6091 kid->op_targ = kkid->op_targ;
6093 /* Now we do not need PADSV and SASSIGN. */
6094 kid->op_sibling = o->op_sibling; /* NULL */
6095 cLISTOPo->op_first = NULL;
6098 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6106 Perl_ck_scmp(pTHX_ OP *o)
6110 if (PL_hints & HINT_LOCALE)
6111 o->op_private |= OPpLOCALE;
6118 Perl_ck_match(pTHX_ OP *o)
6120 o->op_private |= OPpRUNTIME;
6125 Perl_ck_method(pTHX_ OP *o)
6127 OP *kid = cUNOPo->op_first;
6128 if (kid->op_type == OP_CONST) {
6129 SV* sv = kSVOP->op_sv;
6130 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6132 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6133 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6136 kSVOP->op_sv = Nullsv;
6138 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6147 Perl_ck_null(pTHX_ OP *o)
6153 Perl_ck_open(pTHX_ OP *o)
6155 HV *table = GvHV(PL_hintgv);
6159 svp = hv_fetch(table, "open_IN", 7, FALSE);
6161 mode = mode_from_discipline(*svp);
6162 if (mode & O_BINARY)
6163 o->op_private |= OPpOPEN_IN_RAW;
6164 else if (mode & O_TEXT)
6165 o->op_private |= OPpOPEN_IN_CRLF;
6168 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6170 mode = mode_from_discipline(*svp);
6171 if (mode & O_BINARY)
6172 o->op_private |= OPpOPEN_OUT_RAW;
6173 else if (mode & O_TEXT)
6174 o->op_private |= OPpOPEN_OUT_CRLF;
6177 if (o->op_type == OP_BACKTICK)
6183 Perl_ck_repeat(pTHX_ OP *o)
6185 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6186 o->op_private |= OPpREPEAT_DOLIST;
6187 cBINOPo->op_first = force_list(cBINOPo->op_first);
6195 Perl_ck_require(pTHX_ OP *o)
6197 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6198 SVOP *kid = (SVOP*)cUNOPo->op_first;
6200 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6202 for (s = SvPVX(kid->op_sv); *s; s++) {
6203 if (*s == ':' && s[1] == ':') {
6205 Move(s+2, s+1, strlen(s+2)+1, char);
6206 --SvCUR(kid->op_sv);
6209 if (SvREADONLY(kid->op_sv)) {
6210 SvREADONLY_off(kid->op_sv);
6211 sv_catpvn(kid->op_sv, ".pm", 3);
6212 SvREADONLY_on(kid->op_sv);
6215 sv_catpvn(kid->op_sv, ".pm", 3);
6222 Perl_ck_return(pTHX_ OP *o)
6225 if (CvLVALUE(PL_compcv)) {
6226 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6227 mod(kid, OP_LEAVESUBLV);
6234 Perl_ck_retarget(pTHX_ OP *o)
6236 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6243 Perl_ck_select(pTHX_ OP *o)
6246 if (o->op_flags & OPf_KIDS) {
6247 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6248 if (kid && kid->op_sibling) {
6249 o->op_type = OP_SSELECT;
6250 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6252 return fold_constants(o);
6256 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6257 if (kid && kid->op_type == OP_RV2GV)
6258 kid->op_private &= ~HINT_STRICT_REFS;
6263 Perl_ck_shift(pTHX_ OP *o)
6265 I32 type = o->op_type;
6267 if (!(o->op_flags & OPf_KIDS)) {
6272 if (!CvUNIQUE(PL_compcv)) {
6273 argop = newOP(OP_PADAV, OPf_REF);
6274 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6277 argop = newUNOP(OP_RV2AV, 0,
6278 scalar(newGVOP(OP_GV, 0,
6279 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6282 argop = newUNOP(OP_RV2AV, 0,
6283 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6284 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6285 #endif /* USE_THREADS */
6286 return newUNOP(type, 0, scalar(argop));
6288 return scalar(modkids(ck_fun(o), type));
6292 Perl_ck_sort(pTHX_ OP *o)
6297 if (PL_hints & HINT_LOCALE)
6298 o->op_private |= OPpLOCALE;
6301 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6303 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6304 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6306 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6308 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6310 if (kid->op_type == OP_SCOPE) {
6314 else if (kid->op_type == OP_LEAVE) {
6315 if (o->op_type == OP_SORT) {
6316 null(kid); /* wipe out leave */
6319 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6320 if (k->op_next == kid)
6322 /* don't descend into loops */
6323 else if (k->op_type == OP_ENTERLOOP
6324 || k->op_type == OP_ENTERITER)
6326 k = cLOOPx(k)->op_lastop;
6331 kid->op_next = 0; /* just disconnect the leave */
6332 k = kLISTOP->op_first;
6337 if (o->op_type == OP_SORT) {
6338 /* provide scalar context for comparison function/block */
6344 o->op_flags |= OPf_SPECIAL;
6346 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6349 firstkid = firstkid->op_sibling;
6352 /* provide list context for arguments */
6353 if (o->op_type == OP_SORT)
6360 S_simplify_sort(pTHX_ OP *o)
6362 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6366 if (!(o->op_flags & OPf_STACKED))
6368 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6369 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6370 kid = kUNOP->op_first; /* get past null */
6371 if (kid->op_type != OP_SCOPE)
6373 kid = kLISTOP->op_last; /* get past scope */
6374 switch(kid->op_type) {
6382 k = kid; /* remember this node*/
6383 if (kBINOP->op_first->op_type != OP_RV2SV)
6385 kid = kBINOP->op_first; /* get past cmp */
6386 if (kUNOP->op_first->op_type != OP_GV)
6388 kid = kUNOP->op_first; /* get past rv2sv */
6390 if (GvSTASH(gv) != PL_curstash)
6392 if (strEQ(GvNAME(gv), "a"))
6394 else if (strEQ(GvNAME(gv), "b"))
6398 kid = k; /* back to cmp */
6399 if (kBINOP->op_last->op_type != OP_RV2SV)
6401 kid = kBINOP->op_last; /* down to 2nd arg */
6402 if (kUNOP->op_first->op_type != OP_GV)
6404 kid = kUNOP->op_first; /* get past rv2sv */
6406 if (GvSTASH(gv) != PL_curstash
6408 ? strNE(GvNAME(gv), "a")
6409 : strNE(GvNAME(gv), "b")))
6411 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6413 o->op_private |= OPpSORT_REVERSE;
6414 if (k->op_type == OP_NCMP)
6415 o->op_private |= OPpSORT_NUMERIC;
6416 if (k->op_type == OP_I_NCMP)
6417 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6418 kid = cLISTOPo->op_first->op_sibling;
6419 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6420 op_free(kid); /* then delete it */
6424 Perl_ck_split(pTHX_ OP *o)
6428 if (o->op_flags & OPf_STACKED)
6429 return no_fh_allowed(o);
6431 kid = cLISTOPo->op_first;
6432 if (kid->op_type != OP_NULL)
6433 Perl_croak(aTHX_ "panic: ck_split");
6434 kid = kid->op_sibling;
6435 op_free(cLISTOPo->op_first);
6436 cLISTOPo->op_first = kid;
6438 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6439 cLISTOPo->op_last = kid; /* There was only one element previously */
6442 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6443 OP *sibl = kid->op_sibling;
6444 kid->op_sibling = 0;
6445 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6446 if (cLISTOPo->op_first == cLISTOPo->op_last)
6447 cLISTOPo->op_last = kid;
6448 cLISTOPo->op_first = kid;
6449 kid->op_sibling = sibl;
6452 kid->op_type = OP_PUSHRE;
6453 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6456 if (!kid->op_sibling)
6457 append_elem(OP_SPLIT, o, newDEFSVOP());
6459 kid = kid->op_sibling;
6462 if (!kid->op_sibling)
6463 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6465 kid = kid->op_sibling;
6468 if (kid->op_sibling)
6469 return too_many_arguments(o,PL_op_desc[o->op_type]);
6475 Perl_ck_join(pTHX_ OP *o)
6477 if (ckWARN(WARN_SYNTAX)) {
6478 OP *kid = cLISTOPo->op_first->op_sibling;
6479 if (kid && kid->op_type == OP_MATCH) {
6480 char *pmstr = "STRING";
6481 if (kPMOP->op_pmregexp)
6482 pmstr = kPMOP->op_pmregexp->precomp;
6483 Perl_warner(aTHX_ WARN_SYNTAX,
6484 "/%s/ should probably be written as \"%s\"",
6492 Perl_ck_subr(pTHX_ OP *o)
6494 OP *prev = ((cUNOPo->op_first->op_sibling)
6495 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6496 OP *o2 = prev->op_sibling;
6505 o->op_private |= OPpENTERSUB_HASTARG;
6506 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6507 if (cvop->op_type == OP_RV2CV) {
6509 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6510 null(cvop); /* disable rv2cv */
6511 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6512 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6513 GV *gv = cGVOPx_gv(tmpop);
6516 tmpop->op_private |= OPpEARLY_CV;
6517 else if (SvPOK(cv)) {
6518 namegv = CvANON(cv) ? gv : CvGV(cv);
6519 proto = SvPV((SV*)cv, n_a);
6523 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6524 if (o2->op_type == OP_CONST)
6525 o2->op_private &= ~OPpCONST_STRICT;
6526 else if (o2->op_type == OP_LIST) {
6527 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6528 if (o && o->op_type == OP_CONST)
6529 o->op_private &= ~OPpCONST_STRICT;
6532 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6533 if (PERLDB_SUB && PL_curstash != PL_debstash)
6534 o->op_private |= OPpENTERSUB_DB;
6535 while (o2 != cvop) {
6539 return too_many_arguments(o, gv_ename(namegv));
6557 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6559 arg == 1 ? "block or sub {}" : "sub {}",
6560 gv_ename(namegv), o2);
6563 /* '*' allows any scalar type, including bareword */
6566 if (o2->op_type == OP_RV2GV)
6567 goto wrapref; /* autoconvert GLOB -> GLOBref */
6568 else if (o2->op_type == OP_CONST)
6569 o2->op_private &= ~OPpCONST_STRICT;
6570 else if (o2->op_type == OP_ENTERSUB) {
6571 /* accidental subroutine, revert to bareword */
6572 OP *gvop = ((UNOP*)o2)->op_first;
6573 if (gvop && gvop->op_type == OP_NULL) {
6574 gvop = ((UNOP*)gvop)->op_first;
6576 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6579 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6580 (gvop = ((UNOP*)gvop)->op_first) &&
6581 gvop->op_type == OP_GV)
6583 GV *gv = cGVOPx_gv(gvop);
6584 OP *sibling = o2->op_sibling;
6585 SV *n = newSVpvn("",0);
6587 gv_fullname3(n, gv, "");
6588 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6589 sv_chop(n, SvPVX(n)+6);
6590 o2 = newSVOP(OP_CONST, 0, n);
6591 prev->op_sibling = o2;
6592 o2->op_sibling = sibling;
6604 if (o2->op_type != OP_RV2GV)
6605 bad_type(arg, "symbol", gv_ename(namegv), o2);
6608 if (o2->op_type != OP_ENTERSUB)
6609 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6612 if (o2->op_type != OP_RV2SV
6613 && o2->op_type != OP_PADSV
6614 && o2->op_type != OP_HELEM
6615 && o2->op_type != OP_AELEM
6616 && o2->op_type != OP_THREADSV)
6618 bad_type(arg, "scalar", gv_ename(namegv), o2);
6622 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6623 bad_type(arg, "array", gv_ename(namegv), o2);
6626 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6627 bad_type(arg, "hash", gv_ename(namegv), o2);
6631 OP* sib = kid->op_sibling;
6632 kid->op_sibling = 0;
6633 o2 = newUNOP(OP_REFGEN, 0, kid);
6634 o2->op_sibling = sib;
6635 prev->op_sibling = o2;
6646 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6647 gv_ename(namegv), SvPV((SV*)cv, n_a));
6652 mod(o2, OP_ENTERSUB);
6654 o2 = o2->op_sibling;
6656 if (proto && !optional &&
6657 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6658 return too_few_arguments(o, gv_ename(namegv));
6663 Perl_ck_svconst(pTHX_ OP *o)
6665 SvREADONLY_on(cSVOPo->op_sv);
6670 Perl_ck_trunc(pTHX_ OP *o)
6672 if (o->op_flags & OPf_KIDS) {
6673 SVOP *kid = (SVOP*)cUNOPo->op_first;
6675 if (kid->op_type == OP_NULL)
6676 kid = (SVOP*)kid->op_sibling;
6677 if (kid && kid->op_type == OP_CONST &&
6678 (kid->op_private & OPpCONST_BARE))
6680 o->op_flags |= OPf_SPECIAL;
6681 kid->op_private &= ~OPpCONST_STRICT;
6688 Perl_ck_substr(pTHX_ OP *o)
6691 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6692 OP *kid = cLISTOPo->op_first;
6694 if (kid->op_type == OP_NULL)
6695 kid = kid->op_sibling;
6697 kid->op_flags |= OPf_MOD;
6703 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6706 Perl_peep(pTHX_ register OP *o)
6708 register OP* oldop = 0;
6711 if (!o || o->op_seq)
6715 SAVEVPTR(PL_curcop);
6716 for (; o; o = o->op_next) {
6722 switch (o->op_type) {
6726 PL_curcop = ((COP*)o); /* for warnings */
6727 o->op_seq = PL_op_seqmax++;
6731 if (cSVOPo->op_private & OPpCONST_STRICT)
6732 no_bareword_allowed(o);
6734 /* Relocate sv to the pad for thread safety.
6735 * Despite being a "constant", the SV is written to,
6736 * for reference counts, sv_upgrade() etc. */
6738 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6739 if (SvPADTMP(cSVOPo->op_sv)) {
6740 /* If op_sv is already a PADTMP then it is being used by
6741 * some pad, so make a copy. */
6742 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6743 SvREADONLY_on(PL_curpad[ix]);
6744 SvREFCNT_dec(cSVOPo->op_sv);
6747 SvREFCNT_dec(PL_curpad[ix]);
6748 SvPADTMP_on(cSVOPo->op_sv);
6749 PL_curpad[ix] = cSVOPo->op_sv;
6750 /* XXX I don't know how this isn't readonly already. */
6751 SvREADONLY_on(PL_curpad[ix]);
6753 cSVOPo->op_sv = Nullsv;
6757 o->op_seq = PL_op_seqmax++;
6761 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6762 if (o->op_next->op_private & OPpTARGET_MY) {
6763 if (o->op_flags & OPf_STACKED) /* chained concats */
6764 goto ignore_optimization;
6766 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6767 o->op_targ = o->op_next->op_targ;
6768 o->op_next->op_targ = 0;
6769 o->op_private |= OPpTARGET_MY;
6774 ignore_optimization:
6775 o->op_seq = PL_op_seqmax++;
6778 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6779 o->op_seq = PL_op_seqmax++;
6780 break; /* Scalar stub must produce undef. List stub is noop */
6784 if (o->op_targ == OP_NEXTSTATE
6785 || o->op_targ == OP_DBSTATE
6786 || o->op_targ == OP_SETSTATE)
6788 PL_curcop = ((COP*)o);
6795 if (oldop && o->op_next) {
6796 oldop->op_next = o->op_next;
6799 o->op_seq = PL_op_seqmax++;
6803 if (o->op_next->op_type == OP_RV2SV) {
6804 if (!(o->op_next->op_private & OPpDEREF)) {
6806 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6808 o->op_next = o->op_next->op_next;
6809 o->op_type = OP_GVSV;
6810 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6813 else if (o->op_next->op_type == OP_RV2AV) {
6814 OP* pop = o->op_next->op_next;
6816 if (pop->op_type == OP_CONST &&
6817 (PL_op = pop->op_next) &&
6818 pop->op_next->op_type == OP_AELEM &&
6819 !(pop->op_next->op_private &
6820 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6821 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6829 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6830 o->op_next = pop->op_next->op_next;
6831 o->op_type = OP_AELEMFAST;
6832 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6833 o->op_private = (U8)i;
6838 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6840 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6841 /* XXX could check prototype here instead of just carping */
6842 SV *sv = sv_newmortal();
6843 gv_efullname3(sv, gv, Nullch);
6844 Perl_warner(aTHX_ WARN_PROTOTYPE,
6845 "%s() called too early to check prototype",
6850 o->op_seq = PL_op_seqmax++;
6861 o->op_seq = PL_op_seqmax++;
6862 while (cLOGOP->op_other->op_type == OP_NULL)
6863 cLOGOP->op_other = cLOGOP->op_other->op_next;
6864 peep(cLOGOP->op_other);
6869 o->op_seq = PL_op_seqmax++;
6870 while (cLOOP->op_redoop->op_type == OP_NULL)
6871 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6872 peep(cLOOP->op_redoop);
6873 while (cLOOP->op_nextop->op_type == OP_NULL)
6874 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6875 peep(cLOOP->op_nextop);
6876 while (cLOOP->op_lastop->op_type == OP_NULL)
6877 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6878 peep(cLOOP->op_lastop);
6884 o->op_seq = PL_op_seqmax++;
6885 while (cPMOP->op_pmreplstart &&
6886 cPMOP->op_pmreplstart->op_type == OP_NULL)
6887 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6888 peep(cPMOP->op_pmreplstart);
6892 o->op_seq = PL_op_seqmax++;
6893 if (ckWARN(WARN_SYNTAX) && o->op_next
6894 && o->op_next->op_type == OP_NEXTSTATE) {
6895 if (o->op_next->op_sibling &&
6896 o->op_next->op_sibling->op_type != OP_EXIT &&
6897 o->op_next->op_sibling->op_type != OP_WARN &&
6898 o->op_next->op_sibling->op_type != OP_DIE) {
6899 line_t oldline = CopLINE(PL_curcop);
6901 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6902 Perl_warner(aTHX_ WARN_EXEC,
6903 "Statement unlikely to be reached");
6904 Perl_warner(aTHX_ WARN_EXEC,
6905 "\t(Maybe you meant system() when you said exec()?)\n");
6906 CopLINE_set(PL_curcop, oldline);
6915 SV **svp, **indsvp, *sv;
6920 o->op_seq = PL_op_seqmax++;
6922 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6925 /* Make the CONST have a shared SV */
6926 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6927 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6928 key = SvPV(sv, keylen);
6931 lexname = newSVpvn_share(key, keylen, 0);
6936 if ((o->op_private & (OPpLVAL_INTRO)))
6939 rop = (UNOP*)((BINOP*)o)->op_first;
6940 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6942 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6943 if (!SvOBJECT(lexname))
6945 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6946 if (!fields || !GvHV(*fields))
6948 key = SvPV(*svp, keylen);
6951 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6953 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6954 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6956 ind = SvIV(*indsvp);
6958 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6959 rop->op_type = OP_RV2AV;
6960 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6961 o->op_type = OP_AELEM;
6962 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6964 if (SvREADONLY(*svp))
6966 SvFLAGS(sv) |= (SvFLAGS(*svp)
6967 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6977 SV **svp, **indsvp, *sv;
6981 SVOP *first_key_op, *key_op;
6983 o->op_seq = PL_op_seqmax++;
6984 if ((o->op_private & (OPpLVAL_INTRO))
6985 /* I bet there's always a pushmark... */
6986 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6987 /* hmmm, no optimization if list contains only one key. */
6989 rop = (UNOP*)((LISTOP*)o)->op_last;
6990 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6992 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6993 if (!SvOBJECT(lexname))
6995 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6996 if (!fields || !GvHV(*fields))
6998 /* Again guessing that the pushmark can be jumped over.... */
6999 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7000 ->op_first->op_sibling;
7001 /* Check that the key list contains only constants. */
7002 for (key_op = first_key_op; key_op;
7003 key_op = (SVOP*)key_op->op_sibling)
7004 if (key_op->op_type != OP_CONST)
7008 rop->op_type = OP_RV2AV;
7009 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7010 o->op_type = OP_ASLICE;
7011 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7012 for (key_op = first_key_op; key_op;
7013 key_op = (SVOP*)key_op->op_sibling) {
7014 svp = cSVOPx_svp(key_op);
7015 key = SvPV(*svp, keylen);
7018 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7020 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7021 "in variable %s of type %s",
7022 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7024 ind = SvIV(*indsvp);
7026 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7028 if (SvREADONLY(*svp))
7030 SvFLAGS(sv) |= (SvFLAGS(*svp)
7031 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7039 o->op_seq = PL_op_seqmax++;
7049 /* Efficient sub that returns a constant scalar value. */
7051 const_sv_xsub(pTHXo_ CV* cv)
7056 Perl_croak(aTHX_ "usage: %s::%s()",
7057 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7061 ST(0) = (SV*)XSANY.any_ptr;