3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 /* #define PL_OP_SLAB_ALLOC */
25 #ifdef PL_OP_SLAB_ALLOC
26 #define SLAB_SIZE 8192
27 static char *PL_OpPtr = NULL;
28 static int PL_OpSpace = 0;
29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
30 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
32 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
36 S_Slab_Alloc(pTHX_ int m, size_t sz)
38 Newz(m,PL_OpPtr,SLAB_SIZE,char);
39 PL_OpSpace = SLAB_SIZE - sz;
40 return PL_OpPtr += PL_OpSpace;
44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
47 * In the following definition, the ", Nullop" is just to make the compiler
48 * think the expression is of the right type: croak actually does a Siglongjmp.
50 #define CHECKOP(type,o) \
51 ((PL_op_mask && PL_op_mask[type]) \
52 ? ( op_free((OP*)o), \
53 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
55 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
57 #define PAD_MAX 999999999
58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
61 S_gv_ename(pTHX_ GV *gv)
64 SV* tmpsv = sv_newmortal();
65 gv_efullname3(tmpsv, gv, Nullch);
66 return SvPV(tmpsv,n_a);
70 S_no_fh_allowed(pTHX_ OP *o)
72 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
73 PL_op_desc[o->op_type]));
78 S_too_few_arguments(pTHX_ OP *o, char *name)
80 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
85 S_too_many_arguments(pTHX_ OP *o, char *name)
87 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
94 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
95 (int)n, name, t, PL_op_desc[kid->op_type]));
99 S_no_bareword_allowed(pTHX_ OP *o)
101 qerror(Perl_mess(aTHX_
102 "Bareword \"%s\" not allowed while \"strict subs\" in use",
103 SvPV_nolen(cSVOPo_sv)));
106 /* "register" allocation */
109 Perl_pad_allocmy(pTHX_ char *name)
114 if (!(PL_in_my == KEY_our ||
116 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
117 (name[1] == '_' && (int)strlen(name) > 2)))
119 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
120 /* 1999-02-27 mjd@plover.com */
122 p = strchr(name, '\0');
123 /* The next block assumes the buffer is at least 205 chars
124 long. At present, it's always at least 256 chars. */
126 strcpy(name+200, "...");
132 /* Move everything else down one character */
133 for (; p-name > 2; p--)
135 name[2] = toCTRL(name[1]);
138 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
140 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
141 SV **svp = AvARRAY(PL_comppad_name);
142 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
143 PADOFFSET top = AvFILLp(PL_comppad_name);
144 for (off = top; off > PL_comppad_name_floor; off--) {
146 && sv != &PL_sv_undef
147 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
148 && (PL_in_my != KEY_our
149 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
150 && strEQ(name, SvPVX(sv)))
152 Perl_warner(aTHX_ WARN_MISC,
153 "\"%s\" variable %s masks earlier declaration in same %s",
154 (PL_in_my == KEY_our ? "our" : "my"),
156 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
161 if (PL_in_my == KEY_our) {
164 && sv != &PL_sv_undef
165 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
166 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
167 && strEQ(name, SvPVX(sv)))
169 Perl_warner(aTHX_ WARN_MISC,
170 "\"our\" variable %s redeclared", name);
171 Perl_warner(aTHX_ WARN_MISC,
172 "\t(Did you mean \"local\" instead of \"our\"?)\n");
175 } while ( off-- > 0 );
178 off = pad_alloc(OP_PADSV, SVs_PADMY);
180 sv_upgrade(sv, SVt_PVNV);
182 if (PL_in_my_stash) {
184 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
185 name, PL_in_my == KEY_our ? "our" : "my"));
187 (void)SvUPGRADE(sv, SVt_PVMG);
188 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
191 if (PL_in_my == KEY_our) {
192 (void)SvUPGRADE(sv, SVt_PVGV);
193 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
194 SvFLAGS(sv) |= SVpad_OUR;
196 av_store(PL_comppad_name, off, sv);
197 SvNVX(sv) = (NV)PAD_MAX;
198 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
199 if (!PL_min_intro_pending)
200 PL_min_intro_pending = off;
201 PL_max_intro_pending = off;
203 av_store(PL_comppad, off, (SV*)newAV());
204 else if (*name == '%')
205 av_store(PL_comppad, off, (SV*)newHV());
206 SvPADMY_on(PL_curpad[off]);
211 S_pad_addlex(pTHX_ SV *proto_namesv)
213 SV *namesv = NEWSV(1103,0);
214 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
215 sv_upgrade(namesv, SVt_PVNV);
216 sv_setpv(namesv, SvPVX(proto_namesv));
217 av_store(PL_comppad_name, newoff, namesv);
218 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
219 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
220 SvFAKE_on(namesv); /* A ref, not a real var */
221 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
222 SvFLAGS(namesv) |= SVpad_OUR;
223 (void)SvUPGRADE(namesv, SVt_PVGV);
224 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
226 if (SvOBJECT(proto_namesv)) { /* A typed var */
228 (void)SvUPGRADE(namesv, SVt_PVMG);
229 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
235 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
238 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
239 I32 cx_ix, I32 saweval, U32 flags)
245 register PERL_CONTEXT *cx;
247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
252 if (!svp || *svp == &PL_sv_undef)
255 svp = AvARRAY(curname);
256 for (off = AvFILLp(curname); off > 0; off--) {
257 if ((sv = svp[off]) &&
258 sv != &PL_sv_undef &&
260 seq > I_32(SvNVX(sv)) &&
261 strEQ(SvPVX(sv), name))
272 return 0; /* don't clone from inactive stack frame */
276 oldpad = (AV*)AvARRAY(curlist)[depth];
277 oldsv = *av_fetch(oldpad, off, TRUE);
278 if (!newoff) { /* Not a mere clone operation. */
279 newoff = pad_addlex(sv);
280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
281 /* "It's closures all the way down." */
282 CvCLONE_on(PL_compcv);
284 if (CvANON(PL_compcv))
285 oldsv = Nullsv; /* no need to keep ref */
290 bcv && bcv != cv && !CvCLONE(bcv);
291 bcv = CvOUTSIDE(bcv))
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
314 Perl_warner(aTHX_ WARN_CLOSURE,
315 "Variable \"%s\" may be unavailable",
323 else if (!CvUNIQUE(PL_compcv)) {
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
327 Perl_warner(aTHX_ WARN_CLOSURE,
328 "Variable \"%s\" will not stay shared", name);
332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
338 if (flags & FINDLEX_NOSEARCH)
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
346 for (i = cx_ix; i >= 0; i--) {
348 switch (CxTYPE(cx)) {
350 if (i == 0 && saweval) {
351 seq = cxstack[saweval].blk_oldcop->cop_seq;
352 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
356 switch (cx->blk_eval.old_op_type) {
363 /* require/do must have their own scope */
372 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
373 saweval = i; /* so we know where we were called from */
376 seq = cxstack[saweval].blk_oldcop->cop_seq;
377 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
385 Perl_pad_findmy(pTHX_ char *name)
390 SV **svp = AvARRAY(PL_comppad_name);
391 U32 seq = PL_cop_seqmax;
397 * Special case to get lexical (and hence per-thread) @_.
398 * XXX I need to find out how to tell at parse-time whether use
399 * of @_ should refer to a lexical (from a sub) or defgv (global
400 * scope and maybe weird sub-ish things like formats). See
401 * startsub in perly.y. It's possible that @_ could be lexical
402 * (at least from subs) even in non-threaded perl.
404 if (strEQ(name, "@_"))
405 return 0; /* success. (NOT_IN_PAD indicates failure) */
406 #endif /* USE_THREADS */
408 /* The one we're looking for is probably just before comppad_name_fill. */
409 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
410 if ((sv = svp[off]) &&
411 sv != &PL_sv_undef &&
414 seq > I_32(SvNVX(sv)))) &&
415 strEQ(SvPVX(sv), name))
417 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
418 return (PADOFFSET)off;
419 pendoff = off; /* this pending def. will override import */
423 outside = CvOUTSIDE(PL_compcv);
425 /* Check if if we're compiling an eval'', and adjust seq to be the
426 * eval's seq number. This depends on eval'' having a non-null
427 * CvOUTSIDE() while it is being compiled. The eval'' itself is
428 * identified by CvEVAL being true and CvGV being null. */
429 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
430 cx = &cxstack[cxstack_ix];
432 seq = cx->blk_oldcop->cop_seq;
435 /* See if it's in a nested scope */
436 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
438 /* If there is a pending local definition, this new alias must die */
440 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
441 return off; /* pad_findlex returns 0 for failure...*/
443 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
447 Perl_pad_leavemy(pTHX_ I32 fill)
450 SV **svp = AvARRAY(PL_comppad_name);
452 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
453 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
454 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
455 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
458 /* "Deintroduce" my variables that are leaving with this scope. */
459 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
460 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
461 SvIVX(sv) = PL_cop_seqmax;
466 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
471 if (AvARRAY(PL_comppad) != PL_curpad)
472 Perl_croak(aTHX_ "panic: pad_alloc");
473 if (PL_pad_reset_pending)
475 if (tmptype & SVs_PADMY) {
477 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
478 } while (SvPADBUSY(sv)); /* need a fresh one */
479 retval = AvFILLp(PL_comppad);
482 SV **names = AvARRAY(PL_comppad_name);
483 SSize_t names_fill = AvFILLp(PL_comppad_name);
486 * "foreach" index vars temporarily become aliases to non-"my"
487 * values. Thus we must skip, not just pad values that are
488 * marked as current pad values, but also those with names.
490 if (++PL_padix <= names_fill &&
491 (sv = names[PL_padix]) && sv != &PL_sv_undef)
493 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
494 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
495 !IS_PADGV(sv) && !IS_PADCONST(sv))
500 SvFLAGS(sv) |= tmptype;
501 PL_curpad = AvARRAY(PL_comppad);
503 DEBUG_X(PerlIO_printf(Perl_debug_log,
504 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
505 PTR2UV(thr), PTR2UV(PL_curpad),
506 (long) retval, PL_op_name[optype]));
508 DEBUG_X(PerlIO_printf(Perl_debug_log,
509 "Pad 0x%"UVxf" alloc %ld for %s\n",
511 (long) retval, PL_op_name[optype]));
512 #endif /* USE_THREADS */
513 return (PADOFFSET)retval;
517 Perl_pad_sv(pTHX_ PADOFFSET po)
520 DEBUG_X(PerlIO_printf(Perl_debug_log,
521 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
522 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
525 Perl_croak(aTHX_ "panic: pad_sv po");
526 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
527 PTR2UV(PL_curpad), (IV)po));
528 #endif /* USE_THREADS */
529 return PL_curpad[po]; /* eventually we'll turn this into a macro */
533 Perl_pad_free(pTHX_ PADOFFSET po)
537 if (AvARRAY(PL_comppad) != PL_curpad)
538 Perl_croak(aTHX_ "panic: pad_free curpad");
540 Perl_croak(aTHX_ "panic: pad_free po");
542 DEBUG_X(PerlIO_printf(Perl_debug_log,
543 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
544 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
546 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
547 PTR2UV(PL_curpad), (IV)po));
548 #endif /* USE_THREADS */
549 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
550 SvPADTMP_off(PL_curpad[po]);
552 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
555 if ((I32)po < PL_padix)
560 Perl_pad_swipe(pTHX_ PADOFFSET po)
562 if (AvARRAY(PL_comppad) != PL_curpad)
563 Perl_croak(aTHX_ "panic: pad_swipe curpad");
565 Perl_croak(aTHX_ "panic: pad_swipe po");
567 DEBUG_X(PerlIO_printf(Perl_debug_log,
568 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
569 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
571 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
572 PTR2UV(PL_curpad), (IV)po));
573 #endif /* USE_THREADS */
574 SvPADTMP_off(PL_curpad[po]);
575 PL_curpad[po] = NEWSV(1107,0);
576 SvPADTMP_on(PL_curpad[po]);
577 if ((I32)po < PL_padix)
581 /* XXX pad_reset() is currently disabled because it results in serious bugs.
582 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
583 * on the stack by OPs that use them, there are several ways to get an alias
584 * to a shared TARG. Such an alias will change randomly and unpredictably.
585 * We avoid doing this until we can think of a Better Way.
590 #ifdef USE_BROKEN_PAD_RESET
593 if (AvARRAY(PL_comppad) != PL_curpad)
594 Perl_croak(aTHX_ "panic: pad_reset curpad");
596 DEBUG_X(PerlIO_printf(Perl_debug_log,
597 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
598 PTR2UV(thr), PTR2UV(PL_curpad)));
600 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
602 #endif /* USE_THREADS */
603 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
604 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
605 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
606 SvPADTMP_off(PL_curpad[po]);
608 PL_padix = PL_padix_floor;
611 PL_pad_reset_pending = FALSE;
615 /* find_threadsv is not reentrant */
617 Perl_find_threadsv(pTHX_ const char *name)
622 /* We currently only handle names of a single character */
623 p = strchr(PL_threadsv_names, *name);
626 key = p - PL_threadsv_names;
627 MUTEX_LOCK(&thr->mutex);
628 svp = av_fetch(thr->threadsv, key, FALSE);
630 MUTEX_UNLOCK(&thr->mutex);
632 SV *sv = NEWSV(0, 0);
633 av_store(thr->threadsv, key, sv);
634 thr->threadsvp = AvARRAY(thr->threadsv);
635 MUTEX_UNLOCK(&thr->mutex);
637 * Some magic variables used to be automagically initialised
638 * in gv_fetchpv. Those which are now per-thread magicals get
639 * initialised here instead.
645 sv_setpv(sv, "\034");
646 sv_magic(sv, 0, 0, name, 1);
651 PL_sawampersand = TRUE;
665 /* XXX %! tied to Errno.pm needs to be added here.
666 * See gv_fetchpv(). */
670 sv_magic(sv, 0, 0, name, 1);
672 DEBUG_S(PerlIO_printf(Perl_error_log,
673 "find_threadsv: new SV %p for $%s%c\n",
674 sv, (*name < 32) ? "^" : "",
675 (*name < 32) ? toCTRL(*name) : *name));
679 #endif /* USE_THREADS */
684 Perl_op_free(pTHX_ OP *o)
686 register OP *kid, *nextkid;
689 if (!o || o->op_seq == (U16)-1)
692 if (o->op_private & OPpREFCOUNTED) {
693 switch (o->op_type) {
701 if (OpREFCNT_dec(o)) {
712 if (o->op_flags & OPf_KIDS) {
713 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
714 nextkid = kid->op_sibling; /* Get before next freeing kid */
722 /* COP* is not cleared by op_clear() so that we may track line
723 * numbers etc even after null() */
724 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
729 #ifdef PL_OP_SLAB_ALLOC
730 if ((char *) o == PL_OpPtr)
739 S_op_clear(pTHX_ OP *o)
741 switch (o->op_type) {
742 case OP_NULL: /* Was holding old type, if any. */
743 case OP_ENTEREVAL: /* Was holding hints. */
745 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
751 if (!(o->op_flags & OPf_SPECIAL))
754 #endif /* USE_THREADS */
756 if (!(o->op_flags & OPf_REF)
757 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
764 if (cPADOPo->op_padix > 0) {
767 pad_swipe(cPADOPo->op_padix);
768 /* No GvIN_PAD_off(gv) here, because other references may still
769 * exist on the pad */
772 cPADOPo->op_padix = 0;
775 SvREFCNT_dec(cSVOPo->op_sv);
776 cSVOPo->op_sv = Nullsv;
779 case OP_METHOD_NAMED:
781 SvREFCNT_dec(cSVOPo->op_sv);
782 cSVOPo->op_sv = Nullsv;
788 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
792 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
793 SvREFCNT_dec(cSVOPo->op_sv);
794 cSVOPo->op_sv = Nullsv;
797 Safefree(cPVOPo->op_pv);
798 cPVOPo->op_pv = Nullch;
802 op_free(cPMOPo->op_pmreplroot);
806 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
808 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
809 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
810 /* No GvIN_PAD_off(gv) here, because other references may still
811 * exist on the pad */
816 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
823 HV *pmstash = PmopSTASH(cPMOPo);
824 if (pmstash && SvREFCNT(pmstash)) {
825 PMOP *pmop = HvPMROOT(pmstash);
826 PMOP *lastpmop = NULL;
828 if (cPMOPo == pmop) {
830 lastpmop->op_pmnext = pmop->op_pmnext;
832 HvPMROOT(pmstash) = pmop->op_pmnext;
836 pmop = pmop->op_pmnext;
839 Safefree(PmopSTASHPV(cPMOPo));
841 /* NOTE: PMOP.op_pmstash is not refcounted */
845 cPMOPo->op_pmreplroot = Nullop;
846 ReREFCNT_dec(cPMOPo->op_pmregexp);
847 cPMOPo->op_pmregexp = (REGEXP*)NULL;
851 if (o->op_targ > 0) {
852 pad_free(o->op_targ);
858 S_cop_free(pTHX_ COP* cop)
860 Safefree(cop->cop_label);
862 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
863 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
865 /* NOTE: COP.cop_stash is not refcounted */
866 SvREFCNT_dec(CopFILEGV(cop));
868 if (! specialWARN(cop->cop_warnings))
869 SvREFCNT_dec(cop->cop_warnings);
870 if (! specialCopIO(cop->cop_io))
871 SvREFCNT_dec(cop->cop_io);
877 if (o->op_type == OP_NULL)
880 o->op_targ = o->op_type;
881 o->op_type = OP_NULL;
882 o->op_ppaddr = PL_ppaddr[OP_NULL];
885 /* Contextualizers */
887 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
890 Perl_linklist(pTHX_ OP *o)
897 /* establish postfix order */
898 if (cUNOPo->op_first) {
899 o->op_next = LINKLIST(cUNOPo->op_first);
900 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
902 kid->op_next = LINKLIST(kid->op_sibling);
914 Perl_scalarkids(pTHX_ OP *o)
917 if (o && o->op_flags & OPf_KIDS) {
918 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
925 S_scalarboolean(pTHX_ OP *o)
927 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
928 if (ckWARN(WARN_SYNTAX)) {
929 line_t oldline = CopLINE(PL_curcop);
931 if (PL_copline != NOLINE)
932 CopLINE_set(PL_curcop, PL_copline);
933 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
934 CopLINE_set(PL_curcop, oldline);
941 Perl_scalar(pTHX_ OP *o)
945 /* assumes no premature commitment */
946 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
947 || o->op_type == OP_RETURN)
952 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
954 switch (o->op_type) {
956 scalar(cBINOPo->op_first);
961 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
965 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
966 if (!kPMOP->op_pmreplroot)
967 deprecate("implicit split to @_");
975 if (o->op_flags & OPf_KIDS) {
976 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
982 kid = cLISTOPo->op_first;
984 while ((kid = kid->op_sibling)) {
990 WITH_THR(PL_curcop = &PL_compiling);
995 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1001 WITH_THR(PL_curcop = &PL_compiling);
1008 Perl_scalarvoid(pTHX_ OP *o)
1015 if (o->op_type == OP_NEXTSTATE
1016 || o->op_type == OP_SETSTATE
1017 || o->op_type == OP_DBSTATE
1018 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1019 || o->op_targ == OP_SETSTATE
1020 || o->op_targ == OP_DBSTATE)))
1021 PL_curcop = (COP*)o; /* for warning below */
1023 /* assumes no premature commitment */
1024 want = o->op_flags & OPf_WANT;
1025 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1026 || o->op_type == OP_RETURN)
1031 if ((o->op_private & OPpTARGET_MY)
1032 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1034 return scalar(o); /* As if inside SASSIGN */
1037 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1039 switch (o->op_type) {
1041 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1045 if (o->op_flags & OPf_STACKED)
1049 if (o->op_private == 4)
1091 case OP_GETSOCKNAME:
1092 case OP_GETPEERNAME:
1097 case OP_GETPRIORITY:
1120 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1121 useless = PL_op_desc[o->op_type];
1128 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1129 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1130 useless = "a variable";
1135 if (cSVOPo->op_private & OPpCONST_STRICT)
1136 no_bareword_allowed(o);
1138 if (ckWARN(WARN_VOID)) {
1139 useless = "a constant";
1140 /* the constants 0 and 1 are permitted as they are
1141 conventionally used as dummies in constructs like
1142 1 while some_condition_with_side_effects; */
1143 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1145 else if (SvPOK(sv)) {
1146 /* perl4's way of mixing documentation and code
1147 (before the invention of POD) was based on a
1148 trick to mix nroff and perl code. The trick was
1149 built upon these three nroff macros being used in
1150 void context. The pink camel has the details in
1151 the script wrapman near page 319. */
1152 if (strnEQ(SvPVX(sv), "di", 2) ||
1153 strnEQ(SvPVX(sv), "ds", 2) ||
1154 strnEQ(SvPVX(sv), "ig", 2))
1159 null(o); /* don't execute or even remember it */
1163 o->op_type = OP_PREINC; /* pre-increment is faster */
1164 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1168 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1169 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1175 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1180 if (o->op_flags & OPf_STACKED)
1187 if (!(o->op_flags & OPf_KIDS))
1196 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1203 /* all requires must return a boolean value */
1204 o->op_flags &= ~OPf_WANT;
1209 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1210 if (!kPMOP->op_pmreplroot)
1211 deprecate("implicit split to @_");
1215 if (useless && ckWARN(WARN_VOID))
1216 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1221 Perl_listkids(pTHX_ OP *o)
1224 if (o && o->op_flags & OPf_KIDS) {
1225 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1232 Perl_list(pTHX_ OP *o)
1236 /* assumes no premature commitment */
1237 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1238 || o->op_type == OP_RETURN)
1243 if ((o->op_private & OPpTARGET_MY)
1244 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1246 return o; /* As if inside SASSIGN */
1249 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1251 switch (o->op_type) {
1254 list(cBINOPo->op_first);
1259 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1267 if (!(o->op_flags & OPf_KIDS))
1269 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1270 list(cBINOPo->op_first);
1271 return gen_constant_list(o);
1278 kid = cLISTOPo->op_first;
1280 while ((kid = kid->op_sibling)) {
1281 if (kid->op_sibling)
1286 WITH_THR(PL_curcop = &PL_compiling);
1290 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1291 if (kid->op_sibling)
1296 WITH_THR(PL_curcop = &PL_compiling);
1299 /* all requires must return a boolean value */
1300 o->op_flags &= ~OPf_WANT;
1307 Perl_scalarseq(pTHX_ OP *o)
1312 if (o->op_type == OP_LINESEQ ||
1313 o->op_type == OP_SCOPE ||
1314 o->op_type == OP_LEAVE ||
1315 o->op_type == OP_LEAVETRY)
1317 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1318 if (kid->op_sibling) {
1322 PL_curcop = &PL_compiling;
1324 o->op_flags &= ~OPf_PARENS;
1325 if (PL_hints & HINT_BLOCK_SCOPE)
1326 o->op_flags |= OPf_PARENS;
1329 o = newOP(OP_STUB, 0);
1334 S_modkids(pTHX_ OP *o, I32 type)
1337 if (o && o->op_flags & OPf_KIDS) {
1338 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1345 Perl_mod(pTHX_ OP *o, I32 type)
1350 if (!o || PL_error_count)
1353 if ((o->op_private & OPpTARGET_MY)
1354 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1359 switch (o->op_type) {
1364 if (!(o->op_private & (OPpCONST_ARYBASE)))
1366 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1367 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1371 SAVEI32(PL_compiling.cop_arybase);
1372 PL_compiling.cop_arybase = 0;
1374 else if (type == OP_REFGEN)
1377 Perl_croak(aTHX_ "That use of $[ is unsupported");
1380 if (o->op_flags & OPf_PARENS)
1384 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1385 !(o->op_flags & OPf_STACKED)) {
1386 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1387 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1388 assert(cUNOPo->op_first->op_type == OP_NULL);
1389 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1392 else { /* lvalue subroutine call */
1393 o->op_private |= OPpLVAL_INTRO;
1394 PL_modcount = RETURN_UNLIMITED_NUMBER;
1395 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1396 /* Backward compatibility mode: */
1397 o->op_private |= OPpENTERSUB_INARGS;
1400 else { /* Compile-time error message: */
1401 OP *kid = cUNOPo->op_first;
1405 if (kid->op_type == OP_PUSHMARK)
1407 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1409 "panic: unexpected lvalue entersub "
1410 "args: type/targ %ld:%ld",
1411 (long)kid->op_type,kid->op_targ);
1412 kid = kLISTOP->op_first;
1414 while (kid->op_sibling)
1415 kid = kid->op_sibling;
1416 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1418 if (kid->op_type == OP_METHOD_NAMED
1419 || kid->op_type == OP_METHOD)
1423 if (kid->op_sibling || kid->op_next != kid) {
1424 yyerror("panic: unexpected optree near method call");
1428 NewOp(1101, newop, 1, UNOP);
1429 newop->op_type = OP_RV2CV;
1430 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1431 newop->op_first = Nullop;
1432 newop->op_next = (OP*)newop;
1433 kid->op_sibling = (OP*)newop;
1434 newop->op_private |= OPpLVAL_INTRO;
1438 if (kid->op_type != OP_RV2CV)
1440 "panic: unexpected lvalue entersub "
1441 "entry via type/targ %ld:%ld",
1442 (long)kid->op_type,kid->op_targ);
1443 kid->op_private |= OPpLVAL_INTRO;
1444 break; /* Postpone until runtime */
1448 kid = kUNOP->op_first;
1449 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1450 kid = kUNOP->op_first;
1451 if (kid->op_type == OP_NULL)
1453 "Unexpected constant lvalue entersub "
1454 "entry via type/targ %ld:%ld",
1455 (long)kid->op_type,kid->op_targ);
1456 if (kid->op_type != OP_GV) {
1457 /* Restore RV2CV to check lvalueness */
1459 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1460 okid->op_next = kid->op_next;
1461 kid->op_next = okid;
1464 okid->op_next = Nullop;
1465 okid->op_type = OP_RV2CV;
1467 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1468 okid->op_private |= OPpLVAL_INTRO;
1472 cv = GvCV(kGVOP_gv);
1482 /* grep, foreach, subcalls, refgen */
1483 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1485 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1486 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1488 : (o->op_type == OP_ENTERSUB
1489 ? "non-lvalue subroutine call"
1490 : PL_op_desc[o->op_type])),
1491 type ? PL_op_desc[type] : "local"));
1505 case OP_RIGHT_SHIFT:
1514 if (!(o->op_flags & OPf_STACKED))
1520 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1526 if (!type && cUNOPo->op_first->op_type != OP_GV)
1527 Perl_croak(aTHX_ "Can't localize through a reference");
1528 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1529 PL_modcount = RETURN_UNLIMITED_NUMBER;
1530 return o; /* Treat \(@foo) like ordinary list. */
1534 if (scalar_mod_type(o, type))
1536 ref(cUNOPo->op_first, o->op_type);
1540 if (type == OP_LEAVESUBLV)
1541 o->op_private |= OPpMAYBE_LVSUB;
1547 PL_modcount = RETURN_UNLIMITED_NUMBER;
1550 if (!type && cUNOPo->op_first->op_type != OP_GV)
1551 Perl_croak(aTHX_ "Can't localize through a reference");
1552 ref(cUNOPo->op_first, o->op_type);
1556 PL_hints |= HINT_BLOCK_SCOPE;
1566 PL_modcount = RETURN_UNLIMITED_NUMBER;
1567 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1568 return o; /* Treat \(@foo) like ordinary list. */
1569 if (scalar_mod_type(o, type))
1571 if (type == OP_LEAVESUBLV)
1572 o->op_private |= OPpMAYBE_LVSUB;
1577 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1578 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1583 PL_modcount++; /* XXX ??? */
1585 #endif /* USE_THREADS */
1591 if (type != OP_SASSIGN)
1595 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1600 if (type == OP_LEAVESUBLV)
1601 o->op_private |= OPpMAYBE_LVSUB;
1603 pad_free(o->op_targ);
1604 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1605 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1606 if (o->op_flags & OPf_KIDS)
1607 mod(cBINOPo->op_first->op_sibling, type);
1612 ref(cBINOPo->op_first, o->op_type);
1613 if (type == OP_ENTERSUB &&
1614 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1615 o->op_private |= OPpLVAL_DEFER;
1616 if (type == OP_LEAVESUBLV)
1617 o->op_private |= OPpMAYBE_LVSUB;
1625 if (o->op_flags & OPf_KIDS)
1626 mod(cLISTOPo->op_last, type);
1630 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1632 else if (!(o->op_flags & OPf_KIDS))
1634 if (o->op_targ != OP_LIST) {
1635 mod(cBINOPo->op_first, type);
1640 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1645 if (type != OP_LEAVESUBLV)
1647 break; /* mod()ing was handled by ck_return() */
1649 if (type != OP_LEAVESUBLV)
1650 o->op_flags |= OPf_MOD;
1652 if (type == OP_AASSIGN || type == OP_SASSIGN)
1653 o->op_flags |= OPf_SPECIAL|OPf_REF;
1655 o->op_private |= OPpLVAL_INTRO;
1656 o->op_flags &= ~OPf_SPECIAL;
1657 PL_hints |= HINT_BLOCK_SCOPE;
1659 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1660 && type != OP_LEAVESUBLV)
1661 o->op_flags |= OPf_REF;
1666 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1670 if (o->op_type == OP_RV2GV)
1694 case OP_RIGHT_SHIFT:
1713 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1715 switch (o->op_type) {
1723 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1736 Perl_refkids(pTHX_ OP *o, I32 type)
1739 if (o && o->op_flags & OPf_KIDS) {
1740 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1747 Perl_ref(pTHX_ OP *o, I32 type)
1751 if (!o || PL_error_count)
1754 switch (o->op_type) {
1756 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1757 !(o->op_flags & OPf_STACKED)) {
1758 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1759 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1760 assert(cUNOPo->op_first->op_type == OP_NULL);
1761 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1762 o->op_flags |= OPf_SPECIAL;
1767 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1771 if (type == OP_DEFINED)
1772 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1773 ref(cUNOPo->op_first, o->op_type);
1776 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1777 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1778 : type == OP_RV2HV ? OPpDEREF_HV
1780 o->op_flags |= OPf_MOD;
1785 o->op_flags |= OPf_MOD; /* XXX ??? */
1790 o->op_flags |= OPf_REF;
1793 if (type == OP_DEFINED)
1794 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1795 ref(cUNOPo->op_first, o->op_type);
1800 o->op_flags |= OPf_REF;
1805 if (!(o->op_flags & OPf_KIDS))
1807 ref(cBINOPo->op_first, type);
1811 ref(cBINOPo->op_first, o->op_type);
1812 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1813 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1814 : type == OP_RV2HV ? OPpDEREF_HV
1816 o->op_flags |= OPf_MOD;
1824 if (!(o->op_flags & OPf_KIDS))
1826 ref(cLISTOPo->op_last, type);
1836 S_dup_attrlist(pTHX_ OP *o)
1840 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1841 * where the first kid is OP_PUSHMARK and the remaining ones
1842 * are OP_CONST. We need to push the OP_CONST values.
1844 if (o->op_type == OP_CONST)
1845 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1847 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1848 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1849 if (o->op_type == OP_CONST)
1850 rop = append_elem(OP_LIST, rop,
1851 newSVOP(OP_CONST, o->op_flags,
1852 SvREFCNT_inc(cSVOPo->op_sv)));
1859 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1863 /* fake up C<use attributes $pkg,$rv,@attrs> */
1864 ENTER; /* need to protect against side-effects of 'use' */
1866 if (stash && HvNAME(stash))
1867 stashsv = newSVpv(HvNAME(stash), 0);
1869 stashsv = &PL_sv_no;
1871 #define ATTRSMODULE "attributes"
1873 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1874 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1876 prepend_elem(OP_LIST,
1877 newSVOP(OP_CONST, 0, stashsv),
1878 prepend_elem(OP_LIST,
1879 newSVOP(OP_CONST, 0,
1881 dup_attrlist(attrs))));
1886 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1887 char *attrstr, STRLEN len)
1892 len = strlen(attrstr);
1896 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1898 char *sstr = attrstr;
1899 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1900 attrs = append_elem(OP_LIST, attrs,
1901 newSVOP(OP_CONST, 0,
1902 newSVpvn(sstr, attrstr-sstr)));
1906 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1907 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1908 Nullsv, prepend_elem(OP_LIST,
1909 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1910 prepend_elem(OP_LIST,
1911 newSVOP(OP_CONST, 0,
1917 S_my_kid(pTHX_ OP *o, OP *attrs)
1922 if (!o || PL_error_count)
1926 if (type == OP_LIST) {
1927 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1929 } else if (type == OP_UNDEF) {
1931 } else if (type == OP_RV2SV || /* "our" declaration */
1933 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1935 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1937 PL_in_my_stash = Nullhv;
1938 apply_attrs(GvSTASH(gv),
1939 (type == OP_RV2SV ? GvSV(gv) :
1940 type == OP_RV2AV ? (SV*)GvAV(gv) :
1941 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1944 o->op_private |= OPpOUR_INTRO;
1946 } else if (type != OP_PADSV &&
1949 type != OP_PUSHMARK)
1951 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1952 PL_op_desc[o->op_type],
1953 PL_in_my == KEY_our ? "our" : "my"));
1956 else if (attrs && type != OP_PUSHMARK) {
1962 PL_in_my_stash = Nullhv;
1964 /* check for C<my Dog $spot> when deciding package */
1965 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1966 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1967 stash = SvSTASH(*namesvp);
1969 stash = PL_curstash;
1970 padsv = PAD_SV(o->op_targ);
1971 apply_attrs(stash, padsv, attrs);
1973 o->op_flags |= OPf_MOD;
1974 o->op_private |= OPpLVAL_INTRO;
1979 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1981 if (o->op_flags & OPf_PARENS)
1985 o = my_kid(o, attrs);
1987 PL_in_my_stash = Nullhv;
1992 Perl_my(pTHX_ OP *o)
1994 return my_kid(o, Nullop);
1998 Perl_sawparens(pTHX_ OP *o)
2001 o->op_flags |= OPf_PARENS;
2006 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2010 if (ckWARN(WARN_MISC) &&
2011 (left->op_type == OP_RV2AV ||
2012 left->op_type == OP_RV2HV ||
2013 left->op_type == OP_PADAV ||
2014 left->op_type == OP_PADHV)) {
2015 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2016 right->op_type == OP_TRANS)
2017 ? right->op_type : OP_MATCH];
2018 const char *sample = ((left->op_type == OP_RV2AV ||
2019 left->op_type == OP_PADAV)
2020 ? "@array" : "%hash");
2021 Perl_warner(aTHX_ WARN_MISC,
2022 "Applying %s to %s will act on scalar(%s)",
2023 desc, sample, sample);
2026 if (!(right->op_flags & OPf_STACKED) &&
2027 (right->op_type == OP_MATCH ||
2028 right->op_type == OP_SUBST ||
2029 right->op_type == OP_TRANS)) {
2030 right->op_flags |= OPf_STACKED;
2031 if (right->op_type != OP_MATCH &&
2032 ! (right->op_type == OP_TRANS &&
2033 right->op_private & OPpTRANS_IDENTICAL))
2034 left = mod(left, right->op_type);
2035 if (right->op_type == OP_TRANS)
2036 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2038 o = prepend_elem(right->op_type, scalar(left), right);
2040 return newUNOP(OP_NOT, 0, scalar(o));
2044 return bind_match(type, left,
2045 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2049 Perl_invert(pTHX_ OP *o)
2053 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2054 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2058 Perl_scope(pTHX_ OP *o)
2061 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2062 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2063 o->op_type = OP_LEAVE;
2064 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2067 if (o->op_type == OP_LINESEQ) {
2069 o->op_type = OP_SCOPE;
2070 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2071 kid = ((LISTOP*)o)->op_first;
2072 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2076 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2083 Perl_save_hints(pTHX)
2086 SAVESPTR(GvHV(PL_hintgv));
2087 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2088 SAVEFREESV(GvHV(PL_hintgv));
2092 Perl_block_start(pTHX_ int full)
2094 int retval = PL_savestack_ix;
2096 SAVEI32(PL_comppad_name_floor);
2097 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2099 PL_comppad_name_fill = PL_comppad_name_floor;
2100 if (PL_comppad_name_floor < 0)
2101 PL_comppad_name_floor = 0;
2102 SAVEI32(PL_min_intro_pending);
2103 SAVEI32(PL_max_intro_pending);
2104 PL_min_intro_pending = 0;
2105 SAVEI32(PL_comppad_name_fill);
2106 SAVEI32(PL_padix_floor);
2107 PL_padix_floor = PL_padix;
2108 PL_pad_reset_pending = FALSE;
2110 PL_hints &= ~HINT_BLOCK_SCOPE;
2111 SAVESPTR(PL_compiling.cop_warnings);
2112 if (! specialWARN(PL_compiling.cop_warnings)) {
2113 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2114 SAVEFREESV(PL_compiling.cop_warnings) ;
2116 SAVESPTR(PL_compiling.cop_io);
2117 if (! specialCopIO(PL_compiling.cop_io)) {
2118 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2119 SAVEFREESV(PL_compiling.cop_io) ;
2125 Perl_block_end(pTHX_ I32 floor, OP *seq)
2127 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2128 OP* retval = scalarseq(seq);
2130 PL_pad_reset_pending = FALSE;
2131 PL_compiling.op_private = PL_hints;
2133 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2134 pad_leavemy(PL_comppad_name_fill);
2143 OP *o = newOP(OP_THREADSV, 0);
2144 o->op_targ = find_threadsv("_");
2147 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2148 #endif /* USE_THREADS */
2152 Perl_newPROG(pTHX_ OP *o)
2157 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2158 ((PL_in_eval & EVAL_KEEPERR)
2159 ? OPf_SPECIAL : 0), o);
2160 PL_eval_start = linklist(PL_eval_root);
2161 PL_eval_root->op_private |= OPpREFCOUNTED;
2162 OpREFCNT_set(PL_eval_root, 1);
2163 PL_eval_root->op_next = 0;
2164 peep(PL_eval_start);
2169 PL_main_root = scope(sawparens(scalarvoid(o)));
2170 PL_curcop = &PL_compiling;
2171 PL_main_start = LINKLIST(PL_main_root);
2172 PL_main_root->op_private |= OPpREFCOUNTED;
2173 OpREFCNT_set(PL_main_root, 1);
2174 PL_main_root->op_next = 0;
2175 peep(PL_main_start);
2178 /* Register with debugger */
2180 CV *cv = get_cv("DB::postponed", FALSE);
2184 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2186 call_sv((SV*)cv, G_DISCARD);
2193 Perl_localize(pTHX_ OP *o, I32 lex)
2195 if (o->op_flags & OPf_PARENS)
2198 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2200 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2201 if (*s == ';' || *s == '=')
2202 Perl_warner(aTHX_ WARN_PARENTHESIS,
2203 "Parentheses missing around \"%s\" list",
2204 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2210 o = mod(o, OP_NULL); /* a bit kludgey */
2212 PL_in_my_stash = Nullhv;
2217 Perl_jmaybe(pTHX_ OP *o)
2219 if (o->op_type == OP_LIST) {
2222 o2 = newOP(OP_THREADSV, 0);
2223 o2->op_targ = find_threadsv(";");
2225 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2226 #endif /* USE_THREADS */
2227 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2233 Perl_fold_constants(pTHX_ register OP *o)
2236 I32 type = o->op_type;
2239 if (PL_opargs[type] & OA_RETSCALAR)
2241 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2242 o->op_targ = pad_alloc(type, SVs_PADTMP);
2244 /* integerize op, unless it happens to be C<-foo>.
2245 * XXX should pp_i_negate() do magic string negation instead? */
2246 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2247 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2248 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2250 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2253 if (!(PL_opargs[type] & OA_FOLDCONST))
2258 /* XXX might want a ck_negate() for this */
2259 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2272 if (o->op_private & OPpLOCALE)
2277 goto nope; /* Don't try to run w/ errors */
2279 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2280 if ((curop->op_type != OP_CONST ||
2281 (curop->op_private & OPpCONST_BARE)) &&
2282 curop->op_type != OP_LIST &&
2283 curop->op_type != OP_SCALAR &&
2284 curop->op_type != OP_NULL &&
2285 curop->op_type != OP_PUSHMARK)
2291 curop = LINKLIST(o);
2295 sv = *(PL_stack_sp--);
2296 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2297 pad_swipe(o->op_targ);
2298 else if (SvTEMP(sv)) { /* grab mortal temp? */
2299 (void)SvREFCNT_inc(sv);
2303 if (type == OP_RV2GV)
2304 return newGVOP(OP_GV, 0, (GV*)sv);
2306 /* try to smush double to int, but don't smush -2.0 to -2 */
2307 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2310 #ifdef PERL_PRESERVE_IVUV
2311 /* Only bother to attempt to fold to IV if
2312 most operators will benefit */
2316 return newSVOP(OP_CONST, 0, sv);
2320 if (!(PL_opargs[type] & OA_OTHERINT))
2323 if (!(PL_hints & HINT_INTEGER)) {
2324 if (type == OP_MODULO
2325 || type == OP_DIVIDE
2326 || !(o->op_flags & OPf_KIDS))
2331 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2332 if (curop->op_type == OP_CONST) {
2333 if (SvIOK(((SVOP*)curop)->op_sv))
2337 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2341 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2348 Perl_gen_constant_list(pTHX_ register OP *o)
2351 I32 oldtmps_floor = PL_tmps_floor;
2355 return o; /* Don't attempt to run with errors */
2357 PL_op = curop = LINKLIST(o);
2364 PL_tmps_floor = oldtmps_floor;
2366 o->op_type = OP_RV2AV;
2367 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2368 curop = ((UNOP*)o)->op_first;
2369 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2376 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2378 if (!o || o->op_type != OP_LIST)
2379 o = newLISTOP(OP_LIST, 0, o, Nullop);
2381 o->op_flags &= ~OPf_WANT;
2383 if (!(PL_opargs[type] & OA_MARK))
2384 null(cLISTOPo->op_first);
2387 o->op_ppaddr = PL_ppaddr[type];
2388 o->op_flags |= flags;
2390 o = CHECKOP(type, o);
2391 if (o->op_type != type)
2394 return fold_constants(o);
2397 /* List constructors */
2400 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2408 if (first->op_type != type
2409 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2411 return newLISTOP(type, 0, first, last);
2414 if (first->op_flags & OPf_KIDS)
2415 ((LISTOP*)first)->op_last->op_sibling = last;
2417 first->op_flags |= OPf_KIDS;
2418 ((LISTOP*)first)->op_first = last;
2420 ((LISTOP*)first)->op_last = last;
2425 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2433 if (first->op_type != type)
2434 return prepend_elem(type, (OP*)first, (OP*)last);
2436 if (last->op_type != type)
2437 return append_elem(type, (OP*)first, (OP*)last);
2439 first->op_last->op_sibling = last->op_first;
2440 first->op_last = last->op_last;
2441 first->op_flags |= (last->op_flags & OPf_KIDS);
2443 #ifdef PL_OP_SLAB_ALLOC
2451 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2459 if (last->op_type == type) {
2460 if (type == OP_LIST) { /* already a PUSHMARK there */
2461 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2462 ((LISTOP*)last)->op_first->op_sibling = first;
2463 if (!(first->op_flags & OPf_PARENS))
2464 last->op_flags &= ~OPf_PARENS;
2467 if (!(last->op_flags & OPf_KIDS)) {
2468 ((LISTOP*)last)->op_last = first;
2469 last->op_flags |= OPf_KIDS;
2471 first->op_sibling = ((LISTOP*)last)->op_first;
2472 ((LISTOP*)last)->op_first = first;
2474 last->op_flags |= OPf_KIDS;
2478 return newLISTOP(type, 0, first, last);
2484 Perl_newNULLLIST(pTHX)
2486 return newOP(OP_STUB, 0);
2490 Perl_force_list(pTHX_ OP *o)
2492 if (!o || o->op_type != OP_LIST)
2493 o = newLISTOP(OP_LIST, 0, o, Nullop);
2499 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2503 NewOp(1101, listop, 1, LISTOP);
2505 listop->op_type = type;
2506 listop->op_ppaddr = PL_ppaddr[type];
2509 listop->op_flags = flags;
2513 else if (!first && last)
2516 first->op_sibling = last;
2517 listop->op_first = first;
2518 listop->op_last = last;
2519 if (type == OP_LIST) {
2521 pushop = newOP(OP_PUSHMARK, 0);
2522 pushop->op_sibling = first;
2523 listop->op_first = pushop;
2524 listop->op_flags |= OPf_KIDS;
2526 listop->op_last = pushop;
2533 Perl_newOP(pTHX_ I32 type, I32 flags)
2536 NewOp(1101, o, 1, OP);
2538 o->op_ppaddr = PL_ppaddr[type];
2539 o->op_flags = flags;
2542 o->op_private = 0 + (flags >> 8);
2543 if (PL_opargs[type] & OA_RETSCALAR)
2545 if (PL_opargs[type] & OA_TARGET)
2546 o->op_targ = pad_alloc(type, SVs_PADTMP);
2547 return CHECKOP(type, o);
2551 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2556 first = newOP(OP_STUB, 0);
2557 if (PL_opargs[type] & OA_MARK)
2558 first = force_list(first);
2560 NewOp(1101, unop, 1, UNOP);
2561 unop->op_type = type;
2562 unop->op_ppaddr = PL_ppaddr[type];
2563 unop->op_first = first;
2564 unop->op_flags = flags | OPf_KIDS;
2565 unop->op_private = 1 | (flags >> 8);
2566 unop = (UNOP*) CHECKOP(type, unop);
2570 return fold_constants((OP *) unop);
2574 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2577 NewOp(1101, binop, 1, BINOP);
2580 first = newOP(OP_NULL, 0);
2582 binop->op_type = type;
2583 binop->op_ppaddr = PL_ppaddr[type];
2584 binop->op_first = first;
2585 binop->op_flags = flags | OPf_KIDS;
2588 binop->op_private = 1 | (flags >> 8);
2591 binop->op_private = 2 | (flags >> 8);
2592 first->op_sibling = last;
2595 binop = (BINOP*)CHECKOP(type, binop);
2596 if (binop->op_next || binop->op_type != type)
2599 binop->op_last = binop->op_first->op_sibling;
2601 return fold_constants((OP *)binop);
2605 uvcompare(const void *a, const void *b)
2607 if (*((UV *)a) < (*(UV *)b))
2609 if (*((UV *)a) > (*(UV *)b))
2611 if (*((UV *)a+1) < (*(UV *)b+1))
2613 if (*((UV *)a+1) > (*(UV *)b+1))
2619 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2621 SV *tstr = ((SVOP*)expr)->op_sv;
2622 SV *rstr = ((SVOP*)repl)->op_sv;
2625 U8 *t = (U8*)SvPV(tstr, tlen);
2626 U8 *r = (U8*)SvPV(rstr, rlen);
2633 register short *tbl;
2635 PL_hints |= HINT_BLOCK_SCOPE;
2636 complement = o->op_private & OPpTRANS_COMPLEMENT;
2637 del = o->op_private & OPpTRANS_DELETE;
2638 squash = o->op_private & OPpTRANS_SQUASH;
2641 o->op_private |= OPpTRANS_FROM_UTF;
2644 o->op_private |= OPpTRANS_TO_UTF;
2646 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2647 SV* listsv = newSVpvn("# comment\n",10);
2649 U8* tend = t + tlen;
2650 U8* rend = r + rlen;
2664 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2665 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2671 tsave = t = bytes_to_utf8(t, &len);
2674 if (!to_utf && rlen) {
2676 rsave = r = bytes_to_utf8(r, &len);
2680 /* There are several snags with this code on EBCDIC:
2681 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2682 2. scan_const() in toke.c has encoded chars in native encoding which makes
2683 ranges at least in EBCDIC 0..255 range the bottom odd.
2687 U8 tmpbuf[UTF8_MAXLEN+1];
2690 New(1109, cp, 2*tlen, UV);
2692 transv = newSVpvn("",0);
2694 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2696 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2698 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2702 cp[2*i+1] = cp[2*i];
2706 qsort(cp, i, 2*sizeof(UV), uvcompare);
2707 for (j = 0; j < i; j++) {
2709 diff = val - nextmin;
2711 t = uvuni_to_utf8(tmpbuf,nextmin);
2712 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2714 U8 range_mark = UTF_TO_NATIVE(0xff);
2715 t = uvuni_to_utf8(tmpbuf, val - 1);
2716 sv_catpvn(transv, (char *)&range_mark, 1);
2717 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2724 t = uvuni_to_utf8(tmpbuf,nextmin);
2725 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2727 U8 range_mark = UTF_TO_NATIVE(0xff);
2728 sv_catpvn(transv, (char *)&range_mark, 1);
2730 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2731 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2732 t = (U8*)SvPVX(transv);
2733 tlen = SvCUR(transv);
2737 else if (!rlen && !del) {
2738 r = t; rlen = tlen; rend = tend;
2741 if ((!rlen && !del) || t == r ||
2742 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2744 o->op_private |= OPpTRANS_IDENTICAL;
2748 while (t < tend || tfirst <= tlast) {
2749 /* see if we need more "t" chars */
2750 if (tfirst > tlast) {
2751 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2753 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2755 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2762 /* now see if we need more "r" chars */
2763 if (rfirst > rlast) {
2765 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2767 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2769 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2778 rfirst = rlast = 0xffffffff;
2782 /* now see which range will peter our first, if either. */
2783 tdiff = tlast - tfirst;
2784 rdiff = rlast - rfirst;
2791 if (rfirst == 0xffffffff) {
2792 diff = tdiff; /* oops, pretend rdiff is infinite */
2794 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2795 (long)tfirst, (long)tlast);
2797 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2801 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2802 (long)tfirst, (long)(tfirst + diff),
2805 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2806 (long)tfirst, (long)rfirst);
2808 if (rfirst + diff > max)
2809 max = rfirst + diff;
2811 grows = (tfirst < rfirst &&
2812 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2824 else if (max > 0xff)
2829 Safefree(cPVOPo->op_pv);
2830 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2831 SvREFCNT_dec(listsv);
2833 SvREFCNT_dec(transv);
2835 if (!del && havefinal && rlen)
2836 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2837 newSVuv((UV)final), 0);
2840 o->op_private |= OPpTRANS_GROWS;
2852 tbl = (short*)cPVOPo->op_pv;
2854 Zero(tbl, 256, short);
2855 for (i = 0; i < tlen; i++)
2857 for (i = 0, j = 0; i < 256; i++) {
2868 if (i < 128 && r[j] >= 128)
2878 o->op_private |= OPpTRANS_IDENTICAL;
2883 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2884 tbl[0x100] = rlen - j;
2885 for (i=0; i < rlen - j; i++)
2886 tbl[0x101+i] = r[j+i];
2890 if (!rlen && !del) {
2893 o->op_private |= OPpTRANS_IDENTICAL;
2895 for (i = 0; i < 256; i++)
2897 for (i = 0, j = 0; i < tlen; i++,j++) {
2900 if (tbl[t[i]] == -1)
2906 if (tbl[t[i]] == -1) {
2907 if (t[i] < 128 && r[j] >= 128)
2914 o->op_private |= OPpTRANS_GROWS;
2922 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2926 NewOp(1101, pmop, 1, PMOP);
2927 pmop->op_type = type;
2928 pmop->op_ppaddr = PL_ppaddr[type];
2929 pmop->op_flags = flags;
2930 pmop->op_private = 0 | (flags >> 8);
2932 if (PL_hints & HINT_RE_TAINT)
2933 pmop->op_pmpermflags |= PMf_RETAINT;
2934 if (PL_hints & HINT_LOCALE)
2935 pmop->op_pmpermflags |= PMf_LOCALE;
2936 pmop->op_pmflags = pmop->op_pmpermflags;
2938 /* link into pm list */
2939 if (type != OP_TRANS && PL_curstash) {
2940 pmop->op_pmnext = HvPMROOT(PL_curstash);
2941 HvPMROOT(PL_curstash) = pmop;
2942 PmopSTASH_set(pmop,PL_curstash);
2949 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2953 I32 repl_has_vars = 0;
2955 if (o->op_type == OP_TRANS)
2956 return pmtrans(o, expr, repl);
2958 PL_hints |= HINT_BLOCK_SCOPE;
2961 if (expr->op_type == OP_CONST) {
2963 SV *pat = ((SVOP*)expr)->op_sv;
2964 char *p = SvPV(pat, plen);
2965 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2966 sv_setpvn(pat, "\\s+", 3);
2967 p = SvPV(pat, plen);
2968 pm->op_pmflags |= PMf_SKIPWHITE;
2970 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2971 pm->op_pmdynflags |= PMdf_UTF8;
2972 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2973 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2974 pm->op_pmflags |= PMf_WHITE;
2978 if (PL_hints & HINT_UTF8)
2979 pm->op_pmdynflags |= PMdf_UTF8;
2980 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2981 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2983 : OP_REGCMAYBE),0,expr);
2985 NewOp(1101, rcop, 1, LOGOP);
2986 rcop->op_type = OP_REGCOMP;
2987 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2988 rcop->op_first = scalar(expr);
2989 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2990 ? (OPf_SPECIAL | OPf_KIDS)
2992 rcop->op_private = 1;
2995 /* establish postfix order */
2996 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2998 rcop->op_next = expr;
2999 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3002 rcop->op_next = LINKLIST(expr);
3003 expr->op_next = (OP*)rcop;
3006 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3011 if (pm->op_pmflags & PMf_EVAL) {
3013 if (CopLINE(PL_curcop) < PL_multi_end)
3014 CopLINE_set(PL_curcop, PL_multi_end);
3017 else if (repl->op_type == OP_THREADSV
3018 && strchr("&`'123456789+",
3019 PL_threadsv_names[repl->op_targ]))
3023 #endif /* USE_THREADS */
3024 else if (repl->op_type == OP_CONST)
3028 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3029 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3031 if (curop->op_type == OP_THREADSV) {
3033 if (strchr("&`'123456789+", curop->op_private))
3037 if (curop->op_type == OP_GV) {
3038 GV *gv = cGVOPx_gv(curop);
3040 if (strchr("&`'123456789+", *GvENAME(gv)))
3043 #endif /* USE_THREADS */
3044 else if (curop->op_type == OP_RV2CV)
3046 else if (curop->op_type == OP_RV2SV ||
3047 curop->op_type == OP_RV2AV ||
3048 curop->op_type == OP_RV2HV ||
3049 curop->op_type == OP_RV2GV) {
3050 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3053 else if (curop->op_type == OP_PADSV ||
3054 curop->op_type == OP_PADAV ||
3055 curop->op_type == OP_PADHV ||
3056 curop->op_type == OP_PADANY) {
3059 else if (curop->op_type == OP_PUSHRE)
3060 ; /* Okay here, dangerous in newASSIGNOP */
3069 && (!pm->op_pmregexp
3070 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3071 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3072 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3073 prepend_elem(o->op_type, scalar(repl), o);
3076 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3077 pm->op_pmflags |= PMf_MAYBE_CONST;
3078 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3080 NewOp(1101, rcop, 1, LOGOP);
3081 rcop->op_type = OP_SUBSTCONT;
3082 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3083 rcop->op_first = scalar(repl);
3084 rcop->op_flags |= OPf_KIDS;
3085 rcop->op_private = 1;
3088 /* establish postfix order */
3089 rcop->op_next = LINKLIST(repl);
3090 repl->op_next = (OP*)rcop;
3092 pm->op_pmreplroot = scalar((OP*)rcop);
3093 pm->op_pmreplstart = LINKLIST(rcop);
3102 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3105 NewOp(1101, svop, 1, SVOP);
3106 svop->op_type = type;
3107 svop->op_ppaddr = PL_ppaddr[type];
3109 svop->op_next = (OP*)svop;
3110 svop->op_flags = flags;
3111 if (PL_opargs[type] & OA_RETSCALAR)
3113 if (PL_opargs[type] & OA_TARGET)
3114 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3115 return CHECKOP(type, svop);
3119 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3122 NewOp(1101, padop, 1, PADOP);
3123 padop->op_type = type;
3124 padop->op_ppaddr = PL_ppaddr[type];
3125 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3126 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3127 PL_curpad[padop->op_padix] = sv;
3129 padop->op_next = (OP*)padop;
3130 padop->op_flags = flags;
3131 if (PL_opargs[type] & OA_RETSCALAR)
3133 if (PL_opargs[type] & OA_TARGET)
3134 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3135 return CHECKOP(type, padop);
3139 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3143 return newPADOP(type, flags, SvREFCNT_inc(gv));
3145 return newSVOP(type, flags, SvREFCNT_inc(gv));
3150 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3153 NewOp(1101, pvop, 1, PVOP);
3154 pvop->op_type = type;
3155 pvop->op_ppaddr = PL_ppaddr[type];
3157 pvop->op_next = (OP*)pvop;
3158 pvop->op_flags = flags;
3159 if (PL_opargs[type] & OA_RETSCALAR)
3161 if (PL_opargs[type] & OA_TARGET)
3162 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3163 return CHECKOP(type, pvop);
3167 Perl_package(pTHX_ OP *o)
3171 save_hptr(&PL_curstash);
3172 save_item(PL_curstname);
3177 name = SvPV(sv, len);
3178 PL_curstash = gv_stashpvn(name,len,TRUE);
3179 sv_setpvn(PL_curstname, name, len);
3183 sv_setpv(PL_curstname,"<none>");
3184 PL_curstash = Nullhv;
3186 PL_hints |= HINT_BLOCK_SCOPE;
3187 PL_copline = NOLINE;
3192 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3200 if (id->op_type != OP_CONST)
3201 Perl_croak(aTHX_ "Module name must be constant");
3205 if (version != Nullop) {
3206 SV *vesv = ((SVOP*)version)->op_sv;
3208 if (arg == Nullop && !SvNIOKp(vesv)) {
3215 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3216 Perl_croak(aTHX_ "Version number must be constant number");
3218 /* Make copy of id so we don't free it twice */
3219 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3221 /* Fake up a method call to VERSION */
3222 meth = newSVpvn("VERSION",7);
3223 sv_upgrade(meth, SVt_PVIV);
3224 (void)SvIOK_on(meth);
3225 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3226 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3227 append_elem(OP_LIST,
3228 prepend_elem(OP_LIST, pack, list(version)),
3229 newSVOP(OP_METHOD_NAMED, 0, meth)));
3233 /* Fake up an import/unimport */
3234 if (arg && arg->op_type == OP_STUB)
3235 imop = arg; /* no import on explicit () */
3236 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3237 imop = Nullop; /* use 5.0; */
3242 /* Make copy of id so we don't free it twice */
3243 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3245 /* Fake up a method call to import/unimport */
3246 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3247 sv_upgrade(meth, SVt_PVIV);
3248 (void)SvIOK_on(meth);
3249 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3250 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3251 append_elem(OP_LIST,
3252 prepend_elem(OP_LIST, pack, list(arg)),
3253 newSVOP(OP_METHOD_NAMED, 0, meth)));
3256 /* Fake up a require, handle override, if any */
3257 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3258 if (!(gv && GvIMPORTED_CV(gv)))
3259 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3261 if (gv && GvIMPORTED_CV(gv)) {
3262 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3263 append_elem(OP_LIST, id,
3264 scalar(newUNOP(OP_RV2CV, 0,
3269 rqop = newUNOP(OP_REQUIRE, 0, id);
3272 /* Fake up the BEGIN {}, which does its thing immediately. */
3274 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3277 append_elem(OP_LINESEQ,
3278 append_elem(OP_LINESEQ,
3279 newSTATEOP(0, Nullch, rqop),
3280 newSTATEOP(0, Nullch, veop)),
3281 newSTATEOP(0, Nullch, imop) ));
3283 PL_hints |= HINT_BLOCK_SCOPE;
3284 PL_copline = NOLINE;
3289 =for apidoc load_module
3291 Loads the module whose name is pointed to by the string part of name.
3292 Note that the actual module name, not its filename, should be given.
3293 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3294 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3295 (or 0 for no flags). ver, if specified, provides version semantics
3296 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3297 arguments can be used to specify arguments to the module's import()
3298 method, similar to C<use Foo::Bar VERSION LIST>.
3303 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3306 va_start(args, ver);
3307 vload_module(flags, name, ver, &args);
3311 #ifdef PERL_IMPLICIT_CONTEXT
3313 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3317 va_start(args, ver);
3318 vload_module(flags, name, ver, &args);
3324 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3326 OP *modname, *veop, *imop;
3328 modname = newSVOP(OP_CONST, 0, name);
3329 modname->op_private |= OPpCONST_BARE;
3331 veop = newSVOP(OP_CONST, 0, ver);
3335 if (flags & PERL_LOADMOD_NOIMPORT) {
3336 imop = sawparens(newNULLLIST());
3338 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3339 imop = va_arg(*args, OP*);
3344 sv = va_arg(*args, SV*);
3346 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3347 sv = va_arg(*args, SV*);
3351 line_t ocopline = PL_copline;
3352 int oexpect = PL_expect;
3354 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3355 veop, modname, imop);
3356 PL_expect = oexpect;
3357 PL_copline = ocopline;
3362 Perl_dofile(pTHX_ OP *term)
3367 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3368 if (!(gv && GvIMPORTED_CV(gv)))
3369 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3371 if (gv && GvIMPORTED_CV(gv)) {
3372 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3373 append_elem(OP_LIST, term,
3374 scalar(newUNOP(OP_RV2CV, 0,
3379 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3385 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3387 return newBINOP(OP_LSLICE, flags,
3388 list(force_list(subscript)),
3389 list(force_list(listval)) );
3393 S_list_assignment(pTHX_ register OP *o)
3398 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3399 o = cUNOPo->op_first;
3401 if (o->op_type == OP_COND_EXPR) {
3402 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3403 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3408 yyerror("Assignment to both a list and a scalar");
3412 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3413 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3414 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3417 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3420 if (o->op_type == OP_RV2SV)
3427 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3432 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3433 return newLOGOP(optype, 0,
3434 mod(scalar(left), optype),
3435 newUNOP(OP_SASSIGN, 0, scalar(right)));
3438 return newBINOP(optype, OPf_STACKED,
3439 mod(scalar(left), optype), scalar(right));
3443 if (list_assignment(left)) {
3447 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3448 left = mod(left, OP_AASSIGN);
3456 curop = list(force_list(left));
3457 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3458 o->op_private = 0 | (flags >> 8);
3459 for (curop = ((LISTOP*)curop)->op_first;
3460 curop; curop = curop->op_sibling)
3462 if (curop->op_type == OP_RV2HV &&
3463 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3464 o->op_private |= OPpASSIGN_HASH;
3468 if (!(left->op_private & OPpLVAL_INTRO)) {
3471 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3472 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3473 if (curop->op_type == OP_GV) {
3474 GV *gv = cGVOPx_gv(curop);
3475 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3477 SvCUR(gv) = PL_generation;
3479 else if (curop->op_type == OP_PADSV ||
3480 curop->op_type == OP_PADAV ||
3481 curop->op_type == OP_PADHV ||
3482 curop->op_type == OP_PADANY) {
3483 SV **svp = AvARRAY(PL_comppad_name);
3484 SV *sv = svp[curop->op_targ];
3485 if (SvCUR(sv) == PL_generation)
3487 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3489 else if (curop->op_type == OP_RV2CV)
3491 else if (curop->op_type == OP_RV2SV ||
3492 curop->op_type == OP_RV2AV ||
3493 curop->op_type == OP_RV2HV ||
3494 curop->op_type == OP_RV2GV) {
3495 if (lastop->op_type != OP_GV) /* funny deref? */
3498 else if (curop->op_type == OP_PUSHRE) {
3499 if (((PMOP*)curop)->op_pmreplroot) {
3501 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3503 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3505 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3507 SvCUR(gv) = PL_generation;
3516 o->op_private |= OPpASSIGN_COMMON;
3518 if (right && right->op_type == OP_SPLIT) {
3520 if ((tmpop = ((LISTOP*)right)->op_first) &&
3521 tmpop->op_type == OP_PUSHRE)
3523 PMOP *pm = (PMOP*)tmpop;
3524 if (left->op_type == OP_RV2AV &&
3525 !(left->op_private & OPpLVAL_INTRO) &&
3526 !(o->op_private & OPpASSIGN_COMMON) )
3528 tmpop = ((UNOP*)left)->op_first;
3529 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3531 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3532 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3534 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3535 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3537 pm->op_pmflags |= PMf_ONCE;
3538 tmpop = cUNOPo->op_first; /* to list (nulled) */
3539 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3540 tmpop->op_sibling = Nullop; /* don't free split */
3541 right->op_next = tmpop->op_next; /* fix starting loc */
3542 op_free(o); /* blow off assign */
3543 right->op_flags &= ~OPf_WANT;
3544 /* "I don't know and I don't care." */
3549 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3550 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3552 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3554 sv_setiv(sv, PL_modcount+1);
3562 right = newOP(OP_UNDEF, 0);
3563 if (right->op_type == OP_READLINE) {
3564 right->op_flags |= OPf_STACKED;
3565 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3568 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3569 o = newBINOP(OP_SASSIGN, flags,
3570 scalar(right), mod(scalar(left), OP_SASSIGN) );
3582 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3584 U32 seq = intro_my();
3587 NewOp(1101, cop, 1, COP);
3588 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3589 cop->op_type = OP_DBSTATE;
3590 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3593 cop->op_type = OP_NEXTSTATE;
3594 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3596 cop->op_flags = flags;
3597 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3599 cop->op_private |= NATIVE_HINTS;
3601 PL_compiling.op_private = cop->op_private;
3602 cop->op_next = (OP*)cop;
3605 cop->cop_label = label;
3606 PL_hints |= HINT_BLOCK_SCOPE;
3609 cop->cop_arybase = PL_curcop->cop_arybase;
3610 if (specialWARN(PL_curcop->cop_warnings))
3611 cop->cop_warnings = PL_curcop->cop_warnings ;
3613 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3614 if (specialCopIO(PL_curcop->cop_io))
3615 cop->cop_io = PL_curcop->cop_io;
3617 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3620 if (PL_copline == NOLINE)
3621 CopLINE_set(cop, CopLINE(PL_curcop));
3623 CopLINE_set(cop, PL_copline);
3624 PL_copline = NOLINE;
3627 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3629 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3631 CopSTASH_set(cop, PL_curstash);
3633 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3634 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3635 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3636 (void)SvIOK_on(*svp);
3637 SvIVX(*svp) = PTR2IV(cop);
3641 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3644 /* "Introduce" my variables to visible status. */
3652 if (! PL_min_intro_pending)
3653 return PL_cop_seqmax;
3655 svp = AvARRAY(PL_comppad_name);
3656 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3657 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3658 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3659 SvNVX(sv) = (NV)PL_cop_seqmax;
3662 PL_min_intro_pending = 0;
3663 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3664 return PL_cop_seqmax++;
3668 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3670 return new_logop(type, flags, &first, &other);
3674 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3678 OP *first = *firstp;
3679 OP *other = *otherp;
3681 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3682 return newBINOP(type, flags, scalar(first), scalar(other));
3684 scalarboolean(first);
3685 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3686 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3687 if (type == OP_AND || type == OP_OR) {
3693 first = *firstp = cUNOPo->op_first;
3695 first->op_next = o->op_next;
3696 cUNOPo->op_first = Nullop;
3700 if (first->op_type == OP_CONST) {
3701 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3702 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3703 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3714 else if (first->op_type == OP_WANTARRAY) {
3720 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3721 OP *k1 = ((UNOP*)first)->op_first;
3722 OP *k2 = k1->op_sibling;
3724 switch (first->op_type)
3727 if (k2 && k2->op_type == OP_READLINE
3728 && (k2->op_flags & OPf_STACKED)
3729 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3731 warnop = k2->op_type;
3736 if (k1->op_type == OP_READDIR
3737 || k1->op_type == OP_GLOB
3738 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3739 || k1->op_type == OP_EACH)
3741 warnop = ((k1->op_type == OP_NULL)
3742 ? k1->op_targ : k1->op_type);
3747 line_t oldline = CopLINE(PL_curcop);
3748 CopLINE_set(PL_curcop, PL_copline);
3749 Perl_warner(aTHX_ WARN_MISC,
3750 "Value of %s%s can be \"0\"; test with defined()",
3752 ((warnop == OP_READLINE || warnop == OP_GLOB)
3753 ? " construct" : "() operator"));
3754 CopLINE_set(PL_curcop, oldline);
3761 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3762 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3764 NewOp(1101, logop, 1, LOGOP);
3766 logop->op_type = type;
3767 logop->op_ppaddr = PL_ppaddr[type];
3768 logop->op_first = first;
3769 logop->op_flags = flags | OPf_KIDS;
3770 logop->op_other = LINKLIST(other);
3771 logop->op_private = 1 | (flags >> 8);
3773 /* establish postfix order */
3774 logop->op_next = LINKLIST(first);
3775 first->op_next = (OP*)logop;
3776 first->op_sibling = other;
3778 o = newUNOP(OP_NULL, 0, (OP*)logop);
3785 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3792 return newLOGOP(OP_AND, 0, first, trueop);
3794 return newLOGOP(OP_OR, 0, first, falseop);
3796 scalarboolean(first);
3797 if (first->op_type == OP_CONST) {
3798 if (SvTRUE(((SVOP*)first)->op_sv)) {
3809 else if (first->op_type == OP_WANTARRAY) {
3813 NewOp(1101, logop, 1, LOGOP);
3814 logop->op_type = OP_COND_EXPR;
3815 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3816 logop->op_first = first;
3817 logop->op_flags = flags | OPf_KIDS;
3818 logop->op_private = 1 | (flags >> 8);
3819 logop->op_other = LINKLIST(trueop);
3820 logop->op_next = LINKLIST(falseop);
3823 /* establish postfix order */
3824 start = LINKLIST(first);
3825 first->op_next = (OP*)logop;
3827 first->op_sibling = trueop;
3828 trueop->op_sibling = falseop;
3829 o = newUNOP(OP_NULL, 0, (OP*)logop);
3831 trueop->op_next = falseop->op_next = o;
3838 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3846 NewOp(1101, range, 1, LOGOP);
3848 range->op_type = OP_RANGE;
3849 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3850 range->op_first = left;
3851 range->op_flags = OPf_KIDS;
3852 leftstart = LINKLIST(left);
3853 range->op_other = LINKLIST(right);
3854 range->op_private = 1 | (flags >> 8);
3856 left->op_sibling = right;
3858 range->op_next = (OP*)range;
3859 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3860 flop = newUNOP(OP_FLOP, 0, flip);
3861 o = newUNOP(OP_NULL, 0, flop);
3863 range->op_next = leftstart;
3865 left->op_next = flip;
3866 right->op_next = flop;
3868 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3869 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3870 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3871 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3873 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3874 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3877 if (!flip->op_private || !flop->op_private)
3878 linklist(o); /* blow off optimizer unless constant */
3884 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3888 int once = block && block->op_flags & OPf_SPECIAL &&
3889 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3892 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3893 return block; /* do {} while 0 does once */
3894 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3895 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3896 expr = newUNOP(OP_DEFINED, 0,
3897 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3898 } else if (expr->op_flags & OPf_KIDS) {
3899 OP *k1 = ((UNOP*)expr)->op_first;
3900 OP *k2 = (k1) ? k1->op_sibling : NULL;
3901 switch (expr->op_type) {
3903 if (k2 && k2->op_type == OP_READLINE
3904 && (k2->op_flags & OPf_STACKED)
3905 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3906 expr = newUNOP(OP_DEFINED, 0, expr);
3910 if (k1->op_type == OP_READDIR
3911 || k1->op_type == OP_GLOB
3912 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3913 || k1->op_type == OP_EACH)
3914 expr = newUNOP(OP_DEFINED, 0, expr);
3920 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3921 o = new_logop(OP_AND, 0, &expr, &listop);
3924 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3926 if (once && o != listop)
3927 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3930 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3932 o->op_flags |= flags;
3934 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3939 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3948 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3949 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3950 expr = newUNOP(OP_DEFINED, 0,
3951 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3952 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3953 OP *k1 = ((UNOP*)expr)->op_first;
3954 OP *k2 = (k1) ? k1->op_sibling : NULL;
3955 switch (expr->op_type) {
3957 if (k2 && k2->op_type == OP_READLINE
3958 && (k2->op_flags & OPf_STACKED)
3959 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3960 expr = newUNOP(OP_DEFINED, 0, expr);
3964 if (k1->op_type == OP_READDIR
3965 || k1->op_type == OP_GLOB
3966 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3967 || k1->op_type == OP_EACH)
3968 expr = newUNOP(OP_DEFINED, 0, expr);
3974 block = newOP(OP_NULL, 0);
3976 block = scope(block);
3980 next = LINKLIST(cont);
3983 OP *unstack = newOP(OP_UNSTACK, 0);
3986 cont = append_elem(OP_LINESEQ, cont, unstack);
3987 if ((line_t)whileline != NOLINE) {
3988 PL_copline = whileline;
3989 cont = append_elem(OP_LINESEQ, cont,
3990 newSTATEOP(0, Nullch, Nullop));
3994 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3995 redo = LINKLIST(listop);
3998 PL_copline = whileline;
4000 o = new_logop(OP_AND, 0, &expr, &listop);
4001 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4002 op_free(expr); /* oops, it's a while (0) */
4004 return Nullop; /* listop already freed by new_logop */
4007 ((LISTOP*)listop)->op_last->op_next = condop =
4008 (o == listop ? redo : LINKLIST(o));
4014 NewOp(1101,loop,1,LOOP);
4015 loop->op_type = OP_ENTERLOOP;
4016 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4017 loop->op_private = 0;
4018 loop->op_next = (OP*)loop;
4021 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4023 loop->op_redoop = redo;
4024 loop->op_lastop = o;
4025 o->op_private |= loopflags;
4028 loop->op_nextop = next;
4030 loop->op_nextop = o;
4032 o->op_flags |= flags;
4033 o->op_private |= (flags >> 8);
4038 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4046 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4047 sv->op_type = OP_RV2GV;
4048 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4050 else if (sv->op_type == OP_PADSV) { /* private variable */
4051 padoff = sv->op_targ;
4056 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4057 padoff = sv->op_targ;
4059 iterflags |= OPf_SPECIAL;
4064 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4068 padoff = find_threadsv("_");
4069 iterflags |= OPf_SPECIAL;
4071 sv = newGVOP(OP_GV, 0, PL_defgv);
4074 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4075 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4076 iterflags |= OPf_STACKED;
4078 else if (expr->op_type == OP_NULL &&
4079 (expr->op_flags & OPf_KIDS) &&
4080 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4082 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4083 * set the STACKED flag to indicate that these values are to be
4084 * treated as min/max values by 'pp_iterinit'.
4086 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4087 LOGOP* range = (LOGOP*) flip->op_first;
4088 OP* left = range->op_first;
4089 OP* right = left->op_sibling;
4092 range->op_flags &= ~OPf_KIDS;
4093 range->op_first = Nullop;
4095 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4096 listop->op_first->op_next = range->op_next;
4097 left->op_next = range->op_other;
4098 right->op_next = (OP*)listop;
4099 listop->op_next = listop->op_first;
4102 expr = (OP*)(listop);
4104 iterflags |= OPf_STACKED;
4107 expr = mod(force_list(expr), OP_GREPSTART);
4111 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4112 append_elem(OP_LIST, expr, scalar(sv))));
4113 assert(!loop->op_next);
4114 #ifdef PL_OP_SLAB_ALLOC
4117 NewOp(1234,tmp,1,LOOP);
4118 Copy(loop,tmp,1,LOOP);
4122 Renew(loop, 1, LOOP);
4124 loop->op_targ = padoff;
4125 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4126 PL_copline = forline;
4127 return newSTATEOP(0, label, wop);
4131 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4136 if (type != OP_GOTO || label->op_type == OP_CONST) {
4137 /* "last()" means "last" */
4138 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4139 o = newOP(type, OPf_SPECIAL);
4141 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4142 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4148 if (label->op_type == OP_ENTERSUB)
4149 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4150 o = newUNOP(type, OPf_STACKED, label);
4152 PL_hints |= HINT_BLOCK_SCOPE;
4157 Perl_cv_undef(pTHX_ CV *cv)
4161 MUTEX_DESTROY(CvMUTEXP(cv));
4162 Safefree(CvMUTEXP(cv));
4165 #endif /* USE_THREADS */
4167 if (!CvXSUB(cv) && CvROOT(cv)) {
4169 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4170 Perl_croak(aTHX_ "Can't undef active subroutine");
4173 Perl_croak(aTHX_ "Can't undef active subroutine");
4174 #endif /* USE_THREADS */
4177 SAVEVPTR(PL_curpad);
4180 op_free(CvROOT(cv));
4181 CvROOT(cv) = Nullop;
4184 SvPOK_off((SV*)cv); /* forget prototype */
4186 /* Since closure prototypes have the same lifetime as the containing
4187 * CV, they don't hold a refcount on the outside CV. This avoids
4188 * the refcount loop between the outer CV (which keeps a refcount to
4189 * the closure prototype in the pad entry for pp_anoncode()) and the
4190 * closure prototype, and the ensuing memory leak. --GSAR */
4191 if (!CvANON(cv) || CvCLONED(cv))
4192 SvREFCNT_dec(CvOUTSIDE(cv));
4193 CvOUTSIDE(cv) = Nullcv;
4195 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4198 if (CvPADLIST(cv)) {
4199 /* may be during global destruction */
4200 if (SvREFCNT(CvPADLIST(cv))) {
4201 I32 i = AvFILLp(CvPADLIST(cv));
4203 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4204 SV* sv = svp ? *svp : Nullsv;
4207 if (sv == (SV*)PL_comppad_name)
4208 PL_comppad_name = Nullav;
4209 else if (sv == (SV*)PL_comppad) {
4210 PL_comppad = Nullav;
4211 PL_curpad = Null(SV**);
4215 SvREFCNT_dec((SV*)CvPADLIST(cv));
4217 CvPADLIST(cv) = Nullav;
4222 #ifdef DEBUG_CLOSURES
4224 S_cv_dump(pTHX_ CV *cv)
4227 CV *outside = CvOUTSIDE(cv);
4228 AV* padlist = CvPADLIST(cv);
4235 PerlIO_printf(Perl_debug_log,
4236 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4238 (CvANON(cv) ? "ANON"
4239 : (cv == PL_main_cv) ? "MAIN"
4240 : CvUNIQUE(cv) ? "UNIQUE"
4241 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4244 : CvANON(outside) ? "ANON"
4245 : (outside == PL_main_cv) ? "MAIN"
4246 : CvUNIQUE(outside) ? "UNIQUE"
4247 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4252 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4253 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4254 pname = AvARRAY(pad_name);
4255 ppad = AvARRAY(pad);
4257 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4258 if (SvPOK(pname[ix]))
4259 PerlIO_printf(Perl_debug_log,
4260 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4261 (int)ix, PTR2UV(ppad[ix]),
4262 SvFAKE(pname[ix]) ? "FAKE " : "",
4264 (IV)I_32(SvNVX(pname[ix])),
4267 #endif /* DEBUGGING */
4269 #endif /* DEBUG_CLOSURES */
4272 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4276 AV* protopadlist = CvPADLIST(proto);
4277 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4278 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4279 SV** pname = AvARRAY(protopad_name);
4280 SV** ppad = AvARRAY(protopad);
4281 I32 fname = AvFILLp(protopad_name);
4282 I32 fpad = AvFILLp(protopad);
4286 assert(!CvUNIQUE(proto));
4290 SAVESPTR(PL_comppad_name);
4291 SAVESPTR(PL_compcv);
4293 cv = PL_compcv = (CV*)NEWSV(1104,0);
4294 sv_upgrade((SV *)cv, SvTYPE(proto));
4295 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4299 New(666, CvMUTEXP(cv), 1, perl_mutex);
4300 MUTEX_INIT(CvMUTEXP(cv));
4302 #endif /* USE_THREADS */
4303 CvFILE(cv) = CvFILE(proto);
4304 CvGV(cv) = CvGV(proto);
4305 CvSTASH(cv) = CvSTASH(proto);
4306 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4307 CvSTART(cv) = CvSTART(proto);
4309 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4312 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4314 PL_comppad_name = newAV();
4315 for (ix = fname; ix >= 0; ix--)
4316 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4318 PL_comppad = newAV();
4320 comppadlist = newAV();
4321 AvREAL_off(comppadlist);
4322 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4323 av_store(comppadlist, 1, (SV*)PL_comppad);
4324 CvPADLIST(cv) = comppadlist;
4325 av_fill(PL_comppad, AvFILLp(protopad));
4326 PL_curpad = AvARRAY(PL_comppad);
4328 av = newAV(); /* will be @_ */
4330 av_store(PL_comppad, 0, (SV*)av);
4331 AvFLAGS(av) = AVf_REIFY;
4333 for (ix = fpad; ix > 0; ix--) {
4334 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4335 if (namesv && namesv != &PL_sv_undef) {
4336 char *name = SvPVX(namesv); /* XXX */
4337 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4338 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4339 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4341 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4343 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4345 else { /* our own lexical */
4348 /* anon code -- we'll come back for it */
4349 sv = SvREFCNT_inc(ppad[ix]);
4351 else if (*name == '@')
4353 else if (*name == '%')
4362 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4363 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4366 SV* sv = NEWSV(0,0);
4372 /* Now that vars are all in place, clone nested closures. */
4374 for (ix = fpad; ix > 0; ix--) {
4375 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4377 && namesv != &PL_sv_undef
4378 && !(SvFLAGS(namesv) & SVf_FAKE)
4379 && *SvPVX(namesv) == '&'
4380 && CvCLONE(ppad[ix]))
4382 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4383 SvREFCNT_dec(ppad[ix]);
4386 PL_curpad[ix] = (SV*)kid;
4390 #ifdef DEBUG_CLOSURES
4391 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4393 PerlIO_printf(Perl_debug_log, " from:\n");
4395 PerlIO_printf(Perl_debug_log, " to:\n");
4402 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4404 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4406 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4413 Perl_cv_clone(pTHX_ CV *proto)
4416 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4417 cv = cv_clone2(proto, CvOUTSIDE(proto));
4418 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4423 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4425 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4426 SV* msg = sv_newmortal();
4430 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4431 sv_setpv(msg, "Prototype mismatch:");
4433 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4435 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4436 sv_catpv(msg, " vs ");
4438 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4440 sv_catpv(msg, "none");
4441 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4445 static void const_sv_xsub(pTHXo_ CV* cv);
4448 =for apidoc cv_const_sv
4450 If C<cv> is a constant sub eligible for inlining. returns the constant
4451 value returned by the sub. Otherwise, returns NULL.
4453 Constant subs can be created with C<newCONSTSUB> or as described in
4454 L<perlsub/"Constant Functions">.
4459 Perl_cv_const_sv(pTHX_ CV *cv)
4461 if (!cv || !CvCONST(cv))
4463 return (SV*)CvXSUBANY(cv).any_ptr;
4467 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4474 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4475 o = cLISTOPo->op_first->op_sibling;
4477 for (; o; o = o->op_next) {
4478 OPCODE type = o->op_type;
4480 if (sv && o->op_next == o)
4482 if (o->op_next != o) {
4483 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4485 if (type == OP_DBSTATE)
4488 if (type == OP_LEAVESUB || type == OP_RETURN)
4492 if (type == OP_CONST && cSVOPo->op_sv)
4494 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4495 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4496 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4500 /* We get here only from cv_clone2() while creating a closure.
4501 Copy the const value here instead of in cv_clone2 so that
4502 SvREADONLY_on doesn't lead to problems when leaving
4507 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4519 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4529 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4533 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4535 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4539 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4545 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4550 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4551 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4552 SV *sv = sv_newmortal();
4553 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4554 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4559 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4560 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4570 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4571 maximum a prototype before. */
4572 if (SvTYPE(gv) > SVt_NULL) {
4573 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4574 && ckWARN_d(WARN_PROTOTYPE))
4576 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4578 cv_ckproto((CV*)gv, NULL, ps);
4581 sv_setpv((SV*)gv, ps);
4583 sv_setiv((SV*)gv, -1);
4584 SvREFCNT_dec(PL_compcv);
4585 cv = PL_compcv = NULL;
4586 PL_sub_generation++;
4590 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4592 #ifdef GV_SHARED_CHECK
4593 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4594 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4598 if (!block || !ps || *ps || attrs)
4601 const_sv = op_const_sv(block, Nullcv);
4604 bool exists = CvROOT(cv) || CvXSUB(cv);
4606 #ifdef GV_SHARED_CHECK
4607 if (exists && GvSHARED(gv)) {
4608 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4612 /* if the subroutine doesn't exist and wasn't pre-declared
4613 * with a prototype, assume it will be AUTOLOADed,
4614 * skipping the prototype check
4616 if (exists || SvPOK(cv))
4617 cv_ckproto(cv, gv, ps);
4618 /* already defined (or promised)? */
4619 if (exists || GvASSUMECV(gv)) {
4620 if (!block && !attrs) {
4621 /* just a "sub foo;" when &foo is already defined */
4622 SAVEFREESV(PL_compcv);
4625 /* ahem, death to those who redefine active sort subs */
4626 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4627 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4629 if (ckWARN(WARN_REDEFINE)
4631 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4633 line_t oldline = CopLINE(PL_curcop);
4634 CopLINE_set(PL_curcop, PL_copline);
4635 Perl_warner(aTHX_ WARN_REDEFINE,
4636 CvCONST(cv) ? "Constant subroutine %s redefined"
4637 : "Subroutine %s redefined", name);
4638 CopLINE_set(PL_curcop, oldline);
4646 SvREFCNT_inc(const_sv);
4648 assert(!CvROOT(cv) && !CvCONST(cv));
4649 sv_setpv((SV*)cv, ""); /* prototype is "" */
4650 CvXSUBANY(cv).any_ptr = const_sv;
4651 CvXSUB(cv) = const_sv_xsub;
4656 cv = newCONSTSUB(NULL, name, const_sv);
4659 SvREFCNT_dec(PL_compcv);
4661 PL_sub_generation++;
4668 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4669 * before we clobber PL_compcv.
4673 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4674 stash = GvSTASH(CvGV(cv));
4675 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4676 stash = CvSTASH(cv);
4678 stash = PL_curstash;
4681 /* possibly about to re-define existing subr -- ignore old cv */
4682 rcv = (SV*)PL_compcv;
4683 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4684 stash = GvSTASH(gv);
4686 stash = PL_curstash;
4688 apply_attrs(stash, rcv, attrs);
4690 if (cv) { /* must reuse cv if autoloaded */
4692 /* got here with just attrs -- work done, so bug out */
4693 SAVEFREESV(PL_compcv);
4697 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4698 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4699 CvOUTSIDE(PL_compcv) = 0;
4700 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4701 CvPADLIST(PL_compcv) = 0;
4702 /* inner references to PL_compcv must be fixed up ... */
4704 AV *padlist = CvPADLIST(cv);
4705 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4706 AV *comppad = (AV*)AvARRAY(padlist)[1];
4707 SV **namepad = AvARRAY(comppad_name);
4708 SV **curpad = AvARRAY(comppad);
4709 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4710 SV *namesv = namepad[ix];
4711 if (namesv && namesv != &PL_sv_undef
4712 && *SvPVX(namesv) == '&')
4714 CV *innercv = (CV*)curpad[ix];
4715 if (CvOUTSIDE(innercv) == PL_compcv) {
4716 CvOUTSIDE(innercv) = cv;
4717 if (!CvANON(innercv) || CvCLONED(innercv)) {
4718 (void)SvREFCNT_inc(cv);
4719 SvREFCNT_dec(PL_compcv);
4725 /* ... before we throw it away */
4726 SvREFCNT_dec(PL_compcv);
4733 PL_sub_generation++;
4737 CvFILE(cv) = CopFILE(PL_curcop);
4738 CvSTASH(cv) = PL_curstash;
4741 if (!CvMUTEXP(cv)) {
4742 New(666, CvMUTEXP(cv), 1, perl_mutex);
4743 MUTEX_INIT(CvMUTEXP(cv));
4745 #endif /* USE_THREADS */
4748 sv_setpv((SV*)cv, ps);
4750 if (PL_error_count) {
4754 char *s = strrchr(name, ':');
4756 if (strEQ(s, "BEGIN")) {
4758 "BEGIN not safe after errors--compilation aborted";
4759 if (PL_in_eval & EVAL_KEEPERR)
4760 Perl_croak(aTHX_ not_safe);
4762 /* force display of errors found but not reported */
4763 sv_catpv(ERRSV, not_safe);
4764 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4772 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4773 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4776 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4777 mod(scalarseq(block), OP_LEAVESUBLV));
4780 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4782 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4783 OpREFCNT_set(CvROOT(cv), 1);
4784 CvSTART(cv) = LINKLIST(CvROOT(cv));
4785 CvROOT(cv)->op_next = 0;
4788 /* now that optimizer has done its work, adjust pad values */
4790 SV **namep = AvARRAY(PL_comppad_name);
4791 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4794 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4797 * The only things that a clonable function needs in its
4798 * pad are references to outer lexicals and anonymous subs.
4799 * The rest are created anew during cloning.
4801 if (!((namesv = namep[ix]) != Nullsv &&
4802 namesv != &PL_sv_undef &&
4804 *SvPVX(namesv) == '&')))
4806 SvREFCNT_dec(PL_curpad[ix]);
4807 PL_curpad[ix] = Nullsv;
4810 assert(!CvCONST(cv));
4811 if (ps && !*ps && op_const_sv(block, cv))
4815 AV *av = newAV(); /* Will be @_ */
4817 av_store(PL_comppad, 0, (SV*)av);
4818 AvFLAGS(av) = AVf_REIFY;
4820 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4821 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4823 if (!SvPADMY(PL_curpad[ix]))
4824 SvPADTMP_on(PL_curpad[ix]);
4828 /* If a potential closure prototype, don't keep a refcount on outer CV.
4829 * This is okay as the lifetime of the prototype is tied to the
4830 * lifetime of the outer CV. Avoids memory leak due to reference
4833 SvREFCNT_dec(CvOUTSIDE(cv));
4835 if (name || aname) {
4837 char *tname = (name ? name : aname);
4839 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4840 SV *sv = NEWSV(0,0);
4841 SV *tmpstr = sv_newmortal();
4842 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4846 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4848 (long)PL_subline, (long)CopLINE(PL_curcop));
4849 gv_efullname3(tmpstr, gv, Nullch);
4850 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4851 hv = GvHVn(db_postponed);
4852 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4853 && (pcv = GvCV(db_postponed)))
4859 call_sv((SV*)pcv, G_DISCARD);
4863 if ((s = strrchr(tname,':')))
4868 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4871 if (strEQ(s, "BEGIN")) {
4872 I32 oldscope = PL_scopestack_ix;
4874 SAVECOPFILE(&PL_compiling);
4875 SAVECOPLINE(&PL_compiling);
4877 sv_setsv(PL_rs, PL_nrs);
4880 PL_beginav = newAV();
4881 DEBUG_x( dump_sub(gv) );
4882 av_push(PL_beginav, (SV*)cv);
4883 GvCV(gv) = 0; /* cv has been hijacked */
4884 call_list(oldscope, PL_beginav);
4886 PL_curcop = &PL_compiling;
4887 PL_compiling.op_private = PL_hints;
4890 else if (strEQ(s, "END") && !PL_error_count) {
4893 DEBUG_x( dump_sub(gv) );
4894 av_unshift(PL_endav, 1);
4895 av_store(PL_endav, 0, (SV*)cv);
4896 GvCV(gv) = 0; /* cv has been hijacked */
4898 else if (strEQ(s, "CHECK") && !PL_error_count) {
4900 PL_checkav = 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 CHECK block");
4904 av_unshift(PL_checkav, 1);
4905 av_store(PL_checkav, 0, (SV*)cv);
4906 GvCV(gv) = 0; /* cv has been hijacked */
4908 else if (strEQ(s, "INIT") && !PL_error_count) {
4910 PL_initav = newAV();
4911 DEBUG_x( dump_sub(gv) );
4912 if (PL_main_start && ckWARN(WARN_VOID))
4913 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4914 av_push(PL_initav, (SV*)cv);
4915 GvCV(gv) = 0; /* cv has been hijacked */
4920 PL_copline = NOLINE;
4925 /* XXX unsafe for threads if eval_owner isn't held */
4927 =for apidoc newCONSTSUB
4929 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4930 eligible for inlining at compile-time.
4936 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4942 SAVECOPLINE(PL_curcop);
4943 CopLINE_set(PL_curcop, PL_copline);
4946 PL_hints &= ~HINT_BLOCK_SCOPE;
4949 SAVESPTR(PL_curstash);
4950 SAVECOPSTASH(PL_curcop);
4951 PL_curstash = stash;
4953 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4955 CopSTASH(PL_curcop) = stash;
4959 cv = newXS(name, const_sv_xsub, __FILE__);
4960 CvXSUBANY(cv).any_ptr = sv;
4962 sv_setpv((SV*)cv, ""); /* prototype is "" */
4970 =for apidoc U||newXS
4972 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4978 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4980 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4983 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4985 /* just a cached method */
4989 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4990 /* already defined (or promised) */
4991 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4992 && HvNAME(GvSTASH(CvGV(cv)))
4993 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4994 line_t oldline = CopLINE(PL_curcop);
4995 if (PL_copline != NOLINE)
4996 CopLINE_set(PL_curcop, PL_copline);
4997 Perl_warner(aTHX_ WARN_REDEFINE,
4998 CvCONST(cv) ? "Constant subroutine %s redefined"
4999 : "Subroutine %s redefined"
5001 CopLINE_set(PL_curcop, oldline);
5008 if (cv) /* must reuse cv if autoloaded */
5011 cv = (CV*)NEWSV(1105,0);
5012 sv_upgrade((SV *)cv, SVt_PVCV);
5016 PL_sub_generation++;
5021 New(666, CvMUTEXP(cv), 1, perl_mutex);
5022 MUTEX_INIT(CvMUTEXP(cv));
5024 #endif /* USE_THREADS */
5025 (void)gv_fetchfile(filename);
5026 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5027 an external constant string */
5028 CvXSUB(cv) = subaddr;
5031 char *s = strrchr(name,':');
5037 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5040 if (strEQ(s, "BEGIN")) {
5042 PL_beginav = newAV();
5043 av_push(PL_beginav, (SV*)cv);
5044 GvCV(gv) = 0; /* cv has been hijacked */
5046 else if (strEQ(s, "END")) {
5049 av_unshift(PL_endav, 1);
5050 av_store(PL_endav, 0, (SV*)cv);
5051 GvCV(gv) = 0; /* cv has been hijacked */
5053 else if (strEQ(s, "CHECK")) {
5055 PL_checkav = newAV();
5056 if (PL_main_start && ckWARN(WARN_VOID))
5057 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5058 av_unshift(PL_checkav, 1);
5059 av_store(PL_checkav, 0, (SV*)cv);
5060 GvCV(gv) = 0; /* cv has been hijacked */
5062 else if (strEQ(s, "INIT")) {
5064 PL_initav = newAV();
5065 if (PL_main_start && ckWARN(WARN_VOID))
5066 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5067 av_push(PL_initav, (SV*)cv);
5068 GvCV(gv) = 0; /* cv has been hijacked */
5079 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5088 name = SvPVx(cSVOPo->op_sv, n_a);
5091 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5092 #ifdef GV_SHARED_CHECK
5094 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5098 if ((cv = GvFORM(gv))) {
5099 if (ckWARN(WARN_REDEFINE)) {
5100 line_t oldline = CopLINE(PL_curcop);
5102 CopLINE_set(PL_curcop, PL_copline);
5103 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5104 CopLINE_set(PL_curcop, oldline);
5111 CvFILE(cv) = CopFILE(PL_curcop);
5113 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5114 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5115 SvPADTMP_on(PL_curpad[ix]);
5118 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5119 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5120 OpREFCNT_set(CvROOT(cv), 1);
5121 CvSTART(cv) = LINKLIST(CvROOT(cv));
5122 CvROOT(cv)->op_next = 0;
5125 PL_copline = NOLINE;
5130 Perl_newANONLIST(pTHX_ OP *o)
5132 return newUNOP(OP_REFGEN, 0,
5133 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5137 Perl_newANONHASH(pTHX_ OP *o)
5139 return newUNOP(OP_REFGEN, 0,
5140 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5144 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5146 return newANONATTRSUB(floor, proto, Nullop, block);
5150 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5152 return newUNOP(OP_REFGEN, 0,
5153 newSVOP(OP_ANONCODE, 0,
5154 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5158 Perl_oopsAV(pTHX_ OP *o)
5160 switch (o->op_type) {
5162 o->op_type = OP_PADAV;
5163 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5164 return ref(o, OP_RV2AV);
5167 o->op_type = OP_RV2AV;
5168 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5173 if (ckWARN_d(WARN_INTERNAL))
5174 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5181 Perl_oopsHV(pTHX_ OP *o)
5183 switch (o->op_type) {
5186 o->op_type = OP_PADHV;
5187 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5188 return ref(o, OP_RV2HV);
5192 o->op_type = OP_RV2HV;
5193 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5198 if (ckWARN_d(WARN_INTERNAL))
5199 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5206 Perl_newAVREF(pTHX_ OP *o)
5208 if (o->op_type == OP_PADANY) {
5209 o->op_type = OP_PADAV;
5210 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5213 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5214 && ckWARN(WARN_DEPRECATED)) {
5215 Perl_warner(aTHX_ WARN_DEPRECATED,
5216 "Using an array as a reference is deprecated");
5218 return newUNOP(OP_RV2AV, 0, scalar(o));
5222 Perl_newGVREF(pTHX_ I32 type, OP *o)
5224 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5225 return newUNOP(OP_NULL, 0, o);
5226 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5230 Perl_newHVREF(pTHX_ OP *o)
5232 if (o->op_type == OP_PADANY) {
5233 o->op_type = OP_PADHV;
5234 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5237 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5238 && ckWARN(WARN_DEPRECATED)) {
5239 Perl_warner(aTHX_ WARN_DEPRECATED,
5240 "Using a hash as a reference is deprecated");
5242 return newUNOP(OP_RV2HV, 0, scalar(o));
5246 Perl_oopsCV(pTHX_ OP *o)
5248 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5254 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5256 return newUNOP(OP_RV2CV, flags, scalar(o));
5260 Perl_newSVREF(pTHX_ OP *o)
5262 if (o->op_type == OP_PADANY) {
5263 o->op_type = OP_PADSV;
5264 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5267 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5268 o->op_flags |= OPpDONE_SVREF;
5271 return newUNOP(OP_RV2SV, 0, scalar(o));
5274 /* Check routines. */
5277 Perl_ck_anoncode(pTHX_ OP *o)
5282 name = NEWSV(1106,0);
5283 sv_upgrade(name, SVt_PVNV);
5284 sv_setpvn(name, "&", 1);
5287 ix = pad_alloc(o->op_type, SVs_PADMY);
5288 av_store(PL_comppad_name, ix, name);
5289 av_store(PL_comppad, ix, cSVOPo->op_sv);
5290 SvPADMY_on(cSVOPo->op_sv);
5291 cSVOPo->op_sv = Nullsv;
5292 cSVOPo->op_targ = ix;
5297 Perl_ck_bitop(pTHX_ OP *o)
5299 o->op_private = PL_hints;
5304 Perl_ck_concat(pTHX_ OP *o)
5306 if (cUNOPo->op_first->op_type == OP_CONCAT)
5307 o->op_flags |= OPf_STACKED;
5312 Perl_ck_spair(pTHX_ OP *o)
5314 if (o->op_flags & OPf_KIDS) {
5317 OPCODE type = o->op_type;
5318 o = modkids(ck_fun(o), type);
5319 kid = cUNOPo->op_first;
5320 newop = kUNOP->op_first->op_sibling;
5322 (newop->op_sibling ||
5323 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5324 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5325 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5329 op_free(kUNOP->op_first);
5330 kUNOP->op_first = newop;
5332 o->op_ppaddr = PL_ppaddr[++o->op_type];
5337 Perl_ck_delete(pTHX_ OP *o)
5341 if (o->op_flags & OPf_KIDS) {
5342 OP *kid = cUNOPo->op_first;
5343 switch (kid->op_type) {
5345 o->op_flags |= OPf_SPECIAL;
5348 o->op_private |= OPpSLICE;
5351 o->op_flags |= OPf_SPECIAL;
5356 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5357 PL_op_desc[o->op_type]);
5365 Perl_ck_eof(pTHX_ OP *o)
5367 I32 type = o->op_type;
5369 if (o->op_flags & OPf_KIDS) {
5370 if (cLISTOPo->op_first->op_type == OP_STUB) {
5372 o = newUNOP(type, OPf_SPECIAL,
5373 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5381 Perl_ck_eval(pTHX_ OP *o)
5383 PL_hints |= HINT_BLOCK_SCOPE;
5384 if (o->op_flags & OPf_KIDS) {
5385 SVOP *kid = (SVOP*)cUNOPo->op_first;
5388 o->op_flags &= ~OPf_KIDS;
5391 else if (kid->op_type == OP_LINESEQ) {
5394 kid->op_next = o->op_next;
5395 cUNOPo->op_first = 0;
5398 NewOp(1101, enter, 1, LOGOP);
5399 enter->op_type = OP_ENTERTRY;
5400 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5401 enter->op_private = 0;
5403 /* establish postfix order */
5404 enter->op_next = (OP*)enter;
5406 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5407 o->op_type = OP_LEAVETRY;
5408 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5409 enter->op_other = o;
5417 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5419 o->op_targ = (PADOFFSET)PL_hints;
5424 Perl_ck_exit(pTHX_ OP *o)
5427 HV *table = GvHV(PL_hintgv);
5429 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5430 if (svp && *svp && SvTRUE(*svp))
5431 o->op_private |= OPpEXIT_VMSISH;
5438 Perl_ck_exec(pTHX_ OP *o)
5441 if (o->op_flags & OPf_STACKED) {
5443 kid = cUNOPo->op_first->op_sibling;
5444 if (kid->op_type == OP_RV2GV)
5453 Perl_ck_exists(pTHX_ OP *o)
5456 if (o->op_flags & OPf_KIDS) {
5457 OP *kid = cUNOPo->op_first;
5458 if (kid->op_type == OP_ENTERSUB) {
5459 (void) ref(kid, o->op_type);
5460 if (kid->op_type != OP_RV2CV && !PL_error_count)
5461 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5462 PL_op_desc[o->op_type]);
5463 o->op_private |= OPpEXISTS_SUB;
5465 else if (kid->op_type == OP_AELEM)
5466 o->op_flags |= OPf_SPECIAL;
5467 else if (kid->op_type != OP_HELEM)
5468 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5469 PL_op_desc[o->op_type]);
5477 Perl_ck_gvconst(pTHX_ register OP *o)
5479 o = fold_constants(o);
5480 if (o->op_type == OP_CONST)
5487 Perl_ck_rvconst(pTHX_ register OP *o)
5489 SVOP *kid = (SVOP*)cUNOPo->op_first;
5491 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5492 if (kid->op_type == OP_CONST) {
5496 SV *kidsv = kid->op_sv;
5499 /* Is it a constant from cv_const_sv()? */
5500 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5501 SV *rsv = SvRV(kidsv);
5502 int svtype = SvTYPE(rsv);
5503 char *badtype = Nullch;
5505 switch (o->op_type) {
5507 if (svtype > SVt_PVMG)
5508 badtype = "a SCALAR";
5511 if (svtype != SVt_PVAV)
5512 badtype = "an ARRAY";
5515 if (svtype != SVt_PVHV) {
5516 if (svtype == SVt_PVAV) { /* pseudohash? */
5517 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5518 if (ksv && SvROK(*ksv)
5519 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5528 if (svtype != SVt_PVCV)
5533 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5536 name = SvPV(kidsv, n_a);
5537 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5538 char *badthing = Nullch;
5539 switch (o->op_type) {
5541 badthing = "a SCALAR";
5544 badthing = "an ARRAY";
5547 badthing = "a HASH";
5552 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5556 * This is a little tricky. We only want to add the symbol if we
5557 * didn't add it in the lexer. Otherwise we get duplicate strict
5558 * warnings. But if we didn't add it in the lexer, we must at
5559 * least pretend like we wanted to add it even if it existed before,
5560 * or we get possible typo warnings. OPpCONST_ENTERED says
5561 * whether the lexer already added THIS instance of this symbol.
5563 iscv = (o->op_type == OP_RV2CV) * 2;
5565 gv = gv_fetchpv(name,
5566 iscv | !(kid->op_private & OPpCONST_ENTERED),
5569 : o->op_type == OP_RV2SV
5571 : o->op_type == OP_RV2AV
5573 : o->op_type == OP_RV2HV
5576 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5578 kid->op_type = OP_GV;
5579 SvREFCNT_dec(kid->op_sv);
5581 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5582 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5583 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5585 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5587 kid->op_sv = SvREFCNT_inc(gv);
5589 kid->op_private = 0;
5590 kid->op_ppaddr = PL_ppaddr[OP_GV];
5597 Perl_ck_ftst(pTHX_ OP *o)
5599 I32 type = o->op_type;
5601 if (o->op_flags & OPf_REF) {
5604 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5605 SVOP *kid = (SVOP*)cUNOPo->op_first;
5607 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5609 OP *newop = newGVOP(type, OPf_REF,
5610 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5617 if (type == OP_FTTTY)
5618 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5621 o = newUNOP(type, 0, newDEFSVOP());
5624 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5626 if (PL_hints & HINT_LOCALE)
5627 o->op_private |= OPpLOCALE;
5634 Perl_ck_fun(pTHX_ OP *o)
5640 int type = o->op_type;
5641 register I32 oa = PL_opargs[type] >> OASHIFT;
5643 if (o->op_flags & OPf_STACKED) {
5644 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5647 return no_fh_allowed(o);
5650 if (o->op_flags & OPf_KIDS) {
5652 tokid = &cLISTOPo->op_first;
5653 kid = cLISTOPo->op_first;
5654 if (kid->op_type == OP_PUSHMARK ||
5655 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5657 tokid = &kid->op_sibling;
5658 kid = kid->op_sibling;
5660 if (!kid && PL_opargs[type] & OA_DEFGV)
5661 *tokid = kid = newDEFSVOP();
5665 sibl = kid->op_sibling;
5668 /* list seen where single (scalar) arg expected? */
5669 if (numargs == 1 && !(oa >> 4)
5670 && kid->op_type == OP_LIST && type != OP_SCALAR)
5672 return too_many_arguments(o,PL_op_desc[type]);
5685 if ((type == OP_PUSH || type == OP_UNSHIFT)
5686 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5687 Perl_warner(aTHX_ WARN_SYNTAX,
5688 "Useless use of %s with no values",
5691 if (kid->op_type == OP_CONST &&
5692 (kid->op_private & OPpCONST_BARE))
5694 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5695 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5696 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5697 if (ckWARN(WARN_DEPRECATED))
5698 Perl_warner(aTHX_ WARN_DEPRECATED,
5699 "Array @%s missing the @ in argument %"IVdf" of %s()",
5700 name, (IV)numargs, PL_op_desc[type]);
5703 kid->op_sibling = sibl;
5706 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5707 bad_type(numargs, "array", PL_op_desc[type], kid);
5711 if (kid->op_type == OP_CONST &&
5712 (kid->op_private & OPpCONST_BARE))
5714 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5715 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5716 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5717 if (ckWARN(WARN_DEPRECATED))
5718 Perl_warner(aTHX_ WARN_DEPRECATED,
5719 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5720 name, (IV)numargs, PL_op_desc[type]);
5723 kid->op_sibling = sibl;
5726 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5727 bad_type(numargs, "hash", PL_op_desc[type], kid);
5732 OP *newop = newUNOP(OP_NULL, 0, kid);
5733 kid->op_sibling = 0;
5735 newop->op_next = newop;
5737 kid->op_sibling = sibl;
5742 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5743 if (kid->op_type == OP_CONST &&
5744 (kid->op_private & OPpCONST_BARE))
5746 OP *newop = newGVOP(OP_GV, 0,
5747 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5752 else if (kid->op_type == OP_READLINE) {
5753 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5754 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5757 I32 flags = OPf_SPECIAL;
5761 /* is this op a FH constructor? */
5762 if (is_handle_constructor(o,numargs)) {
5763 char *name = Nullch;
5767 /* Set a flag to tell rv2gv to vivify
5768 * need to "prove" flag does not mean something
5769 * else already - NI-S 1999/05/07
5772 if (kid->op_type == OP_PADSV) {
5773 SV **namep = av_fetch(PL_comppad_name,
5775 if (namep && *namep)
5776 name = SvPV(*namep, len);
5778 else if (kid->op_type == OP_RV2SV
5779 && kUNOP->op_first->op_type == OP_GV)
5781 GV *gv = cGVOPx_gv(kUNOP->op_first);
5783 len = GvNAMELEN(gv);
5785 else if (kid->op_type == OP_AELEM
5786 || kid->op_type == OP_HELEM)
5788 name = "__ANONIO__";
5794 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5795 namesv = PL_curpad[targ];
5796 (void)SvUPGRADE(namesv, SVt_PV);
5798 sv_setpvn(namesv, "$", 1);
5799 sv_catpvn(namesv, name, len);
5802 kid->op_sibling = 0;
5803 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5804 kid->op_targ = targ;
5805 kid->op_private |= priv;
5807 kid->op_sibling = sibl;
5813 mod(scalar(kid), type);
5817 tokid = &kid->op_sibling;
5818 kid = kid->op_sibling;
5820 o->op_private |= numargs;
5822 return too_many_arguments(o,PL_op_desc[o->op_type]);
5825 else if (PL_opargs[type] & OA_DEFGV) {
5827 return newUNOP(type, 0, newDEFSVOP());
5831 while (oa & OA_OPTIONAL)
5833 if (oa && oa != OA_LIST)
5834 return too_few_arguments(o,PL_op_desc[o->op_type]);
5840 Perl_ck_glob(pTHX_ OP *o)
5845 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5846 append_elem(OP_GLOB, o, newDEFSVOP());
5848 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5849 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5851 #if !defined(PERL_EXTERNAL_GLOB)
5852 /* XXX this can be tightened up and made more failsafe. */
5856 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5858 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5859 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5860 GvCV(gv) = GvCV(glob_gv);
5861 SvREFCNT_inc((SV*)GvCV(gv));
5862 GvIMPORTED_CV_on(gv);
5865 #endif /* PERL_EXTERNAL_GLOB */
5867 if (gv && GvIMPORTED_CV(gv)) {
5868 append_elem(OP_GLOB, o,
5869 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5870 o->op_type = OP_LIST;
5871 o->op_ppaddr = PL_ppaddr[OP_LIST];
5872 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5873 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5874 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5875 append_elem(OP_LIST, o,
5876 scalar(newUNOP(OP_RV2CV, 0,
5877 newGVOP(OP_GV, 0, gv)))));
5878 o = newUNOP(OP_NULL, 0, ck_subr(o));
5879 o->op_targ = OP_GLOB; /* hint at what it used to be */
5882 gv = newGVgen("main");
5884 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5890 Perl_ck_grep(pTHX_ OP *o)
5894 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5896 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5897 NewOp(1101, gwop, 1, LOGOP);
5899 if (o->op_flags & OPf_STACKED) {
5902 kid = cLISTOPo->op_first->op_sibling;
5903 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5906 kid->op_next = (OP*)gwop;
5907 o->op_flags &= ~OPf_STACKED;
5909 kid = cLISTOPo->op_first->op_sibling;
5910 if (type == OP_MAPWHILE)
5917 kid = cLISTOPo->op_first->op_sibling;
5918 if (kid->op_type != OP_NULL)
5919 Perl_croak(aTHX_ "panic: ck_grep");
5920 kid = kUNOP->op_first;
5922 gwop->op_type = type;
5923 gwop->op_ppaddr = PL_ppaddr[type];
5924 gwop->op_first = listkids(o);
5925 gwop->op_flags |= OPf_KIDS;
5926 gwop->op_private = 1;
5927 gwop->op_other = LINKLIST(kid);
5928 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5929 kid->op_next = (OP*)gwop;
5931 kid = cLISTOPo->op_first->op_sibling;
5932 if (!kid || !kid->op_sibling)
5933 return too_few_arguments(o,PL_op_desc[o->op_type]);
5934 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5935 mod(kid, OP_GREPSTART);
5941 Perl_ck_index(pTHX_ OP *o)
5943 if (o->op_flags & OPf_KIDS) {
5944 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5946 kid = kid->op_sibling; /* get past "big" */
5947 if (kid && kid->op_type == OP_CONST)
5948 fbm_compile(((SVOP*)kid)->op_sv, 0);
5954 Perl_ck_lengthconst(pTHX_ OP *o)
5956 /* XXX length optimization goes here */
5961 Perl_ck_lfun(pTHX_ OP *o)
5963 OPCODE type = o->op_type;
5964 return modkids(ck_fun(o), type);
5968 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5970 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5971 switch (cUNOPo->op_first->op_type) {
5973 /* This is needed for
5974 if (defined %stash::)
5975 to work. Do not break Tk.
5977 break; /* Globals via GV can be undef */
5979 case OP_AASSIGN: /* Is this a good idea? */
5980 Perl_warner(aTHX_ WARN_DEPRECATED,
5981 "defined(@array) is deprecated");
5982 Perl_warner(aTHX_ WARN_DEPRECATED,
5983 "\t(Maybe you should just omit the defined()?)\n");
5986 /* This is needed for
5987 if (defined %stash::)
5988 to work. Do not break Tk.
5990 break; /* Globals via GV can be undef */
5992 Perl_warner(aTHX_ WARN_DEPRECATED,
5993 "defined(%%hash) is deprecated");
5994 Perl_warner(aTHX_ WARN_DEPRECATED,
5995 "\t(Maybe you should just omit the defined()?)\n");
6006 Perl_ck_rfun(pTHX_ OP *o)
6008 OPCODE type = o->op_type;
6009 return refkids(ck_fun(o), type);
6013 Perl_ck_listiob(pTHX_ OP *o)
6017 kid = cLISTOPo->op_first;
6020 kid = cLISTOPo->op_first;
6022 if (kid->op_type == OP_PUSHMARK)
6023 kid = kid->op_sibling;
6024 if (kid && o->op_flags & OPf_STACKED)
6025 kid = kid->op_sibling;
6026 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6027 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6028 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6029 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6030 cLISTOPo->op_first->op_sibling = kid;
6031 cLISTOPo->op_last = kid;
6032 kid = kid->op_sibling;
6037 append_elem(o->op_type, o, newDEFSVOP());
6043 if (PL_hints & HINT_LOCALE)
6044 o->op_private |= OPpLOCALE;
6051 Perl_ck_fun_locale(pTHX_ OP *o)
6057 if (PL_hints & HINT_LOCALE)
6058 o->op_private |= OPpLOCALE;
6065 Perl_ck_sassign(pTHX_ OP *o)
6067 OP *kid = cLISTOPo->op_first;
6068 /* has a disposable target? */
6069 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6070 && !(kid->op_flags & OPf_STACKED)
6071 /* Cannot steal the second time! */
6072 && !(kid->op_private & OPpTARGET_MY))
6074 OP *kkid = kid->op_sibling;
6076 /* Can just relocate the target. */
6077 if (kkid && kkid->op_type == OP_PADSV
6078 && !(kkid->op_private & OPpLVAL_INTRO))
6080 kid->op_targ = kkid->op_targ;
6082 /* Now we do not need PADSV and SASSIGN. */
6083 kid->op_sibling = o->op_sibling; /* NULL */
6084 cLISTOPo->op_first = NULL;
6087 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6095 Perl_ck_scmp(pTHX_ OP *o)
6099 if (PL_hints & HINT_LOCALE)
6100 o->op_private |= OPpLOCALE;
6107 Perl_ck_match(pTHX_ OP *o)
6109 o->op_private |= OPpRUNTIME;
6114 Perl_ck_method(pTHX_ OP *o)
6116 OP *kid = cUNOPo->op_first;
6117 if (kid->op_type == OP_CONST) {
6118 SV* sv = kSVOP->op_sv;
6119 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6121 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6122 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6125 kSVOP->op_sv = Nullsv;
6127 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6136 Perl_ck_null(pTHX_ OP *o)
6142 Perl_ck_open(pTHX_ OP *o)
6144 HV *table = GvHV(PL_hintgv);
6148 svp = hv_fetch(table, "open_IN", 7, FALSE);
6150 mode = mode_from_discipline(*svp);
6151 if (mode & O_BINARY)
6152 o->op_private |= OPpOPEN_IN_RAW;
6153 else if (mode & O_TEXT)
6154 o->op_private |= OPpOPEN_IN_CRLF;
6157 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6159 mode = mode_from_discipline(*svp);
6160 if (mode & O_BINARY)
6161 o->op_private |= OPpOPEN_OUT_RAW;
6162 else if (mode & O_TEXT)
6163 o->op_private |= OPpOPEN_OUT_CRLF;
6166 if (o->op_type == OP_BACKTICK)
6172 Perl_ck_repeat(pTHX_ OP *o)
6174 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6175 o->op_private |= OPpREPEAT_DOLIST;
6176 cBINOPo->op_first = force_list(cBINOPo->op_first);
6184 Perl_ck_require(pTHX_ OP *o)
6186 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6187 SVOP *kid = (SVOP*)cUNOPo->op_first;
6189 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6191 for (s = SvPVX(kid->op_sv); *s; s++) {
6192 if (*s == ':' && s[1] == ':') {
6194 Move(s+2, s+1, strlen(s+2)+1, char);
6195 --SvCUR(kid->op_sv);
6198 if (SvREADONLY(kid->op_sv)) {
6199 SvREADONLY_off(kid->op_sv);
6200 sv_catpvn(kid->op_sv, ".pm", 3);
6201 SvREADONLY_on(kid->op_sv);
6204 sv_catpvn(kid->op_sv, ".pm", 3);
6211 Perl_ck_return(pTHX_ OP *o)
6214 if (CvLVALUE(PL_compcv)) {
6215 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6216 mod(kid, OP_LEAVESUBLV);
6223 Perl_ck_retarget(pTHX_ OP *o)
6225 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6232 Perl_ck_select(pTHX_ OP *o)
6235 if (o->op_flags & OPf_KIDS) {
6236 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6237 if (kid && kid->op_sibling) {
6238 o->op_type = OP_SSELECT;
6239 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6241 return fold_constants(o);
6245 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6246 if (kid && kid->op_type == OP_RV2GV)
6247 kid->op_private &= ~HINT_STRICT_REFS;
6252 Perl_ck_shift(pTHX_ OP *o)
6254 I32 type = o->op_type;
6256 if (!(o->op_flags & OPf_KIDS)) {
6261 if (!CvUNIQUE(PL_compcv)) {
6262 argop = newOP(OP_PADAV, OPf_REF);
6263 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6266 argop = newUNOP(OP_RV2AV, 0,
6267 scalar(newGVOP(OP_GV, 0,
6268 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6271 argop = newUNOP(OP_RV2AV, 0,
6272 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6273 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6274 #endif /* USE_THREADS */
6275 return newUNOP(type, 0, scalar(argop));
6277 return scalar(modkids(ck_fun(o), type));
6281 Perl_ck_sort(pTHX_ OP *o)
6286 if (PL_hints & HINT_LOCALE)
6287 o->op_private |= OPpLOCALE;
6290 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6292 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6293 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6295 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6297 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6299 if (kid->op_type == OP_SCOPE) {
6303 else if (kid->op_type == OP_LEAVE) {
6304 if (o->op_type == OP_SORT) {
6305 null(kid); /* wipe out leave */
6308 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6309 if (k->op_next == kid)
6311 /* don't descend into loops */
6312 else if (k->op_type == OP_ENTERLOOP
6313 || k->op_type == OP_ENTERITER)
6315 k = cLOOPx(k)->op_lastop;
6320 kid->op_next = 0; /* just disconnect the leave */
6321 k = kLISTOP->op_first;
6326 if (o->op_type == OP_SORT) {
6327 /* provide scalar context for comparison function/block */
6333 o->op_flags |= OPf_SPECIAL;
6335 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6338 firstkid = firstkid->op_sibling;
6341 /* provide list context for arguments */
6342 if (o->op_type == OP_SORT)
6349 S_simplify_sort(pTHX_ OP *o)
6351 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6355 if (!(o->op_flags & OPf_STACKED))
6357 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6358 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6359 kid = kUNOP->op_first; /* get past null */
6360 if (kid->op_type != OP_SCOPE)
6362 kid = kLISTOP->op_last; /* get past scope */
6363 switch(kid->op_type) {
6371 k = kid; /* remember this node*/
6372 if (kBINOP->op_first->op_type != OP_RV2SV)
6374 kid = kBINOP->op_first; /* get past cmp */
6375 if (kUNOP->op_first->op_type != OP_GV)
6377 kid = kUNOP->op_first; /* get past rv2sv */
6379 if (GvSTASH(gv) != PL_curstash)
6381 if (strEQ(GvNAME(gv), "a"))
6383 else if (strEQ(GvNAME(gv), "b"))
6387 kid = k; /* back to cmp */
6388 if (kBINOP->op_last->op_type != OP_RV2SV)
6390 kid = kBINOP->op_last; /* down to 2nd arg */
6391 if (kUNOP->op_first->op_type != OP_GV)
6393 kid = kUNOP->op_first; /* get past rv2sv */
6395 if (GvSTASH(gv) != PL_curstash
6397 ? strNE(GvNAME(gv), "a")
6398 : strNE(GvNAME(gv), "b")))
6400 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6402 o->op_private |= OPpSORT_REVERSE;
6403 if (k->op_type == OP_NCMP)
6404 o->op_private |= OPpSORT_NUMERIC;
6405 if (k->op_type == OP_I_NCMP)
6406 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6407 kid = cLISTOPo->op_first->op_sibling;
6408 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6409 op_free(kid); /* then delete it */
6413 Perl_ck_split(pTHX_ OP *o)
6417 if (o->op_flags & OPf_STACKED)
6418 return no_fh_allowed(o);
6420 kid = cLISTOPo->op_first;
6421 if (kid->op_type != OP_NULL)
6422 Perl_croak(aTHX_ "panic: ck_split");
6423 kid = kid->op_sibling;
6424 op_free(cLISTOPo->op_first);
6425 cLISTOPo->op_first = kid;
6427 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6428 cLISTOPo->op_last = kid; /* There was only one element previously */
6431 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6432 OP *sibl = kid->op_sibling;
6433 kid->op_sibling = 0;
6434 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6435 if (cLISTOPo->op_first == cLISTOPo->op_last)
6436 cLISTOPo->op_last = kid;
6437 cLISTOPo->op_first = kid;
6438 kid->op_sibling = sibl;
6441 kid->op_type = OP_PUSHRE;
6442 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6445 if (!kid->op_sibling)
6446 append_elem(OP_SPLIT, o, newDEFSVOP());
6448 kid = kid->op_sibling;
6451 if (!kid->op_sibling)
6452 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6454 kid = kid->op_sibling;
6457 if (kid->op_sibling)
6458 return too_many_arguments(o,PL_op_desc[o->op_type]);
6464 Perl_ck_join(pTHX_ OP *o)
6466 if (ckWARN(WARN_SYNTAX)) {
6467 OP *kid = cLISTOPo->op_first->op_sibling;
6468 if (kid && kid->op_type == OP_MATCH) {
6469 char *pmstr = "STRING";
6470 if (kPMOP->op_pmregexp)
6471 pmstr = kPMOP->op_pmregexp->precomp;
6472 Perl_warner(aTHX_ WARN_SYNTAX,
6473 "/%s/ should probably be written as \"%s\"",
6481 Perl_ck_subr(pTHX_ OP *o)
6483 OP *prev = ((cUNOPo->op_first->op_sibling)
6484 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6485 OP *o2 = prev->op_sibling;
6494 o->op_private |= OPpENTERSUB_HASTARG;
6495 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6496 if (cvop->op_type == OP_RV2CV) {
6498 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6499 null(cvop); /* disable rv2cv */
6500 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6501 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6502 GV *gv = cGVOPx_gv(tmpop);
6505 tmpop->op_private |= OPpEARLY_CV;
6506 else if (SvPOK(cv)) {
6507 namegv = CvANON(cv) ? gv : CvGV(cv);
6508 proto = SvPV((SV*)cv, n_a);
6512 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6513 if (o2->op_type == OP_CONST)
6514 o2->op_private &= ~OPpCONST_STRICT;
6515 else if (o2->op_type == OP_LIST) {
6516 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6517 if (o && o->op_type == OP_CONST)
6518 o->op_private &= ~OPpCONST_STRICT;
6521 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6522 if (PERLDB_SUB && PL_curstash != PL_debstash)
6523 o->op_private |= OPpENTERSUB_DB;
6524 while (o2 != cvop) {
6528 return too_many_arguments(o, gv_ename(namegv));
6546 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6548 arg == 1 ? "block or sub {}" : "sub {}",
6549 gv_ename(namegv), o2);
6552 /* '*' allows any scalar type, including bareword */
6555 if (o2->op_type == OP_RV2GV)
6556 goto wrapref; /* autoconvert GLOB -> GLOBref */
6557 else if (o2->op_type == OP_CONST)
6558 o2->op_private &= ~OPpCONST_STRICT;
6559 else if (o2->op_type == OP_ENTERSUB) {
6560 /* accidental subroutine, revert to bareword */
6561 OP *gvop = ((UNOP*)o2)->op_first;
6562 if (gvop && gvop->op_type == OP_NULL) {
6563 gvop = ((UNOP*)gvop)->op_first;
6565 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6568 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6569 (gvop = ((UNOP*)gvop)->op_first) &&
6570 gvop->op_type == OP_GV)
6572 GV *gv = cGVOPx_gv(gvop);
6573 OP *sibling = o2->op_sibling;
6574 SV *n = newSVpvn("",0);
6576 gv_fullname3(n, gv, "");
6577 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6578 sv_chop(n, SvPVX(n)+6);
6579 o2 = newSVOP(OP_CONST, 0, n);
6580 prev->op_sibling = o2;
6581 o2->op_sibling = sibling;
6593 if (o2->op_type != OP_RV2GV)
6594 bad_type(arg, "symbol", gv_ename(namegv), o2);
6597 if (o2->op_type != OP_ENTERSUB)
6598 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6601 if (o2->op_type != OP_RV2SV
6602 && o2->op_type != OP_PADSV
6603 && o2->op_type != OP_HELEM
6604 && o2->op_type != OP_AELEM
6605 && o2->op_type != OP_THREADSV)
6607 bad_type(arg, "scalar", gv_ename(namegv), o2);
6611 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6612 bad_type(arg, "array", gv_ename(namegv), o2);
6615 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6616 bad_type(arg, "hash", gv_ename(namegv), o2);
6620 OP* sib = kid->op_sibling;
6621 kid->op_sibling = 0;
6622 o2 = newUNOP(OP_REFGEN, 0, kid);
6623 o2->op_sibling = sib;
6624 prev->op_sibling = o2;
6635 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6636 gv_ename(namegv), SvPV((SV*)cv, n_a));
6641 mod(o2, OP_ENTERSUB);
6643 o2 = o2->op_sibling;
6645 if (proto && !optional &&
6646 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6647 return too_few_arguments(o, gv_ename(namegv));
6652 Perl_ck_svconst(pTHX_ OP *o)
6654 SvREADONLY_on(cSVOPo->op_sv);
6659 Perl_ck_trunc(pTHX_ OP *o)
6661 if (o->op_flags & OPf_KIDS) {
6662 SVOP *kid = (SVOP*)cUNOPo->op_first;
6664 if (kid->op_type == OP_NULL)
6665 kid = (SVOP*)kid->op_sibling;
6666 if (kid && kid->op_type == OP_CONST &&
6667 (kid->op_private & OPpCONST_BARE))
6669 o->op_flags |= OPf_SPECIAL;
6670 kid->op_private &= ~OPpCONST_STRICT;
6677 Perl_ck_substr(pTHX_ OP *o)
6680 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6681 OP *kid = cLISTOPo->op_first;
6683 if (kid->op_type == OP_NULL)
6684 kid = kid->op_sibling;
6686 kid->op_flags |= OPf_MOD;
6692 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6695 Perl_peep(pTHX_ register OP *o)
6697 register OP* oldop = 0;
6700 if (!o || o->op_seq)
6704 SAVEVPTR(PL_curcop);
6705 for (; o; o = o->op_next) {
6711 switch (o->op_type) {
6715 PL_curcop = ((COP*)o); /* for warnings */
6716 o->op_seq = PL_op_seqmax++;
6720 if (cSVOPo->op_private & OPpCONST_STRICT)
6721 no_bareword_allowed(o);
6723 /* Relocate sv to the pad for thread safety.
6724 * Despite being a "constant", the SV is written to,
6725 * for reference counts, sv_upgrade() etc. */
6727 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6728 if (SvPADTMP(cSVOPo->op_sv)) {
6729 /* If op_sv is already a PADTMP then it is being used by
6730 * some pad, so make a copy. */
6731 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6732 SvREADONLY_on(PL_curpad[ix]);
6733 SvREFCNT_dec(cSVOPo->op_sv);
6736 SvREFCNT_dec(PL_curpad[ix]);
6737 SvPADTMP_on(cSVOPo->op_sv);
6738 PL_curpad[ix] = cSVOPo->op_sv;
6739 /* XXX I don't know how this isn't readonly already. */
6740 SvREADONLY_on(PL_curpad[ix]);
6742 cSVOPo->op_sv = Nullsv;
6746 o->op_seq = PL_op_seqmax++;
6750 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6751 if (o->op_next->op_private & OPpTARGET_MY) {
6752 if (o->op_flags & OPf_STACKED) /* chained concats */
6753 goto ignore_optimization;
6755 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6756 o->op_targ = o->op_next->op_targ;
6757 o->op_next->op_targ = 0;
6758 o->op_private |= OPpTARGET_MY;
6763 ignore_optimization:
6764 o->op_seq = PL_op_seqmax++;
6767 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6768 o->op_seq = PL_op_seqmax++;
6769 break; /* Scalar stub must produce undef. List stub is noop */
6773 if (o->op_targ == OP_NEXTSTATE
6774 || o->op_targ == OP_DBSTATE
6775 || o->op_targ == OP_SETSTATE)
6777 PL_curcop = ((COP*)o);
6784 if (oldop && o->op_next) {
6785 oldop->op_next = o->op_next;
6788 o->op_seq = PL_op_seqmax++;
6792 if (o->op_next->op_type == OP_RV2SV) {
6793 if (!(o->op_next->op_private & OPpDEREF)) {
6795 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6797 o->op_next = o->op_next->op_next;
6798 o->op_type = OP_GVSV;
6799 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6802 else if (o->op_next->op_type == OP_RV2AV) {
6803 OP* pop = o->op_next->op_next;
6805 if (pop->op_type == OP_CONST &&
6806 (PL_op = pop->op_next) &&
6807 pop->op_next->op_type == OP_AELEM &&
6808 !(pop->op_next->op_private &
6809 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6810 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6818 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6819 o->op_next = pop->op_next->op_next;
6820 o->op_type = OP_AELEMFAST;
6821 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6822 o->op_private = (U8)i;
6827 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6829 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6830 /* XXX could check prototype here instead of just carping */
6831 SV *sv = sv_newmortal();
6832 gv_efullname3(sv, gv, Nullch);
6833 Perl_warner(aTHX_ WARN_PROTOTYPE,
6834 "%s() called too early to check prototype",
6839 o->op_seq = PL_op_seqmax++;
6850 o->op_seq = PL_op_seqmax++;
6851 while (cLOGOP->op_other->op_type == OP_NULL)
6852 cLOGOP->op_other = cLOGOP->op_other->op_next;
6853 peep(cLOGOP->op_other);
6858 o->op_seq = PL_op_seqmax++;
6859 while (cLOOP->op_redoop->op_type == OP_NULL)
6860 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6861 peep(cLOOP->op_redoop);
6862 while (cLOOP->op_nextop->op_type == OP_NULL)
6863 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6864 peep(cLOOP->op_nextop);
6865 while (cLOOP->op_lastop->op_type == OP_NULL)
6866 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6867 peep(cLOOP->op_lastop);
6873 o->op_seq = PL_op_seqmax++;
6874 while (cPMOP->op_pmreplstart &&
6875 cPMOP->op_pmreplstart->op_type == OP_NULL)
6876 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6877 peep(cPMOP->op_pmreplstart);
6881 o->op_seq = PL_op_seqmax++;
6882 if (ckWARN(WARN_SYNTAX) && o->op_next
6883 && o->op_next->op_type == OP_NEXTSTATE) {
6884 if (o->op_next->op_sibling &&
6885 o->op_next->op_sibling->op_type != OP_EXIT &&
6886 o->op_next->op_sibling->op_type != OP_WARN &&
6887 o->op_next->op_sibling->op_type != OP_DIE) {
6888 line_t oldline = CopLINE(PL_curcop);
6890 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6891 Perl_warner(aTHX_ WARN_EXEC,
6892 "Statement unlikely to be reached");
6893 Perl_warner(aTHX_ WARN_EXEC,
6894 "\t(Maybe you meant system() when you said exec()?)\n");
6895 CopLINE_set(PL_curcop, oldline);
6904 SV **svp, **indsvp, *sv;
6909 o->op_seq = PL_op_seqmax++;
6911 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6914 /* Make the CONST have a shared SV */
6915 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6916 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6917 key = SvPV(sv, keylen);
6920 lexname = newSVpvn_share(key, keylen, 0);
6925 if ((o->op_private & (OPpLVAL_INTRO)))
6928 rop = (UNOP*)((BINOP*)o)->op_first;
6929 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6931 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6932 if (!SvOBJECT(lexname))
6934 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6935 if (!fields || !GvHV(*fields))
6937 key = SvPV(*svp, keylen);
6940 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6942 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6943 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6945 ind = SvIV(*indsvp);
6947 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6948 rop->op_type = OP_RV2AV;
6949 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6950 o->op_type = OP_AELEM;
6951 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6953 if (SvREADONLY(*svp))
6955 SvFLAGS(sv) |= (SvFLAGS(*svp)
6956 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6966 SV **svp, **indsvp, *sv;
6970 SVOP *first_key_op, *key_op;
6972 o->op_seq = PL_op_seqmax++;
6973 if ((o->op_private & (OPpLVAL_INTRO))
6974 /* I bet there's always a pushmark... */
6975 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6976 /* hmmm, no optimization if list contains only one key. */
6978 rop = (UNOP*)((LISTOP*)o)->op_last;
6979 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6981 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6982 if (!SvOBJECT(lexname))
6984 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6985 if (!fields || !GvHV(*fields))
6987 /* Again guessing that the pushmark can be jumped over.... */
6988 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6989 ->op_first->op_sibling;
6990 /* Check that the key list contains only constants. */
6991 for (key_op = first_key_op; key_op;
6992 key_op = (SVOP*)key_op->op_sibling)
6993 if (key_op->op_type != OP_CONST)
6997 rop->op_type = OP_RV2AV;
6998 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6999 o->op_type = OP_ASLICE;
7000 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7001 for (key_op = first_key_op; key_op;
7002 key_op = (SVOP*)key_op->op_sibling) {
7003 svp = cSVOPx_svp(key_op);
7004 key = SvPV(*svp, keylen);
7007 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7009 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7010 "in variable %s of type %s",
7011 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7013 ind = SvIV(*indsvp);
7015 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7017 if (SvREADONLY(*svp))
7019 SvFLAGS(sv) |= (SvFLAGS(*svp)
7020 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7028 o->op_seq = PL_op_seqmax++;
7038 /* Efficient sub that returns a constant scalar value. */
7040 const_sv_xsub(pTHXo_ CV* cv)
7045 Perl_croak(aTHX_ "usage: %s::%s()",
7046 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7050 ST(0) = (SV*)XSANY.any_ptr;