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