3 * Copyright (c) 1991-2000, 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
60 S_gv_ename(pTHX_ GV *gv)
63 SV* tmpsv = sv_newmortal();
64 gv_efullname3(tmpsv, gv, Nullch);
65 return SvPV(tmpsv,n_a);
69 S_no_fh_allowed(pTHX_ OP *o)
71 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
72 PL_op_desc[o->op_type]));
77 S_too_few_arguments(pTHX_ OP *o, char *name)
79 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
84 S_too_many_arguments(pTHX_ OP *o, char *name)
86 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
91 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
93 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
94 (int)n, name, t, PL_op_desc[kid->op_type]));
98 S_no_bareword_allowed(pTHX_ OP *o)
100 qerror(Perl_mess(aTHX_
101 "Bareword \"%s\" not allowed while \"strict subs\" in use",
102 SvPV_nolen(cSVOPo_sv)));
105 /* "register" allocation */
108 Perl_pad_allocmy(pTHX_ char *name)
113 if (!(PL_in_my == KEY_our ||
115 (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) ||
116 (name[1] == '_' && (int)strlen(name) > 2)))
118 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
119 /* 1999-02-27 mjd@plover.com */
121 p = strchr(name, '\0');
122 /* The next block assumes the buffer is at least 205 chars
123 long. At present, it's always at least 256 chars. */
125 strcpy(name+200, "...");
131 /* Move everything else down one character */
132 for (; p-name > 2; p--)
134 name[2] = toCTRL(name[1]);
137 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
139 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
140 SV **svp = AvARRAY(PL_comppad_name);
141 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
142 PADOFFSET top = AvFILLp(PL_comppad_name);
143 for (off = top; off > PL_comppad_name_floor; off--) {
145 && sv != &PL_sv_undef
146 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
147 && (PL_in_my != KEY_our
148 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
149 && strEQ(name, SvPVX(sv)))
151 Perl_warner(aTHX_ WARN_MISC,
152 "\"%s\" variable %s masks earlier declaration in same %s",
153 (PL_in_my == KEY_our ? "our" : "my"),
155 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
160 if (PL_in_my == KEY_our) {
163 && sv != &PL_sv_undef
164 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
165 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
166 && strEQ(name, SvPVX(sv)))
168 Perl_warner(aTHX_ WARN_MISC,
169 "\"our\" variable %s redeclared", name);
170 Perl_warner(aTHX_ WARN_MISC,
171 "\t(Did you mean \"local\" instead of \"our\"?)\n");
174 } while ( off-- > 0 );
177 off = pad_alloc(OP_PADSV, SVs_PADMY);
179 sv_upgrade(sv, SVt_PVNV);
181 if (PL_in_my_stash) {
183 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
184 name, PL_in_my == KEY_our ? "our" : "my"));
186 (void)SvUPGRADE(sv, SVt_PVMG);
187 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
190 if (PL_in_my == KEY_our) {
191 (void)SvUPGRADE(sv, SVt_PVGV);
192 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
193 SvFLAGS(sv) |= SVpad_OUR;
195 av_store(PL_comppad_name, off, sv);
196 SvNVX(sv) = (NV)PAD_MAX;
197 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
198 if (!PL_min_intro_pending)
199 PL_min_intro_pending = off;
200 PL_max_intro_pending = off;
202 av_store(PL_comppad, off, (SV*)newAV());
203 else if (*name == '%')
204 av_store(PL_comppad, off, (SV*)newHV());
205 SvPADMY_on(PL_curpad[off]);
210 S_pad_addlex(pTHX_ SV *proto_namesv)
212 SV *namesv = NEWSV(1103,0);
213 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
214 sv_upgrade(namesv, SVt_PVNV);
215 sv_setpv(namesv, SvPVX(proto_namesv));
216 av_store(PL_comppad_name, newoff, namesv);
217 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
218 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
219 SvFAKE_on(namesv); /* A ref, not a real var */
220 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
221 SvFLAGS(namesv) |= SVpad_OUR;
222 (void)SvUPGRADE(namesv, SVt_PVGV);
223 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
225 if (SvOBJECT(proto_namesv)) { /* A typed var */
227 (void)SvUPGRADE(namesv, SVt_PVMG);
228 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
234 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
237 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
238 I32 cx_ix, I32 saweval, U32 flags)
244 register PERL_CONTEXT *cx;
246 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
247 AV *curlist = CvPADLIST(cv);
248 SV **svp = av_fetch(curlist, 0, FALSE);
251 if (!svp || *svp == &PL_sv_undef)
254 svp = AvARRAY(curname);
255 for (off = AvFILLp(curname); off > 0; off--) {
256 if ((sv = svp[off]) &&
257 sv != &PL_sv_undef &&
259 seq > I_32(SvNVX(sv)) &&
260 strEQ(SvPVX(sv), name))
271 return 0; /* don't clone from inactive stack frame */
275 oldpad = (AV*)AvARRAY(curlist)[depth];
276 oldsv = *av_fetch(oldpad, off, TRUE);
277 if (!newoff) { /* Not a mere clone operation. */
278 newoff = pad_addlex(sv);
279 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
280 /* "It's closures all the way down." */
281 CvCLONE_on(PL_compcv);
283 if (CvANON(PL_compcv))
284 oldsv = Nullsv; /* no need to keep ref */
289 bcv && bcv != cv && !CvCLONE(bcv);
290 bcv = CvOUTSIDE(bcv))
293 /* install the missing pad entry in intervening
294 * nested subs and mark them cloneable.
295 * XXX fix pad_foo() to not use globals */
296 AV *ocomppad_name = PL_comppad_name;
297 AV *ocomppad = PL_comppad;
298 SV **ocurpad = PL_curpad;
299 AV *padlist = CvPADLIST(bcv);
300 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
301 PL_comppad = (AV*)AvARRAY(padlist)[1];
302 PL_curpad = AvARRAY(PL_comppad);
304 PL_comppad_name = ocomppad_name;
305 PL_comppad = ocomppad;
310 if (ckWARN(WARN_CLOSURE)
311 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
313 Perl_warner(aTHX_ WARN_CLOSURE,
314 "Variable \"%s\" may be unavailable",
322 else if (!CvUNIQUE(PL_compcv)) {
323 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
324 && !(SvFLAGS(sv) & SVpad_OUR))
326 Perl_warner(aTHX_ WARN_CLOSURE,
327 "Variable \"%s\" will not stay shared", name);
331 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
337 if (flags & FINDLEX_NOSEARCH)
340 /* Nothing in current lexical context--try eval's context, if any.
341 * This is necessary to let the perldb get at lexically scoped variables.
342 * XXX This will also probably interact badly with eval tree caching.
345 for (i = cx_ix; i >= 0; i--) {
347 switch (CxTYPE(cx)) {
349 if (i == 0 && saweval) {
350 seq = cxstack[saweval].blk_oldcop->cop_seq;
351 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
355 switch (cx->blk_eval.old_op_type) {
362 /* require/do must have their own scope */
371 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
372 saweval = i; /* so we know where we were called from */
375 seq = cxstack[saweval].blk_oldcop->cop_seq;
376 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
384 Perl_pad_findmy(pTHX_ char *name)
389 SV **svp = AvARRAY(PL_comppad_name);
390 U32 seq = PL_cop_seqmax;
396 * Special case to get lexical (and hence per-thread) @_.
397 * XXX I need to find out how to tell at parse-time whether use
398 * of @_ should refer to a lexical (from a sub) or defgv (global
399 * scope and maybe weird sub-ish things like formats). See
400 * startsub in perly.y. It's possible that @_ could be lexical
401 * (at least from subs) even in non-threaded perl.
403 if (strEQ(name, "@_"))
404 return 0; /* success. (NOT_IN_PAD indicates failure) */
405 #endif /* USE_THREADS */
407 /* The one we're looking for is probably just before comppad_name_fill. */
408 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
409 if ((sv = svp[off]) &&
410 sv != &PL_sv_undef &&
413 seq > I_32(SvNVX(sv)))) &&
414 strEQ(SvPVX(sv), name))
416 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
417 return (PADOFFSET)off;
418 pendoff = off; /* this pending def. will override import */
422 outside = CvOUTSIDE(PL_compcv);
424 /* Check if if we're compiling an eval'', and adjust seq to be the
425 * eval's seq number. This depends on eval'' having a non-null
426 * CvOUTSIDE() while it is being compiled. The eval'' itself is
427 * identified by CvEVAL being true and CvGV being null. */
428 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
429 cx = &cxstack[cxstack_ix];
431 seq = cx->blk_oldcop->cop_seq;
434 /* See if it's in a nested scope */
435 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
437 /* If there is a pending local definition, this new alias must die */
439 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
440 return off; /* pad_findlex returns 0 for failure...*/
442 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
446 Perl_pad_leavemy(pTHX_ I32 fill)
449 SV **svp = AvARRAY(PL_comppad_name);
451 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
452 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
453 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
454 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
457 /* "Deintroduce" my variables that are leaving with this scope. */
458 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
459 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
460 SvIVX(sv) = PL_cop_seqmax;
465 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
470 if (AvARRAY(PL_comppad) != PL_curpad)
471 Perl_croak(aTHX_ "panic: pad_alloc");
472 if (PL_pad_reset_pending)
474 if (tmptype & SVs_PADMY) {
476 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
477 } while (SvPADBUSY(sv)); /* need a fresh one */
478 retval = AvFILLp(PL_comppad);
481 SV **names = AvARRAY(PL_comppad_name);
482 SSize_t names_fill = AvFILLp(PL_comppad_name);
485 * "foreach" index vars temporarily become aliases to non-"my"
486 * values. Thus we must skip, not just pad values that are
487 * marked as current pad values, but also those with names.
489 if (++PL_padix <= names_fill &&
490 (sv = names[PL_padix]) && sv != &PL_sv_undef)
492 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
493 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
494 !IS_PADGV(sv) && !IS_PADCONST(sv))
499 SvFLAGS(sv) |= tmptype;
500 PL_curpad = AvARRAY(PL_comppad);
502 DEBUG_X(PerlIO_printf(Perl_debug_log,
503 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
504 PTR2UV(thr), PTR2UV(PL_curpad),
505 (long) retval, PL_op_name[optype]));
507 DEBUG_X(PerlIO_printf(Perl_debug_log,
508 "Pad 0x%"UVxf" alloc %ld for %s\n",
510 (long) retval, PL_op_name[optype]));
511 #endif /* USE_THREADS */
512 return (PADOFFSET)retval;
516 Perl_pad_sv(pTHX_ PADOFFSET po)
519 DEBUG_X(PerlIO_printf(Perl_debug_log,
520 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
521 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
524 Perl_croak(aTHX_ "panic: pad_sv po");
525 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
526 PTR2UV(PL_curpad), (IV)po));
527 #endif /* USE_THREADS */
528 return PL_curpad[po]; /* eventually we'll turn this into a macro */
532 Perl_pad_free(pTHX_ PADOFFSET po)
536 if (AvARRAY(PL_comppad) != PL_curpad)
537 Perl_croak(aTHX_ "panic: pad_free curpad");
539 Perl_croak(aTHX_ "panic: pad_free po");
541 DEBUG_X(PerlIO_printf(Perl_debug_log,
542 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
543 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
545 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
546 PTR2UV(PL_curpad), (IV)po));
547 #endif /* USE_THREADS */
548 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
549 SvPADTMP_off(PL_curpad[po]);
551 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
554 if ((I32)po < PL_padix)
559 Perl_pad_swipe(pTHX_ PADOFFSET po)
561 if (AvARRAY(PL_comppad) != PL_curpad)
562 Perl_croak(aTHX_ "panic: pad_swipe curpad");
564 Perl_croak(aTHX_ "panic: pad_swipe po");
566 DEBUG_X(PerlIO_printf(Perl_debug_log,
567 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
568 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
570 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
571 PTR2UV(PL_curpad), (IV)po));
572 #endif /* USE_THREADS */
573 SvPADTMP_off(PL_curpad[po]);
574 PL_curpad[po] = NEWSV(1107,0);
575 SvPADTMP_on(PL_curpad[po]);
576 if ((I32)po < PL_padix)
580 /* XXX pad_reset() is currently disabled because it results in serious bugs.
581 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
582 * on the stack by OPs that use them, there are several ways to get an alias
583 * to a shared TARG. Such an alias will change randomly and unpredictably.
584 * We avoid doing this until we can think of a Better Way.
589 #ifdef USE_BROKEN_PAD_RESET
592 if (AvARRAY(PL_comppad) != PL_curpad)
593 Perl_croak(aTHX_ "panic: pad_reset curpad");
595 DEBUG_X(PerlIO_printf(Perl_debug_log,
596 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
597 PTR2UV(thr), PTR2UV(PL_curpad)));
599 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
601 #endif /* USE_THREADS */
602 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
603 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
604 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
605 SvPADTMP_off(PL_curpad[po]);
607 PL_padix = PL_padix_floor;
610 PL_pad_reset_pending = FALSE;
614 /* find_threadsv is not reentrant */
616 Perl_find_threadsv(pTHX_ const char *name)
621 /* We currently only handle names of a single character */
622 p = strchr(PL_threadsv_names, *name);
625 key = p - PL_threadsv_names;
626 MUTEX_LOCK(&thr->mutex);
627 svp = av_fetch(thr->threadsv, key, FALSE);
629 MUTEX_UNLOCK(&thr->mutex);
631 SV *sv = NEWSV(0, 0);
632 av_store(thr->threadsv, key, sv);
633 thr->threadsvp = AvARRAY(thr->threadsv);
634 MUTEX_UNLOCK(&thr->mutex);
636 * Some magic variables used to be automagically initialised
637 * in gv_fetchpv. Those which are now per-thread magicals get
638 * initialised here instead.
644 sv_setpv(sv, "\034");
645 sv_magic(sv, 0, 0, name, 1);
650 PL_sawampersand = TRUE;
664 /* XXX %! tied to Errno.pm needs to be added here.
665 * See gv_fetchpv(). */
669 sv_magic(sv, 0, 0, name, 1);
671 DEBUG_S(PerlIO_printf(Perl_error_log,
672 "find_threadsv: new SV %p for $%s%c\n",
673 sv, (*name < 32) ? "^" : "",
674 (*name < 32) ? toCTRL(*name) : *name));
678 #endif /* USE_THREADS */
683 Perl_op_free(pTHX_ OP *o)
685 register OP *kid, *nextkid;
688 if (!o || o->op_seq == (U16)-1)
691 if (o->op_private & OPpREFCOUNTED) {
692 switch (o->op_type) {
700 if (OpREFCNT_dec(o)) {
711 if (o->op_flags & OPf_KIDS) {
712 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
713 nextkid = kid->op_sibling; /* Get before next freeing kid */
721 /* COP* is not cleared by op_clear() so that we may track line
722 * numbers etc even after null() */
723 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
728 #ifdef PL_OP_SLAB_ALLOC
729 if ((char *) o == PL_OpPtr)
738 S_op_clear(pTHX_ OP *o)
740 switch (o->op_type) {
741 case OP_NULL: /* Was holding old type, if any. */
742 case OP_ENTEREVAL: /* Was holding hints. */
744 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
750 if (!(o->op_flags & OPf_SPECIAL))
753 #endif /* USE_THREADS */
755 if (!(o->op_flags & OPf_REF)
756 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
763 if (cPADOPo->op_padix > 0) {
766 pad_swipe(cPADOPo->op_padix);
767 /* No GvIN_PAD_off(gv) here, because other references may still
768 * exist on the pad */
771 cPADOPo->op_padix = 0;
774 SvREFCNT_dec(cSVOPo->op_sv);
775 cSVOPo->op_sv = Nullsv;
778 case OP_METHOD_NAMED:
780 SvREFCNT_dec(cSVOPo->op_sv);
781 cSVOPo->op_sv = Nullsv;
787 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
791 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
792 SvREFCNT_dec(cSVOPo->op_sv);
793 cSVOPo->op_sv = Nullsv;
796 Safefree(cPVOPo->op_pv);
797 cPVOPo->op_pv = Nullch;
801 op_free(cPMOPo->op_pmreplroot);
805 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
807 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
808 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
809 /* No GvIN_PAD_off(gv) here, because other references may still
810 * exist on the pad */
815 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
821 cPMOPo->op_pmreplroot = Nullop;
822 ReREFCNT_dec(cPMOPo->op_pmregexp);
823 cPMOPo->op_pmregexp = (REGEXP*)NULL;
827 if (o->op_targ > 0) {
828 pad_free(o->op_targ);
834 S_cop_free(pTHX_ COP* cop)
836 Safefree(cop->cop_label);
838 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
839 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
841 /* NOTE: COP.cop_stash is not refcounted */
842 SvREFCNT_dec(CopFILEGV(cop));
844 if (! specialWARN(cop->cop_warnings))
845 SvREFCNT_dec(cop->cop_warnings);
846 if (! specialCopIO(cop->cop_io))
847 SvREFCNT_dec(cop->cop_io);
853 if (o->op_type == OP_NULL)
856 o->op_targ = o->op_type;
857 o->op_type = OP_NULL;
858 o->op_ppaddr = PL_ppaddr[OP_NULL];
861 /* Contextualizers */
863 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
866 Perl_linklist(pTHX_ OP *o)
873 /* establish postfix order */
874 if (cUNOPo->op_first) {
875 o->op_next = LINKLIST(cUNOPo->op_first);
876 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
878 kid->op_next = LINKLIST(kid->op_sibling);
890 Perl_scalarkids(pTHX_ OP *o)
893 if (o && o->op_flags & OPf_KIDS) {
894 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
901 S_scalarboolean(pTHX_ OP *o)
903 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
904 if (ckWARN(WARN_SYNTAX)) {
905 line_t oldline = CopLINE(PL_curcop);
907 if (PL_copline != NOLINE)
908 CopLINE_set(PL_curcop, PL_copline);
909 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
910 CopLINE_set(PL_curcop, oldline);
917 Perl_scalar(pTHX_ OP *o)
921 /* assumes no premature commitment */
922 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
923 || o->op_type == OP_RETURN)
928 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
930 switch (o->op_type) {
932 if (o->op_private & OPpREPEAT_DOLIST)
933 null(((LISTOP*)cBINOPo->op_first)->op_first);
934 scalar(cBINOPo->op_first);
939 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
943 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
944 if (!kPMOP->op_pmreplroot)
945 deprecate("implicit split to @_");
953 if (o->op_flags & OPf_KIDS) {
954 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
960 kid = cLISTOPo->op_first;
962 while ((kid = kid->op_sibling)) {
968 WITH_THR(PL_curcop = &PL_compiling);
973 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
979 WITH_THR(PL_curcop = &PL_compiling);
986 Perl_scalarvoid(pTHX_ OP *o)
993 if (o->op_type == OP_NEXTSTATE
994 || o->op_type == OP_SETSTATE
995 || o->op_type == OP_DBSTATE
996 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
997 || o->op_targ == OP_SETSTATE
998 || o->op_targ == OP_DBSTATE)))
999 PL_curcop = (COP*)o; /* for warning below */
1001 /* assumes no premature commitment */
1002 want = o->op_flags & OPf_WANT;
1003 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1004 || o->op_type == OP_RETURN)
1009 if ((o->op_private & OPpTARGET_MY)
1010 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1012 return scalar(o); /* As if inside SASSIGN */
1015 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1017 switch (o->op_type) {
1019 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1023 if (o->op_flags & OPf_STACKED)
1027 if (o->op_private == 4)
1069 case OP_GETSOCKNAME:
1070 case OP_GETPEERNAME:
1075 case OP_GETPRIORITY:
1098 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1099 useless = PL_op_desc[o->op_type];
1106 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1107 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1108 useless = "a variable";
1113 if (cSVOPo->op_private & OPpCONST_STRICT)
1114 no_bareword_allowed(o);
1116 if (ckWARN(WARN_VOID)) {
1117 useless = "a constant";
1118 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1120 else if (SvPOK(sv)) {
1121 /* perl4's way of mixing documentation and code
1122 (before the invention of POD) was based on a
1123 trick to mix nroff and perl code. The trick was
1124 built upon these three nroff macros being used in
1125 void context. The pink camel has the details in
1126 the script wrapman near page 319. */
1127 if (strnEQ(SvPVX(sv), "di", 2) ||
1128 strnEQ(SvPVX(sv), "ds", 2) ||
1129 strnEQ(SvPVX(sv), "ig", 2))
1134 null(o); /* don't execute or even remember it */
1138 o->op_type = OP_PREINC; /* pre-increment is faster */
1139 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1143 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1144 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1150 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1155 if (o->op_flags & OPf_STACKED)
1162 if (!(o->op_flags & OPf_KIDS))
1171 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1178 /* all requires must return a boolean value */
1179 o->op_flags &= ~OPf_WANT;
1184 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1185 if (!kPMOP->op_pmreplroot)
1186 deprecate("implicit split to @_");
1190 if (useless && ckWARN(WARN_VOID))
1191 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1196 Perl_listkids(pTHX_ OP *o)
1199 if (o && o->op_flags & OPf_KIDS) {
1200 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1207 Perl_list(pTHX_ OP *o)
1211 /* assumes no premature commitment */
1212 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1213 || o->op_type == OP_RETURN)
1218 if ((o->op_private & OPpTARGET_MY)
1219 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1221 return o; /* As if inside SASSIGN */
1224 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1226 switch (o->op_type) {
1229 list(cBINOPo->op_first);
1234 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1242 if (!(o->op_flags & OPf_KIDS))
1244 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1245 list(cBINOPo->op_first);
1246 return gen_constant_list(o);
1253 kid = cLISTOPo->op_first;
1255 while ((kid = kid->op_sibling)) {
1256 if (kid->op_sibling)
1261 WITH_THR(PL_curcop = &PL_compiling);
1265 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1266 if (kid->op_sibling)
1271 WITH_THR(PL_curcop = &PL_compiling);
1274 /* all requires must return a boolean value */
1275 o->op_flags &= ~OPf_WANT;
1282 Perl_scalarseq(pTHX_ OP *o)
1287 if (o->op_type == OP_LINESEQ ||
1288 o->op_type == OP_SCOPE ||
1289 o->op_type == OP_LEAVE ||
1290 o->op_type == OP_LEAVETRY)
1292 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1293 if (kid->op_sibling) {
1297 PL_curcop = &PL_compiling;
1299 o->op_flags &= ~OPf_PARENS;
1300 if (PL_hints & HINT_BLOCK_SCOPE)
1301 o->op_flags |= OPf_PARENS;
1304 o = newOP(OP_STUB, 0);
1309 S_modkids(pTHX_ OP *o, I32 type)
1312 if (o && o->op_flags & OPf_KIDS) {
1313 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1320 Perl_mod(pTHX_ OP *o, I32 type)
1325 if (!o || PL_error_count)
1328 if ((o->op_private & OPpTARGET_MY)
1329 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1334 switch (o->op_type) {
1339 if (!(o->op_private & (OPpCONST_ARYBASE)))
1341 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1342 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1346 SAVEI32(PL_compiling.cop_arybase);
1347 PL_compiling.cop_arybase = 0;
1349 else if (type == OP_REFGEN)
1352 Perl_croak(aTHX_ "That use of $[ is unsupported");
1355 if (o->op_flags & OPf_PARENS)
1359 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1360 !(o->op_flags & OPf_STACKED)) {
1361 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1362 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1363 assert(cUNOPo->op_first->op_type == OP_NULL);
1364 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1367 else { /* lvalue subroutine call */
1368 o->op_private |= OPpLVAL_INTRO;
1369 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1370 /* Backward compatibility mode: */
1371 o->op_private |= OPpENTERSUB_INARGS;
1374 else { /* Compile-time error message: */
1375 OP *kid = cUNOPo->op_first;
1379 if (kid->op_type == OP_PUSHMARK)
1381 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1383 "panic: unexpected lvalue entersub "
1384 "args: type/targ %ld:%ld",
1385 (long)kid->op_type,kid->op_targ);
1386 kid = kLISTOP->op_first;
1388 while (kid->op_sibling)
1389 kid = kid->op_sibling;
1390 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1392 if (kid->op_type == OP_METHOD_NAMED
1393 || kid->op_type == OP_METHOD)
1397 if (kid->op_sibling || kid->op_next != kid) {
1398 yyerror("panic: unexpected optree near method call");
1402 NewOp(1101, newop, 1, UNOP);
1403 newop->op_type = OP_RV2CV;
1404 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1405 newop->op_first = Nullop;
1406 newop->op_next = (OP*)newop;
1407 kid->op_sibling = (OP*)newop;
1408 newop->op_private |= OPpLVAL_INTRO;
1412 if (kid->op_type != OP_RV2CV)
1414 "panic: unexpected lvalue entersub "
1415 "entry via type/targ %ld:%ld",
1416 (long)kid->op_type,kid->op_targ);
1417 kid->op_private |= OPpLVAL_INTRO;
1418 break; /* Postpone until runtime */
1422 kid = kUNOP->op_first;
1423 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1424 kid = kUNOP->op_first;
1425 if (kid->op_type == OP_NULL)
1427 "Unexpected constant lvalue entersub "
1428 "entry via type/targ %ld:%ld",
1429 (long)kid->op_type,kid->op_targ);
1430 if (kid->op_type != OP_GV) {
1431 /* Restore RV2CV to check lvalueness */
1433 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1434 okid->op_next = kid->op_next;
1435 kid->op_next = okid;
1438 okid->op_next = Nullop;
1439 okid->op_type = OP_RV2CV;
1441 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1442 okid->op_private |= OPpLVAL_INTRO;
1446 cv = GvCV(kGVOP_gv);
1456 /* grep, foreach, subcalls, refgen */
1457 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1459 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1460 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1462 : (o->op_type == OP_ENTERSUB
1463 ? "non-lvalue subroutine call"
1464 : PL_op_desc[o->op_type])),
1465 type ? PL_op_desc[type] : "local"));
1479 case OP_RIGHT_SHIFT:
1488 if (!(o->op_flags & OPf_STACKED))
1494 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1500 if (!type && cUNOPo->op_first->op_type != OP_GV)
1501 Perl_croak(aTHX_ "Can't localize through a reference");
1502 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1503 PL_modcount = 10000;
1504 return o; /* Treat \(@foo) like ordinary list. */
1508 if (scalar_mod_type(o, type))
1510 ref(cUNOPo->op_first, o->op_type);
1519 PL_modcount = 10000;
1522 if (!type && cUNOPo->op_first->op_type != OP_GV)
1523 Perl_croak(aTHX_ "Can't localize through a reference");
1524 ref(cUNOPo->op_first, o->op_type);
1528 PL_hints |= HINT_BLOCK_SCOPE;
1538 PL_modcount = 10000;
1539 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1540 return o; /* Treat \(@foo) like ordinary list. */
1541 if (scalar_mod_type(o, type))
1547 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1548 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1553 PL_modcount++; /* XXX ??? */
1555 #endif /* USE_THREADS */
1561 if (type != OP_SASSIGN)
1565 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1571 pad_free(o->op_targ);
1572 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1573 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1574 if (o->op_flags & OPf_KIDS)
1575 mod(cBINOPo->op_first->op_sibling, type);
1580 ref(cBINOPo->op_first, o->op_type);
1581 if (type == OP_ENTERSUB &&
1582 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1583 o->op_private |= OPpLVAL_DEFER;
1590 if (o->op_flags & OPf_KIDS)
1591 mod(cLISTOPo->op_last, type);
1595 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1597 else if (!(o->op_flags & OPf_KIDS))
1599 if (o->op_targ != OP_LIST) {
1600 mod(cBINOPo->op_first, type);
1605 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1609 o->op_flags |= OPf_MOD;
1611 if (type == OP_AASSIGN || type == OP_SASSIGN)
1612 o->op_flags |= OPf_SPECIAL|OPf_REF;
1614 o->op_private |= OPpLVAL_INTRO;
1615 o->op_flags &= ~OPf_SPECIAL;
1616 PL_hints |= HINT_BLOCK_SCOPE;
1618 else if (type != OP_GREPSTART && type != OP_ENTERSUB)
1619 o->op_flags |= OPf_REF;
1624 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1628 if (o->op_type == OP_RV2GV)
1652 case OP_RIGHT_SHIFT:
1671 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1673 switch (o->op_type) {
1681 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1694 Perl_refkids(pTHX_ OP *o, I32 type)
1697 if (o && o->op_flags & OPf_KIDS) {
1698 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1705 Perl_ref(pTHX_ OP *o, I32 type)
1709 if (!o || PL_error_count)
1712 switch (o->op_type) {
1714 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1715 !(o->op_flags & OPf_STACKED)) {
1716 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1717 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1718 assert(cUNOPo->op_first->op_type == OP_NULL);
1719 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1720 o->op_flags |= OPf_SPECIAL;
1725 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1729 if (type == OP_DEFINED)
1730 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1731 ref(cUNOPo->op_first, o->op_type);
1734 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1735 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1736 : type == OP_RV2HV ? OPpDEREF_HV
1738 o->op_flags |= OPf_MOD;
1743 o->op_flags |= OPf_MOD; /* XXX ??? */
1748 o->op_flags |= OPf_REF;
1751 if (type == OP_DEFINED)
1752 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1753 ref(cUNOPo->op_first, o->op_type);
1758 o->op_flags |= OPf_REF;
1763 if (!(o->op_flags & OPf_KIDS))
1765 ref(cBINOPo->op_first, type);
1769 ref(cBINOPo->op_first, o->op_type);
1770 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1771 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1772 : type == OP_RV2HV ? OPpDEREF_HV
1774 o->op_flags |= OPf_MOD;
1782 if (!(o->op_flags & OPf_KIDS))
1784 ref(cLISTOPo->op_last, type);
1794 S_dup_attrlist(pTHX_ OP *o)
1798 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1799 * where the first kid is OP_PUSHMARK and the remaining ones
1800 * are OP_CONST. We need to push the OP_CONST values.
1802 if (o->op_type == OP_CONST)
1803 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1805 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1806 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1807 if (o->op_type == OP_CONST)
1808 rop = append_elem(OP_LIST, rop,
1809 newSVOP(OP_CONST, o->op_flags,
1810 SvREFCNT_inc(cSVOPo->op_sv)));
1817 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1821 /* fake up C<use attributes $pkg,$rv,@attrs> */
1822 ENTER; /* need to protect against side-effects of 'use' */
1824 if (stash && HvNAME(stash))
1825 stashsv = newSVpv(HvNAME(stash), 0);
1827 stashsv = &PL_sv_no;
1829 #define ATTRSMODULE "attributes"
1831 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1832 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1834 prepend_elem(OP_LIST,
1835 newSVOP(OP_CONST, 0, stashsv),
1836 prepend_elem(OP_LIST,
1837 newSVOP(OP_CONST, 0,
1839 dup_attrlist(attrs))));
1844 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1845 char *attrstr, STRLEN len)
1850 len = strlen(attrstr);
1854 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1856 char *sstr = attrstr;
1857 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1858 attrs = append_elem(OP_LIST, attrs,
1859 newSVOP(OP_CONST, 0,
1860 newSVpvn(sstr, attrstr-sstr)));
1864 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1865 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1866 Nullsv, prepend_elem(OP_LIST,
1867 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1868 prepend_elem(OP_LIST,
1869 newSVOP(OP_CONST, 0,
1875 S_my_kid(pTHX_ OP *o, OP *attrs)
1880 if (!o || PL_error_count)
1884 if (type == OP_LIST) {
1885 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1887 } else if (type == OP_UNDEF) {
1889 } else if (type == OP_RV2SV || /* "our" declaration */
1891 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1892 o->op_private |= OPpOUR_INTRO;
1894 } else if (type != OP_PADSV &&
1897 type != OP_PUSHMARK)
1899 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1900 PL_op_desc[o->op_type],
1901 PL_in_my == KEY_our ? "our" : "my"));
1904 else if (attrs && type != OP_PUSHMARK) {
1910 PL_in_my_stash = Nullhv;
1912 /* check for C<my Dog $spot> when deciding package */
1913 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1914 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1915 stash = SvSTASH(*namesvp);
1917 stash = PL_curstash;
1918 padsv = PAD_SV(o->op_targ);
1919 apply_attrs(stash, padsv, attrs);
1921 o->op_flags |= OPf_MOD;
1922 o->op_private |= OPpLVAL_INTRO;
1927 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1929 if (o->op_flags & OPf_PARENS)
1933 o = my_kid(o, attrs);
1935 PL_in_my_stash = Nullhv;
1940 Perl_my(pTHX_ OP *o)
1942 return my_kid(o, Nullop);
1946 Perl_sawparens(pTHX_ OP *o)
1949 o->op_flags |= OPf_PARENS;
1954 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1958 if (ckWARN(WARN_MISC) &&
1959 (left->op_type == OP_RV2AV ||
1960 left->op_type == OP_RV2HV ||
1961 left->op_type == OP_PADAV ||
1962 left->op_type == OP_PADHV)) {
1963 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1964 right->op_type == OP_TRANS)
1965 ? right->op_type : OP_MATCH];
1966 const char *sample = ((left->op_type == OP_RV2AV ||
1967 left->op_type == OP_PADAV)
1968 ? "@array" : "%hash");
1969 Perl_warner(aTHX_ WARN_MISC,
1970 "Applying %s to %s will act on scalar(%s)",
1971 desc, sample, sample);
1974 if (!(right->op_flags & OPf_STACKED) &&
1975 (right->op_type == OP_MATCH ||
1976 right->op_type == OP_SUBST ||
1977 right->op_type == OP_TRANS)) {
1978 right->op_flags |= OPf_STACKED;
1979 if (right->op_type != OP_MATCH &&
1980 ! (right->op_type == OP_TRANS &&
1981 right->op_private & OPpTRANS_IDENTICAL))
1982 left = mod(left, right->op_type);
1983 if (right->op_type == OP_TRANS)
1984 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1986 o = prepend_elem(right->op_type, scalar(left), right);
1988 return newUNOP(OP_NOT, 0, scalar(o));
1992 return bind_match(type, left,
1993 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1997 Perl_invert(pTHX_ OP *o)
2001 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2002 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2006 Perl_scope(pTHX_ OP *o)
2009 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2010 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2011 o->op_type = OP_LEAVE;
2012 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2015 if (o->op_type == OP_LINESEQ) {
2017 o->op_type = OP_SCOPE;
2018 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2019 kid = ((LISTOP*)o)->op_first;
2020 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2024 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2031 Perl_save_hints(pTHX)
2034 SAVESPTR(GvHV(PL_hintgv));
2035 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2036 SAVEFREESV(GvHV(PL_hintgv));
2040 Perl_block_start(pTHX_ int full)
2042 int retval = PL_savestack_ix;
2044 SAVEI32(PL_comppad_name_floor);
2045 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2047 PL_comppad_name_fill = PL_comppad_name_floor;
2048 if (PL_comppad_name_floor < 0)
2049 PL_comppad_name_floor = 0;
2050 SAVEI32(PL_min_intro_pending);
2051 SAVEI32(PL_max_intro_pending);
2052 PL_min_intro_pending = 0;
2053 SAVEI32(PL_comppad_name_fill);
2054 SAVEI32(PL_padix_floor);
2055 PL_padix_floor = PL_padix;
2056 PL_pad_reset_pending = FALSE;
2058 PL_hints &= ~HINT_BLOCK_SCOPE;
2059 SAVESPTR(PL_compiling.cop_warnings);
2060 if (! specialWARN(PL_compiling.cop_warnings)) {
2061 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2062 SAVEFREESV(PL_compiling.cop_warnings) ;
2064 SAVESPTR(PL_compiling.cop_io);
2065 if (! specialCopIO(PL_compiling.cop_io)) {
2066 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2067 SAVEFREESV(PL_compiling.cop_io) ;
2073 Perl_block_end(pTHX_ I32 floor, OP *seq)
2075 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2076 OP* retval = scalarseq(seq);
2078 PL_pad_reset_pending = FALSE;
2079 PL_compiling.op_private = PL_hints;
2081 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2082 pad_leavemy(PL_comppad_name_fill);
2091 OP *o = newOP(OP_THREADSV, 0);
2092 o->op_targ = find_threadsv("_");
2095 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2096 #endif /* USE_THREADS */
2100 Perl_newPROG(pTHX_ OP *o)
2105 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2106 ((PL_in_eval & EVAL_KEEPERR)
2107 ? OPf_SPECIAL : 0), o);
2108 PL_eval_start = linklist(PL_eval_root);
2109 PL_eval_root->op_private |= OPpREFCOUNTED;
2110 OpREFCNT_set(PL_eval_root, 1);
2111 PL_eval_root->op_next = 0;
2112 peep(PL_eval_start);
2117 PL_main_root = scope(sawparens(scalarvoid(o)));
2118 PL_curcop = &PL_compiling;
2119 PL_main_start = LINKLIST(PL_main_root);
2120 PL_main_root->op_private |= OPpREFCOUNTED;
2121 OpREFCNT_set(PL_main_root, 1);
2122 PL_main_root->op_next = 0;
2123 peep(PL_main_start);
2126 /* Register with debugger */
2128 CV *cv = get_cv("DB::postponed", FALSE);
2132 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2134 call_sv((SV*)cv, G_DISCARD);
2141 Perl_localize(pTHX_ OP *o, I32 lex)
2143 if (o->op_flags & OPf_PARENS)
2146 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2148 for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ;
2149 if (*s == ';' || *s == '=')
2150 Perl_warner(aTHX_ WARN_PARENTHESIS,
2151 "Parentheses missing around \"%s\" list",
2152 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2158 o = mod(o, OP_NULL); /* a bit kludgey */
2160 PL_in_my_stash = Nullhv;
2165 Perl_jmaybe(pTHX_ OP *o)
2167 if (o->op_type == OP_LIST) {
2170 o2 = newOP(OP_THREADSV, 0);
2171 o2->op_targ = find_threadsv(";");
2173 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2174 #endif /* USE_THREADS */
2175 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2181 Perl_fold_constants(pTHX_ register OP *o)
2184 I32 type = o->op_type;
2187 if (PL_opargs[type] & OA_RETSCALAR)
2189 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2190 o->op_targ = pad_alloc(type, SVs_PADTMP);
2192 /* integerize op, unless it happens to be C<-foo>.
2193 * XXX should pp_i_negate() do magic string negation instead? */
2194 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2195 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2196 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2198 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2201 if (!(PL_opargs[type] & OA_FOLDCONST))
2206 /* XXX might want a ck_negate() for this */
2207 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2220 if (o->op_private & OPpLOCALE)
2225 goto nope; /* Don't try to run w/ errors */
2227 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2228 if ((curop->op_type != OP_CONST ||
2229 (curop->op_private & OPpCONST_BARE)) &&
2230 curop->op_type != OP_LIST &&
2231 curop->op_type != OP_SCALAR &&
2232 curop->op_type != OP_NULL &&
2233 curop->op_type != OP_PUSHMARK)
2239 curop = LINKLIST(o);
2243 sv = *(PL_stack_sp--);
2244 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2245 pad_swipe(o->op_targ);
2246 else if (SvTEMP(sv)) { /* grab mortal temp? */
2247 (void)SvREFCNT_inc(sv);
2251 if (type == OP_RV2GV)
2252 return newGVOP(OP_GV, 0, (GV*)sv);
2254 /* try to smush double to int, but don't smush -2.0 to -2 */
2255 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2258 #ifdef PERL_PRESERVE_IVUV
2259 /* Only bother to attempt to fold to IV if
2260 most operators will benefit */
2264 return newSVOP(OP_CONST, 0, sv);
2268 if (!(PL_opargs[type] & OA_OTHERINT))
2271 if (!(PL_hints & HINT_INTEGER)) {
2272 if (type == OP_MODULO
2273 || type == OP_DIVIDE
2274 || !(o->op_flags & OPf_KIDS))
2279 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2280 if (curop->op_type == OP_CONST) {
2281 if (SvIOK(((SVOP*)curop)->op_sv))
2285 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2289 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2296 Perl_gen_constant_list(pTHX_ register OP *o)
2299 I32 oldtmps_floor = PL_tmps_floor;
2303 return o; /* Don't attempt to run with errors */
2305 PL_op = curop = LINKLIST(o);
2312 PL_tmps_floor = oldtmps_floor;
2314 o->op_type = OP_RV2AV;
2315 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2316 curop = ((UNOP*)o)->op_first;
2317 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2324 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2329 if (!o || o->op_type != OP_LIST)
2330 o = newLISTOP(OP_LIST, 0, o, Nullop);
2332 o->op_flags &= ~OPf_WANT;
2334 if (!(PL_opargs[type] & OA_MARK))
2335 null(cLISTOPo->op_first);
2338 o->op_ppaddr = PL_ppaddr[type];
2339 o->op_flags |= flags;
2341 o = CHECKOP(type, o);
2342 if (o->op_type != type)
2345 if (cLISTOPo->op_children < 7) {
2346 /* XXX do we really need to do this if we're done appending?? */
2347 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2349 cLISTOPo->op_last = last; /* in case check substituted last arg */
2352 return fold_constants(o);
2355 /* List constructors */
2358 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2366 if (first->op_type != type
2367 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2369 return newLISTOP(type, 0, first, last);
2372 if (first->op_flags & OPf_KIDS)
2373 ((LISTOP*)first)->op_last->op_sibling = last;
2375 first->op_flags |= OPf_KIDS;
2376 ((LISTOP*)first)->op_first = last;
2378 ((LISTOP*)first)->op_last = last;
2379 ((LISTOP*)first)->op_children++;
2384 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2392 if (first->op_type != type)
2393 return prepend_elem(type, (OP*)first, (OP*)last);
2395 if (last->op_type != type)
2396 return append_elem(type, (OP*)first, (OP*)last);
2398 first->op_last->op_sibling = last->op_first;
2399 first->op_last = last->op_last;
2400 first->op_children += last->op_children;
2401 if (first->op_children)
2402 first->op_flags |= OPf_KIDS;
2404 #ifdef PL_OP_SLAB_ALLOC
2412 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2420 if (last->op_type == type) {
2421 if (type == OP_LIST) { /* already a PUSHMARK there */
2422 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2423 ((LISTOP*)last)->op_first->op_sibling = first;
2426 if (!(last->op_flags & OPf_KIDS)) {
2427 ((LISTOP*)last)->op_last = first;
2428 last->op_flags |= OPf_KIDS;
2430 first->op_sibling = ((LISTOP*)last)->op_first;
2431 ((LISTOP*)last)->op_first = first;
2433 ((LISTOP*)last)->op_children++;
2437 return newLISTOP(type, 0, first, last);
2443 Perl_newNULLLIST(pTHX)
2445 return newOP(OP_STUB, 0);
2449 Perl_force_list(pTHX_ OP *o)
2451 if (!o || o->op_type != OP_LIST)
2452 o = newLISTOP(OP_LIST, 0, o, Nullop);
2458 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2462 NewOp(1101, listop, 1, LISTOP);
2464 listop->op_type = type;
2465 listop->op_ppaddr = PL_ppaddr[type];
2466 listop->op_children = (first != 0) + (last != 0);
2467 listop->op_flags = flags;
2471 else if (!first && last)
2474 first->op_sibling = last;
2475 listop->op_first = first;
2476 listop->op_last = last;
2477 if (type == OP_LIST) {
2479 pushop = newOP(OP_PUSHMARK, 0);
2480 pushop->op_sibling = first;
2481 listop->op_first = pushop;
2482 listop->op_flags |= OPf_KIDS;
2484 listop->op_last = pushop;
2486 else if (listop->op_children)
2487 listop->op_flags |= OPf_KIDS;
2493 Perl_newOP(pTHX_ I32 type, I32 flags)
2496 NewOp(1101, o, 1, OP);
2498 o->op_ppaddr = PL_ppaddr[type];
2499 o->op_flags = flags;
2502 o->op_private = 0 + (flags >> 8);
2503 if (PL_opargs[type] & OA_RETSCALAR)
2505 if (PL_opargs[type] & OA_TARGET)
2506 o->op_targ = pad_alloc(type, SVs_PADTMP);
2507 return CHECKOP(type, o);
2511 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2516 first = newOP(OP_STUB, 0);
2517 if (PL_opargs[type] & OA_MARK)
2518 first = force_list(first);
2520 NewOp(1101, unop, 1, UNOP);
2521 unop->op_type = type;
2522 unop->op_ppaddr = PL_ppaddr[type];
2523 unop->op_first = first;
2524 unop->op_flags = flags | OPf_KIDS;
2525 unop->op_private = 1 | (flags >> 8);
2526 unop = (UNOP*) CHECKOP(type, unop);
2530 return fold_constants((OP *) unop);
2534 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2537 NewOp(1101, binop, 1, BINOP);
2540 first = newOP(OP_NULL, 0);
2542 binop->op_type = type;
2543 binop->op_ppaddr = PL_ppaddr[type];
2544 binop->op_first = first;
2545 binop->op_flags = flags | OPf_KIDS;
2548 binop->op_private = 1 | (flags >> 8);
2551 binop->op_private = 2 | (flags >> 8);
2552 first->op_sibling = last;
2555 binop = (BINOP*)CHECKOP(type, binop);
2556 if (binop->op_next || binop->op_type != type)
2559 binop->op_last = binop->op_first->op_sibling;
2561 return fold_constants((OP *)binop);
2565 utf8compare(const void *a, const void *b)
2568 for (i = 0; i < 10; i++) {
2569 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2571 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2578 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2580 SV *tstr = ((SVOP*)expr)->op_sv;
2581 SV *rstr = ((SVOP*)repl)->op_sv;
2584 register U8 *t = (U8*)SvPV(tstr, tlen);
2585 register U8 *r = (U8*)SvPV(rstr, rlen);
2591 register short *tbl;
2593 complement = o->op_private & OPpTRANS_COMPLEMENT;
2594 del = o->op_private & OPpTRANS_DELETE;
2595 squash = o->op_private & OPpTRANS_SQUASH;
2598 o->op_private |= OPpTRANS_FROM_UTF;
2601 o->op_private |= OPpTRANS_TO_UTF;
2603 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2604 SV* listsv = newSVpvn("# comment\n",10);
2606 U8* tend = t + tlen;
2607 U8* rend = r + rlen;
2622 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2623 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2626 U8 tmpbuf[UTF8_MAXLEN+1];
2630 New(1109, cp, tlen, U8*);
2632 transv = newSVpvn("",0);
2641 qsort(cp, i, sizeof(U8*), utf8compare);
2642 for (j = 0; j < i; j++) {
2644 I32 cur = j < i ? cp[j+1] - s : tend - s;
2645 UV val = utf8_to_uv(s, cur, &ulen, 0);
2647 diff = val - nextmin;
2649 t = uv_to_utf8(tmpbuf,nextmin);
2650 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2652 t = uv_to_utf8(tmpbuf, val - 1);
2653 sv_catpvn(transv, "\377", 1);
2654 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2658 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2662 t = uv_to_utf8(tmpbuf,nextmin);
2663 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2664 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2665 sv_catpvn(transv, "\377", 1);
2666 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2667 t = (U8*)SvPVX(transv);
2668 tlen = SvCUR(transv);
2671 else if (!rlen && !del) {
2672 r = t; rlen = tlen; rend = tend;
2676 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2678 o->op_private |= OPpTRANS_IDENTICAL;
2682 while (t < tend || tfirst <= tlast) {
2683 /* see if we need more "t" chars */
2684 if (tfirst > tlast) {
2685 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2687 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2689 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2696 /* now see if we need more "r" chars */
2697 if (rfirst > rlast) {
2699 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2701 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2703 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2712 rfirst = rlast = 0xffffffff;
2716 /* now see which range will peter our first, if either. */
2717 tdiff = tlast - tfirst;
2718 rdiff = rlast - rfirst;
2725 if (rfirst == 0xffffffff) {
2726 diff = tdiff; /* oops, pretend rdiff is infinite */
2728 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2729 (long)tfirst, (long)tlast);
2731 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2735 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2736 (long)tfirst, (long)(tfirst + diff),
2739 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2740 (long)tfirst, (long)rfirst);
2742 if (rfirst + diff > max)
2743 max = rfirst + diff;
2748 else if (rfirst <= 0x800)
2749 grows |= (tfirst < 0x80);
2750 else if (rfirst <= 0x10000)
2751 grows |= (tfirst < 0x800);
2752 else if (rfirst <= 0x200000)
2753 grows |= (tfirst < 0x10000);
2754 else if (rfirst <= 0x4000000)
2755 grows |= (tfirst < 0x200000);
2756 else if (rfirst <= 0x80000000)
2757 grows |= (tfirst < 0x4000000);
2769 else if (max > 0xff)
2774 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2775 SvREFCNT_dec(listsv);
2777 SvREFCNT_dec(transv);
2779 if (!del && havefinal)
2780 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2781 newSVuv((UV)final), 0);
2783 if (grows && to_utf)
2784 o->op_private |= OPpTRANS_GROWS;
2791 tbl = (short*)cPVOPo->op_pv;
2793 Zero(tbl, 256, short);
2794 for (i = 0; i < tlen; i++)
2796 for (i = 0, j = 0; i < 256; i++) {
2812 if (!rlen && !del) {
2815 o->op_private |= OPpTRANS_IDENTICAL;
2817 for (i = 0; i < 256; i++)
2819 for (i = 0, j = 0; i < tlen; i++,j++) {
2822 if (tbl[t[i]] == -1)
2828 if (tbl[t[i]] == -1)
2839 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2843 NewOp(1101, pmop, 1, PMOP);
2844 pmop->op_type = type;
2845 pmop->op_ppaddr = PL_ppaddr[type];
2846 pmop->op_flags = flags;
2847 pmop->op_private = 0 | (flags >> 8);
2849 if (PL_hints & HINT_RE_TAINT)
2850 pmop->op_pmpermflags |= PMf_RETAINT;
2851 if (PL_hints & HINT_LOCALE)
2852 pmop->op_pmpermflags |= PMf_LOCALE;
2853 pmop->op_pmflags = pmop->op_pmpermflags;
2855 /* link into pm list */
2856 if (type != OP_TRANS && PL_curstash) {
2857 pmop->op_pmnext = HvPMROOT(PL_curstash);
2858 HvPMROOT(PL_curstash) = pmop;
2865 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2869 I32 repl_has_vars = 0;
2871 if (o->op_type == OP_TRANS)
2872 return pmtrans(o, expr, repl);
2874 PL_hints |= HINT_BLOCK_SCOPE;
2877 if (expr->op_type == OP_CONST) {
2879 SV *pat = ((SVOP*)expr)->op_sv;
2880 char *p = SvPV(pat, plen);
2881 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2882 sv_setpvn(pat, "\\s+", 3);
2883 p = SvPV(pat, plen);
2884 pm->op_pmflags |= PMf_SKIPWHITE;
2886 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2887 pm->op_pmdynflags |= PMdf_UTF8;
2888 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2889 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2890 pm->op_pmflags |= PMf_WHITE;
2894 if (PL_hints & HINT_UTF8)
2895 pm->op_pmdynflags |= PMdf_UTF8;
2896 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2897 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2899 : OP_REGCMAYBE),0,expr);
2901 NewOp(1101, rcop, 1, LOGOP);
2902 rcop->op_type = OP_REGCOMP;
2903 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2904 rcop->op_first = scalar(expr);
2905 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2906 ? (OPf_SPECIAL | OPf_KIDS)
2908 rcop->op_private = 1;
2911 /* establish postfix order */
2912 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2914 rcop->op_next = expr;
2915 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2918 rcop->op_next = LINKLIST(expr);
2919 expr->op_next = (OP*)rcop;
2922 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2927 if (pm->op_pmflags & PMf_EVAL) {
2929 if (CopLINE(PL_curcop) < PL_multi_end)
2930 CopLINE_set(PL_curcop, PL_multi_end);
2933 else if (repl->op_type == OP_THREADSV
2934 && strchr("&`'123456789+",
2935 PL_threadsv_names[repl->op_targ]))
2939 #endif /* USE_THREADS */
2940 else if (repl->op_type == OP_CONST)
2944 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2945 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2947 if (curop->op_type == OP_THREADSV) {
2949 if (strchr("&`'123456789+", curop->op_private))
2953 if (curop->op_type == OP_GV) {
2954 GV *gv = cGVOPx_gv(curop);
2956 if (strchr("&`'123456789+", *GvENAME(gv)))
2959 #endif /* USE_THREADS */
2960 else if (curop->op_type == OP_RV2CV)
2962 else if (curop->op_type == OP_RV2SV ||
2963 curop->op_type == OP_RV2AV ||
2964 curop->op_type == OP_RV2HV ||
2965 curop->op_type == OP_RV2GV) {
2966 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2969 else if (curop->op_type == OP_PADSV ||
2970 curop->op_type == OP_PADAV ||
2971 curop->op_type == OP_PADHV ||
2972 curop->op_type == OP_PADANY) {
2975 else if (curop->op_type == OP_PUSHRE)
2976 ; /* Okay here, dangerous in newASSIGNOP */
2985 && (!pm->op_pmregexp
2986 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
2987 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2988 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2989 prepend_elem(o->op_type, scalar(repl), o);
2992 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
2993 pm->op_pmflags |= PMf_MAYBE_CONST;
2994 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2996 NewOp(1101, rcop, 1, LOGOP);
2997 rcop->op_type = OP_SUBSTCONT;
2998 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2999 rcop->op_first = scalar(repl);
3000 rcop->op_flags |= OPf_KIDS;
3001 rcop->op_private = 1;
3004 /* establish postfix order */
3005 rcop->op_next = LINKLIST(repl);
3006 repl->op_next = (OP*)rcop;
3008 pm->op_pmreplroot = scalar((OP*)rcop);
3009 pm->op_pmreplstart = LINKLIST(rcop);
3018 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3021 NewOp(1101, svop, 1, SVOP);
3022 svop->op_type = type;
3023 svop->op_ppaddr = PL_ppaddr[type];
3025 svop->op_next = (OP*)svop;
3026 svop->op_flags = flags;
3027 if (PL_opargs[type] & OA_RETSCALAR)
3029 if (PL_opargs[type] & OA_TARGET)
3030 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3031 return CHECKOP(type, svop);
3035 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3038 NewOp(1101, padop, 1, PADOP);
3039 padop->op_type = type;
3040 padop->op_ppaddr = PL_ppaddr[type];
3041 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3042 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3043 PL_curpad[padop->op_padix] = sv;
3045 padop->op_next = (OP*)padop;
3046 padop->op_flags = flags;
3047 if (PL_opargs[type] & OA_RETSCALAR)
3049 if (PL_opargs[type] & OA_TARGET)
3050 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3051 return CHECKOP(type, padop);
3055 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3059 return newPADOP(type, flags, SvREFCNT_inc(gv));
3061 return newSVOP(type, flags, SvREFCNT_inc(gv));
3066 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3069 NewOp(1101, pvop, 1, PVOP);
3070 pvop->op_type = type;
3071 pvop->op_ppaddr = PL_ppaddr[type];
3073 pvop->op_next = (OP*)pvop;
3074 pvop->op_flags = flags;
3075 if (PL_opargs[type] & OA_RETSCALAR)
3077 if (PL_opargs[type] & OA_TARGET)
3078 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3079 return CHECKOP(type, pvop);
3083 Perl_package(pTHX_ OP *o)
3087 save_hptr(&PL_curstash);
3088 save_item(PL_curstname);
3093 name = SvPV(sv, len);
3094 PL_curstash = gv_stashpvn(name,len,TRUE);
3095 sv_setpvn(PL_curstname, name, len);
3099 sv_setpv(PL_curstname,"<none>");
3100 PL_curstash = Nullhv;
3102 PL_hints |= HINT_BLOCK_SCOPE;
3103 PL_copline = NOLINE;
3108 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3116 if (id->op_type != OP_CONST)
3117 Perl_croak(aTHX_ "Module name must be constant");
3121 if (version != Nullop) {
3122 SV *vesv = ((SVOP*)version)->op_sv;
3124 if (arg == Nullop && !SvNIOKp(vesv)) {
3131 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3132 Perl_croak(aTHX_ "Version number must be constant number");
3134 /* Make copy of id so we don't free it twice */
3135 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3137 /* Fake up a method call to VERSION */
3138 meth = newSVpvn("VERSION",7);
3139 sv_upgrade(meth, SVt_PVIV);
3140 (void)SvIOK_on(meth);
3141 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3142 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3143 append_elem(OP_LIST,
3144 prepend_elem(OP_LIST, pack, list(version)),
3145 newSVOP(OP_METHOD_NAMED, 0, meth)));
3149 /* Fake up an import/unimport */
3150 if (arg && arg->op_type == OP_STUB)
3151 imop = arg; /* no import on explicit () */
3152 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3153 imop = Nullop; /* use 5.0; */
3158 /* Make copy of id so we don't free it twice */
3159 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3161 /* Fake up a method call to import/unimport */
3162 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3163 sv_upgrade(meth, SVt_PVIV);
3164 (void)SvIOK_on(meth);
3165 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3166 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3167 append_elem(OP_LIST,
3168 prepend_elem(OP_LIST, pack, list(arg)),
3169 newSVOP(OP_METHOD_NAMED, 0, meth)));
3172 /* Fake up a require, handle override, if any */
3173 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3174 if (!(gv && GvIMPORTED_CV(gv)))
3175 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3177 if (gv && GvIMPORTED_CV(gv)) {
3178 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3179 append_elem(OP_LIST, id,
3180 scalar(newUNOP(OP_RV2CV, 0,
3185 rqop = newUNOP(OP_REQUIRE, 0, id);
3188 /* Fake up the BEGIN {}, which does its thing immediately. */
3190 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3193 append_elem(OP_LINESEQ,
3194 append_elem(OP_LINESEQ,
3195 newSTATEOP(0, Nullch, rqop),
3196 newSTATEOP(0, Nullch, veop)),
3197 newSTATEOP(0, Nullch, imop) ));
3199 PL_hints |= HINT_BLOCK_SCOPE;
3200 PL_copline = NOLINE;
3205 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3208 va_start(args, ver);
3209 vload_module(flags, name, ver, &args);
3213 #ifdef PERL_IMPLICIT_CONTEXT
3215 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3219 va_start(args, ver);
3220 vload_module(flags, name, ver, &args);
3226 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3228 OP *modname, *veop, *imop;
3230 modname = newSVOP(OP_CONST, 0, name);
3231 modname->op_private |= OPpCONST_BARE;
3233 veop = newSVOP(OP_CONST, 0, ver);
3237 if (flags & PERL_LOADMOD_NOIMPORT) {
3238 imop = sawparens(newNULLLIST());
3240 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3241 imop = va_arg(*args, OP*);
3246 sv = va_arg(*args, SV*);
3248 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3249 sv = va_arg(*args, SV*);
3253 line_t ocopline = PL_copline;
3254 int oexpect = PL_expect;
3256 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3257 veop, modname, imop);
3258 PL_expect = oexpect;
3259 PL_copline = ocopline;
3264 Perl_dofile(pTHX_ OP *term)
3269 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3270 if (!(gv && GvIMPORTED_CV(gv)))
3271 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3273 if (gv && GvIMPORTED_CV(gv)) {
3274 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3275 append_elem(OP_LIST, term,
3276 scalar(newUNOP(OP_RV2CV, 0,
3281 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3287 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3289 return newBINOP(OP_LSLICE, flags,
3290 list(force_list(subscript)),
3291 list(force_list(listval)) );
3295 S_list_assignment(pTHX_ register OP *o)
3300 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3301 o = cUNOPo->op_first;
3303 if (o->op_type == OP_COND_EXPR) {
3304 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3305 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3310 yyerror("Assignment to both a list and a scalar");
3314 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3315 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3316 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3319 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3322 if (o->op_type == OP_RV2SV)
3329 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3334 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3335 return newLOGOP(optype, 0,
3336 mod(scalar(left), optype),
3337 newUNOP(OP_SASSIGN, 0, scalar(right)));
3340 return newBINOP(optype, OPf_STACKED,
3341 mod(scalar(left), optype), scalar(right));
3345 if (list_assignment(left)) {
3349 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3350 left = mod(left, OP_AASSIGN);
3358 curop = list(force_list(left));
3359 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3360 o->op_private = 0 | (flags >> 8);
3361 for (curop = ((LISTOP*)curop)->op_first;
3362 curop; curop = curop->op_sibling)
3364 if (curop->op_type == OP_RV2HV &&
3365 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3366 o->op_private |= OPpASSIGN_HASH;
3370 if (!(left->op_private & OPpLVAL_INTRO)) {
3373 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3374 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3375 if (curop->op_type == OP_GV) {
3376 GV *gv = cGVOPx_gv(curop);
3377 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3379 SvCUR(gv) = PL_generation;
3381 else if (curop->op_type == OP_PADSV ||
3382 curop->op_type == OP_PADAV ||
3383 curop->op_type == OP_PADHV ||
3384 curop->op_type == OP_PADANY) {
3385 SV **svp = AvARRAY(PL_comppad_name);
3386 SV *sv = svp[curop->op_targ];
3387 if (SvCUR(sv) == PL_generation)
3389 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3391 else if (curop->op_type == OP_RV2CV)
3393 else if (curop->op_type == OP_RV2SV ||
3394 curop->op_type == OP_RV2AV ||
3395 curop->op_type == OP_RV2HV ||
3396 curop->op_type == OP_RV2GV) {
3397 if (lastop->op_type != OP_GV) /* funny deref? */
3400 else if (curop->op_type == OP_PUSHRE) {
3401 if (((PMOP*)curop)->op_pmreplroot) {
3403 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3405 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3407 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3409 SvCUR(gv) = PL_generation;
3418 o->op_private |= OPpASSIGN_COMMON;
3420 if (right && right->op_type == OP_SPLIT) {
3422 if ((tmpop = ((LISTOP*)right)->op_first) &&
3423 tmpop->op_type == OP_PUSHRE)
3425 PMOP *pm = (PMOP*)tmpop;
3426 if (left->op_type == OP_RV2AV &&
3427 !(left->op_private & OPpLVAL_INTRO) &&
3428 !(o->op_private & OPpASSIGN_COMMON) )
3430 tmpop = ((UNOP*)left)->op_first;
3431 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3433 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3434 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3436 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3437 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3439 pm->op_pmflags |= PMf_ONCE;
3440 tmpop = cUNOPo->op_first; /* to list (nulled) */
3441 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3442 tmpop->op_sibling = Nullop; /* don't free split */
3443 right->op_next = tmpop->op_next; /* fix starting loc */
3444 op_free(o); /* blow off assign */
3445 right->op_flags &= ~OPf_WANT;
3446 /* "I don't know and I don't care." */
3451 if (PL_modcount < 10000 &&
3452 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3454 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3456 sv_setiv(sv, PL_modcount+1);
3464 right = newOP(OP_UNDEF, 0);
3465 if (right->op_type == OP_READLINE) {
3466 right->op_flags |= OPf_STACKED;
3467 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3470 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3471 o = newBINOP(OP_SASSIGN, flags,
3472 scalar(right), mod(scalar(left), OP_SASSIGN) );
3484 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3486 U32 seq = intro_my();
3489 NewOp(1101, cop, 1, COP);
3490 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3491 cop->op_type = OP_DBSTATE;
3492 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3495 cop->op_type = OP_NEXTSTATE;
3496 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3498 cop->op_flags = flags;
3499 cop->op_private = (PL_hints & HINT_BYTE);
3501 cop->op_private |= NATIVE_HINTS;
3503 PL_compiling.op_private = cop->op_private;
3504 cop->op_next = (OP*)cop;
3507 cop->cop_label = label;
3508 PL_hints |= HINT_BLOCK_SCOPE;
3511 cop->cop_arybase = PL_curcop->cop_arybase;
3512 if (specialWARN(PL_curcop->cop_warnings))
3513 cop->cop_warnings = PL_curcop->cop_warnings ;
3515 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3516 if (specialCopIO(PL_curcop->cop_io))
3517 cop->cop_io = PL_curcop->cop_io;
3519 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3522 if (PL_copline == NOLINE)
3523 CopLINE_set(cop, CopLINE(PL_curcop));
3525 CopLINE_set(cop, PL_copline);
3526 PL_copline = NOLINE;
3529 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3531 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3533 CopSTASH_set(cop, PL_curstash);
3535 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3536 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3537 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3538 (void)SvIOK_on(*svp);
3539 SvIVX(*svp) = PTR2IV(cop);
3543 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3546 /* "Introduce" my variables to visible status. */
3554 if (! PL_min_intro_pending)
3555 return PL_cop_seqmax;
3557 svp = AvARRAY(PL_comppad_name);
3558 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3559 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3560 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3561 SvNVX(sv) = (NV)PL_cop_seqmax;
3564 PL_min_intro_pending = 0;
3565 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3566 return PL_cop_seqmax++;
3570 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3572 return new_logop(type, flags, &first, &other);
3576 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3580 OP *first = *firstp;
3581 OP *other = *otherp;
3583 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3584 return newBINOP(type, flags, scalar(first), scalar(other));
3586 scalarboolean(first);
3587 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3588 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3589 if (type == OP_AND || type == OP_OR) {
3595 first = *firstp = cUNOPo->op_first;
3597 first->op_next = o->op_next;
3598 cUNOPo->op_first = Nullop;
3602 if (first->op_type == OP_CONST) {
3603 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3604 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3605 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3616 else if (first->op_type == OP_WANTARRAY) {
3622 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3623 OP *k1 = ((UNOP*)first)->op_first;
3624 OP *k2 = k1->op_sibling;
3626 switch (first->op_type)
3629 if (k2 && k2->op_type == OP_READLINE
3630 && (k2->op_flags & OPf_STACKED)
3631 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3633 warnop = k2->op_type;
3638 if (k1->op_type == OP_READDIR
3639 || k1->op_type == OP_GLOB
3640 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3641 || k1->op_type == OP_EACH)
3643 warnop = ((k1->op_type == OP_NULL)
3644 ? k1->op_targ : k1->op_type);
3649 line_t oldline = CopLINE(PL_curcop);
3650 CopLINE_set(PL_curcop, PL_copline);
3651 Perl_warner(aTHX_ WARN_MISC,
3652 "Value of %s%s can be \"0\"; test with defined()",
3654 ((warnop == OP_READLINE || warnop == OP_GLOB)
3655 ? " construct" : "() operator"));
3656 CopLINE_set(PL_curcop, oldline);
3663 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3664 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3666 NewOp(1101, logop, 1, LOGOP);
3668 logop->op_type = type;
3669 logop->op_ppaddr = PL_ppaddr[type];
3670 logop->op_first = first;
3671 logop->op_flags = flags | OPf_KIDS;
3672 logop->op_other = LINKLIST(other);
3673 logop->op_private = 1 | (flags >> 8);
3675 /* establish postfix order */
3676 logop->op_next = LINKLIST(first);
3677 first->op_next = (OP*)logop;
3678 first->op_sibling = other;
3680 o = newUNOP(OP_NULL, 0, (OP*)logop);
3687 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3694 return newLOGOP(OP_AND, 0, first, trueop);
3696 return newLOGOP(OP_OR, 0, first, falseop);
3698 scalarboolean(first);
3699 if (first->op_type == OP_CONST) {
3700 if (SvTRUE(((SVOP*)first)->op_sv)) {
3711 else if (first->op_type == OP_WANTARRAY) {
3715 NewOp(1101, logop, 1, LOGOP);
3716 logop->op_type = OP_COND_EXPR;
3717 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3718 logop->op_first = first;
3719 logop->op_flags = flags | OPf_KIDS;
3720 logop->op_private = 1 | (flags >> 8);
3721 logop->op_other = LINKLIST(trueop);
3722 logop->op_next = LINKLIST(falseop);
3725 /* establish postfix order */
3726 start = LINKLIST(first);
3727 first->op_next = (OP*)logop;
3729 first->op_sibling = trueop;
3730 trueop->op_sibling = falseop;
3731 o = newUNOP(OP_NULL, 0, (OP*)logop);
3733 trueop->op_next = falseop->op_next = o;
3740 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3748 NewOp(1101, range, 1, LOGOP);
3750 range->op_type = OP_RANGE;
3751 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3752 range->op_first = left;
3753 range->op_flags = OPf_KIDS;
3754 leftstart = LINKLIST(left);
3755 range->op_other = LINKLIST(right);
3756 range->op_private = 1 | (flags >> 8);
3758 left->op_sibling = right;
3760 range->op_next = (OP*)range;
3761 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3762 flop = newUNOP(OP_FLOP, 0, flip);
3763 o = newUNOP(OP_NULL, 0, flop);
3765 range->op_next = leftstart;
3767 left->op_next = flip;
3768 right->op_next = flop;
3770 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3771 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3772 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3773 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3775 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3776 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3779 if (!flip->op_private || !flop->op_private)
3780 linklist(o); /* blow off optimizer unless constant */
3786 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3790 int once = block && block->op_flags & OPf_SPECIAL &&
3791 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3794 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3795 return block; /* do {} while 0 does once */
3796 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3797 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3798 expr = newUNOP(OP_DEFINED, 0,
3799 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3800 } else if (expr->op_flags & OPf_KIDS) {
3801 OP *k1 = ((UNOP*)expr)->op_first;
3802 OP *k2 = (k1) ? k1->op_sibling : NULL;
3803 switch (expr->op_type) {
3805 if (k2 && k2->op_type == OP_READLINE
3806 && (k2->op_flags & OPf_STACKED)
3807 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3808 expr = newUNOP(OP_DEFINED, 0, expr);
3812 if (k1->op_type == OP_READDIR
3813 || k1->op_type == OP_GLOB
3814 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3815 || k1->op_type == OP_EACH)
3816 expr = newUNOP(OP_DEFINED, 0, expr);
3822 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3823 o = new_logop(OP_AND, 0, &expr, &listop);
3826 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3828 if (once && o != listop)
3829 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3832 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3834 o->op_flags |= flags;
3836 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3841 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3850 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3851 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3852 expr = newUNOP(OP_DEFINED, 0,
3853 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3854 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3855 OP *k1 = ((UNOP*)expr)->op_first;
3856 OP *k2 = (k1) ? k1->op_sibling : NULL;
3857 switch (expr->op_type) {
3859 if (k2 && k2->op_type == OP_READLINE
3860 && (k2->op_flags & OPf_STACKED)
3861 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3862 expr = newUNOP(OP_DEFINED, 0, expr);
3866 if (k1->op_type == OP_READDIR
3867 || k1->op_type == OP_GLOB
3868 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3869 || k1->op_type == OP_EACH)
3870 expr = newUNOP(OP_DEFINED, 0, expr);
3876 block = newOP(OP_NULL, 0);
3878 block = scope(block);
3882 next = LINKLIST(cont);
3883 loopflags |= OPpLOOP_CONTINUE;
3886 OP *unstack = newOP(OP_UNSTACK, 0);
3889 cont = append_elem(OP_LINESEQ, cont, unstack);
3890 if ((line_t)whileline != NOLINE) {
3891 PL_copline = whileline;
3892 cont = append_elem(OP_LINESEQ, cont,
3893 newSTATEOP(0, Nullch, Nullop));
3897 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3898 redo = LINKLIST(listop);
3901 PL_copline = whileline;
3903 o = new_logop(OP_AND, 0, &expr, &listop);
3904 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3905 op_free(expr); /* oops, it's a while (0) */
3907 return Nullop; /* listop already freed by new_logop */
3910 ((LISTOP*)listop)->op_last->op_next = condop =
3911 (o == listop ? redo : LINKLIST(o));
3917 NewOp(1101,loop,1,LOOP);
3918 loop->op_type = OP_ENTERLOOP;
3919 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3920 loop->op_private = 0;
3921 loop->op_next = (OP*)loop;
3924 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3926 loop->op_redoop = redo;
3927 loop->op_lastop = o;
3928 o->op_private |= loopflags;
3931 loop->op_nextop = next;
3933 loop->op_nextop = o;
3935 o->op_flags |= flags;
3936 o->op_private |= (flags >> 8);
3941 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3949 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3950 sv->op_type = OP_RV2GV;
3951 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3953 else if (sv->op_type == OP_PADSV) { /* private variable */
3954 padoff = sv->op_targ;
3959 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3960 padoff = sv->op_targ;
3962 iterflags |= OPf_SPECIAL;
3967 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3971 padoff = find_threadsv("_");
3972 iterflags |= OPf_SPECIAL;
3974 sv = newGVOP(OP_GV, 0, PL_defgv);
3977 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3978 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3979 iterflags |= OPf_STACKED;
3981 else if (expr->op_type == OP_NULL &&
3982 (expr->op_flags & OPf_KIDS) &&
3983 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3985 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3986 * set the STACKED flag to indicate that these values are to be
3987 * treated as min/max values by 'pp_iterinit'.
3989 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3990 LOGOP* range = (LOGOP*) flip->op_first;
3991 OP* left = range->op_first;
3992 OP* right = left->op_sibling;
3995 range->op_flags &= ~OPf_KIDS;
3996 range->op_first = Nullop;
3998 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3999 listop->op_first->op_next = range->op_next;
4000 left->op_next = range->op_other;
4001 right->op_next = (OP*)listop;
4002 listop->op_next = listop->op_first;
4005 expr = (OP*)(listop);
4007 iterflags |= OPf_STACKED;
4010 expr = mod(force_list(expr), OP_GREPSTART);
4014 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4015 append_elem(OP_LIST, expr, scalar(sv))));
4016 assert(!loop->op_next);
4017 #ifdef PL_OP_SLAB_ALLOC
4020 NewOp(1234,tmp,1,LOOP);
4021 Copy(loop,tmp,1,LOOP);
4025 Renew(loop, 1, LOOP);
4027 loop->op_targ = padoff;
4028 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4029 PL_copline = forline;
4030 return newSTATEOP(0, label, wop);
4034 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4039 if (type != OP_GOTO || label->op_type == OP_CONST) {
4040 /* "last()" means "last" */
4041 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4042 o = newOP(type, OPf_SPECIAL);
4044 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4045 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4051 if (label->op_type == OP_ENTERSUB)
4052 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4053 o = newUNOP(type, OPf_STACKED, label);
4055 PL_hints |= HINT_BLOCK_SCOPE;
4060 Perl_cv_undef(pTHX_ CV *cv)
4064 MUTEX_DESTROY(CvMUTEXP(cv));
4065 Safefree(CvMUTEXP(cv));
4068 #endif /* USE_THREADS */
4070 if (!CvXSUB(cv) && CvROOT(cv)) {
4072 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4073 Perl_croak(aTHX_ "Can't undef active subroutine");
4076 Perl_croak(aTHX_ "Can't undef active subroutine");
4077 #endif /* USE_THREADS */
4080 SAVEVPTR(PL_curpad);
4084 op_free(CvROOT(cv));
4085 CvROOT(cv) = Nullop;
4088 SvPOK_off((SV*)cv); /* forget prototype */
4090 SvREFCNT_dec(CvGV(cv));
4092 SvREFCNT_dec(CvOUTSIDE(cv));
4093 CvOUTSIDE(cv) = Nullcv;
4095 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4098 if (CvPADLIST(cv)) {
4099 /* may be during global destruction */
4100 if (SvREFCNT(CvPADLIST(cv))) {
4101 I32 i = AvFILLp(CvPADLIST(cv));
4103 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4104 SV* sv = svp ? *svp : Nullsv;
4107 if (sv == (SV*)PL_comppad_name)
4108 PL_comppad_name = Nullav;
4109 else if (sv == (SV*)PL_comppad) {
4110 PL_comppad = Nullav;
4111 PL_curpad = Null(SV**);
4115 SvREFCNT_dec((SV*)CvPADLIST(cv));
4117 CvPADLIST(cv) = Nullav;
4122 S_cv_dump(pTHX_ CV *cv)
4125 CV *outside = CvOUTSIDE(cv);
4126 AV* padlist = CvPADLIST(cv);
4133 PerlIO_printf(Perl_debug_log,
4134 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4136 (CvANON(cv) ? "ANON"
4137 : (cv == PL_main_cv) ? "MAIN"
4138 : CvUNIQUE(cv) ? "UNIQUE"
4139 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4142 : CvANON(outside) ? "ANON"
4143 : (outside == PL_main_cv) ? "MAIN"
4144 : CvUNIQUE(outside) ? "UNIQUE"
4145 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4150 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4151 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4152 pname = AvARRAY(pad_name);
4153 ppad = AvARRAY(pad);
4155 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4156 if (SvPOK(pname[ix]))
4157 PerlIO_printf(Perl_debug_log,
4158 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4159 (int)ix, PTR2UV(ppad[ix]),
4160 SvFAKE(pname[ix]) ? "FAKE " : "",
4162 (IV)I_32(SvNVX(pname[ix])),
4165 #endif /* DEBUGGING */
4169 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4173 AV* protopadlist = CvPADLIST(proto);
4174 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4175 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4176 SV** pname = AvARRAY(protopad_name);
4177 SV** ppad = AvARRAY(protopad);
4178 I32 fname = AvFILLp(protopad_name);
4179 I32 fpad = AvFILLp(protopad);
4183 assert(!CvUNIQUE(proto));
4187 SAVESPTR(PL_comppad_name);
4188 SAVESPTR(PL_compcv);
4190 cv = PL_compcv = (CV*)NEWSV(1104,0);
4191 sv_upgrade((SV *)cv, SvTYPE(proto));
4192 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4196 New(666, CvMUTEXP(cv), 1, perl_mutex);
4197 MUTEX_INIT(CvMUTEXP(cv));
4199 #endif /* USE_THREADS */
4200 CvFILE(cv) = CvFILE(proto);
4201 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4202 CvSTASH(cv) = CvSTASH(proto);
4203 CvROOT(cv) = CvROOT(proto);
4204 CvSTART(cv) = CvSTART(proto);
4206 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4209 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4211 PL_comppad_name = newAV();
4212 for (ix = fname; ix >= 0; ix--)
4213 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4215 PL_comppad = newAV();
4217 comppadlist = newAV();
4218 AvREAL_off(comppadlist);
4219 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4220 av_store(comppadlist, 1, (SV*)PL_comppad);
4221 CvPADLIST(cv) = comppadlist;
4222 av_fill(PL_comppad, AvFILLp(protopad));
4223 PL_curpad = AvARRAY(PL_comppad);
4225 av = newAV(); /* will be @_ */
4227 av_store(PL_comppad, 0, (SV*)av);
4228 AvFLAGS(av) = AVf_REIFY;
4230 for (ix = fpad; ix > 0; ix--) {
4231 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4232 if (namesv && namesv != &PL_sv_undef) {
4233 char *name = SvPVX(namesv); /* XXX */
4234 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4235 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4236 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4238 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4240 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4242 else { /* our own lexical */
4245 /* anon code -- we'll come back for it */
4246 sv = SvREFCNT_inc(ppad[ix]);
4248 else if (*name == '@')
4250 else if (*name == '%')
4259 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4260 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4263 SV* sv = NEWSV(0,0);
4269 /* Now that vars are all in place, clone nested closures. */
4271 for (ix = fpad; ix > 0; ix--) {
4272 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4274 && namesv != &PL_sv_undef
4275 && !(SvFLAGS(namesv) & SVf_FAKE)
4276 && *SvPVX(namesv) == '&'
4277 && CvCLONE(ppad[ix]))
4279 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4280 SvREFCNT_dec(ppad[ix]);
4283 PL_curpad[ix] = (SV*)kid;
4287 #ifdef DEBUG_CLOSURES
4288 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4290 PerlIO_printf(Perl_debug_log, " from:\n");
4292 PerlIO_printf(Perl_debug_log, " to:\n");
4299 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4301 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4303 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4310 Perl_cv_clone(pTHX_ CV *proto)
4313 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4314 cv = cv_clone2(proto, CvOUTSIDE(proto));
4315 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4320 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4322 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4323 SV* msg = sv_newmortal();
4327 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4328 sv_setpv(msg, "Prototype mismatch:");
4330 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4332 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4333 sv_catpv(msg, " vs ");
4335 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4337 sv_catpv(msg, "none");
4338 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4342 static void const_sv_xsub(pTHXo_ CV* cv);
4345 =for apidoc cv_const_sv
4347 If C<cv> is a constant sub eligible for inlining. returns the constant
4348 value returned by the sub. Otherwise, returns NULL.
4350 Constant subs can be created with C<newCONSTSUB> or as described in
4351 L<perlsub/"Constant Functions">.
4356 Perl_cv_const_sv(pTHX_ CV *cv)
4358 if (!cv || !CvCONST(cv))
4360 return (SV*)CvXSUBANY(cv).any_ptr;
4364 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4371 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4372 o = cLISTOPo->op_first->op_sibling;
4374 for (; o; o = o->op_next) {
4375 OPCODE type = o->op_type;
4377 if (sv && o->op_next == o)
4379 if (o->op_next != o) {
4380 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4382 if (type == OP_DBSTATE)
4385 if (type == OP_LEAVESUB || type == OP_RETURN)
4389 if (type == OP_CONST && cSVOPo->op_sv)
4391 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4392 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4393 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4397 /* We get here only from cv_clone2() while creating a closure.
4398 Copy the const value here instead of in cv_clone2 so that
4399 SvREADONLY_on doesn't lead to problems when leaving
4404 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4416 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4426 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4430 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4432 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4436 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4442 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4447 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4448 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4449 SV *sv = sv_newmortal();
4450 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4451 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4456 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4457 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4467 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4468 maximum a prototype before. */
4469 if (SvTYPE(gv) > SVt_NULL) {
4470 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4471 && ckWARN_d(WARN_PROTOTYPE))
4473 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4475 cv_ckproto((CV*)gv, NULL, ps);
4478 sv_setpv((SV*)gv, ps);
4480 sv_setiv((SV*)gv, -1);
4481 SvREFCNT_dec(PL_compcv);
4482 cv = PL_compcv = NULL;
4483 PL_sub_generation++;
4487 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4489 if (!block || !ps || *ps || attrs)
4492 const_sv = op_const_sv(block, Nullcv);
4495 bool exists = CvROOT(cv) || CvXSUB(cv);
4496 /* if the subroutine doesn't exist and wasn't pre-declared
4497 * with a prototype, assume it will be AUTOLOADed,
4498 * skipping the prototype check
4500 if (exists || SvPOK(cv))
4501 cv_ckproto(cv, gv, ps);
4502 /* already defined (or promised)? */
4503 if (exists || GvASSUMECV(gv)) {
4504 if (!block && !attrs) {
4505 /* just a "sub foo;" when &foo is already defined */
4506 SAVEFREESV(PL_compcv);
4509 /* ahem, death to those who redefine active sort subs */
4510 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4511 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4513 if (ckWARN(WARN_REDEFINE)
4515 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4517 line_t oldline = CopLINE(PL_curcop);
4518 CopLINE_set(PL_curcop, PL_copline);
4519 Perl_warner(aTHX_ WARN_REDEFINE,
4520 CvCONST(cv) ? "Constant subroutine %s redefined"
4521 : "Subroutine %s redefined", name);
4522 CopLINE_set(PL_curcop, oldline);
4530 SvREFCNT_inc(const_sv);
4532 assert(!CvROOT(cv) && !CvCONST(cv));
4533 sv_setpv((SV*)cv, ""); /* prototype is "" */
4534 CvXSUBANY(cv).any_ptr = const_sv;
4535 CvXSUB(cv) = const_sv_xsub;
4540 cv = newCONSTSUB(NULL, name, const_sv);
4543 SvREFCNT_dec(PL_compcv);
4545 PL_sub_generation++;
4552 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4553 * before we clobber PL_compcv.
4557 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4558 stash = GvSTASH(CvGV(cv));
4559 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4560 stash = CvSTASH(cv);
4562 stash = PL_curstash;
4565 /* possibly about to re-define existing subr -- ignore old cv */
4566 rcv = (SV*)PL_compcv;
4567 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4568 stash = GvSTASH(gv);
4570 stash = PL_curstash;
4572 apply_attrs(stash, rcv, attrs);
4574 if (cv) { /* must reuse cv if autoloaded */
4576 /* got here with just attrs -- work done, so bug out */
4577 SAVEFREESV(PL_compcv);
4581 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4582 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4583 CvOUTSIDE(PL_compcv) = 0;
4584 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4585 CvPADLIST(PL_compcv) = 0;
4586 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4587 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4588 SvREFCNT_dec(PL_compcv);
4595 PL_sub_generation++;
4598 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4599 CvFILE(cv) = CopFILE(PL_curcop);
4600 CvSTASH(cv) = PL_curstash;
4603 if (!CvMUTEXP(cv)) {
4604 New(666, CvMUTEXP(cv), 1, perl_mutex);
4605 MUTEX_INIT(CvMUTEXP(cv));
4607 #endif /* USE_THREADS */
4610 sv_setpv((SV*)cv, ps);
4612 if (PL_error_count) {
4616 char *s = strrchr(name, ':');
4618 if (strEQ(s, "BEGIN")) {
4620 "BEGIN not safe after errors--compilation aborted";
4621 if (PL_in_eval & EVAL_KEEPERR)
4622 Perl_croak(aTHX_ not_safe);
4624 /* force display of errors found but not reported */
4625 sv_catpv(ERRSV, not_safe);
4626 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4634 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4635 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4638 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
4641 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4643 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4644 OpREFCNT_set(CvROOT(cv), 1);
4645 CvSTART(cv) = LINKLIST(CvROOT(cv));
4646 CvROOT(cv)->op_next = 0;
4649 /* now that optimizer has done its work, adjust pad values */
4651 SV **namep = AvARRAY(PL_comppad_name);
4652 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4655 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4658 * The only things that a clonable function needs in its
4659 * pad are references to outer lexicals and anonymous subs.
4660 * The rest are created anew during cloning.
4662 if (!((namesv = namep[ix]) != Nullsv &&
4663 namesv != &PL_sv_undef &&
4665 *SvPVX(namesv) == '&')))
4667 SvREFCNT_dec(PL_curpad[ix]);
4668 PL_curpad[ix] = Nullsv;
4671 assert(!CvCONST(cv));
4672 if (ps && !*ps && op_const_sv(block, cv))
4676 AV *av = newAV(); /* Will be @_ */
4678 av_store(PL_comppad, 0, (SV*)av);
4679 AvFLAGS(av) = AVf_REIFY;
4681 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4682 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4684 if (!SvPADMY(PL_curpad[ix]))
4685 SvPADTMP_on(PL_curpad[ix]);
4689 if (name || aname) {
4691 char *tname = (name ? name : aname);
4693 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4694 SV *sv = NEWSV(0,0);
4695 SV *tmpstr = sv_newmortal();
4696 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4700 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4702 (long)PL_subline, (long)CopLINE(PL_curcop));
4703 gv_efullname3(tmpstr, gv, Nullch);
4704 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4705 hv = GvHVn(db_postponed);
4706 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4707 && (pcv = GvCV(db_postponed)))
4713 call_sv((SV*)pcv, G_DISCARD);
4717 if ((s = strrchr(tname,':')))
4722 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4725 if (strEQ(s, "BEGIN")) {
4726 I32 oldscope = PL_scopestack_ix;
4728 SAVECOPFILE(&PL_compiling);
4729 SAVECOPLINE(&PL_compiling);
4731 sv_setsv(PL_rs, PL_nrs);
4734 PL_beginav = newAV();
4735 DEBUG_x( dump_sub(gv) );
4736 av_push(PL_beginav, (SV*)cv);
4737 GvCV(gv) = 0; /* cv has been hijacked */
4738 call_list(oldscope, PL_beginav);
4740 PL_curcop = &PL_compiling;
4741 PL_compiling.op_private = PL_hints;
4744 else if (strEQ(s, "END") && !PL_error_count) {
4747 DEBUG_x( dump_sub(gv) );
4748 av_unshift(PL_endav, 1);
4749 av_store(PL_endav, 0, (SV*)cv);
4750 GvCV(gv) = 0; /* cv has been hijacked */
4752 else if (strEQ(s, "CHECK") && !PL_error_count) {
4754 PL_checkav = newAV();
4755 DEBUG_x( dump_sub(gv) );
4756 if (PL_main_start && ckWARN(WARN_VOID))
4757 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4758 av_unshift(PL_checkav, 1);
4759 av_store(PL_checkav, 0, (SV*)cv);
4760 GvCV(gv) = 0; /* cv has been hijacked */
4762 else if (strEQ(s, "INIT") && !PL_error_count) {
4764 PL_initav = newAV();
4765 DEBUG_x( dump_sub(gv) );
4766 if (PL_main_start && ckWARN(WARN_VOID))
4767 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4768 av_push(PL_initav, (SV*)cv);
4769 GvCV(gv) = 0; /* cv has been hijacked */
4774 PL_copline = NOLINE;
4779 /* XXX unsafe for threads if eval_owner isn't held */
4781 =for apidoc newCONSTSUB
4783 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4784 eligible for inlining at compile-time.
4790 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4796 SAVECOPLINE(PL_curcop);
4797 CopLINE_set(PL_curcop, PL_copline);
4800 PL_hints &= ~HINT_BLOCK_SCOPE;
4803 SAVESPTR(PL_curstash);
4804 SAVECOPSTASH(PL_curcop);
4805 PL_curstash = stash;
4807 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4809 CopSTASH(PL_curcop) = stash;
4813 cv = newXS(name, const_sv_xsub, __FILE__);
4814 CvXSUBANY(cv).any_ptr = sv;
4816 sv_setpv((SV*)cv, ""); /* prototype is "" */
4824 =for apidoc U||newXS
4826 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4832 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4834 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4837 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4839 /* just a cached method */
4843 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4844 /* already defined (or promised) */
4845 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4846 && HvNAME(GvSTASH(CvGV(cv)))
4847 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4848 line_t oldline = CopLINE(PL_curcop);
4849 if (PL_copline != NOLINE)
4850 CopLINE_set(PL_curcop, PL_copline);
4851 Perl_warner(aTHX_ WARN_REDEFINE,
4852 CvCONST(cv) ? "Constant subroutine %s redefined"
4853 : "Subroutine %s redefined"
4855 CopLINE_set(PL_curcop, oldline);
4862 if (cv) /* must reuse cv if autoloaded */
4865 cv = (CV*)NEWSV(1105,0);
4866 sv_upgrade((SV *)cv, SVt_PVCV);
4870 PL_sub_generation++;
4873 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4875 New(666, CvMUTEXP(cv), 1, perl_mutex);
4876 MUTEX_INIT(CvMUTEXP(cv));
4878 #endif /* USE_THREADS */
4879 (void)gv_fetchfile(filename);
4880 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4881 an external constant string */
4882 CvXSUB(cv) = subaddr;
4885 char *s = strrchr(name,':');
4891 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4894 if (strEQ(s, "BEGIN")) {
4896 PL_beginav = newAV();
4897 av_push(PL_beginav, (SV*)cv);
4898 GvCV(gv) = 0; /* cv has been hijacked */
4900 else if (strEQ(s, "END")) {
4903 av_unshift(PL_endav, 1);
4904 av_store(PL_endav, 0, (SV*)cv);
4905 GvCV(gv) = 0; /* cv has been hijacked */
4907 else if (strEQ(s, "CHECK")) {
4909 PL_checkav = newAV();
4910 if (PL_main_start && ckWARN(WARN_VOID))
4911 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4912 av_unshift(PL_checkav, 1);
4913 av_store(PL_checkav, 0, (SV*)cv);
4914 GvCV(gv) = 0; /* cv has been hijacked */
4916 else if (strEQ(s, "INIT")) {
4918 PL_initav = newAV();
4919 if (PL_main_start && ckWARN(WARN_VOID))
4920 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4921 av_push(PL_initav, (SV*)cv);
4922 GvCV(gv) = 0; /* cv has been hijacked */
4933 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4942 name = SvPVx(cSVOPo->op_sv, n_a);
4945 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4947 if ((cv = GvFORM(gv))) {
4948 if (ckWARN(WARN_REDEFINE)) {
4949 line_t oldline = CopLINE(PL_curcop);
4951 CopLINE_set(PL_curcop, PL_copline);
4952 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
4953 CopLINE_set(PL_curcop, oldline);
4959 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4960 CvFILE(cv) = CopFILE(PL_curcop);
4962 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4963 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
4964 SvPADTMP_on(PL_curpad[ix]);
4967 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4968 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4969 OpREFCNT_set(CvROOT(cv), 1);
4970 CvSTART(cv) = LINKLIST(CvROOT(cv));
4971 CvROOT(cv)->op_next = 0;
4974 PL_copline = NOLINE;
4979 Perl_newANONLIST(pTHX_ OP *o)
4981 return newUNOP(OP_REFGEN, 0,
4982 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4986 Perl_newANONHASH(pTHX_ OP *o)
4988 return newUNOP(OP_REFGEN, 0,
4989 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4993 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4995 return newANONATTRSUB(floor, proto, Nullop, block);
4999 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5001 return newUNOP(OP_REFGEN, 0,
5002 newSVOP(OP_ANONCODE, 0,
5003 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5007 Perl_oopsAV(pTHX_ OP *o)
5009 switch (o->op_type) {
5011 o->op_type = OP_PADAV;
5012 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5013 return ref(o, OP_RV2AV);
5016 o->op_type = OP_RV2AV;
5017 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5022 if (ckWARN_d(WARN_INTERNAL))
5023 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5030 Perl_oopsHV(pTHX_ OP *o)
5032 switch (o->op_type) {
5035 o->op_type = OP_PADHV;
5036 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5037 return ref(o, OP_RV2HV);
5041 o->op_type = OP_RV2HV;
5042 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5047 if (ckWARN_d(WARN_INTERNAL))
5048 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5055 Perl_newAVREF(pTHX_ OP *o)
5057 if (o->op_type == OP_PADANY) {
5058 o->op_type = OP_PADAV;
5059 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5062 return newUNOP(OP_RV2AV, 0, scalar(o));
5066 Perl_newGVREF(pTHX_ I32 type, OP *o)
5068 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5069 return newUNOP(OP_NULL, 0, o);
5070 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5074 Perl_newHVREF(pTHX_ OP *o)
5076 if (o->op_type == OP_PADANY) {
5077 o->op_type = OP_PADHV;
5078 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5081 return newUNOP(OP_RV2HV, 0, scalar(o));
5085 Perl_oopsCV(pTHX_ OP *o)
5087 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5093 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5095 return newUNOP(OP_RV2CV, flags, scalar(o));
5099 Perl_newSVREF(pTHX_ OP *o)
5101 if (o->op_type == OP_PADANY) {
5102 o->op_type = OP_PADSV;
5103 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5106 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5107 o->op_flags |= OPpDONE_SVREF;
5110 return newUNOP(OP_RV2SV, 0, scalar(o));
5113 /* Check routines. */
5116 Perl_ck_anoncode(pTHX_ OP *o)
5121 name = NEWSV(1106,0);
5122 sv_upgrade(name, SVt_PVNV);
5123 sv_setpvn(name, "&", 1);
5126 ix = pad_alloc(o->op_type, SVs_PADMY);
5127 av_store(PL_comppad_name, ix, name);
5128 av_store(PL_comppad, ix, cSVOPo->op_sv);
5129 SvPADMY_on(cSVOPo->op_sv);
5130 cSVOPo->op_sv = Nullsv;
5131 cSVOPo->op_targ = ix;
5136 Perl_ck_bitop(pTHX_ OP *o)
5138 o->op_private = PL_hints;
5143 Perl_ck_concat(pTHX_ OP *o)
5145 if (cUNOPo->op_first->op_type == OP_CONCAT)
5146 o->op_flags |= OPf_STACKED;
5151 Perl_ck_spair(pTHX_ OP *o)
5153 if (o->op_flags & OPf_KIDS) {
5156 OPCODE type = o->op_type;
5157 o = modkids(ck_fun(o), type);
5158 kid = cUNOPo->op_first;
5159 newop = kUNOP->op_first->op_sibling;
5161 (newop->op_sibling ||
5162 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5163 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5164 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5168 op_free(kUNOP->op_first);
5169 kUNOP->op_first = newop;
5171 o->op_ppaddr = PL_ppaddr[++o->op_type];
5176 Perl_ck_delete(pTHX_ OP *o)
5180 if (o->op_flags & OPf_KIDS) {
5181 OP *kid = cUNOPo->op_first;
5182 switch (kid->op_type) {
5184 o->op_flags |= OPf_SPECIAL;
5187 o->op_private |= OPpSLICE;
5190 o->op_flags |= OPf_SPECIAL;
5195 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5196 PL_op_desc[o->op_type]);
5204 Perl_ck_eof(pTHX_ OP *o)
5206 I32 type = o->op_type;
5208 if (o->op_flags & OPf_KIDS) {
5209 if (cLISTOPo->op_first->op_type == OP_STUB) {
5211 o = newUNOP(type, OPf_SPECIAL,
5212 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5220 Perl_ck_eval(pTHX_ OP *o)
5222 PL_hints |= HINT_BLOCK_SCOPE;
5223 if (o->op_flags & OPf_KIDS) {
5224 SVOP *kid = (SVOP*)cUNOPo->op_first;
5227 o->op_flags &= ~OPf_KIDS;
5230 else if (kid->op_type == OP_LINESEQ) {
5233 kid->op_next = o->op_next;
5234 cUNOPo->op_first = 0;
5237 NewOp(1101, enter, 1, LOGOP);
5238 enter->op_type = OP_ENTERTRY;
5239 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5240 enter->op_private = 0;
5242 /* establish postfix order */
5243 enter->op_next = (OP*)enter;
5245 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5246 o->op_type = OP_LEAVETRY;
5247 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5248 enter->op_other = o;
5256 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5258 o->op_targ = (PADOFFSET)PL_hints;
5263 Perl_ck_exit(pTHX_ OP *o)
5266 HV *table = GvHV(PL_hintgv);
5268 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5269 if (svp && *svp && SvTRUE(*svp))
5270 o->op_private |= OPpEXIT_VMSISH;
5277 Perl_ck_exec(pTHX_ OP *o)
5280 if (o->op_flags & OPf_STACKED) {
5282 kid = cUNOPo->op_first->op_sibling;
5283 if (kid->op_type == OP_RV2GV)
5292 Perl_ck_exists(pTHX_ OP *o)
5295 if (o->op_flags & OPf_KIDS) {
5296 OP *kid = cUNOPo->op_first;
5297 if (kid->op_type == OP_ENTERSUB) {
5298 (void) ref(kid, o->op_type);
5299 if (kid->op_type != OP_RV2CV && !PL_error_count)
5300 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5301 PL_op_desc[o->op_type]);
5302 o->op_private |= OPpEXISTS_SUB;
5304 else if (kid->op_type == OP_AELEM)
5305 o->op_flags |= OPf_SPECIAL;
5306 else if (kid->op_type != OP_HELEM)
5307 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5308 PL_op_desc[o->op_type]);
5316 Perl_ck_gvconst(pTHX_ register OP *o)
5318 o = fold_constants(o);
5319 if (o->op_type == OP_CONST)
5326 Perl_ck_rvconst(pTHX_ register OP *o)
5328 SVOP *kid = (SVOP*)cUNOPo->op_first;
5330 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5331 if (kid->op_type == OP_CONST) {
5335 SV *kidsv = kid->op_sv;
5338 /* Is it a constant from cv_const_sv()? */
5339 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5340 SV *rsv = SvRV(kidsv);
5341 int svtype = SvTYPE(rsv);
5342 char *badtype = Nullch;
5344 switch (o->op_type) {
5346 if (svtype > SVt_PVMG)
5347 badtype = "a SCALAR";
5350 if (svtype != SVt_PVAV)
5351 badtype = "an ARRAY";
5354 if (svtype != SVt_PVHV) {
5355 if (svtype == SVt_PVAV) { /* pseudohash? */
5356 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5357 if (ksv && SvROK(*ksv)
5358 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5367 if (svtype != SVt_PVCV)
5372 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5375 name = SvPV(kidsv, n_a);
5376 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5377 char *badthing = Nullch;
5378 switch (o->op_type) {
5380 badthing = "a SCALAR";
5383 badthing = "an ARRAY";
5386 badthing = "a HASH";
5391 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5395 * This is a little tricky. We only want to add the symbol if we
5396 * didn't add it in the lexer. Otherwise we get duplicate strict
5397 * warnings. But if we didn't add it in the lexer, we must at
5398 * least pretend like we wanted to add it even if it existed before,
5399 * or we get possible typo warnings. OPpCONST_ENTERED says
5400 * whether the lexer already added THIS instance of this symbol.
5402 iscv = (o->op_type == OP_RV2CV) * 2;
5404 gv = gv_fetchpv(name,
5405 iscv | !(kid->op_private & OPpCONST_ENTERED),
5408 : o->op_type == OP_RV2SV
5410 : o->op_type == OP_RV2AV
5412 : o->op_type == OP_RV2HV
5415 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5417 kid->op_type = OP_GV;
5418 SvREFCNT_dec(kid->op_sv);
5420 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5421 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5422 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5424 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5426 kid->op_sv = SvREFCNT_inc(gv);
5428 kid->op_ppaddr = PL_ppaddr[OP_GV];
5435 Perl_ck_ftst(pTHX_ OP *o)
5437 I32 type = o->op_type;
5439 if (o->op_flags & OPf_REF) {
5442 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5443 SVOP *kid = (SVOP*)cUNOPo->op_first;
5445 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5447 OP *newop = newGVOP(type, OPf_REF,
5448 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5455 if (type == OP_FTTTY)
5456 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5459 o = newUNOP(type, 0, newDEFSVOP());
5462 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5464 if (PL_hints & HINT_LOCALE)
5465 o->op_private |= OPpLOCALE;
5472 Perl_ck_fun(pTHX_ OP *o)
5478 int type = o->op_type;
5479 register I32 oa = PL_opargs[type] >> OASHIFT;
5481 if (o->op_flags & OPf_STACKED) {
5482 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5485 return no_fh_allowed(o);
5488 if (o->op_flags & OPf_KIDS) {
5490 tokid = &cLISTOPo->op_first;
5491 kid = cLISTOPo->op_first;
5492 if (kid->op_type == OP_PUSHMARK ||
5493 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5495 tokid = &kid->op_sibling;
5496 kid = kid->op_sibling;
5498 if (!kid && PL_opargs[type] & OA_DEFGV)
5499 *tokid = kid = newDEFSVOP();
5503 sibl = kid->op_sibling;
5506 /* list seen where single (scalar) arg expected? */
5507 if (numargs == 1 && !(oa >> 4)
5508 && kid->op_type == OP_LIST && type != OP_SCALAR)
5510 return too_many_arguments(o,PL_op_desc[type]);
5523 if (kid->op_type == OP_CONST &&
5524 (kid->op_private & OPpCONST_BARE))
5526 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5527 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5528 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5529 if (ckWARN(WARN_DEPRECATED))
5530 Perl_warner(aTHX_ WARN_DEPRECATED,
5531 "Array @%s missing the @ in argument %"IVdf" of %s()",
5532 name, (IV)numargs, PL_op_desc[type]);
5535 kid->op_sibling = sibl;
5538 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5539 bad_type(numargs, "array", PL_op_desc[type], kid);
5543 if (kid->op_type == OP_CONST &&
5544 (kid->op_private & OPpCONST_BARE))
5546 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5547 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5548 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5549 if (ckWARN(WARN_DEPRECATED))
5550 Perl_warner(aTHX_ WARN_DEPRECATED,
5551 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5552 name, (IV)numargs, PL_op_desc[type]);
5555 kid->op_sibling = sibl;
5558 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5559 bad_type(numargs, "hash", PL_op_desc[type], kid);
5564 OP *newop = newUNOP(OP_NULL, 0, kid);
5565 kid->op_sibling = 0;
5567 newop->op_next = newop;
5569 kid->op_sibling = sibl;
5574 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5575 if (kid->op_type == OP_CONST &&
5576 (kid->op_private & OPpCONST_BARE))
5578 OP *newop = newGVOP(OP_GV, 0,
5579 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5584 else if (kid->op_type == OP_READLINE) {
5585 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5586 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5589 I32 flags = OPf_SPECIAL;
5593 /* is this op a FH constructor? */
5594 if (is_handle_constructor(o,numargs)) {
5595 char *name = Nullch;
5599 /* Set a flag to tell rv2gv to vivify
5600 * need to "prove" flag does not mean something
5601 * else already - NI-S 1999/05/07
5604 if (kid->op_type == OP_PADSV) {
5605 SV **namep = av_fetch(PL_comppad_name,
5607 if (namep && *namep)
5608 name = SvPV(*namep, len);
5610 else if (kid->op_type == OP_RV2SV
5611 && kUNOP->op_first->op_type == OP_GV)
5613 GV *gv = cGVOPx_gv(kUNOP->op_first);
5615 len = GvNAMELEN(gv);
5617 else if (kid->op_type == OP_AELEM
5618 || kid->op_type == OP_HELEM)
5620 name = "__ANONIO__";
5626 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5627 namesv = PL_curpad[targ];
5628 (void)SvUPGRADE(namesv, SVt_PV);
5630 sv_setpvn(namesv, "$", 1);
5631 sv_catpvn(namesv, name, len);
5634 kid->op_sibling = 0;
5635 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5636 kid->op_targ = targ;
5637 kid->op_private |= priv;
5639 kid->op_sibling = sibl;
5645 mod(scalar(kid), type);
5649 tokid = &kid->op_sibling;
5650 kid = kid->op_sibling;
5652 o->op_private |= numargs;
5654 return too_many_arguments(o,PL_op_desc[o->op_type]);
5657 else if (PL_opargs[type] & OA_DEFGV) {
5659 return newUNOP(type, 0, newDEFSVOP());
5663 while (oa & OA_OPTIONAL)
5665 if (oa && oa != OA_LIST)
5666 return too_few_arguments(o,PL_op_desc[o->op_type]);
5672 Perl_ck_glob(pTHX_ OP *o)
5677 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5678 append_elem(OP_GLOB, o, newDEFSVOP());
5680 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5681 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5683 #if !defined(PERL_EXTERNAL_GLOB)
5684 /* XXX this can be tightened up and made more failsafe. */
5687 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5688 /* null-terminated import list */
5689 newSVpvn(":globally", 9), Nullsv);
5690 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5693 #endif /* PERL_EXTERNAL_GLOB */
5695 if (gv && GvIMPORTED_CV(gv)) {
5696 append_elem(OP_GLOB, o,
5697 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5698 o->op_type = OP_LIST;
5699 o->op_ppaddr = PL_ppaddr[OP_LIST];
5700 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5701 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5702 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5703 append_elem(OP_LIST, o,
5704 scalar(newUNOP(OP_RV2CV, 0,
5705 newGVOP(OP_GV, 0, gv)))));
5706 o = newUNOP(OP_NULL, 0, ck_subr(o));
5707 o->op_targ = OP_GLOB; /* hint at what it used to be */
5710 gv = newGVgen("main");
5712 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5718 Perl_ck_grep(pTHX_ OP *o)
5722 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5724 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5725 NewOp(1101, gwop, 1, LOGOP);
5727 if (o->op_flags & OPf_STACKED) {
5730 kid = cLISTOPo->op_first->op_sibling;
5731 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5734 kid->op_next = (OP*)gwop;
5735 o->op_flags &= ~OPf_STACKED;
5737 kid = cLISTOPo->op_first->op_sibling;
5738 if (type == OP_MAPWHILE)
5745 kid = cLISTOPo->op_first->op_sibling;
5746 if (kid->op_type != OP_NULL)
5747 Perl_croak(aTHX_ "panic: ck_grep");
5748 kid = kUNOP->op_first;
5750 gwop->op_type = type;
5751 gwop->op_ppaddr = PL_ppaddr[type];
5752 gwop->op_first = listkids(o);
5753 gwop->op_flags |= OPf_KIDS;
5754 gwop->op_private = 1;
5755 gwop->op_other = LINKLIST(kid);
5756 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5757 kid->op_next = (OP*)gwop;
5759 kid = cLISTOPo->op_first->op_sibling;
5760 if (!kid || !kid->op_sibling)
5761 return too_few_arguments(o,PL_op_desc[o->op_type]);
5762 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5763 mod(kid, OP_GREPSTART);
5769 Perl_ck_index(pTHX_ OP *o)
5771 if (o->op_flags & OPf_KIDS) {
5772 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5774 kid = kid->op_sibling; /* get past "big" */
5775 if (kid && kid->op_type == OP_CONST)
5776 fbm_compile(((SVOP*)kid)->op_sv, 0);
5782 Perl_ck_lengthconst(pTHX_ OP *o)
5784 /* XXX length optimization goes here */
5789 Perl_ck_lfun(pTHX_ OP *o)
5791 OPCODE type = o->op_type;
5792 return modkids(ck_fun(o), type);
5796 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5798 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5799 switch (cUNOPo->op_first->op_type) {
5801 /* This is needed for
5802 if (defined %stash::)
5803 to work. Do not break Tk.
5805 break; /* Globals via GV can be undef */
5807 case OP_AASSIGN: /* Is this a good idea? */
5808 Perl_warner(aTHX_ WARN_DEPRECATED,
5809 "defined(@array) is deprecated");
5810 Perl_warner(aTHX_ WARN_DEPRECATED,
5811 "\t(Maybe you should just omit the defined()?)\n");
5814 /* This is needed for
5815 if (defined %stash::)
5816 to work. Do not break Tk.
5818 break; /* Globals via GV can be undef */
5820 Perl_warner(aTHX_ WARN_DEPRECATED,
5821 "defined(%%hash) is deprecated");
5822 Perl_warner(aTHX_ WARN_DEPRECATED,
5823 "\t(Maybe you should just omit the defined()?)\n");
5834 Perl_ck_rfun(pTHX_ OP *o)
5836 OPCODE type = o->op_type;
5837 return refkids(ck_fun(o), type);
5841 Perl_ck_listiob(pTHX_ OP *o)
5845 kid = cLISTOPo->op_first;
5848 kid = cLISTOPo->op_first;
5850 if (kid->op_type == OP_PUSHMARK)
5851 kid = kid->op_sibling;
5852 if (kid && o->op_flags & OPf_STACKED)
5853 kid = kid->op_sibling;
5854 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5855 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5856 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5857 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5858 cLISTOPo->op_first->op_sibling = kid;
5859 cLISTOPo->op_last = kid;
5860 kid = kid->op_sibling;
5865 append_elem(o->op_type, o, newDEFSVOP());
5871 if (PL_hints & HINT_LOCALE)
5872 o->op_private |= OPpLOCALE;
5879 Perl_ck_fun_locale(pTHX_ OP *o)
5885 if (PL_hints & HINT_LOCALE)
5886 o->op_private |= OPpLOCALE;
5893 Perl_ck_sassign(pTHX_ OP *o)
5895 OP *kid = cLISTOPo->op_first;
5896 /* has a disposable target? */
5897 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5898 && !(kid->op_flags & OPf_STACKED)
5899 /* Cannot steal the second time! */
5900 && !(kid->op_private & OPpTARGET_MY))
5902 OP *kkid = kid->op_sibling;
5904 /* Can just relocate the target. */
5905 if (kkid && kkid->op_type == OP_PADSV
5906 && !(kkid->op_private & OPpLVAL_INTRO))
5908 kid->op_targ = kkid->op_targ;
5910 /* Now we do not need PADSV and SASSIGN. */
5911 kid->op_sibling = o->op_sibling; /* NULL */
5912 cLISTOPo->op_first = NULL;
5915 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5923 Perl_ck_scmp(pTHX_ OP *o)
5927 if (PL_hints & HINT_LOCALE)
5928 o->op_private |= OPpLOCALE;
5935 Perl_ck_match(pTHX_ OP *o)
5937 o->op_private |= OPpRUNTIME;
5942 Perl_ck_method(pTHX_ OP *o)
5944 OP *kid = cUNOPo->op_first;
5945 if (kid->op_type == OP_CONST) {
5946 SV* sv = kSVOP->op_sv;
5947 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5949 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5950 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5953 kSVOP->op_sv = Nullsv;
5955 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5964 Perl_ck_null(pTHX_ OP *o)
5970 Perl_ck_open(pTHX_ OP *o)
5972 HV *table = GvHV(PL_hintgv);
5976 svp = hv_fetch(table, "open_IN", 7, FALSE);
5978 mode = mode_from_discipline(*svp);
5979 if (mode & O_BINARY)
5980 o->op_private |= OPpOPEN_IN_RAW;
5981 else if (mode & O_TEXT)
5982 o->op_private |= OPpOPEN_IN_CRLF;
5985 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5987 mode = mode_from_discipline(*svp);
5988 if (mode & O_BINARY)
5989 o->op_private |= OPpOPEN_OUT_RAW;
5990 else if (mode & O_TEXT)
5991 o->op_private |= OPpOPEN_OUT_CRLF;
5994 if (o->op_type == OP_BACKTICK)
6000 Perl_ck_repeat(pTHX_ OP *o)
6002 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6003 o->op_private |= OPpREPEAT_DOLIST;
6004 cBINOPo->op_first = force_list(cBINOPo->op_first);
6012 Perl_ck_require(pTHX_ OP *o)
6014 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6015 SVOP *kid = (SVOP*)cUNOPo->op_first;
6017 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6019 for (s = SvPVX(kid->op_sv); *s; s++) {
6020 if (*s == ':' && s[1] == ':') {
6022 Move(s+2, s+1, strlen(s+2)+1, char);
6023 --SvCUR(kid->op_sv);
6026 if (SvREADONLY(kid->op_sv)) {
6027 SvREADONLY_off(kid->op_sv);
6028 sv_catpvn(kid->op_sv, ".pm", 3);
6029 SvREADONLY_on(kid->op_sv);
6032 sv_catpvn(kid->op_sv, ".pm", 3);
6040 Perl_ck_retarget(pTHX_ OP *o)
6042 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6049 Perl_ck_select(pTHX_ OP *o)
6052 if (o->op_flags & OPf_KIDS) {
6053 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6054 if (kid && kid->op_sibling) {
6055 o->op_type = OP_SSELECT;
6056 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6058 return fold_constants(o);
6062 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6063 if (kid && kid->op_type == OP_RV2GV)
6064 kid->op_private &= ~HINT_STRICT_REFS;
6069 Perl_ck_shift(pTHX_ OP *o)
6071 I32 type = o->op_type;
6073 if (!(o->op_flags & OPf_KIDS)) {
6078 if (!CvUNIQUE(PL_compcv)) {
6079 argop = newOP(OP_PADAV, OPf_REF);
6080 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6083 argop = newUNOP(OP_RV2AV, 0,
6084 scalar(newGVOP(OP_GV, 0,
6085 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6088 argop = newUNOP(OP_RV2AV, 0,
6089 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6090 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6091 #endif /* USE_THREADS */
6092 return newUNOP(type, 0, scalar(argop));
6094 return scalar(modkids(ck_fun(o), type));
6098 Perl_ck_sort(pTHX_ OP *o)
6103 if (PL_hints & HINT_LOCALE)
6104 o->op_private |= OPpLOCALE;
6107 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6109 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6110 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6112 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6114 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6116 if (kid->op_type == OP_SCOPE) {
6120 else if (kid->op_type == OP_LEAVE) {
6121 if (o->op_type == OP_SORT) {
6122 null(kid); /* wipe out leave */
6125 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6126 if (k->op_next == kid)
6128 /* don't descend into loops */
6129 else if (k->op_type == OP_ENTERLOOP
6130 || k->op_type == OP_ENTERITER)
6132 k = cLOOPx(k)->op_lastop;
6137 kid->op_next = 0; /* just disconnect the leave */
6138 k = kLISTOP->op_first;
6143 if (o->op_type == OP_SORT) {
6144 /* provide scalar context for comparison function/block */
6150 o->op_flags |= OPf_SPECIAL;
6152 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6155 firstkid = firstkid->op_sibling;
6158 /* provide list context for arguments */
6159 if (o->op_type == OP_SORT)
6166 S_simplify_sort(pTHX_ OP *o)
6168 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6172 if (!(o->op_flags & OPf_STACKED))
6174 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6175 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6176 kid = kUNOP->op_first; /* get past null */
6177 if (kid->op_type != OP_SCOPE)
6179 kid = kLISTOP->op_last; /* get past scope */
6180 switch(kid->op_type) {
6188 k = kid; /* remember this node*/
6189 if (kBINOP->op_first->op_type != OP_RV2SV)
6191 kid = kBINOP->op_first; /* get past cmp */
6192 if (kUNOP->op_first->op_type != OP_GV)
6194 kid = kUNOP->op_first; /* get past rv2sv */
6196 if (GvSTASH(gv) != PL_curstash)
6198 if (strEQ(GvNAME(gv), "a"))
6200 else if (strEQ(GvNAME(gv), "b"))
6204 kid = k; /* back to cmp */
6205 if (kBINOP->op_last->op_type != OP_RV2SV)
6207 kid = kBINOP->op_last; /* down to 2nd arg */
6208 if (kUNOP->op_first->op_type != OP_GV)
6210 kid = kUNOP->op_first; /* get past rv2sv */
6212 if (GvSTASH(gv) != PL_curstash
6214 ? strNE(GvNAME(gv), "a")
6215 : strNE(GvNAME(gv), "b")))
6217 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6219 o->op_private |= OPpSORT_REVERSE;
6220 if (k->op_type == OP_NCMP)
6221 o->op_private |= OPpSORT_NUMERIC;
6222 if (k->op_type == OP_I_NCMP)
6223 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6224 kid = cLISTOPo->op_first->op_sibling;
6225 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6226 op_free(kid); /* then delete it */
6227 cLISTOPo->op_children--;
6231 Perl_ck_split(pTHX_ OP *o)
6235 if (o->op_flags & OPf_STACKED)
6236 return no_fh_allowed(o);
6238 kid = cLISTOPo->op_first;
6239 if (kid->op_type != OP_NULL)
6240 Perl_croak(aTHX_ "panic: ck_split");
6241 kid = kid->op_sibling;
6242 op_free(cLISTOPo->op_first);
6243 cLISTOPo->op_first = kid;
6245 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6246 cLISTOPo->op_last = kid; /* There was only one element previously */
6249 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6250 OP *sibl = kid->op_sibling;
6251 kid->op_sibling = 0;
6252 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6253 if (cLISTOPo->op_first == cLISTOPo->op_last)
6254 cLISTOPo->op_last = kid;
6255 cLISTOPo->op_first = kid;
6256 kid->op_sibling = sibl;
6259 kid->op_type = OP_PUSHRE;
6260 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6263 if (!kid->op_sibling)
6264 append_elem(OP_SPLIT, o, newDEFSVOP());
6266 kid = kid->op_sibling;
6269 if (!kid->op_sibling)
6270 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6272 kid = kid->op_sibling;
6275 if (kid->op_sibling)
6276 return too_many_arguments(o,PL_op_desc[o->op_type]);
6282 Perl_ck_join(pTHX_ OP *o)
6284 if (ckWARN(WARN_SYNTAX)) {
6285 OP *kid = cLISTOPo->op_first->op_sibling;
6286 if (kid && kid->op_type == OP_MATCH) {
6287 char *pmstr = "STRING";
6288 if (kPMOP->op_pmregexp)
6289 pmstr = kPMOP->op_pmregexp->precomp;
6290 Perl_warner(aTHX_ WARN_SYNTAX,
6291 "/%s/ should probably be written as \"%s\"",
6299 Perl_ck_subr(pTHX_ OP *o)
6301 OP *prev = ((cUNOPo->op_first->op_sibling)
6302 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6303 OP *o2 = prev->op_sibling;
6312 o->op_private |= OPpENTERSUB_HASTARG;
6313 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6314 if (cvop->op_type == OP_RV2CV) {
6316 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6317 null(cvop); /* disable rv2cv */
6318 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6319 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6320 GV *gv = cGVOPx_gv(tmpop);
6323 tmpop->op_private |= OPpEARLY_CV;
6324 else if (SvPOK(cv)) {
6325 namegv = CvANON(cv) ? gv : CvGV(cv);
6326 proto = SvPV((SV*)cv, n_a);
6330 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6331 if (o2->op_type == OP_CONST)
6332 o2->op_private &= ~OPpCONST_STRICT;
6333 else if (o2->op_type == OP_LIST) {
6334 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6335 if (o && o->op_type == OP_CONST)
6336 o->op_private &= ~OPpCONST_STRICT;
6339 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6340 if (PERLDB_SUB && PL_curstash != PL_debstash)
6341 o->op_private |= OPpENTERSUB_DB;
6342 while (o2 != cvop) {
6346 return too_many_arguments(o, gv_ename(namegv));
6364 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6366 arg == 1 ? "block or sub {}" : "sub {}",
6367 gv_ename(namegv), o2);
6370 /* '*' allows any scalar type, including bareword */
6373 if (o2->op_type == OP_RV2GV)
6374 goto wrapref; /* autoconvert GLOB -> GLOBref */
6375 else if (o2->op_type == OP_CONST)
6376 o2->op_private &= ~OPpCONST_STRICT;
6377 else if (o2->op_type == OP_ENTERSUB) {
6378 /* accidental subroutine, revert to bareword */
6379 OP *gvop = ((UNOP*)o2)->op_first;
6380 if (gvop && gvop->op_type == OP_NULL) {
6381 gvop = ((UNOP*)gvop)->op_first;
6383 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6386 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6387 (gvop = ((UNOP*)gvop)->op_first) &&
6388 gvop->op_type == OP_GV)
6390 GV *gv = cGVOPx_gv(gvop);
6391 OP *sibling = o2->op_sibling;
6392 SV *n = newSVpvn("",0);
6394 gv_fullname3(n, gv, "");
6395 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6396 sv_chop(n, SvPVX(n)+6);
6397 o2 = newSVOP(OP_CONST, 0, n);
6398 prev->op_sibling = o2;
6399 o2->op_sibling = sibling;
6411 if (o2->op_type != OP_RV2GV)
6412 bad_type(arg, "symbol", gv_ename(namegv), o2);
6415 if (o2->op_type != OP_ENTERSUB)
6416 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6419 if (o2->op_type != OP_RV2SV
6420 && o2->op_type != OP_PADSV
6421 && o2->op_type != OP_HELEM
6422 && o2->op_type != OP_AELEM
6423 && o2->op_type != OP_THREADSV)
6425 bad_type(arg, "scalar", gv_ename(namegv), o2);
6429 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6430 bad_type(arg, "array", gv_ename(namegv), o2);
6433 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6434 bad_type(arg, "hash", gv_ename(namegv), o2);
6438 OP* sib = kid->op_sibling;
6439 kid->op_sibling = 0;
6440 o2 = newUNOP(OP_REFGEN, 0, kid);
6441 o2->op_sibling = sib;
6442 prev->op_sibling = o2;
6453 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6454 gv_ename(namegv), SvPV((SV*)cv, n_a));
6459 mod(o2, OP_ENTERSUB);
6461 o2 = o2->op_sibling;
6463 if (proto && !optional &&
6464 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6465 return too_few_arguments(o, gv_ename(namegv));
6470 Perl_ck_svconst(pTHX_ OP *o)
6472 SvREADONLY_on(cSVOPo->op_sv);
6477 Perl_ck_trunc(pTHX_ OP *o)
6479 if (o->op_flags & OPf_KIDS) {
6480 SVOP *kid = (SVOP*)cUNOPo->op_first;
6482 if (kid->op_type == OP_NULL)
6483 kid = (SVOP*)kid->op_sibling;
6484 if (kid && kid->op_type == OP_CONST &&
6485 (kid->op_private & OPpCONST_BARE))
6487 o->op_flags |= OPf_SPECIAL;
6488 kid->op_private &= ~OPpCONST_STRICT;
6495 Perl_ck_substr(pTHX_ OP *o)
6498 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6499 OP *kid = cLISTOPo->op_first;
6501 if (kid->op_type == OP_NULL)
6502 kid = kid->op_sibling;
6504 kid->op_flags |= OPf_MOD;
6510 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6513 Perl_peep(pTHX_ register OP *o)
6515 register OP* oldop = 0;
6517 OP *last_composite = Nullop;
6519 if (!o || o->op_seq)
6523 SAVEVPTR(PL_curcop);
6524 for (; o; o = o->op_next) {
6530 switch (o->op_type) {
6534 PL_curcop = ((COP*)o); /* for warnings */
6535 o->op_seq = PL_op_seqmax++;
6536 last_composite = Nullop;
6540 if (cSVOPo->op_private & OPpCONST_STRICT)
6541 no_bareword_allowed(o);
6543 /* Relocate sv to the pad for thread safety.
6544 * Despite being a "constant", the SV is written to,
6545 * for reference counts, sv_upgrade() etc. */
6547 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6548 if (SvPADTMP(cSVOPo->op_sv)) {
6549 /* If op_sv is already a PADTMP then it is being used by
6550 * some pad, so make a copy. */
6551 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6552 SvREADONLY_on(PL_curpad[ix]);
6553 SvREFCNT_dec(cSVOPo->op_sv);
6556 SvREFCNT_dec(PL_curpad[ix]);
6557 SvPADTMP_on(cSVOPo->op_sv);
6558 PL_curpad[ix] = cSVOPo->op_sv;
6559 /* XXX I don't know how this isn't readonly already. */
6560 SvREADONLY_on(PL_curpad[ix]);
6562 cSVOPo->op_sv = Nullsv;
6566 o->op_seq = PL_op_seqmax++;
6570 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6571 if (o->op_next->op_private & OPpTARGET_MY) {
6572 if (o->op_flags & OPf_STACKED) /* chained concats */
6573 goto ignore_optimization;
6575 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6576 o->op_targ = o->op_next->op_targ;
6577 o->op_next->op_targ = 0;
6578 o->op_private |= OPpTARGET_MY;
6583 ignore_optimization:
6584 o->op_seq = PL_op_seqmax++;
6587 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6588 o->op_seq = PL_op_seqmax++;
6589 break; /* Scalar stub must produce undef. List stub is noop */
6593 if (o->op_targ == OP_NEXTSTATE
6594 || o->op_targ == OP_DBSTATE
6595 || o->op_targ == OP_SETSTATE)
6597 PL_curcop = ((COP*)o);
6604 if (oldop && o->op_next) {
6605 oldop->op_next = o->op_next;
6608 o->op_seq = PL_op_seqmax++;
6612 if (o->op_next->op_type == OP_RV2SV) {
6613 if (!(o->op_next->op_private & OPpDEREF)) {
6615 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6617 o->op_next = o->op_next->op_next;
6618 o->op_type = OP_GVSV;
6619 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6622 else if (o->op_next->op_type == OP_RV2AV) {
6623 OP* pop = o->op_next->op_next;
6625 if (pop->op_type == OP_CONST &&
6626 (PL_op = pop->op_next) &&
6627 pop->op_next->op_type == OP_AELEM &&
6628 !(pop->op_next->op_private &
6629 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
6630 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6638 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6639 o->op_next = pop->op_next->op_next;
6640 o->op_type = OP_AELEMFAST;
6641 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6642 o->op_private = (U8)i;
6647 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6649 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6650 /* XXX could check prototype here instead of just carping */
6651 SV *sv = sv_newmortal();
6652 gv_efullname3(sv, gv, Nullch);
6653 Perl_warner(aTHX_ WARN_PROTOTYPE,
6654 "%s() called too early to check prototype",
6659 o->op_seq = PL_op_seqmax++;
6670 o->op_seq = PL_op_seqmax++;
6671 while (cLOGOP->op_other->op_type == OP_NULL)
6672 cLOGOP->op_other = cLOGOP->op_other->op_next;
6673 peep(cLOGOP->op_other);
6677 o->op_seq = PL_op_seqmax++;
6678 peep(cLOOP->op_redoop);
6679 peep(cLOOP->op_nextop);
6680 peep(cLOOP->op_lastop);
6686 o->op_seq = PL_op_seqmax++;
6687 peep(cPMOP->op_pmreplstart);
6691 o->op_seq = PL_op_seqmax++;
6692 if (ckWARN(WARN_SYNTAX) && o->op_next
6693 && o->op_next->op_type == OP_NEXTSTATE) {
6694 if (o->op_next->op_sibling &&
6695 o->op_next->op_sibling->op_type != OP_EXIT &&
6696 o->op_next->op_sibling->op_type != OP_WARN &&
6697 o->op_next->op_sibling->op_type != OP_DIE) {
6698 line_t oldline = CopLINE(PL_curcop);
6700 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6701 Perl_warner(aTHX_ WARN_EXEC,
6702 "Statement unlikely to be reached");
6703 Perl_warner(aTHX_ WARN_EXEC,
6704 "\t(Maybe you meant system() when you said exec()?)\n");
6705 CopLINE_set(PL_curcop, oldline);
6714 SV **svp, **indsvp, *sv;
6719 o->op_seq = PL_op_seqmax++;
6721 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6724 /* Make the CONST have a shared SV */
6725 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6726 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6727 key = SvPV(sv, keylen);
6730 lexname = newSVpvn_share(key, keylen, 0);
6735 if ((o->op_private & (OPpLVAL_INTRO)))
6738 rop = (UNOP*)((BINOP*)o)->op_first;
6739 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6741 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6742 if (!SvOBJECT(lexname))
6744 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6745 if (!fields || !GvHV(*fields))
6747 key = SvPV(*svp, keylen);
6748 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6750 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6751 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6753 ind = SvIV(*indsvp);
6755 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6756 rop->op_type = OP_RV2AV;
6757 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6758 o->op_type = OP_AELEM;
6759 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6761 if (SvREADONLY(*svp))
6763 SvFLAGS(sv) |= (SvFLAGS(*svp)
6764 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6774 SV **svp, **indsvp, *sv;
6778 SVOP *first_key_op, *key_op;
6780 o->op_seq = PL_op_seqmax++;
6781 if ((o->op_private & (OPpLVAL_INTRO))
6782 /* I bet there's always a pushmark... */
6783 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6784 /* hmmm, no optimization if list contains only one key. */
6786 rop = (UNOP*)((LISTOP*)o)->op_last;
6787 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6789 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6790 if (!SvOBJECT(lexname))
6792 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6793 if (!fields || !GvHV(*fields))
6795 /* Again guessing that the pushmark can be jumped over.... */
6796 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6797 ->op_first->op_sibling;
6798 /* Check that the key list contains only constants. */
6799 for (key_op = first_key_op; key_op;
6800 key_op = (SVOP*)key_op->op_sibling)
6801 if (key_op->op_type != OP_CONST)
6805 rop->op_type = OP_RV2AV;
6806 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6807 o->op_type = OP_ASLICE;
6808 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6809 for (key_op = first_key_op; key_op;
6810 key_op = (SVOP*)key_op->op_sibling) {
6811 svp = cSVOPx_svp(key_op);
6812 key = SvPV(*svp, keylen);
6813 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6815 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6816 "in variable %s of type %s",
6817 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6819 ind = SvIV(*indsvp);
6821 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6823 if (SvREADONLY(*svp))
6825 SvFLAGS(sv) |= (SvFLAGS(*svp)
6826 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6835 if (!(o->op_flags & OPf_WANT)
6836 || (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
6840 o->op_seq = PL_op_seqmax++;
6844 if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) {
6845 o->op_seq = PL_op_seqmax++;
6851 if (last_composite) {
6852 OP *r = last_composite;
6854 while (r->op_sibling)
6857 || (r->op_next->op_type == OP_LIST
6858 && r->op_next->op_next == o))
6860 if (last_composite->op_type == OP_RV2AV)
6861 yyerror("Lvalue subs returning arrays not implemented yet");
6863 yyerror("Lvalue subs returning hashes not implemented yet");
6870 o->op_seq = PL_op_seqmax++;
6880 /* Efficient sub that returns a constant scalar value. */
6882 const_sv_xsub(pTHXo_ CV* cv)
6886 ST(0) = (SV*)XSANY.any_ptr;