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? */
1959 o->op_private |= OPpOUR_INTRO;
1961 } else if (type != OP_PADSV &&
1964 type != OP_PUSHMARK)
1966 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1967 PL_op_desc[o->op_type],
1968 PL_in_my == KEY_our ? "our" : "my"));
1971 else if (attrs && type != OP_PUSHMARK) {
1977 PL_in_my_stash = Nullhv;
1979 /* check for C<my Dog $spot> when deciding package */
1980 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1981 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1982 stash = SvSTASH(*namesvp);
1984 stash = PL_curstash;
1985 padsv = PAD_SV(o->op_targ);
1986 apply_attrs(stash, padsv, attrs);
1988 o->op_flags |= OPf_MOD;
1989 o->op_private |= OPpLVAL_INTRO;
1994 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1996 if (o->op_flags & OPf_PARENS)
2000 o = my_kid(o, attrs);
2002 PL_in_my_stash = Nullhv;
2007 Perl_my(pTHX_ OP *o)
2009 return my_kid(o, Nullop);
2013 Perl_sawparens(pTHX_ OP *o)
2016 o->op_flags |= OPf_PARENS;
2021 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2025 if (ckWARN(WARN_MISC) &&
2026 (left->op_type == OP_RV2AV ||
2027 left->op_type == OP_RV2HV ||
2028 left->op_type == OP_PADAV ||
2029 left->op_type == OP_PADHV)) {
2030 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2031 right->op_type == OP_TRANS)
2032 ? right->op_type : OP_MATCH];
2033 const char *sample = ((left->op_type == OP_RV2AV ||
2034 left->op_type == OP_PADAV)
2035 ? "@array" : "%hash");
2036 Perl_warner(aTHX_ WARN_MISC,
2037 "Applying %s to %s will act on scalar(%s)",
2038 desc, sample, sample);
2041 if (!(right->op_flags & OPf_STACKED) &&
2042 (right->op_type == OP_MATCH ||
2043 right->op_type == OP_SUBST ||
2044 right->op_type == OP_TRANS)) {
2045 right->op_flags |= OPf_STACKED;
2046 if (right->op_type != OP_MATCH &&
2047 ! (right->op_type == OP_TRANS &&
2048 right->op_private & OPpTRANS_IDENTICAL))
2049 left = mod(left, right->op_type);
2050 if (right->op_type == OP_TRANS)
2051 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2053 o = prepend_elem(right->op_type, scalar(left), right);
2055 return newUNOP(OP_NOT, 0, scalar(o));
2059 return bind_match(type, left,
2060 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2064 Perl_invert(pTHX_ OP *o)
2068 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2069 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2073 Perl_scope(pTHX_ OP *o)
2076 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2077 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2078 o->op_type = OP_LEAVE;
2079 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2082 if (o->op_type == OP_LINESEQ) {
2084 o->op_type = OP_SCOPE;
2085 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2086 kid = ((LISTOP*)o)->op_first;
2087 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2091 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2098 Perl_save_hints(pTHX)
2101 SAVESPTR(GvHV(PL_hintgv));
2102 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2103 SAVEFREESV(GvHV(PL_hintgv));
2107 Perl_block_start(pTHX_ int full)
2109 int retval = PL_savestack_ix;
2111 SAVEI32(PL_comppad_name_floor);
2112 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2114 PL_comppad_name_fill = PL_comppad_name_floor;
2115 if (PL_comppad_name_floor < 0)
2116 PL_comppad_name_floor = 0;
2117 SAVEI32(PL_min_intro_pending);
2118 SAVEI32(PL_max_intro_pending);
2119 PL_min_intro_pending = 0;
2120 SAVEI32(PL_comppad_name_fill);
2121 SAVEI32(PL_padix_floor);
2122 PL_padix_floor = PL_padix;
2123 PL_pad_reset_pending = FALSE;
2125 PL_hints &= ~HINT_BLOCK_SCOPE;
2126 SAVESPTR(PL_compiling.cop_warnings);
2127 if (! specialWARN(PL_compiling.cop_warnings)) {
2128 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2129 SAVEFREESV(PL_compiling.cop_warnings) ;
2131 SAVESPTR(PL_compiling.cop_io);
2132 if (! specialCopIO(PL_compiling.cop_io)) {
2133 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2134 SAVEFREESV(PL_compiling.cop_io) ;
2140 Perl_block_end(pTHX_ I32 floor, OP *seq)
2142 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2143 OP* retval = scalarseq(seq);
2145 PL_pad_reset_pending = FALSE;
2146 PL_compiling.op_private = PL_hints;
2148 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2149 pad_leavemy(PL_comppad_name_fill);
2158 OP *o = newOP(OP_THREADSV, 0);
2159 o->op_targ = find_threadsv("_");
2162 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2163 #endif /* USE_THREADS */
2167 Perl_newPROG(pTHX_ OP *o)
2172 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2173 ((PL_in_eval & EVAL_KEEPERR)
2174 ? OPf_SPECIAL : 0), o);
2175 PL_eval_start = linklist(PL_eval_root);
2176 PL_eval_root->op_private |= OPpREFCOUNTED;
2177 OpREFCNT_set(PL_eval_root, 1);
2178 PL_eval_root->op_next = 0;
2179 peep(PL_eval_start);
2184 PL_main_root = scope(sawparens(scalarvoid(o)));
2185 PL_curcop = &PL_compiling;
2186 PL_main_start = LINKLIST(PL_main_root);
2187 PL_main_root->op_private |= OPpREFCOUNTED;
2188 OpREFCNT_set(PL_main_root, 1);
2189 PL_main_root->op_next = 0;
2190 peep(PL_main_start);
2193 /* Register with debugger */
2195 CV *cv = get_cv("DB::postponed", FALSE);
2199 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2201 call_sv((SV*)cv, G_DISCARD);
2208 Perl_localize(pTHX_ OP *o, I32 lex)
2210 if (o->op_flags & OPf_PARENS)
2213 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2215 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2216 if (*s == ';' || *s == '=')
2217 Perl_warner(aTHX_ WARN_PARENTHESIS,
2218 "Parentheses missing around \"%s\" list",
2219 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2225 o = mod(o, OP_NULL); /* a bit kludgey */
2227 PL_in_my_stash = Nullhv;
2232 Perl_jmaybe(pTHX_ OP *o)
2234 if (o->op_type == OP_LIST) {
2237 o2 = newOP(OP_THREADSV, 0);
2238 o2->op_targ = find_threadsv(";");
2240 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2241 #endif /* USE_THREADS */
2242 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2248 Perl_fold_constants(pTHX_ register OP *o)
2251 I32 type = o->op_type;
2254 if (PL_opargs[type] & OA_RETSCALAR)
2256 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2257 o->op_targ = pad_alloc(type, SVs_PADTMP);
2259 /* integerize op, unless it happens to be C<-foo>.
2260 * XXX should pp_i_negate() do magic string negation instead? */
2261 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2262 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2263 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2265 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2268 if (!(PL_opargs[type] & OA_FOLDCONST))
2273 /* XXX might want a ck_negate() for this */
2274 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2287 if (o->op_private & OPpLOCALE)
2292 goto nope; /* Don't try to run w/ errors */
2294 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2295 if ((curop->op_type != OP_CONST ||
2296 (curop->op_private & OPpCONST_BARE)) &&
2297 curop->op_type != OP_LIST &&
2298 curop->op_type != OP_SCALAR &&
2299 curop->op_type != OP_NULL &&
2300 curop->op_type != OP_PUSHMARK)
2306 curop = LINKLIST(o);
2310 sv = *(PL_stack_sp--);
2311 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2312 pad_swipe(o->op_targ);
2313 else if (SvTEMP(sv)) { /* grab mortal temp? */
2314 (void)SvREFCNT_inc(sv);
2318 if (type == OP_RV2GV)
2319 return newGVOP(OP_GV, 0, (GV*)sv);
2321 /* try to smush double to int, but don't smush -2.0 to -2 */
2322 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2325 #ifdef PERL_PRESERVE_IVUV
2326 /* Only bother to attempt to fold to IV if
2327 most operators will benefit */
2331 return newSVOP(OP_CONST, 0, sv);
2335 if (!(PL_opargs[type] & OA_OTHERINT))
2338 if (!(PL_hints & HINT_INTEGER)) {
2339 if (type == OP_MODULO
2340 || type == OP_DIVIDE
2341 || !(o->op_flags & OPf_KIDS))
2346 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2347 if (curop->op_type == OP_CONST) {
2348 if (SvIOK(((SVOP*)curop)->op_sv))
2352 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2356 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2363 Perl_gen_constant_list(pTHX_ register OP *o)
2366 I32 oldtmps_floor = PL_tmps_floor;
2370 return o; /* Don't attempt to run with errors */
2372 PL_op = curop = LINKLIST(o);
2379 PL_tmps_floor = oldtmps_floor;
2381 o->op_type = OP_RV2AV;
2382 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2383 curop = ((UNOP*)o)->op_first;
2384 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2391 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2396 if (!o || o->op_type != OP_LIST)
2397 o = newLISTOP(OP_LIST, 0, o, Nullop);
2399 o->op_flags &= ~OPf_WANT;
2401 if (!(PL_opargs[type] & OA_MARK))
2402 null(cLISTOPo->op_first);
2405 o->op_ppaddr = PL_ppaddr[type];
2406 o->op_flags |= flags;
2408 o = CHECKOP(type, o);
2409 if (o->op_type != type)
2412 return fold_constants(o);
2415 /* List constructors */
2418 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2426 if (first->op_type != type
2427 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2429 return newLISTOP(type, 0, first, last);
2432 if (first->op_flags & OPf_KIDS)
2433 ((LISTOP*)first)->op_last->op_sibling = last;
2435 first->op_flags |= OPf_KIDS;
2436 ((LISTOP*)first)->op_first = last;
2438 ((LISTOP*)first)->op_last = last;
2443 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2451 if (first->op_type != type)
2452 return prepend_elem(type, (OP*)first, (OP*)last);
2454 if (last->op_type != type)
2455 return append_elem(type, (OP*)first, (OP*)last);
2457 first->op_last->op_sibling = last->op_first;
2458 first->op_last = last->op_last;
2459 first->op_flags |= (last->op_flags & OPf_KIDS);
2461 #ifdef PL_OP_SLAB_ALLOC
2469 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2477 if (last->op_type == type) {
2478 if (type == OP_LIST) { /* already a PUSHMARK there */
2479 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2480 ((LISTOP*)last)->op_first->op_sibling = first;
2481 if (!(first->op_flags & OPf_PARENS))
2482 last->op_flags &= ~OPf_PARENS;
2485 if (!(last->op_flags & OPf_KIDS)) {
2486 ((LISTOP*)last)->op_last = first;
2487 last->op_flags |= OPf_KIDS;
2489 first->op_sibling = ((LISTOP*)last)->op_first;
2490 ((LISTOP*)last)->op_first = first;
2492 last->op_flags |= OPf_KIDS;
2496 return newLISTOP(type, 0, first, last);
2502 Perl_newNULLLIST(pTHX)
2504 return newOP(OP_STUB, 0);
2508 Perl_force_list(pTHX_ OP *o)
2510 if (!o || o->op_type != OP_LIST)
2511 o = newLISTOP(OP_LIST, 0, o, Nullop);
2517 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2521 NewOp(1101, listop, 1, LISTOP);
2523 listop->op_type = type;
2524 listop->op_ppaddr = PL_ppaddr[type];
2527 listop->op_flags = flags;
2531 else if (!first && last)
2534 first->op_sibling = last;
2535 listop->op_first = first;
2536 listop->op_last = last;
2537 if (type == OP_LIST) {
2539 pushop = newOP(OP_PUSHMARK, 0);
2540 pushop->op_sibling = first;
2541 listop->op_first = pushop;
2542 listop->op_flags |= OPf_KIDS;
2544 listop->op_last = pushop;
2551 Perl_newOP(pTHX_ I32 type, I32 flags)
2554 NewOp(1101, o, 1, OP);
2556 o->op_ppaddr = PL_ppaddr[type];
2557 o->op_flags = flags;
2560 o->op_private = 0 + (flags >> 8);
2561 if (PL_opargs[type] & OA_RETSCALAR)
2563 if (PL_opargs[type] & OA_TARGET)
2564 o->op_targ = pad_alloc(type, SVs_PADTMP);
2565 return CHECKOP(type, o);
2569 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2574 first = newOP(OP_STUB, 0);
2575 if (PL_opargs[type] & OA_MARK)
2576 first = force_list(first);
2578 NewOp(1101, unop, 1, UNOP);
2579 unop->op_type = type;
2580 unop->op_ppaddr = PL_ppaddr[type];
2581 unop->op_first = first;
2582 unop->op_flags = flags | OPf_KIDS;
2583 unop->op_private = 1 | (flags >> 8);
2584 unop = (UNOP*) CHECKOP(type, unop);
2588 return fold_constants((OP *) unop);
2592 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2595 NewOp(1101, binop, 1, BINOP);
2598 first = newOP(OP_NULL, 0);
2600 binop->op_type = type;
2601 binop->op_ppaddr = PL_ppaddr[type];
2602 binop->op_first = first;
2603 binop->op_flags = flags | OPf_KIDS;
2606 binop->op_private = 1 | (flags >> 8);
2609 binop->op_private = 2 | (flags >> 8);
2610 first->op_sibling = last;
2613 binop = (BINOP*)CHECKOP(type, binop);
2614 if (binop->op_next || binop->op_type != type)
2617 binop->op_last = binop->op_first->op_sibling;
2619 return fold_constants((OP *)binop);
2623 utf8compare(const void *a, const void *b)
2626 for (i = 0; i < 10; i++) {
2627 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2629 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2636 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2638 SV *tstr = ((SVOP*)expr)->op_sv;
2639 SV *rstr = ((SVOP*)repl)->op_sv;
2642 U8 *t = (U8*)SvPV(tstr, tlen);
2643 U8 *r = (U8*)SvPV(rstr, rlen);
2650 register short *tbl;
2652 complement = o->op_private & OPpTRANS_COMPLEMENT;
2653 del = o->op_private & OPpTRANS_DELETE;
2654 squash = o->op_private & OPpTRANS_SQUASH;
2657 o->op_private |= OPpTRANS_FROM_UTF;
2660 o->op_private |= OPpTRANS_TO_UTF;
2662 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2663 SV* listsv = newSVpvn("# comment\n",10);
2665 U8* tend = t + tlen;
2666 U8* rend = r + rlen;
2680 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2681 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2682 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2683 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2686 U8 tmpbuf[UTF8_MAXLEN+1];
2690 New(1109, cp, tlen, U8*);
2692 transv = newSVpvn("",0);
2696 if (t < tend && *t == 0xff) {
2701 qsort(cp, i, sizeof(U8*), utf8compare);
2702 for (j = 0; j < i; j++) {
2704 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2705 UV val = utf8_to_uv(s, cur, &ulen, 0);
2707 diff = val - nextmin;
2709 t = uv_to_utf8(tmpbuf,nextmin);
2710 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2712 t = uv_to_utf8(tmpbuf, val - 1);
2713 sv_catpvn(transv, "\377", 1);
2714 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2717 if (s < tend && *s == 0xff)
2718 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2722 t = uv_to_utf8(tmpbuf,nextmin);
2723 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2724 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2725 sv_catpvn(transv, "\377", 1);
2726 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2727 t = (U8*)SvPVX(transv);
2728 tlen = SvCUR(transv);
2732 else if (!rlen && !del) {
2733 r = t; rlen = tlen; rend = tend;
2737 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2739 o->op_private |= OPpTRANS_IDENTICAL;
2743 while (t < tend || tfirst <= tlast) {
2744 /* see if we need more "t" chars */
2745 if (tfirst > tlast) {
2746 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2748 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2750 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2757 /* now see if we need more "r" chars */
2758 if (rfirst > rlast) {
2760 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2762 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2764 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2773 rfirst = rlast = 0xffffffff;
2777 /* now see which range will peter our first, if either. */
2778 tdiff = tlast - tfirst;
2779 rdiff = rlast - rfirst;
2786 if (rfirst == 0xffffffff) {
2787 diff = tdiff; /* oops, pretend rdiff is infinite */
2789 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2790 (long)tfirst, (long)tlast);
2792 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2796 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2797 (long)tfirst, (long)(tfirst + diff),
2800 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2801 (long)tfirst, (long)rfirst);
2803 if (rfirst + diff > max)
2804 max = rfirst + diff;
2807 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2818 else if (max > 0xff)
2823 Safefree(cPVOPo->op_pv);
2824 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2825 SvREFCNT_dec(listsv);
2827 SvREFCNT_dec(transv);
2829 if (!del && havefinal)
2830 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2831 newSVuv((UV)final), 0);
2834 o->op_private |= OPpTRANS_GROWS;
2846 tbl = (short*)cPVOPo->op_pv;
2848 Zero(tbl, 256, short);
2849 for (i = 0; i < tlen; i++)
2851 for (i = 0, j = 0; i < 256; i++) {
2862 if (i < 128 && r[j] >= 128)
2870 if (!rlen && !del) {
2873 o->op_private |= OPpTRANS_IDENTICAL;
2875 for (i = 0; i < 256; i++)
2877 for (i = 0, j = 0; i < tlen; i++,j++) {
2880 if (tbl[t[i]] == -1)
2886 if (tbl[t[i]] == -1) {
2887 if (t[i] < 128 && r[j] >= 128)
2894 o->op_private |= OPpTRANS_GROWS;
2902 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2906 NewOp(1101, pmop, 1, PMOP);
2907 pmop->op_type = type;
2908 pmop->op_ppaddr = PL_ppaddr[type];
2909 pmop->op_flags = flags;
2910 pmop->op_private = 0 | (flags >> 8);
2912 if (PL_hints & HINT_RE_TAINT)
2913 pmop->op_pmpermflags |= PMf_RETAINT;
2914 if (PL_hints & HINT_LOCALE)
2915 pmop->op_pmpermflags |= PMf_LOCALE;
2916 pmop->op_pmflags = pmop->op_pmpermflags;
2918 /* link into pm list */
2919 if (type != OP_TRANS && PL_curstash) {
2920 pmop->op_pmnext = HvPMROOT(PL_curstash);
2921 HvPMROOT(PL_curstash) = pmop;
2928 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2932 I32 repl_has_vars = 0;
2934 if (o->op_type == OP_TRANS)
2935 return pmtrans(o, expr, repl);
2937 PL_hints |= HINT_BLOCK_SCOPE;
2940 if (expr->op_type == OP_CONST) {
2942 SV *pat = ((SVOP*)expr)->op_sv;
2943 char *p = SvPV(pat, plen);
2944 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2945 sv_setpvn(pat, "\\s+", 3);
2946 p = SvPV(pat, plen);
2947 pm->op_pmflags |= PMf_SKIPWHITE;
2949 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2950 pm->op_pmdynflags |= PMdf_UTF8;
2951 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2952 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2953 pm->op_pmflags |= PMf_WHITE;
2957 if (PL_hints & HINT_UTF8)
2958 pm->op_pmdynflags |= PMdf_UTF8;
2959 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2960 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2962 : OP_REGCMAYBE),0,expr);
2964 NewOp(1101, rcop, 1, LOGOP);
2965 rcop->op_type = OP_REGCOMP;
2966 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2967 rcop->op_first = scalar(expr);
2968 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2969 ? (OPf_SPECIAL | OPf_KIDS)
2971 rcop->op_private = 1;
2974 /* establish postfix order */
2975 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2977 rcop->op_next = expr;
2978 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2981 rcop->op_next = LINKLIST(expr);
2982 expr->op_next = (OP*)rcop;
2985 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2990 if (pm->op_pmflags & PMf_EVAL) {
2992 if (CopLINE(PL_curcop) < PL_multi_end)
2993 CopLINE_set(PL_curcop, PL_multi_end);
2996 else if (repl->op_type == OP_THREADSV
2997 && strchr("&`'123456789+",
2998 PL_threadsv_names[repl->op_targ]))
3002 #endif /* USE_THREADS */
3003 else if (repl->op_type == OP_CONST)
3007 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3008 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3010 if (curop->op_type == OP_THREADSV) {
3012 if (strchr("&`'123456789+", curop->op_private))
3016 if (curop->op_type == OP_GV) {
3017 GV *gv = cGVOPx_gv(curop);
3019 if (strchr("&`'123456789+", *GvENAME(gv)))
3022 #endif /* USE_THREADS */
3023 else if (curop->op_type == OP_RV2CV)
3025 else if (curop->op_type == OP_RV2SV ||
3026 curop->op_type == OP_RV2AV ||
3027 curop->op_type == OP_RV2HV ||
3028 curop->op_type == OP_RV2GV) {
3029 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3032 else if (curop->op_type == OP_PADSV ||
3033 curop->op_type == OP_PADAV ||
3034 curop->op_type == OP_PADHV ||
3035 curop->op_type == OP_PADANY) {
3038 else if (curop->op_type == OP_PUSHRE)
3039 ; /* Okay here, dangerous in newASSIGNOP */
3048 && (!pm->op_pmregexp
3049 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3050 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3051 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3052 prepend_elem(o->op_type, scalar(repl), o);
3055 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3056 pm->op_pmflags |= PMf_MAYBE_CONST;
3057 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3059 NewOp(1101, rcop, 1, LOGOP);
3060 rcop->op_type = OP_SUBSTCONT;
3061 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3062 rcop->op_first = scalar(repl);
3063 rcop->op_flags |= OPf_KIDS;
3064 rcop->op_private = 1;
3067 /* establish postfix order */
3068 rcop->op_next = LINKLIST(repl);
3069 repl->op_next = (OP*)rcop;
3071 pm->op_pmreplroot = scalar((OP*)rcop);
3072 pm->op_pmreplstart = LINKLIST(rcop);
3081 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3084 NewOp(1101, svop, 1, SVOP);
3085 svop->op_type = type;
3086 svop->op_ppaddr = PL_ppaddr[type];
3088 svop->op_next = (OP*)svop;
3089 svop->op_flags = flags;
3090 if (PL_opargs[type] & OA_RETSCALAR)
3092 if (PL_opargs[type] & OA_TARGET)
3093 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3094 return CHECKOP(type, svop);
3098 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3101 NewOp(1101, padop, 1, PADOP);
3102 padop->op_type = type;
3103 padop->op_ppaddr = PL_ppaddr[type];
3104 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3105 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3106 PL_curpad[padop->op_padix] = sv;
3108 padop->op_next = (OP*)padop;
3109 padop->op_flags = flags;
3110 if (PL_opargs[type] & OA_RETSCALAR)
3112 if (PL_opargs[type] & OA_TARGET)
3113 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3114 return CHECKOP(type, padop);
3118 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3122 return newPADOP(type, flags, SvREFCNT_inc(gv));
3124 return newSVOP(type, flags, SvREFCNT_inc(gv));
3129 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3132 NewOp(1101, pvop, 1, PVOP);
3133 pvop->op_type = type;
3134 pvop->op_ppaddr = PL_ppaddr[type];
3136 pvop->op_next = (OP*)pvop;
3137 pvop->op_flags = flags;
3138 if (PL_opargs[type] & OA_RETSCALAR)
3140 if (PL_opargs[type] & OA_TARGET)
3141 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3142 return CHECKOP(type, pvop);
3146 Perl_package(pTHX_ OP *o)
3150 save_hptr(&PL_curstash);
3151 save_item(PL_curstname);
3156 name = SvPV(sv, len);
3157 PL_curstash = gv_stashpvn(name,len,TRUE);
3158 sv_setpvn(PL_curstname, name, len);
3162 sv_setpv(PL_curstname,"<none>");
3163 PL_curstash = Nullhv;
3165 PL_hints |= HINT_BLOCK_SCOPE;
3166 PL_copline = NOLINE;
3171 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3179 if (id->op_type != OP_CONST)
3180 Perl_croak(aTHX_ "Module name must be constant");
3184 if (version != Nullop) {
3185 SV *vesv = ((SVOP*)version)->op_sv;
3187 if (arg == Nullop && !SvNIOKp(vesv)) {
3194 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3195 Perl_croak(aTHX_ "Version number must be constant number");
3197 /* Make copy of id so we don't free it twice */
3198 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3200 /* Fake up a method call to VERSION */
3201 meth = newSVpvn("VERSION",7);
3202 sv_upgrade(meth, SVt_PVIV);
3203 (void)SvIOK_on(meth);
3204 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3205 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3206 append_elem(OP_LIST,
3207 prepend_elem(OP_LIST, pack, list(version)),
3208 newSVOP(OP_METHOD_NAMED, 0, meth)));
3212 /* Fake up an import/unimport */
3213 if (arg && arg->op_type == OP_STUB)
3214 imop = arg; /* no import on explicit () */
3215 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3216 imop = Nullop; /* use 5.0; */
3221 /* Make copy of id so we don't free it twice */
3222 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3224 /* Fake up a method call to import/unimport */
3225 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3226 sv_upgrade(meth, SVt_PVIV);
3227 (void)SvIOK_on(meth);
3228 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3229 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3230 append_elem(OP_LIST,
3231 prepend_elem(OP_LIST, pack, list(arg)),
3232 newSVOP(OP_METHOD_NAMED, 0, meth)));
3235 /* Fake up a require, handle override, if any */
3236 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3237 if (!(gv && GvIMPORTED_CV(gv)))
3238 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3240 if (gv && GvIMPORTED_CV(gv)) {
3241 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3242 append_elem(OP_LIST, id,
3243 scalar(newUNOP(OP_RV2CV, 0,
3248 rqop = newUNOP(OP_REQUIRE, 0, id);
3251 /* Fake up the BEGIN {}, which does its thing immediately. */
3253 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3256 append_elem(OP_LINESEQ,
3257 append_elem(OP_LINESEQ,
3258 newSTATEOP(0, Nullch, rqop),
3259 newSTATEOP(0, Nullch, veop)),
3260 newSTATEOP(0, Nullch, imop) ));
3262 PL_hints |= HINT_BLOCK_SCOPE;
3263 PL_copline = NOLINE;
3268 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3271 va_start(args, ver);
3272 vload_module(flags, name, ver, &args);
3276 #ifdef PERL_IMPLICIT_CONTEXT
3278 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3282 va_start(args, ver);
3283 vload_module(flags, name, ver, &args);
3289 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3291 OP *modname, *veop, *imop;
3293 modname = newSVOP(OP_CONST, 0, name);
3294 modname->op_private |= OPpCONST_BARE;
3296 veop = newSVOP(OP_CONST, 0, ver);
3300 if (flags & PERL_LOADMOD_NOIMPORT) {
3301 imop = sawparens(newNULLLIST());
3303 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3304 imop = va_arg(*args, OP*);
3309 sv = va_arg(*args, SV*);
3311 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3312 sv = va_arg(*args, SV*);
3316 line_t ocopline = PL_copline;
3317 int oexpect = PL_expect;
3319 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3320 veop, modname, imop);
3321 PL_expect = oexpect;
3322 PL_copline = ocopline;
3327 Perl_dofile(pTHX_ OP *term)
3332 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3333 if (!(gv && GvIMPORTED_CV(gv)))
3334 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3336 if (gv && GvIMPORTED_CV(gv)) {
3337 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3338 append_elem(OP_LIST, term,
3339 scalar(newUNOP(OP_RV2CV, 0,
3344 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3350 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3352 return newBINOP(OP_LSLICE, flags,
3353 list(force_list(subscript)),
3354 list(force_list(listval)) );
3358 S_list_assignment(pTHX_ register OP *o)
3363 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3364 o = cUNOPo->op_first;
3366 if (o->op_type == OP_COND_EXPR) {
3367 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3368 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3373 yyerror("Assignment to both a list and a scalar");
3377 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3378 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3379 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3382 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3385 if (o->op_type == OP_RV2SV)
3392 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3397 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3398 return newLOGOP(optype, 0,
3399 mod(scalar(left), optype),
3400 newUNOP(OP_SASSIGN, 0, scalar(right)));
3403 return newBINOP(optype, OPf_STACKED,
3404 mod(scalar(left), optype), scalar(right));
3408 if (list_assignment(left)) {
3412 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3413 left = mod(left, OP_AASSIGN);
3421 curop = list(force_list(left));
3422 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3423 o->op_private = 0 | (flags >> 8);
3424 for (curop = ((LISTOP*)curop)->op_first;
3425 curop; curop = curop->op_sibling)
3427 if (curop->op_type == OP_RV2HV &&
3428 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3429 o->op_private |= OPpASSIGN_HASH;
3433 if (!(left->op_private & OPpLVAL_INTRO)) {
3436 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3437 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3438 if (curop->op_type == OP_GV) {
3439 GV *gv = cGVOPx_gv(curop);
3440 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3442 SvCUR(gv) = PL_generation;
3444 else if (curop->op_type == OP_PADSV ||
3445 curop->op_type == OP_PADAV ||
3446 curop->op_type == OP_PADHV ||
3447 curop->op_type == OP_PADANY) {
3448 SV **svp = AvARRAY(PL_comppad_name);
3449 SV *sv = svp[curop->op_targ];
3450 if (SvCUR(sv) == PL_generation)
3452 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3454 else if (curop->op_type == OP_RV2CV)
3456 else if (curop->op_type == OP_RV2SV ||
3457 curop->op_type == OP_RV2AV ||
3458 curop->op_type == OP_RV2HV ||
3459 curop->op_type == OP_RV2GV) {
3460 if (lastop->op_type != OP_GV) /* funny deref? */
3463 else if (curop->op_type == OP_PUSHRE) {
3464 if (((PMOP*)curop)->op_pmreplroot) {
3466 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3468 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3470 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3472 SvCUR(gv) = PL_generation;
3481 o->op_private |= OPpASSIGN_COMMON;
3483 if (right && right->op_type == OP_SPLIT) {
3485 if ((tmpop = ((LISTOP*)right)->op_first) &&
3486 tmpop->op_type == OP_PUSHRE)
3488 PMOP *pm = (PMOP*)tmpop;
3489 if (left->op_type == OP_RV2AV &&
3490 !(left->op_private & OPpLVAL_INTRO) &&
3491 !(o->op_private & OPpASSIGN_COMMON) )
3493 tmpop = ((UNOP*)left)->op_first;
3494 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3496 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3497 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3499 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3500 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3502 pm->op_pmflags |= PMf_ONCE;
3503 tmpop = cUNOPo->op_first; /* to list (nulled) */
3504 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3505 tmpop->op_sibling = Nullop; /* don't free split */
3506 right->op_next = tmpop->op_next; /* fix starting loc */
3507 op_free(o); /* blow off assign */
3508 right->op_flags &= ~OPf_WANT;
3509 /* "I don't know and I don't care." */
3514 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3515 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3517 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3519 sv_setiv(sv, PL_modcount+1);
3527 right = newOP(OP_UNDEF, 0);
3528 if (right->op_type == OP_READLINE) {
3529 right->op_flags |= OPf_STACKED;
3530 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3533 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3534 o = newBINOP(OP_SASSIGN, flags,
3535 scalar(right), mod(scalar(left), OP_SASSIGN) );
3547 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3549 U32 seq = intro_my();
3552 NewOp(1101, cop, 1, COP);
3553 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3554 cop->op_type = OP_DBSTATE;
3555 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3558 cop->op_type = OP_NEXTSTATE;
3559 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3561 cop->op_flags = flags;
3562 cop->op_private = (PL_hints & HINT_BYTE);
3564 cop->op_private |= NATIVE_HINTS;
3566 PL_compiling.op_private = cop->op_private;
3567 cop->op_next = (OP*)cop;
3570 cop->cop_label = label;
3571 PL_hints |= HINT_BLOCK_SCOPE;
3574 cop->cop_arybase = PL_curcop->cop_arybase;
3575 if (specialWARN(PL_curcop->cop_warnings))
3576 cop->cop_warnings = PL_curcop->cop_warnings ;
3578 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3579 if (specialCopIO(PL_curcop->cop_io))
3580 cop->cop_io = PL_curcop->cop_io;
3582 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3585 if (PL_copline == NOLINE)
3586 CopLINE_set(cop, CopLINE(PL_curcop));
3588 CopLINE_set(cop, PL_copline);
3589 PL_copline = NOLINE;
3592 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3594 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3596 CopSTASH_set(cop, PL_curstash);
3598 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3599 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3600 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3601 (void)SvIOK_on(*svp);
3602 SvIVX(*svp) = PTR2IV(cop);
3606 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3609 /* "Introduce" my variables to visible status. */
3617 if (! PL_min_intro_pending)
3618 return PL_cop_seqmax;
3620 svp = AvARRAY(PL_comppad_name);
3621 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3622 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3623 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3624 SvNVX(sv) = (NV)PL_cop_seqmax;
3627 PL_min_intro_pending = 0;
3628 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3629 return PL_cop_seqmax++;
3633 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3635 return new_logop(type, flags, &first, &other);
3639 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3643 OP *first = *firstp;
3644 OP *other = *otherp;
3646 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3647 return newBINOP(type, flags, scalar(first), scalar(other));
3649 scalarboolean(first);
3650 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3651 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3652 if (type == OP_AND || type == OP_OR) {
3658 first = *firstp = cUNOPo->op_first;
3660 first->op_next = o->op_next;
3661 cUNOPo->op_first = Nullop;
3665 if (first->op_type == OP_CONST) {
3666 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3667 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3668 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3679 else if (first->op_type == OP_WANTARRAY) {
3685 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3686 OP *k1 = ((UNOP*)first)->op_first;
3687 OP *k2 = k1->op_sibling;
3689 switch (first->op_type)
3692 if (k2 && k2->op_type == OP_READLINE
3693 && (k2->op_flags & OPf_STACKED)
3694 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3696 warnop = k2->op_type;
3701 if (k1->op_type == OP_READDIR
3702 || k1->op_type == OP_GLOB
3703 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3704 || k1->op_type == OP_EACH)
3706 warnop = ((k1->op_type == OP_NULL)
3707 ? k1->op_targ : k1->op_type);
3712 line_t oldline = CopLINE(PL_curcop);
3713 CopLINE_set(PL_curcop, PL_copline);
3714 Perl_warner(aTHX_ WARN_MISC,
3715 "Value of %s%s can be \"0\"; test with defined()",
3717 ((warnop == OP_READLINE || warnop == OP_GLOB)
3718 ? " construct" : "() operator"));
3719 CopLINE_set(PL_curcop, oldline);
3726 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3727 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3729 NewOp(1101, logop, 1, LOGOP);
3731 logop->op_type = type;
3732 logop->op_ppaddr = PL_ppaddr[type];
3733 logop->op_first = first;
3734 logop->op_flags = flags | OPf_KIDS;
3735 logop->op_other = LINKLIST(other);
3736 logop->op_private = 1 | (flags >> 8);
3738 /* establish postfix order */
3739 logop->op_next = LINKLIST(first);
3740 first->op_next = (OP*)logop;
3741 first->op_sibling = other;
3743 o = newUNOP(OP_NULL, 0, (OP*)logop);
3750 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3757 return newLOGOP(OP_AND, 0, first, trueop);
3759 return newLOGOP(OP_OR, 0, first, falseop);
3761 scalarboolean(first);
3762 if (first->op_type == OP_CONST) {
3763 if (SvTRUE(((SVOP*)first)->op_sv)) {
3774 else if (first->op_type == OP_WANTARRAY) {
3778 NewOp(1101, logop, 1, LOGOP);
3779 logop->op_type = OP_COND_EXPR;
3780 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3781 logop->op_first = first;
3782 logop->op_flags = flags | OPf_KIDS;
3783 logop->op_private = 1 | (flags >> 8);
3784 logop->op_other = LINKLIST(trueop);
3785 logop->op_next = LINKLIST(falseop);
3788 /* establish postfix order */
3789 start = LINKLIST(first);
3790 first->op_next = (OP*)logop;
3792 first->op_sibling = trueop;
3793 trueop->op_sibling = falseop;
3794 o = newUNOP(OP_NULL, 0, (OP*)logop);
3796 trueop->op_next = falseop->op_next = o;
3803 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3811 NewOp(1101, range, 1, LOGOP);
3813 range->op_type = OP_RANGE;
3814 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3815 range->op_first = left;
3816 range->op_flags = OPf_KIDS;
3817 leftstart = LINKLIST(left);
3818 range->op_other = LINKLIST(right);
3819 range->op_private = 1 | (flags >> 8);
3821 left->op_sibling = right;
3823 range->op_next = (OP*)range;
3824 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3825 flop = newUNOP(OP_FLOP, 0, flip);
3826 o = newUNOP(OP_NULL, 0, flop);
3828 range->op_next = leftstart;
3830 left->op_next = flip;
3831 right->op_next = flop;
3833 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3834 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3835 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3836 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3838 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3839 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3842 if (!flip->op_private || !flop->op_private)
3843 linklist(o); /* blow off optimizer unless constant */
3849 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3853 int once = block && block->op_flags & OPf_SPECIAL &&
3854 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3857 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3858 return block; /* do {} while 0 does once */
3859 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3860 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3861 expr = newUNOP(OP_DEFINED, 0,
3862 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3863 } else if (expr->op_flags & OPf_KIDS) {
3864 OP *k1 = ((UNOP*)expr)->op_first;
3865 OP *k2 = (k1) ? k1->op_sibling : NULL;
3866 switch (expr->op_type) {
3868 if (k2 && k2->op_type == OP_READLINE
3869 && (k2->op_flags & OPf_STACKED)
3870 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3871 expr = newUNOP(OP_DEFINED, 0, expr);
3875 if (k1->op_type == OP_READDIR
3876 || k1->op_type == OP_GLOB
3877 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3878 || k1->op_type == OP_EACH)
3879 expr = newUNOP(OP_DEFINED, 0, expr);
3885 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3886 o = new_logop(OP_AND, 0, &expr, &listop);
3889 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3891 if (once && o != listop)
3892 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3895 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3897 o->op_flags |= flags;
3899 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3904 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3913 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3914 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3915 expr = newUNOP(OP_DEFINED, 0,
3916 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3917 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3918 OP *k1 = ((UNOP*)expr)->op_first;
3919 OP *k2 = (k1) ? k1->op_sibling : NULL;
3920 switch (expr->op_type) {
3922 if (k2 && k2->op_type == OP_READLINE
3923 && (k2->op_flags & OPf_STACKED)
3924 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3925 expr = newUNOP(OP_DEFINED, 0, expr);
3929 if (k1->op_type == OP_READDIR
3930 || k1->op_type == OP_GLOB
3931 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3932 || k1->op_type == OP_EACH)
3933 expr = newUNOP(OP_DEFINED, 0, expr);
3939 block = newOP(OP_NULL, 0);
3941 block = scope(block);
3945 next = LINKLIST(cont);
3948 OP *unstack = newOP(OP_UNSTACK, 0);
3951 cont = append_elem(OP_LINESEQ, cont, unstack);
3952 if ((line_t)whileline != NOLINE) {
3953 PL_copline = whileline;
3954 cont = append_elem(OP_LINESEQ, cont,
3955 newSTATEOP(0, Nullch, Nullop));
3959 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3960 redo = LINKLIST(listop);
3963 PL_copline = whileline;
3965 o = new_logop(OP_AND, 0, &expr, &listop);
3966 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3967 op_free(expr); /* oops, it's a while (0) */
3969 return Nullop; /* listop already freed by new_logop */
3972 ((LISTOP*)listop)->op_last->op_next = condop =
3973 (o == listop ? redo : LINKLIST(o));
3979 NewOp(1101,loop,1,LOOP);
3980 loop->op_type = OP_ENTERLOOP;
3981 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3982 loop->op_private = 0;
3983 loop->op_next = (OP*)loop;
3986 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3988 loop->op_redoop = redo;
3989 loop->op_lastop = o;
3990 o->op_private |= loopflags;
3993 loop->op_nextop = next;
3995 loop->op_nextop = o;
3997 o->op_flags |= flags;
3998 o->op_private |= (flags >> 8);
4003 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4011 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4012 sv->op_type = OP_RV2GV;
4013 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4015 else if (sv->op_type == OP_PADSV) { /* private variable */
4016 padoff = sv->op_targ;
4021 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4022 padoff = sv->op_targ;
4024 iterflags |= OPf_SPECIAL;
4029 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4033 padoff = find_threadsv("_");
4034 iterflags |= OPf_SPECIAL;
4036 sv = newGVOP(OP_GV, 0, PL_defgv);
4039 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4040 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4041 iterflags |= OPf_STACKED;
4043 else if (expr->op_type == OP_NULL &&
4044 (expr->op_flags & OPf_KIDS) &&
4045 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4047 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4048 * set the STACKED flag to indicate that these values are to be
4049 * treated as min/max values by 'pp_iterinit'.
4051 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4052 LOGOP* range = (LOGOP*) flip->op_first;
4053 OP* left = range->op_first;
4054 OP* right = left->op_sibling;
4057 range->op_flags &= ~OPf_KIDS;
4058 range->op_first = Nullop;
4060 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4061 listop->op_first->op_next = range->op_next;
4062 left->op_next = range->op_other;
4063 right->op_next = (OP*)listop;
4064 listop->op_next = listop->op_first;
4067 expr = (OP*)(listop);
4069 iterflags |= OPf_STACKED;
4072 expr = mod(force_list(expr), OP_GREPSTART);
4076 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4077 append_elem(OP_LIST, expr, scalar(sv))));
4078 assert(!loop->op_next);
4079 #ifdef PL_OP_SLAB_ALLOC
4082 NewOp(1234,tmp,1,LOOP);
4083 Copy(loop,tmp,1,LOOP);
4087 Renew(loop, 1, LOOP);
4089 loop->op_targ = padoff;
4090 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4091 PL_copline = forline;
4092 return newSTATEOP(0, label, wop);
4096 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4101 if (type != OP_GOTO || label->op_type == OP_CONST) {
4102 /* "last()" means "last" */
4103 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4104 o = newOP(type, OPf_SPECIAL);
4106 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4107 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4113 if (label->op_type == OP_ENTERSUB)
4114 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4115 o = newUNOP(type, OPf_STACKED, label);
4117 PL_hints |= HINT_BLOCK_SCOPE;
4122 Perl_cv_undef(pTHX_ CV *cv)
4126 MUTEX_DESTROY(CvMUTEXP(cv));
4127 Safefree(CvMUTEXP(cv));
4130 #endif /* USE_THREADS */
4132 if (!CvXSUB(cv) && CvROOT(cv)) {
4134 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4135 Perl_croak(aTHX_ "Can't undef active subroutine");
4138 Perl_croak(aTHX_ "Can't undef active subroutine");
4139 #endif /* USE_THREADS */
4142 SAVEVPTR(PL_curpad);
4146 op_free(CvROOT(cv));
4147 CvROOT(cv) = Nullop;
4150 SvPOK_off((SV*)cv); /* forget prototype */
4152 SvREFCNT_dec(CvGV(cv));
4154 SvREFCNT_dec(CvOUTSIDE(cv));
4155 CvOUTSIDE(cv) = Nullcv;
4157 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4160 if (CvPADLIST(cv)) {
4161 /* may be during global destruction */
4162 if (SvREFCNT(CvPADLIST(cv))) {
4163 I32 i = AvFILLp(CvPADLIST(cv));
4165 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4166 SV* sv = svp ? *svp : Nullsv;
4169 if (sv == (SV*)PL_comppad_name)
4170 PL_comppad_name = Nullav;
4171 else if (sv == (SV*)PL_comppad) {
4172 PL_comppad = Nullav;
4173 PL_curpad = Null(SV**);
4177 SvREFCNT_dec((SV*)CvPADLIST(cv));
4179 CvPADLIST(cv) = Nullav;
4184 S_cv_dump(pTHX_ CV *cv)
4187 CV *outside = CvOUTSIDE(cv);
4188 AV* padlist = CvPADLIST(cv);
4195 PerlIO_printf(Perl_debug_log,
4196 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4198 (CvANON(cv) ? "ANON"
4199 : (cv == PL_main_cv) ? "MAIN"
4200 : CvUNIQUE(cv) ? "UNIQUE"
4201 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4204 : CvANON(outside) ? "ANON"
4205 : (outside == PL_main_cv) ? "MAIN"
4206 : CvUNIQUE(outside) ? "UNIQUE"
4207 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4212 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4213 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4214 pname = AvARRAY(pad_name);
4215 ppad = AvARRAY(pad);
4217 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4218 if (SvPOK(pname[ix]))
4219 PerlIO_printf(Perl_debug_log,
4220 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4221 (int)ix, PTR2UV(ppad[ix]),
4222 SvFAKE(pname[ix]) ? "FAKE " : "",
4224 (IV)I_32(SvNVX(pname[ix])),
4227 #endif /* DEBUGGING */
4231 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4235 AV* protopadlist = CvPADLIST(proto);
4236 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4237 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4238 SV** pname = AvARRAY(protopad_name);
4239 SV** ppad = AvARRAY(protopad);
4240 I32 fname = AvFILLp(protopad_name);
4241 I32 fpad = AvFILLp(protopad);
4245 assert(!CvUNIQUE(proto));
4249 SAVESPTR(PL_comppad_name);
4250 SAVESPTR(PL_compcv);
4252 cv = PL_compcv = (CV*)NEWSV(1104,0);
4253 sv_upgrade((SV *)cv, SvTYPE(proto));
4254 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4258 New(666, CvMUTEXP(cv), 1, perl_mutex);
4259 MUTEX_INIT(CvMUTEXP(cv));
4261 #endif /* USE_THREADS */
4262 CvFILE(cv) = CvFILE(proto);
4263 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4264 CvSTASH(cv) = CvSTASH(proto);
4265 CvROOT(cv) = CvROOT(proto);
4266 CvSTART(cv) = CvSTART(proto);
4268 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4271 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4273 PL_comppad_name = newAV();
4274 for (ix = fname; ix >= 0; ix--)
4275 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4277 PL_comppad = newAV();
4279 comppadlist = newAV();
4280 AvREAL_off(comppadlist);
4281 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4282 av_store(comppadlist, 1, (SV*)PL_comppad);
4283 CvPADLIST(cv) = comppadlist;
4284 av_fill(PL_comppad, AvFILLp(protopad));
4285 PL_curpad = AvARRAY(PL_comppad);
4287 av = newAV(); /* will be @_ */
4289 av_store(PL_comppad, 0, (SV*)av);
4290 AvFLAGS(av) = AVf_REIFY;
4292 for (ix = fpad; ix > 0; ix--) {
4293 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4294 if (namesv && namesv != &PL_sv_undef) {
4295 char *name = SvPVX(namesv); /* XXX */
4296 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4297 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4298 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4300 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4302 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4304 else { /* our own lexical */
4307 /* anon code -- we'll come back for it */
4308 sv = SvREFCNT_inc(ppad[ix]);
4310 else if (*name == '@')
4312 else if (*name == '%')
4321 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4322 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4325 SV* sv = NEWSV(0,0);
4331 /* Now that vars are all in place, clone nested closures. */
4333 for (ix = fpad; ix > 0; ix--) {
4334 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4336 && namesv != &PL_sv_undef
4337 && !(SvFLAGS(namesv) & SVf_FAKE)
4338 && *SvPVX(namesv) == '&'
4339 && CvCLONE(ppad[ix]))
4341 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4342 SvREFCNT_dec(ppad[ix]);
4345 PL_curpad[ix] = (SV*)kid;
4349 #ifdef DEBUG_CLOSURES
4350 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4352 PerlIO_printf(Perl_debug_log, " from:\n");
4354 PerlIO_printf(Perl_debug_log, " to:\n");
4361 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4363 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4365 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4372 Perl_cv_clone(pTHX_ CV *proto)
4375 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4376 cv = cv_clone2(proto, CvOUTSIDE(proto));
4377 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4382 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4384 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4385 SV* msg = sv_newmortal();
4389 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4390 sv_setpv(msg, "Prototype mismatch:");
4392 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4394 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4395 sv_catpv(msg, " vs ");
4397 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4399 sv_catpv(msg, "none");
4400 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4404 static void const_sv_xsub(pTHXo_ CV* cv);
4407 =for apidoc cv_const_sv
4409 If C<cv> is a constant sub eligible for inlining. returns the constant
4410 value returned by the sub. Otherwise, returns NULL.
4412 Constant subs can be created with C<newCONSTSUB> or as described in
4413 L<perlsub/"Constant Functions">.
4418 Perl_cv_const_sv(pTHX_ CV *cv)
4420 if (!cv || !CvCONST(cv))
4422 return (SV*)CvXSUBANY(cv).any_ptr;
4426 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4433 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4434 o = cLISTOPo->op_first->op_sibling;
4436 for (; o; o = o->op_next) {
4437 OPCODE type = o->op_type;
4439 if (sv && o->op_next == o)
4441 if (o->op_next != o) {
4442 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4444 if (type == OP_DBSTATE)
4447 if (type == OP_LEAVESUB || type == OP_RETURN)
4451 if (type == OP_CONST && cSVOPo->op_sv)
4453 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4454 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4455 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4459 /* We get here only from cv_clone2() while creating a closure.
4460 Copy the const value here instead of in cv_clone2 so that
4461 SvREADONLY_on doesn't lead to problems when leaving
4466 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4478 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4488 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4492 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4494 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4498 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4504 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4509 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4510 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4511 SV *sv = sv_newmortal();
4512 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4513 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4518 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4519 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4529 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4530 maximum a prototype before. */
4531 if (SvTYPE(gv) > SVt_NULL) {
4532 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4533 && ckWARN_d(WARN_PROTOTYPE))
4535 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4537 cv_ckproto((CV*)gv, NULL, ps);
4540 sv_setpv((SV*)gv, ps);
4542 sv_setiv((SV*)gv, -1);
4543 SvREFCNT_dec(PL_compcv);
4544 cv = PL_compcv = NULL;
4545 PL_sub_generation++;
4549 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4551 #ifdef GV_SHARED_CHECK
4552 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4553 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4557 if (!block || !ps || *ps || attrs)
4560 const_sv = op_const_sv(block, Nullcv);
4563 bool exists = CvROOT(cv) || CvXSUB(cv);
4565 #ifdef GV_SHARED_CHECK
4566 if (exists && GvSHARED(gv)) {
4567 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4571 /* if the subroutine doesn't exist and wasn't pre-declared
4572 * with a prototype, assume it will be AUTOLOADed,
4573 * skipping the prototype check
4575 if (exists || SvPOK(cv))
4576 cv_ckproto(cv, gv, ps);
4577 /* already defined (or promised)? */
4578 if (exists || GvASSUMECV(gv)) {
4579 if (!block && !attrs) {
4580 /* just a "sub foo;" when &foo is already defined */
4581 SAVEFREESV(PL_compcv);
4584 /* ahem, death to those who redefine active sort subs */
4585 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4586 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4588 if (ckWARN(WARN_REDEFINE)
4590 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4592 line_t oldline = CopLINE(PL_curcop);
4593 CopLINE_set(PL_curcop, PL_copline);
4594 Perl_warner(aTHX_ WARN_REDEFINE,
4595 CvCONST(cv) ? "Constant subroutine %s redefined"
4596 : "Subroutine %s redefined", name);
4597 CopLINE_set(PL_curcop, oldline);
4605 SvREFCNT_inc(const_sv);
4607 assert(!CvROOT(cv) && !CvCONST(cv));
4608 sv_setpv((SV*)cv, ""); /* prototype is "" */
4609 CvXSUBANY(cv).any_ptr = const_sv;
4610 CvXSUB(cv) = const_sv_xsub;
4615 cv = newCONSTSUB(NULL, name, const_sv);
4618 SvREFCNT_dec(PL_compcv);
4620 PL_sub_generation++;
4627 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4628 * before we clobber PL_compcv.
4632 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4633 stash = GvSTASH(CvGV(cv));
4634 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4635 stash = CvSTASH(cv);
4637 stash = PL_curstash;
4640 /* possibly about to re-define existing subr -- ignore old cv */
4641 rcv = (SV*)PL_compcv;
4642 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4643 stash = GvSTASH(gv);
4645 stash = PL_curstash;
4647 apply_attrs(stash, rcv, attrs);
4649 if (cv) { /* must reuse cv if autoloaded */
4651 /* got here with just attrs -- work done, so bug out */
4652 SAVEFREESV(PL_compcv);
4656 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4657 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4658 CvOUTSIDE(PL_compcv) = 0;
4659 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4660 CvPADLIST(PL_compcv) = 0;
4661 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4662 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4663 SvREFCNT_dec(PL_compcv);
4670 PL_sub_generation++;
4673 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4674 CvFILE(cv) = CopFILE(PL_curcop);
4675 CvSTASH(cv) = PL_curstash;
4678 if (!CvMUTEXP(cv)) {
4679 New(666, CvMUTEXP(cv), 1, perl_mutex);
4680 MUTEX_INIT(CvMUTEXP(cv));
4682 #endif /* USE_THREADS */
4685 sv_setpv((SV*)cv, ps);
4687 if (PL_error_count) {
4691 char *s = strrchr(name, ':');
4693 if (strEQ(s, "BEGIN")) {
4695 "BEGIN not safe after errors--compilation aborted";
4696 if (PL_in_eval & EVAL_KEEPERR)
4697 Perl_croak(aTHX_ not_safe);
4699 /* force display of errors found but not reported */
4700 sv_catpv(ERRSV, not_safe);
4701 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4709 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4710 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4713 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4714 mod(scalarseq(block), OP_LEAVESUBLV));
4717 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4719 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4720 OpREFCNT_set(CvROOT(cv), 1);
4721 CvSTART(cv) = LINKLIST(CvROOT(cv));
4722 CvROOT(cv)->op_next = 0;
4725 /* now that optimizer has done its work, adjust pad values */
4727 SV **namep = AvARRAY(PL_comppad_name);
4728 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4731 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4734 * The only things that a clonable function needs in its
4735 * pad are references to outer lexicals and anonymous subs.
4736 * The rest are created anew during cloning.
4738 if (!((namesv = namep[ix]) != Nullsv &&
4739 namesv != &PL_sv_undef &&
4741 *SvPVX(namesv) == '&')))
4743 SvREFCNT_dec(PL_curpad[ix]);
4744 PL_curpad[ix] = Nullsv;
4747 assert(!CvCONST(cv));
4748 if (ps && !*ps && op_const_sv(block, cv))
4752 AV *av = newAV(); /* Will be @_ */
4754 av_store(PL_comppad, 0, (SV*)av);
4755 AvFLAGS(av) = AVf_REIFY;
4757 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4758 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4760 if (!SvPADMY(PL_curpad[ix]))
4761 SvPADTMP_on(PL_curpad[ix]);
4765 if (name || aname) {
4767 char *tname = (name ? name : aname);
4769 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4770 SV *sv = NEWSV(0,0);
4771 SV *tmpstr = sv_newmortal();
4772 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4776 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4778 (long)PL_subline, (long)CopLINE(PL_curcop));
4779 gv_efullname3(tmpstr, gv, Nullch);
4780 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4781 hv = GvHVn(db_postponed);
4782 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4783 && (pcv = GvCV(db_postponed)))
4789 call_sv((SV*)pcv, G_DISCARD);
4793 if ((s = strrchr(tname,':')))
4798 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4801 if (strEQ(s, "BEGIN")) {
4802 I32 oldscope = PL_scopestack_ix;
4804 SAVECOPFILE(&PL_compiling);
4805 SAVECOPLINE(&PL_compiling);
4807 sv_setsv(PL_rs, PL_nrs);
4810 PL_beginav = newAV();
4811 DEBUG_x( dump_sub(gv) );
4812 av_push(PL_beginav, (SV*)cv);
4813 GvCV(gv) = 0; /* cv has been hijacked */
4814 call_list(oldscope, PL_beginav);
4816 PL_curcop = &PL_compiling;
4817 PL_compiling.op_private = PL_hints;
4820 else if (strEQ(s, "END") && !PL_error_count) {
4823 DEBUG_x( dump_sub(gv) );
4824 av_unshift(PL_endav, 1);
4825 av_store(PL_endav, 0, (SV*)cv);
4826 GvCV(gv) = 0; /* cv has been hijacked */
4828 else if (strEQ(s, "CHECK") && !PL_error_count) {
4830 PL_checkav = newAV();
4831 DEBUG_x( dump_sub(gv) );
4832 if (PL_main_start && ckWARN(WARN_VOID))
4833 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4834 av_unshift(PL_checkav, 1);
4835 av_store(PL_checkav, 0, (SV*)cv);
4836 GvCV(gv) = 0; /* cv has been hijacked */
4838 else if (strEQ(s, "INIT") && !PL_error_count) {
4840 PL_initav = newAV();
4841 DEBUG_x( dump_sub(gv) );
4842 if (PL_main_start && ckWARN(WARN_VOID))
4843 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4844 av_push(PL_initav, (SV*)cv);
4845 GvCV(gv) = 0; /* cv has been hijacked */
4850 PL_copline = NOLINE;
4855 /* XXX unsafe for threads if eval_owner isn't held */
4857 =for apidoc newCONSTSUB
4859 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4860 eligible for inlining at compile-time.
4866 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4872 SAVECOPLINE(PL_curcop);
4873 CopLINE_set(PL_curcop, PL_copline);
4876 PL_hints &= ~HINT_BLOCK_SCOPE;
4879 SAVESPTR(PL_curstash);
4880 SAVECOPSTASH(PL_curcop);
4881 PL_curstash = stash;
4883 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4885 CopSTASH(PL_curcop) = stash;
4889 cv = newXS(name, const_sv_xsub, __FILE__);
4890 CvXSUBANY(cv).any_ptr = sv;
4892 sv_setpv((SV*)cv, ""); /* prototype is "" */
4900 =for apidoc U||newXS
4902 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4908 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4910 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4913 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4915 /* just a cached method */
4919 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4920 /* already defined (or promised) */
4921 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4922 && HvNAME(GvSTASH(CvGV(cv)))
4923 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4924 line_t oldline = CopLINE(PL_curcop);
4925 if (PL_copline != NOLINE)
4926 CopLINE_set(PL_curcop, PL_copline);
4927 Perl_warner(aTHX_ WARN_REDEFINE,
4928 CvCONST(cv) ? "Constant subroutine %s redefined"
4929 : "Subroutine %s redefined"
4931 CopLINE_set(PL_curcop, oldline);
4938 if (cv) /* must reuse cv if autoloaded */
4941 cv = (CV*)NEWSV(1105,0);
4942 sv_upgrade((SV *)cv, SVt_PVCV);
4946 PL_sub_generation++;
4949 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4951 New(666, CvMUTEXP(cv), 1, perl_mutex);
4952 MUTEX_INIT(CvMUTEXP(cv));
4954 #endif /* USE_THREADS */
4955 (void)gv_fetchfile(filename);
4956 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4957 an external constant string */
4958 CvXSUB(cv) = subaddr;
4961 char *s = strrchr(name,':');
4967 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4970 if (strEQ(s, "BEGIN")) {
4972 PL_beginav = newAV();
4973 av_push(PL_beginav, (SV*)cv);
4974 GvCV(gv) = 0; /* cv has been hijacked */
4976 else if (strEQ(s, "END")) {
4979 av_unshift(PL_endav, 1);
4980 av_store(PL_endav, 0, (SV*)cv);
4981 GvCV(gv) = 0; /* cv has been hijacked */
4983 else if (strEQ(s, "CHECK")) {
4985 PL_checkav = newAV();
4986 if (PL_main_start && ckWARN(WARN_VOID))
4987 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4988 av_unshift(PL_checkav, 1);
4989 av_store(PL_checkav, 0, (SV*)cv);
4990 GvCV(gv) = 0; /* cv has been hijacked */
4992 else if (strEQ(s, "INIT")) {
4994 PL_initav = newAV();
4995 if (PL_main_start && ckWARN(WARN_VOID))
4996 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4997 av_push(PL_initav, (SV*)cv);
4998 GvCV(gv) = 0; /* cv has been hijacked */
5009 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5018 name = SvPVx(cSVOPo->op_sv, n_a);
5021 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5022 #ifdef GV_SHARED_CHECK
5024 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5028 if ((cv = GvFORM(gv))) {
5029 if (ckWARN(WARN_REDEFINE)) {
5030 line_t oldline = CopLINE(PL_curcop);
5032 CopLINE_set(PL_curcop, PL_copline);
5033 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5034 CopLINE_set(PL_curcop, oldline);
5040 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
5041 CvFILE(cv) = CopFILE(PL_curcop);
5043 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5044 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5045 SvPADTMP_on(PL_curpad[ix]);
5048 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5049 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5050 OpREFCNT_set(CvROOT(cv), 1);
5051 CvSTART(cv) = LINKLIST(CvROOT(cv));
5052 CvROOT(cv)->op_next = 0;
5055 PL_copline = NOLINE;
5060 Perl_newANONLIST(pTHX_ OP *o)
5062 return newUNOP(OP_REFGEN, 0,
5063 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5067 Perl_newANONHASH(pTHX_ OP *o)
5069 return newUNOP(OP_REFGEN, 0,
5070 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5074 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5076 return newANONATTRSUB(floor, proto, Nullop, block);
5080 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5082 return newUNOP(OP_REFGEN, 0,
5083 newSVOP(OP_ANONCODE, 0,
5084 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5088 Perl_oopsAV(pTHX_ OP *o)
5090 switch (o->op_type) {
5092 o->op_type = OP_PADAV;
5093 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5094 return ref(o, OP_RV2AV);
5097 o->op_type = OP_RV2AV;
5098 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5103 if (ckWARN_d(WARN_INTERNAL))
5104 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5111 Perl_oopsHV(pTHX_ OP *o)
5113 switch (o->op_type) {
5116 o->op_type = OP_PADHV;
5117 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5118 return ref(o, OP_RV2HV);
5122 o->op_type = OP_RV2HV;
5123 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5128 if (ckWARN_d(WARN_INTERNAL))
5129 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5136 Perl_newAVREF(pTHX_ OP *o)
5138 if (o->op_type == OP_PADANY) {
5139 o->op_type = OP_PADAV;
5140 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5143 return newUNOP(OP_RV2AV, 0, scalar(o));
5147 Perl_newGVREF(pTHX_ I32 type, OP *o)
5149 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5150 return newUNOP(OP_NULL, 0, o);
5151 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5155 Perl_newHVREF(pTHX_ OP *o)
5157 if (o->op_type == OP_PADANY) {
5158 o->op_type = OP_PADHV;
5159 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5162 return newUNOP(OP_RV2HV, 0, scalar(o));
5166 Perl_oopsCV(pTHX_ OP *o)
5168 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5174 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5176 return newUNOP(OP_RV2CV, flags, scalar(o));
5180 Perl_newSVREF(pTHX_ OP *o)
5182 if (o->op_type == OP_PADANY) {
5183 o->op_type = OP_PADSV;
5184 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5187 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5188 o->op_flags |= OPpDONE_SVREF;
5191 return newUNOP(OP_RV2SV, 0, scalar(o));
5194 /* Check routines. */
5197 Perl_ck_anoncode(pTHX_ OP *o)
5202 name = NEWSV(1106,0);
5203 sv_upgrade(name, SVt_PVNV);
5204 sv_setpvn(name, "&", 1);
5207 ix = pad_alloc(o->op_type, SVs_PADMY);
5208 av_store(PL_comppad_name, ix, name);
5209 av_store(PL_comppad, ix, cSVOPo->op_sv);
5210 SvPADMY_on(cSVOPo->op_sv);
5211 cSVOPo->op_sv = Nullsv;
5212 cSVOPo->op_targ = ix;
5217 Perl_ck_bitop(pTHX_ OP *o)
5219 o->op_private = PL_hints;
5224 Perl_ck_concat(pTHX_ OP *o)
5226 if (cUNOPo->op_first->op_type == OP_CONCAT)
5227 o->op_flags |= OPf_STACKED;
5232 Perl_ck_spair(pTHX_ OP *o)
5234 if (o->op_flags & OPf_KIDS) {
5237 OPCODE type = o->op_type;
5238 o = modkids(ck_fun(o), type);
5239 kid = cUNOPo->op_first;
5240 newop = kUNOP->op_first->op_sibling;
5242 (newop->op_sibling ||
5243 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5244 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5245 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5249 op_free(kUNOP->op_first);
5250 kUNOP->op_first = newop;
5252 o->op_ppaddr = PL_ppaddr[++o->op_type];
5257 Perl_ck_delete(pTHX_ OP *o)
5261 if (o->op_flags & OPf_KIDS) {
5262 OP *kid = cUNOPo->op_first;
5263 switch (kid->op_type) {
5265 o->op_flags |= OPf_SPECIAL;
5268 o->op_private |= OPpSLICE;
5271 o->op_flags |= OPf_SPECIAL;
5276 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5277 PL_op_desc[o->op_type]);
5285 Perl_ck_eof(pTHX_ OP *o)
5287 I32 type = o->op_type;
5289 if (o->op_flags & OPf_KIDS) {
5290 if (cLISTOPo->op_first->op_type == OP_STUB) {
5292 o = newUNOP(type, OPf_SPECIAL,
5293 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5301 Perl_ck_eval(pTHX_ OP *o)
5303 PL_hints |= HINT_BLOCK_SCOPE;
5304 if (o->op_flags & OPf_KIDS) {
5305 SVOP *kid = (SVOP*)cUNOPo->op_first;
5308 o->op_flags &= ~OPf_KIDS;
5311 else if (kid->op_type == OP_LINESEQ) {
5314 kid->op_next = o->op_next;
5315 cUNOPo->op_first = 0;
5318 NewOp(1101, enter, 1, LOGOP);
5319 enter->op_type = OP_ENTERTRY;
5320 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5321 enter->op_private = 0;
5323 /* establish postfix order */
5324 enter->op_next = (OP*)enter;
5326 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5327 o->op_type = OP_LEAVETRY;
5328 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5329 enter->op_other = o;
5337 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5339 o->op_targ = (PADOFFSET)PL_hints;
5344 Perl_ck_exit(pTHX_ OP *o)
5347 HV *table = GvHV(PL_hintgv);
5349 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5350 if (svp && *svp && SvTRUE(*svp))
5351 o->op_private |= OPpEXIT_VMSISH;
5358 Perl_ck_exec(pTHX_ OP *o)
5361 if (o->op_flags & OPf_STACKED) {
5363 kid = cUNOPo->op_first->op_sibling;
5364 if (kid->op_type == OP_RV2GV)
5373 Perl_ck_exists(pTHX_ OP *o)
5376 if (o->op_flags & OPf_KIDS) {
5377 OP *kid = cUNOPo->op_first;
5378 if (kid->op_type == OP_ENTERSUB) {
5379 (void) ref(kid, o->op_type);
5380 if (kid->op_type != OP_RV2CV && !PL_error_count)
5381 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5382 PL_op_desc[o->op_type]);
5383 o->op_private |= OPpEXISTS_SUB;
5385 else if (kid->op_type == OP_AELEM)
5386 o->op_flags |= OPf_SPECIAL;
5387 else if (kid->op_type != OP_HELEM)
5388 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5389 PL_op_desc[o->op_type]);
5397 Perl_ck_gvconst(pTHX_ register OP *o)
5399 o = fold_constants(o);
5400 if (o->op_type == OP_CONST)
5407 Perl_ck_rvconst(pTHX_ register OP *o)
5409 SVOP *kid = (SVOP*)cUNOPo->op_first;
5411 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5412 if (kid->op_type == OP_CONST) {
5416 SV *kidsv = kid->op_sv;
5419 /* Is it a constant from cv_const_sv()? */
5420 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5421 SV *rsv = SvRV(kidsv);
5422 int svtype = SvTYPE(rsv);
5423 char *badtype = Nullch;
5425 switch (o->op_type) {
5427 if (svtype > SVt_PVMG)
5428 badtype = "a SCALAR";
5431 if (svtype != SVt_PVAV)
5432 badtype = "an ARRAY";
5435 if (svtype != SVt_PVHV) {
5436 if (svtype == SVt_PVAV) { /* pseudohash? */
5437 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5438 if (ksv && SvROK(*ksv)
5439 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5448 if (svtype != SVt_PVCV)
5453 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5456 name = SvPV(kidsv, n_a);
5457 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5458 char *badthing = Nullch;
5459 switch (o->op_type) {
5461 badthing = "a SCALAR";
5464 badthing = "an ARRAY";
5467 badthing = "a HASH";
5472 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5476 * This is a little tricky. We only want to add the symbol if we
5477 * didn't add it in the lexer. Otherwise we get duplicate strict
5478 * warnings. But if we didn't add it in the lexer, we must at
5479 * least pretend like we wanted to add it even if it existed before,
5480 * or we get possible typo warnings. OPpCONST_ENTERED says
5481 * whether the lexer already added THIS instance of this symbol.
5483 iscv = (o->op_type == OP_RV2CV) * 2;
5485 gv = gv_fetchpv(name,
5486 iscv | !(kid->op_private & OPpCONST_ENTERED),
5489 : o->op_type == OP_RV2SV
5491 : o->op_type == OP_RV2AV
5493 : o->op_type == OP_RV2HV
5496 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5498 kid->op_type = OP_GV;
5499 SvREFCNT_dec(kid->op_sv);
5501 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5502 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5503 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5505 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5507 kid->op_sv = SvREFCNT_inc(gv);
5509 kid->op_private = 0;
5510 kid->op_ppaddr = PL_ppaddr[OP_GV];
5517 Perl_ck_ftst(pTHX_ OP *o)
5519 I32 type = o->op_type;
5521 if (o->op_flags & OPf_REF) {
5524 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5525 SVOP *kid = (SVOP*)cUNOPo->op_first;
5527 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5529 OP *newop = newGVOP(type, OPf_REF,
5530 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5537 if (type == OP_FTTTY)
5538 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5541 o = newUNOP(type, 0, newDEFSVOP());
5544 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5546 if (PL_hints & HINT_LOCALE)
5547 o->op_private |= OPpLOCALE;
5554 Perl_ck_fun(pTHX_ OP *o)
5560 int type = o->op_type;
5561 register I32 oa = PL_opargs[type] >> OASHIFT;
5563 if (o->op_flags & OPf_STACKED) {
5564 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5567 return no_fh_allowed(o);
5570 if (o->op_flags & OPf_KIDS) {
5572 tokid = &cLISTOPo->op_first;
5573 kid = cLISTOPo->op_first;
5574 if (kid->op_type == OP_PUSHMARK ||
5575 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5577 tokid = &kid->op_sibling;
5578 kid = kid->op_sibling;
5580 if (!kid && PL_opargs[type] & OA_DEFGV)
5581 *tokid = kid = newDEFSVOP();
5585 sibl = kid->op_sibling;
5588 /* list seen where single (scalar) arg expected? */
5589 if (numargs == 1 && !(oa >> 4)
5590 && kid->op_type == OP_LIST && type != OP_SCALAR)
5592 return too_many_arguments(o,PL_op_desc[type]);
5605 if (kid->op_type == OP_CONST &&
5606 (kid->op_private & OPpCONST_BARE))
5608 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5609 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5610 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5611 if (ckWARN(WARN_DEPRECATED))
5612 Perl_warner(aTHX_ WARN_DEPRECATED,
5613 "Array @%s missing the @ in argument %"IVdf" of %s()",
5614 name, (IV)numargs, PL_op_desc[type]);
5617 kid->op_sibling = sibl;
5620 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5621 bad_type(numargs, "array", PL_op_desc[type], kid);
5625 if (kid->op_type == OP_CONST &&
5626 (kid->op_private & OPpCONST_BARE))
5628 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5629 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5630 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5631 if (ckWARN(WARN_DEPRECATED))
5632 Perl_warner(aTHX_ WARN_DEPRECATED,
5633 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5634 name, (IV)numargs, PL_op_desc[type]);
5637 kid->op_sibling = sibl;
5640 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5641 bad_type(numargs, "hash", PL_op_desc[type], kid);
5646 OP *newop = newUNOP(OP_NULL, 0, kid);
5647 kid->op_sibling = 0;
5649 newop->op_next = newop;
5651 kid->op_sibling = sibl;
5656 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5657 if (kid->op_type == OP_CONST &&
5658 (kid->op_private & OPpCONST_BARE))
5660 OP *newop = newGVOP(OP_GV, 0,
5661 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5666 else if (kid->op_type == OP_READLINE) {
5667 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5668 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5671 I32 flags = OPf_SPECIAL;
5675 /* is this op a FH constructor? */
5676 if (is_handle_constructor(o,numargs)) {
5677 char *name = Nullch;
5681 /* Set a flag to tell rv2gv to vivify
5682 * need to "prove" flag does not mean something
5683 * else already - NI-S 1999/05/07
5686 if (kid->op_type == OP_PADSV) {
5687 SV **namep = av_fetch(PL_comppad_name,
5689 if (namep && *namep)
5690 name = SvPV(*namep, len);
5692 else if (kid->op_type == OP_RV2SV
5693 && kUNOP->op_first->op_type == OP_GV)
5695 GV *gv = cGVOPx_gv(kUNOP->op_first);
5697 len = GvNAMELEN(gv);
5699 else if (kid->op_type == OP_AELEM
5700 || kid->op_type == OP_HELEM)
5702 name = "__ANONIO__";
5708 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5709 namesv = PL_curpad[targ];
5710 (void)SvUPGRADE(namesv, SVt_PV);
5712 sv_setpvn(namesv, "$", 1);
5713 sv_catpvn(namesv, name, len);
5716 kid->op_sibling = 0;
5717 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5718 kid->op_targ = targ;
5719 kid->op_private |= priv;
5721 kid->op_sibling = sibl;
5727 mod(scalar(kid), type);
5731 tokid = &kid->op_sibling;
5732 kid = kid->op_sibling;
5734 o->op_private |= numargs;
5736 return too_many_arguments(o,PL_op_desc[o->op_type]);
5739 else if (PL_opargs[type] & OA_DEFGV) {
5741 return newUNOP(type, 0, newDEFSVOP());
5745 while (oa & OA_OPTIONAL)
5747 if (oa && oa != OA_LIST)
5748 return too_few_arguments(o,PL_op_desc[o->op_type]);
5754 Perl_ck_glob(pTHX_ OP *o)
5759 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5760 append_elem(OP_GLOB, o, newDEFSVOP());
5762 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5763 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5765 #if !defined(PERL_EXTERNAL_GLOB)
5766 /* XXX this can be tightened up and made more failsafe. */
5769 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5770 /* null-terminated import list */
5771 newSVpvn(":globally", 9), Nullsv);
5772 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5775 #endif /* PERL_EXTERNAL_GLOB */
5777 if (gv && GvIMPORTED_CV(gv)) {
5778 append_elem(OP_GLOB, o,
5779 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5780 o->op_type = OP_LIST;
5781 o->op_ppaddr = PL_ppaddr[OP_LIST];
5782 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5783 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5784 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5785 append_elem(OP_LIST, o,
5786 scalar(newUNOP(OP_RV2CV, 0,
5787 newGVOP(OP_GV, 0, gv)))));
5788 o = newUNOP(OP_NULL, 0, ck_subr(o));
5789 o->op_targ = OP_GLOB; /* hint at what it used to be */
5792 gv = newGVgen("main");
5794 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5800 Perl_ck_grep(pTHX_ OP *o)
5804 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5806 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5807 NewOp(1101, gwop, 1, LOGOP);
5809 if (o->op_flags & OPf_STACKED) {
5812 kid = cLISTOPo->op_first->op_sibling;
5813 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5816 kid->op_next = (OP*)gwop;
5817 o->op_flags &= ~OPf_STACKED;
5819 kid = cLISTOPo->op_first->op_sibling;
5820 if (type == OP_MAPWHILE)
5827 kid = cLISTOPo->op_first->op_sibling;
5828 if (kid->op_type != OP_NULL)
5829 Perl_croak(aTHX_ "panic: ck_grep");
5830 kid = kUNOP->op_first;
5832 gwop->op_type = type;
5833 gwop->op_ppaddr = PL_ppaddr[type];
5834 gwop->op_first = listkids(o);
5835 gwop->op_flags |= OPf_KIDS;
5836 gwop->op_private = 1;
5837 gwop->op_other = LINKLIST(kid);
5838 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5839 kid->op_next = (OP*)gwop;
5841 kid = cLISTOPo->op_first->op_sibling;
5842 if (!kid || !kid->op_sibling)
5843 return too_few_arguments(o,PL_op_desc[o->op_type]);
5844 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5845 mod(kid, OP_GREPSTART);
5851 Perl_ck_index(pTHX_ OP *o)
5853 if (o->op_flags & OPf_KIDS) {
5854 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5856 kid = kid->op_sibling; /* get past "big" */
5857 if (kid && kid->op_type == OP_CONST)
5858 fbm_compile(((SVOP*)kid)->op_sv, 0);
5864 Perl_ck_lengthconst(pTHX_ OP *o)
5866 /* XXX length optimization goes here */
5871 Perl_ck_lfun(pTHX_ OP *o)
5873 OPCODE type = o->op_type;
5874 return modkids(ck_fun(o), type);
5878 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5880 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5881 switch (cUNOPo->op_first->op_type) {
5883 /* This is needed for
5884 if (defined %stash::)
5885 to work. Do not break Tk.
5887 break; /* Globals via GV can be undef */
5889 case OP_AASSIGN: /* Is this a good idea? */
5890 Perl_warner(aTHX_ WARN_DEPRECATED,
5891 "defined(@array) is deprecated");
5892 Perl_warner(aTHX_ WARN_DEPRECATED,
5893 "\t(Maybe you should just omit the defined()?)\n");
5896 /* This is needed for
5897 if (defined %stash::)
5898 to work. Do not break Tk.
5900 break; /* Globals via GV can be undef */
5902 Perl_warner(aTHX_ WARN_DEPRECATED,
5903 "defined(%%hash) is deprecated");
5904 Perl_warner(aTHX_ WARN_DEPRECATED,
5905 "\t(Maybe you should just omit the defined()?)\n");
5916 Perl_ck_rfun(pTHX_ OP *o)
5918 OPCODE type = o->op_type;
5919 return refkids(ck_fun(o), type);
5923 Perl_ck_listiob(pTHX_ OP *o)
5927 kid = cLISTOPo->op_first;
5930 kid = cLISTOPo->op_first;
5932 if (kid->op_type == OP_PUSHMARK)
5933 kid = kid->op_sibling;
5934 if (kid && o->op_flags & OPf_STACKED)
5935 kid = kid->op_sibling;
5936 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5937 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5938 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5939 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5940 cLISTOPo->op_first->op_sibling = kid;
5941 cLISTOPo->op_last = kid;
5942 kid = kid->op_sibling;
5947 append_elem(o->op_type, o, newDEFSVOP());
5953 if (PL_hints & HINT_LOCALE)
5954 o->op_private |= OPpLOCALE;
5961 Perl_ck_fun_locale(pTHX_ OP *o)
5967 if (PL_hints & HINT_LOCALE)
5968 o->op_private |= OPpLOCALE;
5975 Perl_ck_sassign(pTHX_ OP *o)
5977 OP *kid = cLISTOPo->op_first;
5978 /* has a disposable target? */
5979 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5980 && !(kid->op_flags & OPf_STACKED)
5981 /* Cannot steal the second time! */
5982 && !(kid->op_private & OPpTARGET_MY))
5984 OP *kkid = kid->op_sibling;
5986 /* Can just relocate the target. */
5987 if (kkid && kkid->op_type == OP_PADSV
5988 && !(kkid->op_private & OPpLVAL_INTRO))
5990 kid->op_targ = kkid->op_targ;
5992 /* Now we do not need PADSV and SASSIGN. */
5993 kid->op_sibling = o->op_sibling; /* NULL */
5994 cLISTOPo->op_first = NULL;
5997 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6005 Perl_ck_scmp(pTHX_ OP *o)
6009 if (PL_hints & HINT_LOCALE)
6010 o->op_private |= OPpLOCALE;
6017 Perl_ck_match(pTHX_ OP *o)
6019 o->op_private |= OPpRUNTIME;
6024 Perl_ck_method(pTHX_ OP *o)
6026 OP *kid = cUNOPo->op_first;
6027 if (kid->op_type == OP_CONST) {
6028 SV* sv = kSVOP->op_sv;
6029 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6031 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6032 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6035 kSVOP->op_sv = Nullsv;
6037 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6046 Perl_ck_null(pTHX_ OP *o)
6052 Perl_ck_open(pTHX_ OP *o)
6054 HV *table = GvHV(PL_hintgv);
6058 svp = hv_fetch(table, "open_IN", 7, FALSE);
6060 mode = mode_from_discipline(*svp);
6061 if (mode & O_BINARY)
6062 o->op_private |= OPpOPEN_IN_RAW;
6063 else if (mode & O_TEXT)
6064 o->op_private |= OPpOPEN_IN_CRLF;
6067 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6069 mode = mode_from_discipline(*svp);
6070 if (mode & O_BINARY)
6071 o->op_private |= OPpOPEN_OUT_RAW;
6072 else if (mode & O_TEXT)
6073 o->op_private |= OPpOPEN_OUT_CRLF;
6076 if (o->op_type == OP_BACKTICK)
6082 Perl_ck_repeat(pTHX_ OP *o)
6084 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6085 o->op_private |= OPpREPEAT_DOLIST;
6086 cBINOPo->op_first = force_list(cBINOPo->op_first);
6094 Perl_ck_require(pTHX_ OP *o)
6096 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6097 SVOP *kid = (SVOP*)cUNOPo->op_first;
6099 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6101 for (s = SvPVX(kid->op_sv); *s; s++) {
6102 if (*s == ':' && s[1] == ':') {
6104 Move(s+2, s+1, strlen(s+2)+1, char);
6105 --SvCUR(kid->op_sv);
6108 if (SvREADONLY(kid->op_sv)) {
6109 SvREADONLY_off(kid->op_sv);
6110 sv_catpvn(kid->op_sv, ".pm", 3);
6111 SvREADONLY_on(kid->op_sv);
6114 sv_catpvn(kid->op_sv, ".pm", 3);
6121 Perl_ck_return(pTHX_ OP *o)
6124 if (CvLVALUE(PL_compcv)) {
6125 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6126 mod(kid, OP_LEAVESUBLV);
6133 Perl_ck_retarget(pTHX_ OP *o)
6135 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6142 Perl_ck_select(pTHX_ OP *o)
6145 if (o->op_flags & OPf_KIDS) {
6146 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6147 if (kid && kid->op_sibling) {
6148 o->op_type = OP_SSELECT;
6149 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6151 return fold_constants(o);
6155 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6156 if (kid && kid->op_type == OP_RV2GV)
6157 kid->op_private &= ~HINT_STRICT_REFS;
6162 Perl_ck_shift(pTHX_ OP *o)
6164 I32 type = o->op_type;
6166 if (!(o->op_flags & OPf_KIDS)) {
6171 if (!CvUNIQUE(PL_compcv)) {
6172 argop = newOP(OP_PADAV, OPf_REF);
6173 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6176 argop = newUNOP(OP_RV2AV, 0,
6177 scalar(newGVOP(OP_GV, 0,
6178 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6181 argop = newUNOP(OP_RV2AV, 0,
6182 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6183 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6184 #endif /* USE_THREADS */
6185 return newUNOP(type, 0, scalar(argop));
6187 return scalar(modkids(ck_fun(o), type));
6191 Perl_ck_sort(pTHX_ OP *o)
6196 if (PL_hints & HINT_LOCALE)
6197 o->op_private |= OPpLOCALE;
6200 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6202 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6203 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6205 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6207 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6209 if (kid->op_type == OP_SCOPE) {
6213 else if (kid->op_type == OP_LEAVE) {
6214 if (o->op_type == OP_SORT) {
6215 null(kid); /* wipe out leave */
6218 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6219 if (k->op_next == kid)
6221 /* don't descend into loops */
6222 else if (k->op_type == OP_ENTERLOOP
6223 || k->op_type == OP_ENTERITER)
6225 k = cLOOPx(k)->op_lastop;
6230 kid->op_next = 0; /* just disconnect the leave */
6231 k = kLISTOP->op_first;
6236 if (o->op_type == OP_SORT) {
6237 /* provide scalar context for comparison function/block */
6243 o->op_flags |= OPf_SPECIAL;
6245 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6248 firstkid = firstkid->op_sibling;
6251 /* provide list context for arguments */
6252 if (o->op_type == OP_SORT)
6259 S_simplify_sort(pTHX_ OP *o)
6261 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6265 if (!(o->op_flags & OPf_STACKED))
6267 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6268 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6269 kid = kUNOP->op_first; /* get past null */
6270 if (kid->op_type != OP_SCOPE)
6272 kid = kLISTOP->op_last; /* get past scope */
6273 switch(kid->op_type) {
6281 k = kid; /* remember this node*/
6282 if (kBINOP->op_first->op_type != OP_RV2SV)
6284 kid = kBINOP->op_first; /* get past cmp */
6285 if (kUNOP->op_first->op_type != OP_GV)
6287 kid = kUNOP->op_first; /* get past rv2sv */
6289 if (GvSTASH(gv) != PL_curstash)
6291 if (strEQ(GvNAME(gv), "a"))
6293 else if (strEQ(GvNAME(gv), "b"))
6297 kid = k; /* back to cmp */
6298 if (kBINOP->op_last->op_type != OP_RV2SV)
6300 kid = kBINOP->op_last; /* down to 2nd arg */
6301 if (kUNOP->op_first->op_type != OP_GV)
6303 kid = kUNOP->op_first; /* get past rv2sv */
6305 if (GvSTASH(gv) != PL_curstash
6307 ? strNE(GvNAME(gv), "a")
6308 : strNE(GvNAME(gv), "b")))
6310 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6312 o->op_private |= OPpSORT_REVERSE;
6313 if (k->op_type == OP_NCMP)
6314 o->op_private |= OPpSORT_NUMERIC;
6315 if (k->op_type == OP_I_NCMP)
6316 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6317 kid = cLISTOPo->op_first->op_sibling;
6318 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6319 op_free(kid); /* then delete it */
6323 Perl_ck_split(pTHX_ OP *o)
6327 if (o->op_flags & OPf_STACKED)
6328 return no_fh_allowed(o);
6330 kid = cLISTOPo->op_first;
6331 if (kid->op_type != OP_NULL)
6332 Perl_croak(aTHX_ "panic: ck_split");
6333 kid = kid->op_sibling;
6334 op_free(cLISTOPo->op_first);
6335 cLISTOPo->op_first = kid;
6337 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6338 cLISTOPo->op_last = kid; /* There was only one element previously */
6341 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6342 OP *sibl = kid->op_sibling;
6343 kid->op_sibling = 0;
6344 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6345 if (cLISTOPo->op_first == cLISTOPo->op_last)
6346 cLISTOPo->op_last = kid;
6347 cLISTOPo->op_first = kid;
6348 kid->op_sibling = sibl;
6351 kid->op_type = OP_PUSHRE;
6352 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6355 if (!kid->op_sibling)
6356 append_elem(OP_SPLIT, o, newDEFSVOP());
6358 kid = kid->op_sibling;
6361 if (!kid->op_sibling)
6362 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6364 kid = kid->op_sibling;
6367 if (kid->op_sibling)
6368 return too_many_arguments(o,PL_op_desc[o->op_type]);
6374 Perl_ck_join(pTHX_ OP *o)
6376 if (ckWARN(WARN_SYNTAX)) {
6377 OP *kid = cLISTOPo->op_first->op_sibling;
6378 if (kid && kid->op_type == OP_MATCH) {
6379 char *pmstr = "STRING";
6380 if (kPMOP->op_pmregexp)
6381 pmstr = kPMOP->op_pmregexp->precomp;
6382 Perl_warner(aTHX_ WARN_SYNTAX,
6383 "/%s/ should probably be written as \"%s\"",
6391 Perl_ck_subr(pTHX_ OP *o)
6393 OP *prev = ((cUNOPo->op_first->op_sibling)
6394 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6395 OP *o2 = prev->op_sibling;
6404 o->op_private |= OPpENTERSUB_HASTARG;
6405 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6406 if (cvop->op_type == OP_RV2CV) {
6408 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6409 null(cvop); /* disable rv2cv */
6410 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6411 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6412 GV *gv = cGVOPx_gv(tmpop);
6415 tmpop->op_private |= OPpEARLY_CV;
6416 else if (SvPOK(cv)) {
6417 namegv = CvANON(cv) ? gv : CvGV(cv);
6418 proto = SvPV((SV*)cv, n_a);
6422 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6423 if (o2->op_type == OP_CONST)
6424 o2->op_private &= ~OPpCONST_STRICT;
6425 else if (o2->op_type == OP_LIST) {
6426 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6427 if (o && o->op_type == OP_CONST)
6428 o->op_private &= ~OPpCONST_STRICT;
6431 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6432 if (PERLDB_SUB && PL_curstash != PL_debstash)
6433 o->op_private |= OPpENTERSUB_DB;
6434 while (o2 != cvop) {
6438 return too_many_arguments(o, gv_ename(namegv));
6456 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6458 arg == 1 ? "block or sub {}" : "sub {}",
6459 gv_ename(namegv), o2);
6462 /* '*' allows any scalar type, including bareword */
6465 if (o2->op_type == OP_RV2GV)
6466 goto wrapref; /* autoconvert GLOB -> GLOBref */
6467 else if (o2->op_type == OP_CONST)
6468 o2->op_private &= ~OPpCONST_STRICT;
6469 else if (o2->op_type == OP_ENTERSUB) {
6470 /* accidental subroutine, revert to bareword */
6471 OP *gvop = ((UNOP*)o2)->op_first;
6472 if (gvop && gvop->op_type == OP_NULL) {
6473 gvop = ((UNOP*)gvop)->op_first;
6475 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6478 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6479 (gvop = ((UNOP*)gvop)->op_first) &&
6480 gvop->op_type == OP_GV)
6482 GV *gv = cGVOPx_gv(gvop);
6483 OP *sibling = o2->op_sibling;
6484 SV *n = newSVpvn("",0);
6486 gv_fullname3(n, gv, "");
6487 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6488 sv_chop(n, SvPVX(n)+6);
6489 o2 = newSVOP(OP_CONST, 0, n);
6490 prev->op_sibling = o2;
6491 o2->op_sibling = sibling;
6503 if (o2->op_type != OP_RV2GV)
6504 bad_type(arg, "symbol", gv_ename(namegv), o2);
6507 if (o2->op_type != OP_ENTERSUB)
6508 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6511 if (o2->op_type != OP_RV2SV
6512 && o2->op_type != OP_PADSV
6513 && o2->op_type != OP_HELEM
6514 && o2->op_type != OP_AELEM
6515 && o2->op_type != OP_THREADSV)
6517 bad_type(arg, "scalar", gv_ename(namegv), o2);
6521 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6522 bad_type(arg, "array", gv_ename(namegv), o2);
6525 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6526 bad_type(arg, "hash", gv_ename(namegv), o2);
6530 OP* sib = kid->op_sibling;
6531 kid->op_sibling = 0;
6532 o2 = newUNOP(OP_REFGEN, 0, kid);
6533 o2->op_sibling = sib;
6534 prev->op_sibling = o2;
6545 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6546 gv_ename(namegv), SvPV((SV*)cv, n_a));
6551 mod(o2, OP_ENTERSUB);
6553 o2 = o2->op_sibling;
6555 if (proto && !optional &&
6556 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6557 return too_few_arguments(o, gv_ename(namegv));
6562 Perl_ck_svconst(pTHX_ OP *o)
6564 SvREADONLY_on(cSVOPo->op_sv);
6569 Perl_ck_trunc(pTHX_ OP *o)
6571 if (o->op_flags & OPf_KIDS) {
6572 SVOP *kid = (SVOP*)cUNOPo->op_first;
6574 if (kid->op_type == OP_NULL)
6575 kid = (SVOP*)kid->op_sibling;
6576 if (kid && kid->op_type == OP_CONST &&
6577 (kid->op_private & OPpCONST_BARE))
6579 o->op_flags |= OPf_SPECIAL;
6580 kid->op_private &= ~OPpCONST_STRICT;
6587 Perl_ck_substr(pTHX_ OP *o)
6590 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6591 OP *kid = cLISTOPo->op_first;
6593 if (kid->op_type == OP_NULL)
6594 kid = kid->op_sibling;
6596 kid->op_flags |= OPf_MOD;
6602 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6605 Perl_peep(pTHX_ register OP *o)
6607 register OP* oldop = 0;
6610 if (!o || o->op_seq)
6614 SAVEVPTR(PL_curcop);
6615 for (; o; o = o->op_next) {
6621 switch (o->op_type) {
6625 PL_curcop = ((COP*)o); /* for warnings */
6626 o->op_seq = PL_op_seqmax++;
6630 if (cSVOPo->op_private & OPpCONST_STRICT)
6631 no_bareword_allowed(o);
6633 /* Relocate sv to the pad for thread safety.
6634 * Despite being a "constant", the SV is written to,
6635 * for reference counts, sv_upgrade() etc. */
6637 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6638 if (SvPADTMP(cSVOPo->op_sv)) {
6639 /* If op_sv is already a PADTMP then it is being used by
6640 * some pad, so make a copy. */
6641 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6642 SvREADONLY_on(PL_curpad[ix]);
6643 SvREFCNT_dec(cSVOPo->op_sv);
6646 SvREFCNT_dec(PL_curpad[ix]);
6647 SvPADTMP_on(cSVOPo->op_sv);
6648 PL_curpad[ix] = cSVOPo->op_sv;
6649 /* XXX I don't know how this isn't readonly already. */
6650 SvREADONLY_on(PL_curpad[ix]);
6652 cSVOPo->op_sv = Nullsv;
6656 o->op_seq = PL_op_seqmax++;
6660 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6661 if (o->op_next->op_private & OPpTARGET_MY) {
6662 if (o->op_flags & OPf_STACKED) /* chained concats */
6663 goto ignore_optimization;
6665 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6666 o->op_targ = o->op_next->op_targ;
6667 o->op_next->op_targ = 0;
6668 o->op_private |= OPpTARGET_MY;
6673 ignore_optimization:
6674 o->op_seq = PL_op_seqmax++;
6677 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6678 o->op_seq = PL_op_seqmax++;
6679 break; /* Scalar stub must produce undef. List stub is noop */
6683 if (o->op_targ == OP_NEXTSTATE
6684 || o->op_targ == OP_DBSTATE
6685 || o->op_targ == OP_SETSTATE)
6687 PL_curcop = ((COP*)o);
6694 if (oldop && o->op_next) {
6695 oldop->op_next = o->op_next;
6698 o->op_seq = PL_op_seqmax++;
6702 if (o->op_next->op_type == OP_RV2SV) {
6703 if (!(o->op_next->op_private & OPpDEREF)) {
6705 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6707 o->op_next = o->op_next->op_next;
6708 o->op_type = OP_GVSV;
6709 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6712 else if (o->op_next->op_type == OP_RV2AV) {
6713 OP* pop = o->op_next->op_next;
6715 if (pop->op_type == OP_CONST &&
6716 (PL_op = pop->op_next) &&
6717 pop->op_next->op_type == OP_AELEM &&
6718 !(pop->op_next->op_private &
6719 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6720 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6728 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6729 o->op_next = pop->op_next->op_next;
6730 o->op_type = OP_AELEMFAST;
6731 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6732 o->op_private = (U8)i;
6737 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6739 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6740 /* XXX could check prototype here instead of just carping */
6741 SV *sv = sv_newmortal();
6742 gv_efullname3(sv, gv, Nullch);
6743 Perl_warner(aTHX_ WARN_PROTOTYPE,
6744 "%s() called too early to check prototype",
6749 o->op_seq = PL_op_seqmax++;
6760 o->op_seq = PL_op_seqmax++;
6761 while (cLOGOP->op_other->op_type == OP_NULL)
6762 cLOGOP->op_other = cLOGOP->op_other->op_next;
6763 peep(cLOGOP->op_other);
6767 o->op_seq = PL_op_seqmax++;
6768 while (cLOOP->op_redoop->op_type == OP_NULL)
6769 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6770 peep(cLOOP->op_redoop);
6771 while (cLOOP->op_nextop->op_type == OP_NULL)
6772 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6773 peep(cLOOP->op_nextop);
6774 while (cLOOP->op_lastop->op_type == OP_NULL)
6775 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6776 peep(cLOOP->op_lastop);
6782 o->op_seq = PL_op_seqmax++;
6783 while (cPMOP->op_pmreplstart &&
6784 cPMOP->op_pmreplstart->op_type == OP_NULL)
6785 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6786 peep(cPMOP->op_pmreplstart);
6790 o->op_seq = PL_op_seqmax++;
6791 if (ckWARN(WARN_SYNTAX) && o->op_next
6792 && o->op_next->op_type == OP_NEXTSTATE) {
6793 if (o->op_next->op_sibling &&
6794 o->op_next->op_sibling->op_type != OP_EXIT &&
6795 o->op_next->op_sibling->op_type != OP_WARN &&
6796 o->op_next->op_sibling->op_type != OP_DIE) {
6797 line_t oldline = CopLINE(PL_curcop);
6799 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6800 Perl_warner(aTHX_ WARN_EXEC,
6801 "Statement unlikely to be reached");
6802 Perl_warner(aTHX_ WARN_EXEC,
6803 "\t(Maybe you meant system() when you said exec()?)\n");
6804 CopLINE_set(PL_curcop, oldline);
6813 SV **svp, **indsvp, *sv;
6818 o->op_seq = PL_op_seqmax++;
6820 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6823 /* Make the CONST have a shared SV */
6824 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6825 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6826 key = SvPV(sv, keylen);
6829 lexname = newSVpvn_share(key, keylen, 0);
6834 if ((o->op_private & (OPpLVAL_INTRO)))
6837 rop = (UNOP*)((BINOP*)o)->op_first;
6838 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6840 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6841 if (!SvOBJECT(lexname))
6843 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6844 if (!fields || !GvHV(*fields))
6846 key = SvPV(*svp, keylen);
6849 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6851 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6852 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6854 ind = SvIV(*indsvp);
6856 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6857 rop->op_type = OP_RV2AV;
6858 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6859 o->op_type = OP_AELEM;
6860 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6862 if (SvREADONLY(*svp))
6864 SvFLAGS(sv) |= (SvFLAGS(*svp)
6865 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6875 SV **svp, **indsvp, *sv;
6879 SVOP *first_key_op, *key_op;
6881 o->op_seq = PL_op_seqmax++;
6882 if ((o->op_private & (OPpLVAL_INTRO))
6883 /* I bet there's always a pushmark... */
6884 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6885 /* hmmm, no optimization if list contains only one key. */
6887 rop = (UNOP*)((LISTOP*)o)->op_last;
6888 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6890 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6891 if (!SvOBJECT(lexname))
6893 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6894 if (!fields || !GvHV(*fields))
6896 /* Again guessing that the pushmark can be jumped over.... */
6897 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6898 ->op_first->op_sibling;
6899 /* Check that the key list contains only constants. */
6900 for (key_op = first_key_op; key_op;
6901 key_op = (SVOP*)key_op->op_sibling)
6902 if (key_op->op_type != OP_CONST)
6906 rop->op_type = OP_RV2AV;
6907 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6908 o->op_type = OP_ASLICE;
6909 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6910 for (key_op = first_key_op; key_op;
6911 key_op = (SVOP*)key_op->op_sibling) {
6912 svp = cSVOPx_svp(key_op);
6913 key = SvPV(*svp, keylen);
6916 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6918 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6919 "in variable %s of type %s",
6920 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6922 ind = SvIV(*indsvp);
6924 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6926 if (SvREADONLY(*svp))
6928 SvFLAGS(sv) |= (SvFLAGS(*svp)
6929 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6937 o->op_seq = PL_op_seqmax++;
6947 /* Efficient sub that returns a constant scalar value. */
6949 const_sv_xsub(pTHXo_ CV* cv)
6953 ST(0) = (SV*)XSANY.any_ptr;