3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 /* #define PL_OP_SLAB_ALLOC */
25 #ifdef PL_OP_SLAB_ALLOC
26 #define SLAB_SIZE 8192
27 static char *PL_OpPtr = NULL;
28 static int PL_OpSpace = 0;
29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
30 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
32 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
36 S_Slab_Alloc(pTHX_ int m, size_t sz)
38 Newz(m,PL_OpPtr,SLAB_SIZE,char);
39 PL_OpSpace = SLAB_SIZE - sz;
40 return PL_OpPtr += PL_OpSpace;
44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
47 * In the following definition, the ", Nullop" is just to make the compiler
48 * think the expression is of the right type: croak actually does a Siglongjmp.
50 #define CHECKOP(type,o) \
51 ((PL_op_mask && PL_op_mask[type]) \
52 ? ( op_free((OP*)o), \
53 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
55 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
57 #define PAD_MAX 999999999
58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
61 S_gv_ename(pTHX_ GV *gv)
64 SV* tmpsv = sv_newmortal();
65 gv_efullname3(tmpsv, gv, Nullch);
66 return SvPV(tmpsv,n_a);
70 S_no_fh_allowed(pTHX_ OP *o)
72 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
73 PL_op_desc[o->op_type]));
78 S_too_few_arguments(pTHX_ OP *o, char *name)
80 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
85 S_too_many_arguments(pTHX_ OP *o, char *name)
87 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
94 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
95 (int)n, name, t, PL_op_desc[kid->op_type]));
99 S_no_bareword_allowed(pTHX_ OP *o)
101 qerror(Perl_mess(aTHX_
102 "Bareword \"%s\" not allowed while \"strict subs\" in use",
103 SvPV_nolen(cSVOPo_sv)));
107 S_trlist_upgrade(pTHX_ U8** sp, U8** ep)
113 Newz(801, d, (e - s) * 2, U8);
117 if (*s < 0x80 || *s == 0xff)
121 *d++ = ((c >> 6) | 0xc0);
122 *d++ = ((c & 0x3f) | 0x80);
130 /* "register" allocation */
133 Perl_pad_allocmy(pTHX_ char *name)
138 if (!(PL_in_my == KEY_our ||
140 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
141 (name[1] == '_' && (int)strlen(name) > 2)))
143 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
144 /* 1999-02-27 mjd@plover.com */
146 p = strchr(name, '\0');
147 /* The next block assumes the buffer is at least 205 chars
148 long. At present, it's always at least 256 chars. */
150 strcpy(name+200, "...");
156 /* Move everything else down one character */
157 for (; p-name > 2; p--)
159 name[2] = toCTRL(name[1]);
162 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
164 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
165 SV **svp = AvARRAY(PL_comppad_name);
166 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
167 PADOFFSET top = AvFILLp(PL_comppad_name);
168 for (off = top; off > PL_comppad_name_floor; off--) {
170 && sv != &PL_sv_undef
171 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
172 && (PL_in_my != KEY_our
173 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
174 && strEQ(name, SvPVX(sv)))
176 Perl_warner(aTHX_ WARN_MISC,
177 "\"%s\" variable %s masks earlier declaration in same %s",
178 (PL_in_my == KEY_our ? "our" : "my"),
180 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
185 if (PL_in_my == KEY_our) {
188 && sv != &PL_sv_undef
189 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
190 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
191 && strEQ(name, SvPVX(sv)))
193 Perl_warner(aTHX_ WARN_MISC,
194 "\"our\" variable %s redeclared", name);
195 Perl_warner(aTHX_ WARN_MISC,
196 "\t(Did you mean \"local\" instead of \"our\"?)\n");
199 } while ( off-- > 0 );
202 off = pad_alloc(OP_PADSV, SVs_PADMY);
204 sv_upgrade(sv, SVt_PVNV);
206 if (PL_in_my_stash) {
208 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
209 name, PL_in_my == KEY_our ? "our" : "my"));
211 (void)SvUPGRADE(sv, SVt_PVMG);
212 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
215 if (PL_in_my == KEY_our) {
216 (void)SvUPGRADE(sv, SVt_PVGV);
217 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
218 SvFLAGS(sv) |= SVpad_OUR;
220 av_store(PL_comppad_name, off, sv);
221 SvNVX(sv) = (NV)PAD_MAX;
222 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
223 if (!PL_min_intro_pending)
224 PL_min_intro_pending = off;
225 PL_max_intro_pending = off;
227 av_store(PL_comppad, off, (SV*)newAV());
228 else if (*name == '%')
229 av_store(PL_comppad, off, (SV*)newHV());
230 SvPADMY_on(PL_curpad[off]);
235 S_pad_addlex(pTHX_ SV *proto_namesv)
237 SV *namesv = NEWSV(1103,0);
238 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
239 sv_upgrade(namesv, SVt_PVNV);
240 sv_setpv(namesv, SvPVX(proto_namesv));
241 av_store(PL_comppad_name, newoff, namesv);
242 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
243 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
244 SvFAKE_on(namesv); /* A ref, not a real var */
245 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
246 SvFLAGS(namesv) |= SVpad_OUR;
247 (void)SvUPGRADE(namesv, SVt_PVGV);
248 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
250 if (SvOBJECT(proto_namesv)) { /* A typed var */
252 (void)SvUPGRADE(namesv, SVt_PVMG);
253 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
259 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
262 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
263 I32 cx_ix, I32 saweval, U32 flags)
269 register PERL_CONTEXT *cx;
271 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
272 AV *curlist = CvPADLIST(cv);
273 SV **svp = av_fetch(curlist, 0, FALSE);
276 if (!svp || *svp == &PL_sv_undef)
279 svp = AvARRAY(curname);
280 for (off = AvFILLp(curname); off > 0; off--) {
281 if ((sv = svp[off]) &&
282 sv != &PL_sv_undef &&
284 seq > I_32(SvNVX(sv)) &&
285 strEQ(SvPVX(sv), name))
296 return 0; /* don't clone from inactive stack frame */
300 oldpad = (AV*)AvARRAY(curlist)[depth];
301 oldsv = *av_fetch(oldpad, off, TRUE);
302 if (!newoff) { /* Not a mere clone operation. */
303 newoff = pad_addlex(sv);
304 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
305 /* "It's closures all the way down." */
306 CvCLONE_on(PL_compcv);
308 if (CvANON(PL_compcv))
309 oldsv = Nullsv; /* no need to keep ref */
314 bcv && bcv != cv && !CvCLONE(bcv);
315 bcv = CvOUTSIDE(bcv))
318 /* install the missing pad entry in intervening
319 * nested subs and mark them cloneable.
320 * XXX fix pad_foo() to not use globals */
321 AV *ocomppad_name = PL_comppad_name;
322 AV *ocomppad = PL_comppad;
323 SV **ocurpad = PL_curpad;
324 AV *padlist = CvPADLIST(bcv);
325 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
326 PL_comppad = (AV*)AvARRAY(padlist)[1];
327 PL_curpad = AvARRAY(PL_comppad);
329 PL_comppad_name = ocomppad_name;
330 PL_comppad = ocomppad;
335 if (ckWARN(WARN_CLOSURE)
336 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
338 Perl_warner(aTHX_ WARN_CLOSURE,
339 "Variable \"%s\" may be unavailable",
347 else if (!CvUNIQUE(PL_compcv)) {
348 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
349 && !(SvFLAGS(sv) & SVpad_OUR))
351 Perl_warner(aTHX_ WARN_CLOSURE,
352 "Variable \"%s\" will not stay shared", name);
356 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
362 if (flags & FINDLEX_NOSEARCH)
365 /* Nothing in current lexical context--try eval's context, if any.
366 * This is necessary to let the perldb get at lexically scoped variables.
367 * XXX This will also probably interact badly with eval tree caching.
370 for (i = cx_ix; i >= 0; i--) {
372 switch (CxTYPE(cx)) {
374 if (i == 0 && saweval) {
375 seq = cxstack[saweval].blk_oldcop->cop_seq;
376 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
380 switch (cx->blk_eval.old_op_type) {
387 /* require/do must have their own scope */
396 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
397 saweval = i; /* so we know where we were called from */
400 seq = cxstack[saweval].blk_oldcop->cop_seq;
401 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
409 Perl_pad_findmy(pTHX_ char *name)
414 SV **svp = AvARRAY(PL_comppad_name);
415 U32 seq = PL_cop_seqmax;
421 * Special case to get lexical (and hence per-thread) @_.
422 * XXX I need to find out how to tell at parse-time whether use
423 * of @_ should refer to a lexical (from a sub) or defgv (global
424 * scope and maybe weird sub-ish things like formats). See
425 * startsub in perly.y. It's possible that @_ could be lexical
426 * (at least from subs) even in non-threaded perl.
428 if (strEQ(name, "@_"))
429 return 0; /* success. (NOT_IN_PAD indicates failure) */
430 #endif /* USE_THREADS */
432 /* The one we're looking for is probably just before comppad_name_fill. */
433 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
434 if ((sv = svp[off]) &&
435 sv != &PL_sv_undef &&
438 seq > I_32(SvNVX(sv)))) &&
439 strEQ(SvPVX(sv), name))
441 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
442 return (PADOFFSET)off;
443 pendoff = off; /* this pending def. will override import */
447 outside = CvOUTSIDE(PL_compcv);
449 /* Check if if we're compiling an eval'', and adjust seq to be the
450 * eval's seq number. This depends on eval'' having a non-null
451 * CvOUTSIDE() while it is being compiled. The eval'' itself is
452 * identified by CvEVAL being true and CvGV being null. */
453 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
454 cx = &cxstack[cxstack_ix];
456 seq = cx->blk_oldcop->cop_seq;
459 /* See if it's in a nested scope */
460 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
462 /* If there is a pending local definition, this new alias must die */
464 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
465 return off; /* pad_findlex returns 0 for failure...*/
467 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
471 Perl_pad_leavemy(pTHX_ I32 fill)
474 SV **svp = AvARRAY(PL_comppad_name);
476 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
477 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
478 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
479 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
482 /* "Deintroduce" my variables that are leaving with this scope. */
483 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
484 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
485 SvIVX(sv) = PL_cop_seqmax;
490 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
495 if (AvARRAY(PL_comppad) != PL_curpad)
496 Perl_croak(aTHX_ "panic: pad_alloc");
497 if (PL_pad_reset_pending)
499 if (tmptype & SVs_PADMY) {
501 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
502 } while (SvPADBUSY(sv)); /* need a fresh one */
503 retval = AvFILLp(PL_comppad);
506 SV **names = AvARRAY(PL_comppad_name);
507 SSize_t names_fill = AvFILLp(PL_comppad_name);
510 * "foreach" index vars temporarily become aliases to non-"my"
511 * values. Thus we must skip, not just pad values that are
512 * marked as current pad values, but also those with names.
514 if (++PL_padix <= names_fill &&
515 (sv = names[PL_padix]) && sv != &PL_sv_undef)
517 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
518 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
519 !IS_PADGV(sv) && !IS_PADCONST(sv))
524 SvFLAGS(sv) |= tmptype;
525 PL_curpad = AvARRAY(PL_comppad);
527 DEBUG_X(PerlIO_printf(Perl_debug_log,
528 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
529 PTR2UV(thr), PTR2UV(PL_curpad),
530 (long) retval, PL_op_name[optype]));
532 DEBUG_X(PerlIO_printf(Perl_debug_log,
533 "Pad 0x%"UVxf" alloc %ld for %s\n",
535 (long) retval, PL_op_name[optype]));
536 #endif /* USE_THREADS */
537 return (PADOFFSET)retval;
541 Perl_pad_sv(pTHX_ PADOFFSET po)
544 DEBUG_X(PerlIO_printf(Perl_debug_log,
545 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
546 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
549 Perl_croak(aTHX_ "panic: pad_sv po");
550 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
551 PTR2UV(PL_curpad), (IV)po));
552 #endif /* USE_THREADS */
553 return PL_curpad[po]; /* eventually we'll turn this into a macro */
557 Perl_pad_free(pTHX_ PADOFFSET po)
561 if (AvARRAY(PL_comppad) != PL_curpad)
562 Perl_croak(aTHX_ "panic: pad_free curpad");
564 Perl_croak(aTHX_ "panic: pad_free po");
566 DEBUG_X(PerlIO_printf(Perl_debug_log,
567 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
568 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
570 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
571 PTR2UV(PL_curpad), (IV)po));
572 #endif /* USE_THREADS */
573 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
574 SvPADTMP_off(PL_curpad[po]);
576 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
579 if ((I32)po < PL_padix)
584 Perl_pad_swipe(pTHX_ PADOFFSET po)
586 if (AvARRAY(PL_comppad) != PL_curpad)
587 Perl_croak(aTHX_ "panic: pad_swipe curpad");
589 Perl_croak(aTHX_ "panic: pad_swipe po");
591 DEBUG_X(PerlIO_printf(Perl_debug_log,
592 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
593 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
595 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
596 PTR2UV(PL_curpad), (IV)po));
597 #endif /* USE_THREADS */
598 SvPADTMP_off(PL_curpad[po]);
599 PL_curpad[po] = NEWSV(1107,0);
600 SvPADTMP_on(PL_curpad[po]);
601 if ((I32)po < PL_padix)
605 /* XXX pad_reset() is currently disabled because it results in serious bugs.
606 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
607 * on the stack by OPs that use them, there are several ways to get an alias
608 * to a shared TARG. Such an alias will change randomly and unpredictably.
609 * We avoid doing this until we can think of a Better Way.
614 #ifdef USE_BROKEN_PAD_RESET
617 if (AvARRAY(PL_comppad) != PL_curpad)
618 Perl_croak(aTHX_ "panic: pad_reset curpad");
620 DEBUG_X(PerlIO_printf(Perl_debug_log,
621 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
622 PTR2UV(thr), PTR2UV(PL_curpad)));
624 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
626 #endif /* USE_THREADS */
627 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
628 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
629 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
630 SvPADTMP_off(PL_curpad[po]);
632 PL_padix = PL_padix_floor;
635 PL_pad_reset_pending = FALSE;
639 /* find_threadsv is not reentrant */
641 Perl_find_threadsv(pTHX_ const char *name)
646 /* We currently only handle names of a single character */
647 p = strchr(PL_threadsv_names, *name);
650 key = p - PL_threadsv_names;
651 MUTEX_LOCK(&thr->mutex);
652 svp = av_fetch(thr->threadsv, key, FALSE);
654 MUTEX_UNLOCK(&thr->mutex);
656 SV *sv = NEWSV(0, 0);
657 av_store(thr->threadsv, key, sv);
658 thr->threadsvp = AvARRAY(thr->threadsv);
659 MUTEX_UNLOCK(&thr->mutex);
661 * Some magic variables used to be automagically initialised
662 * in gv_fetchpv. Those which are now per-thread magicals get
663 * initialised here instead.
669 sv_setpv(sv, "\034");
670 sv_magic(sv, 0, 0, name, 1);
675 PL_sawampersand = TRUE;
689 /* XXX %! tied to Errno.pm needs to be added here.
690 * See gv_fetchpv(). */
694 sv_magic(sv, 0, 0, name, 1);
696 DEBUG_S(PerlIO_printf(Perl_error_log,
697 "find_threadsv: new SV %p for $%s%c\n",
698 sv, (*name < 32) ? "^" : "",
699 (*name < 32) ? toCTRL(*name) : *name));
703 #endif /* USE_THREADS */
708 Perl_op_free(pTHX_ OP *o)
710 register OP *kid, *nextkid;
713 if (!o || o->op_seq == (U16)-1)
716 if (o->op_private & OPpREFCOUNTED) {
717 switch (o->op_type) {
725 if (OpREFCNT_dec(o)) {
736 if (o->op_flags & OPf_KIDS) {
737 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
738 nextkid = kid->op_sibling; /* Get before next freeing kid */
746 /* COP* is not cleared by op_clear() so that we may track line
747 * numbers etc even after null() */
748 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
753 #ifdef PL_OP_SLAB_ALLOC
754 if ((char *) o == PL_OpPtr)
763 S_op_clear(pTHX_ OP *o)
765 switch (o->op_type) {
766 case OP_NULL: /* Was holding old type, if any. */
767 case OP_ENTEREVAL: /* Was holding hints. */
769 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
775 if (!(o->op_flags & OPf_SPECIAL))
778 #endif /* USE_THREADS */
780 if (!(o->op_flags & OPf_REF)
781 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
788 if (cPADOPo->op_padix > 0) {
791 pad_swipe(cPADOPo->op_padix);
792 /* No GvIN_PAD_off(gv) here, because other references may still
793 * exist on the pad */
796 cPADOPo->op_padix = 0;
799 SvREFCNT_dec(cSVOPo->op_sv);
800 cSVOPo->op_sv = Nullsv;
803 case OP_METHOD_NAMED:
805 SvREFCNT_dec(cSVOPo->op_sv);
806 cSVOPo->op_sv = Nullsv;
812 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
816 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
817 SvREFCNT_dec(cSVOPo->op_sv);
818 cSVOPo->op_sv = Nullsv;
821 Safefree(cPVOPo->op_pv);
822 cPVOPo->op_pv = Nullch;
826 op_free(cPMOPo->op_pmreplroot);
830 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
832 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
833 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
834 /* No GvIN_PAD_off(gv) here, because other references may still
835 * exist on the pad */
840 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
846 cPMOPo->op_pmreplroot = Nullop;
847 ReREFCNT_dec(cPMOPo->op_pmregexp);
848 cPMOPo->op_pmregexp = (REGEXP*)NULL;
852 if (o->op_targ > 0) {
853 pad_free(o->op_targ);
859 S_cop_free(pTHX_ COP* cop)
861 Safefree(cop->cop_label);
863 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
864 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
866 /* NOTE: COP.cop_stash is not refcounted */
867 SvREFCNT_dec(CopFILEGV(cop));
869 if (! specialWARN(cop->cop_warnings))
870 SvREFCNT_dec(cop->cop_warnings);
871 if (! specialCopIO(cop->cop_io))
872 SvREFCNT_dec(cop->cop_io);
878 if (o->op_type == OP_NULL)
881 o->op_targ = o->op_type;
882 o->op_type = OP_NULL;
883 o->op_ppaddr = PL_ppaddr[OP_NULL];
886 /* Contextualizers */
888 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
891 Perl_linklist(pTHX_ OP *o)
898 /* establish postfix order */
899 if (cUNOPo->op_first) {
900 o->op_next = LINKLIST(cUNOPo->op_first);
901 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
903 kid->op_next = LINKLIST(kid->op_sibling);
915 Perl_scalarkids(pTHX_ OP *o)
918 if (o && o->op_flags & OPf_KIDS) {
919 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
926 S_scalarboolean(pTHX_ OP *o)
928 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
929 if (ckWARN(WARN_SYNTAX)) {
930 line_t oldline = CopLINE(PL_curcop);
932 if (PL_copline != NOLINE)
933 CopLINE_set(PL_curcop, PL_copline);
934 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
935 CopLINE_set(PL_curcop, oldline);
942 Perl_scalar(pTHX_ OP *o)
946 /* assumes no premature commitment */
947 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
948 || o->op_type == OP_RETURN)
953 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
955 switch (o->op_type) {
957 if (o->op_private & OPpREPEAT_DOLIST)
958 null(((LISTOP*)cBINOPo->op_first)->op_first);
959 scalar(cBINOPo->op_first);
964 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
968 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
969 if (!kPMOP->op_pmreplroot)
970 deprecate("implicit split to @_");
978 if (o->op_flags & OPf_KIDS) {
979 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
985 kid = cLISTOPo->op_first;
987 while ((kid = kid->op_sibling)) {
993 WITH_THR(PL_curcop = &PL_compiling);
998 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1004 WITH_THR(PL_curcop = &PL_compiling);
1011 Perl_scalarvoid(pTHX_ OP *o)
1018 if (o->op_type == OP_NEXTSTATE
1019 || o->op_type == OP_SETSTATE
1020 || o->op_type == OP_DBSTATE
1021 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1022 || o->op_targ == OP_SETSTATE
1023 || o->op_targ == OP_DBSTATE)))
1024 PL_curcop = (COP*)o; /* for warning below */
1026 /* assumes no premature commitment */
1027 want = o->op_flags & OPf_WANT;
1028 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1029 || o->op_type == OP_RETURN)
1034 if ((o->op_private & OPpTARGET_MY)
1035 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1037 return scalar(o); /* As if inside SASSIGN */
1040 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1042 switch (o->op_type) {
1044 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1048 if (o->op_flags & OPf_STACKED)
1052 if (o->op_private == 4)
1094 case OP_GETSOCKNAME:
1095 case OP_GETPEERNAME:
1100 case OP_GETPRIORITY:
1123 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1124 useless = PL_op_desc[o->op_type];
1131 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1132 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1133 useless = "a variable";
1138 if (cSVOPo->op_private & OPpCONST_STRICT)
1139 no_bareword_allowed(o);
1141 if (ckWARN(WARN_VOID)) {
1142 useless = "a constant";
1143 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1145 else if (SvPOK(sv)) {
1146 /* perl4's way of mixing documentation and code
1147 (before the invention of POD) was based on a
1148 trick to mix nroff and perl code. The trick was
1149 built upon these three nroff macros being used in
1150 void context. The pink camel has the details in
1151 the script wrapman near page 319. */
1152 if (strnEQ(SvPVX(sv), "di", 2) ||
1153 strnEQ(SvPVX(sv), "ds", 2) ||
1154 strnEQ(SvPVX(sv), "ig", 2))
1159 null(o); /* don't execute or even remember it */
1163 o->op_type = OP_PREINC; /* pre-increment is faster */
1164 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1168 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1169 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1175 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1180 if (o->op_flags & OPf_STACKED)
1187 if (!(o->op_flags & OPf_KIDS))
1196 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1203 /* all requires must return a boolean value */
1204 o->op_flags &= ~OPf_WANT;
1209 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1210 if (!kPMOP->op_pmreplroot)
1211 deprecate("implicit split to @_");
1215 if (useless && ckWARN(WARN_VOID))
1216 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1221 Perl_listkids(pTHX_ OP *o)
1224 if (o && o->op_flags & OPf_KIDS) {
1225 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1232 Perl_list(pTHX_ OP *o)
1236 /* assumes no premature commitment */
1237 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1238 || o->op_type == OP_RETURN)
1243 if ((o->op_private & OPpTARGET_MY)
1244 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1246 return o; /* As if inside SASSIGN */
1249 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1251 switch (o->op_type) {
1254 list(cBINOPo->op_first);
1259 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1267 if (!(o->op_flags & OPf_KIDS))
1269 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1270 list(cBINOPo->op_first);
1271 return gen_constant_list(o);
1278 kid = cLISTOPo->op_first;
1280 while ((kid = kid->op_sibling)) {
1281 if (kid->op_sibling)
1286 WITH_THR(PL_curcop = &PL_compiling);
1290 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1291 if (kid->op_sibling)
1296 WITH_THR(PL_curcop = &PL_compiling);
1299 /* all requires must return a boolean value */
1300 o->op_flags &= ~OPf_WANT;
1307 Perl_scalarseq(pTHX_ OP *o)
1312 if (o->op_type == OP_LINESEQ ||
1313 o->op_type == OP_SCOPE ||
1314 o->op_type == OP_LEAVE ||
1315 o->op_type == OP_LEAVETRY)
1317 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1318 if (kid->op_sibling) {
1322 PL_curcop = &PL_compiling;
1324 o->op_flags &= ~OPf_PARENS;
1325 if (PL_hints & HINT_BLOCK_SCOPE)
1326 o->op_flags |= OPf_PARENS;
1329 o = newOP(OP_STUB, 0);
1334 S_modkids(pTHX_ OP *o, I32 type)
1337 if (o && o->op_flags & OPf_KIDS) {
1338 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1345 Perl_mod(pTHX_ OP *o, I32 type)
1350 if (!o || PL_error_count)
1353 if ((o->op_private & OPpTARGET_MY)
1354 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1359 switch (o->op_type) {
1364 if (o->op_private & (OPpCONST_BARE) &&
1365 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1366 SV *sv = ((SVOP*)o)->op_sv;
1369 /* Could be a filehandle */
1370 if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1371 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1375 /* OK, it's a sub */
1377 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1379 enter = newUNOP(OP_ENTERSUB,0,
1380 newUNOP(OP_RV2CV, 0,
1381 newGVOP(OP_GV, 0, gv)
1383 enter->op_private |= OPpLVAL_INTRO;
1389 if (!(o->op_private & (OPpCONST_ARYBASE)))
1391 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1392 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1396 SAVEI32(PL_compiling.cop_arybase);
1397 PL_compiling.cop_arybase = 0;
1399 else if (type == OP_REFGEN)
1402 Perl_croak(aTHX_ "That use of $[ is unsupported");
1405 if (o->op_flags & OPf_PARENS)
1409 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1410 !(o->op_flags & OPf_STACKED)) {
1411 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1412 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1413 assert(cUNOPo->op_first->op_type == OP_NULL);
1414 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1417 else { /* lvalue subroutine call */
1418 o->op_private |= OPpLVAL_INTRO;
1419 PL_modcount = RETURN_UNLIMITED_NUMBER;
1420 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1421 /* Backward compatibility mode: */
1422 o->op_private |= OPpENTERSUB_INARGS;
1425 else { /* Compile-time error message: */
1426 OP *kid = cUNOPo->op_first;
1430 if (kid->op_type == OP_PUSHMARK)
1432 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1434 "panic: unexpected lvalue entersub "
1435 "args: type/targ %ld:%ld",
1436 (long)kid->op_type,kid->op_targ);
1437 kid = kLISTOP->op_first;
1439 while (kid->op_sibling)
1440 kid = kid->op_sibling;
1441 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1443 if (kid->op_type == OP_METHOD_NAMED
1444 || kid->op_type == OP_METHOD)
1448 if (kid->op_sibling || kid->op_next != kid) {
1449 yyerror("panic: unexpected optree near method call");
1453 NewOp(1101, newop, 1, UNOP);
1454 newop->op_type = OP_RV2CV;
1455 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456 newop->op_first = Nullop;
1457 newop->op_next = (OP*)newop;
1458 kid->op_sibling = (OP*)newop;
1459 newop->op_private |= OPpLVAL_INTRO;
1463 if (kid->op_type != OP_RV2CV)
1465 "panic: unexpected lvalue entersub "
1466 "entry via type/targ %ld:%ld",
1467 (long)kid->op_type,kid->op_targ);
1468 kid->op_private |= OPpLVAL_INTRO;
1469 break; /* Postpone until runtime */
1473 kid = kUNOP->op_first;
1474 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1475 kid = kUNOP->op_first;
1476 if (kid->op_type == OP_NULL)
1478 "Unexpected constant lvalue entersub "
1479 "entry via type/targ %ld:%ld",
1480 (long)kid->op_type,kid->op_targ);
1481 if (kid->op_type != OP_GV) {
1482 /* Restore RV2CV to check lvalueness */
1484 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1485 okid->op_next = kid->op_next;
1486 kid->op_next = okid;
1489 okid->op_next = Nullop;
1490 okid->op_type = OP_RV2CV;
1492 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1493 okid->op_private |= OPpLVAL_INTRO;
1497 cv = GvCV(kGVOP_gv);
1507 /* grep, foreach, subcalls, refgen */
1508 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1510 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1511 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1513 : (o->op_type == OP_ENTERSUB
1514 ? "non-lvalue subroutine call"
1515 : PL_op_desc[o->op_type])),
1516 type ? PL_op_desc[type] : "local"));
1530 case OP_RIGHT_SHIFT:
1539 if (!(o->op_flags & OPf_STACKED))
1545 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1551 if (!type && cUNOPo->op_first->op_type != OP_GV)
1552 Perl_croak(aTHX_ "Can't localize through a reference");
1553 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1554 PL_modcount = RETURN_UNLIMITED_NUMBER;
1555 return o; /* Treat \(@foo) like ordinary list. */
1559 if (scalar_mod_type(o, type))
1561 ref(cUNOPo->op_first, o->op_type);
1565 if (type == OP_LEAVESUBLV)
1566 o->op_private |= OPpMAYBE_LVSUB;
1572 PL_modcount = RETURN_UNLIMITED_NUMBER;
1575 if (!type && cUNOPo->op_first->op_type != OP_GV)
1576 Perl_croak(aTHX_ "Can't localize through a reference");
1577 ref(cUNOPo->op_first, o->op_type);
1581 PL_hints |= HINT_BLOCK_SCOPE;
1591 PL_modcount = RETURN_UNLIMITED_NUMBER;
1592 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1593 return o; /* Treat \(@foo) like ordinary list. */
1594 if (scalar_mod_type(o, type))
1596 if (type == OP_LEAVESUBLV)
1597 o->op_private |= OPpMAYBE_LVSUB;
1602 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1603 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1608 PL_modcount++; /* XXX ??? */
1610 #endif /* USE_THREADS */
1616 if (type != OP_SASSIGN)
1620 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1628 pad_free(o->op_targ);
1629 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1630 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1631 if (o->op_flags & OPf_KIDS)
1632 mod(cBINOPo->op_first->op_sibling, type);
1637 ref(cBINOPo->op_first, o->op_type);
1638 if (type == OP_ENTERSUB &&
1639 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1640 o->op_private |= OPpLVAL_DEFER;
1641 if (type == OP_LEAVESUBLV)
1642 o->op_private |= OPpMAYBE_LVSUB;
1650 if (o->op_flags & OPf_KIDS)
1651 mod(cLISTOPo->op_last, type);
1655 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1657 else if (!(o->op_flags & OPf_KIDS))
1659 if (o->op_targ != OP_LIST) {
1660 mod(cBINOPo->op_first, type);
1665 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1670 if (type != OP_LEAVESUBLV)
1672 break; /* mod()ing was handled by ck_return() */
1674 if (type != OP_LEAVESUBLV)
1675 o->op_flags |= OPf_MOD;
1677 if (type == OP_AASSIGN || type == OP_SASSIGN)
1678 o->op_flags |= OPf_SPECIAL|OPf_REF;
1680 o->op_private |= OPpLVAL_INTRO;
1681 o->op_flags &= ~OPf_SPECIAL;
1682 PL_hints |= HINT_BLOCK_SCOPE;
1684 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1685 && type != OP_LEAVESUBLV)
1686 o->op_flags |= OPf_REF;
1691 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1695 if (o->op_type == OP_RV2GV)
1719 case OP_RIGHT_SHIFT:
1738 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1740 switch (o->op_type) {
1748 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1761 Perl_refkids(pTHX_ OP *o, I32 type)
1764 if (o && o->op_flags & OPf_KIDS) {
1765 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1772 Perl_ref(pTHX_ OP *o, I32 type)
1776 if (!o || PL_error_count)
1779 switch (o->op_type) {
1781 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1782 !(o->op_flags & OPf_STACKED)) {
1783 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1784 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1785 assert(cUNOPo->op_first->op_type == OP_NULL);
1786 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1787 o->op_flags |= OPf_SPECIAL;
1792 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1796 if (type == OP_DEFINED)
1797 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1798 ref(cUNOPo->op_first, o->op_type);
1801 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1802 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1803 : type == OP_RV2HV ? OPpDEREF_HV
1805 o->op_flags |= OPf_MOD;
1810 o->op_flags |= OPf_MOD; /* XXX ??? */
1815 o->op_flags |= OPf_REF;
1818 if (type == OP_DEFINED)
1819 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1820 ref(cUNOPo->op_first, o->op_type);
1825 o->op_flags |= OPf_REF;
1830 if (!(o->op_flags & OPf_KIDS))
1832 ref(cBINOPo->op_first, type);
1836 ref(cBINOPo->op_first, o->op_type);
1837 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1838 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1839 : type == OP_RV2HV ? OPpDEREF_HV
1841 o->op_flags |= OPf_MOD;
1849 if (!(o->op_flags & OPf_KIDS))
1851 ref(cLISTOPo->op_last, type);
1861 S_dup_attrlist(pTHX_ OP *o)
1865 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1866 * where the first kid is OP_PUSHMARK and the remaining ones
1867 * are OP_CONST. We need to push the OP_CONST values.
1869 if (o->op_type == OP_CONST)
1870 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1872 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1873 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1874 if (o->op_type == OP_CONST)
1875 rop = append_elem(OP_LIST, rop,
1876 newSVOP(OP_CONST, o->op_flags,
1877 SvREFCNT_inc(cSVOPo->op_sv)));
1884 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1888 /* fake up C<use attributes $pkg,$rv,@attrs> */
1889 ENTER; /* need to protect against side-effects of 'use' */
1891 if (stash && HvNAME(stash))
1892 stashsv = newSVpv(HvNAME(stash), 0);
1894 stashsv = &PL_sv_no;
1896 #define ATTRSMODULE "attributes"
1898 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1899 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1901 prepend_elem(OP_LIST,
1902 newSVOP(OP_CONST, 0, stashsv),
1903 prepend_elem(OP_LIST,
1904 newSVOP(OP_CONST, 0,
1906 dup_attrlist(attrs))));
1911 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1912 char *attrstr, STRLEN len)
1917 len = strlen(attrstr);
1921 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1923 char *sstr = attrstr;
1924 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1925 attrs = append_elem(OP_LIST, attrs,
1926 newSVOP(OP_CONST, 0,
1927 newSVpvn(sstr, attrstr-sstr)));
1931 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1932 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1933 Nullsv, prepend_elem(OP_LIST,
1934 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1935 prepend_elem(OP_LIST,
1936 newSVOP(OP_CONST, 0,
1942 S_my_kid(pTHX_ OP *o, OP *attrs)
1947 if (!o || PL_error_count)
1951 if (type == OP_LIST) {
1952 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1954 } else if (type == OP_UNDEF) {
1956 } else if (type == OP_RV2SV || /* "our" declaration */
1958 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1960 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1962 PL_in_my_stash = Nullhv;
1963 apply_attrs(GvSTASH(gv),
1964 (type == OP_RV2SV ? GvSV(gv) :
1965 type == OP_RV2AV ? (SV*)GvAV(gv) :
1966 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1969 o->op_private |= OPpOUR_INTRO;
1971 } else if (type != OP_PADSV &&
1974 type != OP_PUSHMARK)
1976 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1977 PL_op_desc[o->op_type],
1978 PL_in_my == KEY_our ? "our" : "my"));
1981 else if (attrs && type != OP_PUSHMARK) {
1987 PL_in_my_stash = Nullhv;
1989 /* check for C<my Dog $spot> when deciding package */
1990 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1991 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1992 stash = SvSTASH(*namesvp);
1994 stash = PL_curstash;
1995 padsv = PAD_SV(o->op_targ);
1996 apply_attrs(stash, padsv, attrs);
1998 o->op_flags |= OPf_MOD;
1999 o->op_private |= OPpLVAL_INTRO;
2004 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2006 if (o->op_flags & OPf_PARENS)
2010 o = my_kid(o, attrs);
2012 PL_in_my_stash = Nullhv;
2017 Perl_my(pTHX_ OP *o)
2019 return my_kid(o, Nullop);
2023 Perl_sawparens(pTHX_ OP *o)
2026 o->op_flags |= OPf_PARENS;
2031 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2035 if (ckWARN(WARN_MISC) &&
2036 (left->op_type == OP_RV2AV ||
2037 left->op_type == OP_RV2HV ||
2038 left->op_type == OP_PADAV ||
2039 left->op_type == OP_PADHV)) {
2040 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2041 right->op_type == OP_TRANS)
2042 ? right->op_type : OP_MATCH];
2043 const char *sample = ((left->op_type == OP_RV2AV ||
2044 left->op_type == OP_PADAV)
2045 ? "@array" : "%hash");
2046 Perl_warner(aTHX_ WARN_MISC,
2047 "Applying %s to %s will act on scalar(%s)",
2048 desc, sample, sample);
2051 if (!(right->op_flags & OPf_STACKED) &&
2052 (right->op_type == OP_MATCH ||
2053 right->op_type == OP_SUBST ||
2054 right->op_type == OP_TRANS)) {
2055 right->op_flags |= OPf_STACKED;
2056 if (right->op_type != OP_MATCH &&
2057 ! (right->op_type == OP_TRANS &&
2058 right->op_private & OPpTRANS_IDENTICAL))
2059 left = mod(left, right->op_type);
2060 if (right->op_type == OP_TRANS)
2061 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2063 o = prepend_elem(right->op_type, scalar(left), right);
2065 return newUNOP(OP_NOT, 0, scalar(o));
2069 return bind_match(type, left,
2070 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2074 Perl_invert(pTHX_ OP *o)
2078 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2079 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2083 Perl_scope(pTHX_ OP *o)
2086 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2087 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2088 o->op_type = OP_LEAVE;
2089 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2092 if (o->op_type == OP_LINESEQ) {
2094 o->op_type = OP_SCOPE;
2095 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2096 kid = ((LISTOP*)o)->op_first;
2097 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2101 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2108 Perl_save_hints(pTHX)
2111 SAVESPTR(GvHV(PL_hintgv));
2112 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2113 SAVEFREESV(GvHV(PL_hintgv));
2117 Perl_block_start(pTHX_ int full)
2119 int retval = PL_savestack_ix;
2121 SAVEI32(PL_comppad_name_floor);
2122 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2124 PL_comppad_name_fill = PL_comppad_name_floor;
2125 if (PL_comppad_name_floor < 0)
2126 PL_comppad_name_floor = 0;
2127 SAVEI32(PL_min_intro_pending);
2128 SAVEI32(PL_max_intro_pending);
2129 PL_min_intro_pending = 0;
2130 SAVEI32(PL_comppad_name_fill);
2131 SAVEI32(PL_padix_floor);
2132 PL_padix_floor = PL_padix;
2133 PL_pad_reset_pending = FALSE;
2135 PL_hints &= ~HINT_BLOCK_SCOPE;
2136 SAVESPTR(PL_compiling.cop_warnings);
2137 if (! specialWARN(PL_compiling.cop_warnings)) {
2138 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2139 SAVEFREESV(PL_compiling.cop_warnings) ;
2141 SAVESPTR(PL_compiling.cop_io);
2142 if (! specialCopIO(PL_compiling.cop_io)) {
2143 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2144 SAVEFREESV(PL_compiling.cop_io) ;
2150 Perl_block_end(pTHX_ I32 floor, OP *seq)
2152 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2153 OP* retval = scalarseq(seq);
2155 PL_pad_reset_pending = FALSE;
2156 PL_compiling.op_private = PL_hints;
2158 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2159 pad_leavemy(PL_comppad_name_fill);
2168 OP *o = newOP(OP_THREADSV, 0);
2169 o->op_targ = find_threadsv("_");
2172 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2173 #endif /* USE_THREADS */
2177 Perl_newPROG(pTHX_ OP *o)
2182 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2183 ((PL_in_eval & EVAL_KEEPERR)
2184 ? OPf_SPECIAL : 0), o);
2185 PL_eval_start = linklist(PL_eval_root);
2186 PL_eval_root->op_private |= OPpREFCOUNTED;
2187 OpREFCNT_set(PL_eval_root, 1);
2188 PL_eval_root->op_next = 0;
2189 peep(PL_eval_start);
2194 PL_main_root = scope(sawparens(scalarvoid(o)));
2195 PL_curcop = &PL_compiling;
2196 PL_main_start = LINKLIST(PL_main_root);
2197 PL_main_root->op_private |= OPpREFCOUNTED;
2198 OpREFCNT_set(PL_main_root, 1);
2199 PL_main_root->op_next = 0;
2200 peep(PL_main_start);
2203 /* Register with debugger */
2205 CV *cv = get_cv("DB::postponed", FALSE);
2209 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2211 call_sv((SV*)cv, G_DISCARD);
2218 Perl_localize(pTHX_ OP *o, I32 lex)
2220 if (o->op_flags & OPf_PARENS)
2223 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2225 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2226 if (*s == ';' || *s == '=')
2227 Perl_warner(aTHX_ WARN_PARENTHESIS,
2228 "Parentheses missing around \"%s\" list",
2229 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2235 o = mod(o, OP_NULL); /* a bit kludgey */
2237 PL_in_my_stash = Nullhv;
2242 Perl_jmaybe(pTHX_ OP *o)
2244 if (o->op_type == OP_LIST) {
2247 o2 = newOP(OP_THREADSV, 0);
2248 o2->op_targ = find_threadsv(";");
2250 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2251 #endif /* USE_THREADS */
2252 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2258 Perl_fold_constants(pTHX_ register OP *o)
2261 I32 type = o->op_type;
2264 if (PL_opargs[type] & OA_RETSCALAR)
2266 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2267 o->op_targ = pad_alloc(type, SVs_PADTMP);
2269 /* integerize op, unless it happens to be C<-foo>.
2270 * XXX should pp_i_negate() do magic string negation instead? */
2271 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2272 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2273 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2275 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2278 if (!(PL_opargs[type] & OA_FOLDCONST))
2283 /* XXX might want a ck_negate() for this */
2284 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2297 if (o->op_private & OPpLOCALE)
2302 goto nope; /* Don't try to run w/ errors */
2304 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2305 if ((curop->op_type != OP_CONST ||
2306 (curop->op_private & OPpCONST_BARE)) &&
2307 curop->op_type != OP_LIST &&
2308 curop->op_type != OP_SCALAR &&
2309 curop->op_type != OP_NULL &&
2310 curop->op_type != OP_PUSHMARK)
2316 curop = LINKLIST(o);
2320 sv = *(PL_stack_sp--);
2321 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2322 pad_swipe(o->op_targ);
2323 else if (SvTEMP(sv)) { /* grab mortal temp? */
2324 (void)SvREFCNT_inc(sv);
2328 if (type == OP_RV2GV)
2329 return newGVOP(OP_GV, 0, (GV*)sv);
2331 /* try to smush double to int, but don't smush -2.0 to -2 */
2332 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2335 #ifdef PERL_PRESERVE_IVUV
2336 /* Only bother to attempt to fold to IV if
2337 most operators will benefit */
2341 return newSVOP(OP_CONST, 0, sv);
2345 if (!(PL_opargs[type] & OA_OTHERINT))
2348 if (!(PL_hints & HINT_INTEGER)) {
2349 if (type == OP_MODULO
2350 || type == OP_DIVIDE
2351 || !(o->op_flags & OPf_KIDS))
2356 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2357 if (curop->op_type == OP_CONST) {
2358 if (SvIOK(((SVOP*)curop)->op_sv))
2362 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2366 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2373 Perl_gen_constant_list(pTHX_ register OP *o)
2376 I32 oldtmps_floor = PL_tmps_floor;
2380 return o; /* Don't attempt to run with errors */
2382 PL_op = curop = LINKLIST(o);
2389 PL_tmps_floor = oldtmps_floor;
2391 o->op_type = OP_RV2AV;
2392 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2393 curop = ((UNOP*)o)->op_first;
2394 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2401 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2403 if (!o || o->op_type != OP_LIST)
2404 o = newLISTOP(OP_LIST, 0, o, Nullop);
2406 o->op_flags &= ~OPf_WANT;
2408 if (!(PL_opargs[type] & OA_MARK))
2409 null(cLISTOPo->op_first);
2412 o->op_ppaddr = PL_ppaddr[type];
2413 o->op_flags |= flags;
2415 o = CHECKOP(type, o);
2416 if (o->op_type != type)
2419 return fold_constants(o);
2422 /* List constructors */
2425 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2433 if (first->op_type != type
2434 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2436 return newLISTOP(type, 0, first, last);
2439 if (first->op_flags & OPf_KIDS)
2440 ((LISTOP*)first)->op_last->op_sibling = last;
2442 first->op_flags |= OPf_KIDS;
2443 ((LISTOP*)first)->op_first = last;
2445 ((LISTOP*)first)->op_last = last;
2450 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2458 if (first->op_type != type)
2459 return prepend_elem(type, (OP*)first, (OP*)last);
2461 if (last->op_type != type)
2462 return append_elem(type, (OP*)first, (OP*)last);
2464 first->op_last->op_sibling = last->op_first;
2465 first->op_last = last->op_last;
2466 first->op_flags |= (last->op_flags & OPf_KIDS);
2468 #ifdef PL_OP_SLAB_ALLOC
2476 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2484 if (last->op_type == type) {
2485 if (type == OP_LIST) { /* already a PUSHMARK there */
2486 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2487 ((LISTOP*)last)->op_first->op_sibling = first;
2488 if (!(first->op_flags & OPf_PARENS))
2489 last->op_flags &= ~OPf_PARENS;
2492 if (!(last->op_flags & OPf_KIDS)) {
2493 ((LISTOP*)last)->op_last = first;
2494 last->op_flags |= OPf_KIDS;
2496 first->op_sibling = ((LISTOP*)last)->op_first;
2497 ((LISTOP*)last)->op_first = first;
2499 last->op_flags |= OPf_KIDS;
2503 return newLISTOP(type, 0, first, last);
2509 Perl_newNULLLIST(pTHX)
2511 return newOP(OP_STUB, 0);
2515 Perl_force_list(pTHX_ OP *o)
2517 if (!o || o->op_type != OP_LIST)
2518 o = newLISTOP(OP_LIST, 0, o, Nullop);
2524 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2528 NewOp(1101, listop, 1, LISTOP);
2530 listop->op_type = type;
2531 listop->op_ppaddr = PL_ppaddr[type];
2534 listop->op_flags = flags;
2538 else if (!first && last)
2541 first->op_sibling = last;
2542 listop->op_first = first;
2543 listop->op_last = last;
2544 if (type == OP_LIST) {
2546 pushop = newOP(OP_PUSHMARK, 0);
2547 pushop->op_sibling = first;
2548 listop->op_first = pushop;
2549 listop->op_flags |= OPf_KIDS;
2551 listop->op_last = pushop;
2558 Perl_newOP(pTHX_ I32 type, I32 flags)
2561 NewOp(1101, o, 1, OP);
2563 o->op_ppaddr = PL_ppaddr[type];
2564 o->op_flags = flags;
2567 o->op_private = 0 + (flags >> 8);
2568 if (PL_opargs[type] & OA_RETSCALAR)
2570 if (PL_opargs[type] & OA_TARGET)
2571 o->op_targ = pad_alloc(type, SVs_PADTMP);
2572 return CHECKOP(type, o);
2576 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2581 first = newOP(OP_STUB, 0);
2582 if (PL_opargs[type] & OA_MARK)
2583 first = force_list(first);
2585 NewOp(1101, unop, 1, UNOP);
2586 unop->op_type = type;
2587 unop->op_ppaddr = PL_ppaddr[type];
2588 unop->op_first = first;
2589 unop->op_flags = flags | OPf_KIDS;
2590 unop->op_private = 1 | (flags >> 8);
2591 unop = (UNOP*) CHECKOP(type, unop);
2595 return fold_constants((OP *) unop);
2599 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2602 NewOp(1101, binop, 1, BINOP);
2605 first = newOP(OP_NULL, 0);
2607 binop->op_type = type;
2608 binop->op_ppaddr = PL_ppaddr[type];
2609 binop->op_first = first;
2610 binop->op_flags = flags | OPf_KIDS;
2613 binop->op_private = 1 | (flags >> 8);
2616 binop->op_private = 2 | (flags >> 8);
2617 first->op_sibling = last;
2620 binop = (BINOP*)CHECKOP(type, binop);
2621 if (binop->op_next || binop->op_type != type)
2624 binop->op_last = binop->op_first->op_sibling;
2626 return fold_constants((OP *)binop);
2630 utf8compare(const void *a, const void *b)
2633 for (i = 0; i < 10; i++) {
2634 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2636 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2643 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2645 SV *tstr = ((SVOP*)expr)->op_sv;
2646 SV *rstr = ((SVOP*)repl)->op_sv;
2649 U8 *t = (U8*)SvPV(tstr, tlen);
2650 U8 *r = (U8*)SvPV(rstr, rlen);
2657 register short *tbl;
2659 complement = o->op_private & OPpTRANS_COMPLEMENT;
2660 del = o->op_private & OPpTRANS_DELETE;
2661 squash = o->op_private & OPpTRANS_SQUASH;
2664 o->op_private |= OPpTRANS_FROM_UTF;
2667 o->op_private |= OPpTRANS_TO_UTF;
2669 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2670 SV* listsv = newSVpvn("# comment\n",10);
2672 U8* tend = t + tlen;
2673 U8* rend = r + rlen;
2687 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2688 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2689 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2690 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2693 U8 tmpbuf[UTF8_MAXLEN+1];
2696 New(1109, cp, tlen, U8*);
2698 transv = newSVpvn("",0);
2702 if (t < tend && *t == 0xff) {
2707 qsort(cp, i, sizeof(U8*), utf8compare);
2708 for (j = 0; j < i; j++) {
2710 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2711 UV val = utf8_to_uv(s, cur, &ulen, 0);
2713 diff = val - nextmin;
2715 t = uv_to_utf8(tmpbuf,nextmin);
2716 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2718 t = uv_to_utf8(tmpbuf, val - 1);
2719 sv_catpvn(transv, "\377", 1);
2720 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2723 if (s < tend && *s == 0xff)
2724 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2728 t = uv_to_utf8(tmpbuf,nextmin);
2729 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2730 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2731 sv_catpvn(transv, "\377", 1);
2732 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2733 t = (U8*)SvPVX(transv);
2734 tlen = SvCUR(transv);
2738 else if (!rlen && !del) {
2739 r = t; rlen = tlen; rend = tend;
2743 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2745 o->op_private |= OPpTRANS_IDENTICAL;
2749 while (t < tend || tfirst <= tlast) {
2750 /* see if we need more "t" chars */
2751 if (tfirst > tlast) {
2752 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2754 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2756 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2763 /* now see if we need more "r" chars */
2764 if (rfirst > rlast) {
2766 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2768 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2770 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2779 rfirst = rlast = 0xffffffff;
2783 /* now see which range will peter our first, if either. */
2784 tdiff = tlast - tfirst;
2785 rdiff = rlast - rfirst;
2792 if (rfirst == 0xffffffff) {
2793 diff = tdiff; /* oops, pretend rdiff is infinite */
2795 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2796 (long)tfirst, (long)tlast);
2798 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2802 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2803 (long)tfirst, (long)(tfirst + diff),
2806 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2807 (long)tfirst, (long)rfirst);
2809 if (rfirst + diff > max)
2810 max = rfirst + diff;
2813 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2824 else if (max > 0xff)
2829 Safefree(cPVOPo->op_pv);
2830 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2831 SvREFCNT_dec(listsv);
2833 SvREFCNT_dec(transv);
2835 if (!del && havefinal)
2836 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2837 newSVuv((UV)final), 0);
2840 o->op_private |= OPpTRANS_GROWS;
2852 tbl = (short*)cPVOPo->op_pv;
2854 Zero(tbl, 256, short);
2855 for (i = 0; i < tlen; i++)
2857 for (i = 0, j = 0; i < 256; i++) {
2868 if (i < 128 && r[j] >= 128)
2876 if (!rlen && !del) {
2879 o->op_private |= OPpTRANS_IDENTICAL;
2881 for (i = 0; i < 256; i++)
2883 for (i = 0, j = 0; i < tlen; i++,j++) {
2886 if (tbl[t[i]] == -1)
2892 if (tbl[t[i]] == -1) {
2893 if (t[i] < 128 && r[j] >= 128)
2900 o->op_private |= OPpTRANS_GROWS;
2908 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2912 NewOp(1101, pmop, 1, PMOP);
2913 pmop->op_type = type;
2914 pmop->op_ppaddr = PL_ppaddr[type];
2915 pmop->op_flags = flags;
2916 pmop->op_private = 0 | (flags >> 8);
2918 if (PL_hints & HINT_RE_TAINT)
2919 pmop->op_pmpermflags |= PMf_RETAINT;
2920 if (PL_hints & HINT_LOCALE)
2921 pmop->op_pmpermflags |= PMf_LOCALE;
2922 pmop->op_pmflags = pmop->op_pmpermflags;
2924 /* link into pm list */
2925 if (type != OP_TRANS && PL_curstash) {
2926 pmop->op_pmnext = HvPMROOT(PL_curstash);
2927 HvPMROOT(PL_curstash) = pmop;
2934 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2938 I32 repl_has_vars = 0;
2940 if (o->op_type == OP_TRANS)
2941 return pmtrans(o, expr, repl);
2943 PL_hints |= HINT_BLOCK_SCOPE;
2946 if (expr->op_type == OP_CONST) {
2948 SV *pat = ((SVOP*)expr)->op_sv;
2949 char *p = SvPV(pat, plen);
2950 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2951 sv_setpvn(pat, "\\s+", 3);
2952 p = SvPV(pat, plen);
2953 pm->op_pmflags |= PMf_SKIPWHITE;
2955 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2956 pm->op_pmdynflags |= PMdf_UTF8;
2957 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2958 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2959 pm->op_pmflags |= PMf_WHITE;
2963 if (PL_hints & HINT_UTF8)
2964 pm->op_pmdynflags |= PMdf_UTF8;
2965 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2966 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2968 : OP_REGCMAYBE),0,expr);
2970 NewOp(1101, rcop, 1, LOGOP);
2971 rcop->op_type = OP_REGCOMP;
2972 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2973 rcop->op_first = scalar(expr);
2974 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2975 ? (OPf_SPECIAL | OPf_KIDS)
2977 rcop->op_private = 1;
2980 /* establish postfix order */
2981 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2983 rcop->op_next = expr;
2984 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2987 rcop->op_next = LINKLIST(expr);
2988 expr->op_next = (OP*)rcop;
2991 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2996 if (pm->op_pmflags & PMf_EVAL) {
2998 if (CopLINE(PL_curcop) < PL_multi_end)
2999 CopLINE_set(PL_curcop, PL_multi_end);
3002 else if (repl->op_type == OP_THREADSV
3003 && strchr("&`'123456789+",
3004 PL_threadsv_names[repl->op_targ]))
3008 #endif /* USE_THREADS */
3009 else if (repl->op_type == OP_CONST)
3013 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3014 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3016 if (curop->op_type == OP_THREADSV) {
3018 if (strchr("&`'123456789+", curop->op_private))
3022 if (curop->op_type == OP_GV) {
3023 GV *gv = cGVOPx_gv(curop);
3025 if (strchr("&`'123456789+", *GvENAME(gv)))
3028 #endif /* USE_THREADS */
3029 else if (curop->op_type == OP_RV2CV)
3031 else if (curop->op_type == OP_RV2SV ||
3032 curop->op_type == OP_RV2AV ||
3033 curop->op_type == OP_RV2HV ||
3034 curop->op_type == OP_RV2GV) {
3035 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3038 else if (curop->op_type == OP_PADSV ||
3039 curop->op_type == OP_PADAV ||
3040 curop->op_type == OP_PADHV ||
3041 curop->op_type == OP_PADANY) {
3044 else if (curop->op_type == OP_PUSHRE)
3045 ; /* Okay here, dangerous in newASSIGNOP */
3054 && (!pm->op_pmregexp
3055 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3056 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3057 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3058 prepend_elem(o->op_type, scalar(repl), o);
3061 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3062 pm->op_pmflags |= PMf_MAYBE_CONST;
3063 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3065 NewOp(1101, rcop, 1, LOGOP);
3066 rcop->op_type = OP_SUBSTCONT;
3067 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3068 rcop->op_first = scalar(repl);
3069 rcop->op_flags |= OPf_KIDS;
3070 rcop->op_private = 1;
3073 /* establish postfix order */
3074 rcop->op_next = LINKLIST(repl);
3075 repl->op_next = (OP*)rcop;
3077 pm->op_pmreplroot = scalar((OP*)rcop);
3078 pm->op_pmreplstart = LINKLIST(rcop);
3087 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3090 NewOp(1101, svop, 1, SVOP);
3091 svop->op_type = type;
3092 svop->op_ppaddr = PL_ppaddr[type];
3094 svop->op_next = (OP*)svop;
3095 svop->op_flags = flags;
3096 if (PL_opargs[type] & OA_RETSCALAR)
3098 if (PL_opargs[type] & OA_TARGET)
3099 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3100 return CHECKOP(type, svop);
3104 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3107 NewOp(1101, padop, 1, PADOP);
3108 padop->op_type = type;
3109 padop->op_ppaddr = PL_ppaddr[type];
3110 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3111 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3112 PL_curpad[padop->op_padix] = sv;
3114 padop->op_next = (OP*)padop;
3115 padop->op_flags = flags;
3116 if (PL_opargs[type] & OA_RETSCALAR)
3118 if (PL_opargs[type] & OA_TARGET)
3119 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3120 return CHECKOP(type, padop);
3124 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3128 return newPADOP(type, flags, SvREFCNT_inc(gv));
3130 return newSVOP(type, flags, SvREFCNT_inc(gv));
3135 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3138 NewOp(1101, pvop, 1, PVOP);
3139 pvop->op_type = type;
3140 pvop->op_ppaddr = PL_ppaddr[type];
3142 pvop->op_next = (OP*)pvop;
3143 pvop->op_flags = flags;
3144 if (PL_opargs[type] & OA_RETSCALAR)
3146 if (PL_opargs[type] & OA_TARGET)
3147 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3148 return CHECKOP(type, pvop);
3152 Perl_package(pTHX_ OP *o)
3156 save_hptr(&PL_curstash);
3157 save_item(PL_curstname);
3162 name = SvPV(sv, len);
3163 PL_curstash = gv_stashpvn(name,len,TRUE);
3164 sv_setpvn(PL_curstname, name, len);
3168 sv_setpv(PL_curstname,"<none>");
3169 PL_curstash = Nullhv;
3171 PL_hints |= HINT_BLOCK_SCOPE;
3172 PL_copline = NOLINE;
3177 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3185 if (id->op_type != OP_CONST)
3186 Perl_croak(aTHX_ "Module name must be constant");
3190 if (version != Nullop) {
3191 SV *vesv = ((SVOP*)version)->op_sv;
3193 if (arg == Nullop && !SvNIOKp(vesv)) {
3200 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3201 Perl_croak(aTHX_ "Version number must be constant number");
3203 /* Make copy of id so we don't free it twice */
3204 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3206 /* Fake up a method call to VERSION */
3207 meth = newSVpvn("VERSION",7);
3208 sv_upgrade(meth, SVt_PVIV);
3209 (void)SvIOK_on(meth);
3210 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3211 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3212 append_elem(OP_LIST,
3213 prepend_elem(OP_LIST, pack, list(version)),
3214 newSVOP(OP_METHOD_NAMED, 0, meth)));
3218 /* Fake up an import/unimport */
3219 if (arg && arg->op_type == OP_STUB)
3220 imop = arg; /* no import on explicit () */
3221 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3222 imop = Nullop; /* use 5.0; */
3227 /* Make copy of id so we don't free it twice */
3228 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3230 /* Fake up a method call to import/unimport */
3231 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3232 sv_upgrade(meth, SVt_PVIV);
3233 (void)SvIOK_on(meth);
3234 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3235 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3236 append_elem(OP_LIST,
3237 prepend_elem(OP_LIST, pack, list(arg)),
3238 newSVOP(OP_METHOD_NAMED, 0, meth)));
3241 /* Fake up a require, handle override, if any */
3242 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3243 if (!(gv && GvIMPORTED_CV(gv)))
3244 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3246 if (gv && GvIMPORTED_CV(gv)) {
3247 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3248 append_elem(OP_LIST, id,
3249 scalar(newUNOP(OP_RV2CV, 0,
3254 rqop = newUNOP(OP_REQUIRE, 0, id);
3257 /* Fake up the BEGIN {}, which does its thing immediately. */
3259 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3262 append_elem(OP_LINESEQ,
3263 append_elem(OP_LINESEQ,
3264 newSTATEOP(0, Nullch, rqop),
3265 newSTATEOP(0, Nullch, veop)),
3266 newSTATEOP(0, Nullch, imop) ));
3268 PL_hints |= HINT_BLOCK_SCOPE;
3269 PL_copline = NOLINE;
3274 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3277 va_start(args, ver);
3278 vload_module(flags, name, ver, &args);
3282 #ifdef PERL_IMPLICIT_CONTEXT
3284 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3288 va_start(args, ver);
3289 vload_module(flags, name, ver, &args);
3295 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3297 OP *modname, *veop, *imop;
3299 modname = newSVOP(OP_CONST, 0, name);
3300 modname->op_private |= OPpCONST_BARE;
3302 veop = newSVOP(OP_CONST, 0, ver);
3306 if (flags & PERL_LOADMOD_NOIMPORT) {
3307 imop = sawparens(newNULLLIST());
3309 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3310 imop = va_arg(*args, OP*);
3315 sv = va_arg(*args, SV*);
3317 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3318 sv = va_arg(*args, SV*);
3322 line_t ocopline = PL_copline;
3323 int oexpect = PL_expect;
3325 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3326 veop, modname, imop);
3327 PL_expect = oexpect;
3328 PL_copline = ocopline;
3333 Perl_dofile(pTHX_ OP *term)
3338 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3339 if (!(gv && GvIMPORTED_CV(gv)))
3340 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3342 if (gv && GvIMPORTED_CV(gv)) {
3343 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3344 append_elem(OP_LIST, term,
3345 scalar(newUNOP(OP_RV2CV, 0,
3350 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3356 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3358 return newBINOP(OP_LSLICE, flags,
3359 list(force_list(subscript)),
3360 list(force_list(listval)) );
3364 S_list_assignment(pTHX_ register OP *o)
3369 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3370 o = cUNOPo->op_first;
3372 if (o->op_type == OP_COND_EXPR) {
3373 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3374 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3379 yyerror("Assignment to both a list and a scalar");
3383 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3384 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3385 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3388 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3391 if (o->op_type == OP_RV2SV)
3398 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3403 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3404 return newLOGOP(optype, 0,
3405 mod(scalar(left), optype),
3406 newUNOP(OP_SASSIGN, 0, scalar(right)));
3409 return newBINOP(optype, OPf_STACKED,
3410 mod(scalar(left), optype), scalar(right));
3414 if (list_assignment(left)) {
3418 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3419 left = mod(left, OP_AASSIGN);
3427 curop = list(force_list(left));
3428 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3429 o->op_private = 0 | (flags >> 8);
3430 for (curop = ((LISTOP*)curop)->op_first;
3431 curop; curop = curop->op_sibling)
3433 if (curop->op_type == OP_RV2HV &&
3434 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3435 o->op_private |= OPpASSIGN_HASH;
3439 if (!(left->op_private & OPpLVAL_INTRO)) {
3442 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3443 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3444 if (curop->op_type == OP_GV) {
3445 GV *gv = cGVOPx_gv(curop);
3446 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3448 SvCUR(gv) = PL_generation;
3450 else if (curop->op_type == OP_PADSV ||
3451 curop->op_type == OP_PADAV ||
3452 curop->op_type == OP_PADHV ||
3453 curop->op_type == OP_PADANY) {
3454 SV **svp = AvARRAY(PL_comppad_name);
3455 SV *sv = svp[curop->op_targ];
3456 if (SvCUR(sv) == PL_generation)
3458 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3460 else if (curop->op_type == OP_RV2CV)
3462 else if (curop->op_type == OP_RV2SV ||
3463 curop->op_type == OP_RV2AV ||
3464 curop->op_type == OP_RV2HV ||
3465 curop->op_type == OP_RV2GV) {
3466 if (lastop->op_type != OP_GV) /* funny deref? */
3469 else if (curop->op_type == OP_PUSHRE) {
3470 if (((PMOP*)curop)->op_pmreplroot) {
3472 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3474 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3476 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3478 SvCUR(gv) = PL_generation;
3487 o->op_private |= OPpASSIGN_COMMON;
3489 if (right && right->op_type == OP_SPLIT) {
3491 if ((tmpop = ((LISTOP*)right)->op_first) &&
3492 tmpop->op_type == OP_PUSHRE)
3494 PMOP *pm = (PMOP*)tmpop;
3495 if (left->op_type == OP_RV2AV &&
3496 !(left->op_private & OPpLVAL_INTRO) &&
3497 !(o->op_private & OPpASSIGN_COMMON) )
3499 tmpop = ((UNOP*)left)->op_first;
3500 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3502 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3503 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3505 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3506 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3508 pm->op_pmflags |= PMf_ONCE;
3509 tmpop = cUNOPo->op_first; /* to list (nulled) */
3510 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3511 tmpop->op_sibling = Nullop; /* don't free split */
3512 right->op_next = tmpop->op_next; /* fix starting loc */
3513 op_free(o); /* blow off assign */
3514 right->op_flags &= ~OPf_WANT;
3515 /* "I don't know and I don't care." */
3520 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3521 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3523 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3525 sv_setiv(sv, PL_modcount+1);
3533 right = newOP(OP_UNDEF, 0);
3534 if (right->op_type == OP_READLINE) {
3535 right->op_flags |= OPf_STACKED;
3536 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3539 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3540 o = newBINOP(OP_SASSIGN, flags,
3541 scalar(right), mod(scalar(left), OP_SASSIGN) );
3553 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3555 U32 seq = intro_my();
3558 NewOp(1101, cop, 1, COP);
3559 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3560 cop->op_type = OP_DBSTATE;
3561 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3564 cop->op_type = OP_NEXTSTATE;
3565 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3567 cop->op_flags = flags;
3568 cop->op_private = (PL_hints & HINT_BYTE);
3570 cop->op_private |= NATIVE_HINTS;
3572 PL_compiling.op_private = cop->op_private;
3573 cop->op_next = (OP*)cop;
3576 cop->cop_label = label;
3577 PL_hints |= HINT_BLOCK_SCOPE;
3580 cop->cop_arybase = PL_curcop->cop_arybase;
3581 if (specialWARN(PL_curcop->cop_warnings))
3582 cop->cop_warnings = PL_curcop->cop_warnings ;
3584 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3585 if (specialCopIO(PL_curcop->cop_io))
3586 cop->cop_io = PL_curcop->cop_io;
3588 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3591 if (PL_copline == NOLINE)
3592 CopLINE_set(cop, CopLINE(PL_curcop));
3594 CopLINE_set(cop, PL_copline);
3595 PL_copline = NOLINE;
3598 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3600 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3602 CopSTASH_set(cop, PL_curstash);
3604 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3605 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3606 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3607 (void)SvIOK_on(*svp);
3608 SvIVX(*svp) = PTR2IV(cop);
3612 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3615 /* "Introduce" my variables to visible status. */
3623 if (! PL_min_intro_pending)
3624 return PL_cop_seqmax;
3626 svp = AvARRAY(PL_comppad_name);
3627 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3628 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3629 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3630 SvNVX(sv) = (NV)PL_cop_seqmax;
3633 PL_min_intro_pending = 0;
3634 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3635 return PL_cop_seqmax++;
3639 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3641 return new_logop(type, flags, &first, &other);
3645 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3649 OP *first = *firstp;
3650 OP *other = *otherp;
3652 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3653 return newBINOP(type, flags, scalar(first), scalar(other));
3655 scalarboolean(first);
3656 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3657 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3658 if (type == OP_AND || type == OP_OR) {
3664 first = *firstp = cUNOPo->op_first;
3666 first->op_next = o->op_next;
3667 cUNOPo->op_first = Nullop;
3671 if (first->op_type == OP_CONST) {
3672 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3673 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3674 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3685 else if (first->op_type == OP_WANTARRAY) {
3691 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3692 OP *k1 = ((UNOP*)first)->op_first;
3693 OP *k2 = k1->op_sibling;
3695 switch (first->op_type)
3698 if (k2 && k2->op_type == OP_READLINE
3699 && (k2->op_flags & OPf_STACKED)
3700 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3702 warnop = k2->op_type;
3707 if (k1->op_type == OP_READDIR
3708 || k1->op_type == OP_GLOB
3709 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3710 || k1->op_type == OP_EACH)
3712 warnop = ((k1->op_type == OP_NULL)
3713 ? k1->op_targ : k1->op_type);
3718 line_t oldline = CopLINE(PL_curcop);
3719 CopLINE_set(PL_curcop, PL_copline);
3720 Perl_warner(aTHX_ WARN_MISC,
3721 "Value of %s%s can be \"0\"; test with defined()",
3723 ((warnop == OP_READLINE || warnop == OP_GLOB)
3724 ? " construct" : "() operator"));
3725 CopLINE_set(PL_curcop, oldline);
3732 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3733 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3735 NewOp(1101, logop, 1, LOGOP);
3737 logop->op_type = type;
3738 logop->op_ppaddr = PL_ppaddr[type];
3739 logop->op_first = first;
3740 logop->op_flags = flags | OPf_KIDS;
3741 logop->op_other = LINKLIST(other);
3742 logop->op_private = 1 | (flags >> 8);
3744 /* establish postfix order */
3745 logop->op_next = LINKLIST(first);
3746 first->op_next = (OP*)logop;
3747 first->op_sibling = other;
3749 o = newUNOP(OP_NULL, 0, (OP*)logop);
3756 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3763 return newLOGOP(OP_AND, 0, first, trueop);
3765 return newLOGOP(OP_OR, 0, first, falseop);
3767 scalarboolean(first);
3768 if (first->op_type == OP_CONST) {
3769 if (SvTRUE(((SVOP*)first)->op_sv)) {
3780 else if (first->op_type == OP_WANTARRAY) {
3784 NewOp(1101, logop, 1, LOGOP);
3785 logop->op_type = OP_COND_EXPR;
3786 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3787 logop->op_first = first;
3788 logop->op_flags = flags | OPf_KIDS;
3789 logop->op_private = 1 | (flags >> 8);
3790 logop->op_other = LINKLIST(trueop);
3791 logop->op_next = LINKLIST(falseop);
3794 /* establish postfix order */
3795 start = LINKLIST(first);
3796 first->op_next = (OP*)logop;
3798 first->op_sibling = trueop;
3799 trueop->op_sibling = falseop;
3800 o = newUNOP(OP_NULL, 0, (OP*)logop);
3802 trueop->op_next = falseop->op_next = o;
3809 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3817 NewOp(1101, range, 1, LOGOP);
3819 range->op_type = OP_RANGE;
3820 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3821 range->op_first = left;
3822 range->op_flags = OPf_KIDS;
3823 leftstart = LINKLIST(left);
3824 range->op_other = LINKLIST(right);
3825 range->op_private = 1 | (flags >> 8);
3827 left->op_sibling = right;
3829 range->op_next = (OP*)range;
3830 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3831 flop = newUNOP(OP_FLOP, 0, flip);
3832 o = newUNOP(OP_NULL, 0, flop);
3834 range->op_next = leftstart;
3836 left->op_next = flip;
3837 right->op_next = flop;
3839 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3840 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3841 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3842 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3844 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3845 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3848 if (!flip->op_private || !flop->op_private)
3849 linklist(o); /* blow off optimizer unless constant */
3855 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3859 int once = block && block->op_flags & OPf_SPECIAL &&
3860 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3863 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3864 return block; /* do {} while 0 does once */
3865 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3866 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3867 expr = newUNOP(OP_DEFINED, 0,
3868 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3869 } else if (expr->op_flags & OPf_KIDS) {
3870 OP *k1 = ((UNOP*)expr)->op_first;
3871 OP *k2 = (k1) ? k1->op_sibling : NULL;
3872 switch (expr->op_type) {
3874 if (k2 && k2->op_type == OP_READLINE
3875 && (k2->op_flags & OPf_STACKED)
3876 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3877 expr = newUNOP(OP_DEFINED, 0, expr);
3881 if (k1->op_type == OP_READDIR
3882 || k1->op_type == OP_GLOB
3883 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3884 || k1->op_type == OP_EACH)
3885 expr = newUNOP(OP_DEFINED, 0, expr);
3891 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3892 o = new_logop(OP_AND, 0, &expr, &listop);
3895 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3897 if (once && o != listop)
3898 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3901 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3903 o->op_flags |= flags;
3905 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3910 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3919 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3920 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3921 expr = newUNOP(OP_DEFINED, 0,
3922 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3923 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3924 OP *k1 = ((UNOP*)expr)->op_first;
3925 OP *k2 = (k1) ? k1->op_sibling : NULL;
3926 switch (expr->op_type) {
3928 if (k2 && k2->op_type == OP_READLINE
3929 && (k2->op_flags & OPf_STACKED)
3930 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3931 expr = newUNOP(OP_DEFINED, 0, expr);
3935 if (k1->op_type == OP_READDIR
3936 || k1->op_type == OP_GLOB
3937 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3938 || k1->op_type == OP_EACH)
3939 expr = newUNOP(OP_DEFINED, 0, expr);
3945 block = newOP(OP_NULL, 0);
3947 block = scope(block);
3951 next = LINKLIST(cont);
3954 OP *unstack = newOP(OP_UNSTACK, 0);
3957 cont = append_elem(OP_LINESEQ, cont, unstack);
3958 if ((line_t)whileline != NOLINE) {
3959 PL_copline = whileline;
3960 cont = append_elem(OP_LINESEQ, cont,
3961 newSTATEOP(0, Nullch, Nullop));
3965 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3966 redo = LINKLIST(listop);
3969 PL_copline = whileline;
3971 o = new_logop(OP_AND, 0, &expr, &listop);
3972 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3973 op_free(expr); /* oops, it's a while (0) */
3975 return Nullop; /* listop already freed by new_logop */
3978 ((LISTOP*)listop)->op_last->op_next = condop =
3979 (o == listop ? redo : LINKLIST(o));
3985 NewOp(1101,loop,1,LOOP);
3986 loop->op_type = OP_ENTERLOOP;
3987 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3988 loop->op_private = 0;
3989 loop->op_next = (OP*)loop;
3992 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3994 loop->op_redoop = redo;
3995 loop->op_lastop = o;
3996 o->op_private |= loopflags;
3999 loop->op_nextop = next;
4001 loop->op_nextop = o;
4003 o->op_flags |= flags;
4004 o->op_private |= (flags >> 8);
4009 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4017 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4018 sv->op_type = OP_RV2GV;
4019 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4021 else if (sv->op_type == OP_PADSV) { /* private variable */
4022 padoff = sv->op_targ;
4027 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4028 padoff = sv->op_targ;
4030 iterflags |= OPf_SPECIAL;
4035 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4039 padoff = find_threadsv("_");
4040 iterflags |= OPf_SPECIAL;
4042 sv = newGVOP(OP_GV, 0, PL_defgv);
4045 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4046 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4047 iterflags |= OPf_STACKED;
4049 else if (expr->op_type == OP_NULL &&
4050 (expr->op_flags & OPf_KIDS) &&
4051 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4053 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4054 * set the STACKED flag to indicate that these values are to be
4055 * treated as min/max values by 'pp_iterinit'.
4057 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4058 LOGOP* range = (LOGOP*) flip->op_first;
4059 OP* left = range->op_first;
4060 OP* right = left->op_sibling;
4063 range->op_flags &= ~OPf_KIDS;
4064 range->op_first = Nullop;
4066 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4067 listop->op_first->op_next = range->op_next;
4068 left->op_next = range->op_other;
4069 right->op_next = (OP*)listop;
4070 listop->op_next = listop->op_first;
4073 expr = (OP*)(listop);
4075 iterflags |= OPf_STACKED;
4078 expr = mod(force_list(expr), OP_GREPSTART);
4082 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4083 append_elem(OP_LIST, expr, scalar(sv))));
4084 assert(!loop->op_next);
4085 #ifdef PL_OP_SLAB_ALLOC
4088 NewOp(1234,tmp,1,LOOP);
4089 Copy(loop,tmp,1,LOOP);
4093 Renew(loop, 1, LOOP);
4095 loop->op_targ = padoff;
4096 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4097 PL_copline = forline;
4098 return newSTATEOP(0, label, wop);
4102 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4107 if (type != OP_GOTO || label->op_type == OP_CONST) {
4108 /* "last()" means "last" */
4109 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4110 o = newOP(type, OPf_SPECIAL);
4112 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4113 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4119 if (label->op_type == OP_ENTERSUB)
4120 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4121 o = newUNOP(type, OPf_STACKED, label);
4123 PL_hints |= HINT_BLOCK_SCOPE;
4128 Perl_cv_undef(pTHX_ CV *cv)
4132 MUTEX_DESTROY(CvMUTEXP(cv));
4133 Safefree(CvMUTEXP(cv));
4136 #endif /* USE_THREADS */
4138 if (!CvXSUB(cv) && CvROOT(cv)) {
4140 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4141 Perl_croak(aTHX_ "Can't undef active subroutine");
4144 Perl_croak(aTHX_ "Can't undef active subroutine");
4145 #endif /* USE_THREADS */
4148 SAVEVPTR(PL_curpad);
4152 op_free(CvROOT(cv));
4153 CvROOT(cv) = Nullop;
4156 SvPOK_off((SV*)cv); /* forget prototype */
4159 SvREFCNT_dec(CvOUTSIDE(cv));
4160 CvOUTSIDE(cv) = Nullcv;
4162 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4165 if (CvPADLIST(cv)) {
4166 /* may be during global destruction */
4167 if (SvREFCNT(CvPADLIST(cv))) {
4168 I32 i = AvFILLp(CvPADLIST(cv));
4170 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4171 SV* sv = svp ? *svp : Nullsv;
4174 if (sv == (SV*)PL_comppad_name)
4175 PL_comppad_name = Nullav;
4176 else if (sv == (SV*)PL_comppad) {
4177 PL_comppad = Nullav;
4178 PL_curpad = Null(SV**);
4182 SvREFCNT_dec((SV*)CvPADLIST(cv));
4184 CvPADLIST(cv) = Nullav;
4188 #ifdef DEBUG_CLOSURES
4190 S_cv_dump(pTHX_ CV *cv)
4193 CV *outside = CvOUTSIDE(cv);
4194 AV* padlist = CvPADLIST(cv);
4201 PerlIO_printf(Perl_debug_log,
4202 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4204 (CvANON(cv) ? "ANON"
4205 : (cv == PL_main_cv) ? "MAIN"
4206 : CvUNIQUE(cv) ? "UNIQUE"
4207 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4210 : CvANON(outside) ? "ANON"
4211 : (outside == PL_main_cv) ? "MAIN"
4212 : CvUNIQUE(outside) ? "UNIQUE"
4213 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4218 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4219 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4220 pname = AvARRAY(pad_name);
4221 ppad = AvARRAY(pad);
4223 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4224 if (SvPOK(pname[ix]))
4225 PerlIO_printf(Perl_debug_log,
4226 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4227 (int)ix, PTR2UV(ppad[ix]),
4228 SvFAKE(pname[ix]) ? "FAKE " : "",
4230 (IV)I_32(SvNVX(pname[ix])),
4233 #endif /* DEBUGGING */
4235 #endif /* DEBUG_CLOSURES */
4238 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4242 AV* protopadlist = CvPADLIST(proto);
4243 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4244 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4245 SV** pname = AvARRAY(protopad_name);
4246 SV** ppad = AvARRAY(protopad);
4247 I32 fname = AvFILLp(protopad_name);
4248 I32 fpad = AvFILLp(protopad);
4252 assert(!CvUNIQUE(proto));
4256 SAVESPTR(PL_comppad_name);
4257 SAVESPTR(PL_compcv);
4259 cv = PL_compcv = (CV*)NEWSV(1104,0);
4260 sv_upgrade((SV *)cv, SvTYPE(proto));
4261 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4265 New(666, CvMUTEXP(cv), 1, perl_mutex);
4266 MUTEX_INIT(CvMUTEXP(cv));
4268 #endif /* USE_THREADS */
4269 CvFILE(cv) = CvFILE(proto);
4270 CvGV(cv) = CvGV(proto);
4271 CvSTASH(cv) = CvSTASH(proto);
4272 CvROOT(cv) = CvROOT(proto);
4273 CvSTART(cv) = CvSTART(proto);
4275 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4278 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4280 PL_comppad_name = newAV();
4281 for (ix = fname; ix >= 0; ix--)
4282 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4284 PL_comppad = newAV();
4286 comppadlist = newAV();
4287 AvREAL_off(comppadlist);
4288 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4289 av_store(comppadlist, 1, (SV*)PL_comppad);
4290 CvPADLIST(cv) = comppadlist;
4291 av_fill(PL_comppad, AvFILLp(protopad));
4292 PL_curpad = AvARRAY(PL_comppad);
4294 av = newAV(); /* will be @_ */
4296 av_store(PL_comppad, 0, (SV*)av);
4297 AvFLAGS(av) = AVf_REIFY;
4299 for (ix = fpad; ix > 0; ix--) {
4300 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4301 if (namesv && namesv != &PL_sv_undef) {
4302 char *name = SvPVX(namesv); /* XXX */
4303 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4304 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4305 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4307 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4309 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4311 else { /* our own lexical */
4314 /* anon code -- we'll come back for it */
4315 sv = SvREFCNT_inc(ppad[ix]);
4317 else if (*name == '@')
4319 else if (*name == '%')
4328 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4329 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4332 SV* sv = NEWSV(0,0);
4338 /* Now that vars are all in place, clone nested closures. */
4340 for (ix = fpad; ix > 0; ix--) {
4341 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4343 && namesv != &PL_sv_undef
4344 && !(SvFLAGS(namesv) & SVf_FAKE)
4345 && *SvPVX(namesv) == '&'
4346 && CvCLONE(ppad[ix]))
4348 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4349 SvREFCNT_dec(ppad[ix]);
4352 PL_curpad[ix] = (SV*)kid;
4356 #ifdef DEBUG_CLOSURES
4357 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4359 PerlIO_printf(Perl_debug_log, " from:\n");
4361 PerlIO_printf(Perl_debug_log, " to:\n");
4368 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4370 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4372 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4379 Perl_cv_clone(pTHX_ CV *proto)
4382 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4383 cv = cv_clone2(proto, CvOUTSIDE(proto));
4384 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4389 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4391 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4392 SV* msg = sv_newmortal();
4396 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4397 sv_setpv(msg, "Prototype mismatch:");
4399 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4401 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4402 sv_catpv(msg, " vs ");
4404 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4406 sv_catpv(msg, "none");
4407 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4411 static void const_sv_xsub(pTHXo_ CV* cv);
4414 =for apidoc cv_const_sv
4416 If C<cv> is a constant sub eligible for inlining. returns the constant
4417 value returned by the sub. Otherwise, returns NULL.
4419 Constant subs can be created with C<newCONSTSUB> or as described in
4420 L<perlsub/"Constant Functions">.
4425 Perl_cv_const_sv(pTHX_ CV *cv)
4427 if (!cv || !CvCONST(cv))
4429 return (SV*)CvXSUBANY(cv).any_ptr;
4433 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4440 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4441 o = cLISTOPo->op_first->op_sibling;
4443 for (; o; o = o->op_next) {
4444 OPCODE type = o->op_type;
4446 if (sv && o->op_next == o)
4448 if (o->op_next != o) {
4449 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4451 if (type == OP_DBSTATE)
4454 if (type == OP_LEAVESUB || type == OP_RETURN)
4458 if (type == OP_CONST && cSVOPo->op_sv)
4460 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4461 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4462 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4466 /* We get here only from cv_clone2() while creating a closure.
4467 Copy the const value here instead of in cv_clone2 so that
4468 SvREADONLY_on doesn't lead to problems when leaving
4473 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4485 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4495 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4499 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4501 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4505 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4511 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4516 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4517 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4518 SV *sv = sv_newmortal();
4519 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4520 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4525 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4526 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4536 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4537 maximum a prototype before. */
4538 if (SvTYPE(gv) > SVt_NULL) {
4539 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4540 && ckWARN_d(WARN_PROTOTYPE))
4542 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4544 cv_ckproto((CV*)gv, NULL, ps);
4547 sv_setpv((SV*)gv, ps);
4549 sv_setiv((SV*)gv, -1);
4550 SvREFCNT_dec(PL_compcv);
4551 cv = PL_compcv = NULL;
4552 PL_sub_generation++;
4556 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4558 #ifdef GV_SHARED_CHECK
4559 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4560 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4564 if (!block || !ps || *ps || attrs)
4567 const_sv = op_const_sv(block, Nullcv);
4570 bool exists = CvROOT(cv) || CvXSUB(cv);
4572 #ifdef GV_SHARED_CHECK
4573 if (exists && GvSHARED(gv)) {
4574 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4578 /* if the subroutine doesn't exist and wasn't pre-declared
4579 * with a prototype, assume it will be AUTOLOADed,
4580 * skipping the prototype check
4582 if (exists || SvPOK(cv))
4583 cv_ckproto(cv, gv, ps);
4584 /* already defined (or promised)? */
4585 if (exists || GvASSUMECV(gv)) {
4586 if (!block && !attrs) {
4587 /* just a "sub foo;" when &foo is already defined */
4588 SAVEFREESV(PL_compcv);
4591 /* ahem, death to those who redefine active sort subs */
4592 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4593 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4595 if (ckWARN(WARN_REDEFINE)
4597 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4599 line_t oldline = CopLINE(PL_curcop);
4600 CopLINE_set(PL_curcop, PL_copline);
4601 Perl_warner(aTHX_ WARN_REDEFINE,
4602 CvCONST(cv) ? "Constant subroutine %s redefined"
4603 : "Subroutine %s redefined", name);
4604 CopLINE_set(PL_curcop, oldline);
4612 SvREFCNT_inc(const_sv);
4614 assert(!CvROOT(cv) && !CvCONST(cv));
4615 sv_setpv((SV*)cv, ""); /* prototype is "" */
4616 CvXSUBANY(cv).any_ptr = const_sv;
4617 CvXSUB(cv) = const_sv_xsub;
4622 cv = newCONSTSUB(NULL, name, const_sv);
4625 SvREFCNT_dec(PL_compcv);
4627 PL_sub_generation++;
4634 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4635 * before we clobber PL_compcv.
4639 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4640 stash = GvSTASH(CvGV(cv));
4641 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4642 stash = CvSTASH(cv);
4644 stash = PL_curstash;
4647 /* possibly about to re-define existing subr -- ignore old cv */
4648 rcv = (SV*)PL_compcv;
4649 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4650 stash = GvSTASH(gv);
4652 stash = PL_curstash;
4654 apply_attrs(stash, rcv, attrs);
4656 if (cv) { /* must reuse cv if autoloaded */
4658 /* got here with just attrs -- work done, so bug out */
4659 SAVEFREESV(PL_compcv);
4663 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4664 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4665 CvOUTSIDE(PL_compcv) = 0;
4666 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4667 CvPADLIST(PL_compcv) = 0;
4668 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4669 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4670 SvREFCNT_dec(PL_compcv);
4677 PL_sub_generation++;
4681 CvFILE(cv) = CopFILE(PL_curcop);
4682 CvSTASH(cv) = PL_curstash;
4685 if (!CvMUTEXP(cv)) {
4686 New(666, CvMUTEXP(cv), 1, perl_mutex);
4687 MUTEX_INIT(CvMUTEXP(cv));
4689 #endif /* USE_THREADS */
4692 sv_setpv((SV*)cv, ps);
4694 if (PL_error_count) {
4698 char *s = strrchr(name, ':');
4700 if (strEQ(s, "BEGIN")) {
4702 "BEGIN not safe after errors--compilation aborted";
4703 if (PL_in_eval & EVAL_KEEPERR)
4704 Perl_croak(aTHX_ not_safe);
4706 /* force display of errors found but not reported */
4707 sv_catpv(ERRSV, not_safe);
4708 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4716 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4717 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4720 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4721 mod(scalarseq(block), OP_LEAVESUBLV));
4724 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4726 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4727 OpREFCNT_set(CvROOT(cv), 1);
4728 CvSTART(cv) = LINKLIST(CvROOT(cv));
4729 CvROOT(cv)->op_next = 0;
4732 /* now that optimizer has done its work, adjust pad values */
4734 SV **namep = AvARRAY(PL_comppad_name);
4735 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4738 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4741 * The only things that a clonable function needs in its
4742 * pad are references to outer lexicals and anonymous subs.
4743 * The rest are created anew during cloning.
4745 if (!((namesv = namep[ix]) != Nullsv &&
4746 namesv != &PL_sv_undef &&
4748 *SvPVX(namesv) == '&')))
4750 SvREFCNT_dec(PL_curpad[ix]);
4751 PL_curpad[ix] = Nullsv;
4754 assert(!CvCONST(cv));
4755 if (ps && !*ps && op_const_sv(block, cv))
4759 AV *av = newAV(); /* Will be @_ */
4761 av_store(PL_comppad, 0, (SV*)av);
4762 AvFLAGS(av) = AVf_REIFY;
4764 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4765 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4767 if (!SvPADMY(PL_curpad[ix]))
4768 SvPADTMP_on(PL_curpad[ix]);
4772 if (name || aname) {
4774 char *tname = (name ? name : aname);
4776 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4777 SV *sv = NEWSV(0,0);
4778 SV *tmpstr = sv_newmortal();
4779 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4783 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4785 (long)PL_subline, (long)CopLINE(PL_curcop));
4786 gv_efullname3(tmpstr, gv, Nullch);
4787 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4788 hv = GvHVn(db_postponed);
4789 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4790 && (pcv = GvCV(db_postponed)))
4796 call_sv((SV*)pcv, G_DISCARD);
4800 if ((s = strrchr(tname,':')))
4805 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4808 if (strEQ(s, "BEGIN")) {
4809 I32 oldscope = PL_scopestack_ix;
4811 SAVECOPFILE(&PL_compiling);
4812 SAVECOPLINE(&PL_compiling);
4814 sv_setsv(PL_rs, PL_nrs);
4817 PL_beginav = newAV();
4818 DEBUG_x( dump_sub(gv) );
4819 av_push(PL_beginav, (SV*)cv);
4820 GvCV(gv) = 0; /* cv has been hijacked */
4821 call_list(oldscope, PL_beginav);
4823 PL_curcop = &PL_compiling;
4824 PL_compiling.op_private = PL_hints;
4827 else if (strEQ(s, "END") && !PL_error_count) {
4830 DEBUG_x( dump_sub(gv) );
4831 av_unshift(PL_endav, 1);
4832 av_store(PL_endav, 0, (SV*)cv);
4833 GvCV(gv) = 0; /* cv has been hijacked */
4835 else if (strEQ(s, "CHECK") && !PL_error_count) {
4837 PL_checkav = newAV();
4838 DEBUG_x( dump_sub(gv) );
4839 if (PL_main_start && ckWARN(WARN_VOID))
4840 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4841 av_unshift(PL_checkav, 1);
4842 av_store(PL_checkav, 0, (SV*)cv);
4843 GvCV(gv) = 0; /* cv has been hijacked */
4845 else if (strEQ(s, "INIT") && !PL_error_count) {
4847 PL_initav = newAV();
4848 DEBUG_x( dump_sub(gv) );
4849 if (PL_main_start && ckWARN(WARN_VOID))
4850 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4851 av_push(PL_initav, (SV*)cv);
4852 GvCV(gv) = 0; /* cv has been hijacked */
4857 PL_copline = NOLINE;
4862 /* XXX unsafe for threads if eval_owner isn't held */
4864 =for apidoc newCONSTSUB
4866 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4867 eligible for inlining at compile-time.
4873 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4879 SAVECOPLINE(PL_curcop);
4880 CopLINE_set(PL_curcop, PL_copline);
4883 PL_hints &= ~HINT_BLOCK_SCOPE;
4886 SAVESPTR(PL_curstash);
4887 SAVECOPSTASH(PL_curcop);
4888 PL_curstash = stash;
4890 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4892 CopSTASH(PL_curcop) = stash;
4896 cv = newXS(name, const_sv_xsub, __FILE__);
4897 CvXSUBANY(cv).any_ptr = sv;
4899 sv_setpv((SV*)cv, ""); /* prototype is "" */
4907 =for apidoc U||newXS
4909 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4915 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4917 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4920 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4922 /* just a cached method */
4926 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4927 /* already defined (or promised) */
4928 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4929 && HvNAME(GvSTASH(CvGV(cv)))
4930 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4931 line_t oldline = CopLINE(PL_curcop);
4932 if (PL_copline != NOLINE)
4933 CopLINE_set(PL_curcop, PL_copline);
4934 Perl_warner(aTHX_ WARN_REDEFINE,
4935 CvCONST(cv) ? "Constant subroutine %s redefined"
4936 : "Subroutine %s redefined"
4938 CopLINE_set(PL_curcop, oldline);
4945 if (cv) /* must reuse cv if autoloaded */
4948 cv = (CV*)NEWSV(1105,0);
4949 sv_upgrade((SV *)cv, SVt_PVCV);
4953 PL_sub_generation++;
4958 New(666, CvMUTEXP(cv), 1, perl_mutex);
4959 MUTEX_INIT(CvMUTEXP(cv));
4961 #endif /* USE_THREADS */
4962 (void)gv_fetchfile(filename);
4963 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4964 an external constant string */
4965 CvXSUB(cv) = subaddr;
4968 char *s = strrchr(name,':');
4974 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4977 if (strEQ(s, "BEGIN")) {
4979 PL_beginav = newAV();
4980 av_push(PL_beginav, (SV*)cv);
4981 GvCV(gv) = 0; /* cv has been hijacked */
4983 else if (strEQ(s, "END")) {
4986 av_unshift(PL_endav, 1);
4987 av_store(PL_endav, 0, (SV*)cv);
4988 GvCV(gv) = 0; /* cv has been hijacked */
4990 else if (strEQ(s, "CHECK")) {
4992 PL_checkav = newAV();
4993 if (PL_main_start && ckWARN(WARN_VOID))
4994 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4995 av_unshift(PL_checkav, 1);
4996 av_store(PL_checkav, 0, (SV*)cv);
4997 GvCV(gv) = 0; /* cv has been hijacked */
4999 else if (strEQ(s, "INIT")) {
5001 PL_initav = newAV();
5002 if (PL_main_start && ckWARN(WARN_VOID))
5003 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5004 av_push(PL_initav, (SV*)cv);
5005 GvCV(gv) = 0; /* cv has been hijacked */
5016 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5025 name = SvPVx(cSVOPo->op_sv, n_a);
5028 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5029 #ifdef GV_SHARED_CHECK
5031 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5035 if ((cv = GvFORM(gv))) {
5036 if (ckWARN(WARN_REDEFINE)) {
5037 line_t oldline = CopLINE(PL_curcop);
5039 CopLINE_set(PL_curcop, PL_copline);
5040 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5041 CopLINE_set(PL_curcop, oldline);
5048 CvFILE(cv) = CopFILE(PL_curcop);
5050 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5051 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5052 SvPADTMP_on(PL_curpad[ix]);
5055 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5056 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5057 OpREFCNT_set(CvROOT(cv), 1);
5058 CvSTART(cv) = LINKLIST(CvROOT(cv));
5059 CvROOT(cv)->op_next = 0;
5062 PL_copline = NOLINE;
5067 Perl_newANONLIST(pTHX_ OP *o)
5069 return newUNOP(OP_REFGEN, 0,
5070 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5074 Perl_newANONHASH(pTHX_ OP *o)
5076 return newUNOP(OP_REFGEN, 0,
5077 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5081 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5083 return newANONATTRSUB(floor, proto, Nullop, block);
5087 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5089 return newUNOP(OP_REFGEN, 0,
5090 newSVOP(OP_ANONCODE, 0,
5091 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5095 Perl_oopsAV(pTHX_ OP *o)
5097 switch (o->op_type) {
5099 o->op_type = OP_PADAV;
5100 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5101 return ref(o, OP_RV2AV);
5104 o->op_type = OP_RV2AV;
5105 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5110 if (ckWARN_d(WARN_INTERNAL))
5111 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5118 Perl_oopsHV(pTHX_ OP *o)
5120 switch (o->op_type) {
5123 o->op_type = OP_PADHV;
5124 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5125 return ref(o, OP_RV2HV);
5129 o->op_type = OP_RV2HV;
5130 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5135 if (ckWARN_d(WARN_INTERNAL))
5136 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5143 Perl_newAVREF(pTHX_ OP *o)
5145 if (o->op_type == OP_PADANY) {
5146 o->op_type = OP_PADAV;
5147 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5150 return newUNOP(OP_RV2AV, 0, scalar(o));
5154 Perl_newGVREF(pTHX_ I32 type, OP *o)
5156 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5157 return newUNOP(OP_NULL, 0, o);
5158 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5162 Perl_newHVREF(pTHX_ OP *o)
5164 if (o->op_type == OP_PADANY) {
5165 o->op_type = OP_PADHV;
5166 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5169 return newUNOP(OP_RV2HV, 0, scalar(o));
5173 Perl_oopsCV(pTHX_ OP *o)
5175 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5181 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5183 return newUNOP(OP_RV2CV, flags, scalar(o));
5187 Perl_newSVREF(pTHX_ OP *o)
5189 if (o->op_type == OP_PADANY) {
5190 o->op_type = OP_PADSV;
5191 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5194 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5195 o->op_flags |= OPpDONE_SVREF;
5198 return newUNOP(OP_RV2SV, 0, scalar(o));
5201 /* Check routines. */
5204 Perl_ck_anoncode(pTHX_ OP *o)
5209 name = NEWSV(1106,0);
5210 sv_upgrade(name, SVt_PVNV);
5211 sv_setpvn(name, "&", 1);
5214 ix = pad_alloc(o->op_type, SVs_PADMY);
5215 av_store(PL_comppad_name, ix, name);
5216 av_store(PL_comppad, ix, cSVOPo->op_sv);
5217 SvPADMY_on(cSVOPo->op_sv);
5218 cSVOPo->op_sv = Nullsv;
5219 cSVOPo->op_targ = ix;
5224 Perl_ck_bitop(pTHX_ OP *o)
5226 o->op_private = PL_hints;
5231 Perl_ck_concat(pTHX_ OP *o)
5233 if (cUNOPo->op_first->op_type == OP_CONCAT)
5234 o->op_flags |= OPf_STACKED;
5239 Perl_ck_spair(pTHX_ OP *o)
5241 if (o->op_flags & OPf_KIDS) {
5244 OPCODE type = o->op_type;
5245 o = modkids(ck_fun(o), type);
5246 kid = cUNOPo->op_first;
5247 newop = kUNOP->op_first->op_sibling;
5249 (newop->op_sibling ||
5250 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5251 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5252 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5256 op_free(kUNOP->op_first);
5257 kUNOP->op_first = newop;
5259 o->op_ppaddr = PL_ppaddr[++o->op_type];
5264 Perl_ck_delete(pTHX_ OP *o)
5268 if (o->op_flags & OPf_KIDS) {
5269 OP *kid = cUNOPo->op_first;
5270 switch (kid->op_type) {
5272 o->op_flags |= OPf_SPECIAL;
5275 o->op_private |= OPpSLICE;
5278 o->op_flags |= OPf_SPECIAL;
5283 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5284 PL_op_desc[o->op_type]);
5292 Perl_ck_eof(pTHX_ OP *o)
5294 I32 type = o->op_type;
5296 if (o->op_flags & OPf_KIDS) {
5297 if (cLISTOPo->op_first->op_type == OP_STUB) {
5299 o = newUNOP(type, OPf_SPECIAL,
5300 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5308 Perl_ck_eval(pTHX_ OP *o)
5310 PL_hints |= HINT_BLOCK_SCOPE;
5311 if (o->op_flags & OPf_KIDS) {
5312 SVOP *kid = (SVOP*)cUNOPo->op_first;
5315 o->op_flags &= ~OPf_KIDS;
5318 else if (kid->op_type == OP_LINESEQ) {
5321 kid->op_next = o->op_next;
5322 cUNOPo->op_first = 0;
5325 NewOp(1101, enter, 1, LOGOP);
5326 enter->op_type = OP_ENTERTRY;
5327 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5328 enter->op_private = 0;
5330 /* establish postfix order */
5331 enter->op_next = (OP*)enter;
5333 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5334 o->op_type = OP_LEAVETRY;
5335 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5336 enter->op_other = o;
5344 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5346 o->op_targ = (PADOFFSET)PL_hints;
5351 Perl_ck_exit(pTHX_ OP *o)
5354 HV *table = GvHV(PL_hintgv);
5356 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5357 if (svp && *svp && SvTRUE(*svp))
5358 o->op_private |= OPpEXIT_VMSISH;
5365 Perl_ck_exec(pTHX_ OP *o)
5368 if (o->op_flags & OPf_STACKED) {
5370 kid = cUNOPo->op_first->op_sibling;
5371 if (kid->op_type == OP_RV2GV)
5380 Perl_ck_exists(pTHX_ OP *o)
5383 if (o->op_flags & OPf_KIDS) {
5384 OP *kid = cUNOPo->op_first;
5385 if (kid->op_type == OP_ENTERSUB) {
5386 (void) ref(kid, o->op_type);
5387 if (kid->op_type != OP_RV2CV && !PL_error_count)
5388 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5389 PL_op_desc[o->op_type]);
5390 o->op_private |= OPpEXISTS_SUB;
5392 else if (kid->op_type == OP_AELEM)
5393 o->op_flags |= OPf_SPECIAL;
5394 else if (kid->op_type != OP_HELEM)
5395 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5396 PL_op_desc[o->op_type]);
5404 Perl_ck_gvconst(pTHX_ register OP *o)
5406 o = fold_constants(o);
5407 if (o->op_type == OP_CONST)
5414 Perl_ck_rvconst(pTHX_ register OP *o)
5416 SVOP *kid = (SVOP*)cUNOPo->op_first;
5418 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5419 if (kid->op_type == OP_CONST) {
5423 SV *kidsv = kid->op_sv;
5426 /* Is it a constant from cv_const_sv()? */
5427 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5428 SV *rsv = SvRV(kidsv);
5429 int svtype = SvTYPE(rsv);
5430 char *badtype = Nullch;
5432 switch (o->op_type) {
5434 if (svtype > SVt_PVMG)
5435 badtype = "a SCALAR";
5438 if (svtype != SVt_PVAV)
5439 badtype = "an ARRAY";
5442 if (svtype != SVt_PVHV) {
5443 if (svtype == SVt_PVAV) { /* pseudohash? */
5444 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5445 if (ksv && SvROK(*ksv)
5446 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5455 if (svtype != SVt_PVCV)
5460 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5463 name = SvPV(kidsv, n_a);
5464 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5465 char *badthing = Nullch;
5466 switch (o->op_type) {
5468 badthing = "a SCALAR";
5471 badthing = "an ARRAY";
5474 badthing = "a HASH";
5479 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5483 * This is a little tricky. We only want to add the symbol if we
5484 * didn't add it in the lexer. Otherwise we get duplicate strict
5485 * warnings. But if we didn't add it in the lexer, we must at
5486 * least pretend like we wanted to add it even if it existed before,
5487 * or we get possible typo warnings. OPpCONST_ENTERED says
5488 * whether the lexer already added THIS instance of this symbol.
5490 iscv = (o->op_type == OP_RV2CV) * 2;
5492 gv = gv_fetchpv(name,
5493 iscv | !(kid->op_private & OPpCONST_ENTERED),
5496 : o->op_type == OP_RV2SV
5498 : o->op_type == OP_RV2AV
5500 : o->op_type == OP_RV2HV
5503 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5505 kid->op_type = OP_GV;
5506 SvREFCNT_dec(kid->op_sv);
5508 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5509 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5510 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5512 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5514 kid->op_sv = SvREFCNT_inc(gv);
5516 kid->op_private = 0;
5517 kid->op_ppaddr = PL_ppaddr[OP_GV];
5524 Perl_ck_ftst(pTHX_ OP *o)
5526 I32 type = o->op_type;
5528 if (o->op_flags & OPf_REF) {
5531 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5532 SVOP *kid = (SVOP*)cUNOPo->op_first;
5534 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5536 OP *newop = newGVOP(type, OPf_REF,
5537 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5544 if (type == OP_FTTTY)
5545 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5548 o = newUNOP(type, 0, newDEFSVOP());
5551 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5553 if (PL_hints & HINT_LOCALE)
5554 o->op_private |= OPpLOCALE;
5561 Perl_ck_fun(pTHX_ OP *o)
5567 int type = o->op_type;
5568 register I32 oa = PL_opargs[type] >> OASHIFT;
5570 if (o->op_flags & OPf_STACKED) {
5571 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5574 return no_fh_allowed(o);
5577 if (o->op_flags & OPf_KIDS) {
5579 tokid = &cLISTOPo->op_first;
5580 kid = cLISTOPo->op_first;
5581 if (kid->op_type == OP_PUSHMARK ||
5582 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5584 tokid = &kid->op_sibling;
5585 kid = kid->op_sibling;
5587 if (!kid && PL_opargs[type] & OA_DEFGV)
5588 *tokid = kid = newDEFSVOP();
5592 sibl = kid->op_sibling;
5595 /* list seen where single (scalar) arg expected? */
5596 if (numargs == 1 && !(oa >> 4)
5597 && kid->op_type == OP_LIST && type != OP_SCALAR)
5599 return too_many_arguments(o,PL_op_desc[type]);
5612 if (kid->op_type == OP_CONST &&
5613 (kid->op_private & OPpCONST_BARE))
5615 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5616 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5617 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5618 if (ckWARN(WARN_DEPRECATED))
5619 Perl_warner(aTHX_ WARN_DEPRECATED,
5620 "Array @%s missing the @ in argument %"IVdf" of %s()",
5621 name, (IV)numargs, PL_op_desc[type]);
5624 kid->op_sibling = sibl;
5627 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5628 bad_type(numargs, "array", PL_op_desc[type], kid);
5632 if (kid->op_type == OP_CONST &&
5633 (kid->op_private & OPpCONST_BARE))
5635 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5636 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5637 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5638 if (ckWARN(WARN_DEPRECATED))
5639 Perl_warner(aTHX_ WARN_DEPRECATED,
5640 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5641 name, (IV)numargs, PL_op_desc[type]);
5644 kid->op_sibling = sibl;
5647 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5648 bad_type(numargs, "hash", PL_op_desc[type], kid);
5653 OP *newop = newUNOP(OP_NULL, 0, kid);
5654 kid->op_sibling = 0;
5656 newop->op_next = newop;
5658 kid->op_sibling = sibl;
5663 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5664 if (kid->op_type == OP_CONST &&
5665 (kid->op_private & OPpCONST_BARE))
5667 OP *newop = newGVOP(OP_GV, 0,
5668 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5673 else if (kid->op_type == OP_READLINE) {
5674 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5675 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5678 I32 flags = OPf_SPECIAL;
5682 /* is this op a FH constructor? */
5683 if (is_handle_constructor(o,numargs)) {
5684 char *name = Nullch;
5688 /* Set a flag to tell rv2gv to vivify
5689 * need to "prove" flag does not mean something
5690 * else already - NI-S 1999/05/07
5693 if (kid->op_type == OP_PADSV) {
5694 SV **namep = av_fetch(PL_comppad_name,
5696 if (namep && *namep)
5697 name = SvPV(*namep, len);
5699 else if (kid->op_type == OP_RV2SV
5700 && kUNOP->op_first->op_type == OP_GV)
5702 GV *gv = cGVOPx_gv(kUNOP->op_first);
5704 len = GvNAMELEN(gv);
5706 else if (kid->op_type == OP_AELEM
5707 || kid->op_type == OP_HELEM)
5709 name = "__ANONIO__";
5715 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5716 namesv = PL_curpad[targ];
5717 (void)SvUPGRADE(namesv, SVt_PV);
5719 sv_setpvn(namesv, "$", 1);
5720 sv_catpvn(namesv, name, len);
5723 kid->op_sibling = 0;
5724 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5725 kid->op_targ = targ;
5726 kid->op_private |= priv;
5728 kid->op_sibling = sibl;
5734 mod(scalar(kid), type);
5738 tokid = &kid->op_sibling;
5739 kid = kid->op_sibling;
5741 o->op_private |= numargs;
5743 return too_many_arguments(o,PL_op_desc[o->op_type]);
5746 else if (PL_opargs[type] & OA_DEFGV) {
5748 return newUNOP(type, 0, newDEFSVOP());
5752 while (oa & OA_OPTIONAL)
5754 if (oa && oa != OA_LIST)
5755 return too_few_arguments(o,PL_op_desc[o->op_type]);
5761 Perl_ck_glob(pTHX_ OP *o)
5766 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5767 append_elem(OP_GLOB, o, newDEFSVOP());
5769 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5770 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5772 #if !defined(PERL_EXTERNAL_GLOB)
5773 /* XXX this can be tightened up and made more failsafe. */
5776 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5777 /* null-terminated import list */
5778 newSVpvn(":globally", 9), Nullsv);
5779 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5782 #endif /* PERL_EXTERNAL_GLOB */
5784 if (gv && GvIMPORTED_CV(gv)) {
5785 append_elem(OP_GLOB, o,
5786 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5787 o->op_type = OP_LIST;
5788 o->op_ppaddr = PL_ppaddr[OP_LIST];
5789 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5790 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5791 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5792 append_elem(OP_LIST, o,
5793 scalar(newUNOP(OP_RV2CV, 0,
5794 newGVOP(OP_GV, 0, gv)))));
5795 o = newUNOP(OP_NULL, 0, ck_subr(o));
5796 o->op_targ = OP_GLOB; /* hint at what it used to be */
5799 gv = newGVgen("main");
5801 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5807 Perl_ck_grep(pTHX_ OP *o)
5811 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5813 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5814 NewOp(1101, gwop, 1, LOGOP);
5816 if (o->op_flags & OPf_STACKED) {
5819 kid = cLISTOPo->op_first->op_sibling;
5820 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5823 kid->op_next = (OP*)gwop;
5824 o->op_flags &= ~OPf_STACKED;
5826 kid = cLISTOPo->op_first->op_sibling;
5827 if (type == OP_MAPWHILE)
5834 kid = cLISTOPo->op_first->op_sibling;
5835 if (kid->op_type != OP_NULL)
5836 Perl_croak(aTHX_ "panic: ck_grep");
5837 kid = kUNOP->op_first;
5839 gwop->op_type = type;
5840 gwop->op_ppaddr = PL_ppaddr[type];
5841 gwop->op_first = listkids(o);
5842 gwop->op_flags |= OPf_KIDS;
5843 gwop->op_private = 1;
5844 gwop->op_other = LINKLIST(kid);
5845 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5846 kid->op_next = (OP*)gwop;
5848 kid = cLISTOPo->op_first->op_sibling;
5849 if (!kid || !kid->op_sibling)
5850 return too_few_arguments(o,PL_op_desc[o->op_type]);
5851 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5852 mod(kid, OP_GREPSTART);
5858 Perl_ck_index(pTHX_ OP *o)
5860 if (o->op_flags & OPf_KIDS) {
5861 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5863 kid = kid->op_sibling; /* get past "big" */
5864 if (kid && kid->op_type == OP_CONST)
5865 fbm_compile(((SVOP*)kid)->op_sv, 0);
5871 Perl_ck_lengthconst(pTHX_ OP *o)
5873 /* XXX length optimization goes here */
5878 Perl_ck_lfun(pTHX_ OP *o)
5880 OPCODE type = o->op_type;
5881 return modkids(ck_fun(o), type);
5885 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5887 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5888 switch (cUNOPo->op_first->op_type) {
5890 /* This is needed for
5891 if (defined %stash::)
5892 to work. Do not break Tk.
5894 break; /* Globals via GV can be undef */
5896 case OP_AASSIGN: /* Is this a good idea? */
5897 Perl_warner(aTHX_ WARN_DEPRECATED,
5898 "defined(@array) is deprecated");
5899 Perl_warner(aTHX_ WARN_DEPRECATED,
5900 "\t(Maybe you should just omit the defined()?)\n");
5903 /* This is needed for
5904 if (defined %stash::)
5905 to work. Do not break Tk.
5907 break; /* Globals via GV can be undef */
5909 Perl_warner(aTHX_ WARN_DEPRECATED,
5910 "defined(%%hash) is deprecated");
5911 Perl_warner(aTHX_ WARN_DEPRECATED,
5912 "\t(Maybe you should just omit the defined()?)\n");
5923 Perl_ck_rfun(pTHX_ OP *o)
5925 OPCODE type = o->op_type;
5926 return refkids(ck_fun(o), type);
5930 Perl_ck_listiob(pTHX_ OP *o)
5934 kid = cLISTOPo->op_first;
5937 kid = cLISTOPo->op_first;
5939 if (kid->op_type == OP_PUSHMARK)
5940 kid = kid->op_sibling;
5941 if (kid && o->op_flags & OPf_STACKED)
5942 kid = kid->op_sibling;
5943 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5944 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5945 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5946 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5947 cLISTOPo->op_first->op_sibling = kid;
5948 cLISTOPo->op_last = kid;
5949 kid = kid->op_sibling;
5954 append_elem(o->op_type, o, newDEFSVOP());
5960 if (PL_hints & HINT_LOCALE)
5961 o->op_private |= OPpLOCALE;
5968 Perl_ck_fun_locale(pTHX_ OP *o)
5974 if (PL_hints & HINT_LOCALE)
5975 o->op_private |= OPpLOCALE;
5982 Perl_ck_sassign(pTHX_ OP *o)
5984 OP *kid = cLISTOPo->op_first;
5985 /* has a disposable target? */
5986 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5987 && !(kid->op_flags & OPf_STACKED)
5988 /* Cannot steal the second time! */
5989 && !(kid->op_private & OPpTARGET_MY))
5991 OP *kkid = kid->op_sibling;
5993 /* Can just relocate the target. */
5994 if (kkid && kkid->op_type == OP_PADSV
5995 && !(kkid->op_private & OPpLVAL_INTRO))
5997 kid->op_targ = kkid->op_targ;
5999 /* Now we do not need PADSV and SASSIGN. */
6000 kid->op_sibling = o->op_sibling; /* NULL */
6001 cLISTOPo->op_first = NULL;
6004 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6012 Perl_ck_scmp(pTHX_ OP *o)
6016 if (PL_hints & HINT_LOCALE)
6017 o->op_private |= OPpLOCALE;
6024 Perl_ck_match(pTHX_ OP *o)
6026 o->op_private |= OPpRUNTIME;
6031 Perl_ck_method(pTHX_ OP *o)
6033 OP *kid = cUNOPo->op_first;
6034 if (kid->op_type == OP_CONST) {
6035 SV* sv = kSVOP->op_sv;
6036 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6038 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6039 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6042 kSVOP->op_sv = Nullsv;
6044 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6053 Perl_ck_null(pTHX_ OP *o)
6059 Perl_ck_open(pTHX_ OP *o)
6061 HV *table = GvHV(PL_hintgv);
6065 svp = hv_fetch(table, "open_IN", 7, FALSE);
6067 mode = mode_from_discipline(*svp);
6068 if (mode & O_BINARY)
6069 o->op_private |= OPpOPEN_IN_RAW;
6070 else if (mode & O_TEXT)
6071 o->op_private |= OPpOPEN_IN_CRLF;
6074 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6076 mode = mode_from_discipline(*svp);
6077 if (mode & O_BINARY)
6078 o->op_private |= OPpOPEN_OUT_RAW;
6079 else if (mode & O_TEXT)
6080 o->op_private |= OPpOPEN_OUT_CRLF;
6083 if (o->op_type == OP_BACKTICK)
6089 Perl_ck_repeat(pTHX_ OP *o)
6091 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6092 o->op_private |= OPpREPEAT_DOLIST;
6093 cBINOPo->op_first = force_list(cBINOPo->op_first);
6101 Perl_ck_require(pTHX_ OP *o)
6103 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6104 SVOP *kid = (SVOP*)cUNOPo->op_first;
6106 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6108 for (s = SvPVX(kid->op_sv); *s; s++) {
6109 if (*s == ':' && s[1] == ':') {
6111 Move(s+2, s+1, strlen(s+2)+1, char);
6112 --SvCUR(kid->op_sv);
6115 if (SvREADONLY(kid->op_sv)) {
6116 SvREADONLY_off(kid->op_sv);
6117 sv_catpvn(kid->op_sv, ".pm", 3);
6118 SvREADONLY_on(kid->op_sv);
6121 sv_catpvn(kid->op_sv, ".pm", 3);
6128 Perl_ck_return(pTHX_ OP *o)
6131 if (CvLVALUE(PL_compcv)) {
6132 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6133 mod(kid, OP_LEAVESUBLV);
6140 Perl_ck_retarget(pTHX_ OP *o)
6142 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6149 Perl_ck_select(pTHX_ OP *o)
6152 if (o->op_flags & OPf_KIDS) {
6153 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6154 if (kid && kid->op_sibling) {
6155 o->op_type = OP_SSELECT;
6156 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6158 return fold_constants(o);
6162 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6163 if (kid && kid->op_type == OP_RV2GV)
6164 kid->op_private &= ~HINT_STRICT_REFS;
6169 Perl_ck_shift(pTHX_ OP *o)
6171 I32 type = o->op_type;
6173 if (!(o->op_flags & OPf_KIDS)) {
6178 if (!CvUNIQUE(PL_compcv)) {
6179 argop = newOP(OP_PADAV, OPf_REF);
6180 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6183 argop = newUNOP(OP_RV2AV, 0,
6184 scalar(newGVOP(OP_GV, 0,
6185 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6188 argop = newUNOP(OP_RV2AV, 0,
6189 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6190 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6191 #endif /* USE_THREADS */
6192 return newUNOP(type, 0, scalar(argop));
6194 return scalar(modkids(ck_fun(o), type));
6198 Perl_ck_sort(pTHX_ OP *o)
6203 if (PL_hints & HINT_LOCALE)
6204 o->op_private |= OPpLOCALE;
6207 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6209 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6210 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6212 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6214 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6216 if (kid->op_type == OP_SCOPE) {
6220 else if (kid->op_type == OP_LEAVE) {
6221 if (o->op_type == OP_SORT) {
6222 null(kid); /* wipe out leave */
6225 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6226 if (k->op_next == kid)
6228 /* don't descend into loops */
6229 else if (k->op_type == OP_ENTERLOOP
6230 || k->op_type == OP_ENTERITER)
6232 k = cLOOPx(k)->op_lastop;
6237 kid->op_next = 0; /* just disconnect the leave */
6238 k = kLISTOP->op_first;
6243 if (o->op_type == OP_SORT) {
6244 /* provide scalar context for comparison function/block */
6250 o->op_flags |= OPf_SPECIAL;
6252 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6255 firstkid = firstkid->op_sibling;
6258 /* provide list context for arguments */
6259 if (o->op_type == OP_SORT)
6266 S_simplify_sort(pTHX_ OP *o)
6268 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6272 if (!(o->op_flags & OPf_STACKED))
6274 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6275 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6276 kid = kUNOP->op_first; /* get past null */
6277 if (kid->op_type != OP_SCOPE)
6279 kid = kLISTOP->op_last; /* get past scope */
6280 switch(kid->op_type) {
6288 k = kid; /* remember this node*/
6289 if (kBINOP->op_first->op_type != OP_RV2SV)
6291 kid = kBINOP->op_first; /* get past cmp */
6292 if (kUNOP->op_first->op_type != OP_GV)
6294 kid = kUNOP->op_first; /* get past rv2sv */
6296 if (GvSTASH(gv) != PL_curstash)
6298 if (strEQ(GvNAME(gv), "a"))
6300 else if (strEQ(GvNAME(gv), "b"))
6304 kid = k; /* back to cmp */
6305 if (kBINOP->op_last->op_type != OP_RV2SV)
6307 kid = kBINOP->op_last; /* down to 2nd arg */
6308 if (kUNOP->op_first->op_type != OP_GV)
6310 kid = kUNOP->op_first; /* get past rv2sv */
6312 if (GvSTASH(gv) != PL_curstash
6314 ? strNE(GvNAME(gv), "a")
6315 : strNE(GvNAME(gv), "b")))
6317 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6319 o->op_private |= OPpSORT_REVERSE;
6320 if (k->op_type == OP_NCMP)
6321 o->op_private |= OPpSORT_NUMERIC;
6322 if (k->op_type == OP_I_NCMP)
6323 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6324 kid = cLISTOPo->op_first->op_sibling;
6325 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6326 op_free(kid); /* then delete it */
6330 Perl_ck_split(pTHX_ OP *o)
6334 if (o->op_flags & OPf_STACKED)
6335 return no_fh_allowed(o);
6337 kid = cLISTOPo->op_first;
6338 if (kid->op_type != OP_NULL)
6339 Perl_croak(aTHX_ "panic: ck_split");
6340 kid = kid->op_sibling;
6341 op_free(cLISTOPo->op_first);
6342 cLISTOPo->op_first = kid;
6344 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6345 cLISTOPo->op_last = kid; /* There was only one element previously */
6348 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6349 OP *sibl = kid->op_sibling;
6350 kid->op_sibling = 0;
6351 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6352 if (cLISTOPo->op_first == cLISTOPo->op_last)
6353 cLISTOPo->op_last = kid;
6354 cLISTOPo->op_first = kid;
6355 kid->op_sibling = sibl;
6358 kid->op_type = OP_PUSHRE;
6359 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6362 if (!kid->op_sibling)
6363 append_elem(OP_SPLIT, o, newDEFSVOP());
6365 kid = kid->op_sibling;
6368 if (!kid->op_sibling)
6369 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6371 kid = kid->op_sibling;
6374 if (kid->op_sibling)
6375 return too_many_arguments(o,PL_op_desc[o->op_type]);
6381 Perl_ck_join(pTHX_ OP *o)
6383 if (ckWARN(WARN_SYNTAX)) {
6384 OP *kid = cLISTOPo->op_first->op_sibling;
6385 if (kid && kid->op_type == OP_MATCH) {
6386 char *pmstr = "STRING";
6387 if (kPMOP->op_pmregexp)
6388 pmstr = kPMOP->op_pmregexp->precomp;
6389 Perl_warner(aTHX_ WARN_SYNTAX,
6390 "/%s/ should probably be written as \"%s\"",
6398 Perl_ck_subr(pTHX_ OP *o)
6400 OP *prev = ((cUNOPo->op_first->op_sibling)
6401 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6402 OP *o2 = prev->op_sibling;
6411 o->op_private |= OPpENTERSUB_HASTARG;
6412 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6413 if (cvop->op_type == OP_RV2CV) {
6415 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6416 null(cvop); /* disable rv2cv */
6417 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6418 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6419 GV *gv = cGVOPx_gv(tmpop);
6422 tmpop->op_private |= OPpEARLY_CV;
6423 else if (SvPOK(cv)) {
6424 namegv = CvANON(cv) ? gv : CvGV(cv);
6425 proto = SvPV((SV*)cv, n_a);
6429 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6430 if (o2->op_type == OP_CONST)
6431 o2->op_private &= ~OPpCONST_STRICT;
6432 else if (o2->op_type == OP_LIST) {
6433 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6434 if (o && o->op_type == OP_CONST)
6435 o->op_private &= ~OPpCONST_STRICT;
6438 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6439 if (PERLDB_SUB && PL_curstash != PL_debstash)
6440 o->op_private |= OPpENTERSUB_DB;
6441 while (o2 != cvop) {
6445 return too_many_arguments(o, gv_ename(namegv));
6463 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6465 arg == 1 ? "block or sub {}" : "sub {}",
6466 gv_ename(namegv), o2);
6469 /* '*' allows any scalar type, including bareword */
6472 if (o2->op_type == OP_RV2GV)
6473 goto wrapref; /* autoconvert GLOB -> GLOBref */
6474 else if (o2->op_type == OP_CONST)
6475 o2->op_private &= ~OPpCONST_STRICT;
6476 else if (o2->op_type == OP_ENTERSUB) {
6477 /* accidental subroutine, revert to bareword */
6478 OP *gvop = ((UNOP*)o2)->op_first;
6479 if (gvop && gvop->op_type == OP_NULL) {
6480 gvop = ((UNOP*)gvop)->op_first;
6482 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6485 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6486 (gvop = ((UNOP*)gvop)->op_first) &&
6487 gvop->op_type == OP_GV)
6489 GV *gv = cGVOPx_gv(gvop);
6490 OP *sibling = o2->op_sibling;
6491 SV *n = newSVpvn("",0);
6493 gv_fullname3(n, gv, "");
6494 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6495 sv_chop(n, SvPVX(n)+6);
6496 o2 = newSVOP(OP_CONST, 0, n);
6497 prev->op_sibling = o2;
6498 o2->op_sibling = sibling;
6510 if (o2->op_type != OP_RV2GV)
6511 bad_type(arg, "symbol", gv_ename(namegv), o2);
6514 if (o2->op_type != OP_ENTERSUB)
6515 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6518 if (o2->op_type != OP_RV2SV
6519 && o2->op_type != OP_PADSV
6520 && o2->op_type != OP_HELEM
6521 && o2->op_type != OP_AELEM
6522 && o2->op_type != OP_THREADSV)
6524 bad_type(arg, "scalar", gv_ename(namegv), o2);
6528 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6529 bad_type(arg, "array", gv_ename(namegv), o2);
6532 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6533 bad_type(arg, "hash", gv_ename(namegv), o2);
6537 OP* sib = kid->op_sibling;
6538 kid->op_sibling = 0;
6539 o2 = newUNOP(OP_REFGEN, 0, kid);
6540 o2->op_sibling = sib;
6541 prev->op_sibling = o2;
6552 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6553 gv_ename(namegv), SvPV((SV*)cv, n_a));
6558 mod(o2, OP_ENTERSUB);
6560 o2 = o2->op_sibling;
6562 if (proto && !optional &&
6563 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6564 return too_few_arguments(o, gv_ename(namegv));
6569 Perl_ck_svconst(pTHX_ OP *o)
6571 SvREADONLY_on(cSVOPo->op_sv);
6576 Perl_ck_trunc(pTHX_ OP *o)
6578 if (o->op_flags & OPf_KIDS) {
6579 SVOP *kid = (SVOP*)cUNOPo->op_first;
6581 if (kid->op_type == OP_NULL)
6582 kid = (SVOP*)kid->op_sibling;
6583 if (kid && kid->op_type == OP_CONST &&
6584 (kid->op_private & OPpCONST_BARE))
6586 o->op_flags |= OPf_SPECIAL;
6587 kid->op_private &= ~OPpCONST_STRICT;
6594 Perl_ck_substr(pTHX_ OP *o)
6597 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6598 OP *kid = cLISTOPo->op_first;
6600 if (kid->op_type == OP_NULL)
6601 kid = kid->op_sibling;
6603 kid->op_flags |= OPf_MOD;
6609 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6612 Perl_peep(pTHX_ register OP *o)
6614 register OP* oldop = 0;
6617 if (!o || o->op_seq)
6621 SAVEVPTR(PL_curcop);
6622 for (; o; o = o->op_next) {
6628 switch (o->op_type) {
6632 PL_curcop = ((COP*)o); /* for warnings */
6633 o->op_seq = PL_op_seqmax++;
6637 if (cSVOPo->op_private & OPpCONST_STRICT)
6638 no_bareword_allowed(o);
6640 /* Relocate sv to the pad for thread safety.
6641 * Despite being a "constant", the SV is written to,
6642 * for reference counts, sv_upgrade() etc. */
6644 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6645 if (SvPADTMP(cSVOPo->op_sv)) {
6646 /* If op_sv is already a PADTMP then it is being used by
6647 * some pad, so make a copy. */
6648 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6649 SvREADONLY_on(PL_curpad[ix]);
6650 SvREFCNT_dec(cSVOPo->op_sv);
6653 SvREFCNT_dec(PL_curpad[ix]);
6654 SvPADTMP_on(cSVOPo->op_sv);
6655 PL_curpad[ix] = cSVOPo->op_sv;
6656 /* XXX I don't know how this isn't readonly already. */
6657 SvREADONLY_on(PL_curpad[ix]);
6659 cSVOPo->op_sv = Nullsv;
6663 o->op_seq = PL_op_seqmax++;
6667 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6668 if (o->op_next->op_private & OPpTARGET_MY) {
6669 if (o->op_flags & OPf_STACKED) /* chained concats */
6670 goto ignore_optimization;
6672 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6673 o->op_targ = o->op_next->op_targ;
6674 o->op_next->op_targ = 0;
6675 o->op_private |= OPpTARGET_MY;
6680 ignore_optimization:
6681 o->op_seq = PL_op_seqmax++;
6684 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6685 o->op_seq = PL_op_seqmax++;
6686 break; /* Scalar stub must produce undef. List stub is noop */
6690 if (o->op_targ == OP_NEXTSTATE
6691 || o->op_targ == OP_DBSTATE
6692 || o->op_targ == OP_SETSTATE)
6694 PL_curcop = ((COP*)o);
6701 if (oldop && o->op_next) {
6702 oldop->op_next = o->op_next;
6705 o->op_seq = PL_op_seqmax++;
6709 if (o->op_next->op_type == OP_RV2SV) {
6710 if (!(o->op_next->op_private & OPpDEREF)) {
6712 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6714 o->op_next = o->op_next->op_next;
6715 o->op_type = OP_GVSV;
6716 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6719 else if (o->op_next->op_type == OP_RV2AV) {
6720 OP* pop = o->op_next->op_next;
6722 if (pop->op_type == OP_CONST &&
6723 (PL_op = pop->op_next) &&
6724 pop->op_next->op_type == OP_AELEM &&
6725 !(pop->op_next->op_private &
6726 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6727 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6735 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6736 o->op_next = pop->op_next->op_next;
6737 o->op_type = OP_AELEMFAST;
6738 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6739 o->op_private = (U8)i;
6744 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6746 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6747 /* XXX could check prototype here instead of just carping */
6748 SV *sv = sv_newmortal();
6749 gv_efullname3(sv, gv, Nullch);
6750 Perl_warner(aTHX_ WARN_PROTOTYPE,
6751 "%s() called too early to check prototype",
6756 o->op_seq = PL_op_seqmax++;
6767 o->op_seq = PL_op_seqmax++;
6768 while (cLOGOP->op_other->op_type == OP_NULL)
6769 cLOGOP->op_other = cLOGOP->op_other->op_next;
6770 peep(cLOGOP->op_other);
6774 o->op_seq = PL_op_seqmax++;
6775 while (cLOOP->op_redoop->op_type == OP_NULL)
6776 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6777 peep(cLOOP->op_redoop);
6778 while (cLOOP->op_nextop->op_type == OP_NULL)
6779 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6780 peep(cLOOP->op_nextop);
6781 while (cLOOP->op_lastop->op_type == OP_NULL)
6782 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6783 peep(cLOOP->op_lastop);
6789 o->op_seq = PL_op_seqmax++;
6790 while (cPMOP->op_pmreplstart &&
6791 cPMOP->op_pmreplstart->op_type == OP_NULL)
6792 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6793 peep(cPMOP->op_pmreplstart);
6797 o->op_seq = PL_op_seqmax++;
6798 if (ckWARN(WARN_SYNTAX) && o->op_next
6799 && o->op_next->op_type == OP_NEXTSTATE) {
6800 if (o->op_next->op_sibling &&
6801 o->op_next->op_sibling->op_type != OP_EXIT &&
6802 o->op_next->op_sibling->op_type != OP_WARN &&
6803 o->op_next->op_sibling->op_type != OP_DIE) {
6804 line_t oldline = CopLINE(PL_curcop);
6806 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6807 Perl_warner(aTHX_ WARN_EXEC,
6808 "Statement unlikely to be reached");
6809 Perl_warner(aTHX_ WARN_EXEC,
6810 "\t(Maybe you meant system() when you said exec()?)\n");
6811 CopLINE_set(PL_curcop, oldline);
6820 SV **svp, **indsvp, *sv;
6825 o->op_seq = PL_op_seqmax++;
6827 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6830 /* Make the CONST have a shared SV */
6831 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6832 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6833 key = SvPV(sv, keylen);
6836 lexname = newSVpvn_share(key, keylen, 0);
6841 if ((o->op_private & (OPpLVAL_INTRO)))
6844 rop = (UNOP*)((BINOP*)o)->op_first;
6845 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6847 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6848 if (!SvOBJECT(lexname))
6850 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6851 if (!fields || !GvHV(*fields))
6853 key = SvPV(*svp, keylen);
6856 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6858 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6859 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6861 ind = SvIV(*indsvp);
6863 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6864 rop->op_type = OP_RV2AV;
6865 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6866 o->op_type = OP_AELEM;
6867 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6869 if (SvREADONLY(*svp))
6871 SvFLAGS(sv) |= (SvFLAGS(*svp)
6872 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6882 SV **svp, **indsvp, *sv;
6886 SVOP *first_key_op, *key_op;
6888 o->op_seq = PL_op_seqmax++;
6889 if ((o->op_private & (OPpLVAL_INTRO))
6890 /* I bet there's always a pushmark... */
6891 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6892 /* hmmm, no optimization if list contains only one key. */
6894 rop = (UNOP*)((LISTOP*)o)->op_last;
6895 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6897 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6898 if (!SvOBJECT(lexname))
6900 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6901 if (!fields || !GvHV(*fields))
6903 /* Again guessing that the pushmark can be jumped over.... */
6904 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6905 ->op_first->op_sibling;
6906 /* Check that the key list contains only constants. */
6907 for (key_op = first_key_op; key_op;
6908 key_op = (SVOP*)key_op->op_sibling)
6909 if (key_op->op_type != OP_CONST)
6913 rop->op_type = OP_RV2AV;
6914 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6915 o->op_type = OP_ASLICE;
6916 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6917 for (key_op = first_key_op; key_op;
6918 key_op = (SVOP*)key_op->op_sibling) {
6919 svp = cSVOPx_svp(key_op);
6920 key = SvPV(*svp, keylen);
6923 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6925 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6926 "in variable %s of type %s",
6927 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6929 ind = SvIV(*indsvp);
6931 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6933 if (SvREADONLY(*svp))
6935 SvFLAGS(sv) |= (SvFLAGS(*svp)
6936 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6944 o->op_seq = PL_op_seqmax++;
6954 /* Efficient sub that returns a constant scalar value. */
6956 const_sv_xsub(pTHXo_ CV* cv)
6961 Perl_croak(aTHX_ "usage: %s::%s()",
6962 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6966 ST(0) = (SV*)XSANY.any_ptr;