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 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1142 else if (SvPOK(sv)) {
1143 /* perl4's way of mixing documentation and code
1144 (before the invention of POD) was based on a
1145 trick to mix nroff and perl code. The trick was
1146 built upon these three nroff macros being used in
1147 void context. The pink camel has the details in
1148 the script wrapman near page 319. */
1149 if (strnEQ(SvPVX(sv), "di", 2) ||
1150 strnEQ(SvPVX(sv), "ds", 2) ||
1151 strnEQ(SvPVX(sv), "ig", 2))
1156 null(o); /* don't execute or even remember it */
1160 o->op_type = OP_PREINC; /* pre-increment is faster */
1161 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1165 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1166 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1172 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1177 if (o->op_flags & OPf_STACKED)
1184 if (!(o->op_flags & OPf_KIDS))
1193 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1200 /* all requires must return a boolean value */
1201 o->op_flags &= ~OPf_WANT;
1206 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1207 if (!kPMOP->op_pmreplroot)
1208 deprecate("implicit split to @_");
1212 if (useless && ckWARN(WARN_VOID))
1213 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1218 Perl_listkids(pTHX_ OP *o)
1221 if (o && o->op_flags & OPf_KIDS) {
1222 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1229 Perl_list(pTHX_ OP *o)
1233 /* assumes no premature commitment */
1234 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1235 || o->op_type == OP_RETURN)
1240 if ((o->op_private & OPpTARGET_MY)
1241 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1243 return o; /* As if inside SASSIGN */
1246 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1248 switch (o->op_type) {
1251 list(cBINOPo->op_first);
1256 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1264 if (!(o->op_flags & OPf_KIDS))
1266 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1267 list(cBINOPo->op_first);
1268 return gen_constant_list(o);
1275 kid = cLISTOPo->op_first;
1277 while ((kid = kid->op_sibling)) {
1278 if (kid->op_sibling)
1283 WITH_THR(PL_curcop = &PL_compiling);
1287 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1288 if (kid->op_sibling)
1293 WITH_THR(PL_curcop = &PL_compiling);
1296 /* all requires must return a boolean value */
1297 o->op_flags &= ~OPf_WANT;
1304 Perl_scalarseq(pTHX_ OP *o)
1309 if (o->op_type == OP_LINESEQ ||
1310 o->op_type == OP_SCOPE ||
1311 o->op_type == OP_LEAVE ||
1312 o->op_type == OP_LEAVETRY)
1314 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1315 if (kid->op_sibling) {
1319 PL_curcop = &PL_compiling;
1321 o->op_flags &= ~OPf_PARENS;
1322 if (PL_hints & HINT_BLOCK_SCOPE)
1323 o->op_flags |= OPf_PARENS;
1326 o = newOP(OP_STUB, 0);
1331 S_modkids(pTHX_ OP *o, I32 type)
1334 if (o && o->op_flags & OPf_KIDS) {
1335 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1342 Perl_mod(pTHX_ OP *o, I32 type)
1347 if (!o || PL_error_count)
1350 if ((o->op_private & OPpTARGET_MY)
1351 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1356 switch (o->op_type) {
1361 if (o->op_private & (OPpCONST_BARE) &&
1362 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1363 SV *sv = ((SVOP*)o)->op_sv;
1366 /* Could be a filehandle */
1367 if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1368 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1372 /* OK, it's a sub */
1374 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1376 enter = newUNOP(OP_ENTERSUB,0,
1377 newUNOP(OP_RV2CV, 0,
1378 newGVOP(OP_GV, 0, gv)
1380 enter->op_private |= OPpLVAL_INTRO;
1386 if (!(o->op_private & (OPpCONST_ARYBASE)))
1388 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1389 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1393 SAVEI32(PL_compiling.cop_arybase);
1394 PL_compiling.cop_arybase = 0;
1396 else if (type == OP_REFGEN)
1399 Perl_croak(aTHX_ "That use of $[ is unsupported");
1402 if (o->op_flags & OPf_PARENS)
1406 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1407 !(o->op_flags & OPf_STACKED)) {
1408 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1409 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1410 assert(cUNOPo->op_first->op_type == OP_NULL);
1411 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1414 else { /* lvalue subroutine call */
1415 o->op_private |= OPpLVAL_INTRO;
1416 PL_modcount = RETURN_UNLIMITED_NUMBER;
1417 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1418 /* Backward compatibility mode: */
1419 o->op_private |= OPpENTERSUB_INARGS;
1422 else { /* Compile-time error message: */
1423 OP *kid = cUNOPo->op_first;
1427 if (kid->op_type == OP_PUSHMARK)
1429 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1431 "panic: unexpected lvalue entersub "
1432 "args: type/targ %ld:%ld",
1433 (long)kid->op_type,kid->op_targ);
1434 kid = kLISTOP->op_first;
1436 while (kid->op_sibling)
1437 kid = kid->op_sibling;
1438 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1440 if (kid->op_type == OP_METHOD_NAMED
1441 || kid->op_type == OP_METHOD)
1445 if (kid->op_sibling || kid->op_next != kid) {
1446 yyerror("panic: unexpected optree near method call");
1450 NewOp(1101, newop, 1, UNOP);
1451 newop->op_type = OP_RV2CV;
1452 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1453 newop->op_first = Nullop;
1454 newop->op_next = (OP*)newop;
1455 kid->op_sibling = (OP*)newop;
1456 newop->op_private |= OPpLVAL_INTRO;
1460 if (kid->op_type != OP_RV2CV)
1462 "panic: unexpected lvalue entersub "
1463 "entry via type/targ %ld:%ld",
1464 (long)kid->op_type,kid->op_targ);
1465 kid->op_private |= OPpLVAL_INTRO;
1466 break; /* Postpone until runtime */
1470 kid = kUNOP->op_first;
1471 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL)
1475 "Unexpected constant lvalue entersub "
1476 "entry via type/targ %ld:%ld",
1477 (long)kid->op_type,kid->op_targ);
1478 if (kid->op_type != OP_GV) {
1479 /* Restore RV2CV to check lvalueness */
1481 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1482 okid->op_next = kid->op_next;
1483 kid->op_next = okid;
1486 okid->op_next = Nullop;
1487 okid->op_type = OP_RV2CV;
1489 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1490 okid->op_private |= OPpLVAL_INTRO;
1494 cv = GvCV(kGVOP_gv);
1504 /* grep, foreach, subcalls, refgen */
1505 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1507 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1508 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1510 : (o->op_type == OP_ENTERSUB
1511 ? "non-lvalue subroutine call"
1512 : PL_op_desc[o->op_type])),
1513 type ? PL_op_desc[type] : "local"));
1527 case OP_RIGHT_SHIFT:
1536 if (!(o->op_flags & OPf_STACKED))
1542 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1548 if (!type && cUNOPo->op_first->op_type != OP_GV)
1549 Perl_croak(aTHX_ "Can't localize through a reference");
1550 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1551 PL_modcount = RETURN_UNLIMITED_NUMBER;
1552 return o; /* Treat \(@foo) like ordinary list. */
1556 if (scalar_mod_type(o, type))
1558 ref(cUNOPo->op_first, o->op_type);
1562 if (type == OP_LEAVESUBLV)
1563 o->op_private |= OPpMAYBE_LVSUB;
1569 PL_modcount = RETURN_UNLIMITED_NUMBER;
1572 if (!type && cUNOPo->op_first->op_type != OP_GV)
1573 Perl_croak(aTHX_ "Can't localize through a reference");
1574 ref(cUNOPo->op_first, o->op_type);
1578 PL_hints |= HINT_BLOCK_SCOPE;
1588 PL_modcount = RETURN_UNLIMITED_NUMBER;
1589 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1590 return o; /* Treat \(@foo) like ordinary list. */
1591 if (scalar_mod_type(o, type))
1593 if (type == OP_LEAVESUBLV)
1594 o->op_private |= OPpMAYBE_LVSUB;
1599 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1600 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1605 PL_modcount++; /* XXX ??? */
1607 #endif /* USE_THREADS */
1613 if (type != OP_SASSIGN)
1617 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1622 if (type == OP_LEAVESUBLV)
1623 o->op_private |= OPpMAYBE_LVSUB;
1625 pad_free(o->op_targ);
1626 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1627 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1628 if (o->op_flags & OPf_KIDS)
1629 mod(cBINOPo->op_first->op_sibling, type);
1634 ref(cBINOPo->op_first, o->op_type);
1635 if (type == OP_ENTERSUB &&
1636 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1637 o->op_private |= OPpLVAL_DEFER;
1638 if (type == OP_LEAVESUBLV)
1639 o->op_private |= OPpMAYBE_LVSUB;
1647 if (o->op_flags & OPf_KIDS)
1648 mod(cLISTOPo->op_last, type);
1652 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1654 else if (!(o->op_flags & OPf_KIDS))
1656 if (o->op_targ != OP_LIST) {
1657 mod(cBINOPo->op_first, type);
1662 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1667 if (type != OP_LEAVESUBLV)
1669 break; /* mod()ing was handled by ck_return() */
1671 if (type != OP_LEAVESUBLV)
1672 o->op_flags |= OPf_MOD;
1674 if (type == OP_AASSIGN || type == OP_SASSIGN)
1675 o->op_flags |= OPf_SPECIAL|OPf_REF;
1677 o->op_private |= OPpLVAL_INTRO;
1678 o->op_flags &= ~OPf_SPECIAL;
1679 PL_hints |= HINT_BLOCK_SCOPE;
1681 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1682 && type != OP_LEAVESUBLV)
1683 o->op_flags |= OPf_REF;
1688 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1692 if (o->op_type == OP_RV2GV)
1716 case OP_RIGHT_SHIFT:
1735 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1737 switch (o->op_type) {
1745 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1758 Perl_refkids(pTHX_ OP *o, I32 type)
1761 if (o && o->op_flags & OPf_KIDS) {
1762 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1769 Perl_ref(pTHX_ OP *o, I32 type)
1773 if (!o || PL_error_count)
1776 switch (o->op_type) {
1778 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1779 !(o->op_flags & OPf_STACKED)) {
1780 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1781 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1782 assert(cUNOPo->op_first->op_type == OP_NULL);
1783 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1784 o->op_flags |= OPf_SPECIAL;
1789 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1793 if (type == OP_DEFINED)
1794 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1795 ref(cUNOPo->op_first, o->op_type);
1798 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1799 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1800 : type == OP_RV2HV ? OPpDEREF_HV
1802 o->op_flags |= OPf_MOD;
1807 o->op_flags |= OPf_MOD; /* XXX ??? */
1812 o->op_flags |= OPf_REF;
1815 if (type == OP_DEFINED)
1816 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1817 ref(cUNOPo->op_first, o->op_type);
1822 o->op_flags |= OPf_REF;
1827 if (!(o->op_flags & OPf_KIDS))
1829 ref(cBINOPo->op_first, type);
1833 ref(cBINOPo->op_first, o->op_type);
1834 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1835 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1836 : type == OP_RV2HV ? OPpDEREF_HV
1838 o->op_flags |= OPf_MOD;
1846 if (!(o->op_flags & OPf_KIDS))
1848 ref(cLISTOPo->op_last, type);
1858 S_dup_attrlist(pTHX_ OP *o)
1862 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1863 * where the first kid is OP_PUSHMARK and the remaining ones
1864 * are OP_CONST. We need to push the OP_CONST values.
1866 if (o->op_type == OP_CONST)
1867 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1869 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1870 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1871 if (o->op_type == OP_CONST)
1872 rop = append_elem(OP_LIST, rop,
1873 newSVOP(OP_CONST, o->op_flags,
1874 SvREFCNT_inc(cSVOPo->op_sv)));
1881 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1885 /* fake up C<use attributes $pkg,$rv,@attrs> */
1886 ENTER; /* need to protect against side-effects of 'use' */
1888 if (stash && HvNAME(stash))
1889 stashsv = newSVpv(HvNAME(stash), 0);
1891 stashsv = &PL_sv_no;
1893 #define ATTRSMODULE "attributes"
1895 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1896 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1898 prepend_elem(OP_LIST,
1899 newSVOP(OP_CONST, 0, stashsv),
1900 prepend_elem(OP_LIST,
1901 newSVOP(OP_CONST, 0,
1903 dup_attrlist(attrs))));
1908 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1909 char *attrstr, STRLEN len)
1914 len = strlen(attrstr);
1918 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1920 char *sstr = attrstr;
1921 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1922 attrs = append_elem(OP_LIST, attrs,
1923 newSVOP(OP_CONST, 0,
1924 newSVpvn(sstr, attrstr-sstr)));
1928 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1929 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1930 Nullsv, prepend_elem(OP_LIST,
1931 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1932 prepend_elem(OP_LIST,
1933 newSVOP(OP_CONST, 0,
1939 S_my_kid(pTHX_ OP *o, OP *attrs)
1944 if (!o || PL_error_count)
1948 if (type == OP_LIST) {
1949 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1951 } else if (type == OP_UNDEF) {
1953 } else if (type == OP_RV2SV || /* "our" declaration */
1955 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1957 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1959 PL_in_my_stash = Nullhv;
1960 apply_attrs(GvSTASH(gv),
1961 (type == OP_RV2SV ? GvSV(gv) :
1962 type == OP_RV2AV ? (SV*)GvAV(gv) :
1963 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1966 o->op_private |= OPpOUR_INTRO;
1968 } else if (type != OP_PADSV &&
1971 type != OP_PUSHMARK)
1973 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1974 PL_op_desc[o->op_type],
1975 PL_in_my == KEY_our ? "our" : "my"));
1978 else if (attrs && type != OP_PUSHMARK) {
1984 PL_in_my_stash = Nullhv;
1986 /* check for C<my Dog $spot> when deciding package */
1987 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1988 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1989 stash = SvSTASH(*namesvp);
1991 stash = PL_curstash;
1992 padsv = PAD_SV(o->op_targ);
1993 apply_attrs(stash, padsv, attrs);
1995 o->op_flags |= OPf_MOD;
1996 o->op_private |= OPpLVAL_INTRO;
2001 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2003 if (o->op_flags & OPf_PARENS)
2007 o = my_kid(o, attrs);
2009 PL_in_my_stash = Nullhv;
2014 Perl_my(pTHX_ OP *o)
2016 return my_kid(o, Nullop);
2020 Perl_sawparens(pTHX_ OP *o)
2023 o->op_flags |= OPf_PARENS;
2028 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2032 if (ckWARN(WARN_MISC) &&
2033 (left->op_type == OP_RV2AV ||
2034 left->op_type == OP_RV2HV ||
2035 left->op_type == OP_PADAV ||
2036 left->op_type == OP_PADHV)) {
2037 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2038 right->op_type == OP_TRANS)
2039 ? right->op_type : OP_MATCH];
2040 const char *sample = ((left->op_type == OP_RV2AV ||
2041 left->op_type == OP_PADAV)
2042 ? "@array" : "%hash");
2043 Perl_warner(aTHX_ WARN_MISC,
2044 "Applying %s to %s will act on scalar(%s)",
2045 desc, sample, sample);
2048 if (!(right->op_flags & OPf_STACKED) &&
2049 (right->op_type == OP_MATCH ||
2050 right->op_type == OP_SUBST ||
2051 right->op_type == OP_TRANS)) {
2052 right->op_flags |= OPf_STACKED;
2053 if (right->op_type != OP_MATCH &&
2054 ! (right->op_type == OP_TRANS &&
2055 right->op_private & OPpTRANS_IDENTICAL))
2056 left = mod(left, right->op_type);
2057 if (right->op_type == OP_TRANS)
2058 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2060 o = prepend_elem(right->op_type, scalar(left), right);
2062 return newUNOP(OP_NOT, 0, scalar(o));
2066 return bind_match(type, left,
2067 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2071 Perl_invert(pTHX_ OP *o)
2075 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2076 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2080 Perl_scope(pTHX_ OP *o)
2083 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2084 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2085 o->op_type = OP_LEAVE;
2086 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2089 if (o->op_type == OP_LINESEQ) {
2091 o->op_type = OP_SCOPE;
2092 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2093 kid = ((LISTOP*)o)->op_first;
2094 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2098 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2105 Perl_save_hints(pTHX)
2108 SAVESPTR(GvHV(PL_hintgv));
2109 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2110 SAVEFREESV(GvHV(PL_hintgv));
2114 Perl_block_start(pTHX_ int full)
2116 int retval = PL_savestack_ix;
2118 SAVEI32(PL_comppad_name_floor);
2119 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2121 PL_comppad_name_fill = PL_comppad_name_floor;
2122 if (PL_comppad_name_floor < 0)
2123 PL_comppad_name_floor = 0;
2124 SAVEI32(PL_min_intro_pending);
2125 SAVEI32(PL_max_intro_pending);
2126 PL_min_intro_pending = 0;
2127 SAVEI32(PL_comppad_name_fill);
2128 SAVEI32(PL_padix_floor);
2129 PL_padix_floor = PL_padix;
2130 PL_pad_reset_pending = FALSE;
2132 PL_hints &= ~HINT_BLOCK_SCOPE;
2133 SAVESPTR(PL_compiling.cop_warnings);
2134 if (! specialWARN(PL_compiling.cop_warnings)) {
2135 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2136 SAVEFREESV(PL_compiling.cop_warnings) ;
2138 SAVESPTR(PL_compiling.cop_io);
2139 if (! specialCopIO(PL_compiling.cop_io)) {
2140 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2141 SAVEFREESV(PL_compiling.cop_io) ;
2147 Perl_block_end(pTHX_ I32 floor, OP *seq)
2149 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2150 OP* retval = scalarseq(seq);
2152 PL_pad_reset_pending = FALSE;
2153 PL_compiling.op_private = PL_hints;
2155 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2156 pad_leavemy(PL_comppad_name_fill);
2165 OP *o = newOP(OP_THREADSV, 0);
2166 o->op_targ = find_threadsv("_");
2169 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2170 #endif /* USE_THREADS */
2174 Perl_newPROG(pTHX_ OP *o)
2179 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2180 ((PL_in_eval & EVAL_KEEPERR)
2181 ? OPf_SPECIAL : 0), o);
2182 PL_eval_start = linklist(PL_eval_root);
2183 PL_eval_root->op_private |= OPpREFCOUNTED;
2184 OpREFCNT_set(PL_eval_root, 1);
2185 PL_eval_root->op_next = 0;
2186 peep(PL_eval_start);
2191 PL_main_root = scope(sawparens(scalarvoid(o)));
2192 PL_curcop = &PL_compiling;
2193 PL_main_start = LINKLIST(PL_main_root);
2194 PL_main_root->op_private |= OPpREFCOUNTED;
2195 OpREFCNT_set(PL_main_root, 1);
2196 PL_main_root->op_next = 0;
2197 peep(PL_main_start);
2200 /* Register with debugger */
2202 CV *cv = get_cv("DB::postponed", FALSE);
2206 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2208 call_sv((SV*)cv, G_DISCARD);
2215 Perl_localize(pTHX_ OP *o, I32 lex)
2217 if (o->op_flags & OPf_PARENS)
2220 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2222 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2223 if (*s == ';' || *s == '=')
2224 Perl_warner(aTHX_ WARN_PARENTHESIS,
2225 "Parentheses missing around \"%s\" list",
2226 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2232 o = mod(o, OP_NULL); /* a bit kludgey */
2234 PL_in_my_stash = Nullhv;
2239 Perl_jmaybe(pTHX_ OP *o)
2241 if (o->op_type == OP_LIST) {
2244 o2 = newOP(OP_THREADSV, 0);
2245 o2->op_targ = find_threadsv(";");
2247 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2248 #endif /* USE_THREADS */
2249 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2255 Perl_fold_constants(pTHX_ register OP *o)
2258 I32 type = o->op_type;
2261 if (PL_opargs[type] & OA_RETSCALAR)
2263 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2264 o->op_targ = pad_alloc(type, SVs_PADTMP);
2266 /* integerize op, unless it happens to be C<-foo>.
2267 * XXX should pp_i_negate() do magic string negation instead? */
2268 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2269 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2270 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2272 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2275 if (!(PL_opargs[type] & OA_FOLDCONST))
2280 /* XXX might want a ck_negate() for this */
2281 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2294 if (o->op_private & OPpLOCALE)
2299 goto nope; /* Don't try to run w/ errors */
2301 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2302 if ((curop->op_type != OP_CONST ||
2303 (curop->op_private & OPpCONST_BARE)) &&
2304 curop->op_type != OP_LIST &&
2305 curop->op_type != OP_SCALAR &&
2306 curop->op_type != OP_NULL &&
2307 curop->op_type != OP_PUSHMARK)
2313 curop = LINKLIST(o);
2317 sv = *(PL_stack_sp--);
2318 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2319 pad_swipe(o->op_targ);
2320 else if (SvTEMP(sv)) { /* grab mortal temp? */
2321 (void)SvREFCNT_inc(sv);
2325 if (type == OP_RV2GV)
2326 return newGVOP(OP_GV, 0, (GV*)sv);
2328 /* try to smush double to int, but don't smush -2.0 to -2 */
2329 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2332 #ifdef PERL_PRESERVE_IVUV
2333 /* Only bother to attempt to fold to IV if
2334 most operators will benefit */
2338 return newSVOP(OP_CONST, 0, sv);
2342 if (!(PL_opargs[type] & OA_OTHERINT))
2345 if (!(PL_hints & HINT_INTEGER)) {
2346 if (type == OP_MODULO
2347 || type == OP_DIVIDE
2348 || !(o->op_flags & OPf_KIDS))
2353 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2354 if (curop->op_type == OP_CONST) {
2355 if (SvIOK(((SVOP*)curop)->op_sv))
2359 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2363 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2370 Perl_gen_constant_list(pTHX_ register OP *o)
2373 I32 oldtmps_floor = PL_tmps_floor;
2377 return o; /* Don't attempt to run with errors */
2379 PL_op = curop = LINKLIST(o);
2386 PL_tmps_floor = oldtmps_floor;
2388 o->op_type = OP_RV2AV;
2389 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2390 curop = ((UNOP*)o)->op_first;
2391 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2398 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2400 if (!o || o->op_type != OP_LIST)
2401 o = newLISTOP(OP_LIST, 0, o, Nullop);
2403 o->op_flags &= ~OPf_WANT;
2405 if (!(PL_opargs[type] & OA_MARK))
2406 null(cLISTOPo->op_first);
2409 o->op_ppaddr = PL_ppaddr[type];
2410 o->op_flags |= flags;
2412 o = CHECKOP(type, o);
2413 if (o->op_type != type)
2416 return fold_constants(o);
2419 /* List constructors */
2422 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2430 if (first->op_type != type
2431 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2433 return newLISTOP(type, 0, first, last);
2436 if (first->op_flags & OPf_KIDS)
2437 ((LISTOP*)first)->op_last->op_sibling = last;
2439 first->op_flags |= OPf_KIDS;
2440 ((LISTOP*)first)->op_first = last;
2442 ((LISTOP*)first)->op_last = last;
2447 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2455 if (first->op_type != type)
2456 return prepend_elem(type, (OP*)first, (OP*)last);
2458 if (last->op_type != type)
2459 return append_elem(type, (OP*)first, (OP*)last);
2461 first->op_last->op_sibling = last->op_first;
2462 first->op_last = last->op_last;
2463 first->op_flags |= (last->op_flags & OPf_KIDS);
2465 #ifdef PL_OP_SLAB_ALLOC
2473 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2481 if (last->op_type == type) {
2482 if (type == OP_LIST) { /* already a PUSHMARK there */
2483 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2484 ((LISTOP*)last)->op_first->op_sibling = first;
2485 if (!(first->op_flags & OPf_PARENS))
2486 last->op_flags &= ~OPf_PARENS;
2489 if (!(last->op_flags & OPf_KIDS)) {
2490 ((LISTOP*)last)->op_last = first;
2491 last->op_flags |= OPf_KIDS;
2493 first->op_sibling = ((LISTOP*)last)->op_first;
2494 ((LISTOP*)last)->op_first = first;
2496 last->op_flags |= OPf_KIDS;
2500 return newLISTOP(type, 0, first, last);
2506 Perl_newNULLLIST(pTHX)
2508 return newOP(OP_STUB, 0);
2512 Perl_force_list(pTHX_ OP *o)
2514 if (!o || o->op_type != OP_LIST)
2515 o = newLISTOP(OP_LIST, 0, o, Nullop);
2521 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2525 NewOp(1101, listop, 1, LISTOP);
2527 listop->op_type = type;
2528 listop->op_ppaddr = PL_ppaddr[type];
2531 listop->op_flags = flags;
2535 else if (!first && last)
2538 first->op_sibling = last;
2539 listop->op_first = first;
2540 listop->op_last = last;
2541 if (type == OP_LIST) {
2543 pushop = newOP(OP_PUSHMARK, 0);
2544 pushop->op_sibling = first;
2545 listop->op_first = pushop;
2546 listop->op_flags |= OPf_KIDS;
2548 listop->op_last = pushop;
2555 Perl_newOP(pTHX_ I32 type, I32 flags)
2558 NewOp(1101, o, 1, OP);
2560 o->op_ppaddr = PL_ppaddr[type];
2561 o->op_flags = flags;
2564 o->op_private = 0 + (flags >> 8);
2565 if (PL_opargs[type] & OA_RETSCALAR)
2567 if (PL_opargs[type] & OA_TARGET)
2568 o->op_targ = pad_alloc(type, SVs_PADTMP);
2569 return CHECKOP(type, o);
2573 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2578 first = newOP(OP_STUB, 0);
2579 if (PL_opargs[type] & OA_MARK)
2580 first = force_list(first);
2582 NewOp(1101, unop, 1, UNOP);
2583 unop->op_type = type;
2584 unop->op_ppaddr = PL_ppaddr[type];
2585 unop->op_first = first;
2586 unop->op_flags = flags | OPf_KIDS;
2587 unop->op_private = 1 | (flags >> 8);
2588 unop = (UNOP*) CHECKOP(type, unop);
2592 return fold_constants((OP *) unop);
2596 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2599 NewOp(1101, binop, 1, BINOP);
2602 first = newOP(OP_NULL, 0);
2604 binop->op_type = type;
2605 binop->op_ppaddr = PL_ppaddr[type];
2606 binop->op_first = first;
2607 binop->op_flags = flags | OPf_KIDS;
2610 binop->op_private = 1 | (flags >> 8);
2613 binop->op_private = 2 | (flags >> 8);
2614 first->op_sibling = last;
2617 binop = (BINOP*)CHECKOP(type, binop);
2618 if (binop->op_next || binop->op_type != type)
2621 binop->op_last = binop->op_first->op_sibling;
2623 return fold_constants((OP *)binop);
2627 uvcompare(const void *a, const void *b)
2629 if (*((UV *)a) < (*(UV *)b))
2631 if (*((UV *)a) > (*(UV *)b))
2633 if (*((UV *)a+1) < (*(UV *)b+1))
2635 if (*((UV *)a+1) > (*(UV *)b+1))
2641 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2643 SV *tstr = ((SVOP*)expr)->op_sv;
2644 SV *rstr = ((SVOP*)repl)->op_sv;
2647 U8 *t = (U8*)SvPV(tstr, tlen);
2648 U8 *r = (U8*)SvPV(rstr, rlen);
2655 register short *tbl;
2657 complement = o->op_private & OPpTRANS_COMPLEMENT;
2658 del = o->op_private & OPpTRANS_DELETE;
2659 squash = o->op_private & OPpTRANS_SQUASH;
2662 o->op_private |= OPpTRANS_FROM_UTF;
2665 o->op_private |= OPpTRANS_TO_UTF;
2667 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2668 SV* listsv = newSVpvn("# comment\n",10);
2670 U8* tend = t + tlen;
2671 U8* rend = r + rlen;
2685 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2686 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2692 tsave = t = bytes_to_utf8(t, &len);
2695 if (!to_utf && rlen) {
2697 rsave = r = bytes_to_utf8(r, &len);
2701 /* There are several snags with this code on EBCDIC:
2702 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2703 2. scan_const() in toke.c has encoded chars in native encoding which makes
2704 ranges at least in EBCDIC 0..255 range the bottom odd.
2708 U8 tmpbuf[UTF8_MAXLEN+1];
2711 New(1109, cp, 2*tlen, UV);
2713 transv = newSVpvn("",0);
2715 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2717 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2719 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2723 cp[2*i+1] = cp[2*i];
2727 qsort(cp, i, 2*sizeof(UV), uvcompare);
2728 for (j = 0; j < i; j++) {
2730 diff = val - nextmin;
2732 t = uvuni_to_utf8(tmpbuf,nextmin);
2733 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2735 U8 range_mark = UTF_TO_NATIVE(0xff);
2736 t = uvuni_to_utf8(tmpbuf, val - 1);
2737 sv_catpvn(transv, (char *)&range_mark, 1);
2738 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2745 t = uvuni_to_utf8(tmpbuf,nextmin);
2746 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2748 U8 range_mark = UTF_TO_NATIVE(0xff);
2749 sv_catpvn(transv, (char *)&range_mark, 1);
2751 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2752 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2753 t = (U8*)SvPVX(transv);
2754 tlen = SvCUR(transv);
2758 else if (!rlen && !del) {
2759 r = t; rlen = tlen; rend = tend;
2762 if ((!rlen && !del) || t == r ||
2763 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2765 o->op_private |= OPpTRANS_IDENTICAL;
2769 while (t < tend || tfirst <= tlast) {
2770 /* see if we need more "t" chars */
2771 if (tfirst > tlast) {
2772 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2774 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2776 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2783 /* now see if we need more "r" chars */
2784 if (rfirst > rlast) {
2786 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2788 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2790 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2799 rfirst = rlast = 0xffffffff;
2803 /* now see which range will peter our first, if either. */
2804 tdiff = tlast - tfirst;
2805 rdiff = rlast - rfirst;
2812 if (rfirst == 0xffffffff) {
2813 diff = tdiff; /* oops, pretend rdiff is infinite */
2815 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2816 (long)tfirst, (long)tlast);
2818 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2822 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2823 (long)tfirst, (long)(tfirst + diff),
2826 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2827 (long)tfirst, (long)rfirst);
2829 if (rfirst + diff > max)
2830 max = rfirst + diff;
2832 grows = (tfirst < rfirst &&
2833 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2845 else if (max > 0xff)
2850 Safefree(cPVOPo->op_pv);
2851 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2852 SvREFCNT_dec(listsv);
2854 SvREFCNT_dec(transv);
2856 if (!del && havefinal && rlen)
2857 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2858 newSVuv((UV)final), 0);
2861 o->op_private |= OPpTRANS_GROWS;
2873 tbl = (short*)cPVOPo->op_pv;
2875 Zero(tbl, 256, short);
2876 for (i = 0; i < tlen; i++)
2878 for (i = 0, j = 0; i < 256; i++) {
2889 if (i < 128 && r[j] >= 128)
2899 o->op_private |= OPpTRANS_IDENTICAL;
2904 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2905 tbl[0x100] = rlen - j;
2906 for (i=0; i < rlen - j; i++)
2907 tbl[0x101+i] = r[j+i];
2911 if (!rlen && !del) {
2914 o->op_private |= OPpTRANS_IDENTICAL;
2916 for (i = 0; i < 256; i++)
2918 for (i = 0, j = 0; i < tlen; i++,j++) {
2921 if (tbl[t[i]] == -1)
2927 if (tbl[t[i]] == -1) {
2928 if (t[i] < 128 && r[j] >= 128)
2935 o->op_private |= OPpTRANS_GROWS;
2943 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2947 NewOp(1101, pmop, 1, PMOP);
2948 pmop->op_type = type;
2949 pmop->op_ppaddr = PL_ppaddr[type];
2950 pmop->op_flags = flags;
2951 pmop->op_private = 0 | (flags >> 8);
2953 if (PL_hints & HINT_RE_TAINT)
2954 pmop->op_pmpermflags |= PMf_RETAINT;
2955 if (PL_hints & HINT_LOCALE)
2956 pmop->op_pmpermflags |= PMf_LOCALE;
2957 pmop->op_pmflags = pmop->op_pmpermflags;
2959 /* link into pm list */
2960 if (type != OP_TRANS && PL_curstash) {
2961 pmop->op_pmnext = HvPMROOT(PL_curstash);
2962 HvPMROOT(PL_curstash) = pmop;
2963 PmopSTASH_set(pmop,PL_curstash);
2970 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2974 I32 repl_has_vars = 0;
2976 if (o->op_type == OP_TRANS)
2977 return pmtrans(o, expr, repl);
2979 PL_hints |= HINT_BLOCK_SCOPE;
2982 if (expr->op_type == OP_CONST) {
2984 SV *pat = ((SVOP*)expr)->op_sv;
2985 char *p = SvPV(pat, plen);
2986 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2987 sv_setpvn(pat, "\\s+", 3);
2988 p = SvPV(pat, plen);
2989 pm->op_pmflags |= PMf_SKIPWHITE;
2991 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2992 pm->op_pmdynflags |= PMdf_UTF8;
2993 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2994 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2995 pm->op_pmflags |= PMf_WHITE;
2999 if (PL_hints & HINT_UTF8)
3000 pm->op_pmdynflags |= PMdf_UTF8;
3001 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3002 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3004 : OP_REGCMAYBE),0,expr);
3006 NewOp(1101, rcop, 1, LOGOP);
3007 rcop->op_type = OP_REGCOMP;
3008 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3009 rcop->op_first = scalar(expr);
3010 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3011 ? (OPf_SPECIAL | OPf_KIDS)
3013 rcop->op_private = 1;
3016 /* establish postfix order */
3017 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3019 rcop->op_next = expr;
3020 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3023 rcop->op_next = LINKLIST(expr);
3024 expr->op_next = (OP*)rcop;
3027 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3032 if (pm->op_pmflags & PMf_EVAL) {
3034 if (CopLINE(PL_curcop) < PL_multi_end)
3035 CopLINE_set(PL_curcop, PL_multi_end);
3038 else if (repl->op_type == OP_THREADSV
3039 && strchr("&`'123456789+",
3040 PL_threadsv_names[repl->op_targ]))
3044 #endif /* USE_THREADS */
3045 else if (repl->op_type == OP_CONST)
3049 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3050 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3052 if (curop->op_type == OP_THREADSV) {
3054 if (strchr("&`'123456789+", curop->op_private))
3058 if (curop->op_type == OP_GV) {
3059 GV *gv = cGVOPx_gv(curop);
3061 if (strchr("&`'123456789+", *GvENAME(gv)))
3064 #endif /* USE_THREADS */
3065 else if (curop->op_type == OP_RV2CV)
3067 else if (curop->op_type == OP_RV2SV ||
3068 curop->op_type == OP_RV2AV ||
3069 curop->op_type == OP_RV2HV ||
3070 curop->op_type == OP_RV2GV) {
3071 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3074 else if (curop->op_type == OP_PADSV ||
3075 curop->op_type == OP_PADAV ||
3076 curop->op_type == OP_PADHV ||
3077 curop->op_type == OP_PADANY) {
3080 else if (curop->op_type == OP_PUSHRE)
3081 ; /* Okay here, dangerous in newASSIGNOP */
3090 && (!pm->op_pmregexp
3091 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3092 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3093 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3094 prepend_elem(o->op_type, scalar(repl), o);
3097 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3098 pm->op_pmflags |= PMf_MAYBE_CONST;
3099 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3101 NewOp(1101, rcop, 1, LOGOP);
3102 rcop->op_type = OP_SUBSTCONT;
3103 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3104 rcop->op_first = scalar(repl);
3105 rcop->op_flags |= OPf_KIDS;
3106 rcop->op_private = 1;
3109 /* establish postfix order */
3110 rcop->op_next = LINKLIST(repl);
3111 repl->op_next = (OP*)rcop;
3113 pm->op_pmreplroot = scalar((OP*)rcop);
3114 pm->op_pmreplstart = LINKLIST(rcop);
3123 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3126 NewOp(1101, svop, 1, SVOP);
3127 svop->op_type = type;
3128 svop->op_ppaddr = PL_ppaddr[type];
3130 svop->op_next = (OP*)svop;
3131 svop->op_flags = flags;
3132 if (PL_opargs[type] & OA_RETSCALAR)
3134 if (PL_opargs[type] & OA_TARGET)
3135 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3136 return CHECKOP(type, svop);
3140 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3143 NewOp(1101, padop, 1, PADOP);
3144 padop->op_type = type;
3145 padop->op_ppaddr = PL_ppaddr[type];
3146 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3147 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3148 PL_curpad[padop->op_padix] = sv;
3150 padop->op_next = (OP*)padop;
3151 padop->op_flags = flags;
3152 if (PL_opargs[type] & OA_RETSCALAR)
3154 if (PL_opargs[type] & OA_TARGET)
3155 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3156 return CHECKOP(type, padop);
3160 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3164 return newPADOP(type, flags, SvREFCNT_inc(gv));
3166 return newSVOP(type, flags, SvREFCNT_inc(gv));
3171 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3174 NewOp(1101, pvop, 1, PVOP);
3175 pvop->op_type = type;
3176 pvop->op_ppaddr = PL_ppaddr[type];
3178 pvop->op_next = (OP*)pvop;
3179 pvop->op_flags = flags;
3180 if (PL_opargs[type] & OA_RETSCALAR)
3182 if (PL_opargs[type] & OA_TARGET)
3183 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3184 return CHECKOP(type, pvop);
3188 Perl_package(pTHX_ OP *o)
3192 save_hptr(&PL_curstash);
3193 save_item(PL_curstname);
3198 name = SvPV(sv, len);
3199 PL_curstash = gv_stashpvn(name,len,TRUE);
3200 sv_setpvn(PL_curstname, name, len);
3204 sv_setpv(PL_curstname,"<none>");
3205 PL_curstash = Nullhv;
3207 PL_hints |= HINT_BLOCK_SCOPE;
3208 PL_copline = NOLINE;
3213 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3221 if (id->op_type != OP_CONST)
3222 Perl_croak(aTHX_ "Module name must be constant");
3226 if (version != Nullop) {
3227 SV *vesv = ((SVOP*)version)->op_sv;
3229 if (arg == Nullop && !SvNIOKp(vesv)) {
3236 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3237 Perl_croak(aTHX_ "Version number must be constant number");
3239 /* Make copy of id so we don't free it twice */
3240 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3242 /* Fake up a method call to VERSION */
3243 meth = newSVpvn("VERSION",7);
3244 sv_upgrade(meth, SVt_PVIV);
3245 (void)SvIOK_on(meth);
3246 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3247 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3248 append_elem(OP_LIST,
3249 prepend_elem(OP_LIST, pack, list(version)),
3250 newSVOP(OP_METHOD_NAMED, 0, meth)));
3254 /* Fake up an import/unimport */
3255 if (arg && arg->op_type == OP_STUB)
3256 imop = arg; /* no import on explicit () */
3257 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3258 imop = Nullop; /* use 5.0; */
3263 /* Make copy of id so we don't free it twice */
3264 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3266 /* Fake up a method call to import/unimport */
3267 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3268 sv_upgrade(meth, SVt_PVIV);
3269 (void)SvIOK_on(meth);
3270 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3271 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3272 append_elem(OP_LIST,
3273 prepend_elem(OP_LIST, pack, list(arg)),
3274 newSVOP(OP_METHOD_NAMED, 0, meth)));
3277 /* Fake up a require, handle override, if any */
3278 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3279 if (!(gv && GvIMPORTED_CV(gv)))
3280 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3282 if (gv && GvIMPORTED_CV(gv)) {
3283 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3284 append_elem(OP_LIST, id,
3285 scalar(newUNOP(OP_RV2CV, 0,
3290 rqop = newUNOP(OP_REQUIRE, 0, id);
3293 /* Fake up the BEGIN {}, which does its thing immediately. */
3295 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3298 append_elem(OP_LINESEQ,
3299 append_elem(OP_LINESEQ,
3300 newSTATEOP(0, Nullch, rqop),
3301 newSTATEOP(0, Nullch, veop)),
3302 newSTATEOP(0, Nullch, imop) ));
3304 PL_hints |= HINT_BLOCK_SCOPE;
3305 PL_copline = NOLINE;
3310 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3313 va_start(args, ver);
3314 vload_module(flags, name, ver, &args);
3318 #ifdef PERL_IMPLICIT_CONTEXT
3320 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3324 va_start(args, ver);
3325 vload_module(flags, name, ver, &args);
3331 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3333 OP *modname, *veop, *imop;
3335 modname = newSVOP(OP_CONST, 0, name);
3336 modname->op_private |= OPpCONST_BARE;
3338 veop = newSVOP(OP_CONST, 0, ver);
3342 if (flags & PERL_LOADMOD_NOIMPORT) {
3343 imop = sawparens(newNULLLIST());
3345 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3346 imop = va_arg(*args, OP*);
3351 sv = va_arg(*args, SV*);
3353 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3354 sv = va_arg(*args, SV*);
3358 line_t ocopline = PL_copline;
3359 int oexpect = PL_expect;
3361 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3362 veop, modname, imop);
3363 PL_expect = oexpect;
3364 PL_copline = ocopline;
3369 Perl_dofile(pTHX_ OP *term)
3374 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3375 if (!(gv && GvIMPORTED_CV(gv)))
3376 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3378 if (gv && GvIMPORTED_CV(gv)) {
3379 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3380 append_elem(OP_LIST, term,
3381 scalar(newUNOP(OP_RV2CV, 0,
3386 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3392 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3394 return newBINOP(OP_LSLICE, flags,
3395 list(force_list(subscript)),
3396 list(force_list(listval)) );
3400 S_list_assignment(pTHX_ register OP *o)
3405 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3406 o = cUNOPo->op_first;
3408 if (o->op_type == OP_COND_EXPR) {
3409 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3410 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3415 yyerror("Assignment to both a list and a scalar");
3419 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3420 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3421 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3424 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3427 if (o->op_type == OP_RV2SV)
3434 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3439 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3440 return newLOGOP(optype, 0,
3441 mod(scalar(left), optype),
3442 newUNOP(OP_SASSIGN, 0, scalar(right)));
3445 return newBINOP(optype, OPf_STACKED,
3446 mod(scalar(left), optype), scalar(right));
3450 if (list_assignment(left)) {
3454 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3455 left = mod(left, OP_AASSIGN);
3463 curop = list(force_list(left));
3464 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3465 o->op_private = 0 | (flags >> 8);
3466 for (curop = ((LISTOP*)curop)->op_first;
3467 curop; curop = curop->op_sibling)
3469 if (curop->op_type == OP_RV2HV &&
3470 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3471 o->op_private |= OPpASSIGN_HASH;
3475 if (!(left->op_private & OPpLVAL_INTRO)) {
3478 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3479 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3480 if (curop->op_type == OP_GV) {
3481 GV *gv = cGVOPx_gv(curop);
3482 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3484 SvCUR(gv) = PL_generation;
3486 else if (curop->op_type == OP_PADSV ||
3487 curop->op_type == OP_PADAV ||
3488 curop->op_type == OP_PADHV ||
3489 curop->op_type == OP_PADANY) {
3490 SV **svp = AvARRAY(PL_comppad_name);
3491 SV *sv = svp[curop->op_targ];
3492 if (SvCUR(sv) == PL_generation)
3494 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3496 else if (curop->op_type == OP_RV2CV)
3498 else if (curop->op_type == OP_RV2SV ||
3499 curop->op_type == OP_RV2AV ||
3500 curop->op_type == OP_RV2HV ||
3501 curop->op_type == OP_RV2GV) {
3502 if (lastop->op_type != OP_GV) /* funny deref? */
3505 else if (curop->op_type == OP_PUSHRE) {
3506 if (((PMOP*)curop)->op_pmreplroot) {
3508 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3510 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3512 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3514 SvCUR(gv) = PL_generation;
3523 o->op_private |= OPpASSIGN_COMMON;
3525 if (right && right->op_type == OP_SPLIT) {
3527 if ((tmpop = ((LISTOP*)right)->op_first) &&
3528 tmpop->op_type == OP_PUSHRE)
3530 PMOP *pm = (PMOP*)tmpop;
3531 if (left->op_type == OP_RV2AV &&
3532 !(left->op_private & OPpLVAL_INTRO) &&
3533 !(o->op_private & OPpASSIGN_COMMON) )
3535 tmpop = ((UNOP*)left)->op_first;
3536 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3538 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3539 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3541 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3542 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3544 pm->op_pmflags |= PMf_ONCE;
3545 tmpop = cUNOPo->op_first; /* to list (nulled) */
3546 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3547 tmpop->op_sibling = Nullop; /* don't free split */
3548 right->op_next = tmpop->op_next; /* fix starting loc */
3549 op_free(o); /* blow off assign */
3550 right->op_flags &= ~OPf_WANT;
3551 /* "I don't know and I don't care." */
3556 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3557 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3559 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3561 sv_setiv(sv, PL_modcount+1);
3569 right = newOP(OP_UNDEF, 0);
3570 if (right->op_type == OP_READLINE) {
3571 right->op_flags |= OPf_STACKED;
3572 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3575 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3576 o = newBINOP(OP_SASSIGN, flags,
3577 scalar(right), mod(scalar(left), OP_SASSIGN) );
3589 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3591 U32 seq = intro_my();
3594 NewOp(1101, cop, 1, COP);
3595 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3596 cop->op_type = OP_DBSTATE;
3597 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3600 cop->op_type = OP_NEXTSTATE;
3601 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3603 cop->op_flags = flags;
3604 cop->op_private = (PL_hints & HINT_BYTE);
3606 cop->op_private |= NATIVE_HINTS;
3608 PL_compiling.op_private = cop->op_private;
3609 cop->op_next = (OP*)cop;
3612 cop->cop_label = label;
3613 PL_hints |= HINT_BLOCK_SCOPE;
3616 cop->cop_arybase = PL_curcop->cop_arybase;
3617 if (specialWARN(PL_curcop->cop_warnings))
3618 cop->cop_warnings = PL_curcop->cop_warnings ;
3620 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3621 if (specialCopIO(PL_curcop->cop_io))
3622 cop->cop_io = PL_curcop->cop_io;
3624 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3627 if (PL_copline == NOLINE)
3628 CopLINE_set(cop, CopLINE(PL_curcop));
3630 CopLINE_set(cop, PL_copline);
3631 PL_copline = NOLINE;
3634 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3636 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3638 CopSTASH_set(cop, PL_curstash);
3640 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3641 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3642 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3643 (void)SvIOK_on(*svp);
3644 SvIVX(*svp) = PTR2IV(cop);
3648 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3651 /* "Introduce" my variables to visible status. */
3659 if (! PL_min_intro_pending)
3660 return PL_cop_seqmax;
3662 svp = AvARRAY(PL_comppad_name);
3663 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3664 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3665 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3666 SvNVX(sv) = (NV)PL_cop_seqmax;
3669 PL_min_intro_pending = 0;
3670 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3671 return PL_cop_seqmax++;
3675 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3677 return new_logop(type, flags, &first, &other);
3681 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3685 OP *first = *firstp;
3686 OP *other = *otherp;
3688 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3689 return newBINOP(type, flags, scalar(first), scalar(other));
3691 scalarboolean(first);
3692 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3693 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3694 if (type == OP_AND || type == OP_OR) {
3700 first = *firstp = cUNOPo->op_first;
3702 first->op_next = o->op_next;
3703 cUNOPo->op_first = Nullop;
3707 if (first->op_type == OP_CONST) {
3708 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3709 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3710 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3721 else if (first->op_type == OP_WANTARRAY) {
3727 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3728 OP *k1 = ((UNOP*)first)->op_first;
3729 OP *k2 = k1->op_sibling;
3731 switch (first->op_type)
3734 if (k2 && k2->op_type == OP_READLINE
3735 && (k2->op_flags & OPf_STACKED)
3736 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3738 warnop = k2->op_type;
3743 if (k1->op_type == OP_READDIR
3744 || k1->op_type == OP_GLOB
3745 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3746 || k1->op_type == OP_EACH)
3748 warnop = ((k1->op_type == OP_NULL)
3749 ? k1->op_targ : k1->op_type);
3754 line_t oldline = CopLINE(PL_curcop);
3755 CopLINE_set(PL_curcop, PL_copline);
3756 Perl_warner(aTHX_ WARN_MISC,
3757 "Value of %s%s can be \"0\"; test with defined()",
3759 ((warnop == OP_READLINE || warnop == OP_GLOB)
3760 ? " construct" : "() operator"));
3761 CopLINE_set(PL_curcop, oldline);
3768 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3769 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3771 NewOp(1101, logop, 1, LOGOP);
3773 logop->op_type = type;
3774 logop->op_ppaddr = PL_ppaddr[type];
3775 logop->op_first = first;
3776 logop->op_flags = flags | OPf_KIDS;
3777 logop->op_other = LINKLIST(other);
3778 logop->op_private = 1 | (flags >> 8);
3780 /* establish postfix order */
3781 logop->op_next = LINKLIST(first);
3782 first->op_next = (OP*)logop;
3783 first->op_sibling = other;
3785 o = newUNOP(OP_NULL, 0, (OP*)logop);
3792 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3799 return newLOGOP(OP_AND, 0, first, trueop);
3801 return newLOGOP(OP_OR, 0, first, falseop);
3803 scalarboolean(first);
3804 if (first->op_type == OP_CONST) {
3805 if (SvTRUE(((SVOP*)first)->op_sv)) {
3816 else if (first->op_type == OP_WANTARRAY) {
3820 NewOp(1101, logop, 1, LOGOP);
3821 logop->op_type = OP_COND_EXPR;
3822 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3823 logop->op_first = first;
3824 logop->op_flags = flags | OPf_KIDS;
3825 logop->op_private = 1 | (flags >> 8);
3826 logop->op_other = LINKLIST(trueop);
3827 logop->op_next = LINKLIST(falseop);
3830 /* establish postfix order */
3831 start = LINKLIST(first);
3832 first->op_next = (OP*)logop;
3834 first->op_sibling = trueop;
3835 trueop->op_sibling = falseop;
3836 o = newUNOP(OP_NULL, 0, (OP*)logop);
3838 trueop->op_next = falseop->op_next = o;
3845 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3853 NewOp(1101, range, 1, LOGOP);
3855 range->op_type = OP_RANGE;
3856 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3857 range->op_first = left;
3858 range->op_flags = OPf_KIDS;
3859 leftstart = LINKLIST(left);
3860 range->op_other = LINKLIST(right);
3861 range->op_private = 1 | (flags >> 8);
3863 left->op_sibling = right;
3865 range->op_next = (OP*)range;
3866 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3867 flop = newUNOP(OP_FLOP, 0, flip);
3868 o = newUNOP(OP_NULL, 0, flop);
3870 range->op_next = leftstart;
3872 left->op_next = flip;
3873 right->op_next = flop;
3875 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3876 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3877 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3878 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3880 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3881 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3884 if (!flip->op_private || !flop->op_private)
3885 linklist(o); /* blow off optimizer unless constant */
3891 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3895 int once = block && block->op_flags & OPf_SPECIAL &&
3896 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3899 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3900 return block; /* do {} while 0 does once */
3901 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3902 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3903 expr = newUNOP(OP_DEFINED, 0,
3904 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3905 } else if (expr->op_flags & OPf_KIDS) {
3906 OP *k1 = ((UNOP*)expr)->op_first;
3907 OP *k2 = (k1) ? k1->op_sibling : NULL;
3908 switch (expr->op_type) {
3910 if (k2 && k2->op_type == OP_READLINE
3911 && (k2->op_flags & OPf_STACKED)
3912 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3913 expr = newUNOP(OP_DEFINED, 0, expr);
3917 if (k1->op_type == OP_READDIR
3918 || k1->op_type == OP_GLOB
3919 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3920 || k1->op_type == OP_EACH)
3921 expr = newUNOP(OP_DEFINED, 0, expr);
3927 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3928 o = new_logop(OP_AND, 0, &expr, &listop);
3931 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3933 if (once && o != listop)
3934 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3937 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3939 o->op_flags |= flags;
3941 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3946 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3955 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3956 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3957 expr = newUNOP(OP_DEFINED, 0,
3958 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3959 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3960 OP *k1 = ((UNOP*)expr)->op_first;
3961 OP *k2 = (k1) ? k1->op_sibling : NULL;
3962 switch (expr->op_type) {
3964 if (k2 && k2->op_type == OP_READLINE
3965 && (k2->op_flags & OPf_STACKED)
3966 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3967 expr = newUNOP(OP_DEFINED, 0, expr);
3971 if (k1->op_type == OP_READDIR
3972 || k1->op_type == OP_GLOB
3973 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3974 || k1->op_type == OP_EACH)
3975 expr = newUNOP(OP_DEFINED, 0, expr);
3981 block = newOP(OP_NULL, 0);
3983 block = scope(block);
3987 next = LINKLIST(cont);
3990 OP *unstack = newOP(OP_UNSTACK, 0);
3993 cont = append_elem(OP_LINESEQ, cont, unstack);
3994 if ((line_t)whileline != NOLINE) {
3995 PL_copline = whileline;
3996 cont = append_elem(OP_LINESEQ, cont,
3997 newSTATEOP(0, Nullch, Nullop));
4001 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4002 redo = LINKLIST(listop);
4005 PL_copline = whileline;
4007 o = new_logop(OP_AND, 0, &expr, &listop);
4008 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4009 op_free(expr); /* oops, it's a while (0) */
4011 return Nullop; /* listop already freed by new_logop */
4014 ((LISTOP*)listop)->op_last->op_next = condop =
4015 (o == listop ? redo : LINKLIST(o));
4021 NewOp(1101,loop,1,LOOP);
4022 loop->op_type = OP_ENTERLOOP;
4023 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4024 loop->op_private = 0;
4025 loop->op_next = (OP*)loop;
4028 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4030 loop->op_redoop = redo;
4031 loop->op_lastop = o;
4032 o->op_private |= loopflags;
4035 loop->op_nextop = next;
4037 loop->op_nextop = o;
4039 o->op_flags |= flags;
4040 o->op_private |= (flags >> 8);
4045 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4053 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4054 sv->op_type = OP_RV2GV;
4055 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4057 else if (sv->op_type == OP_PADSV) { /* private variable */
4058 padoff = sv->op_targ;
4063 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4064 padoff = sv->op_targ;
4066 iterflags |= OPf_SPECIAL;
4071 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4075 padoff = find_threadsv("_");
4076 iterflags |= OPf_SPECIAL;
4078 sv = newGVOP(OP_GV, 0, PL_defgv);
4081 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4082 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4083 iterflags |= OPf_STACKED;
4085 else if (expr->op_type == OP_NULL &&
4086 (expr->op_flags & OPf_KIDS) &&
4087 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4089 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4090 * set the STACKED flag to indicate that these values are to be
4091 * treated as min/max values by 'pp_iterinit'.
4093 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4094 LOGOP* range = (LOGOP*) flip->op_first;
4095 OP* left = range->op_first;
4096 OP* right = left->op_sibling;
4099 range->op_flags &= ~OPf_KIDS;
4100 range->op_first = Nullop;
4102 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4103 listop->op_first->op_next = range->op_next;
4104 left->op_next = range->op_other;
4105 right->op_next = (OP*)listop;
4106 listop->op_next = listop->op_first;
4109 expr = (OP*)(listop);
4111 iterflags |= OPf_STACKED;
4114 expr = mod(force_list(expr), OP_GREPSTART);
4118 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4119 append_elem(OP_LIST, expr, scalar(sv))));
4120 assert(!loop->op_next);
4121 #ifdef PL_OP_SLAB_ALLOC
4124 NewOp(1234,tmp,1,LOOP);
4125 Copy(loop,tmp,1,LOOP);
4129 Renew(loop, 1, LOOP);
4131 loop->op_targ = padoff;
4132 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4133 PL_copline = forline;
4134 return newSTATEOP(0, label, wop);
4138 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4143 if (type != OP_GOTO || label->op_type == OP_CONST) {
4144 /* "last()" means "last" */
4145 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4146 o = newOP(type, OPf_SPECIAL);
4148 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4149 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4155 if (label->op_type == OP_ENTERSUB)
4156 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4157 o = newUNOP(type, OPf_STACKED, label);
4159 PL_hints |= HINT_BLOCK_SCOPE;
4164 Perl_cv_undef(pTHX_ CV *cv)
4168 MUTEX_DESTROY(CvMUTEXP(cv));
4169 Safefree(CvMUTEXP(cv));
4172 #endif /* USE_THREADS */
4174 if (!CvXSUB(cv) && CvROOT(cv)) {
4176 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4177 Perl_croak(aTHX_ "Can't undef active subroutine");
4180 Perl_croak(aTHX_ "Can't undef active subroutine");
4181 #endif /* USE_THREADS */
4184 SAVEVPTR(PL_curpad);
4187 op_free(CvROOT(cv));
4188 CvROOT(cv) = Nullop;
4191 SvPOK_off((SV*)cv); /* forget prototype */
4193 /* Since closure prototypes have the same lifetime as the containing
4194 * CV, they don't hold a refcount on the outside CV. This avoids
4195 * the refcount loop between the outer CV (which keeps a refcount to
4196 * the closure prototype in the pad entry for pp_anoncode()) and the
4197 * closure prototype, and the ensuing memory leak. --GSAR */
4198 if (!CvANON(cv) || CvCLONED(cv))
4199 SvREFCNT_dec(CvOUTSIDE(cv));
4200 CvOUTSIDE(cv) = Nullcv;
4202 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4205 if (CvPADLIST(cv)) {
4206 /* may be during global destruction */
4207 if (SvREFCNT(CvPADLIST(cv))) {
4208 I32 i = AvFILLp(CvPADLIST(cv));
4210 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4211 SV* sv = svp ? *svp : Nullsv;
4214 if (sv == (SV*)PL_comppad_name)
4215 PL_comppad_name = Nullav;
4216 else if (sv == (SV*)PL_comppad) {
4217 PL_comppad = Nullav;
4218 PL_curpad = Null(SV**);
4222 SvREFCNT_dec((SV*)CvPADLIST(cv));
4224 CvPADLIST(cv) = Nullav;
4229 #ifdef DEBUG_CLOSURES
4231 S_cv_dump(pTHX_ CV *cv)
4234 CV *outside = CvOUTSIDE(cv);
4235 AV* padlist = CvPADLIST(cv);
4242 PerlIO_printf(Perl_debug_log,
4243 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4245 (CvANON(cv) ? "ANON"
4246 : (cv == PL_main_cv) ? "MAIN"
4247 : CvUNIQUE(cv) ? "UNIQUE"
4248 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4251 : CvANON(outside) ? "ANON"
4252 : (outside == PL_main_cv) ? "MAIN"
4253 : CvUNIQUE(outside) ? "UNIQUE"
4254 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4259 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4260 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4261 pname = AvARRAY(pad_name);
4262 ppad = AvARRAY(pad);
4264 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4265 if (SvPOK(pname[ix]))
4266 PerlIO_printf(Perl_debug_log,
4267 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4268 (int)ix, PTR2UV(ppad[ix]),
4269 SvFAKE(pname[ix]) ? "FAKE " : "",
4271 (IV)I_32(SvNVX(pname[ix])),
4274 #endif /* DEBUGGING */
4276 #endif /* DEBUG_CLOSURES */
4279 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4283 AV* protopadlist = CvPADLIST(proto);
4284 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4285 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4286 SV** pname = AvARRAY(protopad_name);
4287 SV** ppad = AvARRAY(protopad);
4288 I32 fname = AvFILLp(protopad_name);
4289 I32 fpad = AvFILLp(protopad);
4293 assert(!CvUNIQUE(proto));
4297 SAVESPTR(PL_comppad_name);
4298 SAVESPTR(PL_compcv);
4300 cv = PL_compcv = (CV*)NEWSV(1104,0);
4301 sv_upgrade((SV *)cv, SvTYPE(proto));
4302 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4306 New(666, CvMUTEXP(cv), 1, perl_mutex);
4307 MUTEX_INIT(CvMUTEXP(cv));
4309 #endif /* USE_THREADS */
4310 CvFILE(cv) = CvFILE(proto);
4311 CvGV(cv) = CvGV(proto);
4312 CvSTASH(cv) = CvSTASH(proto);
4313 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4314 CvSTART(cv) = CvSTART(proto);
4316 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4319 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4321 PL_comppad_name = newAV();
4322 for (ix = fname; ix >= 0; ix--)
4323 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4325 PL_comppad = newAV();
4327 comppadlist = newAV();
4328 AvREAL_off(comppadlist);
4329 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4330 av_store(comppadlist, 1, (SV*)PL_comppad);
4331 CvPADLIST(cv) = comppadlist;
4332 av_fill(PL_comppad, AvFILLp(protopad));
4333 PL_curpad = AvARRAY(PL_comppad);
4335 av = newAV(); /* will be @_ */
4337 av_store(PL_comppad, 0, (SV*)av);
4338 AvFLAGS(av) = AVf_REIFY;
4340 for (ix = fpad; ix > 0; ix--) {
4341 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4342 if (namesv && namesv != &PL_sv_undef) {
4343 char *name = SvPVX(namesv); /* XXX */
4344 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4345 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4346 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4348 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4350 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4352 else { /* our own lexical */
4355 /* anon code -- we'll come back for it */
4356 sv = SvREFCNT_inc(ppad[ix]);
4358 else if (*name == '@')
4360 else if (*name == '%')
4369 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4370 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4373 SV* sv = NEWSV(0,0);
4379 /* Now that vars are all in place, clone nested closures. */
4381 for (ix = fpad; ix > 0; ix--) {
4382 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4384 && namesv != &PL_sv_undef
4385 && !(SvFLAGS(namesv) & SVf_FAKE)
4386 && *SvPVX(namesv) == '&'
4387 && CvCLONE(ppad[ix]))
4389 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4390 SvREFCNT_dec(ppad[ix]);
4393 PL_curpad[ix] = (SV*)kid;
4397 #ifdef DEBUG_CLOSURES
4398 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4400 PerlIO_printf(Perl_debug_log, " from:\n");
4402 PerlIO_printf(Perl_debug_log, " to:\n");
4409 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4411 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4413 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4420 Perl_cv_clone(pTHX_ CV *proto)
4423 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4424 cv = cv_clone2(proto, CvOUTSIDE(proto));
4425 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4430 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4432 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4433 SV* msg = sv_newmortal();
4437 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4438 sv_setpv(msg, "Prototype mismatch:");
4440 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4442 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4443 sv_catpv(msg, " vs ");
4445 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4447 sv_catpv(msg, "none");
4448 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4452 static void const_sv_xsub(pTHXo_ CV* cv);
4455 =for apidoc cv_const_sv
4457 If C<cv> is a constant sub eligible for inlining. returns the constant
4458 value returned by the sub. Otherwise, returns NULL.
4460 Constant subs can be created with C<newCONSTSUB> or as described in
4461 L<perlsub/"Constant Functions">.
4466 Perl_cv_const_sv(pTHX_ CV *cv)
4468 if (!cv || !CvCONST(cv))
4470 return (SV*)CvXSUBANY(cv).any_ptr;
4474 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4481 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4482 o = cLISTOPo->op_first->op_sibling;
4484 for (; o; o = o->op_next) {
4485 OPCODE type = o->op_type;
4487 if (sv && o->op_next == o)
4489 if (o->op_next != o) {
4490 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4492 if (type == OP_DBSTATE)
4495 if (type == OP_LEAVESUB || type == OP_RETURN)
4499 if (type == OP_CONST && cSVOPo->op_sv)
4501 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4502 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4503 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4507 /* We get here only from cv_clone2() while creating a closure.
4508 Copy the const value here instead of in cv_clone2 so that
4509 SvREADONLY_on doesn't lead to problems when leaving
4514 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4526 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4536 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4540 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4542 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4546 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4552 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4557 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4558 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4559 SV *sv = sv_newmortal();
4560 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4561 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4566 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4567 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4577 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4578 maximum a prototype before. */
4579 if (SvTYPE(gv) > SVt_NULL) {
4580 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4581 && ckWARN_d(WARN_PROTOTYPE))
4583 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4585 cv_ckproto((CV*)gv, NULL, ps);
4588 sv_setpv((SV*)gv, ps);
4590 sv_setiv((SV*)gv, -1);
4591 SvREFCNT_dec(PL_compcv);
4592 cv = PL_compcv = NULL;
4593 PL_sub_generation++;
4597 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4599 #ifdef GV_SHARED_CHECK
4600 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4601 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4605 if (!block || !ps || *ps || attrs)
4608 const_sv = op_const_sv(block, Nullcv);
4611 bool exists = CvROOT(cv) || CvXSUB(cv);
4613 #ifdef GV_SHARED_CHECK
4614 if (exists && GvSHARED(gv)) {
4615 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4619 /* if the subroutine doesn't exist and wasn't pre-declared
4620 * with a prototype, assume it will be AUTOLOADed,
4621 * skipping the prototype check
4623 if (exists || SvPOK(cv))
4624 cv_ckproto(cv, gv, ps);
4625 /* already defined (or promised)? */
4626 if (exists || GvASSUMECV(gv)) {
4627 if (!block && !attrs) {
4628 /* just a "sub foo;" when &foo is already defined */
4629 SAVEFREESV(PL_compcv);
4632 /* ahem, death to those who redefine active sort subs */
4633 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4634 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4636 if (ckWARN(WARN_REDEFINE)
4638 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4640 line_t oldline = CopLINE(PL_curcop);
4641 CopLINE_set(PL_curcop, PL_copline);
4642 Perl_warner(aTHX_ WARN_REDEFINE,
4643 CvCONST(cv) ? "Constant subroutine %s redefined"
4644 : "Subroutine %s redefined", name);
4645 CopLINE_set(PL_curcop, oldline);
4653 SvREFCNT_inc(const_sv);
4655 assert(!CvROOT(cv) && !CvCONST(cv));
4656 sv_setpv((SV*)cv, ""); /* prototype is "" */
4657 CvXSUBANY(cv).any_ptr = const_sv;
4658 CvXSUB(cv) = const_sv_xsub;
4663 cv = newCONSTSUB(NULL, name, const_sv);
4666 SvREFCNT_dec(PL_compcv);
4668 PL_sub_generation++;
4675 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4676 * before we clobber PL_compcv.
4680 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4681 stash = GvSTASH(CvGV(cv));
4682 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4683 stash = CvSTASH(cv);
4685 stash = PL_curstash;
4688 /* possibly about to re-define existing subr -- ignore old cv */
4689 rcv = (SV*)PL_compcv;
4690 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4691 stash = GvSTASH(gv);
4693 stash = PL_curstash;
4695 apply_attrs(stash, rcv, attrs);
4697 if (cv) { /* must reuse cv if autoloaded */
4699 /* got here with just attrs -- work done, so bug out */
4700 SAVEFREESV(PL_compcv);
4704 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4705 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4706 CvOUTSIDE(PL_compcv) = 0;
4707 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4708 CvPADLIST(PL_compcv) = 0;
4709 /* inner references to PL_compcv must be fixed up ... */
4711 AV *padlist = CvPADLIST(cv);
4712 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4713 AV *comppad = (AV*)AvARRAY(padlist)[1];
4714 SV **namepad = AvARRAY(comppad_name);
4715 SV **curpad = AvARRAY(comppad);
4716 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4717 SV *namesv = namepad[ix];
4718 if (namesv && namesv != &PL_sv_undef
4719 && *SvPVX(namesv) == '&')
4721 CV *innercv = (CV*)curpad[ix];
4722 if (CvOUTSIDE(innercv) == PL_compcv) {
4723 CvOUTSIDE(innercv) = cv;
4724 if (!CvANON(innercv) || CvCLONED(innercv)) {
4725 (void)SvREFCNT_inc(cv);
4726 SvREFCNT_dec(PL_compcv);
4732 /* ... before we throw it away */
4733 SvREFCNT_dec(PL_compcv);
4740 PL_sub_generation++;
4744 CvFILE(cv) = CopFILE(PL_curcop);
4745 CvSTASH(cv) = PL_curstash;
4748 if (!CvMUTEXP(cv)) {
4749 New(666, CvMUTEXP(cv), 1, perl_mutex);
4750 MUTEX_INIT(CvMUTEXP(cv));
4752 #endif /* USE_THREADS */
4755 sv_setpv((SV*)cv, ps);
4757 if (PL_error_count) {
4761 char *s = strrchr(name, ':');
4763 if (strEQ(s, "BEGIN")) {
4765 "BEGIN not safe after errors--compilation aborted";
4766 if (PL_in_eval & EVAL_KEEPERR)
4767 Perl_croak(aTHX_ not_safe);
4769 /* force display of errors found but not reported */
4770 sv_catpv(ERRSV, not_safe);
4771 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4779 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4780 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4783 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4784 mod(scalarseq(block), OP_LEAVESUBLV));
4787 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4789 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4790 OpREFCNT_set(CvROOT(cv), 1);
4791 CvSTART(cv) = LINKLIST(CvROOT(cv));
4792 CvROOT(cv)->op_next = 0;
4795 /* now that optimizer has done its work, adjust pad values */
4797 SV **namep = AvARRAY(PL_comppad_name);
4798 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4801 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4804 * The only things that a clonable function needs in its
4805 * pad are references to outer lexicals and anonymous subs.
4806 * The rest are created anew during cloning.
4808 if (!((namesv = namep[ix]) != Nullsv &&
4809 namesv != &PL_sv_undef &&
4811 *SvPVX(namesv) == '&')))
4813 SvREFCNT_dec(PL_curpad[ix]);
4814 PL_curpad[ix] = Nullsv;
4817 assert(!CvCONST(cv));
4818 if (ps && !*ps && op_const_sv(block, cv))
4822 AV *av = newAV(); /* Will be @_ */
4824 av_store(PL_comppad, 0, (SV*)av);
4825 AvFLAGS(av) = AVf_REIFY;
4827 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4828 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4830 if (!SvPADMY(PL_curpad[ix]))
4831 SvPADTMP_on(PL_curpad[ix]);
4835 /* If a potential closure prototype, don't keep a refcount on outer CV.
4836 * This is okay as the lifetime of the prototype is tied to the
4837 * lifetime of the outer CV. Avoids memory leak due to reference
4840 SvREFCNT_dec(CvOUTSIDE(cv));
4842 if (name || aname) {
4844 char *tname = (name ? name : aname);
4846 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4847 SV *sv = NEWSV(0,0);
4848 SV *tmpstr = sv_newmortal();
4849 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4853 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4855 (long)PL_subline, (long)CopLINE(PL_curcop));
4856 gv_efullname3(tmpstr, gv, Nullch);
4857 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4858 hv = GvHVn(db_postponed);
4859 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4860 && (pcv = GvCV(db_postponed)))
4866 call_sv((SV*)pcv, G_DISCARD);
4870 if ((s = strrchr(tname,':')))
4875 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4878 if (strEQ(s, "BEGIN")) {
4879 I32 oldscope = PL_scopestack_ix;
4881 SAVECOPFILE(&PL_compiling);
4882 SAVECOPLINE(&PL_compiling);
4884 sv_setsv(PL_rs, PL_nrs);
4887 PL_beginav = newAV();
4888 DEBUG_x( dump_sub(gv) );
4889 av_push(PL_beginav, (SV*)cv);
4890 GvCV(gv) = 0; /* cv has been hijacked */
4891 call_list(oldscope, PL_beginav);
4893 PL_curcop = &PL_compiling;
4894 PL_compiling.op_private = PL_hints;
4897 else if (strEQ(s, "END") && !PL_error_count) {
4900 DEBUG_x( dump_sub(gv) );
4901 av_unshift(PL_endav, 1);
4902 av_store(PL_endav, 0, (SV*)cv);
4903 GvCV(gv) = 0; /* cv has been hijacked */
4905 else if (strEQ(s, "CHECK") && !PL_error_count) {
4907 PL_checkav = newAV();
4908 DEBUG_x( dump_sub(gv) );
4909 if (PL_main_start && ckWARN(WARN_VOID))
4910 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4911 av_unshift(PL_checkav, 1);
4912 av_store(PL_checkav, 0, (SV*)cv);
4913 GvCV(gv) = 0; /* cv has been hijacked */
4915 else if (strEQ(s, "INIT") && !PL_error_count) {
4917 PL_initav = newAV();
4918 DEBUG_x( dump_sub(gv) );
4919 if (PL_main_start && ckWARN(WARN_VOID))
4920 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4921 av_push(PL_initav, (SV*)cv);
4922 GvCV(gv) = 0; /* cv has been hijacked */
4927 PL_copline = NOLINE;
4932 /* XXX unsafe for threads if eval_owner isn't held */
4934 =for apidoc newCONSTSUB
4936 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4937 eligible for inlining at compile-time.
4943 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4949 SAVECOPLINE(PL_curcop);
4950 CopLINE_set(PL_curcop, PL_copline);
4953 PL_hints &= ~HINT_BLOCK_SCOPE;
4956 SAVESPTR(PL_curstash);
4957 SAVECOPSTASH(PL_curcop);
4958 PL_curstash = stash;
4960 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4962 CopSTASH(PL_curcop) = stash;
4966 cv = newXS(name, const_sv_xsub, __FILE__);
4967 CvXSUBANY(cv).any_ptr = sv;
4969 sv_setpv((SV*)cv, ""); /* prototype is "" */
4977 =for apidoc U||newXS
4979 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4985 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4987 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4990 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4992 /* just a cached method */
4996 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4997 /* already defined (or promised) */
4998 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4999 && HvNAME(GvSTASH(CvGV(cv)))
5000 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5001 line_t oldline = CopLINE(PL_curcop);
5002 if (PL_copline != NOLINE)
5003 CopLINE_set(PL_curcop, PL_copline);
5004 Perl_warner(aTHX_ WARN_REDEFINE,
5005 CvCONST(cv) ? "Constant subroutine %s redefined"
5006 : "Subroutine %s redefined"
5008 CopLINE_set(PL_curcop, oldline);
5015 if (cv) /* must reuse cv if autoloaded */
5018 cv = (CV*)NEWSV(1105,0);
5019 sv_upgrade((SV *)cv, SVt_PVCV);
5023 PL_sub_generation++;
5028 New(666, CvMUTEXP(cv), 1, perl_mutex);
5029 MUTEX_INIT(CvMUTEXP(cv));
5031 #endif /* USE_THREADS */
5032 (void)gv_fetchfile(filename);
5033 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5034 an external constant string */
5035 CvXSUB(cv) = subaddr;
5038 char *s = strrchr(name,':');
5044 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5047 if (strEQ(s, "BEGIN")) {
5049 PL_beginav = newAV();
5050 av_push(PL_beginav, (SV*)cv);
5051 GvCV(gv) = 0; /* cv has been hijacked */
5053 else if (strEQ(s, "END")) {
5056 av_unshift(PL_endav, 1);
5057 av_store(PL_endav, 0, (SV*)cv);
5058 GvCV(gv) = 0; /* cv has been hijacked */
5060 else if (strEQ(s, "CHECK")) {
5062 PL_checkav = newAV();
5063 if (PL_main_start && ckWARN(WARN_VOID))
5064 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5065 av_unshift(PL_checkav, 1);
5066 av_store(PL_checkav, 0, (SV*)cv);
5067 GvCV(gv) = 0; /* cv has been hijacked */
5069 else if (strEQ(s, "INIT")) {
5071 PL_initav = newAV();
5072 if (PL_main_start && ckWARN(WARN_VOID))
5073 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5074 av_push(PL_initav, (SV*)cv);
5075 GvCV(gv) = 0; /* cv has been hijacked */
5086 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5095 name = SvPVx(cSVOPo->op_sv, n_a);
5098 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5099 #ifdef GV_SHARED_CHECK
5101 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5105 if ((cv = GvFORM(gv))) {
5106 if (ckWARN(WARN_REDEFINE)) {
5107 line_t oldline = CopLINE(PL_curcop);
5109 CopLINE_set(PL_curcop, PL_copline);
5110 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5111 CopLINE_set(PL_curcop, oldline);
5118 CvFILE(cv) = CopFILE(PL_curcop);
5120 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5121 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5122 SvPADTMP_on(PL_curpad[ix]);
5125 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5126 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5127 OpREFCNT_set(CvROOT(cv), 1);
5128 CvSTART(cv) = LINKLIST(CvROOT(cv));
5129 CvROOT(cv)->op_next = 0;
5132 PL_copline = NOLINE;
5137 Perl_newANONLIST(pTHX_ OP *o)
5139 return newUNOP(OP_REFGEN, 0,
5140 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5144 Perl_newANONHASH(pTHX_ OP *o)
5146 return newUNOP(OP_REFGEN, 0,
5147 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5151 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5153 return newANONATTRSUB(floor, proto, Nullop, block);
5157 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5159 return newUNOP(OP_REFGEN, 0,
5160 newSVOP(OP_ANONCODE, 0,
5161 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5165 Perl_oopsAV(pTHX_ OP *o)
5167 switch (o->op_type) {
5169 o->op_type = OP_PADAV;
5170 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5171 return ref(o, OP_RV2AV);
5174 o->op_type = OP_RV2AV;
5175 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5180 if (ckWARN_d(WARN_INTERNAL))
5181 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5188 Perl_oopsHV(pTHX_ OP *o)
5190 switch (o->op_type) {
5193 o->op_type = OP_PADHV;
5194 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5195 return ref(o, OP_RV2HV);
5199 o->op_type = OP_RV2HV;
5200 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5205 if (ckWARN_d(WARN_INTERNAL))
5206 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5213 Perl_newAVREF(pTHX_ OP *o)
5215 if (o->op_type == OP_PADANY) {
5216 o->op_type = OP_PADAV;
5217 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5220 return newUNOP(OP_RV2AV, 0, scalar(o));
5224 Perl_newGVREF(pTHX_ I32 type, OP *o)
5226 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5227 return newUNOP(OP_NULL, 0, o);
5228 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5232 Perl_newHVREF(pTHX_ OP *o)
5234 if (o->op_type == OP_PADANY) {
5235 o->op_type = OP_PADHV;
5236 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5239 return newUNOP(OP_RV2HV, 0, scalar(o));
5243 Perl_oopsCV(pTHX_ OP *o)
5245 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5251 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5253 return newUNOP(OP_RV2CV, flags, scalar(o));
5257 Perl_newSVREF(pTHX_ OP *o)
5259 if (o->op_type == OP_PADANY) {
5260 o->op_type = OP_PADSV;
5261 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5264 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5265 o->op_flags |= OPpDONE_SVREF;
5268 return newUNOP(OP_RV2SV, 0, scalar(o));
5271 /* Check routines. */
5274 Perl_ck_anoncode(pTHX_ OP *o)
5279 name = NEWSV(1106,0);
5280 sv_upgrade(name, SVt_PVNV);
5281 sv_setpvn(name, "&", 1);
5284 ix = pad_alloc(o->op_type, SVs_PADMY);
5285 av_store(PL_comppad_name, ix, name);
5286 av_store(PL_comppad, ix, cSVOPo->op_sv);
5287 SvPADMY_on(cSVOPo->op_sv);
5288 cSVOPo->op_sv = Nullsv;
5289 cSVOPo->op_targ = ix;
5294 Perl_ck_bitop(pTHX_ OP *o)
5296 o->op_private = PL_hints;
5301 Perl_ck_concat(pTHX_ OP *o)
5303 if (cUNOPo->op_first->op_type == OP_CONCAT)
5304 o->op_flags |= OPf_STACKED;
5309 Perl_ck_spair(pTHX_ OP *o)
5311 if (o->op_flags & OPf_KIDS) {
5314 OPCODE type = o->op_type;
5315 o = modkids(ck_fun(o), type);
5316 kid = cUNOPo->op_first;
5317 newop = kUNOP->op_first->op_sibling;
5319 (newop->op_sibling ||
5320 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5321 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5322 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5326 op_free(kUNOP->op_first);
5327 kUNOP->op_first = newop;
5329 o->op_ppaddr = PL_ppaddr[++o->op_type];
5334 Perl_ck_delete(pTHX_ OP *o)
5338 if (o->op_flags & OPf_KIDS) {
5339 OP *kid = cUNOPo->op_first;
5340 switch (kid->op_type) {
5342 o->op_flags |= OPf_SPECIAL;
5345 o->op_private |= OPpSLICE;
5348 o->op_flags |= OPf_SPECIAL;
5353 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5354 PL_op_desc[o->op_type]);
5362 Perl_ck_eof(pTHX_ OP *o)
5364 I32 type = o->op_type;
5366 if (o->op_flags & OPf_KIDS) {
5367 if (cLISTOPo->op_first->op_type == OP_STUB) {
5369 o = newUNOP(type, OPf_SPECIAL,
5370 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5378 Perl_ck_eval(pTHX_ OP *o)
5380 PL_hints |= HINT_BLOCK_SCOPE;
5381 if (o->op_flags & OPf_KIDS) {
5382 SVOP *kid = (SVOP*)cUNOPo->op_first;
5385 o->op_flags &= ~OPf_KIDS;
5388 else if (kid->op_type == OP_LINESEQ) {
5391 kid->op_next = o->op_next;
5392 cUNOPo->op_first = 0;
5395 NewOp(1101, enter, 1, LOGOP);
5396 enter->op_type = OP_ENTERTRY;
5397 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5398 enter->op_private = 0;
5400 /* establish postfix order */
5401 enter->op_next = (OP*)enter;
5403 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5404 o->op_type = OP_LEAVETRY;
5405 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5406 enter->op_other = o;
5414 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5416 o->op_targ = (PADOFFSET)PL_hints;
5421 Perl_ck_exit(pTHX_ OP *o)
5424 HV *table = GvHV(PL_hintgv);
5426 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5427 if (svp && *svp && SvTRUE(*svp))
5428 o->op_private |= OPpEXIT_VMSISH;
5435 Perl_ck_exec(pTHX_ OP *o)
5438 if (o->op_flags & OPf_STACKED) {
5440 kid = cUNOPo->op_first->op_sibling;
5441 if (kid->op_type == OP_RV2GV)
5450 Perl_ck_exists(pTHX_ OP *o)
5453 if (o->op_flags & OPf_KIDS) {
5454 OP *kid = cUNOPo->op_first;
5455 if (kid->op_type == OP_ENTERSUB) {
5456 (void) ref(kid, o->op_type);
5457 if (kid->op_type != OP_RV2CV && !PL_error_count)
5458 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5459 PL_op_desc[o->op_type]);
5460 o->op_private |= OPpEXISTS_SUB;
5462 else if (kid->op_type == OP_AELEM)
5463 o->op_flags |= OPf_SPECIAL;
5464 else if (kid->op_type != OP_HELEM)
5465 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5466 PL_op_desc[o->op_type]);
5474 Perl_ck_gvconst(pTHX_ register OP *o)
5476 o = fold_constants(o);
5477 if (o->op_type == OP_CONST)
5484 Perl_ck_rvconst(pTHX_ register OP *o)
5486 SVOP *kid = (SVOP*)cUNOPo->op_first;
5488 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5489 if (kid->op_type == OP_CONST) {
5493 SV *kidsv = kid->op_sv;
5496 /* Is it a constant from cv_const_sv()? */
5497 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5498 SV *rsv = SvRV(kidsv);
5499 int svtype = SvTYPE(rsv);
5500 char *badtype = Nullch;
5502 switch (o->op_type) {
5504 if (svtype > SVt_PVMG)
5505 badtype = "a SCALAR";
5508 if (svtype != SVt_PVAV)
5509 badtype = "an ARRAY";
5512 if (svtype != SVt_PVHV) {
5513 if (svtype == SVt_PVAV) { /* pseudohash? */
5514 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5515 if (ksv && SvROK(*ksv)
5516 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5525 if (svtype != SVt_PVCV)
5530 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5533 name = SvPV(kidsv, n_a);
5534 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5535 char *badthing = Nullch;
5536 switch (o->op_type) {
5538 badthing = "a SCALAR";
5541 badthing = "an ARRAY";
5544 badthing = "a HASH";
5549 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5553 * This is a little tricky. We only want to add the symbol if we
5554 * didn't add it in the lexer. Otherwise we get duplicate strict
5555 * warnings. But if we didn't add it in the lexer, we must at
5556 * least pretend like we wanted to add it even if it existed before,
5557 * or we get possible typo warnings. OPpCONST_ENTERED says
5558 * whether the lexer already added THIS instance of this symbol.
5560 iscv = (o->op_type == OP_RV2CV) * 2;
5562 gv = gv_fetchpv(name,
5563 iscv | !(kid->op_private & OPpCONST_ENTERED),
5566 : o->op_type == OP_RV2SV
5568 : o->op_type == OP_RV2AV
5570 : o->op_type == OP_RV2HV
5573 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5575 kid->op_type = OP_GV;
5576 SvREFCNT_dec(kid->op_sv);
5578 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5579 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5580 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5582 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5584 kid->op_sv = SvREFCNT_inc(gv);
5586 kid->op_private = 0;
5587 kid->op_ppaddr = PL_ppaddr[OP_GV];
5594 Perl_ck_ftst(pTHX_ OP *o)
5596 I32 type = o->op_type;
5598 if (o->op_flags & OPf_REF) {
5601 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5602 SVOP *kid = (SVOP*)cUNOPo->op_first;
5604 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5606 OP *newop = newGVOP(type, OPf_REF,
5607 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5614 if (type == OP_FTTTY)
5615 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5618 o = newUNOP(type, 0, newDEFSVOP());
5621 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5623 if (PL_hints & HINT_LOCALE)
5624 o->op_private |= OPpLOCALE;
5631 Perl_ck_fun(pTHX_ OP *o)
5637 int type = o->op_type;
5638 register I32 oa = PL_opargs[type] >> OASHIFT;
5640 if (o->op_flags & OPf_STACKED) {
5641 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5644 return no_fh_allowed(o);
5647 if (o->op_flags & OPf_KIDS) {
5649 tokid = &cLISTOPo->op_first;
5650 kid = cLISTOPo->op_first;
5651 if (kid->op_type == OP_PUSHMARK ||
5652 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5654 tokid = &kid->op_sibling;
5655 kid = kid->op_sibling;
5657 if (!kid && PL_opargs[type] & OA_DEFGV)
5658 *tokid = kid = newDEFSVOP();
5662 sibl = kid->op_sibling;
5665 /* list seen where single (scalar) arg expected? */
5666 if (numargs == 1 && !(oa >> 4)
5667 && kid->op_type == OP_LIST && type != OP_SCALAR)
5669 return too_many_arguments(o,PL_op_desc[type]);
5682 if (kid->op_type == OP_CONST &&
5683 (kid->op_private & OPpCONST_BARE))
5685 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5686 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5687 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5688 if (ckWARN(WARN_DEPRECATED))
5689 Perl_warner(aTHX_ WARN_DEPRECATED,
5690 "Array @%s missing the @ in argument %"IVdf" of %s()",
5691 name, (IV)numargs, PL_op_desc[type]);
5694 kid->op_sibling = sibl;
5697 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5698 bad_type(numargs, "array", PL_op_desc[type], kid);
5702 if (kid->op_type == OP_CONST &&
5703 (kid->op_private & OPpCONST_BARE))
5705 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5706 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5707 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5708 if (ckWARN(WARN_DEPRECATED))
5709 Perl_warner(aTHX_ WARN_DEPRECATED,
5710 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5711 name, (IV)numargs, PL_op_desc[type]);
5714 kid->op_sibling = sibl;
5717 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5718 bad_type(numargs, "hash", PL_op_desc[type], kid);
5723 OP *newop = newUNOP(OP_NULL, 0, kid);
5724 kid->op_sibling = 0;
5726 newop->op_next = newop;
5728 kid->op_sibling = sibl;
5733 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5734 if (kid->op_type == OP_CONST &&
5735 (kid->op_private & OPpCONST_BARE))
5737 OP *newop = newGVOP(OP_GV, 0,
5738 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5743 else if (kid->op_type == OP_READLINE) {
5744 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5745 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5748 I32 flags = OPf_SPECIAL;
5752 /* is this op a FH constructor? */
5753 if (is_handle_constructor(o,numargs)) {
5754 char *name = Nullch;
5758 /* Set a flag to tell rv2gv to vivify
5759 * need to "prove" flag does not mean something
5760 * else already - NI-S 1999/05/07
5763 if (kid->op_type == OP_PADSV) {
5764 SV **namep = av_fetch(PL_comppad_name,
5766 if (namep && *namep)
5767 name = SvPV(*namep, len);
5769 else if (kid->op_type == OP_RV2SV
5770 && kUNOP->op_first->op_type == OP_GV)
5772 GV *gv = cGVOPx_gv(kUNOP->op_first);
5774 len = GvNAMELEN(gv);
5776 else if (kid->op_type == OP_AELEM
5777 || kid->op_type == OP_HELEM)
5779 name = "__ANONIO__";
5785 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5786 namesv = PL_curpad[targ];
5787 (void)SvUPGRADE(namesv, SVt_PV);
5789 sv_setpvn(namesv, "$", 1);
5790 sv_catpvn(namesv, name, len);
5793 kid->op_sibling = 0;
5794 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5795 kid->op_targ = targ;
5796 kid->op_private |= priv;
5798 kid->op_sibling = sibl;
5804 mod(scalar(kid), type);
5808 tokid = &kid->op_sibling;
5809 kid = kid->op_sibling;
5811 o->op_private |= numargs;
5813 return too_many_arguments(o,PL_op_desc[o->op_type]);
5816 else if (PL_opargs[type] & OA_DEFGV) {
5818 return newUNOP(type, 0, newDEFSVOP());
5822 while (oa & OA_OPTIONAL)
5824 if (oa && oa != OA_LIST)
5825 return too_few_arguments(o,PL_op_desc[o->op_type]);
5831 Perl_ck_glob(pTHX_ OP *o)
5836 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5837 append_elem(OP_GLOB, o, newDEFSVOP());
5839 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5840 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5842 #if !defined(PERL_EXTERNAL_GLOB)
5843 /* XXX this can be tightened up and made more failsafe. */
5846 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5847 /* null-terminated import list */
5848 newSVpvn(":globally", 9), Nullsv);
5849 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5852 #endif /* PERL_EXTERNAL_GLOB */
5854 if (gv && GvIMPORTED_CV(gv)) {
5855 append_elem(OP_GLOB, o,
5856 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5857 o->op_type = OP_LIST;
5858 o->op_ppaddr = PL_ppaddr[OP_LIST];
5859 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5860 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5861 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5862 append_elem(OP_LIST, o,
5863 scalar(newUNOP(OP_RV2CV, 0,
5864 newGVOP(OP_GV, 0, gv)))));
5865 o = newUNOP(OP_NULL, 0, ck_subr(o));
5866 o->op_targ = OP_GLOB; /* hint at what it used to be */
5869 gv = newGVgen("main");
5871 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5877 Perl_ck_grep(pTHX_ OP *o)
5881 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5883 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5884 NewOp(1101, gwop, 1, LOGOP);
5886 if (o->op_flags & OPf_STACKED) {
5889 kid = cLISTOPo->op_first->op_sibling;
5890 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5893 kid->op_next = (OP*)gwop;
5894 o->op_flags &= ~OPf_STACKED;
5896 kid = cLISTOPo->op_first->op_sibling;
5897 if (type == OP_MAPWHILE)
5904 kid = cLISTOPo->op_first->op_sibling;
5905 if (kid->op_type != OP_NULL)
5906 Perl_croak(aTHX_ "panic: ck_grep");
5907 kid = kUNOP->op_first;
5909 gwop->op_type = type;
5910 gwop->op_ppaddr = PL_ppaddr[type];
5911 gwop->op_first = listkids(o);
5912 gwop->op_flags |= OPf_KIDS;
5913 gwop->op_private = 1;
5914 gwop->op_other = LINKLIST(kid);
5915 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5916 kid->op_next = (OP*)gwop;
5918 kid = cLISTOPo->op_first->op_sibling;
5919 if (!kid || !kid->op_sibling)
5920 return too_few_arguments(o,PL_op_desc[o->op_type]);
5921 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5922 mod(kid, OP_GREPSTART);
5928 Perl_ck_index(pTHX_ OP *o)
5930 if (o->op_flags & OPf_KIDS) {
5931 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5933 kid = kid->op_sibling; /* get past "big" */
5934 if (kid && kid->op_type == OP_CONST)
5935 fbm_compile(((SVOP*)kid)->op_sv, 0);
5941 Perl_ck_lengthconst(pTHX_ OP *o)
5943 /* XXX length optimization goes here */
5948 Perl_ck_lfun(pTHX_ OP *o)
5950 OPCODE type = o->op_type;
5951 return modkids(ck_fun(o), type);
5955 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5957 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5958 switch (cUNOPo->op_first->op_type) {
5960 /* This is needed for
5961 if (defined %stash::)
5962 to work. Do not break Tk.
5964 break; /* Globals via GV can be undef */
5966 case OP_AASSIGN: /* Is this a good idea? */
5967 Perl_warner(aTHX_ WARN_DEPRECATED,
5968 "defined(@array) is deprecated");
5969 Perl_warner(aTHX_ WARN_DEPRECATED,
5970 "\t(Maybe you should just omit the defined()?)\n");
5973 /* This is needed for
5974 if (defined %stash::)
5975 to work. Do not break Tk.
5977 break; /* Globals via GV can be undef */
5979 Perl_warner(aTHX_ WARN_DEPRECATED,
5980 "defined(%%hash) is deprecated");
5981 Perl_warner(aTHX_ WARN_DEPRECATED,
5982 "\t(Maybe you should just omit the defined()?)\n");
5993 Perl_ck_rfun(pTHX_ OP *o)
5995 OPCODE type = o->op_type;
5996 return refkids(ck_fun(o), type);
6000 Perl_ck_listiob(pTHX_ OP *o)
6004 kid = cLISTOPo->op_first;
6007 kid = cLISTOPo->op_first;
6009 if (kid->op_type == OP_PUSHMARK)
6010 kid = kid->op_sibling;
6011 if (kid && o->op_flags & OPf_STACKED)
6012 kid = kid->op_sibling;
6013 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6014 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6015 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6016 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6017 cLISTOPo->op_first->op_sibling = kid;
6018 cLISTOPo->op_last = kid;
6019 kid = kid->op_sibling;
6024 append_elem(o->op_type, o, newDEFSVOP());
6030 if (PL_hints & HINT_LOCALE)
6031 o->op_private |= OPpLOCALE;
6038 Perl_ck_fun_locale(pTHX_ OP *o)
6044 if (PL_hints & HINT_LOCALE)
6045 o->op_private |= OPpLOCALE;
6052 Perl_ck_sassign(pTHX_ OP *o)
6054 OP *kid = cLISTOPo->op_first;
6055 /* has a disposable target? */
6056 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6057 && !(kid->op_flags & OPf_STACKED)
6058 /* Cannot steal the second time! */
6059 && !(kid->op_private & OPpTARGET_MY))
6061 OP *kkid = kid->op_sibling;
6063 /* Can just relocate the target. */
6064 if (kkid && kkid->op_type == OP_PADSV
6065 && !(kkid->op_private & OPpLVAL_INTRO))
6067 kid->op_targ = kkid->op_targ;
6069 /* Now we do not need PADSV and SASSIGN. */
6070 kid->op_sibling = o->op_sibling; /* NULL */
6071 cLISTOPo->op_first = NULL;
6074 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6082 Perl_ck_scmp(pTHX_ OP *o)
6086 if (PL_hints & HINT_LOCALE)
6087 o->op_private |= OPpLOCALE;
6094 Perl_ck_match(pTHX_ OP *o)
6096 o->op_private |= OPpRUNTIME;
6101 Perl_ck_method(pTHX_ OP *o)
6103 OP *kid = cUNOPo->op_first;
6104 if (kid->op_type == OP_CONST) {
6105 SV* sv = kSVOP->op_sv;
6106 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6108 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6109 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6112 kSVOP->op_sv = Nullsv;
6114 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6123 Perl_ck_null(pTHX_ OP *o)
6129 Perl_ck_open(pTHX_ OP *o)
6131 HV *table = GvHV(PL_hintgv);
6135 svp = hv_fetch(table, "open_IN", 7, FALSE);
6137 mode = mode_from_discipline(*svp);
6138 if (mode & O_BINARY)
6139 o->op_private |= OPpOPEN_IN_RAW;
6140 else if (mode & O_TEXT)
6141 o->op_private |= OPpOPEN_IN_CRLF;
6144 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6146 mode = mode_from_discipline(*svp);
6147 if (mode & O_BINARY)
6148 o->op_private |= OPpOPEN_OUT_RAW;
6149 else if (mode & O_TEXT)
6150 o->op_private |= OPpOPEN_OUT_CRLF;
6153 if (o->op_type == OP_BACKTICK)
6159 Perl_ck_repeat(pTHX_ OP *o)
6161 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6162 o->op_private |= OPpREPEAT_DOLIST;
6163 cBINOPo->op_first = force_list(cBINOPo->op_first);
6171 Perl_ck_require(pTHX_ OP *o)
6173 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6174 SVOP *kid = (SVOP*)cUNOPo->op_first;
6176 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6178 for (s = SvPVX(kid->op_sv); *s; s++) {
6179 if (*s == ':' && s[1] == ':') {
6181 Move(s+2, s+1, strlen(s+2)+1, char);
6182 --SvCUR(kid->op_sv);
6185 if (SvREADONLY(kid->op_sv)) {
6186 SvREADONLY_off(kid->op_sv);
6187 sv_catpvn(kid->op_sv, ".pm", 3);
6188 SvREADONLY_on(kid->op_sv);
6191 sv_catpvn(kid->op_sv, ".pm", 3);
6198 Perl_ck_return(pTHX_ OP *o)
6201 if (CvLVALUE(PL_compcv)) {
6202 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6203 mod(kid, OP_LEAVESUBLV);
6210 Perl_ck_retarget(pTHX_ OP *o)
6212 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6219 Perl_ck_select(pTHX_ OP *o)
6222 if (o->op_flags & OPf_KIDS) {
6223 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6224 if (kid && kid->op_sibling) {
6225 o->op_type = OP_SSELECT;
6226 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6228 return fold_constants(o);
6232 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6233 if (kid && kid->op_type == OP_RV2GV)
6234 kid->op_private &= ~HINT_STRICT_REFS;
6239 Perl_ck_shift(pTHX_ OP *o)
6241 I32 type = o->op_type;
6243 if (!(o->op_flags & OPf_KIDS)) {
6248 if (!CvUNIQUE(PL_compcv)) {
6249 argop = newOP(OP_PADAV, OPf_REF);
6250 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6253 argop = newUNOP(OP_RV2AV, 0,
6254 scalar(newGVOP(OP_GV, 0,
6255 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6258 argop = newUNOP(OP_RV2AV, 0,
6259 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6260 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6261 #endif /* USE_THREADS */
6262 return newUNOP(type, 0, scalar(argop));
6264 return scalar(modkids(ck_fun(o), type));
6268 Perl_ck_sort(pTHX_ OP *o)
6273 if (PL_hints & HINT_LOCALE)
6274 o->op_private |= OPpLOCALE;
6277 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6279 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6280 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6282 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6284 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6286 if (kid->op_type == OP_SCOPE) {
6290 else if (kid->op_type == OP_LEAVE) {
6291 if (o->op_type == OP_SORT) {
6292 null(kid); /* wipe out leave */
6295 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6296 if (k->op_next == kid)
6298 /* don't descend into loops */
6299 else if (k->op_type == OP_ENTERLOOP
6300 || k->op_type == OP_ENTERITER)
6302 k = cLOOPx(k)->op_lastop;
6307 kid->op_next = 0; /* just disconnect the leave */
6308 k = kLISTOP->op_first;
6313 if (o->op_type == OP_SORT) {
6314 /* provide scalar context for comparison function/block */
6320 o->op_flags |= OPf_SPECIAL;
6322 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6325 firstkid = firstkid->op_sibling;
6328 /* provide list context for arguments */
6329 if (o->op_type == OP_SORT)
6336 S_simplify_sort(pTHX_ OP *o)
6338 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6342 if (!(o->op_flags & OPf_STACKED))
6344 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6345 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6346 kid = kUNOP->op_first; /* get past null */
6347 if (kid->op_type != OP_SCOPE)
6349 kid = kLISTOP->op_last; /* get past scope */
6350 switch(kid->op_type) {
6358 k = kid; /* remember this node*/
6359 if (kBINOP->op_first->op_type != OP_RV2SV)
6361 kid = kBINOP->op_first; /* get past cmp */
6362 if (kUNOP->op_first->op_type != OP_GV)
6364 kid = kUNOP->op_first; /* get past rv2sv */
6366 if (GvSTASH(gv) != PL_curstash)
6368 if (strEQ(GvNAME(gv), "a"))
6370 else if (strEQ(GvNAME(gv), "b"))
6374 kid = k; /* back to cmp */
6375 if (kBINOP->op_last->op_type != OP_RV2SV)
6377 kid = kBINOP->op_last; /* down to 2nd arg */
6378 if (kUNOP->op_first->op_type != OP_GV)
6380 kid = kUNOP->op_first; /* get past rv2sv */
6382 if (GvSTASH(gv) != PL_curstash
6384 ? strNE(GvNAME(gv), "a")
6385 : strNE(GvNAME(gv), "b")))
6387 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6389 o->op_private |= OPpSORT_REVERSE;
6390 if (k->op_type == OP_NCMP)
6391 o->op_private |= OPpSORT_NUMERIC;
6392 if (k->op_type == OP_I_NCMP)
6393 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6394 kid = cLISTOPo->op_first->op_sibling;
6395 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6396 op_free(kid); /* then delete it */
6400 Perl_ck_split(pTHX_ OP *o)
6404 if (o->op_flags & OPf_STACKED)
6405 return no_fh_allowed(o);
6407 kid = cLISTOPo->op_first;
6408 if (kid->op_type != OP_NULL)
6409 Perl_croak(aTHX_ "panic: ck_split");
6410 kid = kid->op_sibling;
6411 op_free(cLISTOPo->op_first);
6412 cLISTOPo->op_first = kid;
6414 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6415 cLISTOPo->op_last = kid; /* There was only one element previously */
6418 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6419 OP *sibl = kid->op_sibling;
6420 kid->op_sibling = 0;
6421 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6422 if (cLISTOPo->op_first == cLISTOPo->op_last)
6423 cLISTOPo->op_last = kid;
6424 cLISTOPo->op_first = kid;
6425 kid->op_sibling = sibl;
6428 kid->op_type = OP_PUSHRE;
6429 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6432 if (!kid->op_sibling)
6433 append_elem(OP_SPLIT, o, newDEFSVOP());
6435 kid = kid->op_sibling;
6438 if (!kid->op_sibling)
6439 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6441 kid = kid->op_sibling;
6444 if (kid->op_sibling)
6445 return too_many_arguments(o,PL_op_desc[o->op_type]);
6451 Perl_ck_join(pTHX_ OP *o)
6453 if (ckWARN(WARN_SYNTAX)) {
6454 OP *kid = cLISTOPo->op_first->op_sibling;
6455 if (kid && kid->op_type == OP_MATCH) {
6456 char *pmstr = "STRING";
6457 if (kPMOP->op_pmregexp)
6458 pmstr = kPMOP->op_pmregexp->precomp;
6459 Perl_warner(aTHX_ WARN_SYNTAX,
6460 "/%s/ should probably be written as \"%s\"",
6468 Perl_ck_subr(pTHX_ OP *o)
6470 OP *prev = ((cUNOPo->op_first->op_sibling)
6471 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6472 OP *o2 = prev->op_sibling;
6481 o->op_private |= OPpENTERSUB_HASTARG;
6482 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6483 if (cvop->op_type == OP_RV2CV) {
6485 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6486 null(cvop); /* disable rv2cv */
6487 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6488 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6489 GV *gv = cGVOPx_gv(tmpop);
6492 tmpop->op_private |= OPpEARLY_CV;
6493 else if (SvPOK(cv)) {
6494 namegv = CvANON(cv) ? gv : CvGV(cv);
6495 proto = SvPV((SV*)cv, n_a);
6499 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6500 if (o2->op_type == OP_CONST)
6501 o2->op_private &= ~OPpCONST_STRICT;
6502 else if (o2->op_type == OP_LIST) {
6503 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6504 if (o && o->op_type == OP_CONST)
6505 o->op_private &= ~OPpCONST_STRICT;
6508 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6509 if (PERLDB_SUB && PL_curstash != PL_debstash)
6510 o->op_private |= OPpENTERSUB_DB;
6511 while (o2 != cvop) {
6515 return too_many_arguments(o, gv_ename(namegv));
6533 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6535 arg == 1 ? "block or sub {}" : "sub {}",
6536 gv_ename(namegv), o2);
6539 /* '*' allows any scalar type, including bareword */
6542 if (o2->op_type == OP_RV2GV)
6543 goto wrapref; /* autoconvert GLOB -> GLOBref */
6544 else if (o2->op_type == OP_CONST)
6545 o2->op_private &= ~OPpCONST_STRICT;
6546 else if (o2->op_type == OP_ENTERSUB) {
6547 /* accidental subroutine, revert to bareword */
6548 OP *gvop = ((UNOP*)o2)->op_first;
6549 if (gvop && gvop->op_type == OP_NULL) {
6550 gvop = ((UNOP*)gvop)->op_first;
6552 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6555 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6556 (gvop = ((UNOP*)gvop)->op_first) &&
6557 gvop->op_type == OP_GV)
6559 GV *gv = cGVOPx_gv(gvop);
6560 OP *sibling = o2->op_sibling;
6561 SV *n = newSVpvn("",0);
6563 gv_fullname3(n, gv, "");
6564 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6565 sv_chop(n, SvPVX(n)+6);
6566 o2 = newSVOP(OP_CONST, 0, n);
6567 prev->op_sibling = o2;
6568 o2->op_sibling = sibling;
6580 if (o2->op_type != OP_RV2GV)
6581 bad_type(arg, "symbol", gv_ename(namegv), o2);
6584 if (o2->op_type != OP_ENTERSUB)
6585 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6588 if (o2->op_type != OP_RV2SV
6589 && o2->op_type != OP_PADSV
6590 && o2->op_type != OP_HELEM
6591 && o2->op_type != OP_AELEM
6592 && o2->op_type != OP_THREADSV)
6594 bad_type(arg, "scalar", gv_ename(namegv), o2);
6598 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6599 bad_type(arg, "array", gv_ename(namegv), o2);
6602 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6603 bad_type(arg, "hash", gv_ename(namegv), o2);
6607 OP* sib = kid->op_sibling;
6608 kid->op_sibling = 0;
6609 o2 = newUNOP(OP_REFGEN, 0, kid);
6610 o2->op_sibling = sib;
6611 prev->op_sibling = o2;
6622 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6623 gv_ename(namegv), SvPV((SV*)cv, n_a));
6628 mod(o2, OP_ENTERSUB);
6630 o2 = o2->op_sibling;
6632 if (proto && !optional &&
6633 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6634 return too_few_arguments(o, gv_ename(namegv));
6639 Perl_ck_svconst(pTHX_ OP *o)
6641 SvREADONLY_on(cSVOPo->op_sv);
6646 Perl_ck_trunc(pTHX_ OP *o)
6648 if (o->op_flags & OPf_KIDS) {
6649 SVOP *kid = (SVOP*)cUNOPo->op_first;
6651 if (kid->op_type == OP_NULL)
6652 kid = (SVOP*)kid->op_sibling;
6653 if (kid && kid->op_type == OP_CONST &&
6654 (kid->op_private & OPpCONST_BARE))
6656 o->op_flags |= OPf_SPECIAL;
6657 kid->op_private &= ~OPpCONST_STRICT;
6664 Perl_ck_substr(pTHX_ OP *o)
6667 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6668 OP *kid = cLISTOPo->op_first;
6670 if (kid->op_type == OP_NULL)
6671 kid = kid->op_sibling;
6673 kid->op_flags |= OPf_MOD;
6679 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6682 Perl_peep(pTHX_ register OP *o)
6684 register OP* oldop = 0;
6687 if (!o || o->op_seq)
6691 SAVEVPTR(PL_curcop);
6692 for (; o; o = o->op_next) {
6698 switch (o->op_type) {
6702 PL_curcop = ((COP*)o); /* for warnings */
6703 o->op_seq = PL_op_seqmax++;
6707 if (cSVOPo->op_private & OPpCONST_STRICT)
6708 no_bareword_allowed(o);
6710 /* Relocate sv to the pad for thread safety.
6711 * Despite being a "constant", the SV is written to,
6712 * for reference counts, sv_upgrade() etc. */
6714 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6715 if (SvPADTMP(cSVOPo->op_sv)) {
6716 /* If op_sv is already a PADTMP then it is being used by
6717 * some pad, so make a copy. */
6718 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6719 SvREADONLY_on(PL_curpad[ix]);
6720 SvREFCNT_dec(cSVOPo->op_sv);
6723 SvREFCNT_dec(PL_curpad[ix]);
6724 SvPADTMP_on(cSVOPo->op_sv);
6725 PL_curpad[ix] = cSVOPo->op_sv;
6726 /* XXX I don't know how this isn't readonly already. */
6727 SvREADONLY_on(PL_curpad[ix]);
6729 cSVOPo->op_sv = Nullsv;
6733 o->op_seq = PL_op_seqmax++;
6737 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6738 if (o->op_next->op_private & OPpTARGET_MY) {
6739 if (o->op_flags & OPf_STACKED) /* chained concats */
6740 goto ignore_optimization;
6742 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6743 o->op_targ = o->op_next->op_targ;
6744 o->op_next->op_targ = 0;
6745 o->op_private |= OPpTARGET_MY;
6750 ignore_optimization:
6751 o->op_seq = PL_op_seqmax++;
6754 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6755 o->op_seq = PL_op_seqmax++;
6756 break; /* Scalar stub must produce undef. List stub is noop */
6760 if (o->op_targ == OP_NEXTSTATE
6761 || o->op_targ == OP_DBSTATE
6762 || o->op_targ == OP_SETSTATE)
6764 PL_curcop = ((COP*)o);
6771 if (oldop && o->op_next) {
6772 oldop->op_next = o->op_next;
6775 o->op_seq = PL_op_seqmax++;
6779 if (o->op_next->op_type == OP_RV2SV) {
6780 if (!(o->op_next->op_private & OPpDEREF)) {
6782 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6784 o->op_next = o->op_next->op_next;
6785 o->op_type = OP_GVSV;
6786 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6789 else if (o->op_next->op_type == OP_RV2AV) {
6790 OP* pop = o->op_next->op_next;
6792 if (pop->op_type == OP_CONST &&
6793 (PL_op = pop->op_next) &&
6794 pop->op_next->op_type == OP_AELEM &&
6795 !(pop->op_next->op_private &
6796 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6797 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6805 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6806 o->op_next = pop->op_next->op_next;
6807 o->op_type = OP_AELEMFAST;
6808 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6809 o->op_private = (U8)i;
6814 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6816 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6817 /* XXX could check prototype here instead of just carping */
6818 SV *sv = sv_newmortal();
6819 gv_efullname3(sv, gv, Nullch);
6820 Perl_warner(aTHX_ WARN_PROTOTYPE,
6821 "%s() called too early to check prototype",
6826 o->op_seq = PL_op_seqmax++;
6837 o->op_seq = PL_op_seqmax++;
6838 while (cLOGOP->op_other->op_type == OP_NULL)
6839 cLOGOP->op_other = cLOGOP->op_other->op_next;
6840 peep(cLOGOP->op_other);
6845 o->op_seq = PL_op_seqmax++;
6846 while (cLOOP->op_redoop->op_type == OP_NULL)
6847 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6848 peep(cLOOP->op_redoop);
6849 while (cLOOP->op_nextop->op_type == OP_NULL)
6850 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6851 peep(cLOOP->op_nextop);
6852 while (cLOOP->op_lastop->op_type == OP_NULL)
6853 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6854 peep(cLOOP->op_lastop);
6860 o->op_seq = PL_op_seqmax++;
6861 while (cPMOP->op_pmreplstart &&
6862 cPMOP->op_pmreplstart->op_type == OP_NULL)
6863 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6864 peep(cPMOP->op_pmreplstart);
6868 o->op_seq = PL_op_seqmax++;
6869 if (ckWARN(WARN_SYNTAX) && o->op_next
6870 && o->op_next->op_type == OP_NEXTSTATE) {
6871 if (o->op_next->op_sibling &&
6872 o->op_next->op_sibling->op_type != OP_EXIT &&
6873 o->op_next->op_sibling->op_type != OP_WARN &&
6874 o->op_next->op_sibling->op_type != OP_DIE) {
6875 line_t oldline = CopLINE(PL_curcop);
6877 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6878 Perl_warner(aTHX_ WARN_EXEC,
6879 "Statement unlikely to be reached");
6880 Perl_warner(aTHX_ WARN_EXEC,
6881 "\t(Maybe you meant system() when you said exec()?)\n");
6882 CopLINE_set(PL_curcop, oldline);
6891 SV **svp, **indsvp, *sv;
6896 o->op_seq = PL_op_seqmax++;
6898 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6901 /* Make the CONST have a shared SV */
6902 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6903 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6904 key = SvPV(sv, keylen);
6907 lexname = newSVpvn_share(key, keylen, 0);
6912 if ((o->op_private & (OPpLVAL_INTRO)))
6915 rop = (UNOP*)((BINOP*)o)->op_first;
6916 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6918 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6919 if (!SvOBJECT(lexname))
6921 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6922 if (!fields || !GvHV(*fields))
6924 key = SvPV(*svp, keylen);
6927 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6929 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6930 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6932 ind = SvIV(*indsvp);
6934 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6935 rop->op_type = OP_RV2AV;
6936 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6937 o->op_type = OP_AELEM;
6938 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6940 if (SvREADONLY(*svp))
6942 SvFLAGS(sv) |= (SvFLAGS(*svp)
6943 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6953 SV **svp, **indsvp, *sv;
6957 SVOP *first_key_op, *key_op;
6959 o->op_seq = PL_op_seqmax++;
6960 if ((o->op_private & (OPpLVAL_INTRO))
6961 /* I bet there's always a pushmark... */
6962 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6963 /* hmmm, no optimization if list contains only one key. */
6965 rop = (UNOP*)((LISTOP*)o)->op_last;
6966 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6968 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6969 if (!SvOBJECT(lexname))
6971 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6972 if (!fields || !GvHV(*fields))
6974 /* Again guessing that the pushmark can be jumped over.... */
6975 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6976 ->op_first->op_sibling;
6977 /* Check that the key list contains only constants. */
6978 for (key_op = first_key_op; key_op;
6979 key_op = (SVOP*)key_op->op_sibling)
6980 if (key_op->op_type != OP_CONST)
6984 rop->op_type = OP_RV2AV;
6985 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6986 o->op_type = OP_ASLICE;
6987 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6988 for (key_op = first_key_op; key_op;
6989 key_op = (SVOP*)key_op->op_sibling) {
6990 svp = cSVOPx_svp(key_op);
6991 key = SvPV(*svp, keylen);
6994 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6996 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6997 "in variable %s of type %s",
6998 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7000 ind = SvIV(*indsvp);
7002 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7004 if (SvREADONLY(*svp))
7006 SvFLAGS(sv) |= (SvFLAGS(*svp)
7007 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7015 o->op_seq = PL_op_seqmax++;
7025 /* Efficient sub that returns a constant scalar value. */
7027 const_sv_xsub(pTHXo_ CV* cv)
7032 Perl_croak(aTHX_ "usage: %s::%s()",
7033 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7037 ST(0) = (SV*)XSANY.any_ptr;