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 RETVAL_MAX ( 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 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1420 /* Backward compatibility mode: */
1421 o->op_private |= OPpENTERSUB_INARGS;
1424 else { /* Compile-time error message: */
1425 OP *kid = cUNOPo->op_first;
1429 if (kid->op_type == OP_PUSHMARK)
1431 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1433 "panic: unexpected lvalue entersub "
1434 "args: type/targ %ld:%ld",
1435 (long)kid->op_type,kid->op_targ);
1436 kid = kLISTOP->op_first;
1438 while (kid->op_sibling)
1439 kid = kid->op_sibling;
1440 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1442 if (kid->op_type == OP_METHOD_NAMED
1443 || kid->op_type == OP_METHOD)
1447 if (kid->op_sibling || kid->op_next != kid) {
1448 yyerror("panic: unexpected optree near method call");
1452 NewOp(1101, newop, 1, UNOP);
1453 newop->op_type = OP_RV2CV;
1454 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1455 newop->op_first = Nullop;
1456 newop->op_next = (OP*)newop;
1457 kid->op_sibling = (OP*)newop;
1458 newop->op_private |= OPpLVAL_INTRO;
1462 if (kid->op_type != OP_RV2CV)
1464 "panic: unexpected lvalue entersub "
1465 "entry via type/targ %ld:%ld",
1466 (long)kid->op_type,kid->op_targ);
1467 kid->op_private |= OPpLVAL_INTRO;
1468 break; /* Postpone until runtime */
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1474 kid = kUNOP->op_first;
1475 if (kid->op_type == OP_NULL)
1477 "Unexpected constant lvalue entersub "
1478 "entry via type/targ %ld:%ld",
1479 (long)kid->op_type,kid->op_targ);
1480 if (kid->op_type != OP_GV) {
1481 /* Restore RV2CV to check lvalueness */
1483 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1484 okid->op_next = kid->op_next;
1485 kid->op_next = okid;
1488 okid->op_next = Nullop;
1489 okid->op_type = OP_RV2CV;
1491 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1492 okid->op_private |= OPpLVAL_INTRO;
1496 cv = GvCV(kGVOP_gv);
1506 /* grep, foreach, subcalls, refgen */
1507 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1509 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1510 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1512 : (o->op_type == OP_ENTERSUB
1513 ? "non-lvalue subroutine call"
1514 : PL_op_desc[o->op_type])),
1515 type ? PL_op_desc[type] : "local"));
1529 case OP_RIGHT_SHIFT:
1538 if (!(o->op_flags & OPf_STACKED))
1544 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1550 if (!type && cUNOPo->op_first->op_type != OP_GV)
1551 Perl_croak(aTHX_ "Can't localize through a reference");
1552 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1553 PL_modcount = RETVAL_MAX;
1554 return o; /* Treat \(@foo) like ordinary list. */
1558 if (scalar_mod_type(o, type))
1560 ref(cUNOPo->op_first, o->op_type);
1564 if (type == OP_LEAVESUBLV)
1565 o->op_private |= OPpMAYBE_LVSUB;
1572 PL_modcount = RETVAL_MAX;
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 = RETVAL_MAX;
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 if (cLISTOPo->op_children < 7) {
2413 /* XXX do we really need to do this if we're done appending?? */
2414 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2416 cLISTOPo->op_last = last; /* in case check substituted last arg */
2419 return fold_constants(o);
2422 /* List constructors */
2425 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2433 if (first->op_type != type
2434 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2436 return newLISTOP(type, 0, first, last);
2439 if (first->op_flags & OPf_KIDS)
2440 ((LISTOP*)first)->op_last->op_sibling = last;
2442 first->op_flags |= OPf_KIDS;
2443 ((LISTOP*)first)->op_first = last;
2445 ((LISTOP*)first)->op_last = last;
2446 ((LISTOP*)first)->op_children++;
2451 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2459 if (first->op_type != type)
2460 return prepend_elem(type, (OP*)first, (OP*)last);
2462 if (last->op_type != type)
2463 return append_elem(type, (OP*)first, (OP*)last);
2465 first->op_last->op_sibling = last->op_first;
2466 first->op_last = last->op_last;
2467 first->op_children += last->op_children;
2468 if (first->op_children)
2469 first->op_flags |= OPf_KIDS;
2471 #ifdef PL_OP_SLAB_ALLOC
2479 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2487 if (last->op_type == type) {
2488 if (type == OP_LIST) { /* already a PUSHMARK there */
2489 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2490 ((LISTOP*)last)->op_first->op_sibling = first;
2491 if (!(first->op_flags & OPf_PARENS))
2492 last->op_flags &= ~OPf_PARENS;
2495 if (!(last->op_flags & OPf_KIDS)) {
2496 ((LISTOP*)last)->op_last = first;
2497 last->op_flags |= OPf_KIDS;
2499 first->op_sibling = ((LISTOP*)last)->op_first;
2500 ((LISTOP*)last)->op_first = first;
2502 ((LISTOP*)last)->op_children++;
2506 return newLISTOP(type, 0, first, last);
2512 Perl_newNULLLIST(pTHX)
2514 return newOP(OP_STUB, 0);
2518 Perl_force_list(pTHX_ OP *o)
2520 if (!o || o->op_type != OP_LIST)
2521 o = newLISTOP(OP_LIST, 0, o, Nullop);
2527 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2531 NewOp(1101, listop, 1, LISTOP);
2533 listop->op_type = type;
2534 listop->op_ppaddr = PL_ppaddr[type];
2535 listop->op_children = (first != 0) + (last != 0);
2536 listop->op_flags = flags;
2540 else if (!first && last)
2543 first->op_sibling = last;
2544 listop->op_first = first;
2545 listop->op_last = last;
2546 if (type == OP_LIST) {
2548 pushop = newOP(OP_PUSHMARK, 0);
2549 pushop->op_sibling = first;
2550 listop->op_first = pushop;
2551 listop->op_flags |= OPf_KIDS;
2553 listop->op_last = pushop;
2555 else if (listop->op_children)
2556 listop->op_flags |= OPf_KIDS;
2562 Perl_newOP(pTHX_ I32 type, I32 flags)
2565 NewOp(1101, o, 1, OP);
2567 o->op_ppaddr = PL_ppaddr[type];
2568 o->op_flags = flags;
2571 o->op_private = 0 + (flags >> 8);
2572 if (PL_opargs[type] & OA_RETSCALAR)
2574 if (PL_opargs[type] & OA_TARGET)
2575 o->op_targ = pad_alloc(type, SVs_PADTMP);
2576 return CHECKOP(type, o);
2580 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2585 first = newOP(OP_STUB, 0);
2586 if (PL_opargs[type] & OA_MARK)
2587 first = force_list(first);
2589 NewOp(1101, unop, 1, UNOP);
2590 unop->op_type = type;
2591 unop->op_ppaddr = PL_ppaddr[type];
2592 unop->op_first = first;
2593 unop->op_flags = flags | OPf_KIDS;
2594 unop->op_private = 1 | (flags >> 8);
2595 unop = (UNOP*) CHECKOP(type, unop);
2599 return fold_constants((OP *) unop);
2603 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2606 NewOp(1101, binop, 1, BINOP);
2609 first = newOP(OP_NULL, 0);
2611 binop->op_type = type;
2612 binop->op_ppaddr = PL_ppaddr[type];
2613 binop->op_first = first;
2614 binop->op_flags = flags | OPf_KIDS;
2617 binop->op_private = 1 | (flags >> 8);
2620 binop->op_private = 2 | (flags >> 8);
2621 first->op_sibling = last;
2624 binop = (BINOP*)CHECKOP(type, binop);
2625 if (binop->op_next || binop->op_type != type)
2628 binop->op_last = binop->op_first->op_sibling;
2630 return fold_constants((OP *)binop);
2634 utf8compare(const void *a, const void *b)
2637 for (i = 0; i < 10; i++) {
2638 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2640 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2647 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2649 SV *tstr = ((SVOP*)expr)->op_sv;
2650 SV *rstr = ((SVOP*)repl)->op_sv;
2653 U8 *t = (U8*)SvPV(tstr, tlen);
2654 U8 *r = (U8*)SvPV(rstr, rlen);
2661 register short *tbl;
2663 complement = o->op_private & OPpTRANS_COMPLEMENT;
2664 del = o->op_private & OPpTRANS_DELETE;
2665 squash = o->op_private & OPpTRANS_SQUASH;
2668 o->op_private |= OPpTRANS_FROM_UTF;
2671 o->op_private |= OPpTRANS_TO_UTF;
2673 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2674 SV* listsv = newSVpvn("# comment\n",10);
2676 U8* tend = t + tlen;
2677 U8* rend = r + rlen;
2691 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2692 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2693 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2694 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2697 U8 tmpbuf[UTF8_MAXLEN+1];
2701 New(1109, cp, tlen, U8*);
2703 transv = newSVpvn("",0);
2712 qsort(cp, i, sizeof(U8*), utf8compare);
2713 for (j = 0; j < i; j++) {
2715 I32 cur = j < i ? cp[j+1] - s : tend - s;
2716 UV val = utf8_to_uv(s, cur, &ulen, 0);
2718 diff = val - nextmin;
2720 t = uv_to_utf8(tmpbuf,nextmin);
2721 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2723 t = uv_to_utf8(tmpbuf, val - 1);
2724 sv_catpvn(transv, "\377", 1);
2725 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2729 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2733 t = uv_to_utf8(tmpbuf,nextmin);
2734 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2735 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2736 sv_catpvn(transv, "\377", 1);
2737 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2738 t = (U8*)SvPVX(transv);
2739 tlen = SvCUR(transv);
2742 else if (!rlen && !del) {
2743 r = t; rlen = tlen; rend = tend;
2747 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2749 o->op_private |= OPpTRANS_IDENTICAL;
2753 while (t < tend || tfirst <= tlast) {
2754 /* see if we need more "t" chars */
2755 if (tfirst > tlast) {
2756 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2758 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2760 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2767 /* now see if we need more "r" chars */
2768 if (rfirst > rlast) {
2770 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2772 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2774 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2783 rfirst = rlast = 0xffffffff;
2787 /* now see which range will peter our first, if either. */
2788 tdiff = tlast - tfirst;
2789 rdiff = rlast - rfirst;
2796 if (rfirst == 0xffffffff) {
2797 diff = tdiff; /* oops, pretend rdiff is infinite */
2799 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2800 (long)tfirst, (long)tlast);
2802 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2806 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2807 (long)tfirst, (long)(tfirst + diff),
2810 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2811 (long)tfirst, (long)rfirst);
2813 if (rfirst + diff > max)
2814 max = rfirst + diff;
2817 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2828 else if (max > 0xff)
2833 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2834 SvREFCNT_dec(listsv);
2836 SvREFCNT_dec(transv);
2838 if (!del && havefinal)
2839 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2840 newSVuv((UV)final), 0);
2843 o->op_private |= OPpTRANS_GROWS;
2855 tbl = (short*)cPVOPo->op_pv;
2857 Zero(tbl, 256, short);
2858 for (i = 0; i < tlen; i++)
2860 for (i = 0, j = 0; i < 256; i++) {
2871 if (i < 128 && r[j] >= 128)
2879 if (!rlen && !del) {
2882 o->op_private |= OPpTRANS_IDENTICAL;
2884 for (i = 0; i < 256; i++)
2886 for (i = 0, j = 0; i < tlen; i++,j++) {
2889 if (tbl[t[i]] == -1)
2895 if (tbl[t[i]] == -1) {
2896 if (t[i] < 128 && r[j] >= 128)
2903 o->op_private |= OPpTRANS_GROWS;
2911 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2915 NewOp(1101, pmop, 1, PMOP);
2916 pmop->op_type = type;
2917 pmop->op_ppaddr = PL_ppaddr[type];
2918 pmop->op_flags = flags;
2919 pmop->op_private = 0 | (flags >> 8);
2921 if (PL_hints & HINT_RE_TAINT)
2922 pmop->op_pmpermflags |= PMf_RETAINT;
2923 if (PL_hints & HINT_LOCALE)
2924 pmop->op_pmpermflags |= PMf_LOCALE;
2925 pmop->op_pmflags = pmop->op_pmpermflags;
2927 /* link into pm list */
2928 if (type != OP_TRANS && PL_curstash) {
2929 pmop->op_pmnext = HvPMROOT(PL_curstash);
2930 HvPMROOT(PL_curstash) = pmop;
2937 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2941 I32 repl_has_vars = 0;
2943 if (o->op_type == OP_TRANS)
2944 return pmtrans(o, expr, repl);
2946 PL_hints |= HINT_BLOCK_SCOPE;
2949 if (expr->op_type == OP_CONST) {
2951 SV *pat = ((SVOP*)expr)->op_sv;
2952 char *p = SvPV(pat, plen);
2953 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2954 sv_setpvn(pat, "\\s+", 3);
2955 p = SvPV(pat, plen);
2956 pm->op_pmflags |= PMf_SKIPWHITE;
2958 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2959 pm->op_pmdynflags |= PMdf_UTF8;
2960 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2961 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2962 pm->op_pmflags |= PMf_WHITE;
2966 if (PL_hints & HINT_UTF8)
2967 pm->op_pmdynflags |= PMdf_UTF8;
2968 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2969 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2971 : OP_REGCMAYBE),0,expr);
2973 NewOp(1101, rcop, 1, LOGOP);
2974 rcop->op_type = OP_REGCOMP;
2975 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2976 rcop->op_first = scalar(expr);
2977 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2978 ? (OPf_SPECIAL | OPf_KIDS)
2980 rcop->op_private = 1;
2983 /* establish postfix order */
2984 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2986 rcop->op_next = expr;
2987 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2990 rcop->op_next = LINKLIST(expr);
2991 expr->op_next = (OP*)rcop;
2994 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2999 if (pm->op_pmflags & PMf_EVAL) {
3001 if (CopLINE(PL_curcop) < PL_multi_end)
3002 CopLINE_set(PL_curcop, PL_multi_end);
3005 else if (repl->op_type == OP_THREADSV
3006 && strchr("&`'123456789+",
3007 PL_threadsv_names[repl->op_targ]))
3011 #endif /* USE_THREADS */
3012 else if (repl->op_type == OP_CONST)
3016 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3017 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3019 if (curop->op_type == OP_THREADSV) {
3021 if (strchr("&`'123456789+", curop->op_private))
3025 if (curop->op_type == OP_GV) {
3026 GV *gv = cGVOPx_gv(curop);
3028 if (strchr("&`'123456789+", *GvENAME(gv)))
3031 #endif /* USE_THREADS */
3032 else if (curop->op_type == OP_RV2CV)
3034 else if (curop->op_type == OP_RV2SV ||
3035 curop->op_type == OP_RV2AV ||
3036 curop->op_type == OP_RV2HV ||
3037 curop->op_type == OP_RV2GV) {
3038 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3041 else if (curop->op_type == OP_PADSV ||
3042 curop->op_type == OP_PADAV ||
3043 curop->op_type == OP_PADHV ||
3044 curop->op_type == OP_PADANY) {
3047 else if (curop->op_type == OP_PUSHRE)
3048 ; /* Okay here, dangerous in newASSIGNOP */
3057 && (!pm->op_pmregexp
3058 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3059 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3060 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3061 prepend_elem(o->op_type, scalar(repl), o);
3064 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3065 pm->op_pmflags |= PMf_MAYBE_CONST;
3066 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3068 NewOp(1101, rcop, 1, LOGOP);
3069 rcop->op_type = OP_SUBSTCONT;
3070 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3071 rcop->op_first = scalar(repl);
3072 rcop->op_flags |= OPf_KIDS;
3073 rcop->op_private = 1;
3076 /* establish postfix order */
3077 rcop->op_next = LINKLIST(repl);
3078 repl->op_next = (OP*)rcop;
3080 pm->op_pmreplroot = scalar((OP*)rcop);
3081 pm->op_pmreplstart = LINKLIST(rcop);
3090 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3093 NewOp(1101, svop, 1, SVOP);
3094 svop->op_type = type;
3095 svop->op_ppaddr = PL_ppaddr[type];
3097 svop->op_next = (OP*)svop;
3098 svop->op_flags = flags;
3099 if (PL_opargs[type] & OA_RETSCALAR)
3101 if (PL_opargs[type] & OA_TARGET)
3102 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3103 return CHECKOP(type, svop);
3107 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3110 NewOp(1101, padop, 1, PADOP);
3111 padop->op_type = type;
3112 padop->op_ppaddr = PL_ppaddr[type];
3113 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3114 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3115 PL_curpad[padop->op_padix] = sv;
3117 padop->op_next = (OP*)padop;
3118 padop->op_flags = flags;
3119 if (PL_opargs[type] & OA_RETSCALAR)
3121 if (PL_opargs[type] & OA_TARGET)
3122 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3123 return CHECKOP(type, padop);
3127 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3131 return newPADOP(type, flags, SvREFCNT_inc(gv));
3133 return newSVOP(type, flags, SvREFCNT_inc(gv));
3138 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3141 NewOp(1101, pvop, 1, PVOP);
3142 pvop->op_type = type;
3143 pvop->op_ppaddr = PL_ppaddr[type];
3145 pvop->op_next = (OP*)pvop;
3146 pvop->op_flags = flags;
3147 if (PL_opargs[type] & OA_RETSCALAR)
3149 if (PL_opargs[type] & OA_TARGET)
3150 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3151 return CHECKOP(type, pvop);
3155 Perl_package(pTHX_ OP *o)
3159 save_hptr(&PL_curstash);
3160 save_item(PL_curstname);
3165 name = SvPV(sv, len);
3166 PL_curstash = gv_stashpvn(name,len,TRUE);
3167 sv_setpvn(PL_curstname, name, len);
3171 sv_setpv(PL_curstname,"<none>");
3172 PL_curstash = Nullhv;
3174 PL_hints |= HINT_BLOCK_SCOPE;
3175 PL_copline = NOLINE;
3180 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3188 if (id->op_type != OP_CONST)
3189 Perl_croak(aTHX_ "Module name must be constant");
3193 if (version != Nullop) {
3194 SV *vesv = ((SVOP*)version)->op_sv;
3196 if (arg == Nullop && !SvNIOKp(vesv)) {
3203 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3204 Perl_croak(aTHX_ "Version number must be constant number");
3206 /* Make copy of id so we don't free it twice */
3207 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3209 /* Fake up a method call to VERSION */
3210 meth = newSVpvn("VERSION",7);
3211 sv_upgrade(meth, SVt_PVIV);
3212 (void)SvIOK_on(meth);
3213 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3214 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3215 append_elem(OP_LIST,
3216 prepend_elem(OP_LIST, pack, list(version)),
3217 newSVOP(OP_METHOD_NAMED, 0, meth)));
3221 /* Fake up an import/unimport */
3222 if (arg && arg->op_type == OP_STUB)
3223 imop = arg; /* no import on explicit () */
3224 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3225 imop = Nullop; /* use 5.0; */
3230 /* Make copy of id so we don't free it twice */
3231 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3233 /* Fake up a method call to import/unimport */
3234 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3235 sv_upgrade(meth, SVt_PVIV);
3236 (void)SvIOK_on(meth);
3237 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3238 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3239 append_elem(OP_LIST,
3240 prepend_elem(OP_LIST, pack, list(arg)),
3241 newSVOP(OP_METHOD_NAMED, 0, meth)));
3244 /* Fake up a require, handle override, if any */
3245 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3246 if (!(gv && GvIMPORTED_CV(gv)))
3247 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3249 if (gv && GvIMPORTED_CV(gv)) {
3250 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3251 append_elem(OP_LIST, id,
3252 scalar(newUNOP(OP_RV2CV, 0,
3257 rqop = newUNOP(OP_REQUIRE, 0, id);
3260 /* Fake up the BEGIN {}, which does its thing immediately. */
3262 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3265 append_elem(OP_LINESEQ,
3266 append_elem(OP_LINESEQ,
3267 newSTATEOP(0, Nullch, rqop),
3268 newSTATEOP(0, Nullch, veop)),
3269 newSTATEOP(0, Nullch, imop) ));
3271 PL_hints |= HINT_BLOCK_SCOPE;
3272 PL_copline = NOLINE;
3277 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3280 va_start(args, ver);
3281 vload_module(flags, name, ver, &args);
3285 #ifdef PERL_IMPLICIT_CONTEXT
3287 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3291 va_start(args, ver);
3292 vload_module(flags, name, ver, &args);
3298 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3300 OP *modname, *veop, *imop;
3302 modname = newSVOP(OP_CONST, 0, name);
3303 modname->op_private |= OPpCONST_BARE;
3305 veop = newSVOP(OP_CONST, 0, ver);
3309 if (flags & PERL_LOADMOD_NOIMPORT) {
3310 imop = sawparens(newNULLLIST());
3312 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3313 imop = va_arg(*args, OP*);
3318 sv = va_arg(*args, SV*);
3320 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3321 sv = va_arg(*args, SV*);
3325 line_t ocopline = PL_copline;
3326 int oexpect = PL_expect;
3328 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3329 veop, modname, imop);
3330 PL_expect = oexpect;
3331 PL_copline = ocopline;
3336 Perl_dofile(pTHX_ OP *term)
3341 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3342 if (!(gv && GvIMPORTED_CV(gv)))
3343 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3345 if (gv && GvIMPORTED_CV(gv)) {
3346 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3347 append_elem(OP_LIST, term,
3348 scalar(newUNOP(OP_RV2CV, 0,
3353 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3359 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3361 return newBINOP(OP_LSLICE, flags,
3362 list(force_list(subscript)),
3363 list(force_list(listval)) );
3367 S_list_assignment(pTHX_ register OP *o)
3372 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3373 o = cUNOPo->op_first;
3375 if (o->op_type == OP_COND_EXPR) {
3376 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3377 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3382 yyerror("Assignment to both a list and a scalar");
3386 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3387 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3388 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3391 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3394 if (o->op_type == OP_RV2SV)
3401 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3406 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3407 return newLOGOP(optype, 0,
3408 mod(scalar(left), optype),
3409 newUNOP(OP_SASSIGN, 0, scalar(right)));
3412 return newBINOP(optype, OPf_STACKED,
3413 mod(scalar(left), optype), scalar(right));
3417 if (list_assignment(left)) {
3421 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3422 left = mod(left, OP_AASSIGN);
3430 curop = list(force_list(left));
3431 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3432 o->op_private = 0 | (flags >> 8);
3433 for (curop = ((LISTOP*)curop)->op_first;
3434 curop; curop = curop->op_sibling)
3436 if (curop->op_type == OP_RV2HV &&
3437 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3438 o->op_private |= OPpASSIGN_HASH;
3442 if (!(left->op_private & OPpLVAL_INTRO)) {
3445 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3446 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3447 if (curop->op_type == OP_GV) {
3448 GV *gv = cGVOPx_gv(curop);
3449 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3451 SvCUR(gv) = PL_generation;
3453 else if (curop->op_type == OP_PADSV ||
3454 curop->op_type == OP_PADAV ||
3455 curop->op_type == OP_PADHV ||
3456 curop->op_type == OP_PADANY) {
3457 SV **svp = AvARRAY(PL_comppad_name);
3458 SV *sv = svp[curop->op_targ];
3459 if (SvCUR(sv) == PL_generation)
3461 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3463 else if (curop->op_type == OP_RV2CV)
3465 else if (curop->op_type == OP_RV2SV ||
3466 curop->op_type == OP_RV2AV ||
3467 curop->op_type == OP_RV2HV ||
3468 curop->op_type == OP_RV2GV) {
3469 if (lastop->op_type != OP_GV) /* funny deref? */
3472 else if (curop->op_type == OP_PUSHRE) {
3473 if (((PMOP*)curop)->op_pmreplroot) {
3475 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3477 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3479 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3481 SvCUR(gv) = PL_generation;
3490 o->op_private |= OPpASSIGN_COMMON;
3492 if (right && right->op_type == OP_SPLIT) {
3494 if ((tmpop = ((LISTOP*)right)->op_first) &&
3495 tmpop->op_type == OP_PUSHRE)
3497 PMOP *pm = (PMOP*)tmpop;
3498 if (left->op_type == OP_RV2AV &&
3499 !(left->op_private & OPpLVAL_INTRO) &&
3500 !(o->op_private & OPpASSIGN_COMMON) )
3502 tmpop = ((UNOP*)left)->op_first;
3503 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3505 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3506 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3508 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3509 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3511 pm->op_pmflags |= PMf_ONCE;
3512 tmpop = cUNOPo->op_first; /* to list (nulled) */
3513 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3514 tmpop->op_sibling = Nullop; /* don't free split */
3515 right->op_next = tmpop->op_next; /* fix starting loc */
3516 op_free(o); /* blow off assign */
3517 right->op_flags &= ~OPf_WANT;
3518 /* "I don't know and I don't care." */
3523 if (PL_modcount < RETVAL_MAX &&
3524 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3526 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3528 sv_setiv(sv, PL_modcount+1);
3536 right = newOP(OP_UNDEF, 0);
3537 if (right->op_type == OP_READLINE) {
3538 right->op_flags |= OPf_STACKED;
3539 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3542 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3543 o = newBINOP(OP_SASSIGN, flags,
3544 scalar(right), mod(scalar(left), OP_SASSIGN) );
3556 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3558 U32 seq = intro_my();
3561 NewOp(1101, cop, 1, COP);
3562 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3563 cop->op_type = OP_DBSTATE;
3564 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3567 cop->op_type = OP_NEXTSTATE;
3568 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3570 cop->op_flags = flags;
3571 cop->op_private = (PL_hints & HINT_BYTE);
3573 cop->op_private |= NATIVE_HINTS;
3575 PL_compiling.op_private = cop->op_private;
3576 cop->op_next = (OP*)cop;
3579 cop->cop_label = label;
3580 PL_hints |= HINT_BLOCK_SCOPE;
3583 cop->cop_arybase = PL_curcop->cop_arybase;
3584 if (specialWARN(PL_curcop->cop_warnings))
3585 cop->cop_warnings = PL_curcop->cop_warnings ;
3587 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3588 if (specialCopIO(PL_curcop->cop_io))
3589 cop->cop_io = PL_curcop->cop_io;
3591 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3594 if (PL_copline == NOLINE)
3595 CopLINE_set(cop, CopLINE(PL_curcop));
3597 CopLINE_set(cop, PL_copline);
3598 PL_copline = NOLINE;
3601 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3603 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3605 CopSTASH_set(cop, PL_curstash);
3607 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3608 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3609 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3610 (void)SvIOK_on(*svp);
3611 SvIVX(*svp) = PTR2IV(cop);
3615 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3618 /* "Introduce" my variables to visible status. */
3626 if (! PL_min_intro_pending)
3627 return PL_cop_seqmax;
3629 svp = AvARRAY(PL_comppad_name);
3630 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3631 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3632 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3633 SvNVX(sv) = (NV)PL_cop_seqmax;
3636 PL_min_intro_pending = 0;
3637 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3638 return PL_cop_seqmax++;
3642 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3644 return new_logop(type, flags, &first, &other);
3648 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3652 OP *first = *firstp;
3653 OP *other = *otherp;
3655 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3656 return newBINOP(type, flags, scalar(first), scalar(other));
3658 scalarboolean(first);
3659 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3660 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3661 if (type == OP_AND || type == OP_OR) {
3667 first = *firstp = cUNOPo->op_first;
3669 first->op_next = o->op_next;
3670 cUNOPo->op_first = Nullop;
3674 if (first->op_type == OP_CONST) {
3675 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3676 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3677 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3688 else if (first->op_type == OP_WANTARRAY) {
3694 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3695 OP *k1 = ((UNOP*)first)->op_first;
3696 OP *k2 = k1->op_sibling;
3698 switch (first->op_type)
3701 if (k2 && k2->op_type == OP_READLINE
3702 && (k2->op_flags & OPf_STACKED)
3703 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3705 warnop = k2->op_type;
3710 if (k1->op_type == OP_READDIR
3711 || k1->op_type == OP_GLOB
3712 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3713 || k1->op_type == OP_EACH)
3715 warnop = ((k1->op_type == OP_NULL)
3716 ? k1->op_targ : k1->op_type);
3721 line_t oldline = CopLINE(PL_curcop);
3722 CopLINE_set(PL_curcop, PL_copline);
3723 Perl_warner(aTHX_ WARN_MISC,
3724 "Value of %s%s can be \"0\"; test with defined()",
3726 ((warnop == OP_READLINE || warnop == OP_GLOB)
3727 ? " construct" : "() operator"));
3728 CopLINE_set(PL_curcop, oldline);
3735 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3736 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3738 NewOp(1101, logop, 1, LOGOP);
3740 logop->op_type = type;
3741 logop->op_ppaddr = PL_ppaddr[type];
3742 logop->op_first = first;
3743 logop->op_flags = flags | OPf_KIDS;
3744 logop->op_other = LINKLIST(other);
3745 logop->op_private = 1 | (flags >> 8);
3747 /* establish postfix order */
3748 logop->op_next = LINKLIST(first);
3749 first->op_next = (OP*)logop;
3750 first->op_sibling = other;
3752 o = newUNOP(OP_NULL, 0, (OP*)logop);
3759 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3766 return newLOGOP(OP_AND, 0, first, trueop);
3768 return newLOGOP(OP_OR, 0, first, falseop);
3770 scalarboolean(first);
3771 if (first->op_type == OP_CONST) {
3772 if (SvTRUE(((SVOP*)first)->op_sv)) {
3783 else if (first->op_type == OP_WANTARRAY) {
3787 NewOp(1101, logop, 1, LOGOP);
3788 logop->op_type = OP_COND_EXPR;
3789 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3790 logop->op_first = first;
3791 logop->op_flags = flags | OPf_KIDS;
3792 logop->op_private = 1 | (flags >> 8);
3793 logop->op_other = LINKLIST(trueop);
3794 logop->op_next = LINKLIST(falseop);
3797 /* establish postfix order */
3798 start = LINKLIST(first);
3799 first->op_next = (OP*)logop;
3801 first->op_sibling = trueop;
3802 trueop->op_sibling = falseop;
3803 o = newUNOP(OP_NULL, 0, (OP*)logop);
3805 trueop->op_next = falseop->op_next = o;
3812 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3820 NewOp(1101, range, 1, LOGOP);
3822 range->op_type = OP_RANGE;
3823 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3824 range->op_first = left;
3825 range->op_flags = OPf_KIDS;
3826 leftstart = LINKLIST(left);
3827 range->op_other = LINKLIST(right);
3828 range->op_private = 1 | (flags >> 8);
3830 left->op_sibling = right;
3832 range->op_next = (OP*)range;
3833 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3834 flop = newUNOP(OP_FLOP, 0, flip);
3835 o = newUNOP(OP_NULL, 0, flop);
3837 range->op_next = leftstart;
3839 left->op_next = flip;
3840 right->op_next = flop;
3842 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3843 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3844 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3845 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3847 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3848 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3851 if (!flip->op_private || !flop->op_private)
3852 linklist(o); /* blow off optimizer unless constant */
3858 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3862 int once = block && block->op_flags & OPf_SPECIAL &&
3863 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3866 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3867 return block; /* do {} while 0 does once */
3868 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3869 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3870 expr = newUNOP(OP_DEFINED, 0,
3871 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3872 } else if (expr->op_flags & OPf_KIDS) {
3873 OP *k1 = ((UNOP*)expr)->op_first;
3874 OP *k2 = (k1) ? k1->op_sibling : NULL;
3875 switch (expr->op_type) {
3877 if (k2 && k2->op_type == OP_READLINE
3878 && (k2->op_flags & OPf_STACKED)
3879 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3880 expr = newUNOP(OP_DEFINED, 0, expr);
3884 if (k1->op_type == OP_READDIR
3885 || k1->op_type == OP_GLOB
3886 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3887 || k1->op_type == OP_EACH)
3888 expr = newUNOP(OP_DEFINED, 0, expr);
3894 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3895 o = new_logop(OP_AND, 0, &expr, &listop);
3898 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3900 if (once && o != listop)
3901 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3904 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3906 o->op_flags |= flags;
3908 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3913 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3922 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3923 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3924 expr = newUNOP(OP_DEFINED, 0,
3925 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3926 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3927 OP *k1 = ((UNOP*)expr)->op_first;
3928 OP *k2 = (k1) ? k1->op_sibling : NULL;
3929 switch (expr->op_type) {
3931 if (k2 && k2->op_type == OP_READLINE
3932 && (k2->op_flags & OPf_STACKED)
3933 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3934 expr = newUNOP(OP_DEFINED, 0, expr);
3938 if (k1->op_type == OP_READDIR
3939 || k1->op_type == OP_GLOB
3940 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3941 || k1->op_type == OP_EACH)
3942 expr = newUNOP(OP_DEFINED, 0, expr);
3948 block = newOP(OP_NULL, 0);
3950 block = scope(block);
3954 next = LINKLIST(cont);
3957 OP *unstack = newOP(OP_UNSTACK, 0);
3960 cont = append_elem(OP_LINESEQ, cont, unstack);
3961 if ((line_t)whileline != NOLINE) {
3962 PL_copline = whileline;
3963 cont = append_elem(OP_LINESEQ, cont,
3964 newSTATEOP(0, Nullch, Nullop));
3968 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3969 redo = LINKLIST(listop);
3972 PL_copline = whileline;
3974 o = new_logop(OP_AND, 0, &expr, &listop);
3975 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3976 op_free(expr); /* oops, it's a while (0) */
3978 return Nullop; /* listop already freed by new_logop */
3981 ((LISTOP*)listop)->op_last->op_next = condop =
3982 (o == listop ? redo : LINKLIST(o));
3988 NewOp(1101,loop,1,LOOP);
3989 loop->op_type = OP_ENTERLOOP;
3990 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3991 loop->op_private = 0;
3992 loop->op_next = (OP*)loop;
3995 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3997 loop->op_redoop = redo;
3998 loop->op_lastop = o;
3999 o->op_private |= loopflags;
4002 loop->op_nextop = next;
4004 loop->op_nextop = o;
4006 o->op_flags |= flags;
4007 o->op_private |= (flags >> 8);
4012 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4020 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4021 sv->op_type = OP_RV2GV;
4022 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4024 else if (sv->op_type == OP_PADSV) { /* private variable */
4025 padoff = sv->op_targ;
4030 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4031 padoff = sv->op_targ;
4033 iterflags |= OPf_SPECIAL;
4038 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4042 padoff = find_threadsv("_");
4043 iterflags |= OPf_SPECIAL;
4045 sv = newGVOP(OP_GV, 0, PL_defgv);
4048 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4049 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4050 iterflags |= OPf_STACKED;
4052 else if (expr->op_type == OP_NULL &&
4053 (expr->op_flags & OPf_KIDS) &&
4054 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4056 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4057 * set the STACKED flag to indicate that these values are to be
4058 * treated as min/max values by 'pp_iterinit'.
4060 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4061 LOGOP* range = (LOGOP*) flip->op_first;
4062 OP* left = range->op_first;
4063 OP* right = left->op_sibling;
4066 range->op_flags &= ~OPf_KIDS;
4067 range->op_first = Nullop;
4069 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4070 listop->op_first->op_next = range->op_next;
4071 left->op_next = range->op_other;
4072 right->op_next = (OP*)listop;
4073 listop->op_next = listop->op_first;
4076 expr = (OP*)(listop);
4078 iterflags |= OPf_STACKED;
4081 expr = mod(force_list(expr), OP_GREPSTART);
4085 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4086 append_elem(OP_LIST, expr, scalar(sv))));
4087 assert(!loop->op_next);
4088 #ifdef PL_OP_SLAB_ALLOC
4091 NewOp(1234,tmp,1,LOOP);
4092 Copy(loop,tmp,1,LOOP);
4096 Renew(loop, 1, LOOP);
4098 loop->op_targ = padoff;
4099 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4100 PL_copline = forline;
4101 return newSTATEOP(0, label, wop);
4105 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4110 if (type != OP_GOTO || label->op_type == OP_CONST) {
4111 /* "last()" means "last" */
4112 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4113 o = newOP(type, OPf_SPECIAL);
4115 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4116 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4122 if (label->op_type == OP_ENTERSUB)
4123 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4124 o = newUNOP(type, OPf_STACKED, label);
4126 PL_hints |= HINT_BLOCK_SCOPE;
4131 Perl_cv_undef(pTHX_ CV *cv)
4135 MUTEX_DESTROY(CvMUTEXP(cv));
4136 Safefree(CvMUTEXP(cv));
4139 #endif /* USE_THREADS */
4141 if (!CvXSUB(cv) && CvROOT(cv)) {
4143 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4144 Perl_croak(aTHX_ "Can't undef active subroutine");
4147 Perl_croak(aTHX_ "Can't undef active subroutine");
4148 #endif /* USE_THREADS */
4151 SAVEVPTR(PL_curpad);
4155 op_free(CvROOT(cv));
4156 CvROOT(cv) = Nullop;
4159 SvPOK_off((SV*)cv); /* forget prototype */
4161 SvREFCNT_dec(CvGV(cv));
4163 SvREFCNT_dec(CvOUTSIDE(cv));
4164 CvOUTSIDE(cv) = Nullcv;
4166 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4169 if (CvPADLIST(cv)) {
4170 /* may be during global destruction */
4171 if (SvREFCNT(CvPADLIST(cv))) {
4172 I32 i = AvFILLp(CvPADLIST(cv));
4174 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4175 SV* sv = svp ? *svp : Nullsv;
4178 if (sv == (SV*)PL_comppad_name)
4179 PL_comppad_name = Nullav;
4180 else if (sv == (SV*)PL_comppad) {
4181 PL_comppad = Nullav;
4182 PL_curpad = Null(SV**);
4186 SvREFCNT_dec((SV*)CvPADLIST(cv));
4188 CvPADLIST(cv) = Nullav;
4193 S_cv_dump(pTHX_ CV *cv)
4196 CV *outside = CvOUTSIDE(cv);
4197 AV* padlist = CvPADLIST(cv);
4204 PerlIO_printf(Perl_debug_log,
4205 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4207 (CvANON(cv) ? "ANON"
4208 : (cv == PL_main_cv) ? "MAIN"
4209 : CvUNIQUE(cv) ? "UNIQUE"
4210 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4213 : CvANON(outside) ? "ANON"
4214 : (outside == PL_main_cv) ? "MAIN"
4215 : CvUNIQUE(outside) ? "UNIQUE"
4216 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4221 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4222 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4223 pname = AvARRAY(pad_name);
4224 ppad = AvARRAY(pad);
4226 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4227 if (SvPOK(pname[ix]))
4228 PerlIO_printf(Perl_debug_log,
4229 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4230 (int)ix, PTR2UV(ppad[ix]),
4231 SvFAKE(pname[ix]) ? "FAKE " : "",
4233 (IV)I_32(SvNVX(pname[ix])),
4236 #endif /* DEBUGGING */
4240 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4244 AV* protopadlist = CvPADLIST(proto);
4245 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4246 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4247 SV** pname = AvARRAY(protopad_name);
4248 SV** ppad = AvARRAY(protopad);
4249 I32 fname = AvFILLp(protopad_name);
4250 I32 fpad = AvFILLp(protopad);
4254 assert(!CvUNIQUE(proto));
4258 SAVESPTR(PL_comppad_name);
4259 SAVESPTR(PL_compcv);
4261 cv = PL_compcv = (CV*)NEWSV(1104,0);
4262 sv_upgrade((SV *)cv, SvTYPE(proto));
4263 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4267 New(666, CvMUTEXP(cv), 1, perl_mutex);
4268 MUTEX_INIT(CvMUTEXP(cv));
4270 #endif /* USE_THREADS */
4271 CvFILE(cv) = CvFILE(proto);
4272 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4273 CvSTASH(cv) = CvSTASH(proto);
4274 CvROOT(cv) = CvROOT(proto);
4275 CvSTART(cv) = CvSTART(proto);
4277 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4280 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4282 PL_comppad_name = newAV();
4283 for (ix = fname; ix >= 0; ix--)
4284 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4286 PL_comppad = newAV();
4288 comppadlist = newAV();
4289 AvREAL_off(comppadlist);
4290 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4291 av_store(comppadlist, 1, (SV*)PL_comppad);
4292 CvPADLIST(cv) = comppadlist;
4293 av_fill(PL_comppad, AvFILLp(protopad));
4294 PL_curpad = AvARRAY(PL_comppad);
4296 av = newAV(); /* will be @_ */
4298 av_store(PL_comppad, 0, (SV*)av);
4299 AvFLAGS(av) = AVf_REIFY;
4301 for (ix = fpad; ix > 0; ix--) {
4302 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4303 if (namesv && namesv != &PL_sv_undef) {
4304 char *name = SvPVX(namesv); /* XXX */
4305 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4306 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4307 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4309 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4311 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4313 else { /* our own lexical */
4316 /* anon code -- we'll come back for it */
4317 sv = SvREFCNT_inc(ppad[ix]);
4319 else if (*name == '@')
4321 else if (*name == '%')
4330 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4331 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4334 SV* sv = NEWSV(0,0);
4340 /* Now that vars are all in place, clone nested closures. */
4342 for (ix = fpad; ix > 0; ix--) {
4343 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4345 && namesv != &PL_sv_undef
4346 && !(SvFLAGS(namesv) & SVf_FAKE)
4347 && *SvPVX(namesv) == '&'
4348 && CvCLONE(ppad[ix]))
4350 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4351 SvREFCNT_dec(ppad[ix]);
4354 PL_curpad[ix] = (SV*)kid;
4358 #ifdef DEBUG_CLOSURES
4359 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4361 PerlIO_printf(Perl_debug_log, " from:\n");
4363 PerlIO_printf(Perl_debug_log, " to:\n");
4370 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4372 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4374 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4381 Perl_cv_clone(pTHX_ CV *proto)
4384 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4385 cv = cv_clone2(proto, CvOUTSIDE(proto));
4386 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4391 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4393 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4394 SV* msg = sv_newmortal();
4398 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4399 sv_setpv(msg, "Prototype mismatch:");
4401 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4403 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4404 sv_catpv(msg, " vs ");
4406 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4408 sv_catpv(msg, "none");
4409 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4413 static void const_sv_xsub(pTHXo_ CV* cv);
4416 =for apidoc cv_const_sv
4418 If C<cv> is a constant sub eligible for inlining. returns the constant
4419 value returned by the sub. Otherwise, returns NULL.
4421 Constant subs can be created with C<newCONSTSUB> or as described in
4422 L<perlsub/"Constant Functions">.
4427 Perl_cv_const_sv(pTHX_ CV *cv)
4429 if (!cv || !CvCONST(cv))
4431 return (SV*)CvXSUBANY(cv).any_ptr;
4435 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4442 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4443 o = cLISTOPo->op_first->op_sibling;
4445 for (; o; o = o->op_next) {
4446 OPCODE type = o->op_type;
4448 if (sv && o->op_next == o)
4450 if (o->op_next != o) {
4451 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4453 if (type == OP_DBSTATE)
4456 if (type == OP_LEAVESUB || type == OP_RETURN)
4460 if (type == OP_CONST && cSVOPo->op_sv)
4462 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4463 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4464 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4468 /* We get here only from cv_clone2() while creating a closure.
4469 Copy the const value here instead of in cv_clone2 so that
4470 SvREADONLY_on doesn't lead to problems when leaving
4475 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4487 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4497 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4501 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4503 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4507 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4513 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4518 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4519 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4520 SV *sv = sv_newmortal();
4521 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4522 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4527 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4528 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4538 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4539 maximum a prototype before. */
4540 if (SvTYPE(gv) > SVt_NULL) {
4541 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4542 && ckWARN_d(WARN_PROTOTYPE))
4544 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4546 cv_ckproto((CV*)gv, NULL, ps);
4549 sv_setpv((SV*)gv, ps);
4551 sv_setiv((SV*)gv, -1);
4552 SvREFCNT_dec(PL_compcv);
4553 cv = PL_compcv = NULL;
4554 PL_sub_generation++;
4558 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4560 if (!block || !ps || *ps || attrs)
4563 const_sv = op_const_sv(block, Nullcv);
4566 bool exists = CvROOT(cv) || CvXSUB(cv);
4567 /* if the subroutine doesn't exist and wasn't pre-declared
4568 * with a prototype, assume it will be AUTOLOADed,
4569 * skipping the prototype check
4571 if (exists || SvPOK(cv))
4572 cv_ckproto(cv, gv, ps);
4573 /* already defined (or promised)? */
4574 if (exists || GvASSUMECV(gv)) {
4575 if (!block && !attrs) {
4576 /* just a "sub foo;" when &foo is already defined */
4577 SAVEFREESV(PL_compcv);
4580 /* ahem, death to those who redefine active sort subs */
4581 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4582 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4584 if (ckWARN(WARN_REDEFINE)
4586 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4588 line_t oldline = CopLINE(PL_curcop);
4589 CopLINE_set(PL_curcop, PL_copline);
4590 Perl_warner(aTHX_ WARN_REDEFINE,
4591 CvCONST(cv) ? "Constant subroutine %s redefined"
4592 : "Subroutine %s redefined", name);
4593 CopLINE_set(PL_curcop, oldline);
4601 SvREFCNT_inc(const_sv);
4603 assert(!CvROOT(cv) && !CvCONST(cv));
4604 sv_setpv((SV*)cv, ""); /* prototype is "" */
4605 CvXSUBANY(cv).any_ptr = const_sv;
4606 CvXSUB(cv) = const_sv_xsub;
4611 cv = newCONSTSUB(NULL, name, const_sv);
4614 SvREFCNT_dec(PL_compcv);
4616 PL_sub_generation++;
4623 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4624 * before we clobber PL_compcv.
4628 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4629 stash = GvSTASH(CvGV(cv));
4630 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4631 stash = CvSTASH(cv);
4633 stash = PL_curstash;
4636 /* possibly about to re-define existing subr -- ignore old cv */
4637 rcv = (SV*)PL_compcv;
4638 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4639 stash = GvSTASH(gv);
4641 stash = PL_curstash;
4643 apply_attrs(stash, rcv, attrs);
4645 if (cv) { /* must reuse cv if autoloaded */
4647 /* got here with just attrs -- work done, so bug out */
4648 SAVEFREESV(PL_compcv);
4652 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4653 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4654 CvOUTSIDE(PL_compcv) = 0;
4655 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4656 CvPADLIST(PL_compcv) = 0;
4657 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4658 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4659 SvREFCNT_dec(PL_compcv);
4666 PL_sub_generation++;
4669 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4670 CvFILE(cv) = CopFILE(PL_curcop);
4671 CvSTASH(cv) = PL_curstash;
4674 if (!CvMUTEXP(cv)) {
4675 New(666, CvMUTEXP(cv), 1, perl_mutex);
4676 MUTEX_INIT(CvMUTEXP(cv));
4678 #endif /* USE_THREADS */
4681 sv_setpv((SV*)cv, ps);
4683 if (PL_error_count) {
4687 char *s = strrchr(name, ':');
4689 if (strEQ(s, "BEGIN")) {
4691 "BEGIN not safe after errors--compilation aborted";
4692 if (PL_in_eval & EVAL_KEEPERR)
4693 Perl_croak(aTHX_ not_safe);
4695 /* force display of errors found but not reported */
4696 sv_catpv(ERRSV, not_safe);
4697 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4705 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4706 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4709 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4710 mod(scalarseq(block), OP_LEAVESUBLV));
4713 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4715 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4716 OpREFCNT_set(CvROOT(cv), 1);
4717 CvSTART(cv) = LINKLIST(CvROOT(cv));
4718 CvROOT(cv)->op_next = 0;
4721 /* now that optimizer has done its work, adjust pad values */
4723 SV **namep = AvARRAY(PL_comppad_name);
4724 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4727 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4730 * The only things that a clonable function needs in its
4731 * pad are references to outer lexicals and anonymous subs.
4732 * The rest are created anew during cloning.
4734 if (!((namesv = namep[ix]) != Nullsv &&
4735 namesv != &PL_sv_undef &&
4737 *SvPVX(namesv) == '&')))
4739 SvREFCNT_dec(PL_curpad[ix]);
4740 PL_curpad[ix] = Nullsv;
4743 assert(!CvCONST(cv));
4744 if (ps && !*ps && op_const_sv(block, cv))
4748 AV *av = newAV(); /* Will be @_ */
4750 av_store(PL_comppad, 0, (SV*)av);
4751 AvFLAGS(av) = AVf_REIFY;
4753 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4754 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4756 if (!SvPADMY(PL_curpad[ix]))
4757 SvPADTMP_on(PL_curpad[ix]);
4761 if (name || aname) {
4763 char *tname = (name ? name : aname);
4765 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4766 SV *sv = NEWSV(0,0);
4767 SV *tmpstr = sv_newmortal();
4768 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4772 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4774 (long)PL_subline, (long)CopLINE(PL_curcop));
4775 gv_efullname3(tmpstr, gv, Nullch);
4776 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4777 hv = GvHVn(db_postponed);
4778 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4779 && (pcv = GvCV(db_postponed)))
4785 call_sv((SV*)pcv, G_DISCARD);
4789 if ((s = strrchr(tname,':')))
4794 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4797 if (strEQ(s, "BEGIN")) {
4798 I32 oldscope = PL_scopestack_ix;
4800 SAVECOPFILE(&PL_compiling);
4801 SAVECOPLINE(&PL_compiling);
4803 sv_setsv(PL_rs, PL_nrs);
4806 PL_beginav = newAV();
4807 DEBUG_x( dump_sub(gv) );
4808 av_push(PL_beginav, (SV*)cv);
4809 GvCV(gv) = 0; /* cv has been hijacked */
4810 call_list(oldscope, PL_beginav);
4812 PL_curcop = &PL_compiling;
4813 PL_compiling.op_private = PL_hints;
4816 else if (strEQ(s, "END") && !PL_error_count) {
4819 DEBUG_x( dump_sub(gv) );
4820 av_unshift(PL_endav, 1);
4821 av_store(PL_endav, 0, (SV*)cv);
4822 GvCV(gv) = 0; /* cv has been hijacked */
4824 else if (strEQ(s, "CHECK") && !PL_error_count) {
4826 PL_checkav = newAV();
4827 DEBUG_x( dump_sub(gv) );
4828 if (PL_main_start && ckWARN(WARN_VOID))
4829 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4830 av_unshift(PL_checkav, 1);
4831 av_store(PL_checkav, 0, (SV*)cv);
4832 GvCV(gv) = 0; /* cv has been hijacked */
4834 else if (strEQ(s, "INIT") && !PL_error_count) {
4836 PL_initav = newAV();
4837 DEBUG_x( dump_sub(gv) );
4838 if (PL_main_start && ckWARN(WARN_VOID))
4839 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4840 av_push(PL_initav, (SV*)cv);
4841 GvCV(gv) = 0; /* cv has been hijacked */
4846 PL_copline = NOLINE;
4851 /* XXX unsafe for threads if eval_owner isn't held */
4853 =for apidoc newCONSTSUB
4855 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4856 eligible for inlining at compile-time.
4862 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4868 SAVECOPLINE(PL_curcop);
4869 CopLINE_set(PL_curcop, PL_copline);
4872 PL_hints &= ~HINT_BLOCK_SCOPE;
4875 SAVESPTR(PL_curstash);
4876 SAVECOPSTASH(PL_curcop);
4877 PL_curstash = stash;
4879 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4881 CopSTASH(PL_curcop) = stash;
4885 cv = newXS(name, const_sv_xsub, __FILE__);
4886 CvXSUBANY(cv).any_ptr = sv;
4888 sv_setpv((SV*)cv, ""); /* prototype is "" */
4896 =for apidoc U||newXS
4898 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4904 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4906 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4909 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4911 /* just a cached method */
4915 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4916 /* already defined (or promised) */
4917 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4918 && HvNAME(GvSTASH(CvGV(cv)))
4919 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4920 line_t oldline = CopLINE(PL_curcop);
4921 if (PL_copline != NOLINE)
4922 CopLINE_set(PL_curcop, PL_copline);
4923 Perl_warner(aTHX_ WARN_REDEFINE,
4924 CvCONST(cv) ? "Constant subroutine %s redefined"
4925 : "Subroutine %s redefined"
4927 CopLINE_set(PL_curcop, oldline);
4934 if (cv) /* must reuse cv if autoloaded */
4937 cv = (CV*)NEWSV(1105,0);
4938 sv_upgrade((SV *)cv, SVt_PVCV);
4942 PL_sub_generation++;
4945 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4947 New(666, CvMUTEXP(cv), 1, perl_mutex);
4948 MUTEX_INIT(CvMUTEXP(cv));
4950 #endif /* USE_THREADS */
4951 (void)gv_fetchfile(filename);
4952 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4953 an external constant string */
4954 CvXSUB(cv) = subaddr;
4957 char *s = strrchr(name,':');
4963 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4966 if (strEQ(s, "BEGIN")) {
4968 PL_beginav = newAV();
4969 av_push(PL_beginav, (SV*)cv);
4970 GvCV(gv) = 0; /* cv has been hijacked */
4972 else if (strEQ(s, "END")) {
4975 av_unshift(PL_endav, 1);
4976 av_store(PL_endav, 0, (SV*)cv);
4977 GvCV(gv) = 0; /* cv has been hijacked */
4979 else if (strEQ(s, "CHECK")) {
4981 PL_checkav = newAV();
4982 if (PL_main_start && ckWARN(WARN_VOID))
4983 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4984 av_unshift(PL_checkav, 1);
4985 av_store(PL_checkav, 0, (SV*)cv);
4986 GvCV(gv) = 0; /* cv has been hijacked */
4988 else if (strEQ(s, "INIT")) {
4990 PL_initav = newAV();
4991 if (PL_main_start && ckWARN(WARN_VOID))
4992 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4993 av_push(PL_initav, (SV*)cv);
4994 GvCV(gv) = 0; /* cv has been hijacked */
5005 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5014 name = SvPVx(cSVOPo->op_sv, n_a);
5017 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5019 if ((cv = GvFORM(gv))) {
5020 if (ckWARN(WARN_REDEFINE)) {
5021 line_t oldline = CopLINE(PL_curcop);
5023 CopLINE_set(PL_curcop, PL_copline);
5024 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5025 CopLINE_set(PL_curcop, oldline);
5031 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
5032 CvFILE(cv) = CopFILE(PL_curcop);
5034 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5035 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5036 SvPADTMP_on(PL_curpad[ix]);
5039 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5040 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5041 OpREFCNT_set(CvROOT(cv), 1);
5042 CvSTART(cv) = LINKLIST(CvROOT(cv));
5043 CvROOT(cv)->op_next = 0;
5046 PL_copline = NOLINE;
5051 Perl_newANONLIST(pTHX_ OP *o)
5053 return newUNOP(OP_REFGEN, 0,
5054 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5058 Perl_newANONHASH(pTHX_ OP *o)
5060 return newUNOP(OP_REFGEN, 0,
5061 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5065 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5067 return newANONATTRSUB(floor, proto, Nullop, block);
5071 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5073 return newUNOP(OP_REFGEN, 0,
5074 newSVOP(OP_ANONCODE, 0,
5075 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5079 Perl_oopsAV(pTHX_ OP *o)
5081 switch (o->op_type) {
5083 o->op_type = OP_PADAV;
5084 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5085 return ref(o, OP_RV2AV);
5088 o->op_type = OP_RV2AV;
5089 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5094 if (ckWARN_d(WARN_INTERNAL))
5095 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5102 Perl_oopsHV(pTHX_ OP *o)
5104 switch (o->op_type) {
5107 o->op_type = OP_PADHV;
5108 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5109 return ref(o, OP_RV2HV);
5113 o->op_type = OP_RV2HV;
5114 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5119 if (ckWARN_d(WARN_INTERNAL))
5120 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5127 Perl_newAVREF(pTHX_ OP *o)
5129 if (o->op_type == OP_PADANY) {
5130 o->op_type = OP_PADAV;
5131 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5134 return newUNOP(OP_RV2AV, 0, scalar(o));
5138 Perl_newGVREF(pTHX_ I32 type, OP *o)
5140 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5141 return newUNOP(OP_NULL, 0, o);
5142 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5146 Perl_newHVREF(pTHX_ OP *o)
5148 if (o->op_type == OP_PADANY) {
5149 o->op_type = OP_PADHV;
5150 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5153 return newUNOP(OP_RV2HV, 0, scalar(o));
5157 Perl_oopsCV(pTHX_ OP *o)
5159 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5165 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5167 return newUNOP(OP_RV2CV, flags, scalar(o));
5171 Perl_newSVREF(pTHX_ OP *o)
5173 if (o->op_type == OP_PADANY) {
5174 o->op_type = OP_PADSV;
5175 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5178 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5179 o->op_flags |= OPpDONE_SVREF;
5182 return newUNOP(OP_RV2SV, 0, scalar(o));
5185 /* Check routines. */
5188 Perl_ck_anoncode(pTHX_ OP *o)
5193 name = NEWSV(1106,0);
5194 sv_upgrade(name, SVt_PVNV);
5195 sv_setpvn(name, "&", 1);
5198 ix = pad_alloc(o->op_type, SVs_PADMY);
5199 av_store(PL_comppad_name, ix, name);
5200 av_store(PL_comppad, ix, cSVOPo->op_sv);
5201 SvPADMY_on(cSVOPo->op_sv);
5202 cSVOPo->op_sv = Nullsv;
5203 cSVOPo->op_targ = ix;
5208 Perl_ck_bitop(pTHX_ OP *o)
5210 o->op_private = PL_hints;
5215 Perl_ck_concat(pTHX_ OP *o)
5217 if (cUNOPo->op_first->op_type == OP_CONCAT)
5218 o->op_flags |= OPf_STACKED;
5223 Perl_ck_spair(pTHX_ OP *o)
5225 if (o->op_flags & OPf_KIDS) {
5228 OPCODE type = o->op_type;
5229 o = modkids(ck_fun(o), type);
5230 kid = cUNOPo->op_first;
5231 newop = kUNOP->op_first->op_sibling;
5233 (newop->op_sibling ||
5234 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5235 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5236 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5240 op_free(kUNOP->op_first);
5241 kUNOP->op_first = newop;
5243 o->op_ppaddr = PL_ppaddr[++o->op_type];
5248 Perl_ck_delete(pTHX_ OP *o)
5252 if (o->op_flags & OPf_KIDS) {
5253 OP *kid = cUNOPo->op_first;
5254 switch (kid->op_type) {
5256 o->op_flags |= OPf_SPECIAL;
5259 o->op_private |= OPpSLICE;
5262 o->op_flags |= OPf_SPECIAL;
5267 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5268 PL_op_desc[o->op_type]);
5276 Perl_ck_eof(pTHX_ OP *o)
5278 I32 type = o->op_type;
5280 if (o->op_flags & OPf_KIDS) {
5281 if (cLISTOPo->op_first->op_type == OP_STUB) {
5283 o = newUNOP(type, OPf_SPECIAL,
5284 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5292 Perl_ck_eval(pTHX_ OP *o)
5294 PL_hints |= HINT_BLOCK_SCOPE;
5295 if (o->op_flags & OPf_KIDS) {
5296 SVOP *kid = (SVOP*)cUNOPo->op_first;
5299 o->op_flags &= ~OPf_KIDS;
5302 else if (kid->op_type == OP_LINESEQ) {
5305 kid->op_next = o->op_next;
5306 cUNOPo->op_first = 0;
5309 NewOp(1101, enter, 1, LOGOP);
5310 enter->op_type = OP_ENTERTRY;
5311 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5312 enter->op_private = 0;
5314 /* establish postfix order */
5315 enter->op_next = (OP*)enter;
5317 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5318 o->op_type = OP_LEAVETRY;
5319 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5320 enter->op_other = o;
5328 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5330 o->op_targ = (PADOFFSET)PL_hints;
5335 Perl_ck_exit(pTHX_ OP *o)
5338 HV *table = GvHV(PL_hintgv);
5340 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5341 if (svp && *svp && SvTRUE(*svp))
5342 o->op_private |= OPpEXIT_VMSISH;
5349 Perl_ck_exec(pTHX_ OP *o)
5352 if (o->op_flags & OPf_STACKED) {
5354 kid = cUNOPo->op_first->op_sibling;
5355 if (kid->op_type == OP_RV2GV)
5364 Perl_ck_exists(pTHX_ OP *o)
5367 if (o->op_flags & OPf_KIDS) {
5368 OP *kid = cUNOPo->op_first;
5369 if (kid->op_type == OP_ENTERSUB) {
5370 (void) ref(kid, o->op_type);
5371 if (kid->op_type != OP_RV2CV && !PL_error_count)
5372 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5373 PL_op_desc[o->op_type]);
5374 o->op_private |= OPpEXISTS_SUB;
5376 else if (kid->op_type == OP_AELEM)
5377 o->op_flags |= OPf_SPECIAL;
5378 else if (kid->op_type != OP_HELEM)
5379 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5380 PL_op_desc[o->op_type]);
5388 Perl_ck_gvconst(pTHX_ register OP *o)
5390 o = fold_constants(o);
5391 if (o->op_type == OP_CONST)
5398 Perl_ck_rvconst(pTHX_ register OP *o)
5400 SVOP *kid = (SVOP*)cUNOPo->op_first;
5402 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5403 if (kid->op_type == OP_CONST) {
5407 SV *kidsv = kid->op_sv;
5410 /* Is it a constant from cv_const_sv()? */
5411 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5412 SV *rsv = SvRV(kidsv);
5413 int svtype = SvTYPE(rsv);
5414 char *badtype = Nullch;
5416 switch (o->op_type) {
5418 if (svtype > SVt_PVMG)
5419 badtype = "a SCALAR";
5422 if (svtype != SVt_PVAV)
5423 badtype = "an ARRAY";
5426 if (svtype != SVt_PVHV) {
5427 if (svtype == SVt_PVAV) { /* pseudohash? */
5428 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5429 if (ksv && SvROK(*ksv)
5430 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5439 if (svtype != SVt_PVCV)
5444 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5447 name = SvPV(kidsv, n_a);
5448 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5449 char *badthing = Nullch;
5450 switch (o->op_type) {
5452 badthing = "a SCALAR";
5455 badthing = "an ARRAY";
5458 badthing = "a HASH";
5463 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5467 * This is a little tricky. We only want to add the symbol if we
5468 * didn't add it in the lexer. Otherwise we get duplicate strict
5469 * warnings. But if we didn't add it in the lexer, we must at
5470 * least pretend like we wanted to add it even if it existed before,
5471 * or we get possible typo warnings. OPpCONST_ENTERED says
5472 * whether the lexer already added THIS instance of this symbol.
5474 iscv = (o->op_type == OP_RV2CV) * 2;
5476 gv = gv_fetchpv(name,
5477 iscv | !(kid->op_private & OPpCONST_ENTERED),
5480 : o->op_type == OP_RV2SV
5482 : o->op_type == OP_RV2AV
5484 : o->op_type == OP_RV2HV
5487 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5489 kid->op_type = OP_GV;
5490 SvREFCNT_dec(kid->op_sv);
5492 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5493 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5494 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5496 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5498 kid->op_sv = SvREFCNT_inc(gv);
5500 kid->op_private = 0;
5501 kid->op_ppaddr = PL_ppaddr[OP_GV];
5508 Perl_ck_ftst(pTHX_ OP *o)
5510 I32 type = o->op_type;
5512 if (o->op_flags & OPf_REF) {
5515 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5516 SVOP *kid = (SVOP*)cUNOPo->op_first;
5518 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5520 OP *newop = newGVOP(type, OPf_REF,
5521 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5528 if (type == OP_FTTTY)
5529 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5532 o = newUNOP(type, 0, newDEFSVOP());
5535 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5537 if (PL_hints & HINT_LOCALE)
5538 o->op_private |= OPpLOCALE;
5545 Perl_ck_fun(pTHX_ OP *o)
5551 int type = o->op_type;
5552 register I32 oa = PL_opargs[type] >> OASHIFT;
5554 if (o->op_flags & OPf_STACKED) {
5555 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5558 return no_fh_allowed(o);
5561 if (o->op_flags & OPf_KIDS) {
5563 tokid = &cLISTOPo->op_first;
5564 kid = cLISTOPo->op_first;
5565 if (kid->op_type == OP_PUSHMARK ||
5566 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5568 tokid = &kid->op_sibling;
5569 kid = kid->op_sibling;
5571 if (!kid && PL_opargs[type] & OA_DEFGV)
5572 *tokid = kid = newDEFSVOP();
5576 sibl = kid->op_sibling;
5579 /* list seen where single (scalar) arg expected? */
5580 if (numargs == 1 && !(oa >> 4)
5581 && kid->op_type == OP_LIST && type != OP_SCALAR)
5583 return too_many_arguments(o,PL_op_desc[type]);
5596 if (kid->op_type == OP_CONST &&
5597 (kid->op_private & OPpCONST_BARE))
5599 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5600 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5601 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5602 if (ckWARN(WARN_DEPRECATED))
5603 Perl_warner(aTHX_ WARN_DEPRECATED,
5604 "Array @%s missing the @ in argument %"IVdf" of %s()",
5605 name, (IV)numargs, PL_op_desc[type]);
5608 kid->op_sibling = sibl;
5611 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5612 bad_type(numargs, "array", PL_op_desc[type], kid);
5616 if (kid->op_type == OP_CONST &&
5617 (kid->op_private & OPpCONST_BARE))
5619 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5620 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5621 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5622 if (ckWARN(WARN_DEPRECATED))
5623 Perl_warner(aTHX_ WARN_DEPRECATED,
5624 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5625 name, (IV)numargs, PL_op_desc[type]);
5628 kid->op_sibling = sibl;
5631 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5632 bad_type(numargs, "hash", PL_op_desc[type], kid);
5637 OP *newop = newUNOP(OP_NULL, 0, kid);
5638 kid->op_sibling = 0;
5640 newop->op_next = newop;
5642 kid->op_sibling = sibl;
5647 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5648 if (kid->op_type == OP_CONST &&
5649 (kid->op_private & OPpCONST_BARE))
5651 OP *newop = newGVOP(OP_GV, 0,
5652 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5657 else if (kid->op_type == OP_READLINE) {
5658 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5659 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5662 I32 flags = OPf_SPECIAL;
5666 /* is this op a FH constructor? */
5667 if (is_handle_constructor(o,numargs)) {
5668 char *name = Nullch;
5672 /* Set a flag to tell rv2gv to vivify
5673 * need to "prove" flag does not mean something
5674 * else already - NI-S 1999/05/07
5677 if (kid->op_type == OP_PADSV) {
5678 SV **namep = av_fetch(PL_comppad_name,
5680 if (namep && *namep)
5681 name = SvPV(*namep, len);
5683 else if (kid->op_type == OP_RV2SV
5684 && kUNOP->op_first->op_type == OP_GV)
5686 GV *gv = cGVOPx_gv(kUNOP->op_first);
5688 len = GvNAMELEN(gv);
5690 else if (kid->op_type == OP_AELEM
5691 || kid->op_type == OP_HELEM)
5693 name = "__ANONIO__";
5699 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5700 namesv = PL_curpad[targ];
5701 (void)SvUPGRADE(namesv, SVt_PV);
5703 sv_setpvn(namesv, "$", 1);
5704 sv_catpvn(namesv, name, len);
5707 kid->op_sibling = 0;
5708 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5709 kid->op_targ = targ;
5710 kid->op_private |= priv;
5712 kid->op_sibling = sibl;
5718 mod(scalar(kid), type);
5722 tokid = &kid->op_sibling;
5723 kid = kid->op_sibling;
5725 o->op_private |= numargs;
5727 return too_many_arguments(o,PL_op_desc[o->op_type]);
5730 else if (PL_opargs[type] & OA_DEFGV) {
5732 return newUNOP(type, 0, newDEFSVOP());
5736 while (oa & OA_OPTIONAL)
5738 if (oa && oa != OA_LIST)
5739 return too_few_arguments(o,PL_op_desc[o->op_type]);
5745 Perl_ck_glob(pTHX_ OP *o)
5750 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5751 append_elem(OP_GLOB, o, newDEFSVOP());
5753 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5754 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5756 #if !defined(PERL_EXTERNAL_GLOB)
5757 /* XXX this can be tightened up and made more failsafe. */
5760 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5761 /* null-terminated import list */
5762 newSVpvn(":globally", 9), Nullsv);
5763 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5766 #endif /* PERL_EXTERNAL_GLOB */
5768 if (gv && GvIMPORTED_CV(gv)) {
5769 append_elem(OP_GLOB, o,
5770 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5771 o->op_type = OP_LIST;
5772 o->op_ppaddr = PL_ppaddr[OP_LIST];
5773 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5774 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5775 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5776 append_elem(OP_LIST, o,
5777 scalar(newUNOP(OP_RV2CV, 0,
5778 newGVOP(OP_GV, 0, gv)))));
5779 o = newUNOP(OP_NULL, 0, ck_subr(o));
5780 o->op_targ = OP_GLOB; /* hint at what it used to be */
5783 gv = newGVgen("main");
5785 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5791 Perl_ck_grep(pTHX_ OP *o)
5795 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5797 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5798 NewOp(1101, gwop, 1, LOGOP);
5800 if (o->op_flags & OPf_STACKED) {
5803 kid = cLISTOPo->op_first->op_sibling;
5804 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5807 kid->op_next = (OP*)gwop;
5808 o->op_flags &= ~OPf_STACKED;
5810 kid = cLISTOPo->op_first->op_sibling;
5811 if (type == OP_MAPWHILE)
5818 kid = cLISTOPo->op_first->op_sibling;
5819 if (kid->op_type != OP_NULL)
5820 Perl_croak(aTHX_ "panic: ck_grep");
5821 kid = kUNOP->op_first;
5823 gwop->op_type = type;
5824 gwop->op_ppaddr = PL_ppaddr[type];
5825 gwop->op_first = listkids(o);
5826 gwop->op_flags |= OPf_KIDS;
5827 gwop->op_private = 1;
5828 gwop->op_other = LINKLIST(kid);
5829 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5830 kid->op_next = (OP*)gwop;
5832 kid = cLISTOPo->op_first->op_sibling;
5833 if (!kid || !kid->op_sibling)
5834 return too_few_arguments(o,PL_op_desc[o->op_type]);
5835 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5836 mod(kid, OP_GREPSTART);
5842 Perl_ck_index(pTHX_ OP *o)
5844 if (o->op_flags & OPf_KIDS) {
5845 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5847 kid = kid->op_sibling; /* get past "big" */
5848 if (kid && kid->op_type == OP_CONST)
5849 fbm_compile(((SVOP*)kid)->op_sv, 0);
5855 Perl_ck_lengthconst(pTHX_ OP *o)
5857 /* XXX length optimization goes here */
5862 Perl_ck_lfun(pTHX_ OP *o)
5864 OPCODE type = o->op_type;
5865 return modkids(ck_fun(o), type);
5869 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5871 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5872 switch (cUNOPo->op_first->op_type) {
5874 /* This is needed for
5875 if (defined %stash::)
5876 to work. Do not break Tk.
5878 break; /* Globals via GV can be undef */
5880 case OP_AASSIGN: /* Is this a good idea? */
5881 Perl_warner(aTHX_ WARN_DEPRECATED,
5882 "defined(@array) is deprecated");
5883 Perl_warner(aTHX_ WARN_DEPRECATED,
5884 "\t(Maybe you should just omit the defined()?)\n");
5887 /* This is needed for
5888 if (defined %stash::)
5889 to work. Do not break Tk.
5891 break; /* Globals via GV can be undef */
5893 Perl_warner(aTHX_ WARN_DEPRECATED,
5894 "defined(%%hash) is deprecated");
5895 Perl_warner(aTHX_ WARN_DEPRECATED,
5896 "\t(Maybe you should just omit the defined()?)\n");
5907 Perl_ck_rfun(pTHX_ OP *o)
5909 OPCODE type = o->op_type;
5910 return refkids(ck_fun(o), type);
5914 Perl_ck_listiob(pTHX_ OP *o)
5918 kid = cLISTOPo->op_first;
5921 kid = cLISTOPo->op_first;
5923 if (kid->op_type == OP_PUSHMARK)
5924 kid = kid->op_sibling;
5925 if (kid && o->op_flags & OPf_STACKED)
5926 kid = kid->op_sibling;
5927 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5928 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5929 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5930 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5931 cLISTOPo->op_first->op_sibling = kid;
5932 cLISTOPo->op_last = kid;
5933 kid = kid->op_sibling;
5938 append_elem(o->op_type, o, newDEFSVOP());
5944 if (PL_hints & HINT_LOCALE)
5945 o->op_private |= OPpLOCALE;
5952 Perl_ck_fun_locale(pTHX_ OP *o)
5958 if (PL_hints & HINT_LOCALE)
5959 o->op_private |= OPpLOCALE;
5966 Perl_ck_sassign(pTHX_ OP *o)
5968 OP *kid = cLISTOPo->op_first;
5969 /* has a disposable target? */
5970 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5971 && !(kid->op_flags & OPf_STACKED)
5972 /* Cannot steal the second time! */
5973 && !(kid->op_private & OPpTARGET_MY))
5975 OP *kkid = kid->op_sibling;
5977 /* Can just relocate the target. */
5978 if (kkid && kkid->op_type == OP_PADSV
5979 && !(kkid->op_private & OPpLVAL_INTRO))
5981 kid->op_targ = kkid->op_targ;
5983 /* Now we do not need PADSV and SASSIGN. */
5984 kid->op_sibling = o->op_sibling; /* NULL */
5985 cLISTOPo->op_first = NULL;
5988 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5996 Perl_ck_scmp(pTHX_ OP *o)
6000 if (PL_hints & HINT_LOCALE)
6001 o->op_private |= OPpLOCALE;
6008 Perl_ck_match(pTHX_ OP *o)
6010 o->op_private |= OPpRUNTIME;
6015 Perl_ck_method(pTHX_ OP *o)
6017 OP *kid = cUNOPo->op_first;
6018 if (kid->op_type == OP_CONST) {
6019 SV* sv = kSVOP->op_sv;
6020 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6022 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6023 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6026 kSVOP->op_sv = Nullsv;
6028 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6037 Perl_ck_null(pTHX_ OP *o)
6043 Perl_ck_open(pTHX_ OP *o)
6045 HV *table = GvHV(PL_hintgv);
6049 svp = hv_fetch(table, "open_IN", 7, FALSE);
6051 mode = mode_from_discipline(*svp);
6052 if (mode & O_BINARY)
6053 o->op_private |= OPpOPEN_IN_RAW;
6054 else if (mode & O_TEXT)
6055 o->op_private |= OPpOPEN_IN_CRLF;
6058 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6060 mode = mode_from_discipline(*svp);
6061 if (mode & O_BINARY)
6062 o->op_private |= OPpOPEN_OUT_RAW;
6063 else if (mode & O_TEXT)
6064 o->op_private |= OPpOPEN_OUT_CRLF;
6067 if (o->op_type == OP_BACKTICK)
6073 Perl_ck_repeat(pTHX_ OP *o)
6075 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6076 o->op_private |= OPpREPEAT_DOLIST;
6077 cBINOPo->op_first = force_list(cBINOPo->op_first);
6085 Perl_ck_require(pTHX_ OP *o)
6087 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6088 SVOP *kid = (SVOP*)cUNOPo->op_first;
6090 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6092 for (s = SvPVX(kid->op_sv); *s; s++) {
6093 if (*s == ':' && s[1] == ':') {
6095 Move(s+2, s+1, strlen(s+2)+1, char);
6096 --SvCUR(kid->op_sv);
6099 if (SvREADONLY(kid->op_sv)) {
6100 SvREADONLY_off(kid->op_sv);
6101 sv_catpvn(kid->op_sv, ".pm", 3);
6102 SvREADONLY_on(kid->op_sv);
6105 sv_catpvn(kid->op_sv, ".pm", 3);
6112 Perl_ck_return(pTHX_ OP *o)
6115 if (CvLVALUE(PL_compcv)) {
6116 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6117 mod(kid, OP_LEAVESUBLV);
6124 Perl_ck_retarget(pTHX_ OP *o)
6126 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6133 Perl_ck_select(pTHX_ OP *o)
6136 if (o->op_flags & OPf_KIDS) {
6137 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6138 if (kid && kid->op_sibling) {
6139 o->op_type = OP_SSELECT;
6140 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6142 return fold_constants(o);
6146 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6147 if (kid && kid->op_type == OP_RV2GV)
6148 kid->op_private &= ~HINT_STRICT_REFS;
6153 Perl_ck_shift(pTHX_ OP *o)
6155 I32 type = o->op_type;
6157 if (!(o->op_flags & OPf_KIDS)) {
6162 if (!CvUNIQUE(PL_compcv)) {
6163 argop = newOP(OP_PADAV, OPf_REF);
6164 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6167 argop = newUNOP(OP_RV2AV, 0,
6168 scalar(newGVOP(OP_GV, 0,
6169 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6172 argop = newUNOP(OP_RV2AV, 0,
6173 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6174 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6175 #endif /* USE_THREADS */
6176 return newUNOP(type, 0, scalar(argop));
6178 return scalar(modkids(ck_fun(o), type));
6182 Perl_ck_sort(pTHX_ OP *o)
6187 if (PL_hints & HINT_LOCALE)
6188 o->op_private |= OPpLOCALE;
6191 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6193 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6194 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6196 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6198 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6200 if (kid->op_type == OP_SCOPE) {
6204 else if (kid->op_type == OP_LEAVE) {
6205 if (o->op_type == OP_SORT) {
6206 null(kid); /* wipe out leave */
6209 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6210 if (k->op_next == kid)
6212 /* don't descend into loops */
6213 else if (k->op_type == OP_ENTERLOOP
6214 || k->op_type == OP_ENTERITER)
6216 k = cLOOPx(k)->op_lastop;
6221 kid->op_next = 0; /* just disconnect the leave */
6222 k = kLISTOP->op_first;
6227 if (o->op_type == OP_SORT) {
6228 /* provide scalar context for comparison function/block */
6234 o->op_flags |= OPf_SPECIAL;
6236 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6239 firstkid = firstkid->op_sibling;
6242 /* provide list context for arguments */
6243 if (o->op_type == OP_SORT)
6250 S_simplify_sort(pTHX_ OP *o)
6252 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6256 if (!(o->op_flags & OPf_STACKED))
6258 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6259 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6260 kid = kUNOP->op_first; /* get past null */
6261 if (kid->op_type != OP_SCOPE)
6263 kid = kLISTOP->op_last; /* get past scope */
6264 switch(kid->op_type) {
6272 k = kid; /* remember this node*/
6273 if (kBINOP->op_first->op_type != OP_RV2SV)
6275 kid = kBINOP->op_first; /* get past cmp */
6276 if (kUNOP->op_first->op_type != OP_GV)
6278 kid = kUNOP->op_first; /* get past rv2sv */
6280 if (GvSTASH(gv) != PL_curstash)
6282 if (strEQ(GvNAME(gv), "a"))
6284 else if (strEQ(GvNAME(gv), "b"))
6288 kid = k; /* back to cmp */
6289 if (kBINOP->op_last->op_type != OP_RV2SV)
6291 kid = kBINOP->op_last; /* down to 2nd arg */
6292 if (kUNOP->op_first->op_type != OP_GV)
6294 kid = kUNOP->op_first; /* get past rv2sv */
6296 if (GvSTASH(gv) != PL_curstash
6298 ? strNE(GvNAME(gv), "a")
6299 : strNE(GvNAME(gv), "b")))
6301 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6303 o->op_private |= OPpSORT_REVERSE;
6304 if (k->op_type == OP_NCMP)
6305 o->op_private |= OPpSORT_NUMERIC;
6306 if (k->op_type == OP_I_NCMP)
6307 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6308 kid = cLISTOPo->op_first->op_sibling;
6309 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6310 op_free(kid); /* then delete it */
6311 cLISTOPo->op_children--;
6315 Perl_ck_split(pTHX_ OP *o)
6319 if (o->op_flags & OPf_STACKED)
6320 return no_fh_allowed(o);
6322 kid = cLISTOPo->op_first;
6323 if (kid->op_type != OP_NULL)
6324 Perl_croak(aTHX_ "panic: ck_split");
6325 kid = kid->op_sibling;
6326 op_free(cLISTOPo->op_first);
6327 cLISTOPo->op_first = kid;
6329 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6330 cLISTOPo->op_last = kid; /* There was only one element previously */
6333 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6334 OP *sibl = kid->op_sibling;
6335 kid->op_sibling = 0;
6336 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6337 if (cLISTOPo->op_first == cLISTOPo->op_last)
6338 cLISTOPo->op_last = kid;
6339 cLISTOPo->op_first = kid;
6340 kid->op_sibling = sibl;
6343 kid->op_type = OP_PUSHRE;
6344 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6347 if (!kid->op_sibling)
6348 append_elem(OP_SPLIT, o, newDEFSVOP());
6350 kid = kid->op_sibling;
6353 if (!kid->op_sibling)
6354 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6356 kid = kid->op_sibling;
6359 if (kid->op_sibling)
6360 return too_many_arguments(o,PL_op_desc[o->op_type]);
6366 Perl_ck_join(pTHX_ OP *o)
6368 if (ckWARN(WARN_SYNTAX)) {
6369 OP *kid = cLISTOPo->op_first->op_sibling;
6370 if (kid && kid->op_type == OP_MATCH) {
6371 char *pmstr = "STRING";
6372 if (kPMOP->op_pmregexp)
6373 pmstr = kPMOP->op_pmregexp->precomp;
6374 Perl_warner(aTHX_ WARN_SYNTAX,
6375 "/%s/ should probably be written as \"%s\"",
6383 Perl_ck_subr(pTHX_ OP *o)
6385 OP *prev = ((cUNOPo->op_first->op_sibling)
6386 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6387 OP *o2 = prev->op_sibling;
6396 o->op_private |= OPpENTERSUB_HASTARG;
6397 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6398 if (cvop->op_type == OP_RV2CV) {
6400 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6401 null(cvop); /* disable rv2cv */
6402 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6403 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6404 GV *gv = cGVOPx_gv(tmpop);
6407 tmpop->op_private |= OPpEARLY_CV;
6408 else if (SvPOK(cv)) {
6409 namegv = CvANON(cv) ? gv : CvGV(cv);
6410 proto = SvPV((SV*)cv, n_a);
6414 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6415 if (o2->op_type == OP_CONST)
6416 o2->op_private &= ~OPpCONST_STRICT;
6417 else if (o2->op_type == OP_LIST) {
6418 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6419 if (o && o->op_type == OP_CONST)
6420 o->op_private &= ~OPpCONST_STRICT;
6423 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6424 if (PERLDB_SUB && PL_curstash != PL_debstash)
6425 o->op_private |= OPpENTERSUB_DB;
6426 while (o2 != cvop) {
6430 return too_many_arguments(o, gv_ename(namegv));
6448 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6450 arg == 1 ? "block or sub {}" : "sub {}",
6451 gv_ename(namegv), o2);
6454 /* '*' allows any scalar type, including bareword */
6457 if (o2->op_type == OP_RV2GV)
6458 goto wrapref; /* autoconvert GLOB -> GLOBref */
6459 else if (o2->op_type == OP_CONST)
6460 o2->op_private &= ~OPpCONST_STRICT;
6461 else if (o2->op_type == OP_ENTERSUB) {
6462 /* accidental subroutine, revert to bareword */
6463 OP *gvop = ((UNOP*)o2)->op_first;
6464 if (gvop && gvop->op_type == OP_NULL) {
6465 gvop = ((UNOP*)gvop)->op_first;
6467 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6470 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6471 (gvop = ((UNOP*)gvop)->op_first) &&
6472 gvop->op_type == OP_GV)
6474 GV *gv = cGVOPx_gv(gvop);
6475 OP *sibling = o2->op_sibling;
6476 SV *n = newSVpvn("",0);
6478 gv_fullname3(n, gv, "");
6479 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6480 sv_chop(n, SvPVX(n)+6);
6481 o2 = newSVOP(OP_CONST, 0, n);
6482 prev->op_sibling = o2;
6483 o2->op_sibling = sibling;
6495 if (o2->op_type != OP_RV2GV)
6496 bad_type(arg, "symbol", gv_ename(namegv), o2);
6499 if (o2->op_type != OP_ENTERSUB)
6500 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6503 if (o2->op_type != OP_RV2SV
6504 && o2->op_type != OP_PADSV
6505 && o2->op_type != OP_HELEM
6506 && o2->op_type != OP_AELEM
6507 && o2->op_type != OP_THREADSV)
6509 bad_type(arg, "scalar", gv_ename(namegv), o2);
6513 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6514 bad_type(arg, "array", gv_ename(namegv), o2);
6517 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6518 bad_type(arg, "hash", gv_ename(namegv), o2);
6522 OP* sib = kid->op_sibling;
6523 kid->op_sibling = 0;
6524 o2 = newUNOP(OP_REFGEN, 0, kid);
6525 o2->op_sibling = sib;
6526 prev->op_sibling = o2;
6537 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6538 gv_ename(namegv), SvPV((SV*)cv, n_a));
6543 mod(o2, OP_ENTERSUB);
6545 o2 = o2->op_sibling;
6547 if (proto && !optional &&
6548 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6549 return too_few_arguments(o, gv_ename(namegv));
6554 Perl_ck_svconst(pTHX_ OP *o)
6556 SvREADONLY_on(cSVOPo->op_sv);
6561 Perl_ck_trunc(pTHX_ OP *o)
6563 if (o->op_flags & OPf_KIDS) {
6564 SVOP *kid = (SVOP*)cUNOPo->op_first;
6566 if (kid->op_type == OP_NULL)
6567 kid = (SVOP*)kid->op_sibling;
6568 if (kid && kid->op_type == OP_CONST &&
6569 (kid->op_private & OPpCONST_BARE))
6571 o->op_flags |= OPf_SPECIAL;
6572 kid->op_private &= ~OPpCONST_STRICT;
6579 Perl_ck_substr(pTHX_ OP *o)
6582 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6583 OP *kid = cLISTOPo->op_first;
6585 if (kid->op_type == OP_NULL)
6586 kid = kid->op_sibling;
6588 kid->op_flags |= OPf_MOD;
6594 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6597 Perl_peep(pTHX_ register OP *o)
6599 register OP* oldop = 0;
6602 if (!o || o->op_seq)
6606 SAVEVPTR(PL_curcop);
6607 for (; o; o = o->op_next) {
6613 switch (o->op_type) {
6617 PL_curcop = ((COP*)o); /* for warnings */
6618 o->op_seq = PL_op_seqmax++;
6622 if (cSVOPo->op_private & OPpCONST_STRICT)
6623 no_bareword_allowed(o);
6625 /* Relocate sv to the pad for thread safety.
6626 * Despite being a "constant", the SV is written to,
6627 * for reference counts, sv_upgrade() etc. */
6629 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6630 if (SvPADTMP(cSVOPo->op_sv)) {
6631 /* If op_sv is already a PADTMP then it is being used by
6632 * some pad, so make a copy. */
6633 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6634 SvREADONLY_on(PL_curpad[ix]);
6635 SvREFCNT_dec(cSVOPo->op_sv);
6638 SvREFCNT_dec(PL_curpad[ix]);
6639 SvPADTMP_on(cSVOPo->op_sv);
6640 PL_curpad[ix] = cSVOPo->op_sv;
6641 /* XXX I don't know how this isn't readonly already. */
6642 SvREADONLY_on(PL_curpad[ix]);
6644 cSVOPo->op_sv = Nullsv;
6648 o->op_seq = PL_op_seqmax++;
6652 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6653 if (o->op_next->op_private & OPpTARGET_MY) {
6654 if (o->op_flags & OPf_STACKED) /* chained concats */
6655 goto ignore_optimization;
6657 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6658 o->op_targ = o->op_next->op_targ;
6659 o->op_next->op_targ = 0;
6660 o->op_private |= OPpTARGET_MY;
6665 ignore_optimization:
6666 o->op_seq = PL_op_seqmax++;
6669 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6670 o->op_seq = PL_op_seqmax++;
6671 break; /* Scalar stub must produce undef. List stub is noop */
6675 if (o->op_targ == OP_NEXTSTATE
6676 || o->op_targ == OP_DBSTATE
6677 || o->op_targ == OP_SETSTATE)
6679 PL_curcop = ((COP*)o);
6686 if (oldop && o->op_next) {
6687 oldop->op_next = o->op_next;
6690 o->op_seq = PL_op_seqmax++;
6694 if (o->op_next->op_type == OP_RV2SV) {
6695 if (!(o->op_next->op_private & OPpDEREF)) {
6697 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6699 o->op_next = o->op_next->op_next;
6700 o->op_type = OP_GVSV;
6701 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6704 else if (o->op_next->op_type == OP_RV2AV) {
6705 OP* pop = o->op_next->op_next;
6707 if (pop->op_type == OP_CONST &&
6708 (PL_op = pop->op_next) &&
6709 pop->op_next->op_type == OP_AELEM &&
6710 !(pop->op_next->op_private &
6711 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6712 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6720 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6721 o->op_next = pop->op_next->op_next;
6722 o->op_type = OP_AELEMFAST;
6723 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6724 o->op_private = (U8)i;
6729 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6731 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6732 /* XXX could check prototype here instead of just carping */
6733 SV *sv = sv_newmortal();
6734 gv_efullname3(sv, gv, Nullch);
6735 Perl_warner(aTHX_ WARN_PROTOTYPE,
6736 "%s() called too early to check prototype",
6741 o->op_seq = PL_op_seqmax++;
6752 o->op_seq = PL_op_seqmax++;
6753 while (cLOGOP->op_other->op_type == OP_NULL)
6754 cLOGOP->op_other = cLOGOP->op_other->op_next;
6755 peep(cLOGOP->op_other);
6759 o->op_seq = PL_op_seqmax++;
6760 while (cLOOP->op_redoop->op_type == OP_NULL)
6761 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6762 peep(cLOOP->op_redoop);
6763 while (cLOOP->op_nextop->op_type == OP_NULL)
6764 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6765 peep(cLOOP->op_nextop);
6766 while (cLOOP->op_lastop->op_type == OP_NULL)
6767 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6768 peep(cLOOP->op_lastop);
6774 o->op_seq = PL_op_seqmax++;
6775 while (cPMOP->op_pmreplstart &&
6776 cPMOP->op_pmreplstart->op_type == OP_NULL)
6777 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6778 peep(cPMOP->op_pmreplstart);
6782 o->op_seq = PL_op_seqmax++;
6783 if (ckWARN(WARN_SYNTAX) && o->op_next
6784 && o->op_next->op_type == OP_NEXTSTATE) {
6785 if (o->op_next->op_sibling &&
6786 o->op_next->op_sibling->op_type != OP_EXIT &&
6787 o->op_next->op_sibling->op_type != OP_WARN &&
6788 o->op_next->op_sibling->op_type != OP_DIE) {
6789 line_t oldline = CopLINE(PL_curcop);
6791 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6792 Perl_warner(aTHX_ WARN_EXEC,
6793 "Statement unlikely to be reached");
6794 Perl_warner(aTHX_ WARN_EXEC,
6795 "\t(Maybe you meant system() when you said exec()?)\n");
6796 CopLINE_set(PL_curcop, oldline);
6805 SV **svp, **indsvp, *sv;
6810 o->op_seq = PL_op_seqmax++;
6812 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6815 /* Make the CONST have a shared SV */
6816 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6817 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6818 key = SvPV(sv, keylen);
6821 lexname = newSVpvn_share(key, keylen, 0);
6826 if ((o->op_private & (OPpLVAL_INTRO)))
6829 rop = (UNOP*)((BINOP*)o)->op_first;
6830 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6832 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6833 if (!SvOBJECT(lexname))
6835 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6836 if (!fields || !GvHV(*fields))
6838 key = SvPV(*svp, keylen);
6841 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6843 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6844 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6846 ind = SvIV(*indsvp);
6848 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6849 rop->op_type = OP_RV2AV;
6850 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6851 o->op_type = OP_AELEM;
6852 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6854 if (SvREADONLY(*svp))
6856 SvFLAGS(sv) |= (SvFLAGS(*svp)
6857 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6867 SV **svp, **indsvp, *sv;
6871 SVOP *first_key_op, *key_op;
6873 o->op_seq = PL_op_seqmax++;
6874 if ((o->op_private & (OPpLVAL_INTRO))
6875 /* I bet there's always a pushmark... */
6876 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6877 /* hmmm, no optimization if list contains only one key. */
6879 rop = (UNOP*)((LISTOP*)o)->op_last;
6880 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6882 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6883 if (!SvOBJECT(lexname))
6885 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6886 if (!fields || !GvHV(*fields))
6888 /* Again guessing that the pushmark can be jumped over.... */
6889 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6890 ->op_first->op_sibling;
6891 /* Check that the key list contains only constants. */
6892 for (key_op = first_key_op; key_op;
6893 key_op = (SVOP*)key_op->op_sibling)
6894 if (key_op->op_type != OP_CONST)
6898 rop->op_type = OP_RV2AV;
6899 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6900 o->op_type = OP_ASLICE;
6901 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6902 for (key_op = first_key_op; key_op;
6903 key_op = (SVOP*)key_op->op_sibling) {
6904 svp = cSVOPx_svp(key_op);
6905 key = SvPV(*svp, keylen);
6908 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6910 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6911 "in variable %s of type %s",
6912 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6914 ind = SvIV(*indsvp);
6916 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6918 if (SvREADONLY(*svp))
6920 SvFLAGS(sv) |= (SvFLAGS(*svp)
6921 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6929 o->op_seq = PL_op_seqmax++;
6939 /* Efficient sub that returns a constant scalar value. */
6941 const_sv_xsub(pTHXo_ CV* cv)
6945 ST(0) = (SV*)XSANY.any_ptr;