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
60 S_gv_ename(pTHX_ GV *gv)
63 SV* tmpsv = sv_newmortal();
64 gv_efullname3(tmpsv, gv, Nullch);
65 return SvPV(tmpsv,n_a);
69 S_no_fh_allowed(pTHX_ OP *o)
71 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
72 PL_op_desc[o->op_type]));
77 S_too_few_arguments(pTHX_ OP *o, char *name)
79 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
84 S_too_many_arguments(pTHX_ OP *o, char *name)
86 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
91 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
93 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
94 (int)n, name, t, PL_op_desc[kid->op_type]));
98 S_no_bareword_allowed(pTHX_ OP *o)
100 qerror(Perl_mess(aTHX_
101 "Bareword \"%s\" not allowed while \"strict subs\" in use",
102 SvPV_nolen(cSVOPo_sv)));
106 S_trlist_upgrade(pTHX_ U8** sp, U8** ep)
112 Newz(801, d, (e - s) * 2, U8);
116 if (*s < 0x80 || *s == 0xff)
120 *d++ = ((c >> 6) | 0xc0);
121 *d++ = ((c & 0x3f) | 0x80);
129 /* "register" allocation */
132 Perl_pad_allocmy(pTHX_ char *name)
137 if (!(PL_in_my == KEY_our ||
139 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
140 (name[1] == '_' && (int)strlen(name) > 2)))
142 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
143 /* 1999-02-27 mjd@plover.com */
145 p = strchr(name, '\0');
146 /* The next block assumes the buffer is at least 205 chars
147 long. At present, it's always at least 256 chars. */
149 strcpy(name+200, "...");
155 /* Move everything else down one character */
156 for (; p-name > 2; p--)
158 name[2] = toCTRL(name[1]);
161 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
163 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
164 SV **svp = AvARRAY(PL_comppad_name);
165 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
166 PADOFFSET top = AvFILLp(PL_comppad_name);
167 for (off = top; off > PL_comppad_name_floor; off--) {
169 && sv != &PL_sv_undef
170 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
171 && (PL_in_my != KEY_our
172 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
173 && strEQ(name, SvPVX(sv)))
175 Perl_warner(aTHX_ WARN_MISC,
176 "\"%s\" variable %s masks earlier declaration in same %s",
177 (PL_in_my == KEY_our ? "our" : "my"),
179 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
184 if (PL_in_my == KEY_our) {
187 && sv != &PL_sv_undef
188 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
189 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
190 && strEQ(name, SvPVX(sv)))
192 Perl_warner(aTHX_ WARN_MISC,
193 "\"our\" variable %s redeclared", name);
194 Perl_warner(aTHX_ WARN_MISC,
195 "\t(Did you mean \"local\" instead of \"our\"?)\n");
198 } while ( off-- > 0 );
201 off = pad_alloc(OP_PADSV, SVs_PADMY);
203 sv_upgrade(sv, SVt_PVNV);
205 if (PL_in_my_stash) {
207 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
208 name, PL_in_my == KEY_our ? "our" : "my"));
210 (void)SvUPGRADE(sv, SVt_PVMG);
211 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
214 if (PL_in_my == KEY_our) {
215 (void)SvUPGRADE(sv, SVt_PVGV);
216 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
217 SvFLAGS(sv) |= SVpad_OUR;
219 av_store(PL_comppad_name, off, sv);
220 SvNVX(sv) = (NV)PAD_MAX;
221 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
222 if (!PL_min_intro_pending)
223 PL_min_intro_pending = off;
224 PL_max_intro_pending = off;
226 av_store(PL_comppad, off, (SV*)newAV());
227 else if (*name == '%')
228 av_store(PL_comppad, off, (SV*)newHV());
229 SvPADMY_on(PL_curpad[off]);
234 S_pad_addlex(pTHX_ SV *proto_namesv)
236 SV *namesv = NEWSV(1103,0);
237 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
238 sv_upgrade(namesv, SVt_PVNV);
239 sv_setpv(namesv, SvPVX(proto_namesv));
240 av_store(PL_comppad_name, newoff, namesv);
241 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
242 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
243 SvFAKE_on(namesv); /* A ref, not a real var */
244 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
245 SvFLAGS(namesv) |= SVpad_OUR;
246 (void)SvUPGRADE(namesv, SVt_PVGV);
247 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
249 if (SvOBJECT(proto_namesv)) { /* A typed var */
251 (void)SvUPGRADE(namesv, SVt_PVMG);
252 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
258 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
261 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
262 I32 cx_ix, I32 saweval, U32 flags)
268 register PERL_CONTEXT *cx;
270 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
271 AV *curlist = CvPADLIST(cv);
272 SV **svp = av_fetch(curlist, 0, FALSE);
275 if (!svp || *svp == &PL_sv_undef)
278 svp = AvARRAY(curname);
279 for (off = AvFILLp(curname); off > 0; off--) {
280 if ((sv = svp[off]) &&
281 sv != &PL_sv_undef &&
283 seq > I_32(SvNVX(sv)) &&
284 strEQ(SvPVX(sv), name))
295 return 0; /* don't clone from inactive stack frame */
299 oldpad = (AV*)AvARRAY(curlist)[depth];
300 oldsv = *av_fetch(oldpad, off, TRUE);
301 if (!newoff) { /* Not a mere clone operation. */
302 newoff = pad_addlex(sv);
303 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
304 /* "It's closures all the way down." */
305 CvCLONE_on(PL_compcv);
307 if (CvANON(PL_compcv))
308 oldsv = Nullsv; /* no need to keep ref */
313 bcv && bcv != cv && !CvCLONE(bcv);
314 bcv = CvOUTSIDE(bcv))
317 /* install the missing pad entry in intervening
318 * nested subs and mark them cloneable.
319 * XXX fix pad_foo() to not use globals */
320 AV *ocomppad_name = PL_comppad_name;
321 AV *ocomppad = PL_comppad;
322 SV **ocurpad = PL_curpad;
323 AV *padlist = CvPADLIST(bcv);
324 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
325 PL_comppad = (AV*)AvARRAY(padlist)[1];
326 PL_curpad = AvARRAY(PL_comppad);
328 PL_comppad_name = ocomppad_name;
329 PL_comppad = ocomppad;
334 if (ckWARN(WARN_CLOSURE)
335 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
337 Perl_warner(aTHX_ WARN_CLOSURE,
338 "Variable \"%s\" may be unavailable",
346 else if (!CvUNIQUE(PL_compcv)) {
347 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
348 && !(SvFLAGS(sv) & SVpad_OUR))
350 Perl_warner(aTHX_ WARN_CLOSURE,
351 "Variable \"%s\" will not stay shared", name);
355 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
361 if (flags & FINDLEX_NOSEARCH)
364 /* Nothing in current lexical context--try eval's context, if any.
365 * This is necessary to let the perldb get at lexically scoped variables.
366 * XXX This will also probably interact badly with eval tree caching.
369 for (i = cx_ix; i >= 0; i--) {
371 switch (CxTYPE(cx)) {
373 if (i == 0 && saweval) {
374 seq = cxstack[saweval].blk_oldcop->cop_seq;
375 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
379 switch (cx->blk_eval.old_op_type) {
386 /* require/do must have their own scope */
395 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
396 saweval = i; /* so we know where we were called from */
399 seq = cxstack[saweval].blk_oldcop->cop_seq;
400 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
408 Perl_pad_findmy(pTHX_ char *name)
413 SV **svp = AvARRAY(PL_comppad_name);
414 U32 seq = PL_cop_seqmax;
420 * Special case to get lexical (and hence per-thread) @_.
421 * XXX I need to find out how to tell at parse-time whether use
422 * of @_ should refer to a lexical (from a sub) or defgv (global
423 * scope and maybe weird sub-ish things like formats). See
424 * startsub in perly.y. It's possible that @_ could be lexical
425 * (at least from subs) even in non-threaded perl.
427 if (strEQ(name, "@_"))
428 return 0; /* success. (NOT_IN_PAD indicates failure) */
429 #endif /* USE_THREADS */
431 /* The one we're looking for is probably just before comppad_name_fill. */
432 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
433 if ((sv = svp[off]) &&
434 sv != &PL_sv_undef &&
437 seq > I_32(SvNVX(sv)))) &&
438 strEQ(SvPVX(sv), name))
440 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
441 return (PADOFFSET)off;
442 pendoff = off; /* this pending def. will override import */
446 outside = CvOUTSIDE(PL_compcv);
448 /* Check if if we're compiling an eval'', and adjust seq to be the
449 * eval's seq number. This depends on eval'' having a non-null
450 * CvOUTSIDE() while it is being compiled. The eval'' itself is
451 * identified by CvEVAL being true and CvGV being null. */
452 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
453 cx = &cxstack[cxstack_ix];
455 seq = cx->blk_oldcop->cop_seq;
458 /* See if it's in a nested scope */
459 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
461 /* If there is a pending local definition, this new alias must die */
463 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
464 return off; /* pad_findlex returns 0 for failure...*/
466 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
470 Perl_pad_leavemy(pTHX_ I32 fill)
473 SV **svp = AvARRAY(PL_comppad_name);
475 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
476 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
477 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
478 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
481 /* "Deintroduce" my variables that are leaving with this scope. */
482 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
483 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
484 SvIVX(sv) = PL_cop_seqmax;
489 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
494 if (AvARRAY(PL_comppad) != PL_curpad)
495 Perl_croak(aTHX_ "panic: pad_alloc");
496 if (PL_pad_reset_pending)
498 if (tmptype & SVs_PADMY) {
500 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
501 } while (SvPADBUSY(sv)); /* need a fresh one */
502 retval = AvFILLp(PL_comppad);
505 SV **names = AvARRAY(PL_comppad_name);
506 SSize_t names_fill = AvFILLp(PL_comppad_name);
509 * "foreach" index vars temporarily become aliases to non-"my"
510 * values. Thus we must skip, not just pad values that are
511 * marked as current pad values, but also those with names.
513 if (++PL_padix <= names_fill &&
514 (sv = names[PL_padix]) && sv != &PL_sv_undef)
516 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
517 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
518 !IS_PADGV(sv) && !IS_PADCONST(sv))
523 SvFLAGS(sv) |= tmptype;
524 PL_curpad = AvARRAY(PL_comppad);
526 DEBUG_X(PerlIO_printf(Perl_debug_log,
527 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
528 PTR2UV(thr), PTR2UV(PL_curpad),
529 (long) retval, PL_op_name[optype]));
531 DEBUG_X(PerlIO_printf(Perl_debug_log,
532 "Pad 0x%"UVxf" alloc %ld for %s\n",
534 (long) retval, PL_op_name[optype]));
535 #endif /* USE_THREADS */
536 return (PADOFFSET)retval;
540 Perl_pad_sv(pTHX_ PADOFFSET po)
543 DEBUG_X(PerlIO_printf(Perl_debug_log,
544 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
545 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
548 Perl_croak(aTHX_ "panic: pad_sv po");
549 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
550 PTR2UV(PL_curpad), (IV)po));
551 #endif /* USE_THREADS */
552 return PL_curpad[po]; /* eventually we'll turn this into a macro */
556 Perl_pad_free(pTHX_ PADOFFSET po)
560 if (AvARRAY(PL_comppad) != PL_curpad)
561 Perl_croak(aTHX_ "panic: pad_free curpad");
563 Perl_croak(aTHX_ "panic: pad_free po");
565 DEBUG_X(PerlIO_printf(Perl_debug_log,
566 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
567 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
569 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
570 PTR2UV(PL_curpad), (IV)po));
571 #endif /* USE_THREADS */
572 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
573 SvPADTMP_off(PL_curpad[po]);
575 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
578 if ((I32)po < PL_padix)
583 Perl_pad_swipe(pTHX_ PADOFFSET po)
585 if (AvARRAY(PL_comppad) != PL_curpad)
586 Perl_croak(aTHX_ "panic: pad_swipe curpad");
588 Perl_croak(aTHX_ "panic: pad_swipe po");
590 DEBUG_X(PerlIO_printf(Perl_debug_log,
591 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
592 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
594 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
595 PTR2UV(PL_curpad), (IV)po));
596 #endif /* USE_THREADS */
597 SvPADTMP_off(PL_curpad[po]);
598 PL_curpad[po] = NEWSV(1107,0);
599 SvPADTMP_on(PL_curpad[po]);
600 if ((I32)po < PL_padix)
604 /* XXX pad_reset() is currently disabled because it results in serious bugs.
605 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
606 * on the stack by OPs that use them, there are several ways to get an alias
607 * to a shared TARG. Such an alias will change randomly and unpredictably.
608 * We avoid doing this until we can think of a Better Way.
613 #ifdef USE_BROKEN_PAD_RESET
616 if (AvARRAY(PL_comppad) != PL_curpad)
617 Perl_croak(aTHX_ "panic: pad_reset curpad");
619 DEBUG_X(PerlIO_printf(Perl_debug_log,
620 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
621 PTR2UV(thr), PTR2UV(PL_curpad)));
623 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
625 #endif /* USE_THREADS */
626 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
627 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
628 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
629 SvPADTMP_off(PL_curpad[po]);
631 PL_padix = PL_padix_floor;
634 PL_pad_reset_pending = FALSE;
638 /* find_threadsv is not reentrant */
640 Perl_find_threadsv(pTHX_ const char *name)
645 /* We currently only handle names of a single character */
646 p = strchr(PL_threadsv_names, *name);
649 key = p - PL_threadsv_names;
650 MUTEX_LOCK(&thr->mutex);
651 svp = av_fetch(thr->threadsv, key, FALSE);
653 MUTEX_UNLOCK(&thr->mutex);
655 SV *sv = NEWSV(0, 0);
656 av_store(thr->threadsv, key, sv);
657 thr->threadsvp = AvARRAY(thr->threadsv);
658 MUTEX_UNLOCK(&thr->mutex);
660 * Some magic variables used to be automagically initialised
661 * in gv_fetchpv. Those which are now per-thread magicals get
662 * initialised here instead.
668 sv_setpv(sv, "\034");
669 sv_magic(sv, 0, 0, name, 1);
674 PL_sawampersand = TRUE;
688 /* XXX %! tied to Errno.pm needs to be added here.
689 * See gv_fetchpv(). */
693 sv_magic(sv, 0, 0, name, 1);
695 DEBUG_S(PerlIO_printf(Perl_error_log,
696 "find_threadsv: new SV %p for $%s%c\n",
697 sv, (*name < 32) ? "^" : "",
698 (*name < 32) ? toCTRL(*name) : *name));
702 #endif /* USE_THREADS */
707 Perl_op_free(pTHX_ OP *o)
709 register OP *kid, *nextkid;
712 if (!o || o->op_seq == (U16)-1)
715 if (o->op_private & OPpREFCOUNTED) {
716 switch (o->op_type) {
724 if (OpREFCNT_dec(o)) {
735 if (o->op_flags & OPf_KIDS) {
736 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
737 nextkid = kid->op_sibling; /* Get before next freeing kid */
745 /* COP* is not cleared by op_clear() so that we may track line
746 * numbers etc even after null() */
747 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
752 #ifdef PL_OP_SLAB_ALLOC
753 if ((char *) o == PL_OpPtr)
762 S_op_clear(pTHX_ OP *o)
764 switch (o->op_type) {
765 case OP_NULL: /* Was holding old type, if any. */
766 case OP_ENTEREVAL: /* Was holding hints. */
768 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
774 if (!(o->op_flags & OPf_SPECIAL))
777 #endif /* USE_THREADS */
779 if (!(o->op_flags & OPf_REF)
780 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
787 if (cPADOPo->op_padix > 0) {
790 pad_swipe(cPADOPo->op_padix);
791 /* No GvIN_PAD_off(gv) here, because other references may still
792 * exist on the pad */
795 cPADOPo->op_padix = 0;
798 SvREFCNT_dec(cSVOPo->op_sv);
799 cSVOPo->op_sv = Nullsv;
802 case OP_METHOD_NAMED:
804 SvREFCNT_dec(cSVOPo->op_sv);
805 cSVOPo->op_sv = Nullsv;
811 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
815 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
816 SvREFCNT_dec(cSVOPo->op_sv);
817 cSVOPo->op_sv = Nullsv;
820 Safefree(cPVOPo->op_pv);
821 cPVOPo->op_pv = Nullch;
825 op_free(cPMOPo->op_pmreplroot);
829 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
831 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
832 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
833 /* No GvIN_PAD_off(gv) here, because other references may still
834 * exist on the pad */
839 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
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 if (o->op_private & OPpREPEAT_DOLIST)
957 null(((LISTOP*)cBINOPo->op_first)->op_first);
958 scalar(cBINOPo->op_first);
963 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
967 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
968 if (!kPMOP->op_pmreplroot)
969 deprecate("implicit split to @_");
977 if (o->op_flags & OPf_KIDS) {
978 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
984 kid = cLISTOPo->op_first;
986 while ((kid = kid->op_sibling)) {
992 WITH_THR(PL_curcop = &PL_compiling);
997 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1003 WITH_THR(PL_curcop = &PL_compiling);
1010 Perl_scalarvoid(pTHX_ OP *o)
1017 if (o->op_type == OP_NEXTSTATE
1018 || o->op_type == OP_SETSTATE
1019 || o->op_type == OP_DBSTATE
1020 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1021 || o->op_targ == OP_SETSTATE
1022 || o->op_targ == OP_DBSTATE)))
1023 PL_curcop = (COP*)o; /* for warning below */
1025 /* assumes no premature commitment */
1026 want = o->op_flags & OPf_WANT;
1027 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1028 || o->op_type == OP_RETURN)
1033 if ((o->op_private & OPpTARGET_MY)
1034 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1036 return scalar(o); /* As if inside SASSIGN */
1039 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1041 switch (o->op_type) {
1043 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1047 if (o->op_flags & OPf_STACKED)
1051 if (o->op_private == 4)
1093 case OP_GETSOCKNAME:
1094 case OP_GETPEERNAME:
1099 case OP_GETPRIORITY:
1122 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1123 useless = PL_op_desc[o->op_type];
1130 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1131 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1132 useless = "a variable";
1137 if (cSVOPo->op_private & OPpCONST_STRICT)
1138 no_bareword_allowed(o);
1140 if (ckWARN(WARN_VOID)) {
1141 useless = "a constant";
1142 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1144 else if (SvPOK(sv)) {
1145 /* perl4's way of mixing documentation and code
1146 (before the invention of POD) was based on a
1147 trick to mix nroff and perl code. The trick was
1148 built upon these three nroff macros being used in
1149 void context. The pink camel has the details in
1150 the script wrapman near page 319. */
1151 if (strnEQ(SvPVX(sv), "di", 2) ||
1152 strnEQ(SvPVX(sv), "ds", 2) ||
1153 strnEQ(SvPVX(sv), "ig", 2))
1158 null(o); /* don't execute or even remember it */
1162 o->op_type = OP_PREINC; /* pre-increment is faster */
1163 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1167 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1168 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1174 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1179 if (o->op_flags & OPf_STACKED)
1186 if (!(o->op_flags & OPf_KIDS))
1195 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1202 /* all requires must return a boolean value */
1203 o->op_flags &= ~OPf_WANT;
1208 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1209 if (!kPMOP->op_pmreplroot)
1210 deprecate("implicit split to @_");
1214 if (useless && ckWARN(WARN_VOID))
1215 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1220 Perl_listkids(pTHX_ OP *o)
1223 if (o && o->op_flags & OPf_KIDS) {
1224 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1231 Perl_list(pTHX_ OP *o)
1235 /* assumes no premature commitment */
1236 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1237 || o->op_type == OP_RETURN)
1242 if ((o->op_private & OPpTARGET_MY)
1243 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1245 return o; /* As if inside SASSIGN */
1248 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1250 switch (o->op_type) {
1253 list(cBINOPo->op_first);
1258 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1266 if (!(o->op_flags & OPf_KIDS))
1268 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1269 list(cBINOPo->op_first);
1270 return gen_constant_list(o);
1277 kid = cLISTOPo->op_first;
1279 while ((kid = kid->op_sibling)) {
1280 if (kid->op_sibling)
1285 WITH_THR(PL_curcop = &PL_compiling);
1289 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1290 if (kid->op_sibling)
1295 WITH_THR(PL_curcop = &PL_compiling);
1298 /* all requires must return a boolean value */
1299 o->op_flags &= ~OPf_WANT;
1306 Perl_scalarseq(pTHX_ OP *o)
1311 if (o->op_type == OP_LINESEQ ||
1312 o->op_type == OP_SCOPE ||
1313 o->op_type == OP_LEAVE ||
1314 o->op_type == OP_LEAVETRY)
1316 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1317 if (kid->op_sibling) {
1321 PL_curcop = &PL_compiling;
1323 o->op_flags &= ~OPf_PARENS;
1324 if (PL_hints & HINT_BLOCK_SCOPE)
1325 o->op_flags |= OPf_PARENS;
1328 o = newOP(OP_STUB, 0);
1333 S_modkids(pTHX_ OP *o, I32 type)
1336 if (o && o->op_flags & OPf_KIDS) {
1337 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1344 Perl_mod(pTHX_ OP *o, I32 type)
1349 if (!o || PL_error_count)
1352 if ((o->op_private & OPpTARGET_MY)
1353 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1358 switch (o->op_type) {
1363 if (o->op_private & (OPpCONST_BARE) &&
1364 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1365 SV *sv = ((SVOP*)o)->op_sv;
1368 /* Could be a filehandle */
1369 if (gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO)) {
1370 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1374 /* OK, it's a sub */
1376 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1378 enter = newUNOP(OP_ENTERSUB,0,
1379 newUNOP(OP_RV2CV, 0,
1380 newGVOP(OP_GV, 0, gv)
1382 enter->op_private |= OPpLVAL_INTRO;
1388 if (!(o->op_private & (OPpCONST_ARYBASE)))
1390 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1391 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1395 SAVEI32(PL_compiling.cop_arybase);
1396 PL_compiling.cop_arybase = 0;
1398 else if (type == OP_REFGEN)
1401 Perl_croak(aTHX_ "That use of $[ is unsupported");
1404 if (o->op_flags & OPf_PARENS)
1408 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1409 !(o->op_flags & OPf_STACKED)) {
1410 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1411 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1412 assert(cUNOPo->op_first->op_type == OP_NULL);
1413 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1416 else { /* lvalue subroutine call */
1417 o->op_private |= OPpLVAL_INTRO;
1418 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1419 /* Backward compatibility mode: */
1420 o->op_private |= OPpENTERSUB_INARGS;
1423 else { /* Compile-time error message: */
1424 OP *kid = cUNOPo->op_first;
1428 if (kid->op_type == OP_PUSHMARK)
1430 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1432 "panic: unexpected lvalue entersub "
1433 "args: type/targ %ld:%ld",
1434 (long)kid->op_type,kid->op_targ);
1435 kid = kLISTOP->op_first;
1437 while (kid->op_sibling)
1438 kid = kid->op_sibling;
1439 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1441 if (kid->op_type == OP_METHOD_NAMED
1442 || kid->op_type == OP_METHOD)
1446 if (kid->op_sibling || kid->op_next != kid) {
1447 yyerror("panic: unexpected optree near method call");
1451 NewOp(1101, newop, 1, UNOP);
1452 newop->op_type = OP_RV2CV;
1453 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1454 newop->op_first = Nullop;
1455 newop->op_next = (OP*)newop;
1456 kid->op_sibling = (OP*)newop;
1457 newop->op_private |= OPpLVAL_INTRO;
1461 if (kid->op_type != OP_RV2CV)
1463 "panic: unexpected lvalue entersub "
1464 "entry via type/targ %ld:%ld",
1465 (long)kid->op_type,kid->op_targ);
1466 kid->op_private |= OPpLVAL_INTRO;
1467 break; /* Postpone until runtime */
1471 kid = kUNOP->op_first;
1472 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1473 kid = kUNOP->op_first;
1474 if (kid->op_type == OP_NULL)
1476 "Unexpected constant lvalue entersub "
1477 "entry via type/targ %ld:%ld",
1478 (long)kid->op_type,kid->op_targ);
1479 if (kid->op_type != OP_GV) {
1480 /* Restore RV2CV to check lvalueness */
1482 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1483 okid->op_next = kid->op_next;
1484 kid->op_next = okid;
1487 okid->op_next = Nullop;
1488 okid->op_type = OP_RV2CV;
1490 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1491 okid->op_private |= OPpLVAL_INTRO;
1495 cv = GvCV(kGVOP_gv);
1505 /* grep, foreach, subcalls, refgen */
1506 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1508 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1509 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1511 : (o->op_type == OP_ENTERSUB
1512 ? "non-lvalue subroutine call"
1513 : PL_op_desc[o->op_type])),
1514 type ? PL_op_desc[type] : "local"));
1528 case OP_RIGHT_SHIFT:
1537 if (!(o->op_flags & OPf_STACKED))
1543 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1549 if (!type && cUNOPo->op_first->op_type != OP_GV)
1550 Perl_croak(aTHX_ "Can't localize through a reference");
1551 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1552 PL_modcount = 10000;
1553 return o; /* Treat \(@foo) like ordinary list. */
1557 if (scalar_mod_type(o, type))
1559 ref(cUNOPo->op_first, o->op_type);
1568 PL_modcount = 10000;
1571 if (!type && cUNOPo->op_first->op_type != OP_GV)
1572 Perl_croak(aTHX_ "Can't localize through a reference");
1573 ref(cUNOPo->op_first, o->op_type);
1577 PL_hints |= HINT_BLOCK_SCOPE;
1587 PL_modcount = 10000;
1588 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1589 return o; /* Treat \(@foo) like ordinary list. */
1590 if (scalar_mod_type(o, type))
1596 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1597 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1602 PL_modcount++; /* XXX ??? */
1604 #endif /* USE_THREADS */
1610 if (type != OP_SASSIGN)
1614 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1620 pad_free(o->op_targ);
1621 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1622 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1623 if (o->op_flags & OPf_KIDS)
1624 mod(cBINOPo->op_first->op_sibling, type);
1629 ref(cBINOPo->op_first, o->op_type);
1630 if (type == OP_ENTERSUB &&
1631 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1632 o->op_private |= OPpLVAL_DEFER;
1639 if (o->op_flags & OPf_KIDS)
1640 mod(cLISTOPo->op_last, type);
1644 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1646 else if (!(o->op_flags & OPf_KIDS))
1648 if (o->op_targ != OP_LIST) {
1649 mod(cBINOPo->op_first, type);
1654 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1658 o->op_flags |= OPf_MOD;
1660 if (type == OP_AASSIGN || type == OP_SASSIGN)
1661 o->op_flags |= OPf_SPECIAL|OPf_REF;
1663 o->op_private |= OPpLVAL_INTRO;
1664 o->op_flags &= ~OPf_SPECIAL;
1665 PL_hints |= HINT_BLOCK_SCOPE;
1667 else if (type != OP_GREPSTART && type != OP_ENTERSUB)
1668 o->op_flags |= OPf_REF;
1673 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1677 if (o->op_type == OP_RV2GV)
1701 case OP_RIGHT_SHIFT:
1720 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1722 switch (o->op_type) {
1730 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1743 Perl_refkids(pTHX_ OP *o, I32 type)
1746 if (o && o->op_flags & OPf_KIDS) {
1747 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1754 Perl_ref(pTHX_ OP *o, I32 type)
1758 if (!o || PL_error_count)
1761 switch (o->op_type) {
1763 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1764 !(o->op_flags & OPf_STACKED)) {
1765 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1766 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1767 assert(cUNOPo->op_first->op_type == OP_NULL);
1768 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1769 o->op_flags |= OPf_SPECIAL;
1774 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1778 if (type == OP_DEFINED)
1779 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1780 ref(cUNOPo->op_first, o->op_type);
1783 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1784 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1785 : type == OP_RV2HV ? OPpDEREF_HV
1787 o->op_flags |= OPf_MOD;
1792 o->op_flags |= OPf_MOD; /* XXX ??? */
1797 o->op_flags |= OPf_REF;
1800 if (type == OP_DEFINED)
1801 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1802 ref(cUNOPo->op_first, o->op_type);
1807 o->op_flags |= OPf_REF;
1812 if (!(o->op_flags & OPf_KIDS))
1814 ref(cBINOPo->op_first, type);
1818 ref(cBINOPo->op_first, o->op_type);
1819 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1820 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1821 : type == OP_RV2HV ? OPpDEREF_HV
1823 o->op_flags |= OPf_MOD;
1831 if (!(o->op_flags & OPf_KIDS))
1833 ref(cLISTOPo->op_last, type);
1843 S_dup_attrlist(pTHX_ OP *o)
1847 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1848 * where the first kid is OP_PUSHMARK and the remaining ones
1849 * are OP_CONST. We need to push the OP_CONST values.
1851 if (o->op_type == OP_CONST)
1852 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1854 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1855 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1856 if (o->op_type == OP_CONST)
1857 rop = append_elem(OP_LIST, rop,
1858 newSVOP(OP_CONST, o->op_flags,
1859 SvREFCNT_inc(cSVOPo->op_sv)));
1866 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1870 /* fake up C<use attributes $pkg,$rv,@attrs> */
1871 ENTER; /* need to protect against side-effects of 'use' */
1873 if (stash && HvNAME(stash))
1874 stashsv = newSVpv(HvNAME(stash), 0);
1876 stashsv = &PL_sv_no;
1878 #define ATTRSMODULE "attributes"
1880 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1881 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1883 prepend_elem(OP_LIST,
1884 newSVOP(OP_CONST, 0, stashsv),
1885 prepend_elem(OP_LIST,
1886 newSVOP(OP_CONST, 0,
1888 dup_attrlist(attrs))));
1893 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1894 char *attrstr, STRLEN len)
1899 len = strlen(attrstr);
1903 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1905 char *sstr = attrstr;
1906 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1907 attrs = append_elem(OP_LIST, attrs,
1908 newSVOP(OP_CONST, 0,
1909 newSVpvn(sstr, attrstr-sstr)));
1913 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1914 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1915 Nullsv, prepend_elem(OP_LIST,
1916 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1917 prepend_elem(OP_LIST,
1918 newSVOP(OP_CONST, 0,
1924 S_my_kid(pTHX_ OP *o, OP *attrs)
1929 if (!o || PL_error_count)
1933 if (type == OP_LIST) {
1934 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1936 } else if (type == OP_UNDEF) {
1938 } else if (type == OP_RV2SV || /* "our" declaration */
1940 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1941 o->op_private |= OPpOUR_INTRO;
1943 } else if (type != OP_PADSV &&
1946 type != OP_PUSHMARK)
1948 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1949 PL_op_desc[o->op_type],
1950 PL_in_my == KEY_our ? "our" : "my"));
1953 else if (attrs && type != OP_PUSHMARK) {
1959 PL_in_my_stash = Nullhv;
1961 /* check for C<my Dog $spot> when deciding package */
1962 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1963 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1964 stash = SvSTASH(*namesvp);
1966 stash = PL_curstash;
1967 padsv = PAD_SV(o->op_targ);
1968 apply_attrs(stash, padsv, attrs);
1970 o->op_flags |= OPf_MOD;
1971 o->op_private |= OPpLVAL_INTRO;
1976 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1978 if (o->op_flags & OPf_PARENS)
1982 o = my_kid(o, attrs);
1984 PL_in_my_stash = Nullhv;
1989 Perl_my(pTHX_ OP *o)
1991 return my_kid(o, Nullop);
1995 Perl_sawparens(pTHX_ OP *o)
1998 o->op_flags |= OPf_PARENS;
2003 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2007 if (ckWARN(WARN_MISC) &&
2008 (left->op_type == OP_RV2AV ||
2009 left->op_type == OP_RV2HV ||
2010 left->op_type == OP_PADAV ||
2011 left->op_type == OP_PADHV)) {
2012 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2013 right->op_type == OP_TRANS)
2014 ? right->op_type : OP_MATCH];
2015 const char *sample = ((left->op_type == OP_RV2AV ||
2016 left->op_type == OP_PADAV)
2017 ? "@array" : "%hash");
2018 Perl_warner(aTHX_ WARN_MISC,
2019 "Applying %s to %s will act on scalar(%s)",
2020 desc, sample, sample);
2023 if (!(right->op_flags & OPf_STACKED) &&
2024 (right->op_type == OP_MATCH ||
2025 right->op_type == OP_SUBST ||
2026 right->op_type == OP_TRANS)) {
2027 right->op_flags |= OPf_STACKED;
2028 if (right->op_type != OP_MATCH &&
2029 ! (right->op_type == OP_TRANS &&
2030 right->op_private & OPpTRANS_IDENTICAL))
2031 left = mod(left, right->op_type);
2032 if (right->op_type == OP_TRANS)
2033 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2035 o = prepend_elem(right->op_type, scalar(left), right);
2037 return newUNOP(OP_NOT, 0, scalar(o));
2041 return bind_match(type, left,
2042 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2046 Perl_invert(pTHX_ OP *o)
2050 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2051 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2055 Perl_scope(pTHX_ OP *o)
2058 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2059 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2060 o->op_type = OP_LEAVE;
2061 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2064 if (o->op_type == OP_LINESEQ) {
2066 o->op_type = OP_SCOPE;
2067 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2068 kid = ((LISTOP*)o)->op_first;
2069 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2073 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2080 Perl_save_hints(pTHX)
2083 SAVESPTR(GvHV(PL_hintgv));
2084 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2085 SAVEFREESV(GvHV(PL_hintgv));
2089 Perl_block_start(pTHX_ int full)
2091 int retval = PL_savestack_ix;
2093 SAVEI32(PL_comppad_name_floor);
2094 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2096 PL_comppad_name_fill = PL_comppad_name_floor;
2097 if (PL_comppad_name_floor < 0)
2098 PL_comppad_name_floor = 0;
2099 SAVEI32(PL_min_intro_pending);
2100 SAVEI32(PL_max_intro_pending);
2101 PL_min_intro_pending = 0;
2102 SAVEI32(PL_comppad_name_fill);
2103 SAVEI32(PL_padix_floor);
2104 PL_padix_floor = PL_padix;
2105 PL_pad_reset_pending = FALSE;
2107 PL_hints &= ~HINT_BLOCK_SCOPE;
2108 SAVESPTR(PL_compiling.cop_warnings);
2109 if (! specialWARN(PL_compiling.cop_warnings)) {
2110 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2111 SAVEFREESV(PL_compiling.cop_warnings) ;
2113 SAVESPTR(PL_compiling.cop_io);
2114 if (! specialCopIO(PL_compiling.cop_io)) {
2115 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2116 SAVEFREESV(PL_compiling.cop_io) ;
2122 Perl_block_end(pTHX_ I32 floor, OP *seq)
2124 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2125 OP* retval = scalarseq(seq);
2127 PL_pad_reset_pending = FALSE;
2128 PL_compiling.op_private = PL_hints;
2130 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2131 pad_leavemy(PL_comppad_name_fill);
2140 OP *o = newOP(OP_THREADSV, 0);
2141 o->op_targ = find_threadsv("_");
2144 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2145 #endif /* USE_THREADS */
2149 Perl_newPROG(pTHX_ OP *o)
2154 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2155 ((PL_in_eval & EVAL_KEEPERR)
2156 ? OPf_SPECIAL : 0), o);
2157 PL_eval_start = linklist(PL_eval_root);
2158 PL_eval_root->op_private |= OPpREFCOUNTED;
2159 OpREFCNT_set(PL_eval_root, 1);
2160 PL_eval_root->op_next = 0;
2161 peep(PL_eval_start);
2166 PL_main_root = scope(sawparens(scalarvoid(o)));
2167 PL_curcop = &PL_compiling;
2168 PL_main_start = LINKLIST(PL_main_root);
2169 PL_main_root->op_private |= OPpREFCOUNTED;
2170 OpREFCNT_set(PL_main_root, 1);
2171 PL_main_root->op_next = 0;
2172 peep(PL_main_start);
2175 /* Register with debugger */
2177 CV *cv = get_cv("DB::postponed", FALSE);
2181 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2183 call_sv((SV*)cv, G_DISCARD);
2190 Perl_localize(pTHX_ OP *o, I32 lex)
2192 if (o->op_flags & OPf_PARENS)
2195 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2197 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2198 if (*s == ';' || *s == '=')
2199 Perl_warner(aTHX_ WARN_PARENTHESIS,
2200 "Parentheses missing around \"%s\" list",
2201 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2207 o = mod(o, OP_NULL); /* a bit kludgey */
2209 PL_in_my_stash = Nullhv;
2214 Perl_jmaybe(pTHX_ OP *o)
2216 if (o->op_type == OP_LIST) {
2219 o2 = newOP(OP_THREADSV, 0);
2220 o2->op_targ = find_threadsv(";");
2222 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2223 #endif /* USE_THREADS */
2224 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2230 Perl_fold_constants(pTHX_ register OP *o)
2233 I32 type = o->op_type;
2236 if (PL_opargs[type] & OA_RETSCALAR)
2238 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2239 o->op_targ = pad_alloc(type, SVs_PADTMP);
2241 /* integerize op, unless it happens to be C<-foo>.
2242 * XXX should pp_i_negate() do magic string negation instead? */
2243 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2244 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2245 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2247 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2250 if (!(PL_opargs[type] & OA_FOLDCONST))
2255 /* XXX might want a ck_negate() for this */
2256 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2269 if (o->op_private & OPpLOCALE)
2274 goto nope; /* Don't try to run w/ errors */
2276 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2277 if ((curop->op_type != OP_CONST ||
2278 (curop->op_private & OPpCONST_BARE)) &&
2279 curop->op_type != OP_LIST &&
2280 curop->op_type != OP_SCALAR &&
2281 curop->op_type != OP_NULL &&
2282 curop->op_type != OP_PUSHMARK)
2288 curop = LINKLIST(o);
2292 sv = *(PL_stack_sp--);
2293 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2294 pad_swipe(o->op_targ);
2295 else if (SvTEMP(sv)) { /* grab mortal temp? */
2296 (void)SvREFCNT_inc(sv);
2300 if (type == OP_RV2GV)
2301 return newGVOP(OP_GV, 0, (GV*)sv);
2303 /* try to smush double to int, but don't smush -2.0 to -2 */
2304 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2307 #ifdef PERL_PRESERVE_IVUV
2308 /* Only bother to attempt to fold to IV if
2309 most operators will benefit */
2313 return newSVOP(OP_CONST, 0, sv);
2317 if (!(PL_opargs[type] & OA_OTHERINT))
2320 if (!(PL_hints & HINT_INTEGER)) {
2321 if (type == OP_MODULO
2322 || type == OP_DIVIDE
2323 || !(o->op_flags & OPf_KIDS))
2328 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2329 if (curop->op_type == OP_CONST) {
2330 if (SvIOK(((SVOP*)curop)->op_sv))
2334 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2338 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2345 Perl_gen_constant_list(pTHX_ register OP *o)
2348 I32 oldtmps_floor = PL_tmps_floor;
2352 return o; /* Don't attempt to run with errors */
2354 PL_op = curop = LINKLIST(o);
2361 PL_tmps_floor = oldtmps_floor;
2363 o->op_type = OP_RV2AV;
2364 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2365 curop = ((UNOP*)o)->op_first;
2366 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2373 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2378 if (!o || o->op_type != OP_LIST)
2379 o = newLISTOP(OP_LIST, 0, o, Nullop);
2381 o->op_flags &= ~OPf_WANT;
2383 if (!(PL_opargs[type] & OA_MARK))
2384 null(cLISTOPo->op_first);
2387 o->op_ppaddr = PL_ppaddr[type];
2388 o->op_flags |= flags;
2390 o = CHECKOP(type, o);
2391 if (o->op_type != type)
2394 if (cLISTOPo->op_children < 7) {
2395 /* XXX do we really need to do this if we're done appending?? */
2396 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2398 cLISTOPo->op_last = last; /* in case check substituted last arg */
2401 return fold_constants(o);
2404 /* List constructors */
2407 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2415 if (first->op_type != type
2416 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2418 return newLISTOP(type, 0, first, last);
2421 if (first->op_flags & OPf_KIDS)
2422 ((LISTOP*)first)->op_last->op_sibling = last;
2424 first->op_flags |= OPf_KIDS;
2425 ((LISTOP*)first)->op_first = last;
2427 ((LISTOP*)first)->op_last = last;
2428 ((LISTOP*)first)->op_children++;
2433 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2441 if (first->op_type != type)
2442 return prepend_elem(type, (OP*)first, (OP*)last);
2444 if (last->op_type != type)
2445 return append_elem(type, (OP*)first, (OP*)last);
2447 first->op_last->op_sibling = last->op_first;
2448 first->op_last = last->op_last;
2449 first->op_children += last->op_children;
2450 if (first->op_children)
2451 first->op_flags |= OPf_KIDS;
2453 #ifdef PL_OP_SLAB_ALLOC
2461 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2469 if (last->op_type == type) {
2470 if (type == OP_LIST) { /* already a PUSHMARK there */
2471 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2472 ((LISTOP*)last)->op_first->op_sibling = first;
2473 if (!(first->op_flags & OPf_PARENS))
2474 last->op_flags &= ~OPf_PARENS;
2477 if (!(last->op_flags & OPf_KIDS)) {
2478 ((LISTOP*)last)->op_last = first;
2479 last->op_flags |= OPf_KIDS;
2481 first->op_sibling = ((LISTOP*)last)->op_first;
2482 ((LISTOP*)last)->op_first = first;
2484 ((LISTOP*)last)->op_children++;
2488 return newLISTOP(type, 0, first, last);
2494 Perl_newNULLLIST(pTHX)
2496 return newOP(OP_STUB, 0);
2500 Perl_force_list(pTHX_ OP *o)
2502 if (!o || o->op_type != OP_LIST)
2503 o = newLISTOP(OP_LIST, 0, o, Nullop);
2509 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2513 NewOp(1101, listop, 1, LISTOP);
2515 listop->op_type = type;
2516 listop->op_ppaddr = PL_ppaddr[type];
2517 listop->op_children = (first != 0) + (last != 0);
2518 listop->op_flags = flags;
2522 else if (!first && last)
2525 first->op_sibling = last;
2526 listop->op_first = first;
2527 listop->op_last = last;
2528 if (type == OP_LIST) {
2530 pushop = newOP(OP_PUSHMARK, 0);
2531 pushop->op_sibling = first;
2532 listop->op_first = pushop;
2533 listop->op_flags |= OPf_KIDS;
2535 listop->op_last = pushop;
2537 else if (listop->op_children)
2538 listop->op_flags |= OPf_KIDS;
2544 Perl_newOP(pTHX_ I32 type, I32 flags)
2547 NewOp(1101, o, 1, OP);
2549 o->op_ppaddr = PL_ppaddr[type];
2550 o->op_flags = flags;
2553 o->op_private = 0 + (flags >> 8);
2554 if (PL_opargs[type] & OA_RETSCALAR)
2556 if (PL_opargs[type] & OA_TARGET)
2557 o->op_targ = pad_alloc(type, SVs_PADTMP);
2558 return CHECKOP(type, o);
2562 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2567 first = newOP(OP_STUB, 0);
2568 if (PL_opargs[type] & OA_MARK)
2569 first = force_list(first);
2571 NewOp(1101, unop, 1, UNOP);
2572 unop->op_type = type;
2573 unop->op_ppaddr = PL_ppaddr[type];
2574 unop->op_first = first;
2575 unop->op_flags = flags | OPf_KIDS;
2576 unop->op_private = 1 | (flags >> 8);
2577 unop = (UNOP*) CHECKOP(type, unop);
2581 return fold_constants((OP *) unop);
2585 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2588 NewOp(1101, binop, 1, BINOP);
2591 first = newOP(OP_NULL, 0);
2593 binop->op_type = type;
2594 binop->op_ppaddr = PL_ppaddr[type];
2595 binop->op_first = first;
2596 binop->op_flags = flags | OPf_KIDS;
2599 binop->op_private = 1 | (flags >> 8);
2602 binop->op_private = 2 | (flags >> 8);
2603 first->op_sibling = last;
2606 binop = (BINOP*)CHECKOP(type, binop);
2607 if (binop->op_next || binop->op_type != type)
2610 binop->op_last = binop->op_first->op_sibling;
2612 return fold_constants((OP *)binop);
2616 utf8compare(const void *a, const void *b)
2619 for (i = 0; i < 10; i++) {
2620 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2622 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2629 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2631 SV *tstr = ((SVOP*)expr)->op_sv;
2632 SV *rstr = ((SVOP*)repl)->op_sv;
2635 U8 *t = (U8*)SvPV(tstr, tlen);
2636 U8 *r = (U8*)SvPV(rstr, rlen);
2643 register short *tbl;
2645 complement = o->op_private & OPpTRANS_COMPLEMENT;
2646 del = o->op_private & OPpTRANS_DELETE;
2647 squash = o->op_private & OPpTRANS_SQUASH;
2650 o->op_private |= OPpTRANS_FROM_UTF;
2653 o->op_private |= OPpTRANS_TO_UTF;
2655 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2656 SV* listsv = newSVpvn("# comment\n",10);
2658 U8* tend = t + tlen;
2659 U8* rend = r + rlen;
2673 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2674 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2675 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2676 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2679 U8 tmpbuf[UTF8_MAXLEN+1];
2683 New(1109, cp, tlen, U8*);
2685 transv = newSVpvn("",0);
2694 qsort(cp, i, sizeof(U8*), utf8compare);
2695 for (j = 0; j < i; j++) {
2697 I32 cur = j < i ? cp[j+1] - s : tend - s;
2698 UV val = utf8_to_uv(s, cur, &ulen, 0);
2700 diff = val - nextmin;
2702 t = uv_to_utf8(tmpbuf,nextmin);
2703 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2705 t = uv_to_utf8(tmpbuf, val - 1);
2706 sv_catpvn(transv, "\377", 1);
2707 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2711 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2715 t = uv_to_utf8(tmpbuf,nextmin);
2716 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2717 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2718 sv_catpvn(transv, "\377", 1);
2719 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2720 t = (U8*)SvPVX(transv);
2721 tlen = SvCUR(transv);
2724 else if (!rlen && !del) {
2725 r = t; rlen = tlen; rend = tend;
2729 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2731 o->op_private |= OPpTRANS_IDENTICAL;
2735 while (t < tend || tfirst <= tlast) {
2736 /* see if we need more "t" chars */
2737 if (tfirst > tlast) {
2738 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2740 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2742 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2749 /* now see if we need more "r" chars */
2750 if (rfirst > rlast) {
2752 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2754 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2756 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2765 rfirst = rlast = 0xffffffff;
2769 /* now see which range will peter our first, if either. */
2770 tdiff = tlast - tfirst;
2771 rdiff = rlast - rfirst;
2778 if (rfirst == 0xffffffff) {
2779 diff = tdiff; /* oops, pretend rdiff is infinite */
2781 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2782 (long)tfirst, (long)tlast);
2784 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2788 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2789 (long)tfirst, (long)(tfirst + diff),
2792 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2793 (long)tfirst, (long)rfirst);
2795 if (rfirst + diff > max)
2796 max = rfirst + diff;
2799 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2810 else if (max > 0xff)
2815 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2816 SvREFCNT_dec(listsv);
2818 SvREFCNT_dec(transv);
2820 if (!del && havefinal)
2821 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2822 newSVuv((UV)final), 0);
2825 o->op_private |= OPpTRANS_GROWS;
2837 tbl = (short*)cPVOPo->op_pv;
2839 Zero(tbl, 256, short);
2840 for (i = 0; i < tlen; i++)
2842 for (i = 0, j = 0; i < 256; i++) {
2853 if (i < 128 && r[j] >= 128)
2861 if (!rlen && !del) {
2864 o->op_private |= OPpTRANS_IDENTICAL;
2866 for (i = 0; i < 256; i++)
2868 for (i = 0, j = 0; i < tlen; i++,j++) {
2871 if (tbl[t[i]] == -1)
2877 if (tbl[t[i]] == -1) {
2878 if (t[i] < 128 && r[j] >= 128)
2885 o->op_private |= OPpTRANS_GROWS;
2893 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2897 NewOp(1101, pmop, 1, PMOP);
2898 pmop->op_type = type;
2899 pmop->op_ppaddr = PL_ppaddr[type];
2900 pmop->op_flags = flags;
2901 pmop->op_private = 0 | (flags >> 8);
2903 if (PL_hints & HINT_RE_TAINT)
2904 pmop->op_pmpermflags |= PMf_RETAINT;
2905 if (PL_hints & HINT_LOCALE)
2906 pmop->op_pmpermflags |= PMf_LOCALE;
2907 pmop->op_pmflags = pmop->op_pmpermflags;
2909 /* link into pm list */
2910 if (type != OP_TRANS && PL_curstash) {
2911 pmop->op_pmnext = HvPMROOT(PL_curstash);
2912 HvPMROOT(PL_curstash) = pmop;
2919 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2923 I32 repl_has_vars = 0;
2925 if (o->op_type == OP_TRANS)
2926 return pmtrans(o, expr, repl);
2928 PL_hints |= HINT_BLOCK_SCOPE;
2931 if (expr->op_type == OP_CONST) {
2933 SV *pat = ((SVOP*)expr)->op_sv;
2934 char *p = SvPV(pat, plen);
2935 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2936 sv_setpvn(pat, "\\s+", 3);
2937 p = SvPV(pat, plen);
2938 pm->op_pmflags |= PMf_SKIPWHITE;
2940 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2941 pm->op_pmdynflags |= PMdf_UTF8;
2942 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2943 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2944 pm->op_pmflags |= PMf_WHITE;
2948 if (PL_hints & HINT_UTF8)
2949 pm->op_pmdynflags |= PMdf_UTF8;
2950 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2951 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2953 : OP_REGCMAYBE),0,expr);
2955 NewOp(1101, rcop, 1, LOGOP);
2956 rcop->op_type = OP_REGCOMP;
2957 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2958 rcop->op_first = scalar(expr);
2959 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2960 ? (OPf_SPECIAL | OPf_KIDS)
2962 rcop->op_private = 1;
2965 /* establish postfix order */
2966 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2968 rcop->op_next = expr;
2969 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2972 rcop->op_next = LINKLIST(expr);
2973 expr->op_next = (OP*)rcop;
2976 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2981 if (pm->op_pmflags & PMf_EVAL) {
2983 if (CopLINE(PL_curcop) < PL_multi_end)
2984 CopLINE_set(PL_curcop, PL_multi_end);
2987 else if (repl->op_type == OP_THREADSV
2988 && strchr("&`'123456789+",
2989 PL_threadsv_names[repl->op_targ]))
2993 #endif /* USE_THREADS */
2994 else if (repl->op_type == OP_CONST)
2998 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2999 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3001 if (curop->op_type == OP_THREADSV) {
3003 if (strchr("&`'123456789+", curop->op_private))
3007 if (curop->op_type == OP_GV) {
3008 GV *gv = cGVOPx_gv(curop);
3010 if (strchr("&`'123456789+", *GvENAME(gv)))
3013 #endif /* USE_THREADS */
3014 else if (curop->op_type == OP_RV2CV)
3016 else if (curop->op_type == OP_RV2SV ||
3017 curop->op_type == OP_RV2AV ||
3018 curop->op_type == OP_RV2HV ||
3019 curop->op_type == OP_RV2GV) {
3020 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3023 else if (curop->op_type == OP_PADSV ||
3024 curop->op_type == OP_PADAV ||
3025 curop->op_type == OP_PADHV ||
3026 curop->op_type == OP_PADANY) {
3029 else if (curop->op_type == OP_PUSHRE)
3030 ; /* Okay here, dangerous in newASSIGNOP */
3039 && (!pm->op_pmregexp
3040 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3041 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3042 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3043 prepend_elem(o->op_type, scalar(repl), o);
3046 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3047 pm->op_pmflags |= PMf_MAYBE_CONST;
3048 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3050 NewOp(1101, rcop, 1, LOGOP);
3051 rcop->op_type = OP_SUBSTCONT;
3052 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3053 rcop->op_first = scalar(repl);
3054 rcop->op_flags |= OPf_KIDS;
3055 rcop->op_private = 1;
3058 /* establish postfix order */
3059 rcop->op_next = LINKLIST(repl);
3060 repl->op_next = (OP*)rcop;
3062 pm->op_pmreplroot = scalar((OP*)rcop);
3063 pm->op_pmreplstart = LINKLIST(rcop);
3072 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3075 NewOp(1101, svop, 1, SVOP);
3076 svop->op_type = type;
3077 svop->op_ppaddr = PL_ppaddr[type];
3079 svop->op_next = (OP*)svop;
3080 svop->op_flags = flags;
3081 if (PL_opargs[type] & OA_RETSCALAR)
3083 if (PL_opargs[type] & OA_TARGET)
3084 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3085 return CHECKOP(type, svop);
3089 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3092 NewOp(1101, padop, 1, PADOP);
3093 padop->op_type = type;
3094 padop->op_ppaddr = PL_ppaddr[type];
3095 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3096 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3097 PL_curpad[padop->op_padix] = sv;
3099 padop->op_next = (OP*)padop;
3100 padop->op_flags = flags;
3101 if (PL_opargs[type] & OA_RETSCALAR)
3103 if (PL_opargs[type] & OA_TARGET)
3104 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3105 return CHECKOP(type, padop);
3109 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3113 return newPADOP(type, flags, SvREFCNT_inc(gv));
3115 return newSVOP(type, flags, SvREFCNT_inc(gv));
3120 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3123 NewOp(1101, pvop, 1, PVOP);
3124 pvop->op_type = type;
3125 pvop->op_ppaddr = PL_ppaddr[type];
3127 pvop->op_next = (OP*)pvop;
3128 pvop->op_flags = flags;
3129 if (PL_opargs[type] & OA_RETSCALAR)
3131 if (PL_opargs[type] & OA_TARGET)
3132 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3133 return CHECKOP(type, pvop);
3137 Perl_package(pTHX_ OP *o)
3141 save_hptr(&PL_curstash);
3142 save_item(PL_curstname);
3147 name = SvPV(sv, len);
3148 PL_curstash = gv_stashpvn(name,len,TRUE);
3149 sv_setpvn(PL_curstname, name, len);
3153 sv_setpv(PL_curstname,"<none>");
3154 PL_curstash = Nullhv;
3156 PL_hints |= HINT_BLOCK_SCOPE;
3157 PL_copline = NOLINE;
3162 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3170 if (id->op_type != OP_CONST)
3171 Perl_croak(aTHX_ "Module name must be constant");
3175 if (version != Nullop) {
3176 SV *vesv = ((SVOP*)version)->op_sv;
3178 if (arg == Nullop && !SvNIOKp(vesv)) {
3185 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3186 Perl_croak(aTHX_ "Version number must be constant number");
3188 /* Make copy of id so we don't free it twice */
3189 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3191 /* Fake up a method call to VERSION */
3192 meth = newSVpvn("VERSION",7);
3193 sv_upgrade(meth, SVt_PVIV);
3194 (void)SvIOK_on(meth);
3195 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3196 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3197 append_elem(OP_LIST,
3198 prepend_elem(OP_LIST, pack, list(version)),
3199 newSVOP(OP_METHOD_NAMED, 0, meth)));
3203 /* Fake up an import/unimport */
3204 if (arg && arg->op_type == OP_STUB)
3205 imop = arg; /* no import on explicit () */
3206 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3207 imop = Nullop; /* use 5.0; */
3212 /* Make copy of id so we don't free it twice */
3213 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3215 /* Fake up a method call to import/unimport */
3216 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3217 sv_upgrade(meth, SVt_PVIV);
3218 (void)SvIOK_on(meth);
3219 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3220 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3221 append_elem(OP_LIST,
3222 prepend_elem(OP_LIST, pack, list(arg)),
3223 newSVOP(OP_METHOD_NAMED, 0, meth)));
3226 /* Fake up a require, handle override, if any */
3227 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3228 if (!(gv && GvIMPORTED_CV(gv)))
3229 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3231 if (gv && GvIMPORTED_CV(gv)) {
3232 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3233 append_elem(OP_LIST, id,
3234 scalar(newUNOP(OP_RV2CV, 0,
3239 rqop = newUNOP(OP_REQUIRE, 0, id);
3242 /* Fake up the BEGIN {}, which does its thing immediately. */
3244 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3247 append_elem(OP_LINESEQ,
3248 append_elem(OP_LINESEQ,
3249 newSTATEOP(0, Nullch, rqop),
3250 newSTATEOP(0, Nullch, veop)),
3251 newSTATEOP(0, Nullch, imop) ));
3253 PL_hints |= HINT_BLOCK_SCOPE;
3254 PL_copline = NOLINE;
3259 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3262 va_start(args, ver);
3263 vload_module(flags, name, ver, &args);
3267 #ifdef PERL_IMPLICIT_CONTEXT
3269 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3273 va_start(args, ver);
3274 vload_module(flags, name, ver, &args);
3280 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3282 OP *modname, *veop, *imop;
3284 modname = newSVOP(OP_CONST, 0, name);
3285 modname->op_private |= OPpCONST_BARE;
3287 veop = newSVOP(OP_CONST, 0, ver);
3291 if (flags & PERL_LOADMOD_NOIMPORT) {
3292 imop = sawparens(newNULLLIST());
3294 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3295 imop = va_arg(*args, OP*);
3300 sv = va_arg(*args, SV*);
3302 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3303 sv = va_arg(*args, SV*);
3307 line_t ocopline = PL_copline;
3308 int oexpect = PL_expect;
3310 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3311 veop, modname, imop);
3312 PL_expect = oexpect;
3313 PL_copline = ocopline;
3318 Perl_dofile(pTHX_ OP *term)
3323 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3324 if (!(gv && GvIMPORTED_CV(gv)))
3325 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3327 if (gv && GvIMPORTED_CV(gv)) {
3328 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3329 append_elem(OP_LIST, term,
3330 scalar(newUNOP(OP_RV2CV, 0,
3335 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3341 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3343 return newBINOP(OP_LSLICE, flags,
3344 list(force_list(subscript)),
3345 list(force_list(listval)) );
3349 S_list_assignment(pTHX_ register OP *o)
3354 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3355 o = cUNOPo->op_first;
3357 if (o->op_type == OP_COND_EXPR) {
3358 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3359 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3364 yyerror("Assignment to both a list and a scalar");
3368 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3369 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3370 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3373 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3376 if (o->op_type == OP_RV2SV)
3383 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3388 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3389 return newLOGOP(optype, 0,
3390 mod(scalar(left), optype),
3391 newUNOP(OP_SASSIGN, 0, scalar(right)));
3394 return newBINOP(optype, OPf_STACKED,
3395 mod(scalar(left), optype), scalar(right));
3399 if (list_assignment(left)) {
3403 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3404 left = mod(left, OP_AASSIGN);
3412 curop = list(force_list(left));
3413 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3414 o->op_private = 0 | (flags >> 8);
3415 for (curop = ((LISTOP*)curop)->op_first;
3416 curop; curop = curop->op_sibling)
3418 if (curop->op_type == OP_RV2HV &&
3419 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3420 o->op_private |= OPpASSIGN_HASH;
3424 if (!(left->op_private & OPpLVAL_INTRO)) {
3427 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3428 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3429 if (curop->op_type == OP_GV) {
3430 GV *gv = cGVOPx_gv(curop);
3431 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3433 SvCUR(gv) = PL_generation;
3435 else if (curop->op_type == OP_PADSV ||
3436 curop->op_type == OP_PADAV ||
3437 curop->op_type == OP_PADHV ||
3438 curop->op_type == OP_PADANY) {
3439 SV **svp = AvARRAY(PL_comppad_name);
3440 SV *sv = svp[curop->op_targ];
3441 if (SvCUR(sv) == PL_generation)
3443 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3445 else if (curop->op_type == OP_RV2CV)
3447 else if (curop->op_type == OP_RV2SV ||
3448 curop->op_type == OP_RV2AV ||
3449 curop->op_type == OP_RV2HV ||
3450 curop->op_type == OP_RV2GV) {
3451 if (lastop->op_type != OP_GV) /* funny deref? */
3454 else if (curop->op_type == OP_PUSHRE) {
3455 if (((PMOP*)curop)->op_pmreplroot) {
3457 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3459 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3461 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3463 SvCUR(gv) = PL_generation;
3472 o->op_private |= OPpASSIGN_COMMON;
3474 if (right && right->op_type == OP_SPLIT) {
3476 if ((tmpop = ((LISTOP*)right)->op_first) &&
3477 tmpop->op_type == OP_PUSHRE)
3479 PMOP *pm = (PMOP*)tmpop;
3480 if (left->op_type == OP_RV2AV &&
3481 !(left->op_private & OPpLVAL_INTRO) &&
3482 !(o->op_private & OPpASSIGN_COMMON) )
3484 tmpop = ((UNOP*)left)->op_first;
3485 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3487 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3488 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3490 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3491 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3493 pm->op_pmflags |= PMf_ONCE;
3494 tmpop = cUNOPo->op_first; /* to list (nulled) */
3495 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3496 tmpop->op_sibling = Nullop; /* don't free split */
3497 right->op_next = tmpop->op_next; /* fix starting loc */
3498 op_free(o); /* blow off assign */
3499 right->op_flags &= ~OPf_WANT;
3500 /* "I don't know and I don't care." */
3505 if (PL_modcount < 10000 &&
3506 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3508 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3510 sv_setiv(sv, PL_modcount+1);
3518 right = newOP(OP_UNDEF, 0);
3519 if (right->op_type == OP_READLINE) {
3520 right->op_flags |= OPf_STACKED;
3521 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3524 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3525 o = newBINOP(OP_SASSIGN, flags,
3526 scalar(right), mod(scalar(left), OP_SASSIGN) );
3538 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3540 U32 seq = intro_my();
3543 NewOp(1101, cop, 1, COP);
3544 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3545 cop->op_type = OP_DBSTATE;
3546 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3549 cop->op_type = OP_NEXTSTATE;
3550 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3552 cop->op_flags = flags;
3553 cop->op_private = (PL_hints & HINT_BYTE);
3555 cop->op_private |= NATIVE_HINTS;
3557 PL_compiling.op_private = cop->op_private;
3558 cop->op_next = (OP*)cop;
3561 cop->cop_label = label;
3562 PL_hints |= HINT_BLOCK_SCOPE;
3565 cop->cop_arybase = PL_curcop->cop_arybase;
3566 if (specialWARN(PL_curcop->cop_warnings))
3567 cop->cop_warnings = PL_curcop->cop_warnings ;
3569 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3570 if (specialCopIO(PL_curcop->cop_io))
3571 cop->cop_io = PL_curcop->cop_io;
3573 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3576 if (PL_copline == NOLINE)
3577 CopLINE_set(cop, CopLINE(PL_curcop));
3579 CopLINE_set(cop, PL_copline);
3580 PL_copline = NOLINE;
3583 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3585 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3587 CopSTASH_set(cop, PL_curstash);
3589 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3590 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3591 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3592 (void)SvIOK_on(*svp);
3593 SvIVX(*svp) = PTR2IV(cop);
3597 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3600 /* "Introduce" my variables to visible status. */
3608 if (! PL_min_intro_pending)
3609 return PL_cop_seqmax;
3611 svp = AvARRAY(PL_comppad_name);
3612 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3613 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3614 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3615 SvNVX(sv) = (NV)PL_cop_seqmax;
3618 PL_min_intro_pending = 0;
3619 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3620 return PL_cop_seqmax++;
3624 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3626 return new_logop(type, flags, &first, &other);
3630 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3634 OP *first = *firstp;
3635 OP *other = *otherp;
3637 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3638 return newBINOP(type, flags, scalar(first), scalar(other));
3640 scalarboolean(first);
3641 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3642 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3643 if (type == OP_AND || type == OP_OR) {
3649 first = *firstp = cUNOPo->op_first;
3651 first->op_next = o->op_next;
3652 cUNOPo->op_first = Nullop;
3656 if (first->op_type == OP_CONST) {
3657 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3658 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3659 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3670 else if (first->op_type == OP_WANTARRAY) {
3676 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3677 OP *k1 = ((UNOP*)first)->op_first;
3678 OP *k2 = k1->op_sibling;
3680 switch (first->op_type)
3683 if (k2 && k2->op_type == OP_READLINE
3684 && (k2->op_flags & OPf_STACKED)
3685 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3687 warnop = k2->op_type;
3692 if (k1->op_type == OP_READDIR
3693 || k1->op_type == OP_GLOB
3694 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3695 || k1->op_type == OP_EACH)
3697 warnop = ((k1->op_type == OP_NULL)
3698 ? k1->op_targ : k1->op_type);
3703 line_t oldline = CopLINE(PL_curcop);
3704 CopLINE_set(PL_curcop, PL_copline);
3705 Perl_warner(aTHX_ WARN_MISC,
3706 "Value of %s%s can be \"0\"; test with defined()",
3708 ((warnop == OP_READLINE || warnop == OP_GLOB)
3709 ? " construct" : "() operator"));
3710 CopLINE_set(PL_curcop, oldline);
3717 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3718 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3720 NewOp(1101, logop, 1, LOGOP);
3722 logop->op_type = type;
3723 logop->op_ppaddr = PL_ppaddr[type];
3724 logop->op_first = first;
3725 logop->op_flags = flags | OPf_KIDS;
3726 logop->op_other = LINKLIST(other);
3727 logop->op_private = 1 | (flags >> 8);
3729 /* establish postfix order */
3730 logop->op_next = LINKLIST(first);
3731 first->op_next = (OP*)logop;
3732 first->op_sibling = other;
3734 o = newUNOP(OP_NULL, 0, (OP*)logop);
3741 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3748 return newLOGOP(OP_AND, 0, first, trueop);
3750 return newLOGOP(OP_OR, 0, first, falseop);
3752 scalarboolean(first);
3753 if (first->op_type == OP_CONST) {
3754 if (SvTRUE(((SVOP*)first)->op_sv)) {
3765 else if (first->op_type == OP_WANTARRAY) {
3769 NewOp(1101, logop, 1, LOGOP);
3770 logop->op_type = OP_COND_EXPR;
3771 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3772 logop->op_first = first;
3773 logop->op_flags = flags | OPf_KIDS;
3774 logop->op_private = 1 | (flags >> 8);
3775 logop->op_other = LINKLIST(trueop);
3776 logop->op_next = LINKLIST(falseop);
3779 /* establish postfix order */
3780 start = LINKLIST(first);
3781 first->op_next = (OP*)logop;
3783 first->op_sibling = trueop;
3784 trueop->op_sibling = falseop;
3785 o = newUNOP(OP_NULL, 0, (OP*)logop);
3787 trueop->op_next = falseop->op_next = o;
3794 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3802 NewOp(1101, range, 1, LOGOP);
3804 range->op_type = OP_RANGE;
3805 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3806 range->op_first = left;
3807 range->op_flags = OPf_KIDS;
3808 leftstart = LINKLIST(left);
3809 range->op_other = LINKLIST(right);
3810 range->op_private = 1 | (flags >> 8);
3812 left->op_sibling = right;
3814 range->op_next = (OP*)range;
3815 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3816 flop = newUNOP(OP_FLOP, 0, flip);
3817 o = newUNOP(OP_NULL, 0, flop);
3819 range->op_next = leftstart;
3821 left->op_next = flip;
3822 right->op_next = flop;
3824 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3825 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3826 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3827 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3829 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3830 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3833 if (!flip->op_private || !flop->op_private)
3834 linklist(o); /* blow off optimizer unless constant */
3840 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3844 int once = block && block->op_flags & OPf_SPECIAL &&
3845 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3848 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3849 return block; /* do {} while 0 does once */
3850 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3851 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3852 expr = newUNOP(OP_DEFINED, 0,
3853 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3854 } else if (expr->op_flags & OPf_KIDS) {
3855 OP *k1 = ((UNOP*)expr)->op_first;
3856 OP *k2 = (k1) ? k1->op_sibling : NULL;
3857 switch (expr->op_type) {
3859 if (k2 && k2->op_type == OP_READLINE
3860 && (k2->op_flags & OPf_STACKED)
3861 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3862 expr = newUNOP(OP_DEFINED, 0, expr);
3866 if (k1->op_type == OP_READDIR
3867 || k1->op_type == OP_GLOB
3868 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3869 || k1->op_type == OP_EACH)
3870 expr = newUNOP(OP_DEFINED, 0, expr);
3876 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3877 o = new_logop(OP_AND, 0, &expr, &listop);
3880 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3882 if (once && o != listop)
3883 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3886 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3888 o->op_flags |= flags;
3890 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3895 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3904 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3905 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3906 expr = newUNOP(OP_DEFINED, 0,
3907 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3908 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3909 OP *k1 = ((UNOP*)expr)->op_first;
3910 OP *k2 = (k1) ? k1->op_sibling : NULL;
3911 switch (expr->op_type) {
3913 if (k2 && k2->op_type == OP_READLINE
3914 && (k2->op_flags & OPf_STACKED)
3915 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3916 expr = newUNOP(OP_DEFINED, 0, expr);
3920 if (k1->op_type == OP_READDIR
3921 || k1->op_type == OP_GLOB
3922 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3923 || k1->op_type == OP_EACH)
3924 expr = newUNOP(OP_DEFINED, 0, expr);
3930 block = newOP(OP_NULL, 0);
3932 block = scope(block);
3936 next = LINKLIST(cont);
3939 OP *unstack = newOP(OP_UNSTACK, 0);
3942 cont = append_elem(OP_LINESEQ, cont, unstack);
3943 if ((line_t)whileline != NOLINE) {
3944 PL_copline = whileline;
3945 cont = append_elem(OP_LINESEQ, cont,
3946 newSTATEOP(0, Nullch, Nullop));
3950 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3951 redo = LINKLIST(listop);
3954 PL_copline = whileline;
3956 o = new_logop(OP_AND, 0, &expr, &listop);
3957 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3958 op_free(expr); /* oops, it's a while (0) */
3960 return Nullop; /* listop already freed by new_logop */
3963 ((LISTOP*)listop)->op_last->op_next = condop =
3964 (o == listop ? redo : LINKLIST(o));
3970 NewOp(1101,loop,1,LOOP);
3971 loop->op_type = OP_ENTERLOOP;
3972 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3973 loop->op_private = 0;
3974 loop->op_next = (OP*)loop;
3977 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3979 loop->op_redoop = redo;
3980 loop->op_lastop = o;
3981 o->op_private |= loopflags;
3984 loop->op_nextop = next;
3986 loop->op_nextop = o;
3988 o->op_flags |= flags;
3989 o->op_private |= (flags >> 8);
3994 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4002 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4003 sv->op_type = OP_RV2GV;
4004 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4006 else if (sv->op_type == OP_PADSV) { /* private variable */
4007 padoff = sv->op_targ;
4012 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4013 padoff = sv->op_targ;
4015 iterflags |= OPf_SPECIAL;
4020 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4024 padoff = find_threadsv("_");
4025 iterflags |= OPf_SPECIAL;
4027 sv = newGVOP(OP_GV, 0, PL_defgv);
4030 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4031 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4032 iterflags |= OPf_STACKED;
4034 else if (expr->op_type == OP_NULL &&
4035 (expr->op_flags & OPf_KIDS) &&
4036 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4038 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4039 * set the STACKED flag to indicate that these values are to be
4040 * treated as min/max values by 'pp_iterinit'.
4042 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4043 LOGOP* range = (LOGOP*) flip->op_first;
4044 OP* left = range->op_first;
4045 OP* right = left->op_sibling;
4048 range->op_flags &= ~OPf_KIDS;
4049 range->op_first = Nullop;
4051 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4052 listop->op_first->op_next = range->op_next;
4053 left->op_next = range->op_other;
4054 right->op_next = (OP*)listop;
4055 listop->op_next = listop->op_first;
4058 expr = (OP*)(listop);
4060 iterflags |= OPf_STACKED;
4063 expr = mod(force_list(expr), OP_GREPSTART);
4067 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4068 append_elem(OP_LIST, expr, scalar(sv))));
4069 assert(!loop->op_next);
4070 #ifdef PL_OP_SLAB_ALLOC
4073 NewOp(1234,tmp,1,LOOP);
4074 Copy(loop,tmp,1,LOOP);
4078 Renew(loop, 1, LOOP);
4080 loop->op_targ = padoff;
4081 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4082 PL_copline = forline;
4083 return newSTATEOP(0, label, wop);
4087 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4092 if (type != OP_GOTO || label->op_type == OP_CONST) {
4093 /* "last()" means "last" */
4094 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4095 o = newOP(type, OPf_SPECIAL);
4097 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4098 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4104 if (label->op_type == OP_ENTERSUB)
4105 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4106 o = newUNOP(type, OPf_STACKED, label);
4108 PL_hints |= HINT_BLOCK_SCOPE;
4113 Perl_cv_undef(pTHX_ CV *cv)
4117 MUTEX_DESTROY(CvMUTEXP(cv));
4118 Safefree(CvMUTEXP(cv));
4121 #endif /* USE_THREADS */
4123 if (!CvXSUB(cv) && CvROOT(cv)) {
4125 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4126 Perl_croak(aTHX_ "Can't undef active subroutine");
4129 Perl_croak(aTHX_ "Can't undef active subroutine");
4130 #endif /* USE_THREADS */
4133 SAVEVPTR(PL_curpad);
4137 op_free(CvROOT(cv));
4138 CvROOT(cv) = Nullop;
4141 SvPOK_off((SV*)cv); /* forget prototype */
4143 SvREFCNT_dec(CvGV(cv));
4145 SvREFCNT_dec(CvOUTSIDE(cv));
4146 CvOUTSIDE(cv) = Nullcv;
4148 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4151 if (CvPADLIST(cv)) {
4152 /* may be during global destruction */
4153 if (SvREFCNT(CvPADLIST(cv))) {
4154 I32 i = AvFILLp(CvPADLIST(cv));
4156 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4157 SV* sv = svp ? *svp : Nullsv;
4160 if (sv == (SV*)PL_comppad_name)
4161 PL_comppad_name = Nullav;
4162 else if (sv == (SV*)PL_comppad) {
4163 PL_comppad = Nullav;
4164 PL_curpad = Null(SV**);
4168 SvREFCNT_dec((SV*)CvPADLIST(cv));
4170 CvPADLIST(cv) = Nullav;
4175 S_cv_dump(pTHX_ CV *cv)
4178 CV *outside = CvOUTSIDE(cv);
4179 AV* padlist = CvPADLIST(cv);
4186 PerlIO_printf(Perl_debug_log,
4187 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4189 (CvANON(cv) ? "ANON"
4190 : (cv == PL_main_cv) ? "MAIN"
4191 : CvUNIQUE(cv) ? "UNIQUE"
4192 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4195 : CvANON(outside) ? "ANON"
4196 : (outside == PL_main_cv) ? "MAIN"
4197 : CvUNIQUE(outside) ? "UNIQUE"
4198 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4203 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4204 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4205 pname = AvARRAY(pad_name);
4206 ppad = AvARRAY(pad);
4208 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4209 if (SvPOK(pname[ix]))
4210 PerlIO_printf(Perl_debug_log,
4211 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4212 (int)ix, PTR2UV(ppad[ix]),
4213 SvFAKE(pname[ix]) ? "FAKE " : "",
4215 (IV)I_32(SvNVX(pname[ix])),
4218 #endif /* DEBUGGING */
4222 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4226 AV* protopadlist = CvPADLIST(proto);
4227 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4228 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4229 SV** pname = AvARRAY(protopad_name);
4230 SV** ppad = AvARRAY(protopad);
4231 I32 fname = AvFILLp(protopad_name);
4232 I32 fpad = AvFILLp(protopad);
4236 assert(!CvUNIQUE(proto));
4240 SAVESPTR(PL_comppad_name);
4241 SAVESPTR(PL_compcv);
4243 cv = PL_compcv = (CV*)NEWSV(1104,0);
4244 sv_upgrade((SV *)cv, SvTYPE(proto));
4245 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4249 New(666, CvMUTEXP(cv), 1, perl_mutex);
4250 MUTEX_INIT(CvMUTEXP(cv));
4252 #endif /* USE_THREADS */
4253 CvFILE(cv) = CvFILE(proto);
4254 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4255 CvSTASH(cv) = CvSTASH(proto);
4256 CvROOT(cv) = CvROOT(proto);
4257 CvSTART(cv) = CvSTART(proto);
4259 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4262 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4264 PL_comppad_name = newAV();
4265 for (ix = fname; ix >= 0; ix--)
4266 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4268 PL_comppad = newAV();
4270 comppadlist = newAV();
4271 AvREAL_off(comppadlist);
4272 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4273 av_store(comppadlist, 1, (SV*)PL_comppad);
4274 CvPADLIST(cv) = comppadlist;
4275 av_fill(PL_comppad, AvFILLp(protopad));
4276 PL_curpad = AvARRAY(PL_comppad);
4278 av = newAV(); /* will be @_ */
4280 av_store(PL_comppad, 0, (SV*)av);
4281 AvFLAGS(av) = AVf_REIFY;
4283 for (ix = fpad; ix > 0; ix--) {
4284 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4285 if (namesv && namesv != &PL_sv_undef) {
4286 char *name = SvPVX(namesv); /* XXX */
4287 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4288 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4289 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4291 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4293 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4295 else { /* our own lexical */
4298 /* anon code -- we'll come back for it */
4299 sv = SvREFCNT_inc(ppad[ix]);
4301 else if (*name == '@')
4303 else if (*name == '%')
4312 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4313 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4316 SV* sv = NEWSV(0,0);
4322 /* Now that vars are all in place, clone nested closures. */
4324 for (ix = fpad; ix > 0; ix--) {
4325 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4327 && namesv != &PL_sv_undef
4328 && !(SvFLAGS(namesv) & SVf_FAKE)
4329 && *SvPVX(namesv) == '&'
4330 && CvCLONE(ppad[ix]))
4332 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4333 SvREFCNT_dec(ppad[ix]);
4336 PL_curpad[ix] = (SV*)kid;
4340 #ifdef DEBUG_CLOSURES
4341 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4343 PerlIO_printf(Perl_debug_log, " from:\n");
4345 PerlIO_printf(Perl_debug_log, " to:\n");
4352 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4354 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4356 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4363 Perl_cv_clone(pTHX_ CV *proto)
4366 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4367 cv = cv_clone2(proto, CvOUTSIDE(proto));
4368 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4373 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4375 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4376 SV* msg = sv_newmortal();
4380 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4381 sv_setpv(msg, "Prototype mismatch:");
4383 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4385 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4386 sv_catpv(msg, " vs ");
4388 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4390 sv_catpv(msg, "none");
4391 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4395 static void const_sv_xsub(pTHXo_ CV* cv);
4398 =for apidoc cv_const_sv
4400 If C<cv> is a constant sub eligible for inlining. returns the constant
4401 value returned by the sub. Otherwise, returns NULL.
4403 Constant subs can be created with C<newCONSTSUB> or as described in
4404 L<perlsub/"Constant Functions">.
4409 Perl_cv_const_sv(pTHX_ CV *cv)
4411 if (!cv || !CvCONST(cv))
4413 return (SV*)CvXSUBANY(cv).any_ptr;
4417 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4424 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4425 o = cLISTOPo->op_first->op_sibling;
4427 for (; o; o = o->op_next) {
4428 OPCODE type = o->op_type;
4430 if (sv && o->op_next == o)
4432 if (o->op_next != o) {
4433 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4435 if (type == OP_DBSTATE)
4438 if (type == OP_LEAVESUB || type == OP_RETURN)
4442 if (type == OP_CONST && cSVOPo->op_sv)
4444 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4445 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4446 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4450 /* We get here only from cv_clone2() while creating a closure.
4451 Copy the const value here instead of in cv_clone2 so that
4452 SvREADONLY_on doesn't lead to problems when leaving
4457 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4469 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4479 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4483 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4485 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4489 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4495 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4500 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4501 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4502 SV *sv = sv_newmortal();
4503 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4504 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4509 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4510 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4520 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4521 maximum a prototype before. */
4522 if (SvTYPE(gv) > SVt_NULL) {
4523 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4524 && ckWARN_d(WARN_PROTOTYPE))
4526 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4528 cv_ckproto((CV*)gv, NULL, ps);
4531 sv_setpv((SV*)gv, ps);
4533 sv_setiv((SV*)gv, -1);
4534 SvREFCNT_dec(PL_compcv);
4535 cv = PL_compcv = NULL;
4536 PL_sub_generation++;
4540 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4542 if (!block || !ps || *ps || attrs)
4545 const_sv = op_const_sv(block, Nullcv);
4548 bool exists = CvROOT(cv) || CvXSUB(cv);
4549 /* if the subroutine doesn't exist and wasn't pre-declared
4550 * with a prototype, assume it will be AUTOLOADed,
4551 * skipping the prototype check
4553 if (exists || SvPOK(cv))
4554 cv_ckproto(cv, gv, ps);
4555 /* already defined (or promised)? */
4556 if (exists || GvASSUMECV(gv)) {
4557 if (!block && !attrs) {
4558 /* just a "sub foo;" when &foo is already defined */
4559 SAVEFREESV(PL_compcv);
4562 /* ahem, death to those who redefine active sort subs */
4563 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4564 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4566 if (ckWARN(WARN_REDEFINE)
4568 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4570 line_t oldline = CopLINE(PL_curcop);
4571 CopLINE_set(PL_curcop, PL_copline);
4572 Perl_warner(aTHX_ WARN_REDEFINE,
4573 CvCONST(cv) ? "Constant subroutine %s redefined"
4574 : "Subroutine %s redefined", name);
4575 CopLINE_set(PL_curcop, oldline);
4583 SvREFCNT_inc(const_sv);
4585 assert(!CvROOT(cv) && !CvCONST(cv));
4586 sv_setpv((SV*)cv, ""); /* prototype is "" */
4587 CvXSUBANY(cv).any_ptr = const_sv;
4588 CvXSUB(cv) = const_sv_xsub;
4593 cv = newCONSTSUB(NULL, name, const_sv);
4596 SvREFCNT_dec(PL_compcv);
4598 PL_sub_generation++;
4605 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4606 * before we clobber PL_compcv.
4610 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4611 stash = GvSTASH(CvGV(cv));
4612 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4613 stash = CvSTASH(cv);
4615 stash = PL_curstash;
4618 /* possibly about to re-define existing subr -- ignore old cv */
4619 rcv = (SV*)PL_compcv;
4620 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4621 stash = GvSTASH(gv);
4623 stash = PL_curstash;
4625 apply_attrs(stash, rcv, attrs);
4627 if (cv) { /* must reuse cv if autoloaded */
4629 /* got here with just attrs -- work done, so bug out */
4630 SAVEFREESV(PL_compcv);
4634 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4635 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4636 CvOUTSIDE(PL_compcv) = 0;
4637 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4638 CvPADLIST(PL_compcv) = 0;
4639 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4640 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4641 SvREFCNT_dec(PL_compcv);
4648 PL_sub_generation++;
4651 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4652 CvFILE(cv) = CopFILE(PL_curcop);
4653 CvSTASH(cv) = PL_curstash;
4656 if (!CvMUTEXP(cv)) {
4657 New(666, CvMUTEXP(cv), 1, perl_mutex);
4658 MUTEX_INIT(CvMUTEXP(cv));
4660 #endif /* USE_THREADS */
4663 sv_setpv((SV*)cv, ps);
4665 if (PL_error_count) {
4669 char *s = strrchr(name, ':');
4671 if (strEQ(s, "BEGIN")) {
4673 "BEGIN not safe after errors--compilation aborted";
4674 if (PL_in_eval & EVAL_KEEPERR)
4675 Perl_croak(aTHX_ not_safe);
4677 /* force display of errors found but not reported */
4678 sv_catpv(ERRSV, not_safe);
4679 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4687 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4688 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4691 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
4694 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4696 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4697 OpREFCNT_set(CvROOT(cv), 1);
4698 CvSTART(cv) = LINKLIST(CvROOT(cv));
4699 CvROOT(cv)->op_next = 0;
4702 /* now that optimizer has done its work, adjust pad values */
4704 SV **namep = AvARRAY(PL_comppad_name);
4705 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4708 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4711 * The only things that a clonable function needs in its
4712 * pad are references to outer lexicals and anonymous subs.
4713 * The rest are created anew during cloning.
4715 if (!((namesv = namep[ix]) != Nullsv &&
4716 namesv != &PL_sv_undef &&
4718 *SvPVX(namesv) == '&')))
4720 SvREFCNT_dec(PL_curpad[ix]);
4721 PL_curpad[ix] = Nullsv;
4724 assert(!CvCONST(cv));
4725 if (ps && !*ps && op_const_sv(block, cv))
4729 AV *av = newAV(); /* Will be @_ */
4731 av_store(PL_comppad, 0, (SV*)av);
4732 AvFLAGS(av) = AVf_REIFY;
4734 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4735 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4737 if (!SvPADMY(PL_curpad[ix]))
4738 SvPADTMP_on(PL_curpad[ix]);
4742 if (name || aname) {
4744 char *tname = (name ? name : aname);
4746 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4747 SV *sv = NEWSV(0,0);
4748 SV *tmpstr = sv_newmortal();
4749 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4753 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4755 (long)PL_subline, (long)CopLINE(PL_curcop));
4756 gv_efullname3(tmpstr, gv, Nullch);
4757 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4758 hv = GvHVn(db_postponed);
4759 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4760 && (pcv = GvCV(db_postponed)))
4766 call_sv((SV*)pcv, G_DISCARD);
4770 if ((s = strrchr(tname,':')))
4775 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4778 if (strEQ(s, "BEGIN")) {
4779 I32 oldscope = PL_scopestack_ix;
4781 SAVECOPFILE(&PL_compiling);
4782 SAVECOPLINE(&PL_compiling);
4784 sv_setsv(PL_rs, PL_nrs);
4787 PL_beginav = newAV();
4788 DEBUG_x( dump_sub(gv) );
4789 av_push(PL_beginav, (SV*)cv);
4790 GvCV(gv) = 0; /* cv has been hijacked */
4791 call_list(oldscope, PL_beginav);
4793 PL_curcop = &PL_compiling;
4794 PL_compiling.op_private = PL_hints;
4797 else if (strEQ(s, "END") && !PL_error_count) {
4800 DEBUG_x( dump_sub(gv) );
4801 av_unshift(PL_endav, 1);
4802 av_store(PL_endav, 0, (SV*)cv);
4803 GvCV(gv) = 0; /* cv has been hijacked */
4805 else if (strEQ(s, "CHECK") && !PL_error_count) {
4807 PL_checkav = newAV();
4808 DEBUG_x( dump_sub(gv) );
4809 if (PL_main_start && ckWARN(WARN_VOID))
4810 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4811 av_unshift(PL_checkav, 1);
4812 av_store(PL_checkav, 0, (SV*)cv);
4813 GvCV(gv) = 0; /* cv has been hijacked */
4815 else if (strEQ(s, "INIT") && !PL_error_count) {
4817 PL_initav = newAV();
4818 DEBUG_x( dump_sub(gv) );
4819 if (PL_main_start && ckWARN(WARN_VOID))
4820 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4821 av_push(PL_initav, (SV*)cv);
4822 GvCV(gv) = 0; /* cv has been hijacked */
4827 PL_copline = NOLINE;
4832 /* XXX unsafe for threads if eval_owner isn't held */
4834 =for apidoc newCONSTSUB
4836 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4837 eligible for inlining at compile-time.
4843 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4849 SAVECOPLINE(PL_curcop);
4850 CopLINE_set(PL_curcop, PL_copline);
4853 PL_hints &= ~HINT_BLOCK_SCOPE;
4856 SAVESPTR(PL_curstash);
4857 SAVECOPSTASH(PL_curcop);
4858 PL_curstash = stash;
4860 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4862 CopSTASH(PL_curcop) = stash;
4866 cv = newXS(name, const_sv_xsub, __FILE__);
4867 CvXSUBANY(cv).any_ptr = sv;
4869 sv_setpv((SV*)cv, ""); /* prototype is "" */
4877 =for apidoc U||newXS
4879 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4885 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4887 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4890 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4892 /* just a cached method */
4896 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4897 /* already defined (or promised) */
4898 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4899 && HvNAME(GvSTASH(CvGV(cv)))
4900 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4901 line_t oldline = CopLINE(PL_curcop);
4902 if (PL_copline != NOLINE)
4903 CopLINE_set(PL_curcop, PL_copline);
4904 Perl_warner(aTHX_ WARN_REDEFINE,
4905 CvCONST(cv) ? "Constant subroutine %s redefined"
4906 : "Subroutine %s redefined"
4908 CopLINE_set(PL_curcop, oldline);
4915 if (cv) /* must reuse cv if autoloaded */
4918 cv = (CV*)NEWSV(1105,0);
4919 sv_upgrade((SV *)cv, SVt_PVCV);
4923 PL_sub_generation++;
4926 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4928 New(666, CvMUTEXP(cv), 1, perl_mutex);
4929 MUTEX_INIT(CvMUTEXP(cv));
4931 #endif /* USE_THREADS */
4932 (void)gv_fetchfile(filename);
4933 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4934 an external constant string */
4935 CvXSUB(cv) = subaddr;
4938 char *s = strrchr(name,':');
4944 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4947 if (strEQ(s, "BEGIN")) {
4949 PL_beginav = newAV();
4950 av_push(PL_beginav, (SV*)cv);
4951 GvCV(gv) = 0; /* cv has been hijacked */
4953 else if (strEQ(s, "END")) {
4956 av_unshift(PL_endav, 1);
4957 av_store(PL_endav, 0, (SV*)cv);
4958 GvCV(gv) = 0; /* cv has been hijacked */
4960 else if (strEQ(s, "CHECK")) {
4962 PL_checkav = newAV();
4963 if (PL_main_start && ckWARN(WARN_VOID))
4964 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4965 av_unshift(PL_checkav, 1);
4966 av_store(PL_checkav, 0, (SV*)cv);
4967 GvCV(gv) = 0; /* cv has been hijacked */
4969 else if (strEQ(s, "INIT")) {
4971 PL_initav = newAV();
4972 if (PL_main_start && ckWARN(WARN_VOID))
4973 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4974 av_push(PL_initav, (SV*)cv);
4975 GvCV(gv) = 0; /* cv has been hijacked */
4986 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4995 name = SvPVx(cSVOPo->op_sv, n_a);
4998 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5000 if ((cv = GvFORM(gv))) {
5001 if (ckWARN(WARN_REDEFINE)) {
5002 line_t oldline = CopLINE(PL_curcop);
5004 CopLINE_set(PL_curcop, PL_copline);
5005 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5006 CopLINE_set(PL_curcop, oldline);
5012 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
5013 CvFILE(cv) = CopFILE(PL_curcop);
5015 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5016 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5017 SvPADTMP_on(PL_curpad[ix]);
5020 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5021 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5022 OpREFCNT_set(CvROOT(cv), 1);
5023 CvSTART(cv) = LINKLIST(CvROOT(cv));
5024 CvROOT(cv)->op_next = 0;
5027 PL_copline = NOLINE;
5032 Perl_newANONLIST(pTHX_ OP *o)
5034 return newUNOP(OP_REFGEN, 0,
5035 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5039 Perl_newANONHASH(pTHX_ OP *o)
5041 return newUNOP(OP_REFGEN, 0,
5042 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5046 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5048 return newANONATTRSUB(floor, proto, Nullop, block);
5052 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5054 return newUNOP(OP_REFGEN, 0,
5055 newSVOP(OP_ANONCODE, 0,
5056 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5060 Perl_oopsAV(pTHX_ OP *o)
5062 switch (o->op_type) {
5064 o->op_type = OP_PADAV;
5065 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5066 return ref(o, OP_RV2AV);
5069 o->op_type = OP_RV2AV;
5070 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5075 if (ckWARN_d(WARN_INTERNAL))
5076 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5083 Perl_oopsHV(pTHX_ OP *o)
5085 switch (o->op_type) {
5088 o->op_type = OP_PADHV;
5089 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5090 return ref(o, OP_RV2HV);
5094 o->op_type = OP_RV2HV;
5095 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5100 if (ckWARN_d(WARN_INTERNAL))
5101 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5108 Perl_newAVREF(pTHX_ OP *o)
5110 if (o->op_type == OP_PADANY) {
5111 o->op_type = OP_PADAV;
5112 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5115 return newUNOP(OP_RV2AV, 0, scalar(o));
5119 Perl_newGVREF(pTHX_ I32 type, OP *o)
5121 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5122 return newUNOP(OP_NULL, 0, o);
5123 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5127 Perl_newHVREF(pTHX_ OP *o)
5129 if (o->op_type == OP_PADANY) {
5130 o->op_type = OP_PADHV;
5131 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5134 return newUNOP(OP_RV2HV, 0, scalar(o));
5138 Perl_oopsCV(pTHX_ OP *o)
5140 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5146 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5148 return newUNOP(OP_RV2CV, flags, scalar(o));
5152 Perl_newSVREF(pTHX_ OP *o)
5154 if (o->op_type == OP_PADANY) {
5155 o->op_type = OP_PADSV;
5156 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5159 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5160 o->op_flags |= OPpDONE_SVREF;
5163 return newUNOP(OP_RV2SV, 0, scalar(o));
5166 /* Check routines. */
5169 Perl_ck_anoncode(pTHX_ OP *o)
5174 name = NEWSV(1106,0);
5175 sv_upgrade(name, SVt_PVNV);
5176 sv_setpvn(name, "&", 1);
5179 ix = pad_alloc(o->op_type, SVs_PADMY);
5180 av_store(PL_comppad_name, ix, name);
5181 av_store(PL_comppad, ix, cSVOPo->op_sv);
5182 SvPADMY_on(cSVOPo->op_sv);
5183 cSVOPo->op_sv = Nullsv;
5184 cSVOPo->op_targ = ix;
5189 Perl_ck_bitop(pTHX_ OP *o)
5191 o->op_private = PL_hints;
5196 Perl_ck_concat(pTHX_ OP *o)
5198 if (cUNOPo->op_first->op_type == OP_CONCAT)
5199 o->op_flags |= OPf_STACKED;
5204 Perl_ck_spair(pTHX_ OP *o)
5206 if (o->op_flags & OPf_KIDS) {
5209 OPCODE type = o->op_type;
5210 o = modkids(ck_fun(o), type);
5211 kid = cUNOPo->op_first;
5212 newop = kUNOP->op_first->op_sibling;
5214 (newop->op_sibling ||
5215 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5216 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5217 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5221 op_free(kUNOP->op_first);
5222 kUNOP->op_first = newop;
5224 o->op_ppaddr = PL_ppaddr[++o->op_type];
5229 Perl_ck_delete(pTHX_ OP *o)
5233 if (o->op_flags & OPf_KIDS) {
5234 OP *kid = cUNOPo->op_first;
5235 switch (kid->op_type) {
5237 o->op_flags |= OPf_SPECIAL;
5240 o->op_private |= OPpSLICE;
5243 o->op_flags |= OPf_SPECIAL;
5248 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5249 PL_op_desc[o->op_type]);
5257 Perl_ck_eof(pTHX_ OP *o)
5259 I32 type = o->op_type;
5261 if (o->op_flags & OPf_KIDS) {
5262 if (cLISTOPo->op_first->op_type == OP_STUB) {
5264 o = newUNOP(type, OPf_SPECIAL,
5265 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5273 Perl_ck_eval(pTHX_ OP *o)
5275 PL_hints |= HINT_BLOCK_SCOPE;
5276 if (o->op_flags & OPf_KIDS) {
5277 SVOP *kid = (SVOP*)cUNOPo->op_first;
5280 o->op_flags &= ~OPf_KIDS;
5283 else if (kid->op_type == OP_LINESEQ) {
5286 kid->op_next = o->op_next;
5287 cUNOPo->op_first = 0;
5290 NewOp(1101, enter, 1, LOGOP);
5291 enter->op_type = OP_ENTERTRY;
5292 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5293 enter->op_private = 0;
5295 /* establish postfix order */
5296 enter->op_next = (OP*)enter;
5298 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5299 o->op_type = OP_LEAVETRY;
5300 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5301 enter->op_other = o;
5309 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5311 o->op_targ = (PADOFFSET)PL_hints;
5316 Perl_ck_exit(pTHX_ OP *o)
5319 HV *table = GvHV(PL_hintgv);
5321 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5322 if (svp && *svp && SvTRUE(*svp))
5323 o->op_private |= OPpEXIT_VMSISH;
5330 Perl_ck_exec(pTHX_ OP *o)
5333 if (o->op_flags & OPf_STACKED) {
5335 kid = cUNOPo->op_first->op_sibling;
5336 if (kid->op_type == OP_RV2GV)
5345 Perl_ck_exists(pTHX_ OP *o)
5348 if (o->op_flags & OPf_KIDS) {
5349 OP *kid = cUNOPo->op_first;
5350 if (kid->op_type == OP_ENTERSUB) {
5351 (void) ref(kid, o->op_type);
5352 if (kid->op_type != OP_RV2CV && !PL_error_count)
5353 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5354 PL_op_desc[o->op_type]);
5355 o->op_private |= OPpEXISTS_SUB;
5357 else if (kid->op_type == OP_AELEM)
5358 o->op_flags |= OPf_SPECIAL;
5359 else if (kid->op_type != OP_HELEM)
5360 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5361 PL_op_desc[o->op_type]);
5369 Perl_ck_gvconst(pTHX_ register OP *o)
5371 o = fold_constants(o);
5372 if (o->op_type == OP_CONST)
5379 Perl_ck_rvconst(pTHX_ register OP *o)
5381 SVOP *kid = (SVOP*)cUNOPo->op_first;
5383 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5384 if (kid->op_type == OP_CONST) {
5388 SV *kidsv = kid->op_sv;
5391 /* Is it a constant from cv_const_sv()? */
5392 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5393 SV *rsv = SvRV(kidsv);
5394 int svtype = SvTYPE(rsv);
5395 char *badtype = Nullch;
5397 switch (o->op_type) {
5399 if (svtype > SVt_PVMG)
5400 badtype = "a SCALAR";
5403 if (svtype != SVt_PVAV)
5404 badtype = "an ARRAY";
5407 if (svtype != SVt_PVHV) {
5408 if (svtype == SVt_PVAV) { /* pseudohash? */
5409 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5410 if (ksv && SvROK(*ksv)
5411 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5420 if (svtype != SVt_PVCV)
5425 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5428 name = SvPV(kidsv, n_a);
5429 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5430 char *badthing = Nullch;
5431 switch (o->op_type) {
5433 badthing = "a SCALAR";
5436 badthing = "an ARRAY";
5439 badthing = "a HASH";
5444 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5448 * This is a little tricky. We only want to add the symbol if we
5449 * didn't add it in the lexer. Otherwise we get duplicate strict
5450 * warnings. But if we didn't add it in the lexer, we must at
5451 * least pretend like we wanted to add it even if it existed before,
5452 * or we get possible typo warnings. OPpCONST_ENTERED says
5453 * whether the lexer already added THIS instance of this symbol.
5455 iscv = (o->op_type == OP_RV2CV) * 2;
5457 gv = gv_fetchpv(name,
5458 iscv | !(kid->op_private & OPpCONST_ENTERED),
5461 : o->op_type == OP_RV2SV
5463 : o->op_type == OP_RV2AV
5465 : o->op_type == OP_RV2HV
5468 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5470 kid->op_type = OP_GV;
5471 SvREFCNT_dec(kid->op_sv);
5473 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5474 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5475 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5477 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5479 kid->op_sv = SvREFCNT_inc(gv);
5481 kid->op_private = 0;
5482 kid->op_ppaddr = PL_ppaddr[OP_GV];
5489 Perl_ck_ftst(pTHX_ OP *o)
5491 I32 type = o->op_type;
5493 if (o->op_flags & OPf_REF) {
5496 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5497 SVOP *kid = (SVOP*)cUNOPo->op_first;
5499 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5501 OP *newop = newGVOP(type, OPf_REF,
5502 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5509 if (type == OP_FTTTY)
5510 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5513 o = newUNOP(type, 0, newDEFSVOP());
5516 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5518 if (PL_hints & HINT_LOCALE)
5519 o->op_private |= OPpLOCALE;
5526 Perl_ck_fun(pTHX_ OP *o)
5532 int type = o->op_type;
5533 register I32 oa = PL_opargs[type] >> OASHIFT;
5535 if (o->op_flags & OPf_STACKED) {
5536 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5539 return no_fh_allowed(o);
5542 if (o->op_flags & OPf_KIDS) {
5544 tokid = &cLISTOPo->op_first;
5545 kid = cLISTOPo->op_first;
5546 if (kid->op_type == OP_PUSHMARK ||
5547 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5549 tokid = &kid->op_sibling;
5550 kid = kid->op_sibling;
5552 if (!kid && PL_opargs[type] & OA_DEFGV)
5553 *tokid = kid = newDEFSVOP();
5557 sibl = kid->op_sibling;
5560 /* list seen where single (scalar) arg expected? */
5561 if (numargs == 1 && !(oa >> 4)
5562 && kid->op_type == OP_LIST && type != OP_SCALAR)
5564 return too_many_arguments(o,PL_op_desc[type]);
5577 if (kid->op_type == OP_CONST &&
5578 (kid->op_private & OPpCONST_BARE))
5580 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5581 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5582 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5583 if (ckWARN(WARN_DEPRECATED))
5584 Perl_warner(aTHX_ WARN_DEPRECATED,
5585 "Array @%s missing the @ in argument %"IVdf" of %s()",
5586 name, (IV)numargs, PL_op_desc[type]);
5589 kid->op_sibling = sibl;
5592 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5593 bad_type(numargs, "array", PL_op_desc[type], kid);
5597 if (kid->op_type == OP_CONST &&
5598 (kid->op_private & OPpCONST_BARE))
5600 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5601 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5602 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5603 if (ckWARN(WARN_DEPRECATED))
5604 Perl_warner(aTHX_ WARN_DEPRECATED,
5605 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5606 name, (IV)numargs, PL_op_desc[type]);
5609 kid->op_sibling = sibl;
5612 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5613 bad_type(numargs, "hash", PL_op_desc[type], kid);
5618 OP *newop = newUNOP(OP_NULL, 0, kid);
5619 kid->op_sibling = 0;
5621 newop->op_next = newop;
5623 kid->op_sibling = sibl;
5628 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5629 if (kid->op_type == OP_CONST &&
5630 (kid->op_private & OPpCONST_BARE))
5632 OP *newop = newGVOP(OP_GV, 0,
5633 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5638 else if (kid->op_type == OP_READLINE) {
5639 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5640 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5643 I32 flags = OPf_SPECIAL;
5647 /* is this op a FH constructor? */
5648 if (is_handle_constructor(o,numargs)) {
5649 char *name = Nullch;
5653 /* Set a flag to tell rv2gv to vivify
5654 * need to "prove" flag does not mean something
5655 * else already - NI-S 1999/05/07
5658 if (kid->op_type == OP_PADSV) {
5659 SV **namep = av_fetch(PL_comppad_name,
5661 if (namep && *namep)
5662 name = SvPV(*namep, len);
5664 else if (kid->op_type == OP_RV2SV
5665 && kUNOP->op_first->op_type == OP_GV)
5667 GV *gv = cGVOPx_gv(kUNOP->op_first);
5669 len = GvNAMELEN(gv);
5671 else if (kid->op_type == OP_AELEM
5672 || kid->op_type == OP_HELEM)
5674 name = "__ANONIO__";
5680 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5681 namesv = PL_curpad[targ];
5682 (void)SvUPGRADE(namesv, SVt_PV);
5684 sv_setpvn(namesv, "$", 1);
5685 sv_catpvn(namesv, name, len);
5688 kid->op_sibling = 0;
5689 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5690 kid->op_targ = targ;
5691 kid->op_private |= priv;
5693 kid->op_sibling = sibl;
5699 mod(scalar(kid), type);
5703 tokid = &kid->op_sibling;
5704 kid = kid->op_sibling;
5706 o->op_private |= numargs;
5708 return too_many_arguments(o,PL_op_desc[o->op_type]);
5711 else if (PL_opargs[type] & OA_DEFGV) {
5713 return newUNOP(type, 0, newDEFSVOP());
5717 while (oa & OA_OPTIONAL)
5719 if (oa && oa != OA_LIST)
5720 return too_few_arguments(o,PL_op_desc[o->op_type]);
5726 Perl_ck_glob(pTHX_ OP *o)
5731 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5732 append_elem(OP_GLOB, o, newDEFSVOP());
5734 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5735 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5737 #if !defined(PERL_EXTERNAL_GLOB)
5738 /* XXX this can be tightened up and made more failsafe. */
5741 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5742 /* null-terminated import list */
5743 newSVpvn(":globally", 9), Nullsv);
5744 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5747 #endif /* PERL_EXTERNAL_GLOB */
5749 if (gv && GvIMPORTED_CV(gv)) {
5750 append_elem(OP_GLOB, o,
5751 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5752 o->op_type = OP_LIST;
5753 o->op_ppaddr = PL_ppaddr[OP_LIST];
5754 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5755 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5756 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5757 append_elem(OP_LIST, o,
5758 scalar(newUNOP(OP_RV2CV, 0,
5759 newGVOP(OP_GV, 0, gv)))));
5760 o = newUNOP(OP_NULL, 0, ck_subr(o));
5761 o->op_targ = OP_GLOB; /* hint at what it used to be */
5764 gv = newGVgen("main");
5766 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5772 Perl_ck_grep(pTHX_ OP *o)
5776 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5778 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5779 NewOp(1101, gwop, 1, LOGOP);
5781 if (o->op_flags & OPf_STACKED) {
5784 kid = cLISTOPo->op_first->op_sibling;
5785 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5788 kid->op_next = (OP*)gwop;
5789 o->op_flags &= ~OPf_STACKED;
5791 kid = cLISTOPo->op_first->op_sibling;
5792 if (type == OP_MAPWHILE)
5799 kid = cLISTOPo->op_first->op_sibling;
5800 if (kid->op_type != OP_NULL)
5801 Perl_croak(aTHX_ "panic: ck_grep");
5802 kid = kUNOP->op_first;
5804 gwop->op_type = type;
5805 gwop->op_ppaddr = PL_ppaddr[type];
5806 gwop->op_first = listkids(o);
5807 gwop->op_flags |= OPf_KIDS;
5808 gwop->op_private = 1;
5809 gwop->op_other = LINKLIST(kid);
5810 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5811 kid->op_next = (OP*)gwop;
5813 kid = cLISTOPo->op_first->op_sibling;
5814 if (!kid || !kid->op_sibling)
5815 return too_few_arguments(o,PL_op_desc[o->op_type]);
5816 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5817 mod(kid, OP_GREPSTART);
5823 Perl_ck_index(pTHX_ OP *o)
5825 if (o->op_flags & OPf_KIDS) {
5826 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5828 kid = kid->op_sibling; /* get past "big" */
5829 if (kid && kid->op_type == OP_CONST)
5830 fbm_compile(((SVOP*)kid)->op_sv, 0);
5836 Perl_ck_lengthconst(pTHX_ OP *o)
5838 /* XXX length optimization goes here */
5843 Perl_ck_lfun(pTHX_ OP *o)
5845 OPCODE type = o->op_type;
5846 return modkids(ck_fun(o), type);
5850 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5852 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5853 switch (cUNOPo->op_first->op_type) {
5855 /* This is needed for
5856 if (defined %stash::)
5857 to work. Do not break Tk.
5859 break; /* Globals via GV can be undef */
5861 case OP_AASSIGN: /* Is this a good idea? */
5862 Perl_warner(aTHX_ WARN_DEPRECATED,
5863 "defined(@array) is deprecated");
5864 Perl_warner(aTHX_ WARN_DEPRECATED,
5865 "\t(Maybe you should just omit the defined()?)\n");
5868 /* This is needed for
5869 if (defined %stash::)
5870 to work. Do not break Tk.
5872 break; /* Globals via GV can be undef */
5874 Perl_warner(aTHX_ WARN_DEPRECATED,
5875 "defined(%%hash) is deprecated");
5876 Perl_warner(aTHX_ WARN_DEPRECATED,
5877 "\t(Maybe you should just omit the defined()?)\n");
5888 Perl_ck_rfun(pTHX_ OP *o)
5890 OPCODE type = o->op_type;
5891 return refkids(ck_fun(o), type);
5895 Perl_ck_listiob(pTHX_ OP *o)
5899 kid = cLISTOPo->op_first;
5902 kid = cLISTOPo->op_first;
5904 if (kid->op_type == OP_PUSHMARK)
5905 kid = kid->op_sibling;
5906 if (kid && o->op_flags & OPf_STACKED)
5907 kid = kid->op_sibling;
5908 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5909 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5910 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5911 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5912 cLISTOPo->op_first->op_sibling = kid;
5913 cLISTOPo->op_last = kid;
5914 kid = kid->op_sibling;
5919 append_elem(o->op_type, o, newDEFSVOP());
5925 if (PL_hints & HINT_LOCALE)
5926 o->op_private |= OPpLOCALE;
5933 Perl_ck_fun_locale(pTHX_ OP *o)
5939 if (PL_hints & HINT_LOCALE)
5940 o->op_private |= OPpLOCALE;
5947 Perl_ck_sassign(pTHX_ OP *o)
5949 OP *kid = cLISTOPo->op_first;
5950 /* has a disposable target? */
5951 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5952 && !(kid->op_flags & OPf_STACKED)
5953 /* Cannot steal the second time! */
5954 && !(kid->op_private & OPpTARGET_MY))
5956 OP *kkid = kid->op_sibling;
5958 /* Can just relocate the target. */
5959 if (kkid && kkid->op_type == OP_PADSV
5960 && !(kkid->op_private & OPpLVAL_INTRO))
5962 kid->op_targ = kkid->op_targ;
5964 /* Now we do not need PADSV and SASSIGN. */
5965 kid->op_sibling = o->op_sibling; /* NULL */
5966 cLISTOPo->op_first = NULL;
5969 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5977 Perl_ck_scmp(pTHX_ OP *o)
5981 if (PL_hints & HINT_LOCALE)
5982 o->op_private |= OPpLOCALE;
5989 Perl_ck_match(pTHX_ OP *o)
5991 o->op_private |= OPpRUNTIME;
5996 Perl_ck_method(pTHX_ OP *o)
5998 OP *kid = cUNOPo->op_first;
5999 if (kid->op_type == OP_CONST) {
6000 SV* sv = kSVOP->op_sv;
6001 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6003 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6004 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6007 kSVOP->op_sv = Nullsv;
6009 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6018 Perl_ck_null(pTHX_ OP *o)
6024 Perl_ck_open(pTHX_ OP *o)
6026 HV *table = GvHV(PL_hintgv);
6030 svp = hv_fetch(table, "open_IN", 7, FALSE);
6032 mode = mode_from_discipline(*svp);
6033 if (mode & O_BINARY)
6034 o->op_private |= OPpOPEN_IN_RAW;
6035 else if (mode & O_TEXT)
6036 o->op_private |= OPpOPEN_IN_CRLF;
6039 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6041 mode = mode_from_discipline(*svp);
6042 if (mode & O_BINARY)
6043 o->op_private |= OPpOPEN_OUT_RAW;
6044 else if (mode & O_TEXT)
6045 o->op_private |= OPpOPEN_OUT_CRLF;
6048 if (o->op_type == OP_BACKTICK)
6054 Perl_ck_repeat(pTHX_ OP *o)
6056 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6057 o->op_private |= OPpREPEAT_DOLIST;
6058 cBINOPo->op_first = force_list(cBINOPo->op_first);
6066 Perl_ck_require(pTHX_ OP *o)
6068 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6069 SVOP *kid = (SVOP*)cUNOPo->op_first;
6071 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6073 for (s = SvPVX(kid->op_sv); *s; s++) {
6074 if (*s == ':' && s[1] == ':') {
6076 Move(s+2, s+1, strlen(s+2)+1, char);
6077 --SvCUR(kid->op_sv);
6080 if (SvREADONLY(kid->op_sv)) {
6081 SvREADONLY_off(kid->op_sv);
6082 sv_catpvn(kid->op_sv, ".pm", 3);
6083 SvREADONLY_on(kid->op_sv);
6086 sv_catpvn(kid->op_sv, ".pm", 3);
6094 Perl_ck_retarget(pTHX_ OP *o)
6096 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6103 Perl_ck_select(pTHX_ OP *o)
6106 if (o->op_flags & OPf_KIDS) {
6107 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6108 if (kid && kid->op_sibling) {
6109 o->op_type = OP_SSELECT;
6110 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6112 return fold_constants(o);
6116 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6117 if (kid && kid->op_type == OP_RV2GV)
6118 kid->op_private &= ~HINT_STRICT_REFS;
6123 Perl_ck_shift(pTHX_ OP *o)
6125 I32 type = o->op_type;
6127 if (!(o->op_flags & OPf_KIDS)) {
6132 if (!CvUNIQUE(PL_compcv)) {
6133 argop = newOP(OP_PADAV, OPf_REF);
6134 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6137 argop = newUNOP(OP_RV2AV, 0,
6138 scalar(newGVOP(OP_GV, 0,
6139 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6142 argop = newUNOP(OP_RV2AV, 0,
6143 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6144 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6145 #endif /* USE_THREADS */
6146 return newUNOP(type, 0, scalar(argop));
6148 return scalar(modkids(ck_fun(o), type));
6152 Perl_ck_sort(pTHX_ OP *o)
6157 if (PL_hints & HINT_LOCALE)
6158 o->op_private |= OPpLOCALE;
6161 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6163 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6164 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6166 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6168 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6170 if (kid->op_type == OP_SCOPE) {
6174 else if (kid->op_type == OP_LEAVE) {
6175 if (o->op_type == OP_SORT) {
6176 null(kid); /* wipe out leave */
6179 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6180 if (k->op_next == kid)
6182 /* don't descend into loops */
6183 else if (k->op_type == OP_ENTERLOOP
6184 || k->op_type == OP_ENTERITER)
6186 k = cLOOPx(k)->op_lastop;
6191 kid->op_next = 0; /* just disconnect the leave */
6192 k = kLISTOP->op_first;
6197 if (o->op_type == OP_SORT) {
6198 /* provide scalar context for comparison function/block */
6204 o->op_flags |= OPf_SPECIAL;
6206 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6209 firstkid = firstkid->op_sibling;
6212 /* provide list context for arguments */
6213 if (o->op_type == OP_SORT)
6220 S_simplify_sort(pTHX_ OP *o)
6222 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6226 if (!(o->op_flags & OPf_STACKED))
6228 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6229 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6230 kid = kUNOP->op_first; /* get past null */
6231 if (kid->op_type != OP_SCOPE)
6233 kid = kLISTOP->op_last; /* get past scope */
6234 switch(kid->op_type) {
6242 k = kid; /* remember this node*/
6243 if (kBINOP->op_first->op_type != OP_RV2SV)
6245 kid = kBINOP->op_first; /* get past cmp */
6246 if (kUNOP->op_first->op_type != OP_GV)
6248 kid = kUNOP->op_first; /* get past rv2sv */
6250 if (GvSTASH(gv) != PL_curstash)
6252 if (strEQ(GvNAME(gv), "a"))
6254 else if (strEQ(GvNAME(gv), "b"))
6258 kid = k; /* back to cmp */
6259 if (kBINOP->op_last->op_type != OP_RV2SV)
6261 kid = kBINOP->op_last; /* down to 2nd arg */
6262 if (kUNOP->op_first->op_type != OP_GV)
6264 kid = kUNOP->op_first; /* get past rv2sv */
6266 if (GvSTASH(gv) != PL_curstash
6268 ? strNE(GvNAME(gv), "a")
6269 : strNE(GvNAME(gv), "b")))
6271 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6273 o->op_private |= OPpSORT_REVERSE;
6274 if (k->op_type == OP_NCMP)
6275 o->op_private |= OPpSORT_NUMERIC;
6276 if (k->op_type == OP_I_NCMP)
6277 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6278 kid = cLISTOPo->op_first->op_sibling;
6279 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6280 op_free(kid); /* then delete it */
6281 cLISTOPo->op_children--;
6285 Perl_ck_split(pTHX_ OP *o)
6289 if (o->op_flags & OPf_STACKED)
6290 return no_fh_allowed(o);
6292 kid = cLISTOPo->op_first;
6293 if (kid->op_type != OP_NULL)
6294 Perl_croak(aTHX_ "panic: ck_split");
6295 kid = kid->op_sibling;
6296 op_free(cLISTOPo->op_first);
6297 cLISTOPo->op_first = kid;
6299 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6300 cLISTOPo->op_last = kid; /* There was only one element previously */
6303 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6304 OP *sibl = kid->op_sibling;
6305 kid->op_sibling = 0;
6306 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6307 if (cLISTOPo->op_first == cLISTOPo->op_last)
6308 cLISTOPo->op_last = kid;
6309 cLISTOPo->op_first = kid;
6310 kid->op_sibling = sibl;
6313 kid->op_type = OP_PUSHRE;
6314 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6317 if (!kid->op_sibling)
6318 append_elem(OP_SPLIT, o, newDEFSVOP());
6320 kid = kid->op_sibling;
6323 if (!kid->op_sibling)
6324 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6326 kid = kid->op_sibling;
6329 if (kid->op_sibling)
6330 return too_many_arguments(o,PL_op_desc[o->op_type]);
6336 Perl_ck_join(pTHX_ OP *o)
6338 if (ckWARN(WARN_SYNTAX)) {
6339 OP *kid = cLISTOPo->op_first->op_sibling;
6340 if (kid && kid->op_type == OP_MATCH) {
6341 char *pmstr = "STRING";
6342 if (kPMOP->op_pmregexp)
6343 pmstr = kPMOP->op_pmregexp->precomp;
6344 Perl_warner(aTHX_ WARN_SYNTAX,
6345 "/%s/ should probably be written as \"%s\"",
6353 Perl_ck_subr(pTHX_ OP *o)
6355 OP *prev = ((cUNOPo->op_first->op_sibling)
6356 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6357 OP *o2 = prev->op_sibling;
6366 o->op_private |= OPpENTERSUB_HASTARG;
6367 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6368 if (cvop->op_type == OP_RV2CV) {
6370 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6371 null(cvop); /* disable rv2cv */
6372 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6373 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6374 GV *gv = cGVOPx_gv(tmpop);
6377 tmpop->op_private |= OPpEARLY_CV;
6378 else if (SvPOK(cv)) {
6379 namegv = CvANON(cv) ? gv : CvGV(cv);
6380 proto = SvPV((SV*)cv, n_a);
6384 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6385 if (o2->op_type == OP_CONST)
6386 o2->op_private &= ~OPpCONST_STRICT;
6387 else if (o2->op_type == OP_LIST) {
6388 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6389 if (o && o->op_type == OP_CONST)
6390 o->op_private &= ~OPpCONST_STRICT;
6393 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6394 if (PERLDB_SUB && PL_curstash != PL_debstash)
6395 o->op_private |= OPpENTERSUB_DB;
6396 while (o2 != cvop) {
6400 return too_many_arguments(o, gv_ename(namegv));
6418 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6420 arg == 1 ? "block or sub {}" : "sub {}",
6421 gv_ename(namegv), o2);
6424 /* '*' allows any scalar type, including bareword */
6427 if (o2->op_type == OP_RV2GV)
6428 goto wrapref; /* autoconvert GLOB -> GLOBref */
6429 else if (o2->op_type == OP_CONST)
6430 o2->op_private &= ~OPpCONST_STRICT;
6431 else if (o2->op_type == OP_ENTERSUB) {
6432 /* accidental subroutine, revert to bareword */
6433 OP *gvop = ((UNOP*)o2)->op_first;
6434 if (gvop && gvop->op_type == OP_NULL) {
6435 gvop = ((UNOP*)gvop)->op_first;
6437 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6440 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6441 (gvop = ((UNOP*)gvop)->op_first) &&
6442 gvop->op_type == OP_GV)
6444 GV *gv = cGVOPx_gv(gvop);
6445 OP *sibling = o2->op_sibling;
6446 SV *n = newSVpvn("",0);
6448 gv_fullname3(n, gv, "");
6449 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6450 sv_chop(n, SvPVX(n)+6);
6451 o2 = newSVOP(OP_CONST, 0, n);
6452 prev->op_sibling = o2;
6453 o2->op_sibling = sibling;
6465 if (o2->op_type != OP_RV2GV)
6466 bad_type(arg, "symbol", gv_ename(namegv), o2);
6469 if (o2->op_type != OP_ENTERSUB)
6470 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6473 if (o2->op_type != OP_RV2SV
6474 && o2->op_type != OP_PADSV
6475 && o2->op_type != OP_HELEM
6476 && o2->op_type != OP_AELEM
6477 && o2->op_type != OP_THREADSV)
6479 bad_type(arg, "scalar", gv_ename(namegv), o2);
6483 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6484 bad_type(arg, "array", gv_ename(namegv), o2);
6487 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6488 bad_type(arg, "hash", gv_ename(namegv), o2);
6492 OP* sib = kid->op_sibling;
6493 kid->op_sibling = 0;
6494 o2 = newUNOP(OP_REFGEN, 0, kid);
6495 o2->op_sibling = sib;
6496 prev->op_sibling = o2;
6507 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6508 gv_ename(namegv), SvPV((SV*)cv, n_a));
6513 mod(o2, OP_ENTERSUB);
6515 o2 = o2->op_sibling;
6517 if (proto && !optional &&
6518 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6519 return too_few_arguments(o, gv_ename(namegv));
6524 Perl_ck_svconst(pTHX_ OP *o)
6526 SvREADONLY_on(cSVOPo->op_sv);
6531 Perl_ck_trunc(pTHX_ OP *o)
6533 if (o->op_flags & OPf_KIDS) {
6534 SVOP *kid = (SVOP*)cUNOPo->op_first;
6536 if (kid->op_type == OP_NULL)
6537 kid = (SVOP*)kid->op_sibling;
6538 if (kid && kid->op_type == OP_CONST &&
6539 (kid->op_private & OPpCONST_BARE))
6541 o->op_flags |= OPf_SPECIAL;
6542 kid->op_private &= ~OPpCONST_STRICT;
6549 Perl_ck_substr(pTHX_ OP *o)
6552 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6553 OP *kid = cLISTOPo->op_first;
6555 if (kid->op_type == OP_NULL)
6556 kid = kid->op_sibling;
6558 kid->op_flags |= OPf_MOD;
6564 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6567 Perl_peep(pTHX_ register OP *o)
6569 register OP* oldop = 0;
6571 OP *last_composite = Nullop;
6573 if (!o || o->op_seq)
6577 SAVEVPTR(PL_curcop);
6578 for (; o; o = o->op_next) {
6584 switch (o->op_type) {
6588 PL_curcop = ((COP*)o); /* for warnings */
6589 o->op_seq = PL_op_seqmax++;
6590 last_composite = Nullop;
6594 if (cSVOPo->op_private & OPpCONST_STRICT)
6595 no_bareword_allowed(o);
6597 /* Relocate sv to the pad for thread safety.
6598 * Despite being a "constant", the SV is written to,
6599 * for reference counts, sv_upgrade() etc. */
6601 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6602 if (SvPADTMP(cSVOPo->op_sv)) {
6603 /* If op_sv is already a PADTMP then it is being used by
6604 * some pad, so make a copy. */
6605 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6606 SvREADONLY_on(PL_curpad[ix]);
6607 SvREFCNT_dec(cSVOPo->op_sv);
6610 SvREFCNT_dec(PL_curpad[ix]);
6611 SvPADTMP_on(cSVOPo->op_sv);
6612 PL_curpad[ix] = cSVOPo->op_sv;
6613 /* XXX I don't know how this isn't readonly already. */
6614 SvREADONLY_on(PL_curpad[ix]);
6616 cSVOPo->op_sv = Nullsv;
6620 o->op_seq = PL_op_seqmax++;
6624 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6625 if (o->op_next->op_private & OPpTARGET_MY) {
6626 if (o->op_flags & OPf_STACKED) /* chained concats */
6627 goto ignore_optimization;
6629 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6630 o->op_targ = o->op_next->op_targ;
6631 o->op_next->op_targ = 0;
6632 o->op_private |= OPpTARGET_MY;
6637 ignore_optimization:
6638 o->op_seq = PL_op_seqmax++;
6641 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6642 o->op_seq = PL_op_seqmax++;
6643 break; /* Scalar stub must produce undef. List stub is noop */
6647 if (o->op_targ == OP_NEXTSTATE
6648 || o->op_targ == OP_DBSTATE
6649 || o->op_targ == OP_SETSTATE)
6651 PL_curcop = ((COP*)o);
6658 if (oldop && o->op_next) {
6659 oldop->op_next = o->op_next;
6662 o->op_seq = PL_op_seqmax++;
6666 if (o->op_next->op_type == OP_RV2SV) {
6667 if (!(o->op_next->op_private & OPpDEREF)) {
6669 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6671 o->op_next = o->op_next->op_next;
6672 o->op_type = OP_GVSV;
6673 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6676 else if (o->op_next->op_type == OP_RV2AV) {
6677 OP* pop = o->op_next->op_next;
6679 if (pop->op_type == OP_CONST &&
6680 (PL_op = pop->op_next) &&
6681 pop->op_next->op_type == OP_AELEM &&
6682 !(pop->op_next->op_private &
6683 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
6684 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6692 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6693 o->op_next = pop->op_next->op_next;
6694 o->op_type = OP_AELEMFAST;
6695 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6696 o->op_private = (U8)i;
6701 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6703 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6704 /* XXX could check prototype here instead of just carping */
6705 SV *sv = sv_newmortal();
6706 gv_efullname3(sv, gv, Nullch);
6707 Perl_warner(aTHX_ WARN_PROTOTYPE,
6708 "%s() called too early to check prototype",
6713 o->op_seq = PL_op_seqmax++;
6724 o->op_seq = PL_op_seqmax++;
6725 while (cLOGOP->op_other->op_type == OP_NULL)
6726 cLOGOP->op_other = cLOGOP->op_other->op_next;
6727 peep(cLOGOP->op_other);
6731 o->op_seq = PL_op_seqmax++;
6732 while (cLOOP->op_redoop->op_type == OP_NULL)
6733 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6734 peep(cLOOP->op_redoop);
6735 while (cLOOP->op_nextop->op_type == OP_NULL)
6736 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6737 peep(cLOOP->op_nextop);
6738 while (cLOOP->op_lastop->op_type == OP_NULL)
6739 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6740 peep(cLOOP->op_lastop);
6746 o->op_seq = PL_op_seqmax++;
6747 while (cPMOP->op_pmreplstart &&
6748 cPMOP->op_pmreplstart->op_type == OP_NULL)
6749 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6750 peep(cPMOP->op_pmreplstart);
6754 o->op_seq = PL_op_seqmax++;
6755 if (ckWARN(WARN_SYNTAX) && o->op_next
6756 && o->op_next->op_type == OP_NEXTSTATE) {
6757 if (o->op_next->op_sibling &&
6758 o->op_next->op_sibling->op_type != OP_EXIT &&
6759 o->op_next->op_sibling->op_type != OP_WARN &&
6760 o->op_next->op_sibling->op_type != OP_DIE) {
6761 line_t oldline = CopLINE(PL_curcop);
6763 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6764 Perl_warner(aTHX_ WARN_EXEC,
6765 "Statement unlikely to be reached");
6766 Perl_warner(aTHX_ WARN_EXEC,
6767 "\t(Maybe you meant system() when you said exec()?)\n");
6768 CopLINE_set(PL_curcop, oldline);
6777 SV **svp, **indsvp, *sv;
6782 o->op_seq = PL_op_seqmax++;
6784 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6787 /* Make the CONST have a shared SV */
6788 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6789 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6790 key = SvPV(sv, keylen);
6793 lexname = newSVpvn_share(key, keylen, 0);
6798 if ((o->op_private & (OPpLVAL_INTRO)))
6801 rop = (UNOP*)((BINOP*)o)->op_first;
6802 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6804 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6805 if (!SvOBJECT(lexname))
6807 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6808 if (!fields || !GvHV(*fields))
6810 key = SvPV(*svp, keylen);
6813 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6815 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6816 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6818 ind = SvIV(*indsvp);
6820 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6821 rop->op_type = OP_RV2AV;
6822 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6823 o->op_type = OP_AELEM;
6824 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6826 if (SvREADONLY(*svp))
6828 SvFLAGS(sv) |= (SvFLAGS(*svp)
6829 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6839 SV **svp, **indsvp, *sv;
6843 SVOP *first_key_op, *key_op;
6845 o->op_seq = PL_op_seqmax++;
6846 if ((o->op_private & (OPpLVAL_INTRO))
6847 /* I bet there's always a pushmark... */
6848 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6849 /* hmmm, no optimization if list contains only one key. */
6851 rop = (UNOP*)((LISTOP*)o)->op_last;
6852 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6854 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6855 if (!SvOBJECT(lexname))
6857 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6858 if (!fields || !GvHV(*fields))
6860 /* Again guessing that the pushmark can be jumped over.... */
6861 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6862 ->op_first->op_sibling;
6863 /* Check that the key list contains only constants. */
6864 for (key_op = first_key_op; key_op;
6865 key_op = (SVOP*)key_op->op_sibling)
6866 if (key_op->op_type != OP_CONST)
6870 rop->op_type = OP_RV2AV;
6871 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6872 o->op_type = OP_ASLICE;
6873 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6874 for (key_op = first_key_op; key_op;
6875 key_op = (SVOP*)key_op->op_sibling) {
6876 svp = cSVOPx_svp(key_op);
6877 key = SvPV(*svp, keylen);
6880 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6882 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6883 "in variable %s of type %s",
6884 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6886 ind = SvIV(*indsvp);
6888 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6890 if (SvREADONLY(*svp))
6892 SvFLAGS(sv) |= (SvFLAGS(*svp)
6893 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6902 if (!(o->op_flags & OPf_WANT)
6903 || (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
6907 o->op_seq = PL_op_seqmax++;
6911 if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) {
6912 o->op_seq = PL_op_seqmax++;
6918 if (last_composite) {
6919 OP *r = last_composite;
6921 while (r->op_sibling)
6924 || (r->op_next->op_type == OP_LIST
6925 && r->op_next->op_next == o))
6927 if (last_composite->op_type == OP_RV2AV)
6928 yyerror("Lvalue subs returning arrays not implemented yet");
6930 yyerror("Lvalue subs returning hashes not implemented yet");
6937 o->op_seq = PL_op_seqmax++;
6947 /* Efficient sub that returns a constant scalar value. */
6949 const_sv_xsub(pTHXo_ CV* cv)
6953 ST(0) = (SV*)XSANY.any_ptr;