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_BARE) &&
1340 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1341 SV *sv = ((SVOP*)o)->op_sv;
1344 /* Could be a filehandle */
1345 if (gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO)) {
1346 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1350 /* OK, it's a sub */
1352 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1354 enter = newUNOP(OP_ENTERSUB,0,
1355 newUNOP(OP_RV2CV, 0,
1356 newGVOP(OP_GV, 0, gv)
1358 enter->op_private |= OPpLVAL_INTRO;
1364 if (!(o->op_private & (OPpCONST_ARYBASE)))
1366 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1367 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1371 SAVEI32(PL_compiling.cop_arybase);
1372 PL_compiling.cop_arybase = 0;
1374 else if (type == OP_REFGEN)
1377 Perl_croak(aTHX_ "That use of $[ is unsupported");
1380 if (o->op_flags & OPf_PARENS)
1384 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1385 !(o->op_flags & OPf_STACKED)) {
1386 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1387 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1388 assert(cUNOPo->op_first->op_type == OP_NULL);
1389 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1392 else { /* lvalue subroutine call */
1393 o->op_private |= OPpLVAL_INTRO;
1394 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1395 /* Backward compatibility mode: */
1396 o->op_private |= OPpENTERSUB_INARGS;
1399 else { /* Compile-time error message: */
1400 OP *kid = cUNOPo->op_first;
1404 if (kid->op_type == OP_PUSHMARK)
1406 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1408 "panic: unexpected lvalue entersub "
1409 "args: type/targ %ld:%ld",
1410 (long)kid->op_type,kid->op_targ);
1411 kid = kLISTOP->op_first;
1413 while (kid->op_sibling)
1414 kid = kid->op_sibling;
1415 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1417 if (kid->op_type == OP_METHOD_NAMED
1418 || kid->op_type == OP_METHOD)
1422 if (kid->op_sibling || kid->op_next != kid) {
1423 yyerror("panic: unexpected optree near method call");
1427 NewOp(1101, newop, 1, UNOP);
1428 newop->op_type = OP_RV2CV;
1429 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1430 newop->op_first = Nullop;
1431 newop->op_next = (OP*)newop;
1432 kid->op_sibling = (OP*)newop;
1433 newop->op_private |= OPpLVAL_INTRO;
1437 if (kid->op_type != OP_RV2CV)
1439 "panic: unexpected lvalue entersub "
1440 "entry via type/targ %ld:%ld",
1441 (long)kid->op_type,kid->op_targ);
1442 kid->op_private |= OPpLVAL_INTRO;
1443 break; /* Postpone until runtime */
1447 kid = kUNOP->op_first;
1448 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1449 kid = kUNOP->op_first;
1450 if (kid->op_type == OP_NULL)
1452 "Unexpected constant lvalue entersub "
1453 "entry via type/targ %ld:%ld",
1454 (long)kid->op_type,kid->op_targ);
1455 if (kid->op_type != OP_GV) {
1456 /* Restore RV2CV to check lvalueness */
1458 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1459 okid->op_next = kid->op_next;
1460 kid->op_next = okid;
1463 okid->op_next = Nullop;
1464 okid->op_type = OP_RV2CV;
1466 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1467 okid->op_private |= OPpLVAL_INTRO;
1471 cv = GvCV(kGVOP_gv);
1481 /* grep, foreach, subcalls, refgen */
1482 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1484 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1485 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1487 : (o->op_type == OP_ENTERSUB
1488 ? "non-lvalue subroutine call"
1489 : PL_op_desc[o->op_type])),
1490 type ? PL_op_desc[type] : "local"));
1504 case OP_RIGHT_SHIFT:
1513 if (!(o->op_flags & OPf_STACKED))
1519 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1525 if (!type && cUNOPo->op_first->op_type != OP_GV)
1526 Perl_croak(aTHX_ "Can't localize through a reference");
1527 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1528 PL_modcount = 10000;
1529 return o; /* Treat \(@foo) like ordinary list. */
1533 if (scalar_mod_type(o, type))
1535 ref(cUNOPo->op_first, o->op_type);
1544 PL_modcount = 10000;
1547 if (!type && cUNOPo->op_first->op_type != OP_GV)
1548 Perl_croak(aTHX_ "Can't localize through a reference");
1549 ref(cUNOPo->op_first, o->op_type);
1553 PL_hints |= HINT_BLOCK_SCOPE;
1563 PL_modcount = 10000;
1564 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1565 return o; /* Treat \(@foo) like ordinary list. */
1566 if (scalar_mod_type(o, type))
1572 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1573 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1578 PL_modcount++; /* XXX ??? */
1580 #endif /* USE_THREADS */
1586 if (type != OP_SASSIGN)
1590 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1596 pad_free(o->op_targ);
1597 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1598 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1599 if (o->op_flags & OPf_KIDS)
1600 mod(cBINOPo->op_first->op_sibling, type);
1605 ref(cBINOPo->op_first, o->op_type);
1606 if (type == OP_ENTERSUB &&
1607 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1608 o->op_private |= OPpLVAL_DEFER;
1615 if (o->op_flags & OPf_KIDS)
1616 mod(cLISTOPo->op_last, type);
1620 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1622 else if (!(o->op_flags & OPf_KIDS))
1624 if (o->op_targ != OP_LIST) {
1625 mod(cBINOPo->op_first, type);
1630 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1634 o->op_flags |= OPf_MOD;
1636 if (type == OP_AASSIGN || type == OP_SASSIGN)
1637 o->op_flags |= OPf_SPECIAL|OPf_REF;
1639 o->op_private |= OPpLVAL_INTRO;
1640 o->op_flags &= ~OPf_SPECIAL;
1641 PL_hints |= HINT_BLOCK_SCOPE;
1643 else if (type != OP_GREPSTART && type != OP_ENTERSUB)
1644 o->op_flags |= OPf_REF;
1649 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1653 if (o->op_type == OP_RV2GV)
1677 case OP_RIGHT_SHIFT:
1696 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1698 switch (o->op_type) {
1706 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1719 Perl_refkids(pTHX_ OP *o, I32 type)
1722 if (o && o->op_flags & OPf_KIDS) {
1723 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1730 Perl_ref(pTHX_ OP *o, I32 type)
1734 if (!o || PL_error_count)
1737 switch (o->op_type) {
1739 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1740 !(o->op_flags & OPf_STACKED)) {
1741 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1742 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1743 assert(cUNOPo->op_first->op_type == OP_NULL);
1744 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1745 o->op_flags |= OPf_SPECIAL;
1750 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1754 if (type == OP_DEFINED)
1755 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1756 ref(cUNOPo->op_first, o->op_type);
1759 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1760 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1761 : type == OP_RV2HV ? OPpDEREF_HV
1763 o->op_flags |= OPf_MOD;
1768 o->op_flags |= OPf_MOD; /* XXX ??? */
1773 o->op_flags |= OPf_REF;
1776 if (type == OP_DEFINED)
1777 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1778 ref(cUNOPo->op_first, o->op_type);
1783 o->op_flags |= OPf_REF;
1788 if (!(o->op_flags & OPf_KIDS))
1790 ref(cBINOPo->op_first, type);
1794 ref(cBINOPo->op_first, o->op_type);
1795 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1796 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1797 : type == OP_RV2HV ? OPpDEREF_HV
1799 o->op_flags |= OPf_MOD;
1807 if (!(o->op_flags & OPf_KIDS))
1809 ref(cLISTOPo->op_last, type);
1819 S_dup_attrlist(pTHX_ OP *o)
1823 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1824 * where the first kid is OP_PUSHMARK and the remaining ones
1825 * are OP_CONST. We need to push the OP_CONST values.
1827 if (o->op_type == OP_CONST)
1828 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1830 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1831 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1832 if (o->op_type == OP_CONST)
1833 rop = append_elem(OP_LIST, rop,
1834 newSVOP(OP_CONST, o->op_flags,
1835 SvREFCNT_inc(cSVOPo->op_sv)));
1842 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1846 /* fake up C<use attributes $pkg,$rv,@attrs> */
1847 ENTER; /* need to protect against side-effects of 'use' */
1849 if (stash && HvNAME(stash))
1850 stashsv = newSVpv(HvNAME(stash), 0);
1852 stashsv = &PL_sv_no;
1854 #define ATTRSMODULE "attributes"
1856 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1857 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1859 prepend_elem(OP_LIST,
1860 newSVOP(OP_CONST, 0, stashsv),
1861 prepend_elem(OP_LIST,
1862 newSVOP(OP_CONST, 0,
1864 dup_attrlist(attrs))));
1869 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1870 char *attrstr, STRLEN len)
1875 len = strlen(attrstr);
1879 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1881 char *sstr = attrstr;
1882 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1883 attrs = append_elem(OP_LIST, attrs,
1884 newSVOP(OP_CONST, 0,
1885 newSVpvn(sstr, attrstr-sstr)));
1889 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1890 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1891 Nullsv, prepend_elem(OP_LIST,
1892 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1893 prepend_elem(OP_LIST,
1894 newSVOP(OP_CONST, 0,
1900 S_my_kid(pTHX_ OP *o, OP *attrs)
1905 if (!o || PL_error_count)
1909 if (type == OP_LIST) {
1910 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1912 } else if (type == OP_UNDEF) {
1914 } else if (type == OP_RV2SV || /* "our" declaration */
1916 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1917 o->op_private |= OPpOUR_INTRO;
1919 } else if (type != OP_PADSV &&
1922 type != OP_PUSHMARK)
1924 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1925 PL_op_desc[o->op_type],
1926 PL_in_my == KEY_our ? "our" : "my"));
1929 else if (attrs && type != OP_PUSHMARK) {
1935 PL_in_my_stash = Nullhv;
1937 /* check for C<my Dog $spot> when deciding package */
1938 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1939 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1940 stash = SvSTASH(*namesvp);
1942 stash = PL_curstash;
1943 padsv = PAD_SV(o->op_targ);
1944 apply_attrs(stash, padsv, attrs);
1946 o->op_flags |= OPf_MOD;
1947 o->op_private |= OPpLVAL_INTRO;
1952 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1954 if (o->op_flags & OPf_PARENS)
1958 o = my_kid(o, attrs);
1960 PL_in_my_stash = Nullhv;
1965 Perl_my(pTHX_ OP *o)
1967 return my_kid(o, Nullop);
1971 Perl_sawparens(pTHX_ OP *o)
1974 o->op_flags |= OPf_PARENS;
1979 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1983 if (ckWARN(WARN_MISC) &&
1984 (left->op_type == OP_RV2AV ||
1985 left->op_type == OP_RV2HV ||
1986 left->op_type == OP_PADAV ||
1987 left->op_type == OP_PADHV)) {
1988 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1989 right->op_type == OP_TRANS)
1990 ? right->op_type : OP_MATCH];
1991 const char *sample = ((left->op_type == OP_RV2AV ||
1992 left->op_type == OP_PADAV)
1993 ? "@array" : "%hash");
1994 Perl_warner(aTHX_ WARN_MISC,
1995 "Applying %s to %s will act on scalar(%s)",
1996 desc, sample, sample);
1999 if (!(right->op_flags & OPf_STACKED) &&
2000 (right->op_type == OP_MATCH ||
2001 right->op_type == OP_SUBST ||
2002 right->op_type == OP_TRANS)) {
2003 right->op_flags |= OPf_STACKED;
2004 if (right->op_type != OP_MATCH &&
2005 ! (right->op_type == OP_TRANS &&
2006 right->op_private & OPpTRANS_IDENTICAL))
2007 left = mod(left, right->op_type);
2008 if (right->op_type == OP_TRANS)
2009 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2011 o = prepend_elem(right->op_type, scalar(left), right);
2013 return newUNOP(OP_NOT, 0, scalar(o));
2017 return bind_match(type, left,
2018 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2022 Perl_invert(pTHX_ OP *o)
2026 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2027 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2031 Perl_scope(pTHX_ OP *o)
2034 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2035 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2036 o->op_type = OP_LEAVE;
2037 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2040 if (o->op_type == OP_LINESEQ) {
2042 o->op_type = OP_SCOPE;
2043 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2044 kid = ((LISTOP*)o)->op_first;
2045 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2049 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2056 Perl_save_hints(pTHX)
2059 SAVESPTR(GvHV(PL_hintgv));
2060 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2061 SAVEFREESV(GvHV(PL_hintgv));
2065 Perl_block_start(pTHX_ int full)
2067 int retval = PL_savestack_ix;
2069 SAVEI32(PL_comppad_name_floor);
2070 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2072 PL_comppad_name_fill = PL_comppad_name_floor;
2073 if (PL_comppad_name_floor < 0)
2074 PL_comppad_name_floor = 0;
2075 SAVEI32(PL_min_intro_pending);
2076 SAVEI32(PL_max_intro_pending);
2077 PL_min_intro_pending = 0;
2078 SAVEI32(PL_comppad_name_fill);
2079 SAVEI32(PL_padix_floor);
2080 PL_padix_floor = PL_padix;
2081 PL_pad_reset_pending = FALSE;
2083 PL_hints &= ~HINT_BLOCK_SCOPE;
2084 SAVESPTR(PL_compiling.cop_warnings);
2085 if (! specialWARN(PL_compiling.cop_warnings)) {
2086 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2087 SAVEFREESV(PL_compiling.cop_warnings) ;
2089 SAVESPTR(PL_compiling.cop_io);
2090 if (! specialCopIO(PL_compiling.cop_io)) {
2091 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2092 SAVEFREESV(PL_compiling.cop_io) ;
2098 Perl_block_end(pTHX_ I32 floor, OP *seq)
2100 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2101 OP* retval = scalarseq(seq);
2103 PL_pad_reset_pending = FALSE;
2104 PL_compiling.op_private = PL_hints;
2106 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2107 pad_leavemy(PL_comppad_name_fill);
2116 OP *o = newOP(OP_THREADSV, 0);
2117 o->op_targ = find_threadsv("_");
2120 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2121 #endif /* USE_THREADS */
2125 Perl_newPROG(pTHX_ OP *o)
2130 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2131 ((PL_in_eval & EVAL_KEEPERR)
2132 ? OPf_SPECIAL : 0), o);
2133 PL_eval_start = linklist(PL_eval_root);
2134 PL_eval_root->op_private |= OPpREFCOUNTED;
2135 OpREFCNT_set(PL_eval_root, 1);
2136 PL_eval_root->op_next = 0;
2137 peep(PL_eval_start);
2142 PL_main_root = scope(sawparens(scalarvoid(o)));
2143 PL_curcop = &PL_compiling;
2144 PL_main_start = LINKLIST(PL_main_root);
2145 PL_main_root->op_private |= OPpREFCOUNTED;
2146 OpREFCNT_set(PL_main_root, 1);
2147 PL_main_root->op_next = 0;
2148 peep(PL_main_start);
2151 /* Register with debugger */
2153 CV *cv = get_cv("DB::postponed", FALSE);
2157 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2159 call_sv((SV*)cv, G_DISCARD);
2166 Perl_localize(pTHX_ OP *o, I32 lex)
2168 if (o->op_flags & OPf_PARENS)
2171 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2173 for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ;
2174 if (*s == ';' || *s == '=')
2175 Perl_warner(aTHX_ WARN_PARENTHESIS,
2176 "Parentheses missing around \"%s\" list",
2177 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2183 o = mod(o, OP_NULL); /* a bit kludgey */
2185 PL_in_my_stash = Nullhv;
2190 Perl_jmaybe(pTHX_ OP *o)
2192 if (o->op_type == OP_LIST) {
2195 o2 = newOP(OP_THREADSV, 0);
2196 o2->op_targ = find_threadsv(";");
2198 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2199 #endif /* USE_THREADS */
2200 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2206 Perl_fold_constants(pTHX_ register OP *o)
2209 I32 type = o->op_type;
2212 if (PL_opargs[type] & OA_RETSCALAR)
2214 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2215 o->op_targ = pad_alloc(type, SVs_PADTMP);
2217 /* integerize op, unless it happens to be C<-foo>.
2218 * XXX should pp_i_negate() do magic string negation instead? */
2219 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2220 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2221 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2223 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2226 if (!(PL_opargs[type] & OA_FOLDCONST))
2231 /* XXX might want a ck_negate() for this */
2232 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2245 if (o->op_private & OPpLOCALE)
2250 goto nope; /* Don't try to run w/ errors */
2252 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2253 if ((curop->op_type != OP_CONST ||
2254 (curop->op_private & OPpCONST_BARE)) &&
2255 curop->op_type != OP_LIST &&
2256 curop->op_type != OP_SCALAR &&
2257 curop->op_type != OP_NULL &&
2258 curop->op_type != OP_PUSHMARK)
2264 curop = LINKLIST(o);
2268 sv = *(PL_stack_sp--);
2269 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2270 pad_swipe(o->op_targ);
2271 else if (SvTEMP(sv)) { /* grab mortal temp? */
2272 (void)SvREFCNT_inc(sv);
2276 if (type == OP_RV2GV)
2277 return newGVOP(OP_GV, 0, (GV*)sv);
2279 /* try to smush double to int, but don't smush -2.0 to -2 */
2280 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2283 #ifdef PERL_PRESERVE_IVUV
2284 /* Only bother to attempt to fold to IV if
2285 most operators will benefit */
2289 return newSVOP(OP_CONST, 0, sv);
2293 if (!(PL_opargs[type] & OA_OTHERINT))
2296 if (!(PL_hints & HINT_INTEGER)) {
2297 if (type == OP_MODULO
2298 || type == OP_DIVIDE
2299 || !(o->op_flags & OPf_KIDS))
2304 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2305 if (curop->op_type == OP_CONST) {
2306 if (SvIOK(((SVOP*)curop)->op_sv))
2310 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2314 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2321 Perl_gen_constant_list(pTHX_ register OP *o)
2324 I32 oldtmps_floor = PL_tmps_floor;
2328 return o; /* Don't attempt to run with errors */
2330 PL_op = curop = LINKLIST(o);
2337 PL_tmps_floor = oldtmps_floor;
2339 o->op_type = OP_RV2AV;
2340 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2341 curop = ((UNOP*)o)->op_first;
2342 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2349 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2354 if (!o || o->op_type != OP_LIST)
2355 o = newLISTOP(OP_LIST, 0, o, Nullop);
2357 o->op_flags &= ~OPf_WANT;
2359 if (!(PL_opargs[type] & OA_MARK))
2360 null(cLISTOPo->op_first);
2363 o->op_ppaddr = PL_ppaddr[type];
2364 o->op_flags |= flags;
2366 o = CHECKOP(type, o);
2367 if (o->op_type != type)
2370 if (cLISTOPo->op_children < 7) {
2371 /* XXX do we really need to do this if we're done appending?? */
2372 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2374 cLISTOPo->op_last = last; /* in case check substituted last arg */
2377 return fold_constants(o);
2380 /* List constructors */
2383 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2391 if (first->op_type != type
2392 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2394 return newLISTOP(type, 0, first, last);
2397 if (first->op_flags & OPf_KIDS)
2398 ((LISTOP*)first)->op_last->op_sibling = last;
2400 first->op_flags |= OPf_KIDS;
2401 ((LISTOP*)first)->op_first = last;
2403 ((LISTOP*)first)->op_last = last;
2404 ((LISTOP*)first)->op_children++;
2409 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2417 if (first->op_type != type)
2418 return prepend_elem(type, (OP*)first, (OP*)last);
2420 if (last->op_type != type)
2421 return append_elem(type, (OP*)first, (OP*)last);
2423 first->op_last->op_sibling = last->op_first;
2424 first->op_last = last->op_last;
2425 first->op_children += last->op_children;
2426 if (first->op_children)
2427 first->op_flags |= OPf_KIDS;
2429 #ifdef PL_OP_SLAB_ALLOC
2437 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2445 if (last->op_type == type) {
2446 if (type == OP_LIST) { /* already a PUSHMARK there */
2447 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2448 ((LISTOP*)last)->op_first->op_sibling = first;
2449 if (!(first->op_flags & OPf_PARENS))
2450 last->op_flags &= ~OPf_PARENS;
2453 if (!(last->op_flags & OPf_KIDS)) {
2454 ((LISTOP*)last)->op_last = first;
2455 last->op_flags |= OPf_KIDS;
2457 first->op_sibling = ((LISTOP*)last)->op_first;
2458 ((LISTOP*)last)->op_first = first;
2460 ((LISTOP*)last)->op_children++;
2464 return newLISTOP(type, 0, first, last);
2470 Perl_newNULLLIST(pTHX)
2472 return newOP(OP_STUB, 0);
2476 Perl_force_list(pTHX_ OP *o)
2478 if (!o || o->op_type != OP_LIST)
2479 o = newLISTOP(OP_LIST, 0, o, Nullop);
2485 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2489 NewOp(1101, listop, 1, LISTOP);
2491 listop->op_type = type;
2492 listop->op_ppaddr = PL_ppaddr[type];
2493 listop->op_children = (first != 0) + (last != 0);
2494 listop->op_flags = flags;
2498 else if (!first && last)
2501 first->op_sibling = last;
2502 listop->op_first = first;
2503 listop->op_last = last;
2504 if (type == OP_LIST) {
2506 pushop = newOP(OP_PUSHMARK, 0);
2507 pushop->op_sibling = first;
2508 listop->op_first = pushop;
2509 listop->op_flags |= OPf_KIDS;
2511 listop->op_last = pushop;
2513 else if (listop->op_children)
2514 listop->op_flags |= OPf_KIDS;
2520 Perl_newOP(pTHX_ I32 type, I32 flags)
2523 NewOp(1101, o, 1, OP);
2525 o->op_ppaddr = PL_ppaddr[type];
2526 o->op_flags = flags;
2529 o->op_private = 0 + (flags >> 8);
2530 if (PL_opargs[type] & OA_RETSCALAR)
2532 if (PL_opargs[type] & OA_TARGET)
2533 o->op_targ = pad_alloc(type, SVs_PADTMP);
2534 return CHECKOP(type, o);
2538 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2543 first = newOP(OP_STUB, 0);
2544 if (PL_opargs[type] & OA_MARK)
2545 first = force_list(first);
2547 NewOp(1101, unop, 1, UNOP);
2548 unop->op_type = type;
2549 unop->op_ppaddr = PL_ppaddr[type];
2550 unop->op_first = first;
2551 unop->op_flags = flags | OPf_KIDS;
2552 unop->op_private = 1 | (flags >> 8);
2553 unop = (UNOP*) CHECKOP(type, unop);
2557 return fold_constants((OP *) unop);
2561 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2564 NewOp(1101, binop, 1, BINOP);
2567 first = newOP(OP_NULL, 0);
2569 binop->op_type = type;
2570 binop->op_ppaddr = PL_ppaddr[type];
2571 binop->op_first = first;
2572 binop->op_flags = flags | OPf_KIDS;
2575 binop->op_private = 1 | (flags >> 8);
2578 binop->op_private = 2 | (flags >> 8);
2579 first->op_sibling = last;
2582 binop = (BINOP*)CHECKOP(type, binop);
2583 if (binop->op_next || binop->op_type != type)
2586 binop->op_last = binop->op_first->op_sibling;
2588 return fold_constants((OP *)binop);
2592 utf8compare(const void *a, const void *b)
2595 for (i = 0; i < 10; i++) {
2596 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2598 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2605 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2607 SV *tstr = ((SVOP*)expr)->op_sv;
2608 SV *rstr = ((SVOP*)repl)->op_sv;
2611 register U8 *t = (U8*)SvPV(tstr, tlen);
2612 register U8 *r = (U8*)SvPV(rstr, rlen);
2618 register short *tbl;
2620 complement = o->op_private & OPpTRANS_COMPLEMENT;
2621 del = o->op_private & OPpTRANS_DELETE;
2622 squash = o->op_private & OPpTRANS_SQUASH;
2625 o->op_private |= OPpTRANS_FROM_UTF;
2628 o->op_private |= OPpTRANS_TO_UTF;
2630 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2631 SV* listsv = newSVpvn("# comment\n",10);
2633 U8* tend = t + tlen;
2634 U8* rend = r + rlen;
2649 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2650 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2653 U8 tmpbuf[UTF8_MAXLEN+1];
2657 New(1109, cp, tlen, U8*);
2659 transv = newSVpvn("",0);
2668 qsort(cp, i, sizeof(U8*), utf8compare);
2669 for (j = 0; j < i; j++) {
2671 I32 cur = j < i ? cp[j+1] - s : tend - s;
2672 UV val = utf8_to_uv(s, cur, &ulen, 0);
2674 diff = val - nextmin;
2676 t = uv_to_utf8(tmpbuf,nextmin);
2677 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2679 t = uv_to_utf8(tmpbuf, val - 1);
2680 sv_catpvn(transv, "\377", 1);
2681 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2685 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2689 t = uv_to_utf8(tmpbuf,nextmin);
2690 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2691 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2692 sv_catpvn(transv, "\377", 1);
2693 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2694 t = (U8*)SvPVX(transv);
2695 tlen = SvCUR(transv);
2698 else if (!rlen && !del) {
2699 r = t; rlen = tlen; rend = tend;
2703 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2705 o->op_private |= OPpTRANS_IDENTICAL;
2709 while (t < tend || tfirst <= tlast) {
2710 /* see if we need more "t" chars */
2711 if (tfirst > tlast) {
2712 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2714 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2716 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2723 /* now see if we need more "r" chars */
2724 if (rfirst > rlast) {
2726 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2728 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2730 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2739 rfirst = rlast = 0xffffffff;
2743 /* now see which range will peter our first, if either. */
2744 tdiff = tlast - tfirst;
2745 rdiff = rlast - rfirst;
2752 if (rfirst == 0xffffffff) {
2753 diff = tdiff; /* oops, pretend rdiff is infinite */
2755 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2756 (long)tfirst, (long)tlast);
2758 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2762 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2763 (long)tfirst, (long)(tfirst + diff),
2766 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2767 (long)tfirst, (long)rfirst);
2769 if (rfirst + diff > max)
2770 max = rfirst + diff;
2775 else if (rfirst <= 0x800)
2776 grows |= (tfirst < 0x80);
2777 else if (rfirst <= 0x10000)
2778 grows |= (tfirst < 0x800);
2779 else if (rfirst <= 0x200000)
2780 grows |= (tfirst < 0x10000);
2781 else if (rfirst <= 0x4000000)
2782 grows |= (tfirst < 0x200000);
2783 else if (rfirst <= 0x80000000)
2784 grows |= (tfirst < 0x4000000);
2796 else if (max > 0xff)
2801 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2802 SvREFCNT_dec(listsv);
2804 SvREFCNT_dec(transv);
2806 if (!del && havefinal)
2807 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2808 newSVuv((UV)final), 0);
2810 if (grows && to_utf)
2811 o->op_private |= OPpTRANS_GROWS;
2818 tbl = (short*)cPVOPo->op_pv;
2820 Zero(tbl, 256, short);
2821 for (i = 0; i < tlen; i++)
2823 for (i = 0, j = 0; i < 256; i++) {
2839 if (!rlen && !del) {
2842 o->op_private |= OPpTRANS_IDENTICAL;
2844 for (i = 0; i < 256; i++)
2846 for (i = 0, j = 0; i < tlen; i++,j++) {
2849 if (tbl[t[i]] == -1)
2855 if (tbl[t[i]] == -1)
2866 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2870 NewOp(1101, pmop, 1, PMOP);
2871 pmop->op_type = type;
2872 pmop->op_ppaddr = PL_ppaddr[type];
2873 pmop->op_flags = flags;
2874 pmop->op_private = 0 | (flags >> 8);
2876 if (PL_hints & HINT_RE_TAINT)
2877 pmop->op_pmpermflags |= PMf_RETAINT;
2878 if (PL_hints & HINT_LOCALE)
2879 pmop->op_pmpermflags |= PMf_LOCALE;
2880 pmop->op_pmflags = pmop->op_pmpermflags;
2882 /* link into pm list */
2883 if (type != OP_TRANS && PL_curstash) {
2884 pmop->op_pmnext = HvPMROOT(PL_curstash);
2885 HvPMROOT(PL_curstash) = pmop;
2892 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2896 I32 repl_has_vars = 0;
2898 if (o->op_type == OP_TRANS)
2899 return pmtrans(o, expr, repl);
2901 PL_hints |= HINT_BLOCK_SCOPE;
2904 if (expr->op_type == OP_CONST) {
2906 SV *pat = ((SVOP*)expr)->op_sv;
2907 char *p = SvPV(pat, plen);
2908 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2909 sv_setpvn(pat, "\\s+", 3);
2910 p = SvPV(pat, plen);
2911 pm->op_pmflags |= PMf_SKIPWHITE;
2913 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2914 pm->op_pmdynflags |= PMdf_UTF8;
2915 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2916 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2917 pm->op_pmflags |= PMf_WHITE;
2921 if (PL_hints & HINT_UTF8)
2922 pm->op_pmdynflags |= PMdf_UTF8;
2923 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2924 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2926 : OP_REGCMAYBE),0,expr);
2928 NewOp(1101, rcop, 1, LOGOP);
2929 rcop->op_type = OP_REGCOMP;
2930 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2931 rcop->op_first = scalar(expr);
2932 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2933 ? (OPf_SPECIAL | OPf_KIDS)
2935 rcop->op_private = 1;
2938 /* establish postfix order */
2939 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2941 rcop->op_next = expr;
2942 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2945 rcop->op_next = LINKLIST(expr);
2946 expr->op_next = (OP*)rcop;
2949 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2954 if (pm->op_pmflags & PMf_EVAL) {
2956 if (CopLINE(PL_curcop) < PL_multi_end)
2957 CopLINE_set(PL_curcop, PL_multi_end);
2960 else if (repl->op_type == OP_THREADSV
2961 && strchr("&`'123456789+",
2962 PL_threadsv_names[repl->op_targ]))
2966 #endif /* USE_THREADS */
2967 else if (repl->op_type == OP_CONST)
2971 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2972 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2974 if (curop->op_type == OP_THREADSV) {
2976 if (strchr("&`'123456789+", curop->op_private))
2980 if (curop->op_type == OP_GV) {
2981 GV *gv = cGVOPx_gv(curop);
2983 if (strchr("&`'123456789+", *GvENAME(gv)))
2986 #endif /* USE_THREADS */
2987 else if (curop->op_type == OP_RV2CV)
2989 else if (curop->op_type == OP_RV2SV ||
2990 curop->op_type == OP_RV2AV ||
2991 curop->op_type == OP_RV2HV ||
2992 curop->op_type == OP_RV2GV) {
2993 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2996 else if (curop->op_type == OP_PADSV ||
2997 curop->op_type == OP_PADAV ||
2998 curop->op_type == OP_PADHV ||
2999 curop->op_type == OP_PADANY) {
3002 else if (curop->op_type == OP_PUSHRE)
3003 ; /* Okay here, dangerous in newASSIGNOP */
3012 && (!pm->op_pmregexp
3013 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3014 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3015 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3016 prepend_elem(o->op_type, scalar(repl), o);
3019 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3020 pm->op_pmflags |= PMf_MAYBE_CONST;
3021 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3023 NewOp(1101, rcop, 1, LOGOP);
3024 rcop->op_type = OP_SUBSTCONT;
3025 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3026 rcop->op_first = scalar(repl);
3027 rcop->op_flags |= OPf_KIDS;
3028 rcop->op_private = 1;
3031 /* establish postfix order */
3032 rcop->op_next = LINKLIST(repl);
3033 repl->op_next = (OP*)rcop;
3035 pm->op_pmreplroot = scalar((OP*)rcop);
3036 pm->op_pmreplstart = LINKLIST(rcop);
3045 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3048 NewOp(1101, svop, 1, SVOP);
3049 svop->op_type = type;
3050 svop->op_ppaddr = PL_ppaddr[type];
3052 svop->op_next = (OP*)svop;
3053 svop->op_flags = flags;
3054 if (PL_opargs[type] & OA_RETSCALAR)
3056 if (PL_opargs[type] & OA_TARGET)
3057 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3058 return CHECKOP(type, svop);
3062 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3065 NewOp(1101, padop, 1, PADOP);
3066 padop->op_type = type;
3067 padop->op_ppaddr = PL_ppaddr[type];
3068 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3069 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3070 PL_curpad[padop->op_padix] = sv;
3072 padop->op_next = (OP*)padop;
3073 padop->op_flags = flags;
3074 if (PL_opargs[type] & OA_RETSCALAR)
3076 if (PL_opargs[type] & OA_TARGET)
3077 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3078 return CHECKOP(type, padop);
3082 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3086 return newPADOP(type, flags, SvREFCNT_inc(gv));
3088 return newSVOP(type, flags, SvREFCNT_inc(gv));
3093 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3096 NewOp(1101, pvop, 1, PVOP);
3097 pvop->op_type = type;
3098 pvop->op_ppaddr = PL_ppaddr[type];
3100 pvop->op_next = (OP*)pvop;
3101 pvop->op_flags = flags;
3102 if (PL_opargs[type] & OA_RETSCALAR)
3104 if (PL_opargs[type] & OA_TARGET)
3105 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3106 return CHECKOP(type, pvop);
3110 Perl_package(pTHX_ OP *o)
3114 save_hptr(&PL_curstash);
3115 save_item(PL_curstname);
3120 name = SvPV(sv, len);
3121 PL_curstash = gv_stashpvn(name,len,TRUE);
3122 sv_setpvn(PL_curstname, name, len);
3126 sv_setpv(PL_curstname,"<none>");
3127 PL_curstash = Nullhv;
3129 PL_hints |= HINT_BLOCK_SCOPE;
3130 PL_copline = NOLINE;
3135 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3143 if (id->op_type != OP_CONST)
3144 Perl_croak(aTHX_ "Module name must be constant");
3148 if (version != Nullop) {
3149 SV *vesv = ((SVOP*)version)->op_sv;
3151 if (arg == Nullop && !SvNIOKp(vesv)) {
3158 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3159 Perl_croak(aTHX_ "Version number must be constant number");
3161 /* Make copy of id so we don't free it twice */
3162 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3164 /* Fake up a method call to VERSION */
3165 meth = newSVpvn("VERSION",7);
3166 sv_upgrade(meth, SVt_PVIV);
3167 (void)SvIOK_on(meth);
3168 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3169 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3170 append_elem(OP_LIST,
3171 prepend_elem(OP_LIST, pack, list(version)),
3172 newSVOP(OP_METHOD_NAMED, 0, meth)));
3176 /* Fake up an import/unimport */
3177 if (arg && arg->op_type == OP_STUB)
3178 imop = arg; /* no import on explicit () */
3179 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3180 imop = Nullop; /* use 5.0; */
3185 /* Make copy of id so we don't free it twice */
3186 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3188 /* Fake up a method call to import/unimport */
3189 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3190 sv_upgrade(meth, SVt_PVIV);
3191 (void)SvIOK_on(meth);
3192 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3193 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3194 append_elem(OP_LIST,
3195 prepend_elem(OP_LIST, pack, list(arg)),
3196 newSVOP(OP_METHOD_NAMED, 0, meth)));
3199 /* Fake up a require, handle override, if any */
3200 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3201 if (!(gv && GvIMPORTED_CV(gv)))
3202 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3204 if (gv && GvIMPORTED_CV(gv)) {
3205 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3206 append_elem(OP_LIST, id,
3207 scalar(newUNOP(OP_RV2CV, 0,
3212 rqop = newUNOP(OP_REQUIRE, 0, id);
3215 /* Fake up the BEGIN {}, which does its thing immediately. */
3217 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3220 append_elem(OP_LINESEQ,
3221 append_elem(OP_LINESEQ,
3222 newSTATEOP(0, Nullch, rqop),
3223 newSTATEOP(0, Nullch, veop)),
3224 newSTATEOP(0, Nullch, imop) ));
3226 PL_hints |= HINT_BLOCK_SCOPE;
3227 PL_copline = NOLINE;
3232 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3235 va_start(args, ver);
3236 vload_module(flags, name, ver, &args);
3240 #ifdef PERL_IMPLICIT_CONTEXT
3242 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3246 va_start(args, ver);
3247 vload_module(flags, name, ver, &args);
3253 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3255 OP *modname, *veop, *imop;
3257 modname = newSVOP(OP_CONST, 0, name);
3258 modname->op_private |= OPpCONST_BARE;
3260 veop = newSVOP(OP_CONST, 0, ver);
3264 if (flags & PERL_LOADMOD_NOIMPORT) {
3265 imop = sawparens(newNULLLIST());
3267 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3268 imop = va_arg(*args, OP*);
3273 sv = va_arg(*args, SV*);
3275 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3276 sv = va_arg(*args, SV*);
3280 line_t ocopline = PL_copline;
3281 int oexpect = PL_expect;
3283 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3284 veop, modname, imop);
3285 PL_expect = oexpect;
3286 PL_copline = ocopline;
3291 Perl_dofile(pTHX_ OP *term)
3296 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3297 if (!(gv && GvIMPORTED_CV(gv)))
3298 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3300 if (gv && GvIMPORTED_CV(gv)) {
3301 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3302 append_elem(OP_LIST, term,
3303 scalar(newUNOP(OP_RV2CV, 0,
3308 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3314 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3316 return newBINOP(OP_LSLICE, flags,
3317 list(force_list(subscript)),
3318 list(force_list(listval)) );
3322 S_list_assignment(pTHX_ register OP *o)
3327 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3328 o = cUNOPo->op_first;
3330 if (o->op_type == OP_COND_EXPR) {
3331 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3332 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3337 yyerror("Assignment to both a list and a scalar");
3341 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3342 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3343 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3346 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3349 if (o->op_type == OP_RV2SV)
3356 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3361 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3362 return newLOGOP(optype, 0,
3363 mod(scalar(left), optype),
3364 newUNOP(OP_SASSIGN, 0, scalar(right)));
3367 return newBINOP(optype, OPf_STACKED,
3368 mod(scalar(left), optype), scalar(right));
3372 if (list_assignment(left)) {
3376 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3377 left = mod(left, OP_AASSIGN);
3385 curop = list(force_list(left));
3386 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3387 o->op_private = 0 | (flags >> 8);
3388 for (curop = ((LISTOP*)curop)->op_first;
3389 curop; curop = curop->op_sibling)
3391 if (curop->op_type == OP_RV2HV &&
3392 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3393 o->op_private |= OPpASSIGN_HASH;
3397 if (!(left->op_private & OPpLVAL_INTRO)) {
3400 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3401 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3402 if (curop->op_type == OP_GV) {
3403 GV *gv = cGVOPx_gv(curop);
3404 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3406 SvCUR(gv) = PL_generation;
3408 else if (curop->op_type == OP_PADSV ||
3409 curop->op_type == OP_PADAV ||
3410 curop->op_type == OP_PADHV ||
3411 curop->op_type == OP_PADANY) {
3412 SV **svp = AvARRAY(PL_comppad_name);
3413 SV *sv = svp[curop->op_targ];
3414 if (SvCUR(sv) == PL_generation)
3416 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3418 else if (curop->op_type == OP_RV2CV)
3420 else if (curop->op_type == OP_RV2SV ||
3421 curop->op_type == OP_RV2AV ||
3422 curop->op_type == OP_RV2HV ||
3423 curop->op_type == OP_RV2GV) {
3424 if (lastop->op_type != OP_GV) /* funny deref? */
3427 else if (curop->op_type == OP_PUSHRE) {
3428 if (((PMOP*)curop)->op_pmreplroot) {
3430 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3432 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3434 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3436 SvCUR(gv) = PL_generation;
3445 o->op_private |= OPpASSIGN_COMMON;
3447 if (right && right->op_type == OP_SPLIT) {
3449 if ((tmpop = ((LISTOP*)right)->op_first) &&
3450 tmpop->op_type == OP_PUSHRE)
3452 PMOP *pm = (PMOP*)tmpop;
3453 if (left->op_type == OP_RV2AV &&
3454 !(left->op_private & OPpLVAL_INTRO) &&
3455 !(o->op_private & OPpASSIGN_COMMON) )
3457 tmpop = ((UNOP*)left)->op_first;
3458 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3460 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3461 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3463 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3464 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3466 pm->op_pmflags |= PMf_ONCE;
3467 tmpop = cUNOPo->op_first; /* to list (nulled) */
3468 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3469 tmpop->op_sibling = Nullop; /* don't free split */
3470 right->op_next = tmpop->op_next; /* fix starting loc */
3471 op_free(o); /* blow off assign */
3472 right->op_flags &= ~OPf_WANT;
3473 /* "I don't know and I don't care." */
3478 if (PL_modcount < 10000 &&
3479 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3481 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3483 sv_setiv(sv, PL_modcount+1);
3491 right = newOP(OP_UNDEF, 0);
3492 if (right->op_type == OP_READLINE) {
3493 right->op_flags |= OPf_STACKED;
3494 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3497 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3498 o = newBINOP(OP_SASSIGN, flags,
3499 scalar(right), mod(scalar(left), OP_SASSIGN) );
3511 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3513 U32 seq = intro_my();
3516 NewOp(1101, cop, 1, COP);
3517 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3518 cop->op_type = OP_DBSTATE;
3519 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3522 cop->op_type = OP_NEXTSTATE;
3523 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3525 cop->op_flags = flags;
3526 cop->op_private = (PL_hints & HINT_BYTE);
3528 cop->op_private |= NATIVE_HINTS;
3530 PL_compiling.op_private = cop->op_private;
3531 cop->op_next = (OP*)cop;
3534 cop->cop_label = label;
3535 PL_hints |= HINT_BLOCK_SCOPE;
3538 cop->cop_arybase = PL_curcop->cop_arybase;
3539 if (specialWARN(PL_curcop->cop_warnings))
3540 cop->cop_warnings = PL_curcop->cop_warnings ;
3542 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3543 if (specialCopIO(PL_curcop->cop_io))
3544 cop->cop_io = PL_curcop->cop_io;
3546 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3549 if (PL_copline == NOLINE)
3550 CopLINE_set(cop, CopLINE(PL_curcop));
3552 CopLINE_set(cop, PL_copline);
3553 PL_copline = NOLINE;
3556 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3558 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3560 CopSTASH_set(cop, PL_curstash);
3562 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3563 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3564 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3565 (void)SvIOK_on(*svp);
3566 SvIVX(*svp) = PTR2IV(cop);
3570 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3573 /* "Introduce" my variables to visible status. */
3581 if (! PL_min_intro_pending)
3582 return PL_cop_seqmax;
3584 svp = AvARRAY(PL_comppad_name);
3585 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3586 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3587 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3588 SvNVX(sv) = (NV)PL_cop_seqmax;
3591 PL_min_intro_pending = 0;
3592 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3593 return PL_cop_seqmax++;
3597 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3599 return new_logop(type, flags, &first, &other);
3603 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3607 OP *first = *firstp;
3608 OP *other = *otherp;
3610 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3611 return newBINOP(type, flags, scalar(first), scalar(other));
3613 scalarboolean(first);
3614 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3615 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3616 if (type == OP_AND || type == OP_OR) {
3622 first = *firstp = cUNOPo->op_first;
3624 first->op_next = o->op_next;
3625 cUNOPo->op_first = Nullop;
3629 if (first->op_type == OP_CONST) {
3630 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3631 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3632 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3643 else if (first->op_type == OP_WANTARRAY) {
3649 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3650 OP *k1 = ((UNOP*)first)->op_first;
3651 OP *k2 = k1->op_sibling;
3653 switch (first->op_type)
3656 if (k2 && k2->op_type == OP_READLINE
3657 && (k2->op_flags & OPf_STACKED)
3658 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3660 warnop = k2->op_type;
3665 if (k1->op_type == OP_READDIR
3666 || k1->op_type == OP_GLOB
3667 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3668 || k1->op_type == OP_EACH)
3670 warnop = ((k1->op_type == OP_NULL)
3671 ? k1->op_targ : k1->op_type);
3676 line_t oldline = CopLINE(PL_curcop);
3677 CopLINE_set(PL_curcop, PL_copline);
3678 Perl_warner(aTHX_ WARN_MISC,
3679 "Value of %s%s can be \"0\"; test with defined()",
3681 ((warnop == OP_READLINE || warnop == OP_GLOB)
3682 ? " construct" : "() operator"));
3683 CopLINE_set(PL_curcop, oldline);
3690 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3691 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3693 NewOp(1101, logop, 1, LOGOP);
3695 logop->op_type = type;
3696 logop->op_ppaddr = PL_ppaddr[type];
3697 logop->op_first = first;
3698 logop->op_flags = flags | OPf_KIDS;
3699 logop->op_other = LINKLIST(other);
3700 logop->op_private = 1 | (flags >> 8);
3702 /* establish postfix order */
3703 logop->op_next = LINKLIST(first);
3704 first->op_next = (OP*)logop;
3705 first->op_sibling = other;
3707 o = newUNOP(OP_NULL, 0, (OP*)logop);
3714 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3721 return newLOGOP(OP_AND, 0, first, trueop);
3723 return newLOGOP(OP_OR, 0, first, falseop);
3725 scalarboolean(first);
3726 if (first->op_type == OP_CONST) {
3727 if (SvTRUE(((SVOP*)first)->op_sv)) {
3738 else if (first->op_type == OP_WANTARRAY) {
3742 NewOp(1101, logop, 1, LOGOP);
3743 logop->op_type = OP_COND_EXPR;
3744 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3745 logop->op_first = first;
3746 logop->op_flags = flags | OPf_KIDS;
3747 logop->op_private = 1 | (flags >> 8);
3748 logop->op_other = LINKLIST(trueop);
3749 logop->op_next = LINKLIST(falseop);
3752 /* establish postfix order */
3753 start = LINKLIST(first);
3754 first->op_next = (OP*)logop;
3756 first->op_sibling = trueop;
3757 trueop->op_sibling = falseop;
3758 o = newUNOP(OP_NULL, 0, (OP*)logop);
3760 trueop->op_next = falseop->op_next = o;
3767 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3775 NewOp(1101, range, 1, LOGOP);
3777 range->op_type = OP_RANGE;
3778 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3779 range->op_first = left;
3780 range->op_flags = OPf_KIDS;
3781 leftstart = LINKLIST(left);
3782 range->op_other = LINKLIST(right);
3783 range->op_private = 1 | (flags >> 8);
3785 left->op_sibling = right;
3787 range->op_next = (OP*)range;
3788 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3789 flop = newUNOP(OP_FLOP, 0, flip);
3790 o = newUNOP(OP_NULL, 0, flop);
3792 range->op_next = leftstart;
3794 left->op_next = flip;
3795 right->op_next = flop;
3797 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3798 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3799 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3800 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3802 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3803 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3806 if (!flip->op_private || !flop->op_private)
3807 linklist(o); /* blow off optimizer unless constant */
3813 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3817 int once = block && block->op_flags & OPf_SPECIAL &&
3818 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3821 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3822 return block; /* do {} while 0 does once */
3823 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3824 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3825 expr = newUNOP(OP_DEFINED, 0,
3826 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3827 } else if (expr->op_flags & OPf_KIDS) {
3828 OP *k1 = ((UNOP*)expr)->op_first;
3829 OP *k2 = (k1) ? k1->op_sibling : NULL;
3830 switch (expr->op_type) {
3832 if (k2 && k2->op_type == OP_READLINE
3833 && (k2->op_flags & OPf_STACKED)
3834 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3835 expr = newUNOP(OP_DEFINED, 0, expr);
3839 if (k1->op_type == OP_READDIR
3840 || k1->op_type == OP_GLOB
3841 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3842 || k1->op_type == OP_EACH)
3843 expr = newUNOP(OP_DEFINED, 0, expr);
3849 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3850 o = new_logop(OP_AND, 0, &expr, &listop);
3853 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3855 if (once && o != listop)
3856 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3859 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3861 o->op_flags |= flags;
3863 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3868 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3877 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3878 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3879 expr = newUNOP(OP_DEFINED, 0,
3880 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3881 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3882 OP *k1 = ((UNOP*)expr)->op_first;
3883 OP *k2 = (k1) ? k1->op_sibling : NULL;
3884 switch (expr->op_type) {
3886 if (k2 && k2->op_type == OP_READLINE
3887 && (k2->op_flags & OPf_STACKED)
3888 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3889 expr = newUNOP(OP_DEFINED, 0, expr);
3893 if (k1->op_type == OP_READDIR
3894 || k1->op_type == OP_GLOB
3895 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3896 || k1->op_type == OP_EACH)
3897 expr = newUNOP(OP_DEFINED, 0, expr);
3903 block = newOP(OP_NULL, 0);
3905 block = scope(block);
3909 next = LINKLIST(cont);
3910 loopflags |= OPpLOOP_CONTINUE;
3913 OP *unstack = newOP(OP_UNSTACK, 0);
3916 cont = append_elem(OP_LINESEQ, cont, unstack);
3917 if ((line_t)whileline != NOLINE) {
3918 PL_copline = whileline;
3919 cont = append_elem(OP_LINESEQ, cont,
3920 newSTATEOP(0, Nullch, Nullop));
3924 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3925 redo = LINKLIST(listop);
3928 PL_copline = whileline;
3930 o = new_logop(OP_AND, 0, &expr, &listop);
3931 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3932 op_free(expr); /* oops, it's a while (0) */
3934 return Nullop; /* listop already freed by new_logop */
3937 ((LISTOP*)listop)->op_last->op_next = condop =
3938 (o == listop ? redo : LINKLIST(o));
3944 NewOp(1101,loop,1,LOOP);
3945 loop->op_type = OP_ENTERLOOP;
3946 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3947 loop->op_private = 0;
3948 loop->op_next = (OP*)loop;
3951 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3953 loop->op_redoop = redo;
3954 loop->op_lastop = o;
3955 o->op_private |= loopflags;
3958 loop->op_nextop = next;
3960 loop->op_nextop = o;
3962 o->op_flags |= flags;
3963 o->op_private |= (flags >> 8);
3968 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3976 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3977 sv->op_type = OP_RV2GV;
3978 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3980 else if (sv->op_type == OP_PADSV) { /* private variable */
3981 padoff = sv->op_targ;
3986 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3987 padoff = sv->op_targ;
3989 iterflags |= OPf_SPECIAL;
3994 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3998 padoff = find_threadsv("_");
3999 iterflags |= OPf_SPECIAL;
4001 sv = newGVOP(OP_GV, 0, PL_defgv);
4004 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4005 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4006 iterflags |= OPf_STACKED;
4008 else if (expr->op_type == OP_NULL &&
4009 (expr->op_flags & OPf_KIDS) &&
4010 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4012 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4013 * set the STACKED flag to indicate that these values are to be
4014 * treated as min/max values by 'pp_iterinit'.
4016 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4017 LOGOP* range = (LOGOP*) flip->op_first;
4018 OP* left = range->op_first;
4019 OP* right = left->op_sibling;
4022 range->op_flags &= ~OPf_KIDS;
4023 range->op_first = Nullop;
4025 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4026 listop->op_first->op_next = range->op_next;
4027 left->op_next = range->op_other;
4028 right->op_next = (OP*)listop;
4029 listop->op_next = listop->op_first;
4032 expr = (OP*)(listop);
4034 iterflags |= OPf_STACKED;
4037 expr = mod(force_list(expr), OP_GREPSTART);
4041 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4042 append_elem(OP_LIST, expr, scalar(sv))));
4043 assert(!loop->op_next);
4044 #ifdef PL_OP_SLAB_ALLOC
4047 NewOp(1234,tmp,1,LOOP);
4048 Copy(loop,tmp,1,LOOP);
4052 Renew(loop, 1, LOOP);
4054 loop->op_targ = padoff;
4055 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4056 PL_copline = forline;
4057 return newSTATEOP(0, label, wop);
4061 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4066 if (type != OP_GOTO || label->op_type == OP_CONST) {
4067 /* "last()" means "last" */
4068 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4069 o = newOP(type, OPf_SPECIAL);
4071 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4072 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4078 if (label->op_type == OP_ENTERSUB)
4079 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4080 o = newUNOP(type, OPf_STACKED, label);
4082 PL_hints |= HINT_BLOCK_SCOPE;
4087 Perl_cv_undef(pTHX_ CV *cv)
4091 MUTEX_DESTROY(CvMUTEXP(cv));
4092 Safefree(CvMUTEXP(cv));
4095 #endif /* USE_THREADS */
4097 if (!CvXSUB(cv) && CvROOT(cv)) {
4099 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4100 Perl_croak(aTHX_ "Can't undef active subroutine");
4103 Perl_croak(aTHX_ "Can't undef active subroutine");
4104 #endif /* USE_THREADS */
4107 SAVEVPTR(PL_curpad);
4111 op_free(CvROOT(cv));
4112 CvROOT(cv) = Nullop;
4115 SvPOK_off((SV*)cv); /* forget prototype */
4117 SvREFCNT_dec(CvGV(cv));
4119 SvREFCNT_dec(CvOUTSIDE(cv));
4120 CvOUTSIDE(cv) = Nullcv;
4122 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4125 if (CvPADLIST(cv)) {
4126 /* may be during global destruction */
4127 if (SvREFCNT(CvPADLIST(cv))) {
4128 I32 i = AvFILLp(CvPADLIST(cv));
4130 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4131 SV* sv = svp ? *svp : Nullsv;
4134 if (sv == (SV*)PL_comppad_name)
4135 PL_comppad_name = Nullav;
4136 else if (sv == (SV*)PL_comppad) {
4137 PL_comppad = Nullav;
4138 PL_curpad = Null(SV**);
4142 SvREFCNT_dec((SV*)CvPADLIST(cv));
4144 CvPADLIST(cv) = Nullav;
4149 S_cv_dump(pTHX_ CV *cv)
4152 CV *outside = CvOUTSIDE(cv);
4153 AV* padlist = CvPADLIST(cv);
4160 PerlIO_printf(Perl_debug_log,
4161 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4163 (CvANON(cv) ? "ANON"
4164 : (cv == PL_main_cv) ? "MAIN"
4165 : CvUNIQUE(cv) ? "UNIQUE"
4166 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4169 : CvANON(outside) ? "ANON"
4170 : (outside == PL_main_cv) ? "MAIN"
4171 : CvUNIQUE(outside) ? "UNIQUE"
4172 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4177 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4178 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4179 pname = AvARRAY(pad_name);
4180 ppad = AvARRAY(pad);
4182 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4183 if (SvPOK(pname[ix]))
4184 PerlIO_printf(Perl_debug_log,
4185 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4186 (int)ix, PTR2UV(ppad[ix]),
4187 SvFAKE(pname[ix]) ? "FAKE " : "",
4189 (IV)I_32(SvNVX(pname[ix])),
4192 #endif /* DEBUGGING */
4196 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4200 AV* protopadlist = CvPADLIST(proto);
4201 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4202 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4203 SV** pname = AvARRAY(protopad_name);
4204 SV** ppad = AvARRAY(protopad);
4205 I32 fname = AvFILLp(protopad_name);
4206 I32 fpad = AvFILLp(protopad);
4210 assert(!CvUNIQUE(proto));
4214 SAVESPTR(PL_comppad_name);
4215 SAVESPTR(PL_compcv);
4217 cv = PL_compcv = (CV*)NEWSV(1104,0);
4218 sv_upgrade((SV *)cv, SvTYPE(proto));
4219 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4223 New(666, CvMUTEXP(cv), 1, perl_mutex);
4224 MUTEX_INIT(CvMUTEXP(cv));
4226 #endif /* USE_THREADS */
4227 CvFILE(cv) = CvFILE(proto);
4228 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4229 CvSTASH(cv) = CvSTASH(proto);
4230 CvROOT(cv) = CvROOT(proto);
4231 CvSTART(cv) = CvSTART(proto);
4233 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4236 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4238 PL_comppad_name = newAV();
4239 for (ix = fname; ix >= 0; ix--)
4240 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4242 PL_comppad = newAV();
4244 comppadlist = newAV();
4245 AvREAL_off(comppadlist);
4246 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4247 av_store(comppadlist, 1, (SV*)PL_comppad);
4248 CvPADLIST(cv) = comppadlist;
4249 av_fill(PL_comppad, AvFILLp(protopad));
4250 PL_curpad = AvARRAY(PL_comppad);
4252 av = newAV(); /* will be @_ */
4254 av_store(PL_comppad, 0, (SV*)av);
4255 AvFLAGS(av) = AVf_REIFY;
4257 for (ix = fpad; ix > 0; ix--) {
4258 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4259 if (namesv && namesv != &PL_sv_undef) {
4260 char *name = SvPVX(namesv); /* XXX */
4261 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4262 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4263 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4265 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4267 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4269 else { /* our own lexical */
4272 /* anon code -- we'll come back for it */
4273 sv = SvREFCNT_inc(ppad[ix]);
4275 else if (*name == '@')
4277 else if (*name == '%')
4286 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4287 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4290 SV* sv = NEWSV(0,0);
4296 /* Now that vars are all in place, clone nested closures. */
4298 for (ix = fpad; ix > 0; ix--) {
4299 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4301 && namesv != &PL_sv_undef
4302 && !(SvFLAGS(namesv) & SVf_FAKE)
4303 && *SvPVX(namesv) == '&'
4304 && CvCLONE(ppad[ix]))
4306 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4307 SvREFCNT_dec(ppad[ix]);
4310 PL_curpad[ix] = (SV*)kid;
4314 #ifdef DEBUG_CLOSURES
4315 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4317 PerlIO_printf(Perl_debug_log, " from:\n");
4319 PerlIO_printf(Perl_debug_log, " to:\n");
4326 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4328 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4330 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4337 Perl_cv_clone(pTHX_ CV *proto)
4340 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4341 cv = cv_clone2(proto, CvOUTSIDE(proto));
4342 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4347 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4349 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4350 SV* msg = sv_newmortal();
4354 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4355 sv_setpv(msg, "Prototype mismatch:");
4357 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4359 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4360 sv_catpv(msg, " vs ");
4362 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4364 sv_catpv(msg, "none");
4365 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4369 static void const_sv_xsub(pTHXo_ CV* cv);
4372 =for apidoc cv_const_sv
4374 If C<cv> is a constant sub eligible for inlining. returns the constant
4375 value returned by the sub. Otherwise, returns NULL.
4377 Constant subs can be created with C<newCONSTSUB> or as described in
4378 L<perlsub/"Constant Functions">.
4383 Perl_cv_const_sv(pTHX_ CV *cv)
4385 if (!cv || !CvCONST(cv))
4387 return (SV*)CvXSUBANY(cv).any_ptr;
4391 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4398 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4399 o = cLISTOPo->op_first->op_sibling;
4401 for (; o; o = o->op_next) {
4402 OPCODE type = o->op_type;
4404 if (sv && o->op_next == o)
4406 if (o->op_next != o) {
4407 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4409 if (type == OP_DBSTATE)
4412 if (type == OP_LEAVESUB || type == OP_RETURN)
4416 if (type == OP_CONST && cSVOPo->op_sv)
4418 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4419 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4420 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4424 /* We get here only from cv_clone2() while creating a closure.
4425 Copy the const value here instead of in cv_clone2 so that
4426 SvREADONLY_on doesn't lead to problems when leaving
4431 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4443 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4453 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4457 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4459 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4463 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4469 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4474 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4475 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4476 SV *sv = sv_newmortal();
4477 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4478 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4483 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4484 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4494 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4495 maximum a prototype before. */
4496 if (SvTYPE(gv) > SVt_NULL) {
4497 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4498 && ckWARN_d(WARN_PROTOTYPE))
4500 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4502 cv_ckproto((CV*)gv, NULL, ps);
4505 sv_setpv((SV*)gv, ps);
4507 sv_setiv((SV*)gv, -1);
4508 SvREFCNT_dec(PL_compcv);
4509 cv = PL_compcv = NULL;
4510 PL_sub_generation++;
4514 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4516 if (!block || !ps || *ps || attrs)
4519 const_sv = op_const_sv(block, Nullcv);
4522 bool exists = CvROOT(cv) || CvXSUB(cv);
4523 /* if the subroutine doesn't exist and wasn't pre-declared
4524 * with a prototype, assume it will be AUTOLOADed,
4525 * skipping the prototype check
4527 if (exists || SvPOK(cv))
4528 cv_ckproto(cv, gv, ps);
4529 /* already defined (or promised)? */
4530 if (exists || GvASSUMECV(gv)) {
4531 if (!block && !attrs) {
4532 /* just a "sub foo;" when &foo is already defined */
4533 SAVEFREESV(PL_compcv);
4536 /* ahem, death to those who redefine active sort subs */
4537 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4538 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4540 if (ckWARN(WARN_REDEFINE)
4542 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4544 line_t oldline = CopLINE(PL_curcop);
4545 CopLINE_set(PL_curcop, PL_copline);
4546 Perl_warner(aTHX_ WARN_REDEFINE,
4547 CvCONST(cv) ? "Constant subroutine %s redefined"
4548 : "Subroutine %s redefined", name);
4549 CopLINE_set(PL_curcop, oldline);
4557 SvREFCNT_inc(const_sv);
4559 assert(!CvROOT(cv) && !CvCONST(cv));
4560 sv_setpv((SV*)cv, ""); /* prototype is "" */
4561 CvXSUBANY(cv).any_ptr = const_sv;
4562 CvXSUB(cv) = const_sv_xsub;
4567 cv = newCONSTSUB(NULL, name, const_sv);
4570 SvREFCNT_dec(PL_compcv);
4572 PL_sub_generation++;
4579 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4580 * before we clobber PL_compcv.
4584 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4585 stash = GvSTASH(CvGV(cv));
4586 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4587 stash = CvSTASH(cv);
4589 stash = PL_curstash;
4592 /* possibly about to re-define existing subr -- ignore old cv */
4593 rcv = (SV*)PL_compcv;
4594 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4595 stash = GvSTASH(gv);
4597 stash = PL_curstash;
4599 apply_attrs(stash, rcv, attrs);
4601 if (cv) { /* must reuse cv if autoloaded */
4603 /* got here with just attrs -- work done, so bug out */
4604 SAVEFREESV(PL_compcv);
4608 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4609 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4610 CvOUTSIDE(PL_compcv) = 0;
4611 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4612 CvPADLIST(PL_compcv) = 0;
4613 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4614 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4615 SvREFCNT_dec(PL_compcv);
4622 PL_sub_generation++;
4625 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4626 CvFILE(cv) = CopFILE(PL_curcop);
4627 CvSTASH(cv) = PL_curstash;
4630 if (!CvMUTEXP(cv)) {
4631 New(666, CvMUTEXP(cv), 1, perl_mutex);
4632 MUTEX_INIT(CvMUTEXP(cv));
4634 #endif /* USE_THREADS */
4637 sv_setpv((SV*)cv, ps);
4639 if (PL_error_count) {
4643 char *s = strrchr(name, ':');
4645 if (strEQ(s, "BEGIN")) {
4647 "BEGIN not safe after errors--compilation aborted";
4648 if (PL_in_eval & EVAL_KEEPERR)
4649 Perl_croak(aTHX_ not_safe);
4651 /* force display of errors found but not reported */
4652 sv_catpv(ERRSV, not_safe);
4653 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4661 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4662 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4665 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
4668 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4670 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4671 OpREFCNT_set(CvROOT(cv), 1);
4672 CvSTART(cv) = LINKLIST(CvROOT(cv));
4673 CvROOT(cv)->op_next = 0;
4676 /* now that optimizer has done its work, adjust pad values */
4678 SV **namep = AvARRAY(PL_comppad_name);
4679 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4682 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4685 * The only things that a clonable function needs in its
4686 * pad are references to outer lexicals and anonymous subs.
4687 * The rest are created anew during cloning.
4689 if (!((namesv = namep[ix]) != Nullsv &&
4690 namesv != &PL_sv_undef &&
4692 *SvPVX(namesv) == '&')))
4694 SvREFCNT_dec(PL_curpad[ix]);
4695 PL_curpad[ix] = Nullsv;
4698 assert(!CvCONST(cv));
4699 if (ps && !*ps && op_const_sv(block, cv))
4703 AV *av = newAV(); /* Will be @_ */
4705 av_store(PL_comppad, 0, (SV*)av);
4706 AvFLAGS(av) = AVf_REIFY;
4708 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4709 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4711 if (!SvPADMY(PL_curpad[ix]))
4712 SvPADTMP_on(PL_curpad[ix]);
4716 if (name || aname) {
4718 char *tname = (name ? name : aname);
4720 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4721 SV *sv = NEWSV(0,0);
4722 SV *tmpstr = sv_newmortal();
4723 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4727 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4729 (long)PL_subline, (long)CopLINE(PL_curcop));
4730 gv_efullname3(tmpstr, gv, Nullch);
4731 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4732 hv = GvHVn(db_postponed);
4733 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4734 && (pcv = GvCV(db_postponed)))
4740 call_sv((SV*)pcv, G_DISCARD);
4744 if ((s = strrchr(tname,':')))
4749 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4752 if (strEQ(s, "BEGIN")) {
4753 I32 oldscope = PL_scopestack_ix;
4755 SAVECOPFILE(&PL_compiling);
4756 SAVECOPLINE(&PL_compiling);
4758 sv_setsv(PL_rs, PL_nrs);
4761 PL_beginav = newAV();
4762 DEBUG_x( dump_sub(gv) );
4763 av_push(PL_beginav, (SV*)cv);
4764 GvCV(gv) = 0; /* cv has been hijacked */
4765 call_list(oldscope, PL_beginav);
4767 PL_curcop = &PL_compiling;
4768 PL_compiling.op_private = PL_hints;
4771 else if (strEQ(s, "END") && !PL_error_count) {
4774 DEBUG_x( dump_sub(gv) );
4775 av_unshift(PL_endav, 1);
4776 av_store(PL_endav, 0, (SV*)cv);
4777 GvCV(gv) = 0; /* cv has been hijacked */
4779 else if (strEQ(s, "CHECK") && !PL_error_count) {
4781 PL_checkav = newAV();
4782 DEBUG_x( dump_sub(gv) );
4783 if (PL_main_start && ckWARN(WARN_VOID))
4784 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4785 av_unshift(PL_checkav, 1);
4786 av_store(PL_checkav, 0, (SV*)cv);
4787 GvCV(gv) = 0; /* cv has been hijacked */
4789 else if (strEQ(s, "INIT") && !PL_error_count) {
4791 PL_initav = newAV();
4792 DEBUG_x( dump_sub(gv) );
4793 if (PL_main_start && ckWARN(WARN_VOID))
4794 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4795 av_push(PL_initav, (SV*)cv);
4796 GvCV(gv) = 0; /* cv has been hijacked */
4801 PL_copline = NOLINE;
4806 /* XXX unsafe for threads if eval_owner isn't held */
4808 =for apidoc newCONSTSUB
4810 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4811 eligible for inlining at compile-time.
4817 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4823 SAVECOPLINE(PL_curcop);
4824 CopLINE_set(PL_curcop, PL_copline);
4827 PL_hints &= ~HINT_BLOCK_SCOPE;
4830 SAVESPTR(PL_curstash);
4831 SAVECOPSTASH(PL_curcop);
4832 PL_curstash = stash;
4834 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4836 CopSTASH(PL_curcop) = stash;
4840 cv = newXS(name, const_sv_xsub, __FILE__);
4841 CvXSUBANY(cv).any_ptr = sv;
4843 sv_setpv((SV*)cv, ""); /* prototype is "" */
4851 =for apidoc U||newXS
4853 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4859 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4861 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4864 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4866 /* just a cached method */
4870 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4871 /* already defined (or promised) */
4872 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4873 && HvNAME(GvSTASH(CvGV(cv)))
4874 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4875 line_t oldline = CopLINE(PL_curcop);
4876 if (PL_copline != NOLINE)
4877 CopLINE_set(PL_curcop, PL_copline);
4878 Perl_warner(aTHX_ WARN_REDEFINE,
4879 CvCONST(cv) ? "Constant subroutine %s redefined"
4880 : "Subroutine %s redefined"
4882 CopLINE_set(PL_curcop, oldline);
4889 if (cv) /* must reuse cv if autoloaded */
4892 cv = (CV*)NEWSV(1105,0);
4893 sv_upgrade((SV *)cv, SVt_PVCV);
4897 PL_sub_generation++;
4900 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4902 New(666, CvMUTEXP(cv), 1, perl_mutex);
4903 MUTEX_INIT(CvMUTEXP(cv));
4905 #endif /* USE_THREADS */
4906 (void)gv_fetchfile(filename);
4907 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4908 an external constant string */
4909 CvXSUB(cv) = subaddr;
4912 char *s = strrchr(name,':');
4918 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4921 if (strEQ(s, "BEGIN")) {
4923 PL_beginav = newAV();
4924 av_push(PL_beginav, (SV*)cv);
4925 GvCV(gv) = 0; /* cv has been hijacked */
4927 else if (strEQ(s, "END")) {
4930 av_unshift(PL_endav, 1);
4931 av_store(PL_endav, 0, (SV*)cv);
4932 GvCV(gv) = 0; /* cv has been hijacked */
4934 else if (strEQ(s, "CHECK")) {
4936 PL_checkav = newAV();
4937 if (PL_main_start && ckWARN(WARN_VOID))
4938 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4939 av_unshift(PL_checkav, 1);
4940 av_store(PL_checkav, 0, (SV*)cv);
4941 GvCV(gv) = 0; /* cv has been hijacked */
4943 else if (strEQ(s, "INIT")) {
4945 PL_initav = newAV();
4946 if (PL_main_start && ckWARN(WARN_VOID))
4947 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4948 av_push(PL_initav, (SV*)cv);
4949 GvCV(gv) = 0; /* cv has been hijacked */
4960 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4969 name = SvPVx(cSVOPo->op_sv, n_a);
4972 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4974 if ((cv = GvFORM(gv))) {
4975 if (ckWARN(WARN_REDEFINE)) {
4976 line_t oldline = CopLINE(PL_curcop);
4978 CopLINE_set(PL_curcop, PL_copline);
4979 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
4980 CopLINE_set(PL_curcop, oldline);
4986 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4987 CvFILE(cv) = CopFILE(PL_curcop);
4989 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4990 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
4991 SvPADTMP_on(PL_curpad[ix]);
4994 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4995 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4996 OpREFCNT_set(CvROOT(cv), 1);
4997 CvSTART(cv) = LINKLIST(CvROOT(cv));
4998 CvROOT(cv)->op_next = 0;
5001 PL_copline = NOLINE;
5006 Perl_newANONLIST(pTHX_ OP *o)
5008 return newUNOP(OP_REFGEN, 0,
5009 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5013 Perl_newANONHASH(pTHX_ OP *o)
5015 return newUNOP(OP_REFGEN, 0,
5016 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5020 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5022 return newANONATTRSUB(floor, proto, Nullop, block);
5026 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5028 return newUNOP(OP_REFGEN, 0,
5029 newSVOP(OP_ANONCODE, 0,
5030 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5034 Perl_oopsAV(pTHX_ OP *o)
5036 switch (o->op_type) {
5038 o->op_type = OP_PADAV;
5039 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5040 return ref(o, OP_RV2AV);
5043 o->op_type = OP_RV2AV;
5044 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5049 if (ckWARN_d(WARN_INTERNAL))
5050 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5057 Perl_oopsHV(pTHX_ OP *o)
5059 switch (o->op_type) {
5062 o->op_type = OP_PADHV;
5063 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5064 return ref(o, OP_RV2HV);
5068 o->op_type = OP_RV2HV;
5069 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5074 if (ckWARN_d(WARN_INTERNAL))
5075 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5082 Perl_newAVREF(pTHX_ OP *o)
5084 if (o->op_type == OP_PADANY) {
5085 o->op_type = OP_PADAV;
5086 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5089 return newUNOP(OP_RV2AV, 0, scalar(o));
5093 Perl_newGVREF(pTHX_ I32 type, OP *o)
5095 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5096 return newUNOP(OP_NULL, 0, o);
5097 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5101 Perl_newHVREF(pTHX_ OP *o)
5103 if (o->op_type == OP_PADANY) {
5104 o->op_type = OP_PADHV;
5105 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5108 return newUNOP(OP_RV2HV, 0, scalar(o));
5112 Perl_oopsCV(pTHX_ OP *o)
5114 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5120 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5122 return newUNOP(OP_RV2CV, flags, scalar(o));
5126 Perl_newSVREF(pTHX_ OP *o)
5128 if (o->op_type == OP_PADANY) {
5129 o->op_type = OP_PADSV;
5130 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5133 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5134 o->op_flags |= OPpDONE_SVREF;
5137 return newUNOP(OP_RV2SV, 0, scalar(o));
5140 /* Check routines. */
5143 Perl_ck_anoncode(pTHX_ OP *o)
5148 name = NEWSV(1106,0);
5149 sv_upgrade(name, SVt_PVNV);
5150 sv_setpvn(name, "&", 1);
5153 ix = pad_alloc(o->op_type, SVs_PADMY);
5154 av_store(PL_comppad_name, ix, name);
5155 av_store(PL_comppad, ix, cSVOPo->op_sv);
5156 SvPADMY_on(cSVOPo->op_sv);
5157 cSVOPo->op_sv = Nullsv;
5158 cSVOPo->op_targ = ix;
5163 Perl_ck_bitop(pTHX_ OP *o)
5165 o->op_private = PL_hints;
5170 Perl_ck_concat(pTHX_ OP *o)
5172 if (cUNOPo->op_first->op_type == OP_CONCAT)
5173 o->op_flags |= OPf_STACKED;
5178 Perl_ck_spair(pTHX_ OP *o)
5180 if (o->op_flags & OPf_KIDS) {
5183 OPCODE type = o->op_type;
5184 o = modkids(ck_fun(o), type);
5185 kid = cUNOPo->op_first;
5186 newop = kUNOP->op_first->op_sibling;
5188 (newop->op_sibling ||
5189 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5190 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5191 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5195 op_free(kUNOP->op_first);
5196 kUNOP->op_first = newop;
5198 o->op_ppaddr = PL_ppaddr[++o->op_type];
5203 Perl_ck_delete(pTHX_ OP *o)
5207 if (o->op_flags & OPf_KIDS) {
5208 OP *kid = cUNOPo->op_first;
5209 switch (kid->op_type) {
5211 o->op_flags |= OPf_SPECIAL;
5214 o->op_private |= OPpSLICE;
5217 o->op_flags |= OPf_SPECIAL;
5222 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5223 PL_op_desc[o->op_type]);
5231 Perl_ck_eof(pTHX_ OP *o)
5233 I32 type = o->op_type;
5235 if (o->op_flags & OPf_KIDS) {
5236 if (cLISTOPo->op_first->op_type == OP_STUB) {
5238 o = newUNOP(type, OPf_SPECIAL,
5239 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5247 Perl_ck_eval(pTHX_ OP *o)
5249 PL_hints |= HINT_BLOCK_SCOPE;
5250 if (o->op_flags & OPf_KIDS) {
5251 SVOP *kid = (SVOP*)cUNOPo->op_first;
5254 o->op_flags &= ~OPf_KIDS;
5257 else if (kid->op_type == OP_LINESEQ) {
5260 kid->op_next = o->op_next;
5261 cUNOPo->op_first = 0;
5264 NewOp(1101, enter, 1, LOGOP);
5265 enter->op_type = OP_ENTERTRY;
5266 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5267 enter->op_private = 0;
5269 /* establish postfix order */
5270 enter->op_next = (OP*)enter;
5272 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5273 o->op_type = OP_LEAVETRY;
5274 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5275 enter->op_other = o;
5283 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5285 o->op_targ = (PADOFFSET)PL_hints;
5290 Perl_ck_exit(pTHX_ OP *o)
5293 HV *table = GvHV(PL_hintgv);
5295 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5296 if (svp && *svp && SvTRUE(*svp))
5297 o->op_private |= OPpEXIT_VMSISH;
5304 Perl_ck_exec(pTHX_ OP *o)
5307 if (o->op_flags & OPf_STACKED) {
5309 kid = cUNOPo->op_first->op_sibling;
5310 if (kid->op_type == OP_RV2GV)
5319 Perl_ck_exists(pTHX_ OP *o)
5322 if (o->op_flags & OPf_KIDS) {
5323 OP *kid = cUNOPo->op_first;
5324 if (kid->op_type == OP_ENTERSUB) {
5325 (void) ref(kid, o->op_type);
5326 if (kid->op_type != OP_RV2CV && !PL_error_count)
5327 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5328 PL_op_desc[o->op_type]);
5329 o->op_private |= OPpEXISTS_SUB;
5331 else if (kid->op_type == OP_AELEM)
5332 o->op_flags |= OPf_SPECIAL;
5333 else if (kid->op_type != OP_HELEM)
5334 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5335 PL_op_desc[o->op_type]);
5343 Perl_ck_gvconst(pTHX_ register OP *o)
5345 o = fold_constants(o);
5346 if (o->op_type == OP_CONST)
5353 Perl_ck_rvconst(pTHX_ register OP *o)
5355 SVOP *kid = (SVOP*)cUNOPo->op_first;
5357 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5358 if (kid->op_type == OP_CONST) {
5362 SV *kidsv = kid->op_sv;
5365 /* Is it a constant from cv_const_sv()? */
5366 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5367 SV *rsv = SvRV(kidsv);
5368 int svtype = SvTYPE(rsv);
5369 char *badtype = Nullch;
5371 switch (o->op_type) {
5373 if (svtype > SVt_PVMG)
5374 badtype = "a SCALAR";
5377 if (svtype != SVt_PVAV)
5378 badtype = "an ARRAY";
5381 if (svtype != SVt_PVHV) {
5382 if (svtype == SVt_PVAV) { /* pseudohash? */
5383 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5384 if (ksv && SvROK(*ksv)
5385 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5394 if (svtype != SVt_PVCV)
5399 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5402 name = SvPV(kidsv, n_a);
5403 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5404 char *badthing = Nullch;
5405 switch (o->op_type) {
5407 badthing = "a SCALAR";
5410 badthing = "an ARRAY";
5413 badthing = "a HASH";
5418 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5422 * This is a little tricky. We only want to add the symbol if we
5423 * didn't add it in the lexer. Otherwise we get duplicate strict
5424 * warnings. But if we didn't add it in the lexer, we must at
5425 * least pretend like we wanted to add it even if it existed before,
5426 * or we get possible typo warnings. OPpCONST_ENTERED says
5427 * whether the lexer already added THIS instance of this symbol.
5429 iscv = (o->op_type == OP_RV2CV) * 2;
5431 gv = gv_fetchpv(name,
5432 iscv | !(kid->op_private & OPpCONST_ENTERED),
5435 : o->op_type == OP_RV2SV
5437 : o->op_type == OP_RV2AV
5439 : o->op_type == OP_RV2HV
5442 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5444 kid->op_type = OP_GV;
5445 SvREFCNT_dec(kid->op_sv);
5447 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5448 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5449 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5451 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5453 kid->op_sv = SvREFCNT_inc(gv);
5455 kid->op_ppaddr = PL_ppaddr[OP_GV];
5462 Perl_ck_ftst(pTHX_ OP *o)
5464 I32 type = o->op_type;
5466 if (o->op_flags & OPf_REF) {
5469 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5470 SVOP *kid = (SVOP*)cUNOPo->op_first;
5472 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5474 OP *newop = newGVOP(type, OPf_REF,
5475 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5482 if (type == OP_FTTTY)
5483 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5486 o = newUNOP(type, 0, newDEFSVOP());
5489 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5491 if (PL_hints & HINT_LOCALE)
5492 o->op_private |= OPpLOCALE;
5499 Perl_ck_fun(pTHX_ OP *o)
5505 int type = o->op_type;
5506 register I32 oa = PL_opargs[type] >> OASHIFT;
5508 if (o->op_flags & OPf_STACKED) {
5509 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5512 return no_fh_allowed(o);
5515 if (o->op_flags & OPf_KIDS) {
5517 tokid = &cLISTOPo->op_first;
5518 kid = cLISTOPo->op_first;
5519 if (kid->op_type == OP_PUSHMARK ||
5520 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5522 tokid = &kid->op_sibling;
5523 kid = kid->op_sibling;
5525 if (!kid && PL_opargs[type] & OA_DEFGV)
5526 *tokid = kid = newDEFSVOP();
5530 sibl = kid->op_sibling;
5533 /* list seen where single (scalar) arg expected? */
5534 if (numargs == 1 && !(oa >> 4)
5535 && kid->op_type == OP_LIST && type != OP_SCALAR)
5537 return too_many_arguments(o,PL_op_desc[type]);
5550 if (kid->op_type == OP_CONST &&
5551 (kid->op_private & OPpCONST_BARE))
5553 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5554 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5555 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5556 if (ckWARN(WARN_DEPRECATED))
5557 Perl_warner(aTHX_ WARN_DEPRECATED,
5558 "Array @%s missing the @ in argument %"IVdf" of %s()",
5559 name, (IV)numargs, PL_op_desc[type]);
5562 kid->op_sibling = sibl;
5565 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5566 bad_type(numargs, "array", PL_op_desc[type], kid);
5570 if (kid->op_type == OP_CONST &&
5571 (kid->op_private & OPpCONST_BARE))
5573 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5574 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5575 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5576 if (ckWARN(WARN_DEPRECATED))
5577 Perl_warner(aTHX_ WARN_DEPRECATED,
5578 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5579 name, (IV)numargs, PL_op_desc[type]);
5582 kid->op_sibling = sibl;
5585 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5586 bad_type(numargs, "hash", PL_op_desc[type], kid);
5591 OP *newop = newUNOP(OP_NULL, 0, kid);
5592 kid->op_sibling = 0;
5594 newop->op_next = newop;
5596 kid->op_sibling = sibl;
5601 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5602 if (kid->op_type == OP_CONST &&
5603 (kid->op_private & OPpCONST_BARE))
5605 OP *newop = newGVOP(OP_GV, 0,
5606 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5611 else if (kid->op_type == OP_READLINE) {
5612 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5613 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5616 I32 flags = OPf_SPECIAL;
5620 /* is this op a FH constructor? */
5621 if (is_handle_constructor(o,numargs)) {
5622 char *name = Nullch;
5626 /* Set a flag to tell rv2gv to vivify
5627 * need to "prove" flag does not mean something
5628 * else already - NI-S 1999/05/07
5631 if (kid->op_type == OP_PADSV) {
5632 SV **namep = av_fetch(PL_comppad_name,
5634 if (namep && *namep)
5635 name = SvPV(*namep, len);
5637 else if (kid->op_type == OP_RV2SV
5638 && kUNOP->op_first->op_type == OP_GV)
5640 GV *gv = cGVOPx_gv(kUNOP->op_first);
5642 len = GvNAMELEN(gv);
5644 else if (kid->op_type == OP_AELEM
5645 || kid->op_type == OP_HELEM)
5647 name = "__ANONIO__";
5653 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5654 namesv = PL_curpad[targ];
5655 (void)SvUPGRADE(namesv, SVt_PV);
5657 sv_setpvn(namesv, "$", 1);
5658 sv_catpvn(namesv, name, len);
5661 kid->op_sibling = 0;
5662 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5663 kid->op_targ = targ;
5664 kid->op_private |= priv;
5666 kid->op_sibling = sibl;
5672 mod(scalar(kid), type);
5676 tokid = &kid->op_sibling;
5677 kid = kid->op_sibling;
5679 o->op_private |= numargs;
5681 return too_many_arguments(o,PL_op_desc[o->op_type]);
5684 else if (PL_opargs[type] & OA_DEFGV) {
5686 return newUNOP(type, 0, newDEFSVOP());
5690 while (oa & OA_OPTIONAL)
5692 if (oa && oa != OA_LIST)
5693 return too_few_arguments(o,PL_op_desc[o->op_type]);
5699 Perl_ck_glob(pTHX_ OP *o)
5704 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5705 append_elem(OP_GLOB, o, newDEFSVOP());
5707 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5708 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5710 #if !defined(PERL_EXTERNAL_GLOB)
5711 /* XXX this can be tightened up and made more failsafe. */
5714 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5715 /* null-terminated import list */
5716 newSVpvn(":globally", 9), Nullsv);
5717 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5720 #endif /* PERL_EXTERNAL_GLOB */
5722 if (gv && GvIMPORTED_CV(gv)) {
5723 append_elem(OP_GLOB, o,
5724 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5725 o->op_type = OP_LIST;
5726 o->op_ppaddr = PL_ppaddr[OP_LIST];
5727 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5728 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5729 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5730 append_elem(OP_LIST, o,
5731 scalar(newUNOP(OP_RV2CV, 0,
5732 newGVOP(OP_GV, 0, gv)))));
5733 o = newUNOP(OP_NULL, 0, ck_subr(o));
5734 o->op_targ = OP_GLOB; /* hint at what it used to be */
5737 gv = newGVgen("main");
5739 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5745 Perl_ck_grep(pTHX_ OP *o)
5749 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5751 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5752 NewOp(1101, gwop, 1, LOGOP);
5754 if (o->op_flags & OPf_STACKED) {
5757 kid = cLISTOPo->op_first->op_sibling;
5758 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5761 kid->op_next = (OP*)gwop;
5762 o->op_flags &= ~OPf_STACKED;
5764 kid = cLISTOPo->op_first->op_sibling;
5765 if (type == OP_MAPWHILE)
5772 kid = cLISTOPo->op_first->op_sibling;
5773 if (kid->op_type != OP_NULL)
5774 Perl_croak(aTHX_ "panic: ck_grep");
5775 kid = kUNOP->op_first;
5777 gwop->op_type = type;
5778 gwop->op_ppaddr = PL_ppaddr[type];
5779 gwop->op_first = listkids(o);
5780 gwop->op_flags |= OPf_KIDS;
5781 gwop->op_private = 1;
5782 gwop->op_other = LINKLIST(kid);
5783 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5784 kid->op_next = (OP*)gwop;
5786 kid = cLISTOPo->op_first->op_sibling;
5787 if (!kid || !kid->op_sibling)
5788 return too_few_arguments(o,PL_op_desc[o->op_type]);
5789 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5790 mod(kid, OP_GREPSTART);
5796 Perl_ck_index(pTHX_ OP *o)
5798 if (o->op_flags & OPf_KIDS) {
5799 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5801 kid = kid->op_sibling; /* get past "big" */
5802 if (kid && kid->op_type == OP_CONST)
5803 fbm_compile(((SVOP*)kid)->op_sv, 0);
5809 Perl_ck_lengthconst(pTHX_ OP *o)
5811 /* XXX length optimization goes here */
5816 Perl_ck_lfun(pTHX_ OP *o)
5818 OPCODE type = o->op_type;
5819 return modkids(ck_fun(o), type);
5823 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5825 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5826 switch (cUNOPo->op_first->op_type) {
5828 /* This is needed for
5829 if (defined %stash::)
5830 to work. Do not break Tk.
5832 break; /* Globals via GV can be undef */
5834 case OP_AASSIGN: /* Is this a good idea? */
5835 Perl_warner(aTHX_ WARN_DEPRECATED,
5836 "defined(@array) is deprecated");
5837 Perl_warner(aTHX_ WARN_DEPRECATED,
5838 "\t(Maybe you should just omit the defined()?)\n");
5841 /* This is needed for
5842 if (defined %stash::)
5843 to work. Do not break Tk.
5845 break; /* Globals via GV can be undef */
5847 Perl_warner(aTHX_ WARN_DEPRECATED,
5848 "defined(%%hash) is deprecated");
5849 Perl_warner(aTHX_ WARN_DEPRECATED,
5850 "\t(Maybe you should just omit the defined()?)\n");
5861 Perl_ck_rfun(pTHX_ OP *o)
5863 OPCODE type = o->op_type;
5864 return refkids(ck_fun(o), type);
5868 Perl_ck_listiob(pTHX_ OP *o)
5872 kid = cLISTOPo->op_first;
5875 kid = cLISTOPo->op_first;
5877 if (kid->op_type == OP_PUSHMARK)
5878 kid = kid->op_sibling;
5879 if (kid && o->op_flags & OPf_STACKED)
5880 kid = kid->op_sibling;
5881 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5882 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5883 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5884 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5885 cLISTOPo->op_first->op_sibling = kid;
5886 cLISTOPo->op_last = kid;
5887 kid = kid->op_sibling;
5892 append_elem(o->op_type, o, newDEFSVOP());
5898 if (PL_hints & HINT_LOCALE)
5899 o->op_private |= OPpLOCALE;
5906 Perl_ck_fun_locale(pTHX_ OP *o)
5912 if (PL_hints & HINT_LOCALE)
5913 o->op_private |= OPpLOCALE;
5920 Perl_ck_sassign(pTHX_ OP *o)
5922 OP *kid = cLISTOPo->op_first;
5923 /* has a disposable target? */
5924 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5925 && !(kid->op_flags & OPf_STACKED)
5926 /* Cannot steal the second time! */
5927 && !(kid->op_private & OPpTARGET_MY))
5929 OP *kkid = kid->op_sibling;
5931 /* Can just relocate the target. */
5932 if (kkid && kkid->op_type == OP_PADSV
5933 && !(kkid->op_private & OPpLVAL_INTRO))
5935 kid->op_targ = kkid->op_targ;
5937 /* Now we do not need PADSV and SASSIGN. */
5938 kid->op_sibling = o->op_sibling; /* NULL */
5939 cLISTOPo->op_first = NULL;
5942 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5950 Perl_ck_scmp(pTHX_ OP *o)
5954 if (PL_hints & HINT_LOCALE)
5955 o->op_private |= OPpLOCALE;
5962 Perl_ck_match(pTHX_ OP *o)
5964 o->op_private |= OPpRUNTIME;
5969 Perl_ck_method(pTHX_ OP *o)
5971 OP *kid = cUNOPo->op_first;
5972 if (kid->op_type == OP_CONST) {
5973 SV* sv = kSVOP->op_sv;
5974 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5976 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5977 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5980 kSVOP->op_sv = Nullsv;
5982 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5991 Perl_ck_null(pTHX_ OP *o)
5997 Perl_ck_open(pTHX_ OP *o)
5999 HV *table = GvHV(PL_hintgv);
6003 svp = hv_fetch(table, "open_IN", 7, FALSE);
6005 mode = mode_from_discipline(*svp);
6006 if (mode & O_BINARY)
6007 o->op_private |= OPpOPEN_IN_RAW;
6008 else if (mode & O_TEXT)
6009 o->op_private |= OPpOPEN_IN_CRLF;
6012 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6014 mode = mode_from_discipline(*svp);
6015 if (mode & O_BINARY)
6016 o->op_private |= OPpOPEN_OUT_RAW;
6017 else if (mode & O_TEXT)
6018 o->op_private |= OPpOPEN_OUT_CRLF;
6021 if (o->op_type == OP_BACKTICK)
6027 Perl_ck_repeat(pTHX_ OP *o)
6029 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6030 o->op_private |= OPpREPEAT_DOLIST;
6031 cBINOPo->op_first = force_list(cBINOPo->op_first);
6039 Perl_ck_require(pTHX_ OP *o)
6041 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6042 SVOP *kid = (SVOP*)cUNOPo->op_first;
6044 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6046 for (s = SvPVX(kid->op_sv); *s; s++) {
6047 if (*s == ':' && s[1] == ':') {
6049 Move(s+2, s+1, strlen(s+2)+1, char);
6050 --SvCUR(kid->op_sv);
6053 if (SvREADONLY(kid->op_sv)) {
6054 SvREADONLY_off(kid->op_sv);
6055 sv_catpvn(kid->op_sv, ".pm", 3);
6056 SvREADONLY_on(kid->op_sv);
6059 sv_catpvn(kid->op_sv, ".pm", 3);
6067 Perl_ck_retarget(pTHX_ OP *o)
6069 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6076 Perl_ck_select(pTHX_ OP *o)
6079 if (o->op_flags & OPf_KIDS) {
6080 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6081 if (kid && kid->op_sibling) {
6082 o->op_type = OP_SSELECT;
6083 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6085 return fold_constants(o);
6089 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6090 if (kid && kid->op_type == OP_RV2GV)
6091 kid->op_private &= ~HINT_STRICT_REFS;
6096 Perl_ck_shift(pTHX_ OP *o)
6098 I32 type = o->op_type;
6100 if (!(o->op_flags & OPf_KIDS)) {
6105 if (!CvUNIQUE(PL_compcv)) {
6106 argop = newOP(OP_PADAV, OPf_REF);
6107 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6110 argop = newUNOP(OP_RV2AV, 0,
6111 scalar(newGVOP(OP_GV, 0,
6112 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6115 argop = newUNOP(OP_RV2AV, 0,
6116 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6117 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6118 #endif /* USE_THREADS */
6119 return newUNOP(type, 0, scalar(argop));
6121 return scalar(modkids(ck_fun(o), type));
6125 Perl_ck_sort(pTHX_ OP *o)
6130 if (PL_hints & HINT_LOCALE)
6131 o->op_private |= OPpLOCALE;
6134 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6136 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6137 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6139 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6141 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6143 if (kid->op_type == OP_SCOPE) {
6147 else if (kid->op_type == OP_LEAVE) {
6148 if (o->op_type == OP_SORT) {
6149 null(kid); /* wipe out leave */
6152 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6153 if (k->op_next == kid)
6155 /* don't descend into loops */
6156 else if (k->op_type == OP_ENTERLOOP
6157 || k->op_type == OP_ENTERITER)
6159 k = cLOOPx(k)->op_lastop;
6164 kid->op_next = 0; /* just disconnect the leave */
6165 k = kLISTOP->op_first;
6170 if (o->op_type == OP_SORT) {
6171 /* provide scalar context for comparison function/block */
6177 o->op_flags |= OPf_SPECIAL;
6179 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6182 firstkid = firstkid->op_sibling;
6185 /* provide list context for arguments */
6186 if (o->op_type == OP_SORT)
6193 S_simplify_sort(pTHX_ OP *o)
6195 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6199 if (!(o->op_flags & OPf_STACKED))
6201 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6202 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6203 kid = kUNOP->op_first; /* get past null */
6204 if (kid->op_type != OP_SCOPE)
6206 kid = kLISTOP->op_last; /* get past scope */
6207 switch(kid->op_type) {
6215 k = kid; /* remember this node*/
6216 if (kBINOP->op_first->op_type != OP_RV2SV)
6218 kid = kBINOP->op_first; /* get past cmp */
6219 if (kUNOP->op_first->op_type != OP_GV)
6221 kid = kUNOP->op_first; /* get past rv2sv */
6223 if (GvSTASH(gv) != PL_curstash)
6225 if (strEQ(GvNAME(gv), "a"))
6227 else if (strEQ(GvNAME(gv), "b"))
6231 kid = k; /* back to cmp */
6232 if (kBINOP->op_last->op_type != OP_RV2SV)
6234 kid = kBINOP->op_last; /* down to 2nd arg */
6235 if (kUNOP->op_first->op_type != OP_GV)
6237 kid = kUNOP->op_first; /* get past rv2sv */
6239 if (GvSTASH(gv) != PL_curstash
6241 ? strNE(GvNAME(gv), "a")
6242 : strNE(GvNAME(gv), "b")))
6244 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6246 o->op_private |= OPpSORT_REVERSE;
6247 if (k->op_type == OP_NCMP)
6248 o->op_private |= OPpSORT_NUMERIC;
6249 if (k->op_type == OP_I_NCMP)
6250 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6251 kid = cLISTOPo->op_first->op_sibling;
6252 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6253 op_free(kid); /* then delete it */
6254 cLISTOPo->op_children--;
6258 Perl_ck_split(pTHX_ OP *o)
6262 if (o->op_flags & OPf_STACKED)
6263 return no_fh_allowed(o);
6265 kid = cLISTOPo->op_first;
6266 if (kid->op_type != OP_NULL)
6267 Perl_croak(aTHX_ "panic: ck_split");
6268 kid = kid->op_sibling;
6269 op_free(cLISTOPo->op_first);
6270 cLISTOPo->op_first = kid;
6272 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6273 cLISTOPo->op_last = kid; /* There was only one element previously */
6276 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6277 OP *sibl = kid->op_sibling;
6278 kid->op_sibling = 0;
6279 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6280 if (cLISTOPo->op_first == cLISTOPo->op_last)
6281 cLISTOPo->op_last = kid;
6282 cLISTOPo->op_first = kid;
6283 kid->op_sibling = sibl;
6286 kid->op_type = OP_PUSHRE;
6287 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6290 if (!kid->op_sibling)
6291 append_elem(OP_SPLIT, o, newDEFSVOP());
6293 kid = kid->op_sibling;
6296 if (!kid->op_sibling)
6297 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6299 kid = kid->op_sibling;
6302 if (kid->op_sibling)
6303 return too_many_arguments(o,PL_op_desc[o->op_type]);
6309 Perl_ck_join(pTHX_ OP *o)
6311 if (ckWARN(WARN_SYNTAX)) {
6312 OP *kid = cLISTOPo->op_first->op_sibling;
6313 if (kid && kid->op_type == OP_MATCH) {
6314 char *pmstr = "STRING";
6315 if (kPMOP->op_pmregexp)
6316 pmstr = kPMOP->op_pmregexp->precomp;
6317 Perl_warner(aTHX_ WARN_SYNTAX,
6318 "/%s/ should probably be written as \"%s\"",
6326 Perl_ck_subr(pTHX_ OP *o)
6328 OP *prev = ((cUNOPo->op_first->op_sibling)
6329 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6330 OP *o2 = prev->op_sibling;
6339 o->op_private |= OPpENTERSUB_HASTARG;
6340 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6341 if (cvop->op_type == OP_RV2CV) {
6343 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6344 null(cvop); /* disable rv2cv */
6345 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6346 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6347 GV *gv = cGVOPx_gv(tmpop);
6350 tmpop->op_private |= OPpEARLY_CV;
6351 else if (SvPOK(cv)) {
6352 namegv = CvANON(cv) ? gv : CvGV(cv);
6353 proto = SvPV((SV*)cv, n_a);
6357 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6358 if (o2->op_type == OP_CONST)
6359 o2->op_private &= ~OPpCONST_STRICT;
6360 else if (o2->op_type == OP_LIST) {
6361 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6362 if (o && o->op_type == OP_CONST)
6363 o->op_private &= ~OPpCONST_STRICT;
6366 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6367 if (PERLDB_SUB && PL_curstash != PL_debstash)
6368 o->op_private |= OPpENTERSUB_DB;
6369 while (o2 != cvop) {
6373 return too_many_arguments(o, gv_ename(namegv));
6391 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6393 arg == 1 ? "block or sub {}" : "sub {}",
6394 gv_ename(namegv), o2);
6397 /* '*' allows any scalar type, including bareword */
6400 if (o2->op_type == OP_RV2GV)
6401 goto wrapref; /* autoconvert GLOB -> GLOBref */
6402 else if (o2->op_type == OP_CONST)
6403 o2->op_private &= ~OPpCONST_STRICT;
6404 else if (o2->op_type == OP_ENTERSUB) {
6405 /* accidental subroutine, revert to bareword */
6406 OP *gvop = ((UNOP*)o2)->op_first;
6407 if (gvop && gvop->op_type == OP_NULL) {
6408 gvop = ((UNOP*)gvop)->op_first;
6410 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6413 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6414 (gvop = ((UNOP*)gvop)->op_first) &&
6415 gvop->op_type == OP_GV)
6417 GV *gv = cGVOPx_gv(gvop);
6418 OP *sibling = o2->op_sibling;
6419 SV *n = newSVpvn("",0);
6421 gv_fullname3(n, gv, "");
6422 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6423 sv_chop(n, SvPVX(n)+6);
6424 o2 = newSVOP(OP_CONST, 0, n);
6425 prev->op_sibling = o2;
6426 o2->op_sibling = sibling;
6438 if (o2->op_type != OP_RV2GV)
6439 bad_type(arg, "symbol", gv_ename(namegv), o2);
6442 if (o2->op_type != OP_ENTERSUB)
6443 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6446 if (o2->op_type != OP_RV2SV
6447 && o2->op_type != OP_PADSV
6448 && o2->op_type != OP_HELEM
6449 && o2->op_type != OP_AELEM
6450 && o2->op_type != OP_THREADSV)
6452 bad_type(arg, "scalar", gv_ename(namegv), o2);
6456 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6457 bad_type(arg, "array", gv_ename(namegv), o2);
6460 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6461 bad_type(arg, "hash", gv_ename(namegv), o2);
6465 OP* sib = kid->op_sibling;
6466 kid->op_sibling = 0;
6467 o2 = newUNOP(OP_REFGEN, 0, kid);
6468 o2->op_sibling = sib;
6469 prev->op_sibling = o2;
6480 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6481 gv_ename(namegv), SvPV((SV*)cv, n_a));
6486 mod(o2, OP_ENTERSUB);
6488 o2 = o2->op_sibling;
6490 if (proto && !optional &&
6491 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6492 return too_few_arguments(o, gv_ename(namegv));
6497 Perl_ck_svconst(pTHX_ OP *o)
6499 SvREADONLY_on(cSVOPo->op_sv);
6504 Perl_ck_trunc(pTHX_ OP *o)
6506 if (o->op_flags & OPf_KIDS) {
6507 SVOP *kid = (SVOP*)cUNOPo->op_first;
6509 if (kid->op_type == OP_NULL)
6510 kid = (SVOP*)kid->op_sibling;
6511 if (kid && kid->op_type == OP_CONST &&
6512 (kid->op_private & OPpCONST_BARE))
6514 o->op_flags |= OPf_SPECIAL;
6515 kid->op_private &= ~OPpCONST_STRICT;
6522 Perl_ck_substr(pTHX_ OP *o)
6525 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6526 OP *kid = cLISTOPo->op_first;
6528 if (kid->op_type == OP_NULL)
6529 kid = kid->op_sibling;
6531 kid->op_flags |= OPf_MOD;
6537 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6540 Perl_peep(pTHX_ register OP *o)
6542 register OP* oldop = 0;
6544 OP *last_composite = Nullop;
6546 if (!o || o->op_seq)
6550 SAVEVPTR(PL_curcop);
6551 for (; o; o = o->op_next) {
6557 switch (o->op_type) {
6561 PL_curcop = ((COP*)o); /* for warnings */
6562 o->op_seq = PL_op_seqmax++;
6563 last_composite = Nullop;
6567 if (cSVOPo->op_private & OPpCONST_STRICT)
6568 no_bareword_allowed(o);
6570 /* Relocate sv to the pad for thread safety.
6571 * Despite being a "constant", the SV is written to,
6572 * for reference counts, sv_upgrade() etc. */
6574 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6575 if (SvPADTMP(cSVOPo->op_sv)) {
6576 /* If op_sv is already a PADTMP then it is being used by
6577 * some pad, so make a copy. */
6578 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6579 SvREADONLY_on(PL_curpad[ix]);
6580 SvREFCNT_dec(cSVOPo->op_sv);
6583 SvREFCNT_dec(PL_curpad[ix]);
6584 SvPADTMP_on(cSVOPo->op_sv);
6585 PL_curpad[ix] = cSVOPo->op_sv;
6586 /* XXX I don't know how this isn't readonly already. */
6587 SvREADONLY_on(PL_curpad[ix]);
6589 cSVOPo->op_sv = Nullsv;
6593 o->op_seq = PL_op_seqmax++;
6597 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6598 if (o->op_next->op_private & OPpTARGET_MY) {
6599 if (o->op_flags & OPf_STACKED) /* chained concats */
6600 goto ignore_optimization;
6602 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6603 o->op_targ = o->op_next->op_targ;
6604 o->op_next->op_targ = 0;
6605 o->op_private |= OPpTARGET_MY;
6610 ignore_optimization:
6611 o->op_seq = PL_op_seqmax++;
6614 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6615 o->op_seq = PL_op_seqmax++;
6616 break; /* Scalar stub must produce undef. List stub is noop */
6620 if (o->op_targ == OP_NEXTSTATE
6621 || o->op_targ == OP_DBSTATE
6622 || o->op_targ == OP_SETSTATE)
6624 PL_curcop = ((COP*)o);
6631 if (oldop && o->op_next) {
6632 oldop->op_next = o->op_next;
6635 o->op_seq = PL_op_seqmax++;
6639 if (o->op_next->op_type == OP_RV2SV) {
6640 if (!(o->op_next->op_private & OPpDEREF)) {
6642 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6644 o->op_next = o->op_next->op_next;
6645 o->op_type = OP_GVSV;
6646 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6649 else if (o->op_next->op_type == OP_RV2AV) {
6650 OP* pop = o->op_next->op_next;
6652 if (pop->op_type == OP_CONST &&
6653 (PL_op = pop->op_next) &&
6654 pop->op_next->op_type == OP_AELEM &&
6655 !(pop->op_next->op_private &
6656 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
6657 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6665 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6666 o->op_next = pop->op_next->op_next;
6667 o->op_type = OP_AELEMFAST;
6668 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6669 o->op_private = (U8)i;
6674 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6676 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6677 /* XXX could check prototype here instead of just carping */
6678 SV *sv = sv_newmortal();
6679 gv_efullname3(sv, gv, Nullch);
6680 Perl_warner(aTHX_ WARN_PROTOTYPE,
6681 "%s() called too early to check prototype",
6686 o->op_seq = PL_op_seqmax++;
6697 o->op_seq = PL_op_seqmax++;
6698 while (cLOGOP->op_other->op_type == OP_NULL)
6699 cLOGOP->op_other = cLOGOP->op_other->op_next;
6700 peep(cLOGOP->op_other);
6704 o->op_seq = PL_op_seqmax++;
6705 peep(cLOOP->op_redoop);
6706 peep(cLOOP->op_nextop);
6707 peep(cLOOP->op_lastop);
6713 o->op_seq = PL_op_seqmax++;
6714 peep(cPMOP->op_pmreplstart);
6718 o->op_seq = PL_op_seqmax++;
6719 if (ckWARN(WARN_SYNTAX) && o->op_next
6720 && o->op_next->op_type == OP_NEXTSTATE) {
6721 if (o->op_next->op_sibling &&
6722 o->op_next->op_sibling->op_type != OP_EXIT &&
6723 o->op_next->op_sibling->op_type != OP_WARN &&
6724 o->op_next->op_sibling->op_type != OP_DIE) {
6725 line_t oldline = CopLINE(PL_curcop);
6727 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6728 Perl_warner(aTHX_ WARN_EXEC,
6729 "Statement unlikely to be reached");
6730 Perl_warner(aTHX_ WARN_EXEC,
6731 "\t(Maybe you meant system() when you said exec()?)\n");
6732 CopLINE_set(PL_curcop, oldline);
6741 SV **svp, **indsvp, *sv;
6746 o->op_seq = PL_op_seqmax++;
6748 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6751 /* Make the CONST have a shared SV */
6752 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6753 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6754 key = SvPV(sv, keylen);
6757 lexname = newSVpvn_share(key, keylen, 0);
6762 if ((o->op_private & (OPpLVAL_INTRO)))
6765 rop = (UNOP*)((BINOP*)o)->op_first;
6766 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6768 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6769 if (!SvOBJECT(lexname))
6771 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6772 if (!fields || !GvHV(*fields))
6774 key = SvPV(*svp, keylen);
6775 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6777 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6778 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6780 ind = SvIV(*indsvp);
6782 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6783 rop->op_type = OP_RV2AV;
6784 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6785 o->op_type = OP_AELEM;
6786 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6788 if (SvREADONLY(*svp))
6790 SvFLAGS(sv) |= (SvFLAGS(*svp)
6791 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6801 SV **svp, **indsvp, *sv;
6805 SVOP *first_key_op, *key_op;
6807 o->op_seq = PL_op_seqmax++;
6808 if ((o->op_private & (OPpLVAL_INTRO))
6809 /* I bet there's always a pushmark... */
6810 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6811 /* hmmm, no optimization if list contains only one key. */
6813 rop = (UNOP*)((LISTOP*)o)->op_last;
6814 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6816 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6817 if (!SvOBJECT(lexname))
6819 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6820 if (!fields || !GvHV(*fields))
6822 /* Again guessing that the pushmark can be jumped over.... */
6823 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6824 ->op_first->op_sibling;
6825 /* Check that the key list contains only constants. */
6826 for (key_op = first_key_op; key_op;
6827 key_op = (SVOP*)key_op->op_sibling)
6828 if (key_op->op_type != OP_CONST)
6832 rop->op_type = OP_RV2AV;
6833 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6834 o->op_type = OP_ASLICE;
6835 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6836 for (key_op = first_key_op; key_op;
6837 key_op = (SVOP*)key_op->op_sibling) {
6838 svp = cSVOPx_svp(key_op);
6839 key = SvPV(*svp, keylen);
6840 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6842 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6843 "in variable %s of type %s",
6844 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6846 ind = SvIV(*indsvp);
6848 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6850 if (SvREADONLY(*svp))
6852 SvFLAGS(sv) |= (SvFLAGS(*svp)
6853 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6862 if (!(o->op_flags & OPf_WANT)
6863 || (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
6867 o->op_seq = PL_op_seqmax++;
6871 if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) {
6872 o->op_seq = PL_op_seqmax++;
6878 if (last_composite) {
6879 OP *r = last_composite;
6881 while (r->op_sibling)
6884 || (r->op_next->op_type == OP_LIST
6885 && r->op_next->op_next == o))
6887 if (last_composite->op_type == OP_RV2AV)
6888 yyerror("Lvalue subs returning arrays not implemented yet");
6890 yyerror("Lvalue subs returning hashes not implemented yet");
6897 o->op_seq = PL_op_seqmax++;
6907 /* Efficient sub that returns a constant scalar value. */
6909 const_sv_xsub(pTHXo_ CV* cv)
6913 ST(0) = (SV*)XSANY.any_ptr;