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 PL_modcount = RETVAL_MAX;
1420 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1421 /* Backward compatibility mode: */
1422 o->op_private |= OPpENTERSUB_INARGS;
1425 else { /* Compile-time error message: */
1426 OP *kid = cUNOPo->op_first;
1430 if (kid->op_type == OP_PUSHMARK)
1432 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1434 "panic: unexpected lvalue entersub "
1435 "args: type/targ %ld:%ld",
1436 (long)kid->op_type,kid->op_targ);
1437 kid = kLISTOP->op_first;
1439 while (kid->op_sibling)
1440 kid = kid->op_sibling;
1441 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1443 if (kid->op_type == OP_METHOD_NAMED
1444 || kid->op_type == OP_METHOD)
1448 if (kid->op_sibling || kid->op_next != kid) {
1449 yyerror("panic: unexpected optree near method call");
1453 NewOp(1101, newop, 1, UNOP);
1454 newop->op_type = OP_RV2CV;
1455 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456 newop->op_first = Nullop;
1457 newop->op_next = (OP*)newop;
1458 kid->op_sibling = (OP*)newop;
1459 newop->op_private |= OPpLVAL_INTRO;
1463 if (kid->op_type != OP_RV2CV)
1465 "panic: unexpected lvalue entersub "
1466 "entry via type/targ %ld:%ld",
1467 (long)kid->op_type,kid->op_targ);
1468 kid->op_private |= OPpLVAL_INTRO;
1469 break; /* Postpone until runtime */
1473 kid = kUNOP->op_first;
1474 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1475 kid = kUNOP->op_first;
1476 if (kid->op_type == OP_NULL)
1478 "Unexpected constant lvalue entersub "
1479 "entry via type/targ %ld:%ld",
1480 (long)kid->op_type,kid->op_targ);
1481 if (kid->op_type != OP_GV) {
1482 /* Restore RV2CV to check lvalueness */
1484 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1485 okid->op_next = kid->op_next;
1486 kid->op_next = okid;
1489 okid->op_next = Nullop;
1490 okid->op_type = OP_RV2CV;
1492 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1493 okid->op_private |= OPpLVAL_INTRO;
1497 cv = GvCV(kGVOP_gv);
1507 /* grep, foreach, subcalls, refgen */
1508 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1510 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1511 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1513 : (o->op_type == OP_ENTERSUB
1514 ? "non-lvalue subroutine call"
1515 : PL_op_desc[o->op_type])),
1516 type ? PL_op_desc[type] : "local"));
1530 case OP_RIGHT_SHIFT:
1539 if (!(o->op_flags & OPf_STACKED))
1545 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1551 if (!type && cUNOPo->op_first->op_type != OP_GV)
1552 Perl_croak(aTHX_ "Can't localize through a reference");
1553 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1554 PL_modcount = RETVAL_MAX;
1555 return o; /* Treat \(@foo) like ordinary list. */
1559 if (scalar_mod_type(o, type))
1561 ref(cUNOPo->op_first, o->op_type);
1565 if (type == OP_LEAVESUBLV)
1566 o->op_private |= OPpMAYBE_LVSUB;
1573 PL_modcount = RETVAL_MAX;
1576 if (!type && cUNOPo->op_first->op_type != OP_GV)
1577 Perl_croak(aTHX_ "Can't localize through a reference");
1578 ref(cUNOPo->op_first, o->op_type);
1582 PL_hints |= HINT_BLOCK_SCOPE;
1592 PL_modcount = RETVAL_MAX;
1593 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1594 return o; /* Treat \(@foo) like ordinary list. */
1595 if (scalar_mod_type(o, type))
1597 if (type == OP_LEAVESUBLV)
1598 o->op_private |= OPpMAYBE_LVSUB;
1603 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1604 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1609 PL_modcount++; /* XXX ??? */
1611 #endif /* USE_THREADS */
1617 if (type != OP_SASSIGN)
1621 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1626 if (type == OP_LEAVESUBLV)
1627 o->op_private |= OPpMAYBE_LVSUB;
1629 pad_free(o->op_targ);
1630 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1631 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1632 if (o->op_flags & OPf_KIDS)
1633 mod(cBINOPo->op_first->op_sibling, type);
1638 ref(cBINOPo->op_first, o->op_type);
1639 if (type == OP_ENTERSUB &&
1640 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1641 o->op_private |= OPpLVAL_DEFER;
1642 if (type == OP_LEAVESUBLV)
1643 o->op_private |= OPpMAYBE_LVSUB;
1651 if (o->op_flags & OPf_KIDS)
1652 mod(cLISTOPo->op_last, type);
1656 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1658 else if (!(o->op_flags & OPf_KIDS))
1660 if (o->op_targ != OP_LIST) {
1661 mod(cBINOPo->op_first, type);
1666 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1671 if (type != OP_LEAVESUBLV)
1673 break; /* mod()ing was handled by ck_return() */
1675 if (type != OP_LEAVESUBLV)
1676 o->op_flags |= OPf_MOD;
1678 if (type == OP_AASSIGN || type == OP_SASSIGN)
1679 o->op_flags |= OPf_SPECIAL|OPf_REF;
1681 o->op_private |= OPpLVAL_INTRO;
1682 o->op_flags &= ~OPf_SPECIAL;
1683 PL_hints |= HINT_BLOCK_SCOPE;
1685 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1686 && type != OP_LEAVESUBLV)
1687 o->op_flags |= OPf_REF;
1692 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1696 if (o->op_type == OP_RV2GV)
1720 case OP_RIGHT_SHIFT:
1739 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1741 switch (o->op_type) {
1749 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1762 Perl_refkids(pTHX_ OP *o, I32 type)
1765 if (o && o->op_flags & OPf_KIDS) {
1766 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1773 Perl_ref(pTHX_ OP *o, I32 type)
1777 if (!o || PL_error_count)
1780 switch (o->op_type) {
1782 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1783 !(o->op_flags & OPf_STACKED)) {
1784 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1785 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1786 assert(cUNOPo->op_first->op_type == OP_NULL);
1787 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1788 o->op_flags |= OPf_SPECIAL;
1793 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1797 if (type == OP_DEFINED)
1798 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1799 ref(cUNOPo->op_first, o->op_type);
1802 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1803 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1804 : type == OP_RV2HV ? OPpDEREF_HV
1806 o->op_flags |= OPf_MOD;
1811 o->op_flags |= OPf_MOD; /* XXX ??? */
1816 o->op_flags |= OPf_REF;
1819 if (type == OP_DEFINED)
1820 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1821 ref(cUNOPo->op_first, o->op_type);
1826 o->op_flags |= OPf_REF;
1831 if (!(o->op_flags & OPf_KIDS))
1833 ref(cBINOPo->op_first, type);
1837 ref(cBINOPo->op_first, o->op_type);
1838 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1839 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1840 : type == OP_RV2HV ? OPpDEREF_HV
1842 o->op_flags |= OPf_MOD;
1850 if (!(o->op_flags & OPf_KIDS))
1852 ref(cLISTOPo->op_last, type);
1862 S_dup_attrlist(pTHX_ OP *o)
1866 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1867 * where the first kid is OP_PUSHMARK and the remaining ones
1868 * are OP_CONST. We need to push the OP_CONST values.
1870 if (o->op_type == OP_CONST)
1871 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1873 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1874 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1875 if (o->op_type == OP_CONST)
1876 rop = append_elem(OP_LIST, rop,
1877 newSVOP(OP_CONST, o->op_flags,
1878 SvREFCNT_inc(cSVOPo->op_sv)));
1885 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1889 /* fake up C<use attributes $pkg,$rv,@attrs> */
1890 ENTER; /* need to protect against side-effects of 'use' */
1892 if (stash && HvNAME(stash))
1893 stashsv = newSVpv(HvNAME(stash), 0);
1895 stashsv = &PL_sv_no;
1897 #define ATTRSMODULE "attributes"
1899 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1900 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1902 prepend_elem(OP_LIST,
1903 newSVOP(OP_CONST, 0, stashsv),
1904 prepend_elem(OP_LIST,
1905 newSVOP(OP_CONST, 0,
1907 dup_attrlist(attrs))));
1912 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1913 char *attrstr, STRLEN len)
1918 len = strlen(attrstr);
1922 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1924 char *sstr = attrstr;
1925 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1926 attrs = append_elem(OP_LIST, attrs,
1927 newSVOP(OP_CONST, 0,
1928 newSVpvn(sstr, attrstr-sstr)));
1932 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1933 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1934 Nullsv, prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1936 prepend_elem(OP_LIST,
1937 newSVOP(OP_CONST, 0,
1943 S_my_kid(pTHX_ OP *o, OP *attrs)
1948 if (!o || PL_error_count)
1952 if (type == OP_LIST) {
1953 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1955 } else if (type == OP_UNDEF) {
1957 } else if (type == OP_RV2SV || /* "our" declaration */
1959 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1960 o->op_private |= OPpOUR_INTRO;
1962 } else if (type != OP_PADSV &&
1965 type != OP_PUSHMARK)
1967 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1968 PL_op_desc[o->op_type],
1969 PL_in_my == KEY_our ? "our" : "my"));
1972 else if (attrs && type != OP_PUSHMARK) {
1978 PL_in_my_stash = Nullhv;
1980 /* check for C<my Dog $spot> when deciding package */
1981 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1982 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1983 stash = SvSTASH(*namesvp);
1985 stash = PL_curstash;
1986 padsv = PAD_SV(o->op_targ);
1987 apply_attrs(stash, padsv, attrs);
1989 o->op_flags |= OPf_MOD;
1990 o->op_private |= OPpLVAL_INTRO;
1995 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1997 if (o->op_flags & OPf_PARENS)
2001 o = my_kid(o, attrs);
2003 PL_in_my_stash = Nullhv;
2008 Perl_my(pTHX_ OP *o)
2010 return my_kid(o, Nullop);
2014 Perl_sawparens(pTHX_ OP *o)
2017 o->op_flags |= OPf_PARENS;
2022 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2026 if (ckWARN(WARN_MISC) &&
2027 (left->op_type == OP_RV2AV ||
2028 left->op_type == OP_RV2HV ||
2029 left->op_type == OP_PADAV ||
2030 left->op_type == OP_PADHV)) {
2031 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2032 right->op_type == OP_TRANS)
2033 ? right->op_type : OP_MATCH];
2034 const char *sample = ((left->op_type == OP_RV2AV ||
2035 left->op_type == OP_PADAV)
2036 ? "@array" : "%hash");
2037 Perl_warner(aTHX_ WARN_MISC,
2038 "Applying %s to %s will act on scalar(%s)",
2039 desc, sample, sample);
2042 if (!(right->op_flags & OPf_STACKED) &&
2043 (right->op_type == OP_MATCH ||
2044 right->op_type == OP_SUBST ||
2045 right->op_type == OP_TRANS)) {
2046 right->op_flags |= OPf_STACKED;
2047 if (right->op_type != OP_MATCH &&
2048 ! (right->op_type == OP_TRANS &&
2049 right->op_private & OPpTRANS_IDENTICAL))
2050 left = mod(left, right->op_type);
2051 if (right->op_type == OP_TRANS)
2052 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2054 o = prepend_elem(right->op_type, scalar(left), right);
2056 return newUNOP(OP_NOT, 0, scalar(o));
2060 return bind_match(type, left,
2061 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2065 Perl_invert(pTHX_ OP *o)
2069 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2070 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2074 Perl_scope(pTHX_ OP *o)
2077 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2078 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2079 o->op_type = OP_LEAVE;
2080 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2083 if (o->op_type == OP_LINESEQ) {
2085 o->op_type = OP_SCOPE;
2086 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2087 kid = ((LISTOP*)o)->op_first;
2088 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2092 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2099 Perl_save_hints(pTHX)
2102 SAVESPTR(GvHV(PL_hintgv));
2103 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2104 SAVEFREESV(GvHV(PL_hintgv));
2108 Perl_block_start(pTHX_ int full)
2110 int retval = PL_savestack_ix;
2112 SAVEI32(PL_comppad_name_floor);
2113 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2115 PL_comppad_name_fill = PL_comppad_name_floor;
2116 if (PL_comppad_name_floor < 0)
2117 PL_comppad_name_floor = 0;
2118 SAVEI32(PL_min_intro_pending);
2119 SAVEI32(PL_max_intro_pending);
2120 PL_min_intro_pending = 0;
2121 SAVEI32(PL_comppad_name_fill);
2122 SAVEI32(PL_padix_floor);
2123 PL_padix_floor = PL_padix;
2124 PL_pad_reset_pending = FALSE;
2126 PL_hints &= ~HINT_BLOCK_SCOPE;
2127 SAVESPTR(PL_compiling.cop_warnings);
2128 if (! specialWARN(PL_compiling.cop_warnings)) {
2129 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2130 SAVEFREESV(PL_compiling.cop_warnings) ;
2132 SAVESPTR(PL_compiling.cop_io);
2133 if (! specialCopIO(PL_compiling.cop_io)) {
2134 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2135 SAVEFREESV(PL_compiling.cop_io) ;
2141 Perl_block_end(pTHX_ I32 floor, OP *seq)
2143 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2144 OP* retval = scalarseq(seq);
2146 PL_pad_reset_pending = FALSE;
2147 PL_compiling.op_private = PL_hints;
2149 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2150 pad_leavemy(PL_comppad_name_fill);
2159 OP *o = newOP(OP_THREADSV, 0);
2160 o->op_targ = find_threadsv("_");
2163 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2164 #endif /* USE_THREADS */
2168 Perl_newPROG(pTHX_ OP *o)
2173 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2174 ((PL_in_eval & EVAL_KEEPERR)
2175 ? OPf_SPECIAL : 0), o);
2176 PL_eval_start = linklist(PL_eval_root);
2177 PL_eval_root->op_private |= OPpREFCOUNTED;
2178 OpREFCNT_set(PL_eval_root, 1);
2179 PL_eval_root->op_next = 0;
2180 peep(PL_eval_start);
2185 PL_main_root = scope(sawparens(scalarvoid(o)));
2186 PL_curcop = &PL_compiling;
2187 PL_main_start = LINKLIST(PL_main_root);
2188 PL_main_root->op_private |= OPpREFCOUNTED;
2189 OpREFCNT_set(PL_main_root, 1);
2190 PL_main_root->op_next = 0;
2191 peep(PL_main_start);
2194 /* Register with debugger */
2196 CV *cv = get_cv("DB::postponed", FALSE);
2200 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2202 call_sv((SV*)cv, G_DISCARD);
2209 Perl_localize(pTHX_ OP *o, I32 lex)
2211 if (o->op_flags & OPf_PARENS)
2214 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2216 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2217 if (*s == ';' || *s == '=')
2218 Perl_warner(aTHX_ WARN_PARENTHESIS,
2219 "Parentheses missing around \"%s\" list",
2220 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2226 o = mod(o, OP_NULL); /* a bit kludgey */
2228 PL_in_my_stash = Nullhv;
2233 Perl_jmaybe(pTHX_ OP *o)
2235 if (o->op_type == OP_LIST) {
2238 o2 = newOP(OP_THREADSV, 0);
2239 o2->op_targ = find_threadsv(";");
2241 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2242 #endif /* USE_THREADS */
2243 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2249 Perl_fold_constants(pTHX_ register OP *o)
2252 I32 type = o->op_type;
2255 if (PL_opargs[type] & OA_RETSCALAR)
2257 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2258 o->op_targ = pad_alloc(type, SVs_PADTMP);
2260 /* integerize op, unless it happens to be C<-foo>.
2261 * XXX should pp_i_negate() do magic string negation instead? */
2262 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2263 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2264 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2266 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2269 if (!(PL_opargs[type] & OA_FOLDCONST))
2274 /* XXX might want a ck_negate() for this */
2275 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2288 if (o->op_private & OPpLOCALE)
2293 goto nope; /* Don't try to run w/ errors */
2295 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2296 if ((curop->op_type != OP_CONST ||
2297 (curop->op_private & OPpCONST_BARE)) &&
2298 curop->op_type != OP_LIST &&
2299 curop->op_type != OP_SCALAR &&
2300 curop->op_type != OP_NULL &&
2301 curop->op_type != OP_PUSHMARK)
2307 curop = LINKLIST(o);
2311 sv = *(PL_stack_sp--);
2312 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2313 pad_swipe(o->op_targ);
2314 else if (SvTEMP(sv)) { /* grab mortal temp? */
2315 (void)SvREFCNT_inc(sv);
2319 if (type == OP_RV2GV)
2320 return newGVOP(OP_GV, 0, (GV*)sv);
2322 /* try to smush double to int, but don't smush -2.0 to -2 */
2323 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2326 #ifdef PERL_PRESERVE_IVUV
2327 /* Only bother to attempt to fold to IV if
2328 most operators will benefit */
2332 return newSVOP(OP_CONST, 0, sv);
2336 if (!(PL_opargs[type] & OA_OTHERINT))
2339 if (!(PL_hints & HINT_INTEGER)) {
2340 if (type == OP_MODULO
2341 || type == OP_DIVIDE
2342 || !(o->op_flags & OPf_KIDS))
2347 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2348 if (curop->op_type == OP_CONST) {
2349 if (SvIOK(((SVOP*)curop)->op_sv))
2353 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2357 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2364 Perl_gen_constant_list(pTHX_ register OP *o)
2367 I32 oldtmps_floor = PL_tmps_floor;
2371 return o; /* Don't attempt to run with errors */
2373 PL_op = curop = LINKLIST(o);
2380 PL_tmps_floor = oldtmps_floor;
2382 o->op_type = OP_RV2AV;
2383 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2384 curop = ((UNOP*)o)->op_first;
2385 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2392 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2397 if (!o || o->op_type != OP_LIST)
2398 o = newLISTOP(OP_LIST, 0, o, Nullop);
2400 o->op_flags &= ~OPf_WANT;
2402 if (!(PL_opargs[type] & OA_MARK))
2403 null(cLISTOPo->op_first);
2406 o->op_ppaddr = PL_ppaddr[type];
2407 o->op_flags |= flags;
2409 o = CHECKOP(type, o);
2410 if (o->op_type != type)
2413 if (cLISTOPo->op_children < 7) {
2414 /* XXX do we really need to do this if we're done appending?? */
2415 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2417 cLISTOPo->op_last = last; /* in case check substituted last arg */
2420 return fold_constants(o);
2423 /* List constructors */
2426 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2434 if (first->op_type != type
2435 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2437 return newLISTOP(type, 0, first, last);
2440 if (first->op_flags & OPf_KIDS)
2441 ((LISTOP*)first)->op_last->op_sibling = last;
2443 first->op_flags |= OPf_KIDS;
2444 ((LISTOP*)first)->op_first = last;
2446 ((LISTOP*)first)->op_last = last;
2447 ((LISTOP*)first)->op_children++;
2452 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2460 if (first->op_type != type)
2461 return prepend_elem(type, (OP*)first, (OP*)last);
2463 if (last->op_type != type)
2464 return append_elem(type, (OP*)first, (OP*)last);
2466 first->op_last->op_sibling = last->op_first;
2467 first->op_last = last->op_last;
2468 first->op_children += last->op_children;
2469 if (first->op_children)
2470 first->op_flags |= OPf_KIDS;
2472 #ifdef PL_OP_SLAB_ALLOC
2480 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2488 if (last->op_type == type) {
2489 if (type == OP_LIST) { /* already a PUSHMARK there */
2490 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2491 ((LISTOP*)last)->op_first->op_sibling = first;
2492 if (!(first->op_flags & OPf_PARENS))
2493 last->op_flags &= ~OPf_PARENS;
2496 if (!(last->op_flags & OPf_KIDS)) {
2497 ((LISTOP*)last)->op_last = first;
2498 last->op_flags |= OPf_KIDS;
2500 first->op_sibling = ((LISTOP*)last)->op_first;
2501 ((LISTOP*)last)->op_first = first;
2503 ((LISTOP*)last)->op_children++;
2507 return newLISTOP(type, 0, first, last);
2513 Perl_newNULLLIST(pTHX)
2515 return newOP(OP_STUB, 0);
2519 Perl_force_list(pTHX_ OP *o)
2521 if (!o || o->op_type != OP_LIST)
2522 o = newLISTOP(OP_LIST, 0, o, Nullop);
2528 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2532 NewOp(1101, listop, 1, LISTOP);
2534 listop->op_type = type;
2535 listop->op_ppaddr = PL_ppaddr[type];
2536 listop->op_children = (first != 0) + (last != 0);
2537 listop->op_flags = flags;
2541 else if (!first && last)
2544 first->op_sibling = last;
2545 listop->op_first = first;
2546 listop->op_last = last;
2547 if (type == OP_LIST) {
2549 pushop = newOP(OP_PUSHMARK, 0);
2550 pushop->op_sibling = first;
2551 listop->op_first = pushop;
2552 listop->op_flags |= OPf_KIDS;
2554 listop->op_last = pushop;
2556 else if (listop->op_children)
2557 listop->op_flags |= OPf_KIDS;
2563 Perl_newOP(pTHX_ I32 type, I32 flags)
2566 NewOp(1101, o, 1, OP);
2568 o->op_ppaddr = PL_ppaddr[type];
2569 o->op_flags = flags;
2572 o->op_private = 0 + (flags >> 8);
2573 if (PL_opargs[type] & OA_RETSCALAR)
2575 if (PL_opargs[type] & OA_TARGET)
2576 o->op_targ = pad_alloc(type, SVs_PADTMP);
2577 return CHECKOP(type, o);
2581 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2586 first = newOP(OP_STUB, 0);
2587 if (PL_opargs[type] & OA_MARK)
2588 first = force_list(first);
2590 NewOp(1101, unop, 1, UNOP);
2591 unop->op_type = type;
2592 unop->op_ppaddr = PL_ppaddr[type];
2593 unop->op_first = first;
2594 unop->op_flags = flags | OPf_KIDS;
2595 unop->op_private = 1 | (flags >> 8);
2596 unop = (UNOP*) CHECKOP(type, unop);
2600 return fold_constants((OP *) unop);
2604 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2607 NewOp(1101, binop, 1, BINOP);
2610 first = newOP(OP_NULL, 0);
2612 binop->op_type = type;
2613 binop->op_ppaddr = PL_ppaddr[type];
2614 binop->op_first = first;
2615 binop->op_flags = flags | OPf_KIDS;
2618 binop->op_private = 1 | (flags >> 8);
2621 binop->op_private = 2 | (flags >> 8);
2622 first->op_sibling = last;
2625 binop = (BINOP*)CHECKOP(type, binop);
2626 if (binop->op_next || binop->op_type != type)
2629 binop->op_last = binop->op_first->op_sibling;
2631 return fold_constants((OP *)binop);
2635 utf8compare(const void *a, const void *b)
2638 for (i = 0; i < 10; i++) {
2639 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2641 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2648 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2650 SV *tstr = ((SVOP*)expr)->op_sv;
2651 SV *rstr = ((SVOP*)repl)->op_sv;
2654 U8 *t = (U8*)SvPV(tstr, tlen);
2655 U8 *r = (U8*)SvPV(rstr, rlen);
2662 register short *tbl;
2664 complement = o->op_private & OPpTRANS_COMPLEMENT;
2665 del = o->op_private & OPpTRANS_DELETE;
2666 squash = o->op_private & OPpTRANS_SQUASH;
2669 o->op_private |= OPpTRANS_FROM_UTF;
2672 o->op_private |= OPpTRANS_TO_UTF;
2674 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2675 SV* listsv = newSVpvn("# comment\n",10);
2677 U8* tend = t + tlen;
2678 U8* rend = r + rlen;
2692 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2693 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2694 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2695 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2698 U8 tmpbuf[UTF8_MAXLEN+1];
2702 New(1109, cp, tlen, U8*);
2704 transv = newSVpvn("",0);
2713 qsort(cp, i, sizeof(U8*), utf8compare);
2714 for (j = 0; j < i; j++) {
2716 I32 cur = j < i ? cp[j+1] - s : tend - s;
2717 UV val = utf8_to_uv(s, cur, &ulen, 0);
2719 diff = val - nextmin;
2721 t = uv_to_utf8(tmpbuf,nextmin);
2722 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2724 t = uv_to_utf8(tmpbuf, val - 1);
2725 sv_catpvn(transv, "\377", 1);
2726 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2730 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2734 t = uv_to_utf8(tmpbuf,nextmin);
2735 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2736 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2737 sv_catpvn(transv, "\377", 1);
2738 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2739 t = (U8*)SvPVX(transv);
2740 tlen = SvCUR(transv);
2743 else if (!rlen && !del) {
2744 r = t; rlen = tlen; rend = tend;
2748 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2750 o->op_private |= OPpTRANS_IDENTICAL;
2754 while (t < tend || tfirst <= tlast) {
2755 /* see if we need more "t" chars */
2756 if (tfirst > tlast) {
2757 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2759 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2761 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2768 /* now see if we need more "r" chars */
2769 if (rfirst > rlast) {
2771 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2773 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2775 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2784 rfirst = rlast = 0xffffffff;
2788 /* now see which range will peter our first, if either. */
2789 tdiff = tlast - tfirst;
2790 rdiff = rlast - rfirst;
2797 if (rfirst == 0xffffffff) {
2798 diff = tdiff; /* oops, pretend rdiff is infinite */
2800 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2801 (long)tfirst, (long)tlast);
2803 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2807 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2808 (long)tfirst, (long)(tfirst + diff),
2811 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2812 (long)tfirst, (long)rfirst);
2814 if (rfirst + diff > max)
2815 max = rfirst + diff;
2818 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2829 else if (max > 0xff)
2834 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2835 SvREFCNT_dec(listsv);
2837 SvREFCNT_dec(transv);
2839 if (!del && havefinal)
2840 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2841 newSVuv((UV)final), 0);
2844 o->op_private |= OPpTRANS_GROWS;
2856 tbl = (short*)cPVOPo->op_pv;
2858 Zero(tbl, 256, short);
2859 for (i = 0; i < tlen; i++)
2861 for (i = 0, j = 0; i < 256; i++) {
2872 if (i < 128 && r[j] >= 128)
2880 if (!rlen && !del) {
2883 o->op_private |= OPpTRANS_IDENTICAL;
2885 for (i = 0; i < 256; i++)
2887 for (i = 0, j = 0; i < tlen; i++,j++) {
2890 if (tbl[t[i]] == -1)
2896 if (tbl[t[i]] == -1) {
2897 if (t[i] < 128 && r[j] >= 128)
2904 o->op_private |= OPpTRANS_GROWS;
2912 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2916 NewOp(1101, pmop, 1, PMOP);
2917 pmop->op_type = type;
2918 pmop->op_ppaddr = PL_ppaddr[type];
2919 pmop->op_flags = flags;
2920 pmop->op_private = 0 | (flags >> 8);
2922 if (PL_hints & HINT_RE_TAINT)
2923 pmop->op_pmpermflags |= PMf_RETAINT;
2924 if (PL_hints & HINT_LOCALE)
2925 pmop->op_pmpermflags |= PMf_LOCALE;
2926 pmop->op_pmflags = pmop->op_pmpermflags;
2928 /* link into pm list */
2929 if (type != OP_TRANS && PL_curstash) {
2930 pmop->op_pmnext = HvPMROOT(PL_curstash);
2931 HvPMROOT(PL_curstash) = pmop;
2938 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2942 I32 repl_has_vars = 0;
2944 if (o->op_type == OP_TRANS)
2945 return pmtrans(o, expr, repl);
2947 PL_hints |= HINT_BLOCK_SCOPE;
2950 if (expr->op_type == OP_CONST) {
2952 SV *pat = ((SVOP*)expr)->op_sv;
2953 char *p = SvPV(pat, plen);
2954 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2955 sv_setpvn(pat, "\\s+", 3);
2956 p = SvPV(pat, plen);
2957 pm->op_pmflags |= PMf_SKIPWHITE;
2959 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2960 pm->op_pmdynflags |= PMdf_UTF8;
2961 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2962 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2963 pm->op_pmflags |= PMf_WHITE;
2967 if (PL_hints & HINT_UTF8)
2968 pm->op_pmdynflags |= PMdf_UTF8;
2969 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2970 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2972 : OP_REGCMAYBE),0,expr);
2974 NewOp(1101, rcop, 1, LOGOP);
2975 rcop->op_type = OP_REGCOMP;
2976 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2977 rcop->op_first = scalar(expr);
2978 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2979 ? (OPf_SPECIAL | OPf_KIDS)
2981 rcop->op_private = 1;
2984 /* establish postfix order */
2985 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2987 rcop->op_next = expr;
2988 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2991 rcop->op_next = LINKLIST(expr);
2992 expr->op_next = (OP*)rcop;
2995 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3000 if (pm->op_pmflags & PMf_EVAL) {
3002 if (CopLINE(PL_curcop) < PL_multi_end)
3003 CopLINE_set(PL_curcop, PL_multi_end);
3006 else if (repl->op_type == OP_THREADSV
3007 && strchr("&`'123456789+",
3008 PL_threadsv_names[repl->op_targ]))
3012 #endif /* USE_THREADS */
3013 else if (repl->op_type == OP_CONST)
3017 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3018 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3020 if (curop->op_type == OP_THREADSV) {
3022 if (strchr("&`'123456789+", curop->op_private))
3026 if (curop->op_type == OP_GV) {
3027 GV *gv = cGVOPx_gv(curop);
3029 if (strchr("&`'123456789+", *GvENAME(gv)))
3032 #endif /* USE_THREADS */
3033 else if (curop->op_type == OP_RV2CV)
3035 else if (curop->op_type == OP_RV2SV ||
3036 curop->op_type == OP_RV2AV ||
3037 curop->op_type == OP_RV2HV ||
3038 curop->op_type == OP_RV2GV) {
3039 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3042 else if (curop->op_type == OP_PADSV ||
3043 curop->op_type == OP_PADAV ||
3044 curop->op_type == OP_PADHV ||
3045 curop->op_type == OP_PADANY) {
3048 else if (curop->op_type == OP_PUSHRE)
3049 ; /* Okay here, dangerous in newASSIGNOP */
3058 && (!pm->op_pmregexp
3059 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3060 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3061 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3062 prepend_elem(o->op_type, scalar(repl), o);
3065 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3066 pm->op_pmflags |= PMf_MAYBE_CONST;
3067 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3069 NewOp(1101, rcop, 1, LOGOP);
3070 rcop->op_type = OP_SUBSTCONT;
3071 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3072 rcop->op_first = scalar(repl);
3073 rcop->op_flags |= OPf_KIDS;
3074 rcop->op_private = 1;
3077 /* establish postfix order */
3078 rcop->op_next = LINKLIST(repl);
3079 repl->op_next = (OP*)rcop;
3081 pm->op_pmreplroot = scalar((OP*)rcop);
3082 pm->op_pmreplstart = LINKLIST(rcop);
3091 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3094 NewOp(1101, svop, 1, SVOP);
3095 svop->op_type = type;
3096 svop->op_ppaddr = PL_ppaddr[type];
3098 svop->op_next = (OP*)svop;
3099 svop->op_flags = flags;
3100 if (PL_opargs[type] & OA_RETSCALAR)
3102 if (PL_opargs[type] & OA_TARGET)
3103 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3104 return CHECKOP(type, svop);
3108 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3111 NewOp(1101, padop, 1, PADOP);
3112 padop->op_type = type;
3113 padop->op_ppaddr = PL_ppaddr[type];
3114 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3115 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3116 PL_curpad[padop->op_padix] = sv;
3118 padop->op_next = (OP*)padop;
3119 padop->op_flags = flags;
3120 if (PL_opargs[type] & OA_RETSCALAR)
3122 if (PL_opargs[type] & OA_TARGET)
3123 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3124 return CHECKOP(type, padop);
3128 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3132 return newPADOP(type, flags, SvREFCNT_inc(gv));
3134 return newSVOP(type, flags, SvREFCNT_inc(gv));
3139 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3142 NewOp(1101, pvop, 1, PVOP);
3143 pvop->op_type = type;
3144 pvop->op_ppaddr = PL_ppaddr[type];
3146 pvop->op_next = (OP*)pvop;
3147 pvop->op_flags = flags;
3148 if (PL_opargs[type] & OA_RETSCALAR)
3150 if (PL_opargs[type] & OA_TARGET)
3151 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3152 return CHECKOP(type, pvop);
3156 Perl_package(pTHX_ OP *o)
3160 save_hptr(&PL_curstash);
3161 save_item(PL_curstname);
3166 name = SvPV(sv, len);
3167 PL_curstash = gv_stashpvn(name,len,TRUE);
3168 sv_setpvn(PL_curstname, name, len);
3172 sv_setpv(PL_curstname,"<none>");
3173 PL_curstash = Nullhv;
3175 PL_hints |= HINT_BLOCK_SCOPE;
3176 PL_copline = NOLINE;
3181 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3189 if (id->op_type != OP_CONST)
3190 Perl_croak(aTHX_ "Module name must be constant");
3194 if (version != Nullop) {
3195 SV *vesv = ((SVOP*)version)->op_sv;
3197 if (arg == Nullop && !SvNIOKp(vesv)) {
3204 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3205 Perl_croak(aTHX_ "Version number must be constant number");
3207 /* Make copy of id so we don't free it twice */
3208 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3210 /* Fake up a method call to VERSION */
3211 meth = newSVpvn("VERSION",7);
3212 sv_upgrade(meth, SVt_PVIV);
3213 (void)SvIOK_on(meth);
3214 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3215 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3216 append_elem(OP_LIST,
3217 prepend_elem(OP_LIST, pack, list(version)),
3218 newSVOP(OP_METHOD_NAMED, 0, meth)));
3222 /* Fake up an import/unimport */
3223 if (arg && arg->op_type == OP_STUB)
3224 imop = arg; /* no import on explicit () */
3225 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3226 imop = Nullop; /* use 5.0; */
3231 /* Make copy of id so we don't free it twice */
3232 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3234 /* Fake up a method call to import/unimport */
3235 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3236 sv_upgrade(meth, SVt_PVIV);
3237 (void)SvIOK_on(meth);
3238 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3239 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3240 append_elem(OP_LIST,
3241 prepend_elem(OP_LIST, pack, list(arg)),
3242 newSVOP(OP_METHOD_NAMED, 0, meth)));
3245 /* Fake up a require, handle override, if any */
3246 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3247 if (!(gv && GvIMPORTED_CV(gv)))
3248 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3250 if (gv && GvIMPORTED_CV(gv)) {
3251 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3252 append_elem(OP_LIST, id,
3253 scalar(newUNOP(OP_RV2CV, 0,
3258 rqop = newUNOP(OP_REQUIRE, 0, id);
3261 /* Fake up the BEGIN {}, which does its thing immediately. */
3263 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3266 append_elem(OP_LINESEQ,
3267 append_elem(OP_LINESEQ,
3268 newSTATEOP(0, Nullch, rqop),
3269 newSTATEOP(0, Nullch, veop)),
3270 newSTATEOP(0, Nullch, imop) ));
3272 PL_hints |= HINT_BLOCK_SCOPE;
3273 PL_copline = NOLINE;
3278 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3281 va_start(args, ver);
3282 vload_module(flags, name, ver, &args);
3286 #ifdef PERL_IMPLICIT_CONTEXT
3288 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3292 va_start(args, ver);
3293 vload_module(flags, name, ver, &args);
3299 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3301 OP *modname, *veop, *imop;
3303 modname = newSVOP(OP_CONST, 0, name);
3304 modname->op_private |= OPpCONST_BARE;
3306 veop = newSVOP(OP_CONST, 0, ver);
3310 if (flags & PERL_LOADMOD_NOIMPORT) {
3311 imop = sawparens(newNULLLIST());
3313 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3314 imop = va_arg(*args, OP*);
3319 sv = va_arg(*args, SV*);
3321 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3322 sv = va_arg(*args, SV*);
3326 line_t ocopline = PL_copline;
3327 int oexpect = PL_expect;
3329 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3330 veop, modname, imop);
3331 PL_expect = oexpect;
3332 PL_copline = ocopline;
3337 Perl_dofile(pTHX_ OP *term)
3342 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3343 if (!(gv && GvIMPORTED_CV(gv)))
3344 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3346 if (gv && GvIMPORTED_CV(gv)) {
3347 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3348 append_elem(OP_LIST, term,
3349 scalar(newUNOP(OP_RV2CV, 0,
3354 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3360 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3362 return newBINOP(OP_LSLICE, flags,
3363 list(force_list(subscript)),
3364 list(force_list(listval)) );
3368 S_list_assignment(pTHX_ register OP *o)
3373 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3374 o = cUNOPo->op_first;
3376 if (o->op_type == OP_COND_EXPR) {
3377 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3378 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3383 yyerror("Assignment to both a list and a scalar");
3387 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3388 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3389 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3392 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3395 if (o->op_type == OP_RV2SV)
3402 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3407 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3408 return newLOGOP(optype, 0,
3409 mod(scalar(left), optype),
3410 newUNOP(OP_SASSIGN, 0, scalar(right)));
3413 return newBINOP(optype, OPf_STACKED,
3414 mod(scalar(left), optype), scalar(right));
3418 if (list_assignment(left)) {
3422 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3423 left = mod(left, OP_AASSIGN);
3431 curop = list(force_list(left));
3432 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3433 o->op_private = 0 | (flags >> 8);
3434 for (curop = ((LISTOP*)curop)->op_first;
3435 curop; curop = curop->op_sibling)
3437 if (curop->op_type == OP_RV2HV &&
3438 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3439 o->op_private |= OPpASSIGN_HASH;
3443 if (!(left->op_private & OPpLVAL_INTRO)) {
3446 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3447 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3448 if (curop->op_type == OP_GV) {
3449 GV *gv = cGVOPx_gv(curop);
3450 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3452 SvCUR(gv) = PL_generation;
3454 else if (curop->op_type == OP_PADSV ||
3455 curop->op_type == OP_PADAV ||
3456 curop->op_type == OP_PADHV ||
3457 curop->op_type == OP_PADANY) {
3458 SV **svp = AvARRAY(PL_comppad_name);
3459 SV *sv = svp[curop->op_targ];
3460 if (SvCUR(sv) == PL_generation)
3462 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3464 else if (curop->op_type == OP_RV2CV)
3466 else if (curop->op_type == OP_RV2SV ||
3467 curop->op_type == OP_RV2AV ||
3468 curop->op_type == OP_RV2HV ||
3469 curop->op_type == OP_RV2GV) {
3470 if (lastop->op_type != OP_GV) /* funny deref? */
3473 else if (curop->op_type == OP_PUSHRE) {
3474 if (((PMOP*)curop)->op_pmreplroot) {
3476 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3478 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3480 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3482 SvCUR(gv) = PL_generation;
3491 o->op_private |= OPpASSIGN_COMMON;
3493 if (right && right->op_type == OP_SPLIT) {
3495 if ((tmpop = ((LISTOP*)right)->op_first) &&
3496 tmpop->op_type == OP_PUSHRE)
3498 PMOP *pm = (PMOP*)tmpop;
3499 if (left->op_type == OP_RV2AV &&
3500 !(left->op_private & OPpLVAL_INTRO) &&
3501 !(o->op_private & OPpASSIGN_COMMON) )
3503 tmpop = ((UNOP*)left)->op_first;
3504 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3506 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3507 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3509 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3510 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3512 pm->op_pmflags |= PMf_ONCE;
3513 tmpop = cUNOPo->op_first; /* to list (nulled) */
3514 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3515 tmpop->op_sibling = Nullop; /* don't free split */
3516 right->op_next = tmpop->op_next; /* fix starting loc */
3517 op_free(o); /* blow off assign */
3518 right->op_flags &= ~OPf_WANT;
3519 /* "I don't know and I don't care." */
3524 if (PL_modcount < RETVAL_MAX &&
3525 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3527 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3529 sv_setiv(sv, PL_modcount+1);
3537 right = newOP(OP_UNDEF, 0);
3538 if (right->op_type == OP_READLINE) {
3539 right->op_flags |= OPf_STACKED;
3540 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3543 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3544 o = newBINOP(OP_SASSIGN, flags,
3545 scalar(right), mod(scalar(left), OP_SASSIGN) );
3557 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3559 U32 seq = intro_my();
3562 NewOp(1101, cop, 1, COP);
3563 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3564 cop->op_type = OP_DBSTATE;
3565 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3568 cop->op_type = OP_NEXTSTATE;
3569 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3571 cop->op_flags = flags;
3572 cop->op_private = (PL_hints & HINT_BYTE);
3574 cop->op_private |= NATIVE_HINTS;
3576 PL_compiling.op_private = cop->op_private;
3577 cop->op_next = (OP*)cop;
3580 cop->cop_label = label;
3581 PL_hints |= HINT_BLOCK_SCOPE;
3584 cop->cop_arybase = PL_curcop->cop_arybase;
3585 if (specialWARN(PL_curcop->cop_warnings))
3586 cop->cop_warnings = PL_curcop->cop_warnings ;
3588 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3589 if (specialCopIO(PL_curcop->cop_io))
3590 cop->cop_io = PL_curcop->cop_io;
3592 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3595 if (PL_copline == NOLINE)
3596 CopLINE_set(cop, CopLINE(PL_curcop));
3598 CopLINE_set(cop, PL_copline);
3599 PL_copline = NOLINE;
3602 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3604 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3606 CopSTASH_set(cop, PL_curstash);
3608 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3609 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3610 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3611 (void)SvIOK_on(*svp);
3612 SvIVX(*svp) = PTR2IV(cop);
3616 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3619 /* "Introduce" my variables to visible status. */
3627 if (! PL_min_intro_pending)
3628 return PL_cop_seqmax;
3630 svp = AvARRAY(PL_comppad_name);
3631 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3632 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3633 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3634 SvNVX(sv) = (NV)PL_cop_seqmax;
3637 PL_min_intro_pending = 0;
3638 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3639 return PL_cop_seqmax++;
3643 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3645 return new_logop(type, flags, &first, &other);
3649 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3653 OP *first = *firstp;
3654 OP *other = *otherp;
3656 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3657 return newBINOP(type, flags, scalar(first), scalar(other));
3659 scalarboolean(first);
3660 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3661 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3662 if (type == OP_AND || type == OP_OR) {
3668 first = *firstp = cUNOPo->op_first;
3670 first->op_next = o->op_next;
3671 cUNOPo->op_first = Nullop;
3675 if (first->op_type == OP_CONST) {
3676 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3677 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3678 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3689 else if (first->op_type == OP_WANTARRAY) {
3695 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3696 OP *k1 = ((UNOP*)first)->op_first;
3697 OP *k2 = k1->op_sibling;
3699 switch (first->op_type)
3702 if (k2 && k2->op_type == OP_READLINE
3703 && (k2->op_flags & OPf_STACKED)
3704 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3706 warnop = k2->op_type;
3711 if (k1->op_type == OP_READDIR
3712 || k1->op_type == OP_GLOB
3713 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3714 || k1->op_type == OP_EACH)
3716 warnop = ((k1->op_type == OP_NULL)
3717 ? k1->op_targ : k1->op_type);
3722 line_t oldline = CopLINE(PL_curcop);
3723 CopLINE_set(PL_curcop, PL_copline);
3724 Perl_warner(aTHX_ WARN_MISC,
3725 "Value of %s%s can be \"0\"; test with defined()",
3727 ((warnop == OP_READLINE || warnop == OP_GLOB)
3728 ? " construct" : "() operator"));
3729 CopLINE_set(PL_curcop, oldline);
3736 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3737 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3739 NewOp(1101, logop, 1, LOGOP);
3741 logop->op_type = type;
3742 logop->op_ppaddr = PL_ppaddr[type];
3743 logop->op_first = first;
3744 logop->op_flags = flags | OPf_KIDS;
3745 logop->op_other = LINKLIST(other);
3746 logop->op_private = 1 | (flags >> 8);
3748 /* establish postfix order */
3749 logop->op_next = LINKLIST(first);
3750 first->op_next = (OP*)logop;
3751 first->op_sibling = other;
3753 o = newUNOP(OP_NULL, 0, (OP*)logop);
3760 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3767 return newLOGOP(OP_AND, 0, first, trueop);
3769 return newLOGOP(OP_OR, 0, first, falseop);
3771 scalarboolean(first);
3772 if (first->op_type == OP_CONST) {
3773 if (SvTRUE(((SVOP*)first)->op_sv)) {
3784 else if (first->op_type == OP_WANTARRAY) {
3788 NewOp(1101, logop, 1, LOGOP);
3789 logop->op_type = OP_COND_EXPR;
3790 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3791 logop->op_first = first;
3792 logop->op_flags = flags | OPf_KIDS;
3793 logop->op_private = 1 | (flags >> 8);
3794 logop->op_other = LINKLIST(trueop);
3795 logop->op_next = LINKLIST(falseop);
3798 /* establish postfix order */
3799 start = LINKLIST(first);
3800 first->op_next = (OP*)logop;
3802 first->op_sibling = trueop;
3803 trueop->op_sibling = falseop;
3804 o = newUNOP(OP_NULL, 0, (OP*)logop);
3806 trueop->op_next = falseop->op_next = o;
3813 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3821 NewOp(1101, range, 1, LOGOP);
3823 range->op_type = OP_RANGE;
3824 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3825 range->op_first = left;
3826 range->op_flags = OPf_KIDS;
3827 leftstart = LINKLIST(left);
3828 range->op_other = LINKLIST(right);
3829 range->op_private = 1 | (flags >> 8);
3831 left->op_sibling = right;
3833 range->op_next = (OP*)range;
3834 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3835 flop = newUNOP(OP_FLOP, 0, flip);
3836 o = newUNOP(OP_NULL, 0, flop);
3838 range->op_next = leftstart;
3840 left->op_next = flip;
3841 right->op_next = flop;
3843 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3844 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3845 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3846 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3848 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3849 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3852 if (!flip->op_private || !flop->op_private)
3853 linklist(o); /* blow off optimizer unless constant */
3859 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3863 int once = block && block->op_flags & OPf_SPECIAL &&
3864 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3867 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3868 return block; /* do {} while 0 does once */
3869 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3870 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3871 expr = newUNOP(OP_DEFINED, 0,
3872 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3873 } else if (expr->op_flags & OPf_KIDS) {
3874 OP *k1 = ((UNOP*)expr)->op_first;
3875 OP *k2 = (k1) ? k1->op_sibling : NULL;
3876 switch (expr->op_type) {
3878 if (k2 && k2->op_type == OP_READLINE
3879 && (k2->op_flags & OPf_STACKED)
3880 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3881 expr = newUNOP(OP_DEFINED, 0, expr);
3885 if (k1->op_type == OP_READDIR
3886 || k1->op_type == OP_GLOB
3887 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3888 || k1->op_type == OP_EACH)
3889 expr = newUNOP(OP_DEFINED, 0, expr);
3895 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3896 o = new_logop(OP_AND, 0, &expr, &listop);
3899 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3901 if (once && o != listop)
3902 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3905 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3907 o->op_flags |= flags;
3909 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3914 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3923 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3924 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3925 expr = newUNOP(OP_DEFINED, 0,
3926 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3927 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3928 OP *k1 = ((UNOP*)expr)->op_first;
3929 OP *k2 = (k1) ? k1->op_sibling : NULL;
3930 switch (expr->op_type) {
3932 if (k2 && k2->op_type == OP_READLINE
3933 && (k2->op_flags & OPf_STACKED)
3934 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3935 expr = newUNOP(OP_DEFINED, 0, expr);
3939 if (k1->op_type == OP_READDIR
3940 || k1->op_type == OP_GLOB
3941 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3942 || k1->op_type == OP_EACH)
3943 expr = newUNOP(OP_DEFINED, 0, expr);
3949 block = newOP(OP_NULL, 0);
3951 block = scope(block);
3955 next = LINKLIST(cont);
3958 OP *unstack = newOP(OP_UNSTACK, 0);
3961 cont = append_elem(OP_LINESEQ, cont, unstack);
3962 if ((line_t)whileline != NOLINE) {
3963 PL_copline = whileline;
3964 cont = append_elem(OP_LINESEQ, cont,
3965 newSTATEOP(0, Nullch, Nullop));
3969 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3970 redo = LINKLIST(listop);
3973 PL_copline = whileline;
3975 o = new_logop(OP_AND, 0, &expr, &listop);
3976 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3977 op_free(expr); /* oops, it's a while (0) */
3979 return Nullop; /* listop already freed by new_logop */
3982 ((LISTOP*)listop)->op_last->op_next = condop =
3983 (o == listop ? redo : LINKLIST(o));
3989 NewOp(1101,loop,1,LOOP);
3990 loop->op_type = OP_ENTERLOOP;
3991 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3992 loop->op_private = 0;
3993 loop->op_next = (OP*)loop;
3996 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3998 loop->op_redoop = redo;
3999 loop->op_lastop = o;
4000 o->op_private |= loopflags;
4003 loop->op_nextop = next;
4005 loop->op_nextop = o;
4007 o->op_flags |= flags;
4008 o->op_private |= (flags >> 8);
4013 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4021 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4022 sv->op_type = OP_RV2GV;
4023 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4025 else if (sv->op_type == OP_PADSV) { /* private variable */
4026 padoff = sv->op_targ;
4031 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4032 padoff = sv->op_targ;
4034 iterflags |= OPf_SPECIAL;
4039 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4043 padoff = find_threadsv("_");
4044 iterflags |= OPf_SPECIAL;
4046 sv = newGVOP(OP_GV, 0, PL_defgv);
4049 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4050 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4051 iterflags |= OPf_STACKED;
4053 else if (expr->op_type == OP_NULL &&
4054 (expr->op_flags & OPf_KIDS) &&
4055 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4057 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4058 * set the STACKED flag to indicate that these values are to be
4059 * treated as min/max values by 'pp_iterinit'.
4061 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4062 LOGOP* range = (LOGOP*) flip->op_first;
4063 OP* left = range->op_first;
4064 OP* right = left->op_sibling;
4067 range->op_flags &= ~OPf_KIDS;
4068 range->op_first = Nullop;
4070 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4071 listop->op_first->op_next = range->op_next;
4072 left->op_next = range->op_other;
4073 right->op_next = (OP*)listop;
4074 listop->op_next = listop->op_first;
4077 expr = (OP*)(listop);
4079 iterflags |= OPf_STACKED;
4082 expr = mod(force_list(expr), OP_GREPSTART);
4086 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4087 append_elem(OP_LIST, expr, scalar(sv))));
4088 assert(!loop->op_next);
4089 #ifdef PL_OP_SLAB_ALLOC
4092 NewOp(1234,tmp,1,LOOP);
4093 Copy(loop,tmp,1,LOOP);
4097 Renew(loop, 1, LOOP);
4099 loop->op_targ = padoff;
4100 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4101 PL_copline = forline;
4102 return newSTATEOP(0, label, wop);
4106 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4111 if (type != OP_GOTO || label->op_type == OP_CONST) {
4112 /* "last()" means "last" */
4113 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4114 o = newOP(type, OPf_SPECIAL);
4116 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4117 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4123 if (label->op_type == OP_ENTERSUB)
4124 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4125 o = newUNOP(type, OPf_STACKED, label);
4127 PL_hints |= HINT_BLOCK_SCOPE;
4132 Perl_cv_undef(pTHX_ CV *cv)
4136 MUTEX_DESTROY(CvMUTEXP(cv));
4137 Safefree(CvMUTEXP(cv));
4140 #endif /* USE_THREADS */
4142 if (!CvXSUB(cv) && CvROOT(cv)) {
4144 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4145 Perl_croak(aTHX_ "Can't undef active subroutine");
4148 Perl_croak(aTHX_ "Can't undef active subroutine");
4149 #endif /* USE_THREADS */
4152 SAVEVPTR(PL_curpad);
4156 op_free(CvROOT(cv));
4157 CvROOT(cv) = Nullop;
4160 SvPOK_off((SV*)cv); /* forget prototype */
4162 SvREFCNT_dec(CvGV(cv));
4164 SvREFCNT_dec(CvOUTSIDE(cv));
4165 CvOUTSIDE(cv) = Nullcv;
4167 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4170 if (CvPADLIST(cv)) {
4171 /* may be during global destruction */
4172 if (SvREFCNT(CvPADLIST(cv))) {
4173 I32 i = AvFILLp(CvPADLIST(cv));
4175 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4176 SV* sv = svp ? *svp : Nullsv;
4179 if (sv == (SV*)PL_comppad_name)
4180 PL_comppad_name = Nullav;
4181 else if (sv == (SV*)PL_comppad) {
4182 PL_comppad = Nullav;
4183 PL_curpad = Null(SV**);
4187 SvREFCNT_dec((SV*)CvPADLIST(cv));
4189 CvPADLIST(cv) = Nullav;
4194 S_cv_dump(pTHX_ CV *cv)
4197 CV *outside = CvOUTSIDE(cv);
4198 AV* padlist = CvPADLIST(cv);
4205 PerlIO_printf(Perl_debug_log,
4206 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4208 (CvANON(cv) ? "ANON"
4209 : (cv == PL_main_cv) ? "MAIN"
4210 : CvUNIQUE(cv) ? "UNIQUE"
4211 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4214 : CvANON(outside) ? "ANON"
4215 : (outside == PL_main_cv) ? "MAIN"
4216 : CvUNIQUE(outside) ? "UNIQUE"
4217 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4222 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4223 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4224 pname = AvARRAY(pad_name);
4225 ppad = AvARRAY(pad);
4227 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4228 if (SvPOK(pname[ix]))
4229 PerlIO_printf(Perl_debug_log,
4230 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4231 (int)ix, PTR2UV(ppad[ix]),
4232 SvFAKE(pname[ix]) ? "FAKE " : "",
4234 (IV)I_32(SvNVX(pname[ix])),
4237 #endif /* DEBUGGING */
4241 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4245 AV* protopadlist = CvPADLIST(proto);
4246 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4247 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4248 SV** pname = AvARRAY(protopad_name);
4249 SV** ppad = AvARRAY(protopad);
4250 I32 fname = AvFILLp(protopad_name);
4251 I32 fpad = AvFILLp(protopad);
4255 assert(!CvUNIQUE(proto));
4259 SAVESPTR(PL_comppad_name);
4260 SAVESPTR(PL_compcv);
4262 cv = PL_compcv = (CV*)NEWSV(1104,0);
4263 sv_upgrade((SV *)cv, SvTYPE(proto));
4264 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4268 New(666, CvMUTEXP(cv), 1, perl_mutex);
4269 MUTEX_INIT(CvMUTEXP(cv));
4271 #endif /* USE_THREADS */
4272 CvFILE(cv) = CvFILE(proto);
4273 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4274 CvSTASH(cv) = CvSTASH(proto);
4275 CvROOT(cv) = CvROOT(proto);
4276 CvSTART(cv) = CvSTART(proto);
4278 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4281 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4283 PL_comppad_name = newAV();
4284 for (ix = fname; ix >= 0; ix--)
4285 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4287 PL_comppad = newAV();
4289 comppadlist = newAV();
4290 AvREAL_off(comppadlist);
4291 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4292 av_store(comppadlist, 1, (SV*)PL_comppad);
4293 CvPADLIST(cv) = comppadlist;
4294 av_fill(PL_comppad, AvFILLp(protopad));
4295 PL_curpad = AvARRAY(PL_comppad);
4297 av = newAV(); /* will be @_ */
4299 av_store(PL_comppad, 0, (SV*)av);
4300 AvFLAGS(av) = AVf_REIFY;
4302 for (ix = fpad; ix > 0; ix--) {
4303 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4304 if (namesv && namesv != &PL_sv_undef) {
4305 char *name = SvPVX(namesv); /* XXX */
4306 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4307 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4308 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4310 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4312 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4314 else { /* our own lexical */
4317 /* anon code -- we'll come back for it */
4318 sv = SvREFCNT_inc(ppad[ix]);
4320 else if (*name == '@')
4322 else if (*name == '%')
4331 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4332 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4335 SV* sv = NEWSV(0,0);
4341 /* Now that vars are all in place, clone nested closures. */
4343 for (ix = fpad; ix > 0; ix--) {
4344 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4346 && namesv != &PL_sv_undef
4347 && !(SvFLAGS(namesv) & SVf_FAKE)
4348 && *SvPVX(namesv) == '&'
4349 && CvCLONE(ppad[ix]))
4351 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4352 SvREFCNT_dec(ppad[ix]);
4355 PL_curpad[ix] = (SV*)kid;
4359 #ifdef DEBUG_CLOSURES
4360 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4362 PerlIO_printf(Perl_debug_log, " from:\n");
4364 PerlIO_printf(Perl_debug_log, " to:\n");
4371 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4373 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4375 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4382 Perl_cv_clone(pTHX_ CV *proto)
4385 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4386 cv = cv_clone2(proto, CvOUTSIDE(proto));
4387 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4392 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4394 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4395 SV* msg = sv_newmortal();
4399 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4400 sv_setpv(msg, "Prototype mismatch:");
4402 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4404 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4405 sv_catpv(msg, " vs ");
4407 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4409 sv_catpv(msg, "none");
4410 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4414 static void const_sv_xsub(pTHXo_ CV* cv);
4417 =for apidoc cv_const_sv
4419 If C<cv> is a constant sub eligible for inlining. returns the constant
4420 value returned by the sub. Otherwise, returns NULL.
4422 Constant subs can be created with C<newCONSTSUB> or as described in
4423 L<perlsub/"Constant Functions">.
4428 Perl_cv_const_sv(pTHX_ CV *cv)
4430 if (!cv || !CvCONST(cv))
4432 return (SV*)CvXSUBANY(cv).any_ptr;
4436 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4443 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4444 o = cLISTOPo->op_first->op_sibling;
4446 for (; o; o = o->op_next) {
4447 OPCODE type = o->op_type;
4449 if (sv && o->op_next == o)
4451 if (o->op_next != o) {
4452 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4454 if (type == OP_DBSTATE)
4457 if (type == OP_LEAVESUB || type == OP_RETURN)
4461 if (type == OP_CONST && cSVOPo->op_sv)
4463 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4464 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4465 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4469 /* We get here only from cv_clone2() while creating a closure.
4470 Copy the const value here instead of in cv_clone2 so that
4471 SvREADONLY_on doesn't lead to problems when leaving
4476 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4488 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4498 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4502 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4504 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4508 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4514 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4519 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4520 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4521 SV *sv = sv_newmortal();
4522 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4523 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4528 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4529 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4539 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4540 maximum a prototype before. */
4541 if (SvTYPE(gv) > SVt_NULL) {
4542 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4543 && ckWARN_d(WARN_PROTOTYPE))
4545 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4547 cv_ckproto((CV*)gv, NULL, ps);
4550 sv_setpv((SV*)gv, ps);
4552 sv_setiv((SV*)gv, -1);
4553 SvREFCNT_dec(PL_compcv);
4554 cv = PL_compcv = NULL;
4555 PL_sub_generation++;
4559 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4561 if (!block || !ps || *ps || attrs)
4564 const_sv = op_const_sv(block, Nullcv);
4567 bool exists = CvROOT(cv) || CvXSUB(cv);
4568 /* if the subroutine doesn't exist and wasn't pre-declared
4569 * with a prototype, assume it will be AUTOLOADed,
4570 * skipping the prototype check
4572 if (exists || SvPOK(cv))
4573 cv_ckproto(cv, gv, ps);
4574 /* already defined (or promised)? */
4575 if (exists || GvASSUMECV(gv)) {
4576 if (!block && !attrs) {
4577 /* just a "sub foo;" when &foo is already defined */
4578 SAVEFREESV(PL_compcv);
4581 /* ahem, death to those who redefine active sort subs */
4582 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4583 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4585 if (ckWARN(WARN_REDEFINE)
4587 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4589 line_t oldline = CopLINE(PL_curcop);
4590 CopLINE_set(PL_curcop, PL_copline);
4591 Perl_warner(aTHX_ WARN_REDEFINE,
4592 CvCONST(cv) ? "Constant subroutine %s redefined"
4593 : "Subroutine %s redefined", name);
4594 CopLINE_set(PL_curcop, oldline);
4602 SvREFCNT_inc(const_sv);
4604 assert(!CvROOT(cv) && !CvCONST(cv));
4605 sv_setpv((SV*)cv, ""); /* prototype is "" */
4606 CvXSUBANY(cv).any_ptr = const_sv;
4607 CvXSUB(cv) = const_sv_xsub;
4612 cv = newCONSTSUB(NULL, name, const_sv);
4615 SvREFCNT_dec(PL_compcv);
4617 PL_sub_generation++;
4624 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4625 * before we clobber PL_compcv.
4629 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4630 stash = GvSTASH(CvGV(cv));
4631 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4632 stash = CvSTASH(cv);
4634 stash = PL_curstash;
4637 /* possibly about to re-define existing subr -- ignore old cv */
4638 rcv = (SV*)PL_compcv;
4639 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4640 stash = GvSTASH(gv);
4642 stash = PL_curstash;
4644 apply_attrs(stash, rcv, attrs);
4646 if (cv) { /* must reuse cv if autoloaded */
4648 /* got here with just attrs -- work done, so bug out */
4649 SAVEFREESV(PL_compcv);
4653 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4654 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4655 CvOUTSIDE(PL_compcv) = 0;
4656 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4657 CvPADLIST(PL_compcv) = 0;
4658 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4659 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4660 SvREFCNT_dec(PL_compcv);
4667 PL_sub_generation++;
4670 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4671 CvFILE(cv) = CopFILE(PL_curcop);
4672 CvSTASH(cv) = PL_curstash;
4675 if (!CvMUTEXP(cv)) {
4676 New(666, CvMUTEXP(cv), 1, perl_mutex);
4677 MUTEX_INIT(CvMUTEXP(cv));
4679 #endif /* USE_THREADS */
4682 sv_setpv((SV*)cv, ps);
4684 if (PL_error_count) {
4688 char *s = strrchr(name, ':');
4690 if (strEQ(s, "BEGIN")) {
4692 "BEGIN not safe after errors--compilation aborted";
4693 if (PL_in_eval & EVAL_KEEPERR)
4694 Perl_croak(aTHX_ not_safe);
4696 /* force display of errors found but not reported */
4697 sv_catpv(ERRSV, not_safe);
4698 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4706 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4707 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4710 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4711 mod(scalarseq(block), OP_LEAVESUBLV));
4714 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4716 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4717 OpREFCNT_set(CvROOT(cv), 1);
4718 CvSTART(cv) = LINKLIST(CvROOT(cv));
4719 CvROOT(cv)->op_next = 0;
4722 /* now that optimizer has done its work, adjust pad values */
4724 SV **namep = AvARRAY(PL_comppad_name);
4725 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4728 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4731 * The only things that a clonable function needs in its
4732 * pad are references to outer lexicals and anonymous subs.
4733 * The rest are created anew during cloning.
4735 if (!((namesv = namep[ix]) != Nullsv &&
4736 namesv != &PL_sv_undef &&
4738 *SvPVX(namesv) == '&')))
4740 SvREFCNT_dec(PL_curpad[ix]);
4741 PL_curpad[ix] = Nullsv;
4744 assert(!CvCONST(cv));
4745 if (ps && !*ps && op_const_sv(block, cv))
4749 AV *av = newAV(); /* Will be @_ */
4751 av_store(PL_comppad, 0, (SV*)av);
4752 AvFLAGS(av) = AVf_REIFY;
4754 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4755 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4757 if (!SvPADMY(PL_curpad[ix]))
4758 SvPADTMP_on(PL_curpad[ix]);
4762 if (name || aname) {
4764 char *tname = (name ? name : aname);
4766 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4767 SV *sv = NEWSV(0,0);
4768 SV *tmpstr = sv_newmortal();
4769 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4773 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4775 (long)PL_subline, (long)CopLINE(PL_curcop));
4776 gv_efullname3(tmpstr, gv, Nullch);
4777 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4778 hv = GvHVn(db_postponed);
4779 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4780 && (pcv = GvCV(db_postponed)))
4786 call_sv((SV*)pcv, G_DISCARD);
4790 if ((s = strrchr(tname,':')))
4795 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4798 if (strEQ(s, "BEGIN")) {
4799 I32 oldscope = PL_scopestack_ix;
4801 SAVECOPFILE(&PL_compiling);
4802 SAVECOPLINE(&PL_compiling);
4804 sv_setsv(PL_rs, PL_nrs);
4807 PL_beginav = newAV();
4808 DEBUG_x( dump_sub(gv) );
4809 av_push(PL_beginav, (SV*)cv);
4810 GvCV(gv) = 0; /* cv has been hijacked */
4811 call_list(oldscope, PL_beginav);
4813 PL_curcop = &PL_compiling;
4814 PL_compiling.op_private = PL_hints;
4817 else if (strEQ(s, "END") && !PL_error_count) {
4820 DEBUG_x( dump_sub(gv) );
4821 av_unshift(PL_endav, 1);
4822 av_store(PL_endav, 0, (SV*)cv);
4823 GvCV(gv) = 0; /* cv has been hijacked */
4825 else if (strEQ(s, "CHECK") && !PL_error_count) {
4827 PL_checkav = newAV();
4828 DEBUG_x( dump_sub(gv) );
4829 if (PL_main_start && ckWARN(WARN_VOID))
4830 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4831 av_unshift(PL_checkav, 1);
4832 av_store(PL_checkav, 0, (SV*)cv);
4833 GvCV(gv) = 0; /* cv has been hijacked */
4835 else if (strEQ(s, "INIT") && !PL_error_count) {
4837 PL_initav = newAV();
4838 DEBUG_x( dump_sub(gv) );
4839 if (PL_main_start && ckWARN(WARN_VOID))
4840 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4841 av_push(PL_initav, (SV*)cv);
4842 GvCV(gv) = 0; /* cv has been hijacked */
4847 PL_copline = NOLINE;
4852 /* XXX unsafe for threads if eval_owner isn't held */
4854 =for apidoc newCONSTSUB
4856 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4857 eligible for inlining at compile-time.
4863 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4869 SAVECOPLINE(PL_curcop);
4870 CopLINE_set(PL_curcop, PL_copline);
4873 PL_hints &= ~HINT_BLOCK_SCOPE;
4876 SAVESPTR(PL_curstash);
4877 SAVECOPSTASH(PL_curcop);
4878 PL_curstash = stash;
4880 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4882 CopSTASH(PL_curcop) = stash;
4886 cv = newXS(name, const_sv_xsub, __FILE__);
4887 CvXSUBANY(cv).any_ptr = sv;
4889 sv_setpv((SV*)cv, ""); /* prototype is "" */
4897 =for apidoc U||newXS
4899 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4905 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4907 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4910 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4912 /* just a cached method */
4916 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4917 /* already defined (or promised) */
4918 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4919 && HvNAME(GvSTASH(CvGV(cv)))
4920 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4921 line_t oldline = CopLINE(PL_curcop);
4922 if (PL_copline != NOLINE)
4923 CopLINE_set(PL_curcop, PL_copline);
4924 Perl_warner(aTHX_ WARN_REDEFINE,
4925 CvCONST(cv) ? "Constant subroutine %s redefined"
4926 : "Subroutine %s redefined"
4928 CopLINE_set(PL_curcop, oldline);
4935 if (cv) /* must reuse cv if autoloaded */
4938 cv = (CV*)NEWSV(1105,0);
4939 sv_upgrade((SV *)cv, SVt_PVCV);
4943 PL_sub_generation++;
4946 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4948 New(666, CvMUTEXP(cv), 1, perl_mutex);
4949 MUTEX_INIT(CvMUTEXP(cv));
4951 #endif /* USE_THREADS */
4952 (void)gv_fetchfile(filename);
4953 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4954 an external constant string */
4955 CvXSUB(cv) = subaddr;
4958 char *s = strrchr(name,':');
4964 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4967 if (strEQ(s, "BEGIN")) {
4969 PL_beginav = newAV();
4970 av_push(PL_beginav, (SV*)cv);
4971 GvCV(gv) = 0; /* cv has been hijacked */
4973 else if (strEQ(s, "END")) {
4976 av_unshift(PL_endav, 1);
4977 av_store(PL_endav, 0, (SV*)cv);
4978 GvCV(gv) = 0; /* cv has been hijacked */
4980 else if (strEQ(s, "CHECK")) {
4982 PL_checkav = newAV();
4983 if (PL_main_start && ckWARN(WARN_VOID))
4984 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4985 av_unshift(PL_checkav, 1);
4986 av_store(PL_checkav, 0, (SV*)cv);
4987 GvCV(gv) = 0; /* cv has been hijacked */
4989 else if (strEQ(s, "INIT")) {
4991 PL_initav = newAV();
4992 if (PL_main_start && ckWARN(WARN_VOID))
4993 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4994 av_push(PL_initav, (SV*)cv);
4995 GvCV(gv) = 0; /* cv has been hijacked */
5006 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5015 name = SvPVx(cSVOPo->op_sv, n_a);
5018 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5020 if ((cv = GvFORM(gv))) {
5021 if (ckWARN(WARN_REDEFINE)) {
5022 line_t oldline = CopLINE(PL_curcop);
5024 CopLINE_set(PL_curcop, PL_copline);
5025 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5026 CopLINE_set(PL_curcop, oldline);
5032 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
5033 CvFILE(cv) = CopFILE(PL_curcop);
5035 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5036 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5037 SvPADTMP_on(PL_curpad[ix]);
5040 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5041 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5042 OpREFCNT_set(CvROOT(cv), 1);
5043 CvSTART(cv) = LINKLIST(CvROOT(cv));
5044 CvROOT(cv)->op_next = 0;
5047 PL_copline = NOLINE;
5052 Perl_newANONLIST(pTHX_ OP *o)
5054 return newUNOP(OP_REFGEN, 0,
5055 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5059 Perl_newANONHASH(pTHX_ OP *o)
5061 return newUNOP(OP_REFGEN, 0,
5062 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5066 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5068 return newANONATTRSUB(floor, proto, Nullop, block);
5072 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5074 return newUNOP(OP_REFGEN, 0,
5075 newSVOP(OP_ANONCODE, 0,
5076 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5080 Perl_oopsAV(pTHX_ OP *o)
5082 switch (o->op_type) {
5084 o->op_type = OP_PADAV;
5085 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5086 return ref(o, OP_RV2AV);
5089 o->op_type = OP_RV2AV;
5090 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5095 if (ckWARN_d(WARN_INTERNAL))
5096 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5103 Perl_oopsHV(pTHX_ OP *o)
5105 switch (o->op_type) {
5108 o->op_type = OP_PADHV;
5109 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5110 return ref(o, OP_RV2HV);
5114 o->op_type = OP_RV2HV;
5115 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5120 if (ckWARN_d(WARN_INTERNAL))
5121 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5128 Perl_newAVREF(pTHX_ OP *o)
5130 if (o->op_type == OP_PADANY) {
5131 o->op_type = OP_PADAV;
5132 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5135 return newUNOP(OP_RV2AV, 0, scalar(o));
5139 Perl_newGVREF(pTHX_ I32 type, OP *o)
5141 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5142 return newUNOP(OP_NULL, 0, o);
5143 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5147 Perl_newHVREF(pTHX_ OP *o)
5149 if (o->op_type == OP_PADANY) {
5150 o->op_type = OP_PADHV;
5151 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5154 return newUNOP(OP_RV2HV, 0, scalar(o));
5158 Perl_oopsCV(pTHX_ OP *o)
5160 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5166 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5168 return newUNOP(OP_RV2CV, flags, scalar(o));
5172 Perl_newSVREF(pTHX_ OP *o)
5174 if (o->op_type == OP_PADANY) {
5175 o->op_type = OP_PADSV;
5176 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5179 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5180 o->op_flags |= OPpDONE_SVREF;
5183 return newUNOP(OP_RV2SV, 0, scalar(o));
5186 /* Check routines. */
5189 Perl_ck_anoncode(pTHX_ OP *o)
5194 name = NEWSV(1106,0);
5195 sv_upgrade(name, SVt_PVNV);
5196 sv_setpvn(name, "&", 1);
5199 ix = pad_alloc(o->op_type, SVs_PADMY);
5200 av_store(PL_comppad_name, ix, name);
5201 av_store(PL_comppad, ix, cSVOPo->op_sv);
5202 SvPADMY_on(cSVOPo->op_sv);
5203 cSVOPo->op_sv = Nullsv;
5204 cSVOPo->op_targ = ix;
5209 Perl_ck_bitop(pTHX_ OP *o)
5211 o->op_private = PL_hints;
5216 Perl_ck_concat(pTHX_ OP *o)
5218 if (cUNOPo->op_first->op_type == OP_CONCAT)
5219 o->op_flags |= OPf_STACKED;
5224 Perl_ck_spair(pTHX_ OP *o)
5226 if (o->op_flags & OPf_KIDS) {
5229 OPCODE type = o->op_type;
5230 o = modkids(ck_fun(o), type);
5231 kid = cUNOPo->op_first;
5232 newop = kUNOP->op_first->op_sibling;
5234 (newop->op_sibling ||
5235 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5236 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5237 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5241 op_free(kUNOP->op_first);
5242 kUNOP->op_first = newop;
5244 o->op_ppaddr = PL_ppaddr[++o->op_type];
5249 Perl_ck_delete(pTHX_ OP *o)
5253 if (o->op_flags & OPf_KIDS) {
5254 OP *kid = cUNOPo->op_first;
5255 switch (kid->op_type) {
5257 o->op_flags |= OPf_SPECIAL;
5260 o->op_private |= OPpSLICE;
5263 o->op_flags |= OPf_SPECIAL;
5268 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5269 PL_op_desc[o->op_type]);
5277 Perl_ck_eof(pTHX_ OP *o)
5279 I32 type = o->op_type;
5281 if (o->op_flags & OPf_KIDS) {
5282 if (cLISTOPo->op_first->op_type == OP_STUB) {
5284 o = newUNOP(type, OPf_SPECIAL,
5285 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5293 Perl_ck_eval(pTHX_ OP *o)
5295 PL_hints |= HINT_BLOCK_SCOPE;
5296 if (o->op_flags & OPf_KIDS) {
5297 SVOP *kid = (SVOP*)cUNOPo->op_first;
5300 o->op_flags &= ~OPf_KIDS;
5303 else if (kid->op_type == OP_LINESEQ) {
5306 kid->op_next = o->op_next;
5307 cUNOPo->op_first = 0;
5310 NewOp(1101, enter, 1, LOGOP);
5311 enter->op_type = OP_ENTERTRY;
5312 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5313 enter->op_private = 0;
5315 /* establish postfix order */
5316 enter->op_next = (OP*)enter;
5318 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5319 o->op_type = OP_LEAVETRY;
5320 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5321 enter->op_other = o;
5329 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5331 o->op_targ = (PADOFFSET)PL_hints;
5336 Perl_ck_exit(pTHX_ OP *o)
5339 HV *table = GvHV(PL_hintgv);
5341 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5342 if (svp && *svp && SvTRUE(*svp))
5343 o->op_private |= OPpEXIT_VMSISH;
5350 Perl_ck_exec(pTHX_ OP *o)
5353 if (o->op_flags & OPf_STACKED) {
5355 kid = cUNOPo->op_first->op_sibling;
5356 if (kid->op_type == OP_RV2GV)
5365 Perl_ck_exists(pTHX_ OP *o)
5368 if (o->op_flags & OPf_KIDS) {
5369 OP *kid = cUNOPo->op_first;
5370 if (kid->op_type == OP_ENTERSUB) {
5371 (void) ref(kid, o->op_type);
5372 if (kid->op_type != OP_RV2CV && !PL_error_count)
5373 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5374 PL_op_desc[o->op_type]);
5375 o->op_private |= OPpEXISTS_SUB;
5377 else if (kid->op_type == OP_AELEM)
5378 o->op_flags |= OPf_SPECIAL;
5379 else if (kid->op_type != OP_HELEM)
5380 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5381 PL_op_desc[o->op_type]);
5389 Perl_ck_gvconst(pTHX_ register OP *o)
5391 o = fold_constants(o);
5392 if (o->op_type == OP_CONST)
5399 Perl_ck_rvconst(pTHX_ register OP *o)
5401 SVOP *kid = (SVOP*)cUNOPo->op_first;
5403 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5404 if (kid->op_type == OP_CONST) {
5408 SV *kidsv = kid->op_sv;
5411 /* Is it a constant from cv_const_sv()? */
5412 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5413 SV *rsv = SvRV(kidsv);
5414 int svtype = SvTYPE(rsv);
5415 char *badtype = Nullch;
5417 switch (o->op_type) {
5419 if (svtype > SVt_PVMG)
5420 badtype = "a SCALAR";
5423 if (svtype != SVt_PVAV)
5424 badtype = "an ARRAY";
5427 if (svtype != SVt_PVHV) {
5428 if (svtype == SVt_PVAV) { /* pseudohash? */
5429 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5430 if (ksv && SvROK(*ksv)
5431 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5440 if (svtype != SVt_PVCV)
5445 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5448 name = SvPV(kidsv, n_a);
5449 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5450 char *badthing = Nullch;
5451 switch (o->op_type) {
5453 badthing = "a SCALAR";
5456 badthing = "an ARRAY";
5459 badthing = "a HASH";
5464 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5468 * This is a little tricky. We only want to add the symbol if we
5469 * didn't add it in the lexer. Otherwise we get duplicate strict
5470 * warnings. But if we didn't add it in the lexer, we must at
5471 * least pretend like we wanted to add it even if it existed before,
5472 * or we get possible typo warnings. OPpCONST_ENTERED says
5473 * whether the lexer already added THIS instance of this symbol.
5475 iscv = (o->op_type == OP_RV2CV) * 2;
5477 gv = gv_fetchpv(name,
5478 iscv | !(kid->op_private & OPpCONST_ENTERED),
5481 : o->op_type == OP_RV2SV
5483 : o->op_type == OP_RV2AV
5485 : o->op_type == OP_RV2HV
5488 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5490 kid->op_type = OP_GV;
5491 SvREFCNT_dec(kid->op_sv);
5493 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5494 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5495 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5497 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5499 kid->op_sv = SvREFCNT_inc(gv);
5501 kid->op_private = 0;
5502 kid->op_ppaddr = PL_ppaddr[OP_GV];
5509 Perl_ck_ftst(pTHX_ OP *o)
5511 I32 type = o->op_type;
5513 if (o->op_flags & OPf_REF) {
5516 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5517 SVOP *kid = (SVOP*)cUNOPo->op_first;
5519 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5521 OP *newop = newGVOP(type, OPf_REF,
5522 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5529 if (type == OP_FTTTY)
5530 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5533 o = newUNOP(type, 0, newDEFSVOP());
5536 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5538 if (PL_hints & HINT_LOCALE)
5539 o->op_private |= OPpLOCALE;
5546 Perl_ck_fun(pTHX_ OP *o)
5552 int type = o->op_type;
5553 register I32 oa = PL_opargs[type] >> OASHIFT;
5555 if (o->op_flags & OPf_STACKED) {
5556 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5559 return no_fh_allowed(o);
5562 if (o->op_flags & OPf_KIDS) {
5564 tokid = &cLISTOPo->op_first;
5565 kid = cLISTOPo->op_first;
5566 if (kid->op_type == OP_PUSHMARK ||
5567 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5569 tokid = &kid->op_sibling;
5570 kid = kid->op_sibling;
5572 if (!kid && PL_opargs[type] & OA_DEFGV)
5573 *tokid = kid = newDEFSVOP();
5577 sibl = kid->op_sibling;
5580 /* list seen where single (scalar) arg expected? */
5581 if (numargs == 1 && !(oa >> 4)
5582 && kid->op_type == OP_LIST && type != OP_SCALAR)
5584 return too_many_arguments(o,PL_op_desc[type]);
5597 if (kid->op_type == OP_CONST &&
5598 (kid->op_private & OPpCONST_BARE))
5600 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5601 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5602 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5603 if (ckWARN(WARN_DEPRECATED))
5604 Perl_warner(aTHX_ WARN_DEPRECATED,
5605 "Array @%s missing the @ in argument %"IVdf" of %s()",
5606 name, (IV)numargs, PL_op_desc[type]);
5609 kid->op_sibling = sibl;
5612 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5613 bad_type(numargs, "array", PL_op_desc[type], kid);
5617 if (kid->op_type == OP_CONST &&
5618 (kid->op_private & OPpCONST_BARE))
5620 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5621 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5622 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5623 if (ckWARN(WARN_DEPRECATED))
5624 Perl_warner(aTHX_ WARN_DEPRECATED,
5625 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5626 name, (IV)numargs, PL_op_desc[type]);
5629 kid->op_sibling = sibl;
5632 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5633 bad_type(numargs, "hash", PL_op_desc[type], kid);
5638 OP *newop = newUNOP(OP_NULL, 0, kid);
5639 kid->op_sibling = 0;
5641 newop->op_next = newop;
5643 kid->op_sibling = sibl;
5648 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5649 if (kid->op_type == OP_CONST &&
5650 (kid->op_private & OPpCONST_BARE))
5652 OP *newop = newGVOP(OP_GV, 0,
5653 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5658 else if (kid->op_type == OP_READLINE) {
5659 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5660 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5663 I32 flags = OPf_SPECIAL;
5667 /* is this op a FH constructor? */
5668 if (is_handle_constructor(o,numargs)) {
5669 char *name = Nullch;
5673 /* Set a flag to tell rv2gv to vivify
5674 * need to "prove" flag does not mean something
5675 * else already - NI-S 1999/05/07
5678 if (kid->op_type == OP_PADSV) {
5679 SV **namep = av_fetch(PL_comppad_name,
5681 if (namep && *namep)
5682 name = SvPV(*namep, len);
5684 else if (kid->op_type == OP_RV2SV
5685 && kUNOP->op_first->op_type == OP_GV)
5687 GV *gv = cGVOPx_gv(kUNOP->op_first);
5689 len = GvNAMELEN(gv);
5691 else if (kid->op_type == OP_AELEM
5692 || kid->op_type == OP_HELEM)
5694 name = "__ANONIO__";
5700 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5701 namesv = PL_curpad[targ];
5702 (void)SvUPGRADE(namesv, SVt_PV);
5704 sv_setpvn(namesv, "$", 1);
5705 sv_catpvn(namesv, name, len);
5708 kid->op_sibling = 0;
5709 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5710 kid->op_targ = targ;
5711 kid->op_private |= priv;
5713 kid->op_sibling = sibl;
5719 mod(scalar(kid), type);
5723 tokid = &kid->op_sibling;
5724 kid = kid->op_sibling;
5726 o->op_private |= numargs;
5728 return too_many_arguments(o,PL_op_desc[o->op_type]);
5731 else if (PL_opargs[type] & OA_DEFGV) {
5733 return newUNOP(type, 0, newDEFSVOP());
5737 while (oa & OA_OPTIONAL)
5739 if (oa && oa != OA_LIST)
5740 return too_few_arguments(o,PL_op_desc[o->op_type]);
5746 Perl_ck_glob(pTHX_ OP *o)
5751 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5752 append_elem(OP_GLOB, o, newDEFSVOP());
5754 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5755 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5757 #if !defined(PERL_EXTERNAL_GLOB)
5758 /* XXX this can be tightened up and made more failsafe. */
5761 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5762 /* null-terminated import list */
5763 newSVpvn(":globally", 9), Nullsv);
5764 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5767 #endif /* PERL_EXTERNAL_GLOB */
5769 if (gv && GvIMPORTED_CV(gv)) {
5770 append_elem(OP_GLOB, o,
5771 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5772 o->op_type = OP_LIST;
5773 o->op_ppaddr = PL_ppaddr[OP_LIST];
5774 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5775 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5776 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5777 append_elem(OP_LIST, o,
5778 scalar(newUNOP(OP_RV2CV, 0,
5779 newGVOP(OP_GV, 0, gv)))));
5780 o = newUNOP(OP_NULL, 0, ck_subr(o));
5781 o->op_targ = OP_GLOB; /* hint at what it used to be */
5784 gv = newGVgen("main");
5786 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5792 Perl_ck_grep(pTHX_ OP *o)
5796 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5798 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5799 NewOp(1101, gwop, 1, LOGOP);
5801 if (o->op_flags & OPf_STACKED) {
5804 kid = cLISTOPo->op_first->op_sibling;
5805 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5808 kid->op_next = (OP*)gwop;
5809 o->op_flags &= ~OPf_STACKED;
5811 kid = cLISTOPo->op_first->op_sibling;
5812 if (type == OP_MAPWHILE)
5819 kid = cLISTOPo->op_first->op_sibling;
5820 if (kid->op_type != OP_NULL)
5821 Perl_croak(aTHX_ "panic: ck_grep");
5822 kid = kUNOP->op_first;
5824 gwop->op_type = type;
5825 gwop->op_ppaddr = PL_ppaddr[type];
5826 gwop->op_first = listkids(o);
5827 gwop->op_flags |= OPf_KIDS;
5828 gwop->op_private = 1;
5829 gwop->op_other = LINKLIST(kid);
5830 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5831 kid->op_next = (OP*)gwop;
5833 kid = cLISTOPo->op_first->op_sibling;
5834 if (!kid || !kid->op_sibling)
5835 return too_few_arguments(o,PL_op_desc[o->op_type]);
5836 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5837 mod(kid, OP_GREPSTART);
5843 Perl_ck_index(pTHX_ OP *o)
5845 if (o->op_flags & OPf_KIDS) {
5846 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5848 kid = kid->op_sibling; /* get past "big" */
5849 if (kid && kid->op_type == OP_CONST)
5850 fbm_compile(((SVOP*)kid)->op_sv, 0);
5856 Perl_ck_lengthconst(pTHX_ OP *o)
5858 /* XXX length optimization goes here */
5863 Perl_ck_lfun(pTHX_ OP *o)
5865 OPCODE type = o->op_type;
5866 return modkids(ck_fun(o), type);
5870 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5872 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5873 switch (cUNOPo->op_first->op_type) {
5875 /* This is needed for
5876 if (defined %stash::)
5877 to work. Do not break Tk.
5879 break; /* Globals via GV can be undef */
5881 case OP_AASSIGN: /* Is this a good idea? */
5882 Perl_warner(aTHX_ WARN_DEPRECATED,
5883 "defined(@array) is deprecated");
5884 Perl_warner(aTHX_ WARN_DEPRECATED,
5885 "\t(Maybe you should just omit the defined()?)\n");
5888 /* This is needed for
5889 if (defined %stash::)
5890 to work. Do not break Tk.
5892 break; /* Globals via GV can be undef */
5894 Perl_warner(aTHX_ WARN_DEPRECATED,
5895 "defined(%%hash) is deprecated");
5896 Perl_warner(aTHX_ WARN_DEPRECATED,
5897 "\t(Maybe you should just omit the defined()?)\n");
5908 Perl_ck_rfun(pTHX_ OP *o)
5910 OPCODE type = o->op_type;
5911 return refkids(ck_fun(o), type);
5915 Perl_ck_listiob(pTHX_ OP *o)
5919 kid = cLISTOPo->op_first;
5922 kid = cLISTOPo->op_first;
5924 if (kid->op_type == OP_PUSHMARK)
5925 kid = kid->op_sibling;
5926 if (kid && o->op_flags & OPf_STACKED)
5927 kid = kid->op_sibling;
5928 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5929 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5930 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5931 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5932 cLISTOPo->op_first->op_sibling = kid;
5933 cLISTOPo->op_last = kid;
5934 kid = kid->op_sibling;
5939 append_elem(o->op_type, o, newDEFSVOP());
5945 if (PL_hints & HINT_LOCALE)
5946 o->op_private |= OPpLOCALE;
5953 Perl_ck_fun_locale(pTHX_ OP *o)
5959 if (PL_hints & HINT_LOCALE)
5960 o->op_private |= OPpLOCALE;
5967 Perl_ck_sassign(pTHX_ OP *o)
5969 OP *kid = cLISTOPo->op_first;
5970 /* has a disposable target? */
5971 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5972 && !(kid->op_flags & OPf_STACKED)
5973 /* Cannot steal the second time! */
5974 && !(kid->op_private & OPpTARGET_MY))
5976 OP *kkid = kid->op_sibling;
5978 /* Can just relocate the target. */
5979 if (kkid && kkid->op_type == OP_PADSV
5980 && !(kkid->op_private & OPpLVAL_INTRO))
5982 kid->op_targ = kkid->op_targ;
5984 /* Now we do not need PADSV and SASSIGN. */
5985 kid->op_sibling = o->op_sibling; /* NULL */
5986 cLISTOPo->op_first = NULL;
5989 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5997 Perl_ck_scmp(pTHX_ OP *o)
6001 if (PL_hints & HINT_LOCALE)
6002 o->op_private |= OPpLOCALE;
6009 Perl_ck_match(pTHX_ OP *o)
6011 o->op_private |= OPpRUNTIME;
6016 Perl_ck_method(pTHX_ OP *o)
6018 OP *kid = cUNOPo->op_first;
6019 if (kid->op_type == OP_CONST) {
6020 SV* sv = kSVOP->op_sv;
6021 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6023 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6024 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6027 kSVOP->op_sv = Nullsv;
6029 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6038 Perl_ck_null(pTHX_ OP *o)
6044 Perl_ck_open(pTHX_ OP *o)
6046 HV *table = GvHV(PL_hintgv);
6050 svp = hv_fetch(table, "open_IN", 7, FALSE);
6052 mode = mode_from_discipline(*svp);
6053 if (mode & O_BINARY)
6054 o->op_private |= OPpOPEN_IN_RAW;
6055 else if (mode & O_TEXT)
6056 o->op_private |= OPpOPEN_IN_CRLF;
6059 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6061 mode = mode_from_discipline(*svp);
6062 if (mode & O_BINARY)
6063 o->op_private |= OPpOPEN_OUT_RAW;
6064 else if (mode & O_TEXT)
6065 o->op_private |= OPpOPEN_OUT_CRLF;
6068 if (o->op_type == OP_BACKTICK)
6074 Perl_ck_repeat(pTHX_ OP *o)
6076 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6077 o->op_private |= OPpREPEAT_DOLIST;
6078 cBINOPo->op_first = force_list(cBINOPo->op_first);
6086 Perl_ck_require(pTHX_ OP *o)
6088 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6089 SVOP *kid = (SVOP*)cUNOPo->op_first;
6091 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6093 for (s = SvPVX(kid->op_sv); *s; s++) {
6094 if (*s == ':' && s[1] == ':') {
6096 Move(s+2, s+1, strlen(s+2)+1, char);
6097 --SvCUR(kid->op_sv);
6100 if (SvREADONLY(kid->op_sv)) {
6101 SvREADONLY_off(kid->op_sv);
6102 sv_catpvn(kid->op_sv, ".pm", 3);
6103 SvREADONLY_on(kid->op_sv);
6106 sv_catpvn(kid->op_sv, ".pm", 3);
6113 Perl_ck_return(pTHX_ OP *o)
6116 if (CvLVALUE(PL_compcv)) {
6117 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6118 mod(kid, OP_LEAVESUBLV);
6125 Perl_ck_retarget(pTHX_ OP *o)
6127 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6134 Perl_ck_select(pTHX_ OP *o)
6137 if (o->op_flags & OPf_KIDS) {
6138 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6139 if (kid && kid->op_sibling) {
6140 o->op_type = OP_SSELECT;
6141 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6143 return fold_constants(o);
6147 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6148 if (kid && kid->op_type == OP_RV2GV)
6149 kid->op_private &= ~HINT_STRICT_REFS;
6154 Perl_ck_shift(pTHX_ OP *o)
6156 I32 type = o->op_type;
6158 if (!(o->op_flags & OPf_KIDS)) {
6163 if (!CvUNIQUE(PL_compcv)) {
6164 argop = newOP(OP_PADAV, OPf_REF);
6165 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6168 argop = newUNOP(OP_RV2AV, 0,
6169 scalar(newGVOP(OP_GV, 0,
6170 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6173 argop = newUNOP(OP_RV2AV, 0,
6174 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6175 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6176 #endif /* USE_THREADS */
6177 return newUNOP(type, 0, scalar(argop));
6179 return scalar(modkids(ck_fun(o), type));
6183 Perl_ck_sort(pTHX_ OP *o)
6188 if (PL_hints & HINT_LOCALE)
6189 o->op_private |= OPpLOCALE;
6192 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6194 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6195 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6197 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6199 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6201 if (kid->op_type == OP_SCOPE) {
6205 else if (kid->op_type == OP_LEAVE) {
6206 if (o->op_type == OP_SORT) {
6207 null(kid); /* wipe out leave */
6210 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6211 if (k->op_next == kid)
6213 /* don't descend into loops */
6214 else if (k->op_type == OP_ENTERLOOP
6215 || k->op_type == OP_ENTERITER)
6217 k = cLOOPx(k)->op_lastop;
6222 kid->op_next = 0; /* just disconnect the leave */
6223 k = kLISTOP->op_first;
6228 if (o->op_type == OP_SORT) {
6229 /* provide scalar context for comparison function/block */
6235 o->op_flags |= OPf_SPECIAL;
6237 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6240 firstkid = firstkid->op_sibling;
6243 /* provide list context for arguments */
6244 if (o->op_type == OP_SORT)
6251 S_simplify_sort(pTHX_ OP *o)
6253 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6257 if (!(o->op_flags & OPf_STACKED))
6259 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6260 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6261 kid = kUNOP->op_first; /* get past null */
6262 if (kid->op_type != OP_SCOPE)
6264 kid = kLISTOP->op_last; /* get past scope */
6265 switch(kid->op_type) {
6273 k = kid; /* remember this node*/
6274 if (kBINOP->op_first->op_type != OP_RV2SV)
6276 kid = kBINOP->op_first; /* get past cmp */
6277 if (kUNOP->op_first->op_type != OP_GV)
6279 kid = kUNOP->op_first; /* get past rv2sv */
6281 if (GvSTASH(gv) != PL_curstash)
6283 if (strEQ(GvNAME(gv), "a"))
6285 else if (strEQ(GvNAME(gv), "b"))
6289 kid = k; /* back to cmp */
6290 if (kBINOP->op_last->op_type != OP_RV2SV)
6292 kid = kBINOP->op_last; /* down to 2nd arg */
6293 if (kUNOP->op_first->op_type != OP_GV)
6295 kid = kUNOP->op_first; /* get past rv2sv */
6297 if (GvSTASH(gv) != PL_curstash
6299 ? strNE(GvNAME(gv), "a")
6300 : strNE(GvNAME(gv), "b")))
6302 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6304 o->op_private |= OPpSORT_REVERSE;
6305 if (k->op_type == OP_NCMP)
6306 o->op_private |= OPpSORT_NUMERIC;
6307 if (k->op_type == OP_I_NCMP)
6308 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6309 kid = cLISTOPo->op_first->op_sibling;
6310 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6311 op_free(kid); /* then delete it */
6312 cLISTOPo->op_children--;
6316 Perl_ck_split(pTHX_ OP *o)
6320 if (o->op_flags & OPf_STACKED)
6321 return no_fh_allowed(o);
6323 kid = cLISTOPo->op_first;
6324 if (kid->op_type != OP_NULL)
6325 Perl_croak(aTHX_ "panic: ck_split");
6326 kid = kid->op_sibling;
6327 op_free(cLISTOPo->op_first);
6328 cLISTOPo->op_first = kid;
6330 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6331 cLISTOPo->op_last = kid; /* There was only one element previously */
6334 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6335 OP *sibl = kid->op_sibling;
6336 kid->op_sibling = 0;
6337 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6338 if (cLISTOPo->op_first == cLISTOPo->op_last)
6339 cLISTOPo->op_last = kid;
6340 cLISTOPo->op_first = kid;
6341 kid->op_sibling = sibl;
6344 kid->op_type = OP_PUSHRE;
6345 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6348 if (!kid->op_sibling)
6349 append_elem(OP_SPLIT, o, newDEFSVOP());
6351 kid = kid->op_sibling;
6354 if (!kid->op_sibling)
6355 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6357 kid = kid->op_sibling;
6360 if (kid->op_sibling)
6361 return too_many_arguments(o,PL_op_desc[o->op_type]);
6367 Perl_ck_join(pTHX_ OP *o)
6369 if (ckWARN(WARN_SYNTAX)) {
6370 OP *kid = cLISTOPo->op_first->op_sibling;
6371 if (kid && kid->op_type == OP_MATCH) {
6372 char *pmstr = "STRING";
6373 if (kPMOP->op_pmregexp)
6374 pmstr = kPMOP->op_pmregexp->precomp;
6375 Perl_warner(aTHX_ WARN_SYNTAX,
6376 "/%s/ should probably be written as \"%s\"",
6384 Perl_ck_subr(pTHX_ OP *o)
6386 OP *prev = ((cUNOPo->op_first->op_sibling)
6387 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6388 OP *o2 = prev->op_sibling;
6397 o->op_private |= OPpENTERSUB_HASTARG;
6398 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6399 if (cvop->op_type == OP_RV2CV) {
6401 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6402 null(cvop); /* disable rv2cv */
6403 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6404 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6405 GV *gv = cGVOPx_gv(tmpop);
6408 tmpop->op_private |= OPpEARLY_CV;
6409 else if (SvPOK(cv)) {
6410 namegv = CvANON(cv) ? gv : CvGV(cv);
6411 proto = SvPV((SV*)cv, n_a);
6415 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6416 if (o2->op_type == OP_CONST)
6417 o2->op_private &= ~OPpCONST_STRICT;
6418 else if (o2->op_type == OP_LIST) {
6419 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6420 if (o && o->op_type == OP_CONST)
6421 o->op_private &= ~OPpCONST_STRICT;
6424 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6425 if (PERLDB_SUB && PL_curstash != PL_debstash)
6426 o->op_private |= OPpENTERSUB_DB;
6427 while (o2 != cvop) {
6431 return too_many_arguments(o, gv_ename(namegv));
6449 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6451 arg == 1 ? "block or sub {}" : "sub {}",
6452 gv_ename(namegv), o2);
6455 /* '*' allows any scalar type, including bareword */
6458 if (o2->op_type == OP_RV2GV)
6459 goto wrapref; /* autoconvert GLOB -> GLOBref */
6460 else if (o2->op_type == OP_CONST)
6461 o2->op_private &= ~OPpCONST_STRICT;
6462 else if (o2->op_type == OP_ENTERSUB) {
6463 /* accidental subroutine, revert to bareword */
6464 OP *gvop = ((UNOP*)o2)->op_first;
6465 if (gvop && gvop->op_type == OP_NULL) {
6466 gvop = ((UNOP*)gvop)->op_first;
6468 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6471 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6472 (gvop = ((UNOP*)gvop)->op_first) &&
6473 gvop->op_type == OP_GV)
6475 GV *gv = cGVOPx_gv(gvop);
6476 OP *sibling = o2->op_sibling;
6477 SV *n = newSVpvn("",0);
6479 gv_fullname3(n, gv, "");
6480 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6481 sv_chop(n, SvPVX(n)+6);
6482 o2 = newSVOP(OP_CONST, 0, n);
6483 prev->op_sibling = o2;
6484 o2->op_sibling = sibling;
6496 if (o2->op_type != OP_RV2GV)
6497 bad_type(arg, "symbol", gv_ename(namegv), o2);
6500 if (o2->op_type != OP_ENTERSUB)
6501 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6504 if (o2->op_type != OP_RV2SV
6505 && o2->op_type != OP_PADSV
6506 && o2->op_type != OP_HELEM
6507 && o2->op_type != OP_AELEM
6508 && o2->op_type != OP_THREADSV)
6510 bad_type(arg, "scalar", gv_ename(namegv), o2);
6514 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6515 bad_type(arg, "array", gv_ename(namegv), o2);
6518 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6519 bad_type(arg, "hash", gv_ename(namegv), o2);
6523 OP* sib = kid->op_sibling;
6524 kid->op_sibling = 0;
6525 o2 = newUNOP(OP_REFGEN, 0, kid);
6526 o2->op_sibling = sib;
6527 prev->op_sibling = o2;
6538 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6539 gv_ename(namegv), SvPV((SV*)cv, n_a));
6544 mod(o2, OP_ENTERSUB);
6546 o2 = o2->op_sibling;
6548 if (proto && !optional &&
6549 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6550 return too_few_arguments(o, gv_ename(namegv));
6555 Perl_ck_svconst(pTHX_ OP *o)
6557 SvREADONLY_on(cSVOPo->op_sv);
6562 Perl_ck_trunc(pTHX_ OP *o)
6564 if (o->op_flags & OPf_KIDS) {
6565 SVOP *kid = (SVOP*)cUNOPo->op_first;
6567 if (kid->op_type == OP_NULL)
6568 kid = (SVOP*)kid->op_sibling;
6569 if (kid && kid->op_type == OP_CONST &&
6570 (kid->op_private & OPpCONST_BARE))
6572 o->op_flags |= OPf_SPECIAL;
6573 kid->op_private &= ~OPpCONST_STRICT;
6580 Perl_ck_substr(pTHX_ OP *o)
6583 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6584 OP *kid = cLISTOPo->op_first;
6586 if (kid->op_type == OP_NULL)
6587 kid = kid->op_sibling;
6589 kid->op_flags |= OPf_MOD;
6595 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6598 Perl_peep(pTHX_ register OP *o)
6600 register OP* oldop = 0;
6603 if (!o || o->op_seq)
6607 SAVEVPTR(PL_curcop);
6608 for (; o; o = o->op_next) {
6614 switch (o->op_type) {
6618 PL_curcop = ((COP*)o); /* for warnings */
6619 o->op_seq = PL_op_seqmax++;
6623 if (cSVOPo->op_private & OPpCONST_STRICT)
6624 no_bareword_allowed(o);
6626 /* Relocate sv to the pad for thread safety.
6627 * Despite being a "constant", the SV is written to,
6628 * for reference counts, sv_upgrade() etc. */
6630 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6631 if (SvPADTMP(cSVOPo->op_sv)) {
6632 /* If op_sv is already a PADTMP then it is being used by
6633 * some pad, so make a copy. */
6634 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6635 SvREADONLY_on(PL_curpad[ix]);
6636 SvREFCNT_dec(cSVOPo->op_sv);
6639 SvREFCNT_dec(PL_curpad[ix]);
6640 SvPADTMP_on(cSVOPo->op_sv);
6641 PL_curpad[ix] = cSVOPo->op_sv;
6642 /* XXX I don't know how this isn't readonly already. */
6643 SvREADONLY_on(PL_curpad[ix]);
6645 cSVOPo->op_sv = Nullsv;
6649 o->op_seq = PL_op_seqmax++;
6653 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6654 if (o->op_next->op_private & OPpTARGET_MY) {
6655 if (o->op_flags & OPf_STACKED) /* chained concats */
6656 goto ignore_optimization;
6658 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6659 o->op_targ = o->op_next->op_targ;
6660 o->op_next->op_targ = 0;
6661 o->op_private |= OPpTARGET_MY;
6666 ignore_optimization:
6667 o->op_seq = PL_op_seqmax++;
6670 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6671 o->op_seq = PL_op_seqmax++;
6672 break; /* Scalar stub must produce undef. List stub is noop */
6676 if (o->op_targ == OP_NEXTSTATE
6677 || o->op_targ == OP_DBSTATE
6678 || o->op_targ == OP_SETSTATE)
6680 PL_curcop = ((COP*)o);
6687 if (oldop && o->op_next) {
6688 oldop->op_next = o->op_next;
6691 o->op_seq = PL_op_seqmax++;
6695 if (o->op_next->op_type == OP_RV2SV) {
6696 if (!(o->op_next->op_private & OPpDEREF)) {
6698 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6700 o->op_next = o->op_next->op_next;
6701 o->op_type = OP_GVSV;
6702 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6705 else if (o->op_next->op_type == OP_RV2AV) {
6706 OP* pop = o->op_next->op_next;
6708 if (pop->op_type == OP_CONST &&
6709 (PL_op = pop->op_next) &&
6710 pop->op_next->op_type == OP_AELEM &&
6711 !(pop->op_next->op_private &
6712 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6713 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6721 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6722 o->op_next = pop->op_next->op_next;
6723 o->op_type = OP_AELEMFAST;
6724 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6725 o->op_private = (U8)i;
6730 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6732 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6733 /* XXX could check prototype here instead of just carping */
6734 SV *sv = sv_newmortal();
6735 gv_efullname3(sv, gv, Nullch);
6736 Perl_warner(aTHX_ WARN_PROTOTYPE,
6737 "%s() called too early to check prototype",
6742 o->op_seq = PL_op_seqmax++;
6753 o->op_seq = PL_op_seqmax++;
6754 while (cLOGOP->op_other->op_type == OP_NULL)
6755 cLOGOP->op_other = cLOGOP->op_other->op_next;
6756 peep(cLOGOP->op_other);
6760 o->op_seq = PL_op_seqmax++;
6761 while (cLOOP->op_redoop->op_type == OP_NULL)
6762 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6763 peep(cLOOP->op_redoop);
6764 while (cLOOP->op_nextop->op_type == OP_NULL)
6765 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6766 peep(cLOOP->op_nextop);
6767 while (cLOOP->op_lastop->op_type == OP_NULL)
6768 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6769 peep(cLOOP->op_lastop);
6775 o->op_seq = PL_op_seqmax++;
6776 while (cPMOP->op_pmreplstart &&
6777 cPMOP->op_pmreplstart->op_type == OP_NULL)
6778 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6779 peep(cPMOP->op_pmreplstart);
6783 o->op_seq = PL_op_seqmax++;
6784 if (ckWARN(WARN_SYNTAX) && o->op_next
6785 && o->op_next->op_type == OP_NEXTSTATE) {
6786 if (o->op_next->op_sibling &&
6787 o->op_next->op_sibling->op_type != OP_EXIT &&
6788 o->op_next->op_sibling->op_type != OP_WARN &&
6789 o->op_next->op_sibling->op_type != OP_DIE) {
6790 line_t oldline = CopLINE(PL_curcop);
6792 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6793 Perl_warner(aTHX_ WARN_EXEC,
6794 "Statement unlikely to be reached");
6795 Perl_warner(aTHX_ WARN_EXEC,
6796 "\t(Maybe you meant system() when you said exec()?)\n");
6797 CopLINE_set(PL_curcop, oldline);
6806 SV **svp, **indsvp, *sv;
6811 o->op_seq = PL_op_seqmax++;
6813 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6816 /* Make the CONST have a shared SV */
6817 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6818 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6819 key = SvPV(sv, keylen);
6822 lexname = newSVpvn_share(key, keylen, 0);
6827 if ((o->op_private & (OPpLVAL_INTRO)))
6830 rop = (UNOP*)((BINOP*)o)->op_first;
6831 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6833 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6834 if (!SvOBJECT(lexname))
6836 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6837 if (!fields || !GvHV(*fields))
6839 key = SvPV(*svp, keylen);
6842 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6844 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6845 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6847 ind = SvIV(*indsvp);
6849 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6850 rop->op_type = OP_RV2AV;
6851 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6852 o->op_type = OP_AELEM;
6853 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6855 if (SvREADONLY(*svp))
6857 SvFLAGS(sv) |= (SvFLAGS(*svp)
6858 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6868 SV **svp, **indsvp, *sv;
6872 SVOP *first_key_op, *key_op;
6874 o->op_seq = PL_op_seqmax++;
6875 if ((o->op_private & (OPpLVAL_INTRO))
6876 /* I bet there's always a pushmark... */
6877 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6878 /* hmmm, no optimization if list contains only one key. */
6880 rop = (UNOP*)((LISTOP*)o)->op_last;
6881 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6883 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6884 if (!SvOBJECT(lexname))
6886 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6887 if (!fields || !GvHV(*fields))
6889 /* Again guessing that the pushmark can be jumped over.... */
6890 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6891 ->op_first->op_sibling;
6892 /* Check that the key list contains only constants. */
6893 for (key_op = first_key_op; key_op;
6894 key_op = (SVOP*)key_op->op_sibling)
6895 if (key_op->op_type != OP_CONST)
6899 rop->op_type = OP_RV2AV;
6900 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6901 o->op_type = OP_ASLICE;
6902 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6903 for (key_op = first_key_op; key_op;
6904 key_op = (SVOP*)key_op->op_sibling) {
6905 svp = cSVOPx_svp(key_op);
6906 key = SvPV(*svp, keylen);
6909 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6911 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6912 "in variable %s of type %s",
6913 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6915 ind = SvIV(*indsvp);
6917 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6919 if (SvREADONLY(*svp))
6921 SvFLAGS(sv) |= (SvFLAGS(*svp)
6922 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6930 o->op_seq = PL_op_seqmax++;
6940 /* Efficient sub that returns a constant scalar value. */
6942 const_sv_xsub(pTHXo_ CV* cv)
6946 ST(0) = (SV*)XSANY.any_ptr;