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"));
186 SvFLAGS(sv) |= SVpad_TYPED;
187 (void)SvUPGRADE(sv, SVt_PVMG);
188 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
190 if (PL_in_my == KEY_our) {
191 (void)SvUPGRADE(sv, SVt_PVGV);
192 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
193 SvFLAGS(sv) |= SVpad_OUR;
195 av_store(PL_comppad_name, off, sv);
196 SvNVX(sv) = (NV)PAD_MAX;
197 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
198 if (!PL_min_intro_pending)
199 PL_min_intro_pending = off;
200 PL_max_intro_pending = off;
202 av_store(PL_comppad, off, (SV*)newAV());
203 else if (*name == '%')
204 av_store(PL_comppad, off, (SV*)newHV());
205 SvPADMY_on(PL_curpad[off]);
210 S_pad_addlex(pTHX_ SV *proto_namesv)
212 SV *namesv = NEWSV(1103,0);
213 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
214 sv_upgrade(namesv, SVt_PVNV);
215 sv_setpv(namesv, SvPVX(proto_namesv));
216 av_store(PL_comppad_name, newoff, namesv);
217 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
218 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
219 SvFAKE_on(namesv); /* A ref, not a real var */
220 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
221 SvFLAGS(namesv) |= SVpad_OUR;
222 (void)SvUPGRADE(namesv, SVt_PVGV);
223 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
225 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
226 SvFLAGS(namesv) |= SVpad_TYPED;
227 (void)SvUPGRADE(namesv, SVt_PVMG);
228 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
233 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
236 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
237 I32 cx_ix, I32 saweval, U32 flags)
243 register PERL_CONTEXT *cx;
245 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
246 AV *curlist = CvPADLIST(cv);
247 SV **svp = av_fetch(curlist, 0, FALSE);
250 if (!svp || *svp == &PL_sv_undef)
253 svp = AvARRAY(curname);
254 for (off = AvFILLp(curname); off > 0; off--) {
255 if ((sv = svp[off]) &&
256 sv != &PL_sv_undef &&
258 seq > I_32(SvNVX(sv)) &&
259 strEQ(SvPVX(sv), name))
270 return 0; /* don't clone from inactive stack frame */
274 oldpad = (AV*)AvARRAY(curlist)[depth];
275 oldsv = *av_fetch(oldpad, off, TRUE);
276 if (!newoff) { /* Not a mere clone operation. */
277 newoff = pad_addlex(sv);
278 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
279 /* "It's closures all the way down." */
280 CvCLONE_on(PL_compcv);
282 if (CvANON(PL_compcv))
283 oldsv = Nullsv; /* no need to keep ref */
288 bcv && bcv != cv && !CvCLONE(bcv);
289 bcv = CvOUTSIDE(bcv))
292 /* install the missing pad entry in intervening
293 * nested subs and mark them cloneable.
294 * XXX fix pad_foo() to not use globals */
295 AV *ocomppad_name = PL_comppad_name;
296 AV *ocomppad = PL_comppad;
297 SV **ocurpad = PL_curpad;
298 AV *padlist = CvPADLIST(bcv);
299 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
300 PL_comppad = (AV*)AvARRAY(padlist)[1];
301 PL_curpad = AvARRAY(PL_comppad);
303 PL_comppad_name = ocomppad_name;
304 PL_comppad = ocomppad;
309 if (ckWARN(WARN_CLOSURE)
310 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
312 Perl_warner(aTHX_ WARN_CLOSURE,
313 "Variable \"%s\" may be unavailable",
321 else if (!CvUNIQUE(PL_compcv)) {
322 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
323 && !(SvFLAGS(sv) & SVpad_OUR))
325 Perl_warner(aTHX_ WARN_CLOSURE,
326 "Variable \"%s\" will not stay shared", name);
330 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
336 if (flags & FINDLEX_NOSEARCH)
339 /* Nothing in current lexical context--try eval's context, if any.
340 * This is necessary to let the perldb get at lexically scoped variables.
341 * XXX This will also probably interact badly with eval tree caching.
344 for (i = cx_ix; i >= 0; i--) {
346 switch (CxTYPE(cx)) {
348 if (i == 0 && saweval) {
349 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
353 switch (cx->blk_eval.old_op_type) {
355 if (CxREALEVAL(cx)) {
358 seq = cxstack[i].blk_oldcop->cop_seq;
359 startcv = cxstack[i].blk_eval.cv;
360 off = pad_findlex(name, newoff, seq, startcv, i-1,
362 if (off) /* continue looking if not found here */
368 /* require/do must have their own scope */
377 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
378 saweval = i; /* so we know where we were called from */
381 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
389 Perl_pad_findmy(pTHX_ char *name)
394 SV **svp = AvARRAY(PL_comppad_name);
395 U32 seq = PL_cop_seqmax;
401 * Special case to get lexical (and hence per-thread) @_.
402 * XXX I need to find out how to tell at parse-time whether use
403 * of @_ should refer to a lexical (from a sub) or defgv (global
404 * scope and maybe weird sub-ish things like formats). See
405 * startsub in perly.y. It's possible that @_ could be lexical
406 * (at least from subs) even in non-threaded perl.
408 if (strEQ(name, "@_"))
409 return 0; /* success. (NOT_IN_PAD indicates failure) */
410 #endif /* USE_THREADS */
412 /* The one we're looking for is probably just before comppad_name_fill. */
413 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
414 if ((sv = svp[off]) &&
415 sv != &PL_sv_undef &&
418 seq > I_32(SvNVX(sv)))) &&
419 strEQ(SvPVX(sv), name))
421 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
422 return (PADOFFSET)off;
423 pendoff = off; /* this pending def. will override import */
427 outside = CvOUTSIDE(PL_compcv);
429 /* Check if if we're compiling an eval'', and adjust seq to be the
430 * eval's seq number. This depends on eval'' having a non-null
431 * CvOUTSIDE() while it is being compiled. The eval'' itself is
432 * identified by CvEVAL being true and CvGV being null. */
433 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
434 cx = &cxstack[cxstack_ix];
436 seq = cx->blk_oldcop->cop_seq;
439 /* See if it's in a nested scope */
440 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
442 /* If there is a pending local definition, this new alias must die */
444 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
445 return off; /* pad_findlex returns 0 for failure...*/
447 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
451 Perl_pad_leavemy(pTHX_ I32 fill)
454 SV **svp = AvARRAY(PL_comppad_name);
456 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
457 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
458 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
459 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
462 /* "Deintroduce" my variables that are leaving with this scope. */
463 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
464 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
465 SvIVX(sv) = PL_cop_seqmax;
470 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
475 if (AvARRAY(PL_comppad) != PL_curpad)
476 Perl_croak(aTHX_ "panic: pad_alloc");
477 if (PL_pad_reset_pending)
479 if (tmptype & SVs_PADMY) {
481 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
482 } while (SvPADBUSY(sv)); /* need a fresh one */
483 retval = AvFILLp(PL_comppad);
486 SV **names = AvARRAY(PL_comppad_name);
487 SSize_t names_fill = AvFILLp(PL_comppad_name);
490 * "foreach" index vars temporarily become aliases to non-"my"
491 * values. Thus we must skip, not just pad values that are
492 * marked as current pad values, but also those with names.
494 if (++PL_padix <= names_fill &&
495 (sv = names[PL_padix]) && sv != &PL_sv_undef)
497 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
498 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
499 !IS_PADGV(sv) && !IS_PADCONST(sv))
504 SvFLAGS(sv) |= tmptype;
505 PL_curpad = AvARRAY(PL_comppad);
507 DEBUG_X(PerlIO_printf(Perl_debug_log,
508 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
509 PTR2UV(thr), PTR2UV(PL_curpad),
510 (long) retval, PL_op_name[optype]));
512 DEBUG_X(PerlIO_printf(Perl_debug_log,
513 "Pad 0x%"UVxf" alloc %ld for %s\n",
515 (long) retval, PL_op_name[optype]));
516 #endif /* USE_THREADS */
517 return (PADOFFSET)retval;
521 Perl_pad_sv(pTHX_ PADOFFSET po)
524 DEBUG_X(PerlIO_printf(Perl_debug_log,
525 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
526 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
529 Perl_croak(aTHX_ "panic: pad_sv po");
530 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
531 PTR2UV(PL_curpad), (IV)po));
532 #endif /* USE_THREADS */
533 return PL_curpad[po]; /* eventually we'll turn this into a macro */
537 Perl_pad_free(pTHX_ PADOFFSET po)
541 if (AvARRAY(PL_comppad) != PL_curpad)
542 Perl_croak(aTHX_ "panic: pad_free curpad");
544 Perl_croak(aTHX_ "panic: pad_free po");
546 DEBUG_X(PerlIO_printf(Perl_debug_log,
547 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
548 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
550 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
551 PTR2UV(PL_curpad), (IV)po));
552 #endif /* USE_THREADS */
553 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
554 SvPADTMP_off(PL_curpad[po]);
556 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
559 if ((I32)po < PL_padix)
564 Perl_pad_swipe(pTHX_ PADOFFSET po)
566 if (AvARRAY(PL_comppad) != PL_curpad)
567 Perl_croak(aTHX_ "panic: pad_swipe curpad");
569 Perl_croak(aTHX_ "panic: pad_swipe po");
571 DEBUG_X(PerlIO_printf(Perl_debug_log,
572 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
573 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
575 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
576 PTR2UV(PL_curpad), (IV)po));
577 #endif /* USE_THREADS */
578 SvPADTMP_off(PL_curpad[po]);
579 PL_curpad[po] = NEWSV(1107,0);
580 SvPADTMP_on(PL_curpad[po]);
581 if ((I32)po < PL_padix)
585 /* XXX pad_reset() is currently disabled because it results in serious bugs.
586 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
587 * on the stack by OPs that use them, there are several ways to get an alias
588 * to a shared TARG. Such an alias will change randomly and unpredictably.
589 * We avoid doing this until we can think of a Better Way.
594 #ifdef USE_BROKEN_PAD_RESET
597 if (AvARRAY(PL_comppad) != PL_curpad)
598 Perl_croak(aTHX_ "panic: pad_reset curpad");
600 DEBUG_X(PerlIO_printf(Perl_debug_log,
601 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
602 PTR2UV(thr), PTR2UV(PL_curpad)));
604 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
606 #endif /* USE_THREADS */
607 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
608 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
609 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
610 SvPADTMP_off(PL_curpad[po]);
612 PL_padix = PL_padix_floor;
615 PL_pad_reset_pending = FALSE;
619 /* find_threadsv is not reentrant */
621 Perl_find_threadsv(pTHX_ const char *name)
626 /* We currently only handle names of a single character */
627 p = strchr(PL_threadsv_names, *name);
630 key = p - PL_threadsv_names;
631 MUTEX_LOCK(&thr->mutex);
632 svp = av_fetch(thr->threadsv, key, FALSE);
634 MUTEX_UNLOCK(&thr->mutex);
636 SV *sv = NEWSV(0, 0);
637 av_store(thr->threadsv, key, sv);
638 thr->threadsvp = AvARRAY(thr->threadsv);
639 MUTEX_UNLOCK(&thr->mutex);
641 * Some magic variables used to be automagically initialised
642 * in gv_fetchpv. Those which are now per-thread magicals get
643 * initialised here instead.
649 sv_setpv(sv, "\034");
650 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
655 PL_sawampersand = TRUE;
669 /* XXX %! tied to Errno.pm needs to be added here.
670 * See gv_fetchpv(). */
674 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
676 DEBUG_S(PerlIO_printf(Perl_error_log,
677 "find_threadsv: new SV %p for $%s%c\n",
678 sv, (*name < 32) ? "^" : "",
679 (*name < 32) ? toCTRL(*name) : *name));
683 #endif /* USE_THREADS */
688 Perl_op_free(pTHX_ OP *o)
690 register OP *kid, *nextkid;
693 if (!o || o->op_seq == (U16)-1)
696 if (o->op_private & OPpREFCOUNTED) {
697 switch (o->op_type) {
705 if (OpREFCNT_dec(o)) {
716 if (o->op_flags & OPf_KIDS) {
717 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
718 nextkid = kid->op_sibling; /* Get before next freeing kid */
726 /* COP* is not cleared by op_clear() so that we may track line
727 * numbers etc even after null() */
728 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
733 #ifdef PL_OP_SLAB_ALLOC
734 if ((char *) o == PL_OpPtr)
743 Perl_op_clear(pTHX_ OP *o)
745 switch (o->op_type) {
746 case OP_NULL: /* Was holding old type, if any. */
747 case OP_ENTEREVAL: /* Was holding hints. */
749 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
755 if (!(o->op_flags & OPf_SPECIAL))
758 #endif /* USE_THREADS */
760 if (!(o->op_flags & OPf_REF)
761 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
768 if (cPADOPo->op_padix > 0) {
771 pad_swipe(cPADOPo->op_padix);
772 /* No GvIN_PAD_off(gv) here, because other references may still
773 * exist on the pad */
776 cPADOPo->op_padix = 0;
779 SvREFCNT_dec(cSVOPo->op_sv);
780 cSVOPo->op_sv = Nullsv;
783 case OP_METHOD_NAMED:
785 SvREFCNT_dec(cSVOPo->op_sv);
786 cSVOPo->op_sv = Nullsv;
792 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
796 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
797 SvREFCNT_dec(cSVOPo->op_sv);
798 cSVOPo->op_sv = Nullsv;
801 Safefree(cPVOPo->op_pv);
802 cPVOPo->op_pv = Nullch;
806 op_free(cPMOPo->op_pmreplroot);
810 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
812 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
813 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
814 /* No GvIN_PAD_off(gv) here, because other references may still
815 * exist on the pad */
820 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
827 HV *pmstash = PmopSTASH(cPMOPo);
828 if (pmstash && SvREFCNT(pmstash)) {
829 PMOP *pmop = HvPMROOT(pmstash);
830 PMOP *lastpmop = NULL;
832 if (cPMOPo == pmop) {
834 lastpmop->op_pmnext = pmop->op_pmnext;
836 HvPMROOT(pmstash) = pmop->op_pmnext;
840 pmop = pmop->op_pmnext;
843 Safefree(PmopSTASHPV(cPMOPo));
845 /* NOTE: PMOP.op_pmstash is not refcounted */
849 cPMOPo->op_pmreplroot = Nullop;
850 ReREFCNT_dec(cPMOPo->op_pmregexp);
851 cPMOPo->op_pmregexp = (REGEXP*)NULL;
855 if (o->op_targ > 0) {
856 pad_free(o->op_targ);
862 S_cop_free(pTHX_ COP* cop)
864 Safefree(cop->cop_label);
866 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
867 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
869 /* NOTE: COP.cop_stash is not refcounted */
870 SvREFCNT_dec(CopFILEGV(cop));
872 if (! specialWARN(cop->cop_warnings))
873 SvREFCNT_dec(cop->cop_warnings);
874 if (! specialCopIO(cop->cop_io))
875 SvREFCNT_dec(cop->cop_io);
879 Perl_op_null(pTHX_ OP *o)
881 if (o->op_type == OP_NULL)
884 o->op_targ = o->op_type;
885 o->op_type = OP_NULL;
886 o->op_ppaddr = PL_ppaddr[OP_NULL];
889 /* Contextualizers */
891 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
894 Perl_linklist(pTHX_ OP *o)
901 /* establish postfix order */
902 if (cUNOPo->op_first) {
903 o->op_next = LINKLIST(cUNOPo->op_first);
904 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
906 kid->op_next = LINKLIST(kid->op_sibling);
918 Perl_scalarkids(pTHX_ OP *o)
921 if (o && o->op_flags & OPf_KIDS) {
922 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
929 S_scalarboolean(pTHX_ OP *o)
931 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
932 if (ckWARN(WARN_SYNTAX)) {
933 line_t oldline = CopLINE(PL_curcop);
935 if (PL_copline != NOLINE)
936 CopLINE_set(PL_curcop, PL_copline);
937 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
938 CopLINE_set(PL_curcop, oldline);
945 Perl_scalar(pTHX_ OP *o)
949 /* assumes no premature commitment */
950 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
951 || o->op_type == OP_RETURN)
956 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
958 switch (o->op_type) {
960 scalar(cBINOPo->op_first);
965 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
969 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
970 if (!kPMOP->op_pmreplroot)
971 deprecate("implicit split to @_");
979 if (o->op_flags & OPf_KIDS) {
980 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
986 kid = cLISTOPo->op_first;
988 while ((kid = kid->op_sibling)) {
994 WITH_THR(PL_curcop = &PL_compiling);
999 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1000 if (kid->op_sibling)
1005 WITH_THR(PL_curcop = &PL_compiling);
1012 Perl_scalarvoid(pTHX_ OP *o)
1019 if (o->op_type == OP_NEXTSTATE
1020 || o->op_type == OP_SETSTATE
1021 || o->op_type == OP_DBSTATE
1022 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1023 || o->op_targ == OP_SETSTATE
1024 || o->op_targ == OP_DBSTATE)))
1025 PL_curcop = (COP*)o; /* for warning below */
1027 /* assumes no premature commitment */
1028 want = o->op_flags & OPf_WANT;
1029 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1030 || o->op_type == OP_RETURN)
1035 if ((o->op_private & OPpTARGET_MY)
1036 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1038 return scalar(o); /* As if inside SASSIGN */
1041 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1043 switch (o->op_type) {
1045 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1049 if (o->op_flags & OPf_STACKED)
1053 if (o->op_private == 4)
1095 case OP_GETSOCKNAME:
1096 case OP_GETPEERNAME:
1101 case OP_GETPRIORITY:
1124 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1125 useless = PL_op_desc[o->op_type];
1132 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1133 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1134 useless = "a variable";
1139 if (cSVOPo->op_private & OPpCONST_STRICT)
1140 no_bareword_allowed(o);
1142 if (ckWARN(WARN_VOID)) {
1143 useless = "a constant";
1144 /* the constants 0 and 1 are permitted as they are
1145 conventionally used as dummies in constructs like
1146 1 while some_condition_with_side_effects; */
1147 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1149 else if (SvPOK(sv)) {
1150 /* perl4's way of mixing documentation and code
1151 (before the invention of POD) was based on a
1152 trick to mix nroff and perl code. The trick was
1153 built upon these three nroff macros being used in
1154 void context. The pink camel has the details in
1155 the script wrapman near page 319. */
1156 if (strnEQ(SvPVX(sv), "di", 2) ||
1157 strnEQ(SvPVX(sv), "ds", 2) ||
1158 strnEQ(SvPVX(sv), "ig", 2))
1163 op_null(o); /* don't execute or even remember it */
1167 o->op_type = OP_PREINC; /* pre-increment is faster */
1168 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1172 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1173 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1179 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1184 if (o->op_flags & OPf_STACKED)
1191 if (!(o->op_flags & OPf_KIDS))
1200 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1207 /* all requires must return a boolean value */
1208 o->op_flags &= ~OPf_WANT;
1213 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1214 if (!kPMOP->op_pmreplroot)
1215 deprecate("implicit split to @_");
1219 if (useless && ckWARN(WARN_VOID))
1220 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1225 Perl_listkids(pTHX_ OP *o)
1228 if (o && o->op_flags & OPf_KIDS) {
1229 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1236 Perl_list(pTHX_ OP *o)
1240 /* assumes no premature commitment */
1241 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1242 || o->op_type == OP_RETURN)
1247 if ((o->op_private & OPpTARGET_MY)
1248 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1250 return o; /* As if inside SASSIGN */
1253 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1255 switch (o->op_type) {
1258 list(cBINOPo->op_first);
1263 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1271 if (!(o->op_flags & OPf_KIDS))
1273 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1274 list(cBINOPo->op_first);
1275 return gen_constant_list(o);
1282 kid = cLISTOPo->op_first;
1284 while ((kid = kid->op_sibling)) {
1285 if (kid->op_sibling)
1290 WITH_THR(PL_curcop = &PL_compiling);
1294 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1295 if (kid->op_sibling)
1300 WITH_THR(PL_curcop = &PL_compiling);
1303 /* all requires must return a boolean value */
1304 o->op_flags &= ~OPf_WANT;
1311 Perl_scalarseq(pTHX_ OP *o)
1316 if (o->op_type == OP_LINESEQ ||
1317 o->op_type == OP_SCOPE ||
1318 o->op_type == OP_LEAVE ||
1319 o->op_type == OP_LEAVETRY)
1321 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1322 if (kid->op_sibling) {
1326 PL_curcop = &PL_compiling;
1328 o->op_flags &= ~OPf_PARENS;
1329 if (PL_hints & HINT_BLOCK_SCOPE)
1330 o->op_flags |= OPf_PARENS;
1333 o = newOP(OP_STUB, 0);
1338 S_modkids(pTHX_ OP *o, I32 type)
1341 if (o && o->op_flags & OPf_KIDS) {
1342 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1349 Perl_mod(pTHX_ OP *o, I32 type)
1354 if (!o || PL_error_count)
1357 if ((o->op_private & OPpTARGET_MY)
1358 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1363 switch (o->op_type) {
1368 if (!(o->op_private & (OPpCONST_ARYBASE)))
1370 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1371 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1375 SAVEI32(PL_compiling.cop_arybase);
1376 PL_compiling.cop_arybase = 0;
1378 else if (type == OP_REFGEN)
1381 Perl_croak(aTHX_ "That use of $[ is unsupported");
1384 if (o->op_flags & OPf_PARENS)
1388 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1389 !(o->op_flags & OPf_STACKED)) {
1390 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1391 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1392 assert(cUNOPo->op_first->op_type == OP_NULL);
1393 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1396 else { /* lvalue subroutine call */
1397 o->op_private |= OPpLVAL_INTRO;
1398 PL_modcount = RETURN_UNLIMITED_NUMBER;
1399 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1400 /* Backward compatibility mode: */
1401 o->op_private |= OPpENTERSUB_INARGS;
1404 else { /* Compile-time error message: */
1405 OP *kid = cUNOPo->op_first;
1409 if (kid->op_type == OP_PUSHMARK)
1411 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1413 "panic: unexpected lvalue entersub "
1414 "args: type/targ %ld:%ld",
1415 (long)kid->op_type,kid->op_targ);
1416 kid = kLISTOP->op_first;
1418 while (kid->op_sibling)
1419 kid = kid->op_sibling;
1420 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1422 if (kid->op_type == OP_METHOD_NAMED
1423 || kid->op_type == OP_METHOD)
1427 if (kid->op_sibling || kid->op_next != kid) {
1428 yyerror("panic: unexpected optree near method call");
1432 NewOp(1101, newop, 1, UNOP);
1433 newop->op_type = OP_RV2CV;
1434 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1435 newop->op_first = Nullop;
1436 newop->op_next = (OP*)newop;
1437 kid->op_sibling = (OP*)newop;
1438 newop->op_private |= OPpLVAL_INTRO;
1442 if (kid->op_type != OP_RV2CV)
1444 "panic: unexpected lvalue entersub "
1445 "entry via type/targ %ld:%ld",
1446 (long)kid->op_type,kid->op_targ);
1447 kid->op_private |= OPpLVAL_INTRO;
1448 break; /* Postpone until runtime */
1452 kid = kUNOP->op_first;
1453 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1454 kid = kUNOP->op_first;
1455 if (kid->op_type == OP_NULL)
1457 "Unexpected constant lvalue entersub "
1458 "entry via type/targ %ld:%ld",
1459 (long)kid->op_type,kid->op_targ);
1460 if (kid->op_type != OP_GV) {
1461 /* Restore RV2CV to check lvalueness */
1463 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1464 okid->op_next = kid->op_next;
1465 kid->op_next = okid;
1468 okid->op_next = Nullop;
1469 okid->op_type = OP_RV2CV;
1471 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1472 okid->op_private |= OPpLVAL_INTRO;
1476 cv = GvCV(kGVOP_gv);
1486 /* grep, foreach, subcalls, refgen */
1487 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1489 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1490 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1492 : (o->op_type == OP_ENTERSUB
1493 ? "non-lvalue subroutine call"
1494 : PL_op_desc[o->op_type])),
1495 type ? PL_op_desc[type] : "local"));
1509 case OP_RIGHT_SHIFT:
1518 if (!(o->op_flags & OPf_STACKED))
1524 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1530 if (!type && cUNOPo->op_first->op_type != OP_GV)
1531 Perl_croak(aTHX_ "Can't localize through a reference");
1532 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1533 PL_modcount = RETURN_UNLIMITED_NUMBER;
1534 return o; /* Treat \(@foo) like ordinary list. */
1538 if (scalar_mod_type(o, type))
1540 ref(cUNOPo->op_first, o->op_type);
1544 if (type == OP_LEAVESUBLV)
1545 o->op_private |= OPpMAYBE_LVSUB;
1551 PL_modcount = RETURN_UNLIMITED_NUMBER;
1554 if (!type && cUNOPo->op_first->op_type != OP_GV)
1555 Perl_croak(aTHX_ "Can't localize through a reference");
1556 ref(cUNOPo->op_first, o->op_type);
1560 PL_hints |= HINT_BLOCK_SCOPE;
1570 PL_modcount = RETURN_UNLIMITED_NUMBER;
1571 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1572 return o; /* Treat \(@foo) like ordinary list. */
1573 if (scalar_mod_type(o, type))
1575 if (type == OP_LEAVESUBLV)
1576 o->op_private |= OPpMAYBE_LVSUB;
1581 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1582 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1587 PL_modcount++; /* XXX ??? */
1589 #endif /* USE_THREADS */
1595 if (type != OP_SASSIGN)
1599 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1604 if (type == OP_LEAVESUBLV)
1605 o->op_private |= OPpMAYBE_LVSUB;
1607 pad_free(o->op_targ);
1608 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1609 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1610 if (o->op_flags & OPf_KIDS)
1611 mod(cBINOPo->op_first->op_sibling, type);
1616 ref(cBINOPo->op_first, o->op_type);
1617 if (type == OP_ENTERSUB &&
1618 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1619 o->op_private |= OPpLVAL_DEFER;
1620 if (type == OP_LEAVESUBLV)
1621 o->op_private |= OPpMAYBE_LVSUB;
1629 if (o->op_flags & OPf_KIDS)
1630 mod(cLISTOPo->op_last, type);
1634 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1636 else if (!(o->op_flags & OPf_KIDS))
1638 if (o->op_targ != OP_LIST) {
1639 mod(cBINOPo->op_first, type);
1644 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1649 if (type != OP_LEAVESUBLV)
1651 break; /* mod()ing was handled by ck_return() */
1653 if (type != OP_LEAVESUBLV)
1654 o->op_flags |= OPf_MOD;
1656 if (type == OP_AASSIGN || type == OP_SASSIGN)
1657 o->op_flags |= OPf_SPECIAL|OPf_REF;
1659 o->op_private |= OPpLVAL_INTRO;
1660 o->op_flags &= ~OPf_SPECIAL;
1661 PL_hints |= HINT_BLOCK_SCOPE;
1663 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1664 && type != OP_LEAVESUBLV)
1665 o->op_flags |= OPf_REF;
1670 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1674 if (o->op_type == OP_RV2GV)
1698 case OP_RIGHT_SHIFT:
1717 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1719 switch (o->op_type) {
1727 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1740 Perl_refkids(pTHX_ OP *o, I32 type)
1743 if (o && o->op_flags & OPf_KIDS) {
1744 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1751 Perl_ref(pTHX_ OP *o, I32 type)
1755 if (!o || PL_error_count)
1758 switch (o->op_type) {
1760 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1761 !(o->op_flags & OPf_STACKED)) {
1762 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1763 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1764 assert(cUNOPo->op_first->op_type == OP_NULL);
1765 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1766 o->op_flags |= OPf_SPECIAL;
1771 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1775 if (type == OP_DEFINED)
1776 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1777 ref(cUNOPo->op_first, o->op_type);
1780 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1781 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1782 : type == OP_RV2HV ? OPpDEREF_HV
1784 o->op_flags |= OPf_MOD;
1789 o->op_flags |= OPf_MOD; /* XXX ??? */
1794 o->op_flags |= OPf_REF;
1797 if (type == OP_DEFINED)
1798 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1799 ref(cUNOPo->op_first, o->op_type);
1804 o->op_flags |= OPf_REF;
1809 if (!(o->op_flags & OPf_KIDS))
1811 ref(cBINOPo->op_first, type);
1815 ref(cBINOPo->op_first, o->op_type);
1816 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1817 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1818 : type == OP_RV2HV ? OPpDEREF_HV
1820 o->op_flags |= OPf_MOD;
1828 if (!(o->op_flags & OPf_KIDS))
1830 ref(cLISTOPo->op_last, type);
1840 S_dup_attrlist(pTHX_ OP *o)
1844 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1845 * where the first kid is OP_PUSHMARK and the remaining ones
1846 * are OP_CONST. We need to push the OP_CONST values.
1848 if (o->op_type == OP_CONST)
1849 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1851 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1852 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1853 if (o->op_type == OP_CONST)
1854 rop = append_elem(OP_LIST, rop,
1855 newSVOP(OP_CONST, o->op_flags,
1856 SvREFCNT_inc(cSVOPo->op_sv)));
1863 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1867 /* fake up C<use attributes $pkg,$rv,@attrs> */
1868 ENTER; /* need to protect against side-effects of 'use' */
1870 if (stash && HvNAME(stash))
1871 stashsv = newSVpv(HvNAME(stash), 0);
1873 stashsv = &PL_sv_no;
1875 #define ATTRSMODULE "attributes"
1877 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1878 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1880 prepend_elem(OP_LIST,
1881 newSVOP(OP_CONST, 0, stashsv),
1882 prepend_elem(OP_LIST,
1883 newSVOP(OP_CONST, 0,
1885 dup_attrlist(attrs))));
1890 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1891 char *attrstr, STRLEN len)
1896 len = strlen(attrstr);
1900 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1902 char *sstr = attrstr;
1903 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1904 attrs = append_elem(OP_LIST, attrs,
1905 newSVOP(OP_CONST, 0,
1906 newSVpvn(sstr, attrstr-sstr)));
1910 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1911 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1912 Nullsv, prepend_elem(OP_LIST,
1913 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1914 prepend_elem(OP_LIST,
1915 newSVOP(OP_CONST, 0,
1921 S_my_kid(pTHX_ OP *o, OP *attrs)
1926 if (!o || PL_error_count)
1930 if (type == OP_LIST) {
1931 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1933 } else if (type == OP_UNDEF) {
1935 } else if (type == OP_RV2SV || /* "our" declaration */
1937 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1939 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1941 PL_in_my_stash = Nullhv;
1942 apply_attrs(GvSTASH(gv),
1943 (type == OP_RV2SV ? GvSV(gv) :
1944 type == OP_RV2AV ? (SV*)GvAV(gv) :
1945 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1948 o->op_private |= OPpOUR_INTRO;
1950 } else if (type != OP_PADSV &&
1953 type != OP_PUSHMARK)
1955 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1956 PL_op_desc[o->op_type],
1957 PL_in_my == KEY_our ? "our" : "my"));
1960 else if (attrs && type != OP_PUSHMARK) {
1966 PL_in_my_stash = Nullhv;
1968 /* check for C<my Dog $spot> when deciding package */
1969 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1970 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED)
1971 && HvNAME(SvSTASH(*namesvp)))
1972 stash = SvSTASH(*namesvp);
1974 stash = PL_curstash;
1975 padsv = PAD_SV(o->op_targ);
1976 apply_attrs(stash, padsv, attrs);
1978 o->op_flags |= OPf_MOD;
1979 o->op_private |= OPpLVAL_INTRO;
1984 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1986 if (o->op_flags & OPf_PARENS)
1990 o = my_kid(o, attrs);
1992 PL_in_my_stash = Nullhv;
1997 Perl_my(pTHX_ OP *o)
1999 return my_kid(o, Nullop);
2003 Perl_sawparens(pTHX_ OP *o)
2006 o->op_flags |= OPf_PARENS;
2011 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2015 if (ckWARN(WARN_MISC) &&
2016 (left->op_type == OP_RV2AV ||
2017 left->op_type == OP_RV2HV ||
2018 left->op_type == OP_PADAV ||
2019 left->op_type == OP_PADHV)) {
2020 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2021 right->op_type == OP_TRANS)
2022 ? right->op_type : OP_MATCH];
2023 const char *sample = ((left->op_type == OP_RV2AV ||
2024 left->op_type == OP_PADAV)
2025 ? "@array" : "%hash");
2026 Perl_warner(aTHX_ WARN_MISC,
2027 "Applying %s to %s will act on scalar(%s)",
2028 desc, sample, sample);
2031 if (!(right->op_flags & OPf_STACKED) &&
2032 (right->op_type == OP_MATCH ||
2033 right->op_type == OP_SUBST ||
2034 right->op_type == OP_TRANS)) {
2035 right->op_flags |= OPf_STACKED;
2036 if (right->op_type != OP_MATCH &&
2037 ! (right->op_type == OP_TRANS &&
2038 right->op_private & OPpTRANS_IDENTICAL))
2039 left = mod(left, right->op_type);
2040 if (right->op_type == OP_TRANS)
2041 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2043 o = prepend_elem(right->op_type, scalar(left), right);
2045 return newUNOP(OP_NOT, 0, scalar(o));
2049 return bind_match(type, left,
2050 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2054 Perl_invert(pTHX_ OP *o)
2058 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2059 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2063 Perl_scope(pTHX_ OP *o)
2066 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2067 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2068 o->op_type = OP_LEAVE;
2069 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2072 if (o->op_type == OP_LINESEQ) {
2074 o->op_type = OP_SCOPE;
2075 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2076 kid = ((LISTOP*)o)->op_first;
2077 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2081 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2088 Perl_save_hints(pTHX)
2091 SAVESPTR(GvHV(PL_hintgv));
2092 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2093 SAVEFREESV(GvHV(PL_hintgv));
2097 Perl_block_start(pTHX_ int full)
2099 int retval = PL_savestack_ix;
2101 SAVEI32(PL_comppad_name_floor);
2102 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2104 PL_comppad_name_fill = PL_comppad_name_floor;
2105 if (PL_comppad_name_floor < 0)
2106 PL_comppad_name_floor = 0;
2107 SAVEI32(PL_min_intro_pending);
2108 SAVEI32(PL_max_intro_pending);
2109 PL_min_intro_pending = 0;
2110 SAVEI32(PL_comppad_name_fill);
2111 SAVEI32(PL_padix_floor);
2112 PL_padix_floor = PL_padix;
2113 PL_pad_reset_pending = FALSE;
2115 PL_hints &= ~HINT_BLOCK_SCOPE;
2116 SAVESPTR(PL_compiling.cop_warnings);
2117 if (! specialWARN(PL_compiling.cop_warnings)) {
2118 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2119 SAVEFREESV(PL_compiling.cop_warnings) ;
2121 SAVESPTR(PL_compiling.cop_io);
2122 if (! specialCopIO(PL_compiling.cop_io)) {
2123 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2124 SAVEFREESV(PL_compiling.cop_io) ;
2130 Perl_block_end(pTHX_ I32 floor, OP *seq)
2132 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2133 OP* retval = scalarseq(seq);
2135 PL_pad_reset_pending = FALSE;
2136 PL_compiling.op_private = PL_hints;
2138 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2139 pad_leavemy(PL_comppad_name_fill);
2148 OP *o = newOP(OP_THREADSV, 0);
2149 o->op_targ = find_threadsv("_");
2152 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2153 #endif /* USE_THREADS */
2157 Perl_newPROG(pTHX_ OP *o)
2162 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2163 ((PL_in_eval & EVAL_KEEPERR)
2164 ? OPf_SPECIAL : 0), o);
2165 PL_eval_start = linklist(PL_eval_root);
2166 PL_eval_root->op_private |= OPpREFCOUNTED;
2167 OpREFCNT_set(PL_eval_root, 1);
2168 PL_eval_root->op_next = 0;
2169 peep(PL_eval_start);
2174 PL_main_root = scope(sawparens(scalarvoid(o)));
2175 PL_curcop = &PL_compiling;
2176 PL_main_start = LINKLIST(PL_main_root);
2177 PL_main_root->op_private |= OPpREFCOUNTED;
2178 OpREFCNT_set(PL_main_root, 1);
2179 PL_main_root->op_next = 0;
2180 peep(PL_main_start);
2183 /* Register with debugger */
2185 CV *cv = get_cv("DB::postponed", FALSE);
2189 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2191 call_sv((SV*)cv, G_DISCARD);
2198 Perl_localize(pTHX_ OP *o, I32 lex)
2200 if (o->op_flags & OPf_PARENS)
2203 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2205 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2206 if (*s == ';' || *s == '=')
2207 Perl_warner(aTHX_ WARN_PARENTHESIS,
2208 "Parentheses missing around \"%s\" list",
2209 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2215 o = mod(o, OP_NULL); /* a bit kludgey */
2217 PL_in_my_stash = Nullhv;
2222 Perl_jmaybe(pTHX_ OP *o)
2224 if (o->op_type == OP_LIST) {
2227 o2 = newOP(OP_THREADSV, 0);
2228 o2->op_targ = find_threadsv(";");
2230 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2231 #endif /* USE_THREADS */
2232 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2238 Perl_fold_constants(pTHX_ register OP *o)
2241 I32 type = o->op_type;
2244 if (PL_opargs[type] & OA_RETSCALAR)
2246 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2247 o->op_targ = pad_alloc(type, SVs_PADTMP);
2249 /* integerize op, unless it happens to be C<-foo>.
2250 * XXX should pp_i_negate() do magic string negation instead? */
2251 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2252 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2253 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2255 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2258 if (!(PL_opargs[type] & OA_FOLDCONST))
2263 /* XXX might want a ck_negate() for this */
2264 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2276 /* XXX what about the numeric ops? */
2277 if (PL_hints & HINT_LOCALE)
2282 goto nope; /* Don't try to run w/ errors */
2284 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2285 if ((curop->op_type != OP_CONST ||
2286 (curop->op_private & OPpCONST_BARE)) &&
2287 curop->op_type != OP_LIST &&
2288 curop->op_type != OP_SCALAR &&
2289 curop->op_type != OP_NULL &&
2290 curop->op_type != OP_PUSHMARK)
2296 curop = LINKLIST(o);
2300 sv = *(PL_stack_sp--);
2301 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2302 pad_swipe(o->op_targ);
2303 else if (SvTEMP(sv)) { /* grab mortal temp? */
2304 (void)SvREFCNT_inc(sv);
2308 if (type == OP_RV2GV)
2309 return newGVOP(OP_GV, 0, (GV*)sv);
2311 /* try to smush double to int, but don't smush -2.0 to -2 */
2312 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2315 #ifdef PERL_PRESERVE_IVUV
2316 /* Only bother to attempt to fold to IV if
2317 most operators will benefit */
2321 return newSVOP(OP_CONST, 0, sv);
2325 if (!(PL_opargs[type] & OA_OTHERINT))
2328 if (!(PL_hints & HINT_INTEGER)) {
2329 if (type == OP_MODULO
2330 || type == OP_DIVIDE
2331 || !(o->op_flags & OPf_KIDS))
2336 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2337 if (curop->op_type == OP_CONST) {
2338 if (SvIOK(((SVOP*)curop)->op_sv))
2342 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2346 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2353 Perl_gen_constant_list(pTHX_ register OP *o)
2356 I32 oldtmps_floor = PL_tmps_floor;
2360 return o; /* Don't attempt to run with errors */
2362 PL_op = curop = LINKLIST(o);
2369 PL_tmps_floor = oldtmps_floor;
2371 o->op_type = OP_RV2AV;
2372 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2373 curop = ((UNOP*)o)->op_first;
2374 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2381 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2383 if (!o || o->op_type != OP_LIST)
2384 o = newLISTOP(OP_LIST, 0, o, Nullop);
2386 o->op_flags &= ~OPf_WANT;
2388 if (!(PL_opargs[type] & OA_MARK))
2389 op_null(cLISTOPo->op_first);
2392 o->op_ppaddr = PL_ppaddr[type];
2393 o->op_flags |= flags;
2395 o = CHECKOP(type, o);
2396 if (o->op_type != type)
2399 return fold_constants(o);
2402 /* List constructors */
2405 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2413 if (first->op_type != type
2414 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2416 return newLISTOP(type, 0, first, last);
2419 if (first->op_flags & OPf_KIDS)
2420 ((LISTOP*)first)->op_last->op_sibling = last;
2422 first->op_flags |= OPf_KIDS;
2423 ((LISTOP*)first)->op_first = last;
2425 ((LISTOP*)first)->op_last = last;
2430 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2438 if (first->op_type != type)
2439 return prepend_elem(type, (OP*)first, (OP*)last);
2441 if (last->op_type != type)
2442 return append_elem(type, (OP*)first, (OP*)last);
2444 first->op_last->op_sibling = last->op_first;
2445 first->op_last = last->op_last;
2446 first->op_flags |= (last->op_flags & OPf_KIDS);
2448 #ifdef PL_OP_SLAB_ALLOC
2456 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2464 if (last->op_type == type) {
2465 if (type == OP_LIST) { /* already a PUSHMARK there */
2466 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2467 ((LISTOP*)last)->op_first->op_sibling = first;
2468 if (!(first->op_flags & OPf_PARENS))
2469 last->op_flags &= ~OPf_PARENS;
2472 if (!(last->op_flags & OPf_KIDS)) {
2473 ((LISTOP*)last)->op_last = first;
2474 last->op_flags |= OPf_KIDS;
2476 first->op_sibling = ((LISTOP*)last)->op_first;
2477 ((LISTOP*)last)->op_first = first;
2479 last->op_flags |= OPf_KIDS;
2483 return newLISTOP(type, 0, first, last);
2489 Perl_newNULLLIST(pTHX)
2491 return newOP(OP_STUB, 0);
2495 Perl_force_list(pTHX_ OP *o)
2497 if (!o || o->op_type != OP_LIST)
2498 o = newLISTOP(OP_LIST, 0, o, Nullop);
2504 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2508 NewOp(1101, listop, 1, LISTOP);
2510 listop->op_type = type;
2511 listop->op_ppaddr = PL_ppaddr[type];
2514 listop->op_flags = flags;
2518 else if (!first && last)
2521 first->op_sibling = last;
2522 listop->op_first = first;
2523 listop->op_last = last;
2524 if (type == OP_LIST) {
2526 pushop = newOP(OP_PUSHMARK, 0);
2527 pushop->op_sibling = first;
2528 listop->op_first = pushop;
2529 listop->op_flags |= OPf_KIDS;
2531 listop->op_last = pushop;
2538 Perl_newOP(pTHX_ I32 type, I32 flags)
2541 NewOp(1101, o, 1, OP);
2543 o->op_ppaddr = PL_ppaddr[type];
2544 o->op_flags = flags;
2547 o->op_private = 0 + (flags >> 8);
2548 if (PL_opargs[type] & OA_RETSCALAR)
2550 if (PL_opargs[type] & OA_TARGET)
2551 o->op_targ = pad_alloc(type, SVs_PADTMP);
2552 return CHECKOP(type, o);
2556 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2561 first = newOP(OP_STUB, 0);
2562 if (PL_opargs[type] & OA_MARK)
2563 first = force_list(first);
2565 NewOp(1101, unop, 1, UNOP);
2566 unop->op_type = type;
2567 unop->op_ppaddr = PL_ppaddr[type];
2568 unop->op_first = first;
2569 unop->op_flags = flags | OPf_KIDS;
2570 unop->op_private = 1 | (flags >> 8);
2571 unop = (UNOP*) CHECKOP(type, unop);
2575 return fold_constants((OP *) unop);
2579 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2582 NewOp(1101, binop, 1, BINOP);
2585 first = newOP(OP_NULL, 0);
2587 binop->op_type = type;
2588 binop->op_ppaddr = PL_ppaddr[type];
2589 binop->op_first = first;
2590 binop->op_flags = flags | OPf_KIDS;
2593 binop->op_private = 1 | (flags >> 8);
2596 binop->op_private = 2 | (flags >> 8);
2597 first->op_sibling = last;
2600 binop = (BINOP*)CHECKOP(type, binop);
2601 if (binop->op_next || binop->op_type != type)
2604 binop->op_last = binop->op_first->op_sibling;
2606 return fold_constants((OP *)binop);
2610 uvcompare(const void *a, const void *b)
2612 if (*((UV *)a) < (*(UV *)b))
2614 if (*((UV *)a) > (*(UV *)b))
2616 if (*((UV *)a+1) < (*(UV *)b+1))
2618 if (*((UV *)a+1) > (*(UV *)b+1))
2624 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2626 SV *tstr = ((SVOP*)expr)->op_sv;
2627 SV *rstr = ((SVOP*)repl)->op_sv;
2630 U8 *t = (U8*)SvPV(tstr, tlen);
2631 U8 *r = (U8*)SvPV(rstr, rlen);
2638 register short *tbl;
2640 PL_hints |= HINT_BLOCK_SCOPE;
2641 complement = o->op_private & OPpTRANS_COMPLEMENT;
2642 del = o->op_private & OPpTRANS_DELETE;
2643 squash = o->op_private & OPpTRANS_SQUASH;
2646 o->op_private |= OPpTRANS_FROM_UTF;
2649 o->op_private |= OPpTRANS_TO_UTF;
2651 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2652 SV* listsv = newSVpvn("# comment\n",10);
2654 U8* tend = t + tlen;
2655 U8* rend = r + rlen;
2669 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2670 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2676 tsave = t = bytes_to_utf8(t, &len);
2679 if (!to_utf && rlen) {
2681 rsave = r = bytes_to_utf8(r, &len);
2685 /* There are several snags with this code on EBCDIC:
2686 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2687 2. scan_const() in toke.c has encoded chars in native encoding which makes
2688 ranges at least in EBCDIC 0..255 range the bottom odd.
2692 U8 tmpbuf[UTF8_MAXLEN+1];
2695 New(1109, cp, 2*tlen, UV);
2697 transv = newSVpvn("",0);
2699 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2701 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2703 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2707 cp[2*i+1] = cp[2*i];
2711 qsort(cp, i, 2*sizeof(UV), uvcompare);
2712 for (j = 0; j < i; j++) {
2714 diff = val - nextmin;
2716 t = uvuni_to_utf8(tmpbuf,nextmin);
2717 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2719 U8 range_mark = UTF_TO_NATIVE(0xff);
2720 t = uvuni_to_utf8(tmpbuf, val - 1);
2721 sv_catpvn(transv, (char *)&range_mark, 1);
2722 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2729 t = uvuni_to_utf8(tmpbuf,nextmin);
2730 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2732 U8 range_mark = UTF_TO_NATIVE(0xff);
2733 sv_catpvn(transv, (char *)&range_mark, 1);
2735 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2736 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2737 t = (U8*)SvPVX(transv);
2738 tlen = SvCUR(transv);
2742 else if (!rlen && !del) {
2743 r = t; rlen = tlen; rend = tend;
2746 if ((!rlen && !del) || t == r ||
2747 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2749 o->op_private |= OPpTRANS_IDENTICAL;
2753 while (t < tend || tfirst <= tlast) {
2754 /* see if we need more "t" chars */
2755 if (tfirst > tlast) {
2756 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2758 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2760 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2767 /* now see if we need more "r" chars */
2768 if (rfirst > rlast) {
2770 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2772 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2774 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2783 rfirst = rlast = 0xffffffff;
2787 /* now see which range will peter our first, if either. */
2788 tdiff = tlast - tfirst;
2789 rdiff = rlast - rfirst;
2796 if (rfirst == 0xffffffff) {
2797 diff = tdiff; /* oops, pretend rdiff is infinite */
2799 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2800 (long)tfirst, (long)tlast);
2802 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2806 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2807 (long)tfirst, (long)(tfirst + diff),
2810 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2811 (long)tfirst, (long)rfirst);
2813 if (rfirst + diff > max)
2814 max = rfirst + diff;
2816 grows = (tfirst < rfirst &&
2817 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2829 else if (max > 0xff)
2834 Safefree(cPVOPo->op_pv);
2835 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2836 SvREFCNT_dec(listsv);
2838 SvREFCNT_dec(transv);
2840 if (!del && havefinal && rlen)
2841 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2842 newSVuv((UV)final), 0);
2845 o->op_private |= OPpTRANS_GROWS;
2857 tbl = (short*)cPVOPo->op_pv;
2859 Zero(tbl, 256, short);
2860 for (i = 0; i < tlen; i++)
2862 for (i = 0, j = 0; i < 256; i++) {
2873 if (i < 128 && r[j] >= 128)
2883 o->op_private |= OPpTRANS_IDENTICAL;
2888 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2889 tbl[0x100] = rlen - j;
2890 for (i=0; i < rlen - j; i++)
2891 tbl[0x101+i] = r[j+i];
2895 if (!rlen && !del) {
2898 o->op_private |= OPpTRANS_IDENTICAL;
2900 for (i = 0; i < 256; i++)
2902 for (i = 0, j = 0; i < tlen; i++,j++) {
2905 if (tbl[t[i]] == -1)
2911 if (tbl[t[i]] == -1) {
2912 if (t[i] < 128 && r[j] >= 128)
2919 o->op_private |= OPpTRANS_GROWS;
2927 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2931 NewOp(1101, pmop, 1, PMOP);
2932 pmop->op_type = type;
2933 pmop->op_ppaddr = PL_ppaddr[type];
2934 pmop->op_flags = flags;
2935 pmop->op_private = 0 | (flags >> 8);
2937 if (PL_hints & HINT_RE_TAINT)
2938 pmop->op_pmpermflags |= PMf_RETAINT;
2939 if (PL_hints & HINT_LOCALE)
2940 pmop->op_pmpermflags |= PMf_LOCALE;
2941 pmop->op_pmflags = pmop->op_pmpermflags;
2943 /* link into pm list */
2944 if (type != OP_TRANS && PL_curstash) {
2945 pmop->op_pmnext = HvPMROOT(PL_curstash);
2946 HvPMROOT(PL_curstash) = pmop;
2947 PmopSTASH_set(pmop,PL_curstash);
2954 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2958 I32 repl_has_vars = 0;
2960 if (o->op_type == OP_TRANS)
2961 return pmtrans(o, expr, repl);
2963 PL_hints |= HINT_BLOCK_SCOPE;
2966 if (expr->op_type == OP_CONST) {
2968 SV *pat = ((SVOP*)expr)->op_sv;
2969 char *p = SvPV(pat, plen);
2970 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2971 sv_setpvn(pat, "\\s+", 3);
2972 p = SvPV(pat, plen);
2973 pm->op_pmflags |= PMf_SKIPWHITE;
2975 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2976 pm->op_pmdynflags |= PMdf_UTF8;
2977 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2978 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2979 pm->op_pmflags |= PMf_WHITE;
2983 if (PL_hints & HINT_UTF8)
2984 pm->op_pmdynflags |= PMdf_UTF8;
2985 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2986 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2988 : OP_REGCMAYBE),0,expr);
2990 NewOp(1101, rcop, 1, LOGOP);
2991 rcop->op_type = OP_REGCOMP;
2992 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2993 rcop->op_first = scalar(expr);
2994 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2995 ? (OPf_SPECIAL | OPf_KIDS)
2997 rcop->op_private = 1;
3000 /* establish postfix order */
3001 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3003 rcop->op_next = expr;
3004 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3007 rcop->op_next = LINKLIST(expr);
3008 expr->op_next = (OP*)rcop;
3011 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3016 if (pm->op_pmflags & PMf_EVAL) {
3018 if (CopLINE(PL_curcop) < PL_multi_end)
3019 CopLINE_set(PL_curcop, PL_multi_end);
3022 else if (repl->op_type == OP_THREADSV
3023 && strchr("&`'123456789+",
3024 PL_threadsv_names[repl->op_targ]))
3028 #endif /* USE_THREADS */
3029 else if (repl->op_type == OP_CONST)
3033 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3034 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3036 if (curop->op_type == OP_THREADSV) {
3038 if (strchr("&`'123456789+", curop->op_private))
3042 if (curop->op_type == OP_GV) {
3043 GV *gv = cGVOPx_gv(curop);
3045 if (strchr("&`'123456789+", *GvENAME(gv)))
3048 #endif /* USE_THREADS */
3049 else if (curop->op_type == OP_RV2CV)
3051 else if (curop->op_type == OP_RV2SV ||
3052 curop->op_type == OP_RV2AV ||
3053 curop->op_type == OP_RV2HV ||
3054 curop->op_type == OP_RV2GV) {
3055 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3058 else if (curop->op_type == OP_PADSV ||
3059 curop->op_type == OP_PADAV ||
3060 curop->op_type == OP_PADHV ||
3061 curop->op_type == OP_PADANY) {
3064 else if (curop->op_type == OP_PUSHRE)
3065 ; /* Okay here, dangerous in newASSIGNOP */
3074 && (!pm->op_pmregexp
3075 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3076 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3077 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3078 prepend_elem(o->op_type, scalar(repl), o);
3081 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3082 pm->op_pmflags |= PMf_MAYBE_CONST;
3083 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3085 NewOp(1101, rcop, 1, LOGOP);
3086 rcop->op_type = OP_SUBSTCONT;
3087 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3088 rcop->op_first = scalar(repl);
3089 rcop->op_flags |= OPf_KIDS;
3090 rcop->op_private = 1;
3093 /* establish postfix order */
3094 rcop->op_next = LINKLIST(repl);
3095 repl->op_next = (OP*)rcop;
3097 pm->op_pmreplroot = scalar((OP*)rcop);
3098 pm->op_pmreplstart = LINKLIST(rcop);
3107 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3110 NewOp(1101, svop, 1, SVOP);
3111 svop->op_type = type;
3112 svop->op_ppaddr = PL_ppaddr[type];
3114 svop->op_next = (OP*)svop;
3115 svop->op_flags = flags;
3116 if (PL_opargs[type] & OA_RETSCALAR)
3118 if (PL_opargs[type] & OA_TARGET)
3119 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3120 return CHECKOP(type, svop);
3124 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3127 NewOp(1101, padop, 1, PADOP);
3128 padop->op_type = type;
3129 padop->op_ppaddr = PL_ppaddr[type];
3130 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3131 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3132 PL_curpad[padop->op_padix] = sv;
3134 padop->op_next = (OP*)padop;
3135 padop->op_flags = flags;
3136 if (PL_opargs[type] & OA_RETSCALAR)
3138 if (PL_opargs[type] & OA_TARGET)
3139 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3140 return CHECKOP(type, padop);
3144 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3148 return newPADOP(type, flags, SvREFCNT_inc(gv));
3150 return newSVOP(type, flags, SvREFCNT_inc(gv));
3155 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3158 NewOp(1101, pvop, 1, PVOP);
3159 pvop->op_type = type;
3160 pvop->op_ppaddr = PL_ppaddr[type];
3162 pvop->op_next = (OP*)pvop;
3163 pvop->op_flags = flags;
3164 if (PL_opargs[type] & OA_RETSCALAR)
3166 if (PL_opargs[type] & OA_TARGET)
3167 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3168 return CHECKOP(type, pvop);
3172 Perl_package(pTHX_ OP *o)
3176 save_hptr(&PL_curstash);
3177 save_item(PL_curstname);
3182 name = SvPV(sv, len);
3183 PL_curstash = gv_stashpvn(name,len,TRUE);
3184 sv_setpvn(PL_curstname, name, len);
3188 sv_setpv(PL_curstname,"<none>");
3189 PL_curstash = Nullhv;
3191 PL_hints |= HINT_BLOCK_SCOPE;
3192 PL_copline = NOLINE;
3197 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3203 if (id->op_type != OP_CONST)
3204 Perl_croak(aTHX_ "Module name must be constant");
3208 if (version != Nullop) {
3209 SV *vesv = ((SVOP*)version)->op_sv;
3211 if (arg == Nullop && !SvNIOKp(vesv)) {
3218 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3219 Perl_croak(aTHX_ "Version number must be constant number");
3221 /* Make copy of id so we don't free it twice */
3222 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3224 /* Fake up a method call to VERSION */
3225 meth = newSVpvn("VERSION",7);
3226 sv_upgrade(meth, SVt_PVIV);
3227 (void)SvIOK_on(meth);
3228 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3229 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3230 append_elem(OP_LIST,
3231 prepend_elem(OP_LIST, pack, list(version)),
3232 newSVOP(OP_METHOD_NAMED, 0, meth)));
3236 /* Fake up an import/unimport */
3237 if (arg && arg->op_type == OP_STUB)
3238 imop = arg; /* no import on explicit () */
3239 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3240 imop = Nullop; /* use 5.0; */
3245 /* Make copy of id so we don't free it twice */
3246 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3248 /* Fake up a method call to import/unimport */
3249 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3250 sv_upgrade(meth, SVt_PVIV);
3251 (void)SvIOK_on(meth);
3252 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3253 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3254 append_elem(OP_LIST,
3255 prepend_elem(OP_LIST, pack, list(arg)),
3256 newSVOP(OP_METHOD_NAMED, 0, meth)));
3259 /* Fake up the BEGIN {}, which does its thing immediately. */
3261 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3264 append_elem(OP_LINESEQ,
3265 append_elem(OP_LINESEQ,
3266 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3267 newSTATEOP(0, Nullch, veop)),
3268 newSTATEOP(0, Nullch, imop) ));
3270 PL_hints |= HINT_BLOCK_SCOPE;
3271 PL_copline = NOLINE;
3276 =for apidoc load_module
3278 Loads the module whose name is pointed to by the string part of name.
3279 Note that the actual module name, not its filename, should be given.
3280 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3281 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3282 (or 0 for no flags). ver, if specified, provides version semantics
3283 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3284 arguments can be used to specify arguments to the module's import()
3285 method, similar to C<use Foo::Bar VERSION LIST>.
3290 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3293 va_start(args, ver);
3294 vload_module(flags, name, ver, &args);
3298 #ifdef PERL_IMPLICIT_CONTEXT
3300 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3304 va_start(args, ver);
3305 vload_module(flags, name, ver, &args);
3311 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3313 OP *modname, *veop, *imop;
3315 modname = newSVOP(OP_CONST, 0, name);
3316 modname->op_private |= OPpCONST_BARE;
3318 veop = newSVOP(OP_CONST, 0, ver);
3322 if (flags & PERL_LOADMOD_NOIMPORT) {
3323 imop = sawparens(newNULLLIST());
3325 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3326 imop = va_arg(*args, OP*);
3331 sv = va_arg(*args, SV*);
3333 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3334 sv = va_arg(*args, SV*);
3338 line_t ocopline = PL_copline;
3339 int oexpect = PL_expect;
3341 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3342 veop, modname, imop);
3343 PL_expect = oexpect;
3344 PL_copline = ocopline;
3349 Perl_dofile(pTHX_ OP *term)
3354 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3355 if (!(gv && GvIMPORTED_CV(gv)))
3356 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3358 if (gv && GvIMPORTED_CV(gv)) {
3359 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3360 append_elem(OP_LIST, term,
3361 scalar(newUNOP(OP_RV2CV, 0,
3366 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3372 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3374 return newBINOP(OP_LSLICE, flags,
3375 list(force_list(subscript)),
3376 list(force_list(listval)) );
3380 S_list_assignment(pTHX_ register OP *o)
3385 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3386 o = cUNOPo->op_first;
3388 if (o->op_type == OP_COND_EXPR) {
3389 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3390 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3395 yyerror("Assignment to both a list and a scalar");
3399 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3400 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3401 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3404 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3407 if (o->op_type == OP_RV2SV)
3414 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3419 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3420 return newLOGOP(optype, 0,
3421 mod(scalar(left), optype),
3422 newUNOP(OP_SASSIGN, 0, scalar(right)));
3425 return newBINOP(optype, OPf_STACKED,
3426 mod(scalar(left), optype), scalar(right));
3430 if (list_assignment(left)) {
3434 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3435 left = mod(left, OP_AASSIGN);
3443 curop = list(force_list(left));
3444 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3445 o->op_private = 0 | (flags >> 8);
3446 for (curop = ((LISTOP*)curop)->op_first;
3447 curop; curop = curop->op_sibling)
3449 if (curop->op_type == OP_RV2HV &&
3450 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3451 o->op_private |= OPpASSIGN_HASH;
3455 if (!(left->op_private & OPpLVAL_INTRO)) {
3458 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3459 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3460 if (curop->op_type == OP_GV) {
3461 GV *gv = cGVOPx_gv(curop);
3462 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3464 SvCUR(gv) = PL_generation;
3466 else if (curop->op_type == OP_PADSV ||
3467 curop->op_type == OP_PADAV ||
3468 curop->op_type == OP_PADHV ||
3469 curop->op_type == OP_PADANY) {
3470 SV **svp = AvARRAY(PL_comppad_name);
3471 SV *sv = svp[curop->op_targ];
3472 if (SvCUR(sv) == PL_generation)
3474 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3476 else if (curop->op_type == OP_RV2CV)
3478 else if (curop->op_type == OP_RV2SV ||
3479 curop->op_type == OP_RV2AV ||
3480 curop->op_type == OP_RV2HV ||
3481 curop->op_type == OP_RV2GV) {
3482 if (lastop->op_type != OP_GV) /* funny deref? */
3485 else if (curop->op_type == OP_PUSHRE) {
3486 if (((PMOP*)curop)->op_pmreplroot) {
3488 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3490 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3492 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3494 SvCUR(gv) = PL_generation;
3503 o->op_private |= OPpASSIGN_COMMON;
3505 if (right && right->op_type == OP_SPLIT) {
3507 if ((tmpop = ((LISTOP*)right)->op_first) &&
3508 tmpop->op_type == OP_PUSHRE)
3510 PMOP *pm = (PMOP*)tmpop;
3511 if (left->op_type == OP_RV2AV &&
3512 !(left->op_private & OPpLVAL_INTRO) &&
3513 !(o->op_private & OPpASSIGN_COMMON) )
3515 tmpop = ((UNOP*)left)->op_first;
3516 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3518 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3519 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3521 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3522 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3524 pm->op_pmflags |= PMf_ONCE;
3525 tmpop = cUNOPo->op_first; /* to list (nulled) */
3526 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3527 tmpop->op_sibling = Nullop; /* don't free split */
3528 right->op_next = tmpop->op_next; /* fix starting loc */
3529 op_free(o); /* blow off assign */
3530 right->op_flags &= ~OPf_WANT;
3531 /* "I don't know and I don't care." */
3536 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3537 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3539 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3541 sv_setiv(sv, PL_modcount+1);
3549 right = newOP(OP_UNDEF, 0);
3550 if (right->op_type == OP_READLINE) {
3551 right->op_flags |= OPf_STACKED;
3552 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3555 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3556 o = newBINOP(OP_SASSIGN, flags,
3557 scalar(right), mod(scalar(left), OP_SASSIGN) );
3569 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3571 U32 seq = intro_my();
3574 NewOp(1101, cop, 1, COP);
3575 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3576 cop->op_type = OP_DBSTATE;
3577 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3580 cop->op_type = OP_NEXTSTATE;
3581 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3583 cop->op_flags = flags;
3584 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3586 cop->op_private |= NATIVE_HINTS;
3588 PL_compiling.op_private = cop->op_private;
3589 cop->op_next = (OP*)cop;
3592 cop->cop_label = label;
3593 PL_hints |= HINT_BLOCK_SCOPE;
3596 cop->cop_arybase = PL_curcop->cop_arybase;
3597 if (specialWARN(PL_curcop->cop_warnings))
3598 cop->cop_warnings = PL_curcop->cop_warnings ;
3600 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3601 if (specialCopIO(PL_curcop->cop_io))
3602 cop->cop_io = PL_curcop->cop_io;
3604 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3607 if (PL_copline == NOLINE)
3608 CopLINE_set(cop, CopLINE(PL_curcop));
3610 CopLINE_set(cop, PL_copline);
3611 PL_copline = NOLINE;
3614 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3616 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3618 CopSTASH_set(cop, PL_curstash);
3620 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3621 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3622 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3623 (void)SvIOK_on(*svp);
3624 SvIVX(*svp) = PTR2IV(cop);
3628 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3631 /* "Introduce" my variables to visible status. */
3639 if (! PL_min_intro_pending)
3640 return PL_cop_seqmax;
3642 svp = AvARRAY(PL_comppad_name);
3643 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3644 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3645 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3646 SvNVX(sv) = (NV)PL_cop_seqmax;
3649 PL_min_intro_pending = 0;
3650 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3651 return PL_cop_seqmax++;
3655 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3657 return new_logop(type, flags, &first, &other);
3661 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3665 OP *first = *firstp;
3666 OP *other = *otherp;
3668 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3669 return newBINOP(type, flags, scalar(first), scalar(other));
3671 scalarboolean(first);
3672 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3673 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3674 if (type == OP_AND || type == OP_OR) {
3680 first = *firstp = cUNOPo->op_first;
3682 first->op_next = o->op_next;
3683 cUNOPo->op_first = Nullop;
3687 if (first->op_type == OP_CONST) {
3688 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3689 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3690 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3701 else if (first->op_type == OP_WANTARRAY) {
3707 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3708 OP *k1 = ((UNOP*)first)->op_first;
3709 OP *k2 = k1->op_sibling;
3711 switch (first->op_type)
3714 if (k2 && k2->op_type == OP_READLINE
3715 && (k2->op_flags & OPf_STACKED)
3716 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3718 warnop = k2->op_type;
3723 if (k1->op_type == OP_READDIR
3724 || k1->op_type == OP_GLOB
3725 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3726 || k1->op_type == OP_EACH)
3728 warnop = ((k1->op_type == OP_NULL)
3729 ? k1->op_targ : k1->op_type);
3734 line_t oldline = CopLINE(PL_curcop);
3735 CopLINE_set(PL_curcop, PL_copline);
3736 Perl_warner(aTHX_ WARN_MISC,
3737 "Value of %s%s can be \"0\"; test with defined()",
3739 ((warnop == OP_READLINE || warnop == OP_GLOB)
3740 ? " construct" : "() operator"));
3741 CopLINE_set(PL_curcop, oldline);
3748 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3749 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3751 NewOp(1101, logop, 1, LOGOP);
3753 logop->op_type = type;
3754 logop->op_ppaddr = PL_ppaddr[type];
3755 logop->op_first = first;
3756 logop->op_flags = flags | OPf_KIDS;
3757 logop->op_other = LINKLIST(other);
3758 logop->op_private = 1 | (flags >> 8);
3760 /* establish postfix order */
3761 logop->op_next = LINKLIST(first);
3762 first->op_next = (OP*)logop;
3763 first->op_sibling = other;
3765 o = newUNOP(OP_NULL, 0, (OP*)logop);
3772 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3779 return newLOGOP(OP_AND, 0, first, trueop);
3781 return newLOGOP(OP_OR, 0, first, falseop);
3783 scalarboolean(first);
3784 if (first->op_type == OP_CONST) {
3785 if (SvTRUE(((SVOP*)first)->op_sv)) {
3796 else if (first->op_type == OP_WANTARRAY) {
3800 NewOp(1101, logop, 1, LOGOP);
3801 logop->op_type = OP_COND_EXPR;
3802 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3803 logop->op_first = first;
3804 logop->op_flags = flags | OPf_KIDS;
3805 logop->op_private = 1 | (flags >> 8);
3806 logop->op_other = LINKLIST(trueop);
3807 logop->op_next = LINKLIST(falseop);
3810 /* establish postfix order */
3811 start = LINKLIST(first);
3812 first->op_next = (OP*)logop;
3814 first->op_sibling = trueop;
3815 trueop->op_sibling = falseop;
3816 o = newUNOP(OP_NULL, 0, (OP*)logop);
3818 trueop->op_next = falseop->op_next = o;
3825 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3833 NewOp(1101, range, 1, LOGOP);
3835 range->op_type = OP_RANGE;
3836 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3837 range->op_first = left;
3838 range->op_flags = OPf_KIDS;
3839 leftstart = LINKLIST(left);
3840 range->op_other = LINKLIST(right);
3841 range->op_private = 1 | (flags >> 8);
3843 left->op_sibling = right;
3845 range->op_next = (OP*)range;
3846 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3847 flop = newUNOP(OP_FLOP, 0, flip);
3848 o = newUNOP(OP_NULL, 0, flop);
3850 range->op_next = leftstart;
3852 left->op_next = flip;
3853 right->op_next = flop;
3855 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3856 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3857 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3858 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3860 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3861 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3864 if (!flip->op_private || !flop->op_private)
3865 linklist(o); /* blow off optimizer unless constant */
3871 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3875 int once = block && block->op_flags & OPf_SPECIAL &&
3876 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3879 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3880 return block; /* do {} while 0 does once */
3881 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3882 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3883 expr = newUNOP(OP_DEFINED, 0,
3884 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3885 } else if (expr->op_flags & OPf_KIDS) {
3886 OP *k1 = ((UNOP*)expr)->op_first;
3887 OP *k2 = (k1) ? k1->op_sibling : NULL;
3888 switch (expr->op_type) {
3890 if (k2 && k2->op_type == OP_READLINE
3891 && (k2->op_flags & OPf_STACKED)
3892 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3893 expr = newUNOP(OP_DEFINED, 0, expr);
3897 if (k1->op_type == OP_READDIR
3898 || k1->op_type == OP_GLOB
3899 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3900 || k1->op_type == OP_EACH)
3901 expr = newUNOP(OP_DEFINED, 0, expr);
3907 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3908 o = new_logop(OP_AND, 0, &expr, &listop);
3911 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3913 if (once && o != listop)
3914 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3917 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3919 o->op_flags |= flags;
3921 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3926 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3935 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3936 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3937 expr = newUNOP(OP_DEFINED, 0,
3938 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3939 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3940 OP *k1 = ((UNOP*)expr)->op_first;
3941 OP *k2 = (k1) ? k1->op_sibling : NULL;
3942 switch (expr->op_type) {
3944 if (k2 && k2->op_type == OP_READLINE
3945 && (k2->op_flags & OPf_STACKED)
3946 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3947 expr = newUNOP(OP_DEFINED, 0, expr);
3951 if (k1->op_type == OP_READDIR
3952 || k1->op_type == OP_GLOB
3953 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3954 || k1->op_type == OP_EACH)
3955 expr = newUNOP(OP_DEFINED, 0, expr);
3961 block = newOP(OP_NULL, 0);
3963 block = scope(block);
3967 next = LINKLIST(cont);
3970 OP *unstack = newOP(OP_UNSTACK, 0);
3973 cont = append_elem(OP_LINESEQ, cont, unstack);
3974 if ((line_t)whileline != NOLINE) {
3975 PL_copline = whileline;
3976 cont = append_elem(OP_LINESEQ, cont,
3977 newSTATEOP(0, Nullch, Nullop));
3981 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3982 redo = LINKLIST(listop);
3985 PL_copline = whileline;
3987 o = new_logop(OP_AND, 0, &expr, &listop);
3988 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3989 op_free(expr); /* oops, it's a while (0) */
3991 return Nullop; /* listop already freed by new_logop */
3994 ((LISTOP*)listop)->op_last->op_next = condop =
3995 (o == listop ? redo : LINKLIST(o));
4001 NewOp(1101,loop,1,LOOP);
4002 loop->op_type = OP_ENTERLOOP;
4003 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4004 loop->op_private = 0;
4005 loop->op_next = (OP*)loop;
4008 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4010 loop->op_redoop = redo;
4011 loop->op_lastop = o;
4012 o->op_private |= loopflags;
4015 loop->op_nextop = next;
4017 loop->op_nextop = o;
4019 o->op_flags |= flags;
4020 o->op_private |= (flags >> 8);
4025 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4033 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4034 sv->op_type = OP_RV2GV;
4035 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4037 else if (sv->op_type == OP_PADSV) { /* private variable */
4038 padoff = sv->op_targ;
4043 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4044 padoff = sv->op_targ;
4046 iterflags |= OPf_SPECIAL;
4051 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4055 padoff = find_threadsv("_");
4056 iterflags |= OPf_SPECIAL;
4058 sv = newGVOP(OP_GV, 0, PL_defgv);
4061 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4062 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4063 iterflags |= OPf_STACKED;
4065 else if (expr->op_type == OP_NULL &&
4066 (expr->op_flags & OPf_KIDS) &&
4067 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4069 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4070 * set the STACKED flag to indicate that these values are to be
4071 * treated as min/max values by 'pp_iterinit'.
4073 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4074 LOGOP* range = (LOGOP*) flip->op_first;
4075 OP* left = range->op_first;
4076 OP* right = left->op_sibling;
4079 range->op_flags &= ~OPf_KIDS;
4080 range->op_first = Nullop;
4082 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4083 listop->op_first->op_next = range->op_next;
4084 left->op_next = range->op_other;
4085 right->op_next = (OP*)listop;
4086 listop->op_next = listop->op_first;
4089 expr = (OP*)(listop);
4091 iterflags |= OPf_STACKED;
4094 expr = mod(force_list(expr), OP_GREPSTART);
4098 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4099 append_elem(OP_LIST, expr, scalar(sv))));
4100 assert(!loop->op_next);
4101 #ifdef PL_OP_SLAB_ALLOC
4104 NewOp(1234,tmp,1,LOOP);
4105 Copy(loop,tmp,1,LOOP);
4109 Renew(loop, 1, LOOP);
4111 loop->op_targ = padoff;
4112 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4113 PL_copline = forline;
4114 return newSTATEOP(0, label, wop);
4118 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4123 if (type != OP_GOTO || label->op_type == OP_CONST) {
4124 /* "last()" means "last" */
4125 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4126 o = newOP(type, OPf_SPECIAL);
4128 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4129 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4135 if (label->op_type == OP_ENTERSUB)
4136 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4137 o = newUNOP(type, OPf_STACKED, label);
4139 PL_hints |= HINT_BLOCK_SCOPE;
4144 Perl_cv_undef(pTHX_ CV *cv)
4148 MUTEX_DESTROY(CvMUTEXP(cv));
4149 Safefree(CvMUTEXP(cv));
4152 #endif /* USE_THREADS */
4154 if (!CvXSUB(cv) && CvROOT(cv)) {
4156 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4157 Perl_croak(aTHX_ "Can't undef active subroutine");
4160 Perl_croak(aTHX_ "Can't undef active subroutine");
4161 #endif /* USE_THREADS */
4164 SAVEVPTR(PL_curpad);
4167 op_free(CvROOT(cv));
4168 CvROOT(cv) = Nullop;
4171 SvPOK_off((SV*)cv); /* forget prototype */
4173 /* Since closure prototypes have the same lifetime as the containing
4174 * CV, they don't hold a refcount on the outside CV. This avoids
4175 * the refcount loop between the outer CV (which keeps a refcount to
4176 * the closure prototype in the pad entry for pp_anoncode()) and the
4177 * closure prototype, and the ensuing memory leak. --GSAR */
4178 if (!CvANON(cv) || CvCLONED(cv))
4179 SvREFCNT_dec(CvOUTSIDE(cv));
4180 CvOUTSIDE(cv) = Nullcv;
4182 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4185 if (CvPADLIST(cv)) {
4186 /* may be during global destruction */
4187 if (SvREFCNT(CvPADLIST(cv))) {
4188 I32 i = AvFILLp(CvPADLIST(cv));
4190 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4191 SV* sv = svp ? *svp : Nullsv;
4194 if (sv == (SV*)PL_comppad_name)
4195 PL_comppad_name = Nullav;
4196 else if (sv == (SV*)PL_comppad) {
4197 PL_comppad = Nullav;
4198 PL_curpad = Null(SV**);
4202 SvREFCNT_dec((SV*)CvPADLIST(cv));
4204 CvPADLIST(cv) = Nullav;
4212 #ifdef DEBUG_CLOSURES
4214 S_cv_dump(pTHX_ CV *cv)
4217 CV *outside = CvOUTSIDE(cv);
4218 AV* padlist = CvPADLIST(cv);
4225 PerlIO_printf(Perl_debug_log,
4226 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4228 (CvANON(cv) ? "ANON"
4229 : (cv == PL_main_cv) ? "MAIN"
4230 : CvUNIQUE(cv) ? "UNIQUE"
4231 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4234 : CvANON(outside) ? "ANON"
4235 : (outside == PL_main_cv) ? "MAIN"
4236 : CvUNIQUE(outside) ? "UNIQUE"
4237 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4242 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4243 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4244 pname = AvARRAY(pad_name);
4245 ppad = AvARRAY(pad);
4247 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4248 if (SvPOK(pname[ix]))
4249 PerlIO_printf(Perl_debug_log,
4250 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4251 (int)ix, PTR2UV(ppad[ix]),
4252 SvFAKE(pname[ix]) ? "FAKE " : "",
4254 (IV)I_32(SvNVX(pname[ix])),
4257 #endif /* DEBUGGING */
4259 #endif /* DEBUG_CLOSURES */
4262 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4266 AV* protopadlist = CvPADLIST(proto);
4267 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4268 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4269 SV** pname = AvARRAY(protopad_name);
4270 SV** ppad = AvARRAY(protopad);
4271 I32 fname = AvFILLp(protopad_name);
4272 I32 fpad = AvFILLp(protopad);
4276 assert(!CvUNIQUE(proto));
4280 SAVESPTR(PL_comppad_name);
4281 SAVESPTR(PL_compcv);
4283 cv = PL_compcv = (CV*)NEWSV(1104,0);
4284 sv_upgrade((SV *)cv, SvTYPE(proto));
4285 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4289 New(666, CvMUTEXP(cv), 1, perl_mutex);
4290 MUTEX_INIT(CvMUTEXP(cv));
4292 #endif /* USE_THREADS */
4293 CvFILE(cv) = CvFILE(proto);
4294 CvGV(cv) = CvGV(proto);
4295 CvSTASH(cv) = CvSTASH(proto);
4296 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4297 CvSTART(cv) = CvSTART(proto);
4299 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4302 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4304 PL_comppad_name = newAV();
4305 for (ix = fname; ix >= 0; ix--)
4306 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4308 PL_comppad = newAV();
4310 comppadlist = newAV();
4311 AvREAL_off(comppadlist);
4312 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4313 av_store(comppadlist, 1, (SV*)PL_comppad);
4314 CvPADLIST(cv) = comppadlist;
4315 av_fill(PL_comppad, AvFILLp(protopad));
4316 PL_curpad = AvARRAY(PL_comppad);
4318 av = newAV(); /* will be @_ */
4320 av_store(PL_comppad, 0, (SV*)av);
4321 AvFLAGS(av) = AVf_REIFY;
4323 for (ix = fpad; ix > 0; ix--) {
4324 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4325 if (namesv && namesv != &PL_sv_undef) {
4326 char *name = SvPVX(namesv); /* XXX */
4327 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4328 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4329 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4331 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4333 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4335 else { /* our own lexical */
4338 /* anon code -- we'll come back for it */
4339 sv = SvREFCNT_inc(ppad[ix]);
4341 else if (*name == '@')
4343 else if (*name == '%')
4352 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4353 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4356 SV* sv = NEWSV(0,0);
4362 /* Now that vars are all in place, clone nested closures. */
4364 for (ix = fpad; ix > 0; ix--) {
4365 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4367 && namesv != &PL_sv_undef
4368 && !(SvFLAGS(namesv) & SVf_FAKE)
4369 && *SvPVX(namesv) == '&'
4370 && CvCLONE(ppad[ix]))
4372 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4373 SvREFCNT_dec(ppad[ix]);
4376 PL_curpad[ix] = (SV*)kid;
4380 #ifdef DEBUG_CLOSURES
4381 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4383 PerlIO_printf(Perl_debug_log, " from:\n");
4385 PerlIO_printf(Perl_debug_log, " to:\n");
4392 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4394 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4396 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4403 Perl_cv_clone(pTHX_ CV *proto)
4406 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4407 cv = cv_clone2(proto, CvOUTSIDE(proto));
4408 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4413 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4415 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4416 SV* msg = sv_newmortal();
4420 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4421 sv_setpv(msg, "Prototype mismatch:");
4423 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4425 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4426 sv_catpv(msg, " vs ");
4428 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4430 sv_catpv(msg, "none");
4431 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4435 static void const_sv_xsub(pTHXo_ CV* cv);
4438 =for apidoc cv_const_sv
4440 If C<cv> is a constant sub eligible for inlining. returns the constant
4441 value returned by the sub. Otherwise, returns NULL.
4443 Constant subs can be created with C<newCONSTSUB> or as described in
4444 L<perlsub/"Constant Functions">.
4449 Perl_cv_const_sv(pTHX_ CV *cv)
4451 if (!cv || !CvCONST(cv))
4453 return (SV*)CvXSUBANY(cv).any_ptr;
4457 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4464 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4465 o = cLISTOPo->op_first->op_sibling;
4467 for (; o; o = o->op_next) {
4468 OPCODE type = o->op_type;
4470 if (sv && o->op_next == o)
4472 if (o->op_next != o) {
4473 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4475 if (type == OP_DBSTATE)
4478 if (type == OP_LEAVESUB || type == OP_RETURN)
4482 if (type == OP_CONST && cSVOPo->op_sv)
4484 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4485 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4486 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4490 /* We get here only from cv_clone2() while creating a closure.
4491 Copy the const value here instead of in cv_clone2 so that
4492 SvREADONLY_on doesn't lead to problems when leaving
4497 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4509 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4519 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4523 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4525 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4529 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4535 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4540 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4541 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4542 SV *sv = sv_newmortal();
4543 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4544 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4549 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4550 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4560 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4561 maximum a prototype before. */
4562 if (SvTYPE(gv) > SVt_NULL) {
4563 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4564 && ckWARN_d(WARN_PROTOTYPE))
4566 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4568 cv_ckproto((CV*)gv, NULL, ps);
4571 sv_setpv((SV*)gv, ps);
4573 sv_setiv((SV*)gv, -1);
4574 SvREFCNT_dec(PL_compcv);
4575 cv = PL_compcv = NULL;
4576 PL_sub_generation++;
4580 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4582 #ifdef GV_SHARED_CHECK
4583 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4584 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4588 if (!block || !ps || *ps || attrs)
4591 const_sv = op_const_sv(block, Nullcv);
4594 bool exists = CvROOT(cv) || CvXSUB(cv);
4596 #ifdef GV_SHARED_CHECK
4597 if (exists && GvSHARED(gv)) {
4598 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4602 /* if the subroutine doesn't exist and wasn't pre-declared
4603 * with a prototype, assume it will be AUTOLOADed,
4604 * skipping the prototype check
4606 if (exists || SvPOK(cv))
4607 cv_ckproto(cv, gv, ps);
4608 /* already defined (or promised)? */
4609 if (exists || GvASSUMECV(gv)) {
4610 if (!block && !attrs) {
4611 /* just a "sub foo;" when &foo is already defined */
4612 SAVEFREESV(PL_compcv);
4615 /* ahem, death to those who redefine active sort subs */
4616 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4617 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4619 if (ckWARN(WARN_REDEFINE)
4621 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4623 line_t oldline = CopLINE(PL_curcop);
4624 CopLINE_set(PL_curcop, PL_copline);
4625 Perl_warner(aTHX_ WARN_REDEFINE,
4626 CvCONST(cv) ? "Constant subroutine %s redefined"
4627 : "Subroutine %s redefined", name);
4628 CopLINE_set(PL_curcop, oldline);
4636 SvREFCNT_inc(const_sv);
4638 assert(!CvROOT(cv) && !CvCONST(cv));
4639 sv_setpv((SV*)cv, ""); /* prototype is "" */
4640 CvXSUBANY(cv).any_ptr = const_sv;
4641 CvXSUB(cv) = const_sv_xsub;
4646 cv = newCONSTSUB(NULL, name, const_sv);
4649 SvREFCNT_dec(PL_compcv);
4651 PL_sub_generation++;
4658 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4659 * before we clobber PL_compcv.
4663 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4664 stash = GvSTASH(CvGV(cv));
4665 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4666 stash = CvSTASH(cv);
4668 stash = PL_curstash;
4671 /* possibly about to re-define existing subr -- ignore old cv */
4672 rcv = (SV*)PL_compcv;
4673 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4674 stash = GvSTASH(gv);
4676 stash = PL_curstash;
4678 apply_attrs(stash, rcv, attrs);
4680 if (cv) { /* must reuse cv if autoloaded */
4682 /* got here with just attrs -- work done, so bug out */
4683 SAVEFREESV(PL_compcv);
4687 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4688 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4689 CvOUTSIDE(PL_compcv) = 0;
4690 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4691 CvPADLIST(PL_compcv) = 0;
4692 /* inner references to PL_compcv must be fixed up ... */
4694 AV *padlist = CvPADLIST(cv);
4695 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4696 AV *comppad = (AV*)AvARRAY(padlist)[1];
4697 SV **namepad = AvARRAY(comppad_name);
4698 SV **curpad = AvARRAY(comppad);
4699 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4700 SV *namesv = namepad[ix];
4701 if (namesv && namesv != &PL_sv_undef
4702 && *SvPVX(namesv) == '&')
4704 CV *innercv = (CV*)curpad[ix];
4705 if (CvOUTSIDE(innercv) == PL_compcv) {
4706 CvOUTSIDE(innercv) = cv;
4707 if (!CvANON(innercv) || CvCLONED(innercv)) {
4708 (void)SvREFCNT_inc(cv);
4709 SvREFCNT_dec(PL_compcv);
4715 /* ... before we throw it away */
4716 SvREFCNT_dec(PL_compcv);
4723 PL_sub_generation++;
4727 CvFILE(cv) = CopFILE(PL_curcop);
4728 CvSTASH(cv) = PL_curstash;
4731 if (!CvMUTEXP(cv)) {
4732 New(666, CvMUTEXP(cv), 1, perl_mutex);
4733 MUTEX_INIT(CvMUTEXP(cv));
4735 #endif /* USE_THREADS */
4738 sv_setpv((SV*)cv, ps);
4740 if (PL_error_count) {
4744 char *s = strrchr(name, ':');
4746 if (strEQ(s, "BEGIN")) {
4748 "BEGIN not safe after errors--compilation aborted";
4749 if (PL_in_eval & EVAL_KEEPERR)
4750 Perl_croak(aTHX_ not_safe);
4752 /* force display of errors found but not reported */
4753 sv_catpv(ERRSV, not_safe);
4754 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4762 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4763 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4766 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4767 mod(scalarseq(block), OP_LEAVESUBLV));
4770 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4772 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4773 OpREFCNT_set(CvROOT(cv), 1);
4774 CvSTART(cv) = LINKLIST(CvROOT(cv));
4775 CvROOT(cv)->op_next = 0;
4778 /* now that optimizer has done its work, adjust pad values */
4780 SV **namep = AvARRAY(PL_comppad_name);
4781 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4784 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4787 * The only things that a clonable function needs in its
4788 * pad are references to outer lexicals and anonymous subs.
4789 * The rest are created anew during cloning.
4791 if (!((namesv = namep[ix]) != Nullsv &&
4792 namesv != &PL_sv_undef &&
4794 *SvPVX(namesv) == '&')))
4796 SvREFCNT_dec(PL_curpad[ix]);
4797 PL_curpad[ix] = Nullsv;
4800 assert(!CvCONST(cv));
4801 if (ps && !*ps && op_const_sv(block, cv))
4805 AV *av = newAV(); /* Will be @_ */
4807 av_store(PL_comppad, 0, (SV*)av);
4808 AvFLAGS(av) = AVf_REIFY;
4810 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4811 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4813 if (!SvPADMY(PL_curpad[ix]))
4814 SvPADTMP_on(PL_curpad[ix]);
4818 /* If a potential closure prototype, don't keep a refcount on outer CV.
4819 * This is okay as the lifetime of the prototype is tied to the
4820 * lifetime of the outer CV. Avoids memory leak due to reference
4823 SvREFCNT_dec(CvOUTSIDE(cv));
4825 if (name || aname) {
4827 char *tname = (name ? name : aname);
4829 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4830 SV *sv = NEWSV(0,0);
4831 SV *tmpstr = sv_newmortal();
4832 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4836 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4838 (long)PL_subline, (long)CopLINE(PL_curcop));
4839 gv_efullname3(tmpstr, gv, Nullch);
4840 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4841 hv = GvHVn(db_postponed);
4842 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4843 && (pcv = GvCV(db_postponed)))
4849 call_sv((SV*)pcv, G_DISCARD);
4853 if ((s = strrchr(tname,':')))
4858 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4861 if (strEQ(s, "BEGIN")) {
4862 I32 oldscope = PL_scopestack_ix;
4864 SAVECOPFILE(&PL_compiling);
4865 SAVECOPLINE(&PL_compiling);
4867 sv_setsv(PL_rs, PL_nrs);
4870 PL_beginav = newAV();
4871 DEBUG_x( dump_sub(gv) );
4872 av_push(PL_beginav, (SV*)cv);
4873 GvCV(gv) = 0; /* cv has been hijacked */
4874 call_list(oldscope, PL_beginav);
4876 PL_curcop = &PL_compiling;
4877 PL_compiling.op_private = PL_hints;
4880 else if (strEQ(s, "END") && !PL_error_count) {
4883 DEBUG_x( dump_sub(gv) );
4884 av_unshift(PL_endav, 1);
4885 av_store(PL_endav, 0, (SV*)cv);
4886 GvCV(gv) = 0; /* cv has been hijacked */
4888 else if (strEQ(s, "CHECK") && !PL_error_count) {
4890 PL_checkav = newAV();
4891 DEBUG_x( dump_sub(gv) );
4892 if (PL_main_start && ckWARN(WARN_VOID))
4893 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4894 av_unshift(PL_checkav, 1);
4895 av_store(PL_checkav, 0, (SV*)cv);
4896 GvCV(gv) = 0; /* cv has been hijacked */
4898 else if (strEQ(s, "INIT") && !PL_error_count) {
4900 PL_initav = newAV();
4901 DEBUG_x( dump_sub(gv) );
4902 if (PL_main_start && ckWARN(WARN_VOID))
4903 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4904 av_push(PL_initav, (SV*)cv);
4905 GvCV(gv) = 0; /* cv has been hijacked */
4910 PL_copline = NOLINE;
4915 /* XXX unsafe for threads if eval_owner isn't held */
4917 =for apidoc newCONSTSUB
4919 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4920 eligible for inlining at compile-time.
4926 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4932 SAVECOPLINE(PL_curcop);
4933 CopLINE_set(PL_curcop, PL_copline);
4936 PL_hints &= ~HINT_BLOCK_SCOPE;
4939 SAVESPTR(PL_curstash);
4940 SAVECOPSTASH(PL_curcop);
4941 PL_curstash = stash;
4943 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4945 CopSTASH(PL_curcop) = stash;
4949 cv = newXS(name, const_sv_xsub, __FILE__);
4950 CvXSUBANY(cv).any_ptr = sv;
4952 sv_setpv((SV*)cv, ""); /* prototype is "" */
4960 =for apidoc U||newXS
4962 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4968 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4970 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4973 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4975 /* just a cached method */
4979 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4980 /* already defined (or promised) */
4981 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4982 && HvNAME(GvSTASH(CvGV(cv)))
4983 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4984 line_t oldline = CopLINE(PL_curcop);
4985 if (PL_copline != NOLINE)
4986 CopLINE_set(PL_curcop, PL_copline);
4987 Perl_warner(aTHX_ WARN_REDEFINE,
4988 CvCONST(cv) ? "Constant subroutine %s redefined"
4989 : "Subroutine %s redefined"
4991 CopLINE_set(PL_curcop, oldline);
4998 if (cv) /* must reuse cv if autoloaded */
5001 cv = (CV*)NEWSV(1105,0);
5002 sv_upgrade((SV *)cv, SVt_PVCV);
5006 PL_sub_generation++;
5011 New(666, CvMUTEXP(cv), 1, perl_mutex);
5012 MUTEX_INIT(CvMUTEXP(cv));
5014 #endif /* USE_THREADS */
5015 (void)gv_fetchfile(filename);
5016 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5017 an external constant string */
5018 CvXSUB(cv) = subaddr;
5021 char *s = strrchr(name,':');
5027 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5030 if (strEQ(s, "BEGIN")) {
5032 PL_beginav = newAV();
5033 av_push(PL_beginav, (SV*)cv);
5034 GvCV(gv) = 0; /* cv has been hijacked */
5036 else if (strEQ(s, "END")) {
5039 av_unshift(PL_endav, 1);
5040 av_store(PL_endav, 0, (SV*)cv);
5041 GvCV(gv) = 0; /* cv has been hijacked */
5043 else if (strEQ(s, "CHECK")) {
5045 PL_checkav = newAV();
5046 if (PL_main_start && ckWARN(WARN_VOID))
5047 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5048 av_unshift(PL_checkav, 1);
5049 av_store(PL_checkav, 0, (SV*)cv);
5050 GvCV(gv) = 0; /* cv has been hijacked */
5052 else if (strEQ(s, "INIT")) {
5054 PL_initav = newAV();
5055 if (PL_main_start && ckWARN(WARN_VOID))
5056 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5057 av_push(PL_initav, (SV*)cv);
5058 GvCV(gv) = 0; /* cv has been hijacked */
5069 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5078 name = SvPVx(cSVOPo->op_sv, n_a);
5081 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5082 #ifdef GV_SHARED_CHECK
5084 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5088 if ((cv = GvFORM(gv))) {
5089 if (ckWARN(WARN_REDEFINE)) {
5090 line_t oldline = CopLINE(PL_curcop);
5092 CopLINE_set(PL_curcop, PL_copline);
5093 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5094 CopLINE_set(PL_curcop, oldline);
5101 CvFILE(cv) = CopFILE(PL_curcop);
5103 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5104 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5105 SvPADTMP_on(PL_curpad[ix]);
5108 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5109 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5110 OpREFCNT_set(CvROOT(cv), 1);
5111 CvSTART(cv) = LINKLIST(CvROOT(cv));
5112 CvROOT(cv)->op_next = 0;
5115 PL_copline = NOLINE;
5120 Perl_newANONLIST(pTHX_ OP *o)
5122 return newUNOP(OP_REFGEN, 0,
5123 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5127 Perl_newANONHASH(pTHX_ OP *o)
5129 return newUNOP(OP_REFGEN, 0,
5130 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5134 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5136 return newANONATTRSUB(floor, proto, Nullop, block);
5140 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5142 return newUNOP(OP_REFGEN, 0,
5143 newSVOP(OP_ANONCODE, 0,
5144 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5148 Perl_oopsAV(pTHX_ OP *o)
5150 switch (o->op_type) {
5152 o->op_type = OP_PADAV;
5153 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5154 return ref(o, OP_RV2AV);
5157 o->op_type = OP_RV2AV;
5158 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5163 if (ckWARN_d(WARN_INTERNAL))
5164 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5171 Perl_oopsHV(pTHX_ OP *o)
5173 switch (o->op_type) {
5176 o->op_type = OP_PADHV;
5177 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5178 return ref(o, OP_RV2HV);
5182 o->op_type = OP_RV2HV;
5183 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5188 if (ckWARN_d(WARN_INTERNAL))
5189 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5196 Perl_newAVREF(pTHX_ OP *o)
5198 if (o->op_type == OP_PADANY) {
5199 o->op_type = OP_PADAV;
5200 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5203 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5204 && ckWARN(WARN_DEPRECATED)) {
5205 Perl_warner(aTHX_ WARN_DEPRECATED,
5206 "Using an array as a reference is deprecated");
5208 return newUNOP(OP_RV2AV, 0, scalar(o));
5212 Perl_newGVREF(pTHX_ I32 type, OP *o)
5214 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5215 return newUNOP(OP_NULL, 0, o);
5216 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5220 Perl_newHVREF(pTHX_ OP *o)
5222 if (o->op_type == OP_PADANY) {
5223 o->op_type = OP_PADHV;
5224 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5227 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5228 && ckWARN(WARN_DEPRECATED)) {
5229 Perl_warner(aTHX_ WARN_DEPRECATED,
5230 "Using a hash as a reference is deprecated");
5232 return newUNOP(OP_RV2HV, 0, scalar(o));
5236 Perl_oopsCV(pTHX_ OP *o)
5238 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5244 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5246 return newUNOP(OP_RV2CV, flags, scalar(o));
5250 Perl_newSVREF(pTHX_ OP *o)
5252 if (o->op_type == OP_PADANY) {
5253 o->op_type = OP_PADSV;
5254 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5257 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5258 o->op_flags |= OPpDONE_SVREF;
5261 return newUNOP(OP_RV2SV, 0, scalar(o));
5264 /* Check routines. */
5267 Perl_ck_anoncode(pTHX_ OP *o)
5272 name = NEWSV(1106,0);
5273 sv_upgrade(name, SVt_PVNV);
5274 sv_setpvn(name, "&", 1);
5277 ix = pad_alloc(o->op_type, SVs_PADMY);
5278 av_store(PL_comppad_name, ix, name);
5279 av_store(PL_comppad, ix, cSVOPo->op_sv);
5280 SvPADMY_on(cSVOPo->op_sv);
5281 cSVOPo->op_sv = Nullsv;
5282 cSVOPo->op_targ = ix;
5287 Perl_ck_bitop(pTHX_ OP *o)
5289 o->op_private = PL_hints;
5294 Perl_ck_concat(pTHX_ OP *o)
5296 if (cUNOPo->op_first->op_type == OP_CONCAT)
5297 o->op_flags |= OPf_STACKED;
5302 Perl_ck_spair(pTHX_ OP *o)
5304 if (o->op_flags & OPf_KIDS) {
5307 OPCODE type = o->op_type;
5308 o = modkids(ck_fun(o), type);
5309 kid = cUNOPo->op_first;
5310 newop = kUNOP->op_first->op_sibling;
5312 (newop->op_sibling ||
5313 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5314 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5315 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5319 op_free(kUNOP->op_first);
5320 kUNOP->op_first = newop;
5322 o->op_ppaddr = PL_ppaddr[++o->op_type];
5327 Perl_ck_delete(pTHX_ OP *o)
5331 if (o->op_flags & OPf_KIDS) {
5332 OP *kid = cUNOPo->op_first;
5333 switch (kid->op_type) {
5335 o->op_flags |= OPf_SPECIAL;
5338 o->op_private |= OPpSLICE;
5341 o->op_flags |= OPf_SPECIAL;
5346 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5347 PL_op_desc[o->op_type]);
5355 Perl_ck_eof(pTHX_ OP *o)
5357 I32 type = o->op_type;
5359 if (o->op_flags & OPf_KIDS) {
5360 if (cLISTOPo->op_first->op_type == OP_STUB) {
5362 o = newUNOP(type, OPf_SPECIAL,
5363 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5371 Perl_ck_eval(pTHX_ OP *o)
5373 PL_hints |= HINT_BLOCK_SCOPE;
5374 if (o->op_flags & OPf_KIDS) {
5375 SVOP *kid = (SVOP*)cUNOPo->op_first;
5378 o->op_flags &= ~OPf_KIDS;
5381 else if (kid->op_type == OP_LINESEQ) {
5384 kid->op_next = o->op_next;
5385 cUNOPo->op_first = 0;
5388 NewOp(1101, enter, 1, LOGOP);
5389 enter->op_type = OP_ENTERTRY;
5390 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5391 enter->op_private = 0;
5393 /* establish postfix order */
5394 enter->op_next = (OP*)enter;
5396 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5397 o->op_type = OP_LEAVETRY;
5398 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5399 enter->op_other = o;
5407 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5409 o->op_targ = (PADOFFSET)PL_hints;
5414 Perl_ck_exit(pTHX_ OP *o)
5417 HV *table = GvHV(PL_hintgv);
5419 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5420 if (svp && *svp && SvTRUE(*svp))
5421 o->op_private |= OPpEXIT_VMSISH;
5428 Perl_ck_exec(pTHX_ OP *o)
5431 if (o->op_flags & OPf_STACKED) {
5433 kid = cUNOPo->op_first->op_sibling;
5434 if (kid->op_type == OP_RV2GV)
5443 Perl_ck_exists(pTHX_ OP *o)
5446 if (o->op_flags & OPf_KIDS) {
5447 OP *kid = cUNOPo->op_first;
5448 if (kid->op_type == OP_ENTERSUB) {
5449 (void) ref(kid, o->op_type);
5450 if (kid->op_type != OP_RV2CV && !PL_error_count)
5451 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5452 PL_op_desc[o->op_type]);
5453 o->op_private |= OPpEXISTS_SUB;
5455 else if (kid->op_type == OP_AELEM)
5456 o->op_flags |= OPf_SPECIAL;
5457 else if (kid->op_type != OP_HELEM)
5458 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5459 PL_op_desc[o->op_type]);
5467 Perl_ck_gvconst(pTHX_ register OP *o)
5469 o = fold_constants(o);
5470 if (o->op_type == OP_CONST)
5477 Perl_ck_rvconst(pTHX_ register OP *o)
5479 SVOP *kid = (SVOP*)cUNOPo->op_first;
5481 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5482 if (kid->op_type == OP_CONST) {
5486 SV *kidsv = kid->op_sv;
5489 /* Is it a constant from cv_const_sv()? */
5490 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5491 SV *rsv = SvRV(kidsv);
5492 int svtype = SvTYPE(rsv);
5493 char *badtype = Nullch;
5495 switch (o->op_type) {
5497 if (svtype > SVt_PVMG)
5498 badtype = "a SCALAR";
5501 if (svtype != SVt_PVAV)
5502 badtype = "an ARRAY";
5505 if (svtype != SVt_PVHV) {
5506 if (svtype == SVt_PVAV) { /* pseudohash? */
5507 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5508 if (ksv && SvROK(*ksv)
5509 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5518 if (svtype != SVt_PVCV)
5523 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5526 name = SvPV(kidsv, n_a);
5527 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5528 char *badthing = Nullch;
5529 switch (o->op_type) {
5531 badthing = "a SCALAR";
5534 badthing = "an ARRAY";
5537 badthing = "a HASH";
5542 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5546 * This is a little tricky. We only want to add the symbol if we
5547 * didn't add it in the lexer. Otherwise we get duplicate strict
5548 * warnings. But if we didn't add it in the lexer, we must at
5549 * least pretend like we wanted to add it even if it existed before,
5550 * or we get possible typo warnings. OPpCONST_ENTERED says
5551 * whether the lexer already added THIS instance of this symbol.
5553 iscv = (o->op_type == OP_RV2CV) * 2;
5555 gv = gv_fetchpv(name,
5556 iscv | !(kid->op_private & OPpCONST_ENTERED),
5559 : o->op_type == OP_RV2SV
5561 : o->op_type == OP_RV2AV
5563 : o->op_type == OP_RV2HV
5566 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5568 kid->op_type = OP_GV;
5569 SvREFCNT_dec(kid->op_sv);
5571 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5572 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5573 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5575 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5577 kid->op_sv = SvREFCNT_inc(gv);
5579 kid->op_private = 0;
5580 kid->op_ppaddr = PL_ppaddr[OP_GV];
5587 Perl_ck_ftst(pTHX_ OP *o)
5589 I32 type = o->op_type;
5591 if (o->op_flags & OPf_REF) {
5594 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5595 SVOP *kid = (SVOP*)cUNOPo->op_first;
5597 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5599 OP *newop = newGVOP(type, OPf_REF,
5600 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5607 if (type == OP_FTTTY)
5608 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5611 o = newUNOP(type, 0, newDEFSVOP());
5617 Perl_ck_fun(pTHX_ OP *o)
5623 int type = o->op_type;
5624 register I32 oa = PL_opargs[type] >> OASHIFT;
5626 if (o->op_flags & OPf_STACKED) {
5627 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5630 return no_fh_allowed(o);
5633 if (o->op_flags & OPf_KIDS) {
5635 tokid = &cLISTOPo->op_first;
5636 kid = cLISTOPo->op_first;
5637 if (kid->op_type == OP_PUSHMARK ||
5638 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5640 tokid = &kid->op_sibling;
5641 kid = kid->op_sibling;
5643 if (!kid && PL_opargs[type] & OA_DEFGV)
5644 *tokid = kid = newDEFSVOP();
5648 sibl = kid->op_sibling;
5651 /* list seen where single (scalar) arg expected? */
5652 if (numargs == 1 && !(oa >> 4)
5653 && kid->op_type == OP_LIST && type != OP_SCALAR)
5655 return too_many_arguments(o,PL_op_desc[type]);
5668 if ((type == OP_PUSH || type == OP_UNSHIFT)
5669 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5670 Perl_warner(aTHX_ WARN_SYNTAX,
5671 "Useless use of %s with no values",
5674 if (kid->op_type == OP_CONST &&
5675 (kid->op_private & OPpCONST_BARE))
5677 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5678 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5679 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5680 if (ckWARN(WARN_DEPRECATED))
5681 Perl_warner(aTHX_ WARN_DEPRECATED,
5682 "Array @%s missing the @ in argument %"IVdf" of %s()",
5683 name, (IV)numargs, PL_op_desc[type]);
5686 kid->op_sibling = sibl;
5689 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5690 bad_type(numargs, "array", PL_op_desc[type], kid);
5694 if (kid->op_type == OP_CONST &&
5695 (kid->op_private & OPpCONST_BARE))
5697 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5698 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5699 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5700 if (ckWARN(WARN_DEPRECATED))
5701 Perl_warner(aTHX_ WARN_DEPRECATED,
5702 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5703 name, (IV)numargs, PL_op_desc[type]);
5706 kid->op_sibling = sibl;
5709 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5710 bad_type(numargs, "hash", PL_op_desc[type], kid);
5715 OP *newop = newUNOP(OP_NULL, 0, kid);
5716 kid->op_sibling = 0;
5718 newop->op_next = newop;
5720 kid->op_sibling = sibl;
5725 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5726 if (kid->op_type == OP_CONST &&
5727 (kid->op_private & OPpCONST_BARE))
5729 OP *newop = newGVOP(OP_GV, 0,
5730 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5735 else if (kid->op_type == OP_READLINE) {
5736 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5737 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5740 I32 flags = OPf_SPECIAL;
5744 /* is this op a FH constructor? */
5745 if (is_handle_constructor(o,numargs)) {
5746 char *name = Nullch;
5750 /* Set a flag to tell rv2gv to vivify
5751 * need to "prove" flag does not mean something
5752 * else already - NI-S 1999/05/07
5755 if (kid->op_type == OP_PADSV) {
5756 SV **namep = av_fetch(PL_comppad_name,
5758 if (namep && *namep)
5759 name = SvPV(*namep, len);
5761 else if (kid->op_type == OP_RV2SV
5762 && kUNOP->op_first->op_type == OP_GV)
5764 GV *gv = cGVOPx_gv(kUNOP->op_first);
5766 len = GvNAMELEN(gv);
5768 else if (kid->op_type == OP_AELEM
5769 || kid->op_type == OP_HELEM)
5771 name = "__ANONIO__";
5777 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5778 namesv = PL_curpad[targ];
5779 (void)SvUPGRADE(namesv, SVt_PV);
5781 sv_setpvn(namesv, "$", 1);
5782 sv_catpvn(namesv, name, len);
5785 kid->op_sibling = 0;
5786 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5787 kid->op_targ = targ;
5788 kid->op_private |= priv;
5790 kid->op_sibling = sibl;
5796 mod(scalar(kid), type);
5800 tokid = &kid->op_sibling;
5801 kid = kid->op_sibling;
5803 o->op_private |= numargs;
5805 return too_many_arguments(o,PL_op_desc[o->op_type]);
5808 else if (PL_opargs[type] & OA_DEFGV) {
5810 return newUNOP(type, 0, newDEFSVOP());
5814 while (oa & OA_OPTIONAL)
5816 if (oa && oa != OA_LIST)
5817 return too_few_arguments(o,PL_op_desc[o->op_type]);
5823 Perl_ck_glob(pTHX_ OP *o)
5828 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5829 append_elem(OP_GLOB, o, newDEFSVOP());
5831 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5832 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5834 #if !defined(PERL_EXTERNAL_GLOB)
5835 /* XXX this can be tightened up and made more failsafe. */
5839 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5841 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5842 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5843 GvCV(gv) = GvCV(glob_gv);
5844 SvREFCNT_inc((SV*)GvCV(gv));
5845 GvIMPORTED_CV_on(gv);
5848 #endif /* PERL_EXTERNAL_GLOB */
5850 if (gv && GvIMPORTED_CV(gv)) {
5851 append_elem(OP_GLOB, o,
5852 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5853 o->op_type = OP_LIST;
5854 o->op_ppaddr = PL_ppaddr[OP_LIST];
5855 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5856 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5857 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5858 append_elem(OP_LIST, o,
5859 scalar(newUNOP(OP_RV2CV, 0,
5860 newGVOP(OP_GV, 0, gv)))));
5861 o = newUNOP(OP_NULL, 0, ck_subr(o));
5862 o->op_targ = OP_GLOB; /* hint at what it used to be */
5865 gv = newGVgen("main");
5867 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5873 Perl_ck_grep(pTHX_ OP *o)
5877 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5879 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5880 NewOp(1101, gwop, 1, LOGOP);
5882 if (o->op_flags & OPf_STACKED) {
5885 kid = cLISTOPo->op_first->op_sibling;
5886 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5889 kid->op_next = (OP*)gwop;
5890 o->op_flags &= ~OPf_STACKED;
5892 kid = cLISTOPo->op_first->op_sibling;
5893 if (type == OP_MAPWHILE)
5900 kid = cLISTOPo->op_first->op_sibling;
5901 if (kid->op_type != OP_NULL)
5902 Perl_croak(aTHX_ "panic: ck_grep");
5903 kid = kUNOP->op_first;
5905 gwop->op_type = type;
5906 gwop->op_ppaddr = PL_ppaddr[type];
5907 gwop->op_first = listkids(o);
5908 gwop->op_flags |= OPf_KIDS;
5909 gwop->op_private = 1;
5910 gwop->op_other = LINKLIST(kid);
5911 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5912 kid->op_next = (OP*)gwop;
5914 kid = cLISTOPo->op_first->op_sibling;
5915 if (!kid || !kid->op_sibling)
5916 return too_few_arguments(o,PL_op_desc[o->op_type]);
5917 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5918 mod(kid, OP_GREPSTART);
5924 Perl_ck_index(pTHX_ OP *o)
5926 if (o->op_flags & OPf_KIDS) {
5927 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5929 kid = kid->op_sibling; /* get past "big" */
5930 if (kid && kid->op_type == OP_CONST)
5931 fbm_compile(((SVOP*)kid)->op_sv, 0);
5937 Perl_ck_lengthconst(pTHX_ OP *o)
5939 /* XXX length optimization goes here */
5944 Perl_ck_lfun(pTHX_ OP *o)
5946 OPCODE type = o->op_type;
5947 return modkids(ck_fun(o), type);
5951 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5953 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5954 switch (cUNOPo->op_first->op_type) {
5956 /* This is needed for
5957 if (defined %stash::)
5958 to work. Do not break Tk.
5960 break; /* Globals via GV can be undef */
5962 case OP_AASSIGN: /* Is this a good idea? */
5963 Perl_warner(aTHX_ WARN_DEPRECATED,
5964 "defined(@array) is deprecated");
5965 Perl_warner(aTHX_ WARN_DEPRECATED,
5966 "\t(Maybe you should just omit the defined()?)\n");
5969 /* This is needed for
5970 if (defined %stash::)
5971 to work. Do not break Tk.
5973 break; /* Globals via GV can be undef */
5975 Perl_warner(aTHX_ WARN_DEPRECATED,
5976 "defined(%%hash) is deprecated");
5977 Perl_warner(aTHX_ WARN_DEPRECATED,
5978 "\t(Maybe you should just omit the defined()?)\n");
5989 Perl_ck_rfun(pTHX_ OP *o)
5991 OPCODE type = o->op_type;
5992 return refkids(ck_fun(o), type);
5996 Perl_ck_listiob(pTHX_ OP *o)
6000 kid = cLISTOPo->op_first;
6003 kid = cLISTOPo->op_first;
6005 if (kid->op_type == OP_PUSHMARK)
6006 kid = kid->op_sibling;
6007 if (kid && o->op_flags & OPf_STACKED)
6008 kid = kid->op_sibling;
6009 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6010 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6011 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6012 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6013 cLISTOPo->op_first->op_sibling = kid;
6014 cLISTOPo->op_last = kid;
6015 kid = kid->op_sibling;
6020 append_elem(o->op_type, o, newDEFSVOP());
6026 Perl_ck_sassign(pTHX_ OP *o)
6028 OP *kid = cLISTOPo->op_first;
6029 /* has a disposable target? */
6030 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6031 && !(kid->op_flags & OPf_STACKED)
6032 /* Cannot steal the second time! */
6033 && !(kid->op_private & OPpTARGET_MY))
6035 OP *kkid = kid->op_sibling;
6037 /* Can just relocate the target. */
6038 if (kkid && kkid->op_type == OP_PADSV
6039 && !(kkid->op_private & OPpLVAL_INTRO))
6041 kid->op_targ = kkid->op_targ;
6043 /* Now we do not need PADSV and SASSIGN. */
6044 kid->op_sibling = o->op_sibling; /* NULL */
6045 cLISTOPo->op_first = NULL;
6048 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6056 Perl_ck_match(pTHX_ OP *o)
6058 o->op_private |= OPpRUNTIME;
6063 Perl_ck_method(pTHX_ OP *o)
6065 OP *kid = cUNOPo->op_first;
6066 if (kid->op_type == OP_CONST) {
6067 SV* sv = kSVOP->op_sv;
6068 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6070 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6071 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6074 kSVOP->op_sv = Nullsv;
6076 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6085 Perl_ck_null(pTHX_ OP *o)
6091 Perl_ck_open(pTHX_ OP *o)
6093 HV *table = GvHV(PL_hintgv);
6097 svp = hv_fetch(table, "open_IN", 7, FALSE);
6099 mode = mode_from_discipline(*svp);
6100 if (mode & O_BINARY)
6101 o->op_private |= OPpOPEN_IN_RAW;
6102 else if (mode & O_TEXT)
6103 o->op_private |= OPpOPEN_IN_CRLF;
6106 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6108 mode = mode_from_discipline(*svp);
6109 if (mode & O_BINARY)
6110 o->op_private |= OPpOPEN_OUT_RAW;
6111 else if (mode & O_TEXT)
6112 o->op_private |= OPpOPEN_OUT_CRLF;
6115 if (o->op_type == OP_BACKTICK)
6121 Perl_ck_repeat(pTHX_ OP *o)
6123 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6124 o->op_private |= OPpREPEAT_DOLIST;
6125 cBINOPo->op_first = force_list(cBINOPo->op_first);
6133 Perl_ck_require(pTHX_ OP *o)
6137 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6138 SVOP *kid = (SVOP*)cUNOPo->op_first;
6140 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6142 for (s = SvPVX(kid->op_sv); *s; s++) {
6143 if (*s == ':' && s[1] == ':') {
6145 Move(s+2, s+1, strlen(s+2)+1, char);
6146 --SvCUR(kid->op_sv);
6149 if (SvREADONLY(kid->op_sv)) {
6150 SvREADONLY_off(kid->op_sv);
6151 sv_catpvn(kid->op_sv, ".pm", 3);
6152 SvREADONLY_on(kid->op_sv);
6155 sv_catpvn(kid->op_sv, ".pm", 3);
6159 /* handle override, if any */
6160 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6161 if (!(gv && GvIMPORTED_CV(gv)))
6162 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6164 if (gv && GvIMPORTED_CV(gv)) {
6165 OP *kid = cUNOPo->op_first;
6166 cUNOPo->op_first = 0;
6168 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6169 append_elem(OP_LIST, kid,
6170 scalar(newUNOP(OP_RV2CV, 0,
6179 Perl_ck_return(pTHX_ OP *o)
6182 if (CvLVALUE(PL_compcv)) {
6183 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6184 mod(kid, OP_LEAVESUBLV);
6191 Perl_ck_retarget(pTHX_ OP *o)
6193 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6200 Perl_ck_select(pTHX_ OP *o)
6203 if (o->op_flags & OPf_KIDS) {
6204 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6205 if (kid && kid->op_sibling) {
6206 o->op_type = OP_SSELECT;
6207 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6209 return fold_constants(o);
6213 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6214 if (kid && kid->op_type == OP_RV2GV)
6215 kid->op_private &= ~HINT_STRICT_REFS;
6220 Perl_ck_shift(pTHX_ OP *o)
6222 I32 type = o->op_type;
6224 if (!(o->op_flags & OPf_KIDS)) {
6229 if (!CvUNIQUE(PL_compcv)) {
6230 argop = newOP(OP_PADAV, OPf_REF);
6231 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6234 argop = newUNOP(OP_RV2AV, 0,
6235 scalar(newGVOP(OP_GV, 0,
6236 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6239 argop = newUNOP(OP_RV2AV, 0,
6240 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6241 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6242 #endif /* USE_THREADS */
6243 return newUNOP(type, 0, scalar(argop));
6245 return scalar(modkids(ck_fun(o), type));
6249 Perl_ck_sort(pTHX_ OP *o)
6253 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6255 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6256 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6258 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6260 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6262 if (kid->op_type == OP_SCOPE) {
6266 else if (kid->op_type == OP_LEAVE) {
6267 if (o->op_type == OP_SORT) {
6268 op_null(kid); /* wipe out leave */
6271 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6272 if (k->op_next == kid)
6274 /* don't descend into loops */
6275 else if (k->op_type == OP_ENTERLOOP
6276 || k->op_type == OP_ENTERITER)
6278 k = cLOOPx(k)->op_lastop;
6283 kid->op_next = 0; /* just disconnect the leave */
6284 k = kLISTOP->op_first;
6289 if (o->op_type == OP_SORT) {
6290 /* provide scalar context for comparison function/block */
6296 o->op_flags |= OPf_SPECIAL;
6298 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6301 firstkid = firstkid->op_sibling;
6304 /* provide list context for arguments */
6305 if (o->op_type == OP_SORT)
6312 S_simplify_sort(pTHX_ OP *o)
6314 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6318 if (!(o->op_flags & OPf_STACKED))
6320 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6321 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6322 kid = kUNOP->op_first; /* get past null */
6323 if (kid->op_type != OP_SCOPE)
6325 kid = kLISTOP->op_last; /* get past scope */
6326 switch(kid->op_type) {
6334 k = kid; /* remember this node*/
6335 if (kBINOP->op_first->op_type != OP_RV2SV)
6337 kid = kBINOP->op_first; /* get past cmp */
6338 if (kUNOP->op_first->op_type != OP_GV)
6340 kid = kUNOP->op_first; /* get past rv2sv */
6342 if (GvSTASH(gv) != PL_curstash)
6344 if (strEQ(GvNAME(gv), "a"))
6346 else if (strEQ(GvNAME(gv), "b"))
6350 kid = k; /* back to cmp */
6351 if (kBINOP->op_last->op_type != OP_RV2SV)
6353 kid = kBINOP->op_last; /* down to 2nd arg */
6354 if (kUNOP->op_first->op_type != OP_GV)
6356 kid = kUNOP->op_first; /* get past rv2sv */
6358 if (GvSTASH(gv) != PL_curstash
6360 ? strNE(GvNAME(gv), "a")
6361 : strNE(GvNAME(gv), "b")))
6363 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6365 o->op_private |= OPpSORT_REVERSE;
6366 if (k->op_type == OP_NCMP)
6367 o->op_private |= OPpSORT_NUMERIC;
6368 if (k->op_type == OP_I_NCMP)
6369 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6370 kid = cLISTOPo->op_first->op_sibling;
6371 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6372 op_free(kid); /* then delete it */
6376 Perl_ck_split(pTHX_ OP *o)
6380 if (o->op_flags & OPf_STACKED)
6381 return no_fh_allowed(o);
6383 kid = cLISTOPo->op_first;
6384 if (kid->op_type != OP_NULL)
6385 Perl_croak(aTHX_ "panic: ck_split");
6386 kid = kid->op_sibling;
6387 op_free(cLISTOPo->op_first);
6388 cLISTOPo->op_first = kid;
6390 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6391 cLISTOPo->op_last = kid; /* There was only one element previously */
6394 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6395 OP *sibl = kid->op_sibling;
6396 kid->op_sibling = 0;
6397 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6398 if (cLISTOPo->op_first == cLISTOPo->op_last)
6399 cLISTOPo->op_last = kid;
6400 cLISTOPo->op_first = kid;
6401 kid->op_sibling = sibl;
6404 kid->op_type = OP_PUSHRE;
6405 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6408 if (!kid->op_sibling)
6409 append_elem(OP_SPLIT, o, newDEFSVOP());
6411 kid = kid->op_sibling;
6414 if (!kid->op_sibling)
6415 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6417 kid = kid->op_sibling;
6420 if (kid->op_sibling)
6421 return too_many_arguments(o,PL_op_desc[o->op_type]);
6427 Perl_ck_join(pTHX_ OP *o)
6429 if (ckWARN(WARN_SYNTAX)) {
6430 OP *kid = cLISTOPo->op_first->op_sibling;
6431 if (kid && kid->op_type == OP_MATCH) {
6432 char *pmstr = "STRING";
6433 if (kPMOP->op_pmregexp)
6434 pmstr = kPMOP->op_pmregexp->precomp;
6435 Perl_warner(aTHX_ WARN_SYNTAX,
6436 "/%s/ should probably be written as \"%s\"",
6444 Perl_ck_subr(pTHX_ OP *o)
6446 OP *prev = ((cUNOPo->op_first->op_sibling)
6447 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6448 OP *o2 = prev->op_sibling;
6457 o->op_private |= OPpENTERSUB_HASTARG;
6458 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6459 if (cvop->op_type == OP_RV2CV) {
6461 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6462 op_null(cvop); /* disable rv2cv */
6463 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6464 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6465 GV *gv = cGVOPx_gv(tmpop);
6468 tmpop->op_private |= OPpEARLY_CV;
6469 else if (SvPOK(cv)) {
6470 namegv = CvANON(cv) ? gv : CvGV(cv);
6471 proto = SvPV((SV*)cv, n_a);
6475 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6476 if (o2->op_type == OP_CONST)
6477 o2->op_private &= ~OPpCONST_STRICT;
6478 else if (o2->op_type == OP_LIST) {
6479 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6480 if (o && o->op_type == OP_CONST)
6481 o->op_private &= ~OPpCONST_STRICT;
6484 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6485 if (PERLDB_SUB && PL_curstash != PL_debstash)
6486 o->op_private |= OPpENTERSUB_DB;
6487 while (o2 != cvop) {
6491 return too_many_arguments(o, gv_ename(namegv));
6509 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6511 arg == 1 ? "block or sub {}" : "sub {}",
6512 gv_ename(namegv), o2);
6515 /* '*' allows any scalar type, including bareword */
6518 if (o2->op_type == OP_RV2GV)
6519 goto wrapref; /* autoconvert GLOB -> GLOBref */
6520 else if (o2->op_type == OP_CONST)
6521 o2->op_private &= ~OPpCONST_STRICT;
6522 else if (o2->op_type == OP_ENTERSUB) {
6523 /* accidental subroutine, revert to bareword */
6524 OP *gvop = ((UNOP*)o2)->op_first;
6525 if (gvop && gvop->op_type == OP_NULL) {
6526 gvop = ((UNOP*)gvop)->op_first;
6528 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6531 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6532 (gvop = ((UNOP*)gvop)->op_first) &&
6533 gvop->op_type == OP_GV)
6535 GV *gv = cGVOPx_gv(gvop);
6536 OP *sibling = o2->op_sibling;
6537 SV *n = newSVpvn("",0);
6539 gv_fullname3(n, gv, "");
6540 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6541 sv_chop(n, SvPVX(n)+6);
6542 o2 = newSVOP(OP_CONST, 0, n);
6543 prev->op_sibling = o2;
6544 o2->op_sibling = sibling;
6556 if (o2->op_type != OP_RV2GV)
6557 bad_type(arg, "symbol", gv_ename(namegv), o2);
6560 if (o2->op_type != OP_ENTERSUB)
6561 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6564 if (o2->op_type != OP_RV2SV
6565 && o2->op_type != OP_PADSV
6566 && o2->op_type != OP_HELEM
6567 && o2->op_type != OP_AELEM
6568 && o2->op_type != OP_THREADSV)
6570 bad_type(arg, "scalar", gv_ename(namegv), o2);
6574 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6575 bad_type(arg, "array", gv_ename(namegv), o2);
6578 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6579 bad_type(arg, "hash", gv_ename(namegv), o2);
6583 OP* sib = kid->op_sibling;
6584 kid->op_sibling = 0;
6585 o2 = newUNOP(OP_REFGEN, 0, kid);
6586 o2->op_sibling = sib;
6587 prev->op_sibling = o2;
6598 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6599 gv_ename(namegv), SvPV((SV*)cv, n_a));
6604 mod(o2, OP_ENTERSUB);
6606 o2 = o2->op_sibling;
6608 if (proto && !optional &&
6609 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6610 return too_few_arguments(o, gv_ename(namegv));
6615 Perl_ck_svconst(pTHX_ OP *o)
6617 SvREADONLY_on(cSVOPo->op_sv);
6622 Perl_ck_trunc(pTHX_ OP *o)
6624 if (o->op_flags & OPf_KIDS) {
6625 SVOP *kid = (SVOP*)cUNOPo->op_first;
6627 if (kid->op_type == OP_NULL)
6628 kid = (SVOP*)kid->op_sibling;
6629 if (kid && kid->op_type == OP_CONST &&
6630 (kid->op_private & OPpCONST_BARE))
6632 o->op_flags |= OPf_SPECIAL;
6633 kid->op_private &= ~OPpCONST_STRICT;
6640 Perl_ck_substr(pTHX_ OP *o)
6643 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6644 OP *kid = cLISTOPo->op_first;
6646 if (kid->op_type == OP_NULL)
6647 kid = kid->op_sibling;
6649 kid->op_flags |= OPf_MOD;
6655 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6658 Perl_peep(pTHX_ register OP *o)
6660 register OP* oldop = 0;
6663 if (!o || o->op_seq)
6667 SAVEVPTR(PL_curcop);
6668 for (; o; o = o->op_next) {
6674 switch (o->op_type) {
6678 PL_curcop = ((COP*)o); /* for warnings */
6679 o->op_seq = PL_op_seqmax++;
6683 if (cSVOPo->op_private & OPpCONST_STRICT)
6684 no_bareword_allowed(o);
6686 /* Relocate sv to the pad for thread safety.
6687 * Despite being a "constant", the SV is written to,
6688 * for reference counts, sv_upgrade() etc. */
6690 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6691 if (SvPADTMP(cSVOPo->op_sv)) {
6692 /* If op_sv is already a PADTMP then it is being used by
6693 * some pad, so make a copy. */
6694 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6695 SvREADONLY_on(PL_curpad[ix]);
6696 SvREFCNT_dec(cSVOPo->op_sv);
6699 SvREFCNT_dec(PL_curpad[ix]);
6700 SvPADTMP_on(cSVOPo->op_sv);
6701 PL_curpad[ix] = cSVOPo->op_sv;
6702 /* XXX I don't know how this isn't readonly already. */
6703 SvREADONLY_on(PL_curpad[ix]);
6705 cSVOPo->op_sv = Nullsv;
6709 o->op_seq = PL_op_seqmax++;
6713 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6714 if (o->op_next->op_private & OPpTARGET_MY) {
6715 if (o->op_flags & OPf_STACKED) /* chained concats */
6716 goto ignore_optimization;
6718 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6719 o->op_targ = o->op_next->op_targ;
6720 o->op_next->op_targ = 0;
6721 o->op_private |= OPpTARGET_MY;
6724 op_null(o->op_next);
6726 ignore_optimization:
6727 o->op_seq = PL_op_seqmax++;
6730 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6731 o->op_seq = PL_op_seqmax++;
6732 break; /* Scalar stub must produce undef. List stub is noop */
6736 if (o->op_targ == OP_NEXTSTATE
6737 || o->op_targ == OP_DBSTATE
6738 || o->op_targ == OP_SETSTATE)
6740 PL_curcop = ((COP*)o);
6747 if (oldop && o->op_next) {
6748 oldop->op_next = o->op_next;
6751 o->op_seq = PL_op_seqmax++;
6755 if (o->op_next->op_type == OP_RV2SV) {
6756 if (!(o->op_next->op_private & OPpDEREF)) {
6757 op_null(o->op_next);
6758 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6760 o->op_next = o->op_next->op_next;
6761 o->op_type = OP_GVSV;
6762 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6765 else if (o->op_next->op_type == OP_RV2AV) {
6766 OP* pop = o->op_next->op_next;
6768 if (pop->op_type == OP_CONST &&
6769 (PL_op = pop->op_next) &&
6770 pop->op_next->op_type == OP_AELEM &&
6771 !(pop->op_next->op_private &
6772 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6773 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6778 op_null(o->op_next);
6779 op_null(pop->op_next);
6781 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6782 o->op_next = pop->op_next->op_next;
6783 o->op_type = OP_AELEMFAST;
6784 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6785 o->op_private = (U8)i;
6790 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6792 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6793 /* XXX could check prototype here instead of just carping */
6794 SV *sv = sv_newmortal();
6795 gv_efullname3(sv, gv, Nullch);
6796 Perl_warner(aTHX_ WARN_PROTOTYPE,
6797 "%s() called too early to check prototype",
6802 o->op_seq = PL_op_seqmax++;
6813 o->op_seq = PL_op_seqmax++;
6814 while (cLOGOP->op_other->op_type == OP_NULL)
6815 cLOGOP->op_other = cLOGOP->op_other->op_next;
6816 peep(cLOGOP->op_other);
6821 o->op_seq = PL_op_seqmax++;
6822 while (cLOOP->op_redoop->op_type == OP_NULL)
6823 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6824 peep(cLOOP->op_redoop);
6825 while (cLOOP->op_nextop->op_type == OP_NULL)
6826 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6827 peep(cLOOP->op_nextop);
6828 while (cLOOP->op_lastop->op_type == OP_NULL)
6829 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6830 peep(cLOOP->op_lastop);
6836 o->op_seq = PL_op_seqmax++;
6837 while (cPMOP->op_pmreplstart &&
6838 cPMOP->op_pmreplstart->op_type == OP_NULL)
6839 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6840 peep(cPMOP->op_pmreplstart);
6844 o->op_seq = PL_op_seqmax++;
6845 if (ckWARN(WARN_SYNTAX) && o->op_next
6846 && o->op_next->op_type == OP_NEXTSTATE) {
6847 if (o->op_next->op_sibling &&
6848 o->op_next->op_sibling->op_type != OP_EXIT &&
6849 o->op_next->op_sibling->op_type != OP_WARN &&
6850 o->op_next->op_sibling->op_type != OP_DIE) {
6851 line_t oldline = CopLINE(PL_curcop);
6853 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6854 Perl_warner(aTHX_ WARN_EXEC,
6855 "Statement unlikely to be reached");
6856 Perl_warner(aTHX_ WARN_EXEC,
6857 "\t(Maybe you meant system() when you said exec()?)\n");
6858 CopLINE_set(PL_curcop, oldline);
6867 SV **svp, **indsvp, *sv;
6872 o->op_seq = PL_op_seqmax++;
6874 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6877 /* Make the CONST have a shared SV */
6878 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6879 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6880 key = SvPV(sv, keylen);
6883 lexname = newSVpvn_share(key, keylen, 0);
6888 if ((o->op_private & (OPpLVAL_INTRO)))
6891 rop = (UNOP*)((BINOP*)o)->op_first;
6892 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6894 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6895 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6897 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6898 if (!fields || !GvHV(*fields))
6900 key = SvPV(*svp, keylen);
6903 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6905 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6906 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6908 ind = SvIV(*indsvp);
6910 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6911 rop->op_type = OP_RV2AV;
6912 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6913 o->op_type = OP_AELEM;
6914 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6916 if (SvREADONLY(*svp))
6918 SvFLAGS(sv) |= (SvFLAGS(*svp)
6919 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6929 SV **svp, **indsvp, *sv;
6933 SVOP *first_key_op, *key_op;
6935 o->op_seq = PL_op_seqmax++;
6936 if ((o->op_private & (OPpLVAL_INTRO))
6937 /* I bet there's always a pushmark... */
6938 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6939 /* hmmm, no optimization if list contains only one key. */
6941 rop = (UNOP*)((LISTOP*)o)->op_last;
6942 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6944 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6945 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6947 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6948 if (!fields || !GvHV(*fields))
6950 /* Again guessing that the pushmark can be jumped over.... */
6951 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6952 ->op_first->op_sibling;
6953 /* Check that the key list contains only constants. */
6954 for (key_op = first_key_op; key_op;
6955 key_op = (SVOP*)key_op->op_sibling)
6956 if (key_op->op_type != OP_CONST)
6960 rop->op_type = OP_RV2AV;
6961 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6962 o->op_type = OP_ASLICE;
6963 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6964 for (key_op = first_key_op; key_op;
6965 key_op = (SVOP*)key_op->op_sibling) {
6966 svp = cSVOPx_svp(key_op);
6967 key = SvPV(*svp, keylen);
6970 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6972 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6973 "in variable %s of type %s",
6974 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6976 ind = SvIV(*indsvp);
6978 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6980 if (SvREADONLY(*svp))
6982 SvFLAGS(sv) |= (SvFLAGS(*svp)
6983 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6991 o->op_seq = PL_op_seqmax++;
7001 /* Efficient sub that returns a constant scalar value. */
7003 const_sv_xsub(pTHXo_ CV* cv)
7008 Perl_croak(aTHX_ "usage: %s::%s()",
7009 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7013 ST(0) = (SV*)XSANY.any_ptr;