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 SvREFCNT_inc((SV*)GvCV(gv));
5874 GvIMPORTED_CV_on(gv);
5877 #endif /* PERL_EXTERNAL_GLOB */
5879 if (gv && GvIMPORTED_CV(gv)) {
5880 append_elem(OP_GLOB, o,
5881 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5882 o->op_type = OP_LIST;
5883 o->op_ppaddr = PL_ppaddr[OP_LIST];
5884 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5885 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5886 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5887 append_elem(OP_LIST, o,
5888 scalar(newUNOP(OP_RV2CV, 0,
5889 newGVOP(OP_GV, 0, gv)))));
5890 o = newUNOP(OP_NULL, 0, ck_subr(o));
5891 o->op_targ = OP_GLOB; /* hint at what it used to be */
5894 gv = newGVgen("main");
5896 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5902 Perl_ck_grep(pTHX_ OP *o)
5906 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5908 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5909 NewOp(1101, gwop, 1, LOGOP);
5911 if (o->op_flags & OPf_STACKED) {
5914 kid = cLISTOPo->op_first->op_sibling;
5915 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5918 kid->op_next = (OP*)gwop;
5919 o->op_flags &= ~OPf_STACKED;
5921 kid = cLISTOPo->op_first->op_sibling;
5922 if (type == OP_MAPWHILE)
5929 kid = cLISTOPo->op_first->op_sibling;
5930 if (kid->op_type != OP_NULL)
5931 Perl_croak(aTHX_ "panic: ck_grep");
5932 kid = kUNOP->op_first;
5934 gwop->op_type = type;
5935 gwop->op_ppaddr = PL_ppaddr[type];
5936 gwop->op_first = listkids(o);
5937 gwop->op_flags |= OPf_KIDS;
5938 gwop->op_private = 1;
5939 gwop->op_other = LINKLIST(kid);
5940 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5941 kid->op_next = (OP*)gwop;
5943 kid = cLISTOPo->op_first->op_sibling;
5944 if (!kid || !kid->op_sibling)
5945 return too_few_arguments(o,PL_op_desc[o->op_type]);
5946 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5947 mod(kid, OP_GREPSTART);
5953 Perl_ck_index(pTHX_ OP *o)
5955 if (o->op_flags & OPf_KIDS) {
5956 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5958 kid = kid->op_sibling; /* get past "big" */
5959 if (kid && kid->op_type == OP_CONST)
5960 fbm_compile(((SVOP*)kid)->op_sv, 0);
5966 Perl_ck_lengthconst(pTHX_ OP *o)
5968 /* XXX length optimization goes here */
5973 Perl_ck_lfun(pTHX_ OP *o)
5975 OPCODE type = o->op_type;
5976 return modkids(ck_fun(o), type);
5980 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5982 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5983 switch (cUNOPo->op_first->op_type) {
5985 /* This is needed for
5986 if (defined %stash::)
5987 to work. Do not break Tk.
5989 break; /* Globals via GV can be undef */
5991 case OP_AASSIGN: /* Is this a good idea? */
5992 Perl_warner(aTHX_ WARN_DEPRECATED,
5993 "defined(@array) is deprecated");
5994 Perl_warner(aTHX_ WARN_DEPRECATED,
5995 "\t(Maybe you should just omit the defined()?)\n");
5998 /* This is needed for
5999 if (defined %stash::)
6000 to work. Do not break Tk.
6002 break; /* Globals via GV can be undef */
6004 Perl_warner(aTHX_ WARN_DEPRECATED,
6005 "defined(%%hash) is deprecated");
6006 Perl_warner(aTHX_ WARN_DEPRECATED,
6007 "\t(Maybe you should just omit the defined()?)\n");
6018 Perl_ck_rfun(pTHX_ OP *o)
6020 OPCODE type = o->op_type;
6021 return refkids(ck_fun(o), type);
6025 Perl_ck_listiob(pTHX_ OP *o)
6029 kid = cLISTOPo->op_first;
6032 kid = cLISTOPo->op_first;
6034 if (kid->op_type == OP_PUSHMARK)
6035 kid = kid->op_sibling;
6036 if (kid && o->op_flags & OPf_STACKED)
6037 kid = kid->op_sibling;
6038 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6039 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6040 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6041 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6042 cLISTOPo->op_first->op_sibling = kid;
6043 cLISTOPo->op_last = kid;
6044 kid = kid->op_sibling;
6049 append_elem(o->op_type, o, newDEFSVOP());
6055 if (PL_hints & HINT_LOCALE)
6056 o->op_private |= OPpLOCALE;
6063 Perl_ck_fun_locale(pTHX_ OP *o)
6069 if (PL_hints & HINT_LOCALE)
6070 o->op_private |= OPpLOCALE;
6077 Perl_ck_sassign(pTHX_ OP *o)
6079 OP *kid = cLISTOPo->op_first;
6080 /* has a disposable target? */
6081 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6082 && !(kid->op_flags & OPf_STACKED)
6083 /* Cannot steal the second time! */
6084 && !(kid->op_private & OPpTARGET_MY))
6086 OP *kkid = kid->op_sibling;
6088 /* Can just relocate the target. */
6089 if (kkid && kkid->op_type == OP_PADSV
6090 && !(kkid->op_private & OPpLVAL_INTRO))
6092 kid->op_targ = kkid->op_targ;
6094 /* Now we do not need PADSV and SASSIGN. */
6095 kid->op_sibling = o->op_sibling; /* NULL */
6096 cLISTOPo->op_first = NULL;
6099 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6107 Perl_ck_scmp(pTHX_ OP *o)
6111 if (PL_hints & HINT_LOCALE)
6112 o->op_private |= OPpLOCALE;
6119 Perl_ck_match(pTHX_ OP *o)
6121 o->op_private |= OPpRUNTIME;
6126 Perl_ck_method(pTHX_ OP *o)
6128 OP *kid = cUNOPo->op_first;
6129 if (kid->op_type == OP_CONST) {
6130 SV* sv = kSVOP->op_sv;
6131 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6133 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6134 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6137 kSVOP->op_sv = Nullsv;
6139 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6148 Perl_ck_null(pTHX_ OP *o)
6154 Perl_ck_open(pTHX_ OP *o)
6156 HV *table = GvHV(PL_hintgv);
6160 svp = hv_fetch(table, "open_IN", 7, FALSE);
6162 mode = mode_from_discipline(*svp);
6163 if (mode & O_BINARY)
6164 o->op_private |= OPpOPEN_IN_RAW;
6165 else if (mode & O_TEXT)
6166 o->op_private |= OPpOPEN_IN_CRLF;
6169 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6171 mode = mode_from_discipline(*svp);
6172 if (mode & O_BINARY)
6173 o->op_private |= OPpOPEN_OUT_RAW;
6174 else if (mode & O_TEXT)
6175 o->op_private |= OPpOPEN_OUT_CRLF;
6178 if (o->op_type == OP_BACKTICK)
6184 Perl_ck_repeat(pTHX_ OP *o)
6186 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6187 o->op_private |= OPpREPEAT_DOLIST;
6188 cBINOPo->op_first = force_list(cBINOPo->op_first);
6196 Perl_ck_require(pTHX_ OP *o)
6198 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6199 SVOP *kid = (SVOP*)cUNOPo->op_first;
6201 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6203 for (s = SvPVX(kid->op_sv); *s; s++) {
6204 if (*s == ':' && s[1] == ':') {
6206 Move(s+2, s+1, strlen(s+2)+1, char);
6207 --SvCUR(kid->op_sv);
6210 if (SvREADONLY(kid->op_sv)) {
6211 SvREADONLY_off(kid->op_sv);
6212 sv_catpvn(kid->op_sv, ".pm", 3);
6213 SvREADONLY_on(kid->op_sv);
6216 sv_catpvn(kid->op_sv, ".pm", 3);
6223 Perl_ck_return(pTHX_ OP *o)
6226 if (CvLVALUE(PL_compcv)) {
6227 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6228 mod(kid, OP_LEAVESUBLV);
6235 Perl_ck_retarget(pTHX_ OP *o)
6237 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6244 Perl_ck_select(pTHX_ OP *o)
6247 if (o->op_flags & OPf_KIDS) {
6248 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6249 if (kid && kid->op_sibling) {
6250 o->op_type = OP_SSELECT;
6251 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6253 return fold_constants(o);
6257 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6258 if (kid && kid->op_type == OP_RV2GV)
6259 kid->op_private &= ~HINT_STRICT_REFS;
6264 Perl_ck_shift(pTHX_ OP *o)
6266 I32 type = o->op_type;
6268 if (!(o->op_flags & OPf_KIDS)) {
6273 if (!CvUNIQUE(PL_compcv)) {
6274 argop = newOP(OP_PADAV, OPf_REF);
6275 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6278 argop = newUNOP(OP_RV2AV, 0,
6279 scalar(newGVOP(OP_GV, 0,
6280 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6283 argop = newUNOP(OP_RV2AV, 0,
6284 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6285 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6286 #endif /* USE_THREADS */
6287 return newUNOP(type, 0, scalar(argop));
6289 return scalar(modkids(ck_fun(o), type));
6293 Perl_ck_sort(pTHX_ OP *o)
6298 if (PL_hints & HINT_LOCALE)
6299 o->op_private |= OPpLOCALE;
6302 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6304 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6305 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6307 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6309 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6311 if (kid->op_type == OP_SCOPE) {
6315 else if (kid->op_type == OP_LEAVE) {
6316 if (o->op_type == OP_SORT) {
6317 null(kid); /* wipe out leave */
6320 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6321 if (k->op_next == kid)
6323 /* don't descend into loops */
6324 else if (k->op_type == OP_ENTERLOOP
6325 || k->op_type == OP_ENTERITER)
6327 k = cLOOPx(k)->op_lastop;
6332 kid->op_next = 0; /* just disconnect the leave */
6333 k = kLISTOP->op_first;
6338 if (o->op_type == OP_SORT) {
6339 /* provide scalar context for comparison function/block */
6345 o->op_flags |= OPf_SPECIAL;
6347 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6350 firstkid = firstkid->op_sibling;
6353 /* provide list context for arguments */
6354 if (o->op_type == OP_SORT)
6361 S_simplify_sort(pTHX_ OP *o)
6363 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6367 if (!(o->op_flags & OPf_STACKED))
6369 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6370 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6371 kid = kUNOP->op_first; /* get past null */
6372 if (kid->op_type != OP_SCOPE)
6374 kid = kLISTOP->op_last; /* get past scope */
6375 switch(kid->op_type) {
6383 k = kid; /* remember this node*/
6384 if (kBINOP->op_first->op_type != OP_RV2SV)
6386 kid = kBINOP->op_first; /* get past cmp */
6387 if (kUNOP->op_first->op_type != OP_GV)
6389 kid = kUNOP->op_first; /* get past rv2sv */
6391 if (GvSTASH(gv) != PL_curstash)
6393 if (strEQ(GvNAME(gv), "a"))
6395 else if (strEQ(GvNAME(gv), "b"))
6399 kid = k; /* back to cmp */
6400 if (kBINOP->op_last->op_type != OP_RV2SV)
6402 kid = kBINOP->op_last; /* down to 2nd arg */
6403 if (kUNOP->op_first->op_type != OP_GV)
6405 kid = kUNOP->op_first; /* get past rv2sv */
6407 if (GvSTASH(gv) != PL_curstash
6409 ? strNE(GvNAME(gv), "a")
6410 : strNE(GvNAME(gv), "b")))
6412 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6414 o->op_private |= OPpSORT_REVERSE;
6415 if (k->op_type == OP_NCMP)
6416 o->op_private |= OPpSORT_NUMERIC;
6417 if (k->op_type == OP_I_NCMP)
6418 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6419 kid = cLISTOPo->op_first->op_sibling;
6420 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6421 op_free(kid); /* then delete it */
6425 Perl_ck_split(pTHX_ OP *o)
6429 if (o->op_flags & OPf_STACKED)
6430 return no_fh_allowed(o);
6432 kid = cLISTOPo->op_first;
6433 if (kid->op_type != OP_NULL)
6434 Perl_croak(aTHX_ "panic: ck_split");
6435 kid = kid->op_sibling;
6436 op_free(cLISTOPo->op_first);
6437 cLISTOPo->op_first = kid;
6439 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6440 cLISTOPo->op_last = kid; /* There was only one element previously */
6443 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6444 OP *sibl = kid->op_sibling;
6445 kid->op_sibling = 0;
6446 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6447 if (cLISTOPo->op_first == cLISTOPo->op_last)
6448 cLISTOPo->op_last = kid;
6449 cLISTOPo->op_first = kid;
6450 kid->op_sibling = sibl;
6453 kid->op_type = OP_PUSHRE;
6454 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6457 if (!kid->op_sibling)
6458 append_elem(OP_SPLIT, o, newDEFSVOP());
6460 kid = kid->op_sibling;
6463 if (!kid->op_sibling)
6464 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6466 kid = kid->op_sibling;
6469 if (kid->op_sibling)
6470 return too_many_arguments(o,PL_op_desc[o->op_type]);
6476 Perl_ck_join(pTHX_ OP *o)
6478 if (ckWARN(WARN_SYNTAX)) {
6479 OP *kid = cLISTOPo->op_first->op_sibling;
6480 if (kid && kid->op_type == OP_MATCH) {
6481 char *pmstr = "STRING";
6482 if (kPMOP->op_pmregexp)
6483 pmstr = kPMOP->op_pmregexp->precomp;
6484 Perl_warner(aTHX_ WARN_SYNTAX,
6485 "/%s/ should probably be written as \"%s\"",
6493 Perl_ck_subr(pTHX_ OP *o)
6495 OP *prev = ((cUNOPo->op_first->op_sibling)
6496 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6497 OP *o2 = prev->op_sibling;
6506 o->op_private |= OPpENTERSUB_HASTARG;
6507 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6508 if (cvop->op_type == OP_RV2CV) {
6510 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6511 null(cvop); /* disable rv2cv */
6512 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6513 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6514 GV *gv = cGVOPx_gv(tmpop);
6517 tmpop->op_private |= OPpEARLY_CV;
6518 else if (SvPOK(cv)) {
6519 namegv = CvANON(cv) ? gv : CvGV(cv);
6520 proto = SvPV((SV*)cv, n_a);
6524 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6525 if (o2->op_type == OP_CONST)
6526 o2->op_private &= ~OPpCONST_STRICT;
6527 else if (o2->op_type == OP_LIST) {
6528 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6529 if (o && o->op_type == OP_CONST)
6530 o->op_private &= ~OPpCONST_STRICT;
6533 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6534 if (PERLDB_SUB && PL_curstash != PL_debstash)
6535 o->op_private |= OPpENTERSUB_DB;
6536 while (o2 != cvop) {
6540 return too_many_arguments(o, gv_ename(namegv));
6558 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6560 arg == 1 ? "block or sub {}" : "sub {}",
6561 gv_ename(namegv), o2);
6564 /* '*' allows any scalar type, including bareword */
6567 if (o2->op_type == OP_RV2GV)
6568 goto wrapref; /* autoconvert GLOB -> GLOBref */
6569 else if (o2->op_type == OP_CONST)
6570 o2->op_private &= ~OPpCONST_STRICT;
6571 else if (o2->op_type == OP_ENTERSUB) {
6572 /* accidental subroutine, revert to bareword */
6573 OP *gvop = ((UNOP*)o2)->op_first;
6574 if (gvop && gvop->op_type == OP_NULL) {
6575 gvop = ((UNOP*)gvop)->op_first;
6577 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6580 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6581 (gvop = ((UNOP*)gvop)->op_first) &&
6582 gvop->op_type == OP_GV)
6584 GV *gv = cGVOPx_gv(gvop);
6585 OP *sibling = o2->op_sibling;
6586 SV *n = newSVpvn("",0);
6588 gv_fullname3(n, gv, "");
6589 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6590 sv_chop(n, SvPVX(n)+6);
6591 o2 = newSVOP(OP_CONST, 0, n);
6592 prev->op_sibling = o2;
6593 o2->op_sibling = sibling;
6605 if (o2->op_type != OP_RV2GV)
6606 bad_type(arg, "symbol", gv_ename(namegv), o2);
6609 if (o2->op_type != OP_ENTERSUB)
6610 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6613 if (o2->op_type != OP_RV2SV
6614 && o2->op_type != OP_PADSV
6615 && o2->op_type != OP_HELEM
6616 && o2->op_type != OP_AELEM
6617 && o2->op_type != OP_THREADSV)
6619 bad_type(arg, "scalar", gv_ename(namegv), o2);
6623 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6624 bad_type(arg, "array", gv_ename(namegv), o2);
6627 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6628 bad_type(arg, "hash", gv_ename(namegv), o2);
6632 OP* sib = kid->op_sibling;
6633 kid->op_sibling = 0;
6634 o2 = newUNOP(OP_REFGEN, 0, kid);
6635 o2->op_sibling = sib;
6636 prev->op_sibling = o2;
6647 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6648 gv_ename(namegv), SvPV((SV*)cv, n_a));
6653 mod(o2, OP_ENTERSUB);
6655 o2 = o2->op_sibling;
6657 if (proto && !optional &&
6658 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6659 return too_few_arguments(o, gv_ename(namegv));
6664 Perl_ck_svconst(pTHX_ OP *o)
6666 SvREADONLY_on(cSVOPo->op_sv);
6671 Perl_ck_trunc(pTHX_ OP *o)
6673 if (o->op_flags & OPf_KIDS) {
6674 SVOP *kid = (SVOP*)cUNOPo->op_first;
6676 if (kid->op_type == OP_NULL)
6677 kid = (SVOP*)kid->op_sibling;
6678 if (kid && kid->op_type == OP_CONST &&
6679 (kid->op_private & OPpCONST_BARE))
6681 o->op_flags |= OPf_SPECIAL;
6682 kid->op_private &= ~OPpCONST_STRICT;
6689 Perl_ck_substr(pTHX_ OP *o)
6692 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6693 OP *kid = cLISTOPo->op_first;
6695 if (kid->op_type == OP_NULL)
6696 kid = kid->op_sibling;
6698 kid->op_flags |= OPf_MOD;
6704 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6707 Perl_peep(pTHX_ register OP *o)
6709 register OP* oldop = 0;
6712 if (!o || o->op_seq)
6716 SAVEVPTR(PL_curcop);
6717 for (; o; o = o->op_next) {
6723 switch (o->op_type) {
6727 PL_curcop = ((COP*)o); /* for warnings */
6728 o->op_seq = PL_op_seqmax++;
6732 if (cSVOPo->op_private & OPpCONST_STRICT)
6733 no_bareword_allowed(o);
6735 /* Relocate sv to the pad for thread safety.
6736 * Despite being a "constant", the SV is written to,
6737 * for reference counts, sv_upgrade() etc. */
6739 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6740 if (SvPADTMP(cSVOPo->op_sv)) {
6741 /* If op_sv is already a PADTMP then it is being used by
6742 * some pad, so make a copy. */
6743 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6744 SvREADONLY_on(PL_curpad[ix]);
6745 SvREFCNT_dec(cSVOPo->op_sv);
6748 SvREFCNT_dec(PL_curpad[ix]);
6749 SvPADTMP_on(cSVOPo->op_sv);
6750 PL_curpad[ix] = cSVOPo->op_sv;
6751 /* XXX I don't know how this isn't readonly already. */
6752 SvREADONLY_on(PL_curpad[ix]);
6754 cSVOPo->op_sv = Nullsv;
6758 o->op_seq = PL_op_seqmax++;
6762 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6763 if (o->op_next->op_private & OPpTARGET_MY) {
6764 if (o->op_flags & OPf_STACKED) /* chained concats */
6765 goto ignore_optimization;
6767 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6768 o->op_targ = o->op_next->op_targ;
6769 o->op_next->op_targ = 0;
6770 o->op_private |= OPpTARGET_MY;
6775 ignore_optimization:
6776 o->op_seq = PL_op_seqmax++;
6779 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6780 o->op_seq = PL_op_seqmax++;
6781 break; /* Scalar stub must produce undef. List stub is noop */
6785 if (o->op_targ == OP_NEXTSTATE
6786 || o->op_targ == OP_DBSTATE
6787 || o->op_targ == OP_SETSTATE)
6789 PL_curcop = ((COP*)o);
6796 if (oldop && o->op_next) {
6797 oldop->op_next = o->op_next;
6800 o->op_seq = PL_op_seqmax++;
6804 if (o->op_next->op_type == OP_RV2SV) {
6805 if (!(o->op_next->op_private & OPpDEREF)) {
6807 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6809 o->op_next = o->op_next->op_next;
6810 o->op_type = OP_GVSV;
6811 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6814 else if (o->op_next->op_type == OP_RV2AV) {
6815 OP* pop = o->op_next->op_next;
6817 if (pop->op_type == OP_CONST &&
6818 (PL_op = pop->op_next) &&
6819 pop->op_next->op_type == OP_AELEM &&
6820 !(pop->op_next->op_private &
6821 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6822 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6830 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6831 o->op_next = pop->op_next->op_next;
6832 o->op_type = OP_AELEMFAST;
6833 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6834 o->op_private = (U8)i;
6839 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6841 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6842 /* XXX could check prototype here instead of just carping */
6843 SV *sv = sv_newmortal();
6844 gv_efullname3(sv, gv, Nullch);
6845 Perl_warner(aTHX_ WARN_PROTOTYPE,
6846 "%s() called too early to check prototype",
6851 o->op_seq = PL_op_seqmax++;
6862 o->op_seq = PL_op_seqmax++;
6863 while (cLOGOP->op_other->op_type == OP_NULL)
6864 cLOGOP->op_other = cLOGOP->op_other->op_next;
6865 peep(cLOGOP->op_other);
6870 o->op_seq = PL_op_seqmax++;
6871 while (cLOOP->op_redoop->op_type == OP_NULL)
6872 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6873 peep(cLOOP->op_redoop);
6874 while (cLOOP->op_nextop->op_type == OP_NULL)
6875 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6876 peep(cLOOP->op_nextop);
6877 while (cLOOP->op_lastop->op_type == OP_NULL)
6878 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6879 peep(cLOOP->op_lastop);
6885 o->op_seq = PL_op_seqmax++;
6886 while (cPMOP->op_pmreplstart &&
6887 cPMOP->op_pmreplstart->op_type == OP_NULL)
6888 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6889 peep(cPMOP->op_pmreplstart);
6893 o->op_seq = PL_op_seqmax++;
6894 if (ckWARN(WARN_SYNTAX) && o->op_next
6895 && o->op_next->op_type == OP_NEXTSTATE) {
6896 if (o->op_next->op_sibling &&
6897 o->op_next->op_sibling->op_type != OP_EXIT &&
6898 o->op_next->op_sibling->op_type != OP_WARN &&
6899 o->op_next->op_sibling->op_type != OP_DIE) {
6900 line_t oldline = CopLINE(PL_curcop);
6902 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6903 Perl_warner(aTHX_ WARN_EXEC,
6904 "Statement unlikely to be reached");
6905 Perl_warner(aTHX_ WARN_EXEC,
6906 "\t(Maybe you meant system() when you said exec()?)\n");
6907 CopLINE_set(PL_curcop, oldline);
6916 SV **svp, **indsvp, *sv;
6921 o->op_seq = PL_op_seqmax++;
6923 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6926 /* Make the CONST have a shared SV */
6927 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6928 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6929 key = SvPV(sv, keylen);
6932 lexname = newSVpvn_share(key, keylen, 0);
6937 if ((o->op_private & (OPpLVAL_INTRO)))
6940 rop = (UNOP*)((BINOP*)o)->op_first;
6941 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6943 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6944 if (!SvOBJECT(lexname))
6946 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6947 if (!fields || !GvHV(*fields))
6949 key = SvPV(*svp, keylen);
6952 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6954 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6955 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6957 ind = SvIV(*indsvp);
6959 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6960 rop->op_type = OP_RV2AV;
6961 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6962 o->op_type = OP_AELEM;
6963 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6965 if (SvREADONLY(*svp))
6967 SvFLAGS(sv) |= (SvFLAGS(*svp)
6968 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6978 SV **svp, **indsvp, *sv;
6982 SVOP *first_key_op, *key_op;
6984 o->op_seq = PL_op_seqmax++;
6985 if ((o->op_private & (OPpLVAL_INTRO))
6986 /* I bet there's always a pushmark... */
6987 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6988 /* hmmm, no optimization if list contains only one key. */
6990 rop = (UNOP*)((LISTOP*)o)->op_last;
6991 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6993 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6994 if (!SvOBJECT(lexname))
6996 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6997 if (!fields || !GvHV(*fields))
6999 /* Again guessing that the pushmark can be jumped over.... */
7000 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7001 ->op_first->op_sibling;
7002 /* Check that the key list contains only constants. */
7003 for (key_op = first_key_op; key_op;
7004 key_op = (SVOP*)key_op->op_sibling)
7005 if (key_op->op_type != OP_CONST)
7009 rop->op_type = OP_RV2AV;
7010 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7011 o->op_type = OP_ASLICE;
7012 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7013 for (key_op = first_key_op; key_op;
7014 key_op = (SVOP*)key_op->op_sibling) {
7015 svp = cSVOPx_svp(key_op);
7016 key = SvPV(*svp, keylen);
7019 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7021 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7022 "in variable %s of type %s",
7023 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7025 ind = SvIV(*indsvp);
7027 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7029 if (SvREADONLY(*svp))
7031 SvFLAGS(sv) |= (SvFLAGS(*svp)
7032 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7040 o->op_seq = PL_op_seqmax++;
7050 /* Efficient sub that returns a constant scalar value. */
7052 const_sv_xsub(pTHXo_ CV* cv)
7057 Perl_croak(aTHX_ "usage: %s::%s()",
7058 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7062 ST(0) = (SV*)XSANY.any_ptr;