3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 /* #define PL_OP_SLAB_ALLOC */
25 #ifdef PL_OP_SLAB_ALLOC
26 #define SLAB_SIZE 8192
27 static char *PL_OpPtr = NULL;
28 static int PL_OpSpace = 0;
29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
30 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
32 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
36 S_Slab_Alloc(pTHX_ int m, size_t sz)
38 Newz(m,PL_OpPtr,SLAB_SIZE,char);
39 PL_OpSpace = SLAB_SIZE - sz;
40 return PL_OpPtr += PL_OpSpace;
44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
47 * In the following definition, the ", Nullop" is just to make the compiler
48 * think the expression is of the right type: croak actually does a Siglongjmp.
50 #define CHECKOP(type,o) \
51 ((PL_op_mask && PL_op_mask[type]) \
52 ? ( op_free((OP*)o), \
53 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
55 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
57 #define PAD_MAX 999999999
58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
61 S_gv_ename(pTHX_ GV *gv)
64 SV* tmpsv = sv_newmortal();
65 gv_efullname3(tmpsv, gv, Nullch);
66 return SvPV(tmpsv,n_a);
70 S_no_fh_allowed(pTHX_ OP *o)
72 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
73 PL_op_desc[o->op_type]));
78 S_too_few_arguments(pTHX_ OP *o, char *name)
80 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
85 S_too_many_arguments(pTHX_ OP *o, char *name)
87 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
94 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
95 (int)n, name, t, PL_op_desc[kid->op_type]));
99 S_no_bareword_allowed(pTHX_ OP *o)
101 qerror(Perl_mess(aTHX_
102 "Bareword \"%s\" not allowed while \"strict subs\" in use",
103 SvPV_nolen(cSVOPo_sv)));
107 S_trlist_upgrade(pTHX_ U8** sp, U8** ep)
113 Newz(801, d, (e - s) * 2, U8);
117 if (*s < 0x80 || *s == 0xff)
121 *d++ = ((c >> 6) | 0xc0);
122 *d++ = ((c & 0x3f) | 0x80);
130 /* "register" allocation */
133 Perl_pad_allocmy(pTHX_ char *name)
138 if (!(PL_in_my == KEY_our ||
140 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
141 (name[1] == '_' && (int)strlen(name) > 2)))
143 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
144 /* 1999-02-27 mjd@plover.com */
146 p = strchr(name, '\0');
147 /* The next block assumes the buffer is at least 205 chars
148 long. At present, it's always at least 256 chars. */
150 strcpy(name+200, "...");
156 /* Move everything else down one character */
157 for (; p-name > 2; p--)
159 name[2] = toCTRL(name[1]);
162 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
164 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
165 SV **svp = AvARRAY(PL_comppad_name);
166 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
167 PADOFFSET top = AvFILLp(PL_comppad_name);
168 for (off = top; off > PL_comppad_name_floor; off--) {
170 && sv != &PL_sv_undef
171 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
172 && (PL_in_my != KEY_our
173 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
174 && strEQ(name, SvPVX(sv)))
176 Perl_warner(aTHX_ WARN_MISC,
177 "\"%s\" variable %s masks earlier declaration in same %s",
178 (PL_in_my == KEY_our ? "our" : "my"),
180 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
185 if (PL_in_my == KEY_our) {
188 && sv != &PL_sv_undef
189 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
190 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
191 && strEQ(name, SvPVX(sv)))
193 Perl_warner(aTHX_ WARN_MISC,
194 "\"our\" variable %s redeclared", name);
195 Perl_warner(aTHX_ WARN_MISC,
196 "\t(Did you mean \"local\" instead of \"our\"?)\n");
199 } while ( off-- > 0 );
202 off = pad_alloc(OP_PADSV, SVs_PADMY);
204 sv_upgrade(sv, SVt_PVNV);
206 if (PL_in_my_stash) {
208 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
209 name, PL_in_my == KEY_our ? "our" : "my"));
211 (void)SvUPGRADE(sv, SVt_PVMG);
212 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
215 if (PL_in_my == KEY_our) {
216 (void)SvUPGRADE(sv, SVt_PVGV);
217 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
218 SvFLAGS(sv) |= SVpad_OUR;
220 av_store(PL_comppad_name, off, sv);
221 SvNVX(sv) = (NV)PAD_MAX;
222 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
223 if (!PL_min_intro_pending)
224 PL_min_intro_pending = off;
225 PL_max_intro_pending = off;
227 av_store(PL_comppad, off, (SV*)newAV());
228 else if (*name == '%')
229 av_store(PL_comppad, off, (SV*)newHV());
230 SvPADMY_on(PL_curpad[off]);
235 S_pad_addlex(pTHX_ SV *proto_namesv)
237 SV *namesv = NEWSV(1103,0);
238 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
239 sv_upgrade(namesv, SVt_PVNV);
240 sv_setpv(namesv, SvPVX(proto_namesv));
241 av_store(PL_comppad_name, newoff, namesv);
242 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
243 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
244 SvFAKE_on(namesv); /* A ref, not a real var */
245 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
246 SvFLAGS(namesv) |= SVpad_OUR;
247 (void)SvUPGRADE(namesv, SVt_PVGV);
248 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
250 if (SvOBJECT(proto_namesv)) { /* A typed var */
252 (void)SvUPGRADE(namesv, SVt_PVMG);
253 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
259 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
262 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
263 I32 cx_ix, I32 saweval, U32 flags)
269 register PERL_CONTEXT *cx;
271 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
272 AV *curlist = CvPADLIST(cv);
273 SV **svp = av_fetch(curlist, 0, FALSE);
276 if (!svp || *svp == &PL_sv_undef)
279 svp = AvARRAY(curname);
280 for (off = AvFILLp(curname); off > 0; off--) {
281 if ((sv = svp[off]) &&
282 sv != &PL_sv_undef &&
284 seq > I_32(SvNVX(sv)) &&
285 strEQ(SvPVX(sv), name))
296 return 0; /* don't clone from inactive stack frame */
300 oldpad = (AV*)AvARRAY(curlist)[depth];
301 oldsv = *av_fetch(oldpad, off, TRUE);
302 if (!newoff) { /* Not a mere clone operation. */
303 newoff = pad_addlex(sv);
304 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
305 /* "It's closures all the way down." */
306 CvCLONE_on(PL_compcv);
308 if (CvANON(PL_compcv))
309 oldsv = Nullsv; /* no need to keep ref */
314 bcv && bcv != cv && !CvCLONE(bcv);
315 bcv = CvOUTSIDE(bcv))
318 /* install the missing pad entry in intervening
319 * nested subs and mark them cloneable.
320 * XXX fix pad_foo() to not use globals */
321 AV *ocomppad_name = PL_comppad_name;
322 AV *ocomppad = PL_comppad;
323 SV **ocurpad = PL_curpad;
324 AV *padlist = CvPADLIST(bcv);
325 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
326 PL_comppad = (AV*)AvARRAY(padlist)[1];
327 PL_curpad = AvARRAY(PL_comppad);
329 PL_comppad_name = ocomppad_name;
330 PL_comppad = ocomppad;
335 if (ckWARN(WARN_CLOSURE)
336 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
338 Perl_warner(aTHX_ WARN_CLOSURE,
339 "Variable \"%s\" may be unavailable",
347 else if (!CvUNIQUE(PL_compcv)) {
348 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
349 && !(SvFLAGS(sv) & SVpad_OUR))
351 Perl_warner(aTHX_ WARN_CLOSURE,
352 "Variable \"%s\" will not stay shared", name);
356 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
362 if (flags & FINDLEX_NOSEARCH)
365 /* Nothing in current lexical context--try eval's context, if any.
366 * This is necessary to let the perldb get at lexically scoped variables.
367 * XXX This will also probably interact badly with eval tree caching.
370 for (i = cx_ix; i >= 0; i--) {
372 switch (CxTYPE(cx)) {
374 if (i == 0 && saweval) {
375 seq = cxstack[saweval].blk_oldcop->cop_seq;
376 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
380 switch (cx->blk_eval.old_op_type) {
387 /* require/do must have their own scope */
396 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
397 saweval = i; /* so we know where we were called from */
400 seq = cxstack[saweval].blk_oldcop->cop_seq;
401 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
409 Perl_pad_findmy(pTHX_ char *name)
414 SV **svp = AvARRAY(PL_comppad_name);
415 U32 seq = PL_cop_seqmax;
421 * Special case to get lexical (and hence per-thread) @_.
422 * XXX I need to find out how to tell at parse-time whether use
423 * of @_ should refer to a lexical (from a sub) or defgv (global
424 * scope and maybe weird sub-ish things like formats). See
425 * startsub in perly.y. It's possible that @_ could be lexical
426 * (at least from subs) even in non-threaded perl.
428 if (strEQ(name, "@_"))
429 return 0; /* success. (NOT_IN_PAD indicates failure) */
430 #endif /* USE_THREADS */
432 /* The one we're looking for is probably just before comppad_name_fill. */
433 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
434 if ((sv = svp[off]) &&
435 sv != &PL_sv_undef &&
438 seq > I_32(SvNVX(sv)))) &&
439 strEQ(SvPVX(sv), name))
441 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
442 return (PADOFFSET)off;
443 pendoff = off; /* this pending def. will override import */
447 outside = CvOUTSIDE(PL_compcv);
449 /* Check if if we're compiling an eval'', and adjust seq to be the
450 * eval's seq number. This depends on eval'' having a non-null
451 * CvOUTSIDE() while it is being compiled. The eval'' itself is
452 * identified by CvEVAL being true and CvGV being null. */
453 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
454 cx = &cxstack[cxstack_ix];
456 seq = cx->blk_oldcop->cop_seq;
459 /* See if it's in a nested scope */
460 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
462 /* If there is a pending local definition, this new alias must die */
464 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
465 return off; /* pad_findlex returns 0 for failure...*/
467 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
471 Perl_pad_leavemy(pTHX_ I32 fill)
474 SV **svp = AvARRAY(PL_comppad_name);
476 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
477 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
478 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
479 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
482 /* "Deintroduce" my variables that are leaving with this scope. */
483 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
484 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
485 SvIVX(sv) = PL_cop_seqmax;
490 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
495 if (AvARRAY(PL_comppad) != PL_curpad)
496 Perl_croak(aTHX_ "panic: pad_alloc");
497 if (PL_pad_reset_pending)
499 if (tmptype & SVs_PADMY) {
501 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
502 } while (SvPADBUSY(sv)); /* need a fresh one */
503 retval = AvFILLp(PL_comppad);
506 SV **names = AvARRAY(PL_comppad_name);
507 SSize_t names_fill = AvFILLp(PL_comppad_name);
510 * "foreach" index vars temporarily become aliases to non-"my"
511 * values. Thus we must skip, not just pad values that are
512 * marked as current pad values, but also those with names.
514 if (++PL_padix <= names_fill &&
515 (sv = names[PL_padix]) && sv != &PL_sv_undef)
517 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
518 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
519 !IS_PADGV(sv) && !IS_PADCONST(sv))
524 SvFLAGS(sv) |= tmptype;
525 PL_curpad = AvARRAY(PL_comppad);
527 DEBUG_X(PerlIO_printf(Perl_debug_log,
528 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
529 PTR2UV(thr), PTR2UV(PL_curpad),
530 (long) retval, PL_op_name[optype]));
532 DEBUG_X(PerlIO_printf(Perl_debug_log,
533 "Pad 0x%"UVxf" alloc %ld for %s\n",
535 (long) retval, PL_op_name[optype]));
536 #endif /* USE_THREADS */
537 return (PADOFFSET)retval;
541 Perl_pad_sv(pTHX_ PADOFFSET po)
544 DEBUG_X(PerlIO_printf(Perl_debug_log,
545 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
546 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
549 Perl_croak(aTHX_ "panic: pad_sv po");
550 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
551 PTR2UV(PL_curpad), (IV)po));
552 #endif /* USE_THREADS */
553 return PL_curpad[po]; /* eventually we'll turn this into a macro */
557 Perl_pad_free(pTHX_ PADOFFSET po)
561 if (AvARRAY(PL_comppad) != PL_curpad)
562 Perl_croak(aTHX_ "panic: pad_free curpad");
564 Perl_croak(aTHX_ "panic: pad_free po");
566 DEBUG_X(PerlIO_printf(Perl_debug_log,
567 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
568 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
570 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
571 PTR2UV(PL_curpad), (IV)po));
572 #endif /* USE_THREADS */
573 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
574 SvPADTMP_off(PL_curpad[po]);
576 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
579 if ((I32)po < PL_padix)
584 Perl_pad_swipe(pTHX_ PADOFFSET po)
586 if (AvARRAY(PL_comppad) != PL_curpad)
587 Perl_croak(aTHX_ "panic: pad_swipe curpad");
589 Perl_croak(aTHX_ "panic: pad_swipe po");
591 DEBUG_X(PerlIO_printf(Perl_debug_log,
592 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
593 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
595 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
596 PTR2UV(PL_curpad), (IV)po));
597 #endif /* USE_THREADS */
598 SvPADTMP_off(PL_curpad[po]);
599 PL_curpad[po] = NEWSV(1107,0);
600 SvPADTMP_on(PL_curpad[po]);
601 if ((I32)po < PL_padix)
605 /* XXX pad_reset() is currently disabled because it results in serious bugs.
606 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
607 * on the stack by OPs that use them, there are several ways to get an alias
608 * to a shared TARG. Such an alias will change randomly and unpredictably.
609 * We avoid doing this until we can think of a Better Way.
614 #ifdef USE_BROKEN_PAD_RESET
617 if (AvARRAY(PL_comppad) != PL_curpad)
618 Perl_croak(aTHX_ "panic: pad_reset curpad");
620 DEBUG_X(PerlIO_printf(Perl_debug_log,
621 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
622 PTR2UV(thr), PTR2UV(PL_curpad)));
624 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
626 #endif /* USE_THREADS */
627 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
628 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
629 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
630 SvPADTMP_off(PL_curpad[po]);
632 PL_padix = PL_padix_floor;
635 PL_pad_reset_pending = FALSE;
639 /* find_threadsv is not reentrant */
641 Perl_find_threadsv(pTHX_ const char *name)
646 /* We currently only handle names of a single character */
647 p = strchr(PL_threadsv_names, *name);
650 key = p - PL_threadsv_names;
651 MUTEX_LOCK(&thr->mutex);
652 svp = av_fetch(thr->threadsv, key, FALSE);
654 MUTEX_UNLOCK(&thr->mutex);
656 SV *sv = NEWSV(0, 0);
657 av_store(thr->threadsv, key, sv);
658 thr->threadsvp = AvARRAY(thr->threadsv);
659 MUTEX_UNLOCK(&thr->mutex);
661 * Some magic variables used to be automagically initialised
662 * in gv_fetchpv. Those which are now per-thread magicals get
663 * initialised here instead.
669 sv_setpv(sv, "\034");
670 sv_magic(sv, 0, 0, name, 1);
675 PL_sawampersand = TRUE;
689 /* XXX %! tied to Errno.pm needs to be added here.
690 * See gv_fetchpv(). */
694 sv_magic(sv, 0, 0, name, 1);
696 DEBUG_S(PerlIO_printf(Perl_error_log,
697 "find_threadsv: new SV %p for $%s%c\n",
698 sv, (*name < 32) ? "^" : "",
699 (*name < 32) ? toCTRL(*name) : *name));
703 #endif /* USE_THREADS */
708 Perl_op_free(pTHX_ OP *o)
710 register OP *kid, *nextkid;
713 if (!o || o->op_seq == (U16)-1)
716 if (o->op_private & OPpREFCOUNTED) {
717 switch (o->op_type) {
725 if (OpREFCNT_dec(o)) {
736 if (o->op_flags & OPf_KIDS) {
737 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
738 nextkid = kid->op_sibling; /* Get before next freeing kid */
746 /* COP* is not cleared by op_clear() so that we may track line
747 * numbers etc even after null() */
748 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
753 #ifdef PL_OP_SLAB_ALLOC
754 if ((char *) o == PL_OpPtr)
763 S_op_clear(pTHX_ OP *o)
765 switch (o->op_type) {
766 case OP_NULL: /* Was holding old type, if any. */
767 case OP_ENTEREVAL: /* Was holding hints. */
769 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
775 if (!(o->op_flags & OPf_SPECIAL))
778 #endif /* USE_THREADS */
780 if (!(o->op_flags & OPf_REF)
781 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
788 if (cPADOPo->op_padix > 0) {
791 pad_swipe(cPADOPo->op_padix);
792 /* No GvIN_PAD_off(gv) here, because other references may still
793 * exist on the pad */
796 cPADOPo->op_padix = 0;
799 SvREFCNT_dec(cSVOPo->op_sv);
800 cSVOPo->op_sv = Nullsv;
803 case OP_METHOD_NAMED:
805 SvREFCNT_dec(cSVOPo->op_sv);
806 cSVOPo->op_sv = Nullsv;
812 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
816 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
817 SvREFCNT_dec(cSVOPo->op_sv);
818 cSVOPo->op_sv = Nullsv;
821 Safefree(cPVOPo->op_pv);
822 cPVOPo->op_pv = Nullch;
826 op_free(cPMOPo->op_pmreplroot);
830 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
832 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
833 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
834 /* No GvIN_PAD_off(gv) here, because other references may still
835 * exist on the pad */
840 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
846 cPMOPo->op_pmreplroot = Nullop;
847 ReREFCNT_dec(cPMOPo->op_pmregexp);
848 cPMOPo->op_pmregexp = (REGEXP*)NULL;
852 if (o->op_targ > 0) {
853 pad_free(o->op_targ);
859 S_cop_free(pTHX_ COP* cop)
861 Safefree(cop->cop_label);
863 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
864 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
866 /* NOTE: COP.cop_stash is not refcounted */
867 SvREFCNT_dec(CopFILEGV(cop));
869 if (! specialWARN(cop->cop_warnings))
870 SvREFCNT_dec(cop->cop_warnings);
871 if (! specialCopIO(cop->cop_io))
872 SvREFCNT_dec(cop->cop_io);
878 if (o->op_type == OP_NULL)
881 o->op_targ = o->op_type;
882 o->op_type = OP_NULL;
883 o->op_ppaddr = PL_ppaddr[OP_NULL];
886 /* Contextualizers */
888 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
891 Perl_linklist(pTHX_ OP *o)
898 /* establish postfix order */
899 if (cUNOPo->op_first) {
900 o->op_next = LINKLIST(cUNOPo->op_first);
901 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
903 kid->op_next = LINKLIST(kid->op_sibling);
915 Perl_scalarkids(pTHX_ OP *o)
918 if (o && o->op_flags & OPf_KIDS) {
919 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
926 S_scalarboolean(pTHX_ OP *o)
928 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
929 if (ckWARN(WARN_SYNTAX)) {
930 line_t oldline = CopLINE(PL_curcop);
932 if (PL_copline != NOLINE)
933 CopLINE_set(PL_curcop, PL_copline);
934 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
935 CopLINE_set(PL_curcop, oldline);
942 Perl_scalar(pTHX_ OP *o)
946 /* assumes no premature commitment */
947 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
948 || o->op_type == OP_RETURN)
953 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
955 switch (o->op_type) {
957 if (o->op_private & OPpREPEAT_DOLIST)
958 null(((LISTOP*)cBINOPo->op_first)->op_first);
959 scalar(cBINOPo->op_first);
964 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
968 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
969 if (!kPMOP->op_pmreplroot)
970 deprecate("implicit split to @_");
978 if (o->op_flags & OPf_KIDS) {
979 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
985 kid = cLISTOPo->op_first;
987 while ((kid = kid->op_sibling)) {
993 WITH_THR(PL_curcop = &PL_compiling);
998 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1004 WITH_THR(PL_curcop = &PL_compiling);
1011 Perl_scalarvoid(pTHX_ OP *o)
1018 if (o->op_type == OP_NEXTSTATE
1019 || o->op_type == OP_SETSTATE
1020 || o->op_type == OP_DBSTATE
1021 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1022 || o->op_targ == OP_SETSTATE
1023 || o->op_targ == OP_DBSTATE)))
1024 PL_curcop = (COP*)o; /* for warning below */
1026 /* assumes no premature commitment */
1027 want = o->op_flags & OPf_WANT;
1028 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1029 || o->op_type == OP_RETURN)
1034 if ((o->op_private & OPpTARGET_MY)
1035 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1037 return scalar(o); /* As if inside SASSIGN */
1040 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1042 switch (o->op_type) {
1044 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1048 if (o->op_flags & OPf_STACKED)
1052 if (o->op_private == 4)
1094 case OP_GETSOCKNAME:
1095 case OP_GETPEERNAME:
1100 case OP_GETPRIORITY:
1123 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1124 useless = PL_op_desc[o->op_type];
1131 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1132 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1133 useless = "a variable";
1138 if (cSVOPo->op_private & OPpCONST_STRICT)
1139 no_bareword_allowed(o);
1141 if (ckWARN(WARN_VOID)) {
1142 useless = "a constant";
1143 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1145 else if (SvPOK(sv)) {
1146 /* perl4's way of mixing documentation and code
1147 (before the invention of POD) was based on a
1148 trick to mix nroff and perl code. The trick was
1149 built upon these three nroff macros being used in
1150 void context. The pink camel has the details in
1151 the script wrapman near page 319. */
1152 if (strnEQ(SvPVX(sv), "di", 2) ||
1153 strnEQ(SvPVX(sv), "ds", 2) ||
1154 strnEQ(SvPVX(sv), "ig", 2))
1159 null(o); /* don't execute or even remember it */
1163 o->op_type = OP_PREINC; /* pre-increment is faster */
1164 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1168 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1169 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1175 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1180 if (o->op_flags & OPf_STACKED)
1187 if (!(o->op_flags & OPf_KIDS))
1196 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1203 /* all requires must return a boolean value */
1204 o->op_flags &= ~OPf_WANT;
1209 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1210 if (!kPMOP->op_pmreplroot)
1211 deprecate("implicit split to @_");
1215 if (useless && ckWARN(WARN_VOID))
1216 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1221 Perl_listkids(pTHX_ OP *o)
1224 if (o && o->op_flags & OPf_KIDS) {
1225 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1232 Perl_list(pTHX_ OP *o)
1236 /* assumes no premature commitment */
1237 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1238 || o->op_type == OP_RETURN)
1243 if ((o->op_private & OPpTARGET_MY)
1244 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1246 return o; /* As if inside SASSIGN */
1249 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1251 switch (o->op_type) {
1254 list(cBINOPo->op_first);
1259 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1267 if (!(o->op_flags & OPf_KIDS))
1269 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1270 list(cBINOPo->op_first);
1271 return gen_constant_list(o);
1278 kid = cLISTOPo->op_first;
1280 while ((kid = kid->op_sibling)) {
1281 if (kid->op_sibling)
1286 WITH_THR(PL_curcop = &PL_compiling);
1290 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1291 if (kid->op_sibling)
1296 WITH_THR(PL_curcop = &PL_compiling);
1299 /* all requires must return a boolean value */
1300 o->op_flags &= ~OPf_WANT;
1307 Perl_scalarseq(pTHX_ OP *o)
1312 if (o->op_type == OP_LINESEQ ||
1313 o->op_type == OP_SCOPE ||
1314 o->op_type == OP_LEAVE ||
1315 o->op_type == OP_LEAVETRY)
1317 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1318 if (kid->op_sibling) {
1322 PL_curcop = &PL_compiling;
1324 o->op_flags &= ~OPf_PARENS;
1325 if (PL_hints & HINT_BLOCK_SCOPE)
1326 o->op_flags |= OPf_PARENS;
1329 o = newOP(OP_STUB, 0);
1334 S_modkids(pTHX_ OP *o, I32 type)
1337 if (o && o->op_flags & OPf_KIDS) {
1338 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1345 Perl_mod(pTHX_ OP *o, I32 type)
1350 if (!o || PL_error_count)
1353 if ((o->op_private & OPpTARGET_MY)
1354 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1359 switch (o->op_type) {
1364 if (o->op_private & (OPpCONST_BARE) &&
1365 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1366 SV *sv = ((SVOP*)o)->op_sv;
1369 /* Could be a filehandle */
1370 if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1371 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1375 /* OK, it's a sub */
1377 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1379 enter = newUNOP(OP_ENTERSUB,0,
1380 newUNOP(OP_RV2CV, 0,
1381 newGVOP(OP_GV, 0, gv)
1383 enter->op_private |= OPpLVAL_INTRO;
1389 if (!(o->op_private & (OPpCONST_ARYBASE)))
1391 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1392 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1396 SAVEI32(PL_compiling.cop_arybase);
1397 PL_compiling.cop_arybase = 0;
1399 else if (type == OP_REFGEN)
1402 Perl_croak(aTHX_ "That use of $[ is unsupported");
1405 if (o->op_flags & OPf_PARENS)
1409 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1410 !(o->op_flags & OPf_STACKED)) {
1411 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1412 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1413 assert(cUNOPo->op_first->op_type == OP_NULL);
1414 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1417 else { /* lvalue subroutine call */
1418 o->op_private |= OPpLVAL_INTRO;
1419 PL_modcount = RETURN_UNLIMITED_NUMBER;
1420 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1421 /* Backward compatibility mode: */
1422 o->op_private |= OPpENTERSUB_INARGS;
1425 else { /* Compile-time error message: */
1426 OP *kid = cUNOPo->op_first;
1430 if (kid->op_type == OP_PUSHMARK)
1432 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1434 "panic: unexpected lvalue entersub "
1435 "args: type/targ %ld:%ld",
1436 (long)kid->op_type,kid->op_targ);
1437 kid = kLISTOP->op_first;
1439 while (kid->op_sibling)
1440 kid = kid->op_sibling;
1441 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1443 if (kid->op_type == OP_METHOD_NAMED
1444 || kid->op_type == OP_METHOD)
1448 if (kid->op_sibling || kid->op_next != kid) {
1449 yyerror("panic: unexpected optree near method call");
1453 NewOp(1101, newop, 1, UNOP);
1454 newop->op_type = OP_RV2CV;
1455 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456 newop->op_first = Nullop;
1457 newop->op_next = (OP*)newop;
1458 kid->op_sibling = (OP*)newop;
1459 newop->op_private |= OPpLVAL_INTRO;
1463 if (kid->op_type != OP_RV2CV)
1465 "panic: unexpected lvalue entersub "
1466 "entry via type/targ %ld:%ld",
1467 (long)kid->op_type,kid->op_targ);
1468 kid->op_private |= OPpLVAL_INTRO;
1469 break; /* Postpone until runtime */
1473 kid = kUNOP->op_first;
1474 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1475 kid = kUNOP->op_first;
1476 if (kid->op_type == OP_NULL)
1478 "Unexpected constant lvalue entersub "
1479 "entry via type/targ %ld:%ld",
1480 (long)kid->op_type,kid->op_targ);
1481 if (kid->op_type != OP_GV) {
1482 /* Restore RV2CV to check lvalueness */
1484 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1485 okid->op_next = kid->op_next;
1486 kid->op_next = okid;
1489 okid->op_next = Nullop;
1490 okid->op_type = OP_RV2CV;
1492 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1493 okid->op_private |= OPpLVAL_INTRO;
1497 cv = GvCV(kGVOP_gv);
1507 /* grep, foreach, subcalls, refgen */
1508 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1510 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1511 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1513 : (o->op_type == OP_ENTERSUB
1514 ? "non-lvalue subroutine call"
1515 : PL_op_desc[o->op_type])),
1516 type ? PL_op_desc[type] : "local"));
1530 case OP_RIGHT_SHIFT:
1539 if (!(o->op_flags & OPf_STACKED))
1545 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1551 if (!type && cUNOPo->op_first->op_type != OP_GV)
1552 Perl_croak(aTHX_ "Can't localize through a reference");
1553 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1554 PL_modcount = RETURN_UNLIMITED_NUMBER;
1555 return o; /* Treat \(@foo) like ordinary list. */
1559 if (scalar_mod_type(o, type))
1561 ref(cUNOPo->op_first, o->op_type);
1565 if (type == OP_LEAVESUBLV)
1566 o->op_private |= OPpMAYBE_LVSUB;
1572 PL_modcount = RETURN_UNLIMITED_NUMBER;
1575 if (!type && cUNOPo->op_first->op_type != OP_GV)
1576 Perl_croak(aTHX_ "Can't localize through a reference");
1577 ref(cUNOPo->op_first, o->op_type);
1581 PL_hints |= HINT_BLOCK_SCOPE;
1591 PL_modcount = RETURN_UNLIMITED_NUMBER;
1592 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1593 return o; /* Treat \(@foo) like ordinary list. */
1594 if (scalar_mod_type(o, type))
1596 if (type == OP_LEAVESUBLV)
1597 o->op_private |= OPpMAYBE_LVSUB;
1602 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1603 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1608 PL_modcount++; /* XXX ??? */
1610 #endif /* USE_THREADS */
1616 if (type != OP_SASSIGN)
1620 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1628 pad_free(o->op_targ);
1629 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1630 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1631 if (o->op_flags & OPf_KIDS)
1632 mod(cBINOPo->op_first->op_sibling, type);
1637 ref(cBINOPo->op_first, o->op_type);
1638 if (type == OP_ENTERSUB &&
1639 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1640 o->op_private |= OPpLVAL_DEFER;
1641 if (type == OP_LEAVESUBLV)
1642 o->op_private |= OPpMAYBE_LVSUB;
1650 if (o->op_flags & OPf_KIDS)
1651 mod(cLISTOPo->op_last, type);
1655 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1657 else if (!(o->op_flags & OPf_KIDS))
1659 if (o->op_targ != OP_LIST) {
1660 mod(cBINOPo->op_first, type);
1665 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1670 if (type != OP_LEAVESUBLV)
1672 break; /* mod()ing was handled by ck_return() */
1674 if (type != OP_LEAVESUBLV)
1675 o->op_flags |= OPf_MOD;
1677 if (type == OP_AASSIGN || type == OP_SASSIGN)
1678 o->op_flags |= OPf_SPECIAL|OPf_REF;
1680 o->op_private |= OPpLVAL_INTRO;
1681 o->op_flags &= ~OPf_SPECIAL;
1682 PL_hints |= HINT_BLOCK_SCOPE;
1684 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1685 && type != OP_LEAVESUBLV)
1686 o->op_flags |= OPf_REF;
1691 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1695 if (o->op_type == OP_RV2GV)
1719 case OP_RIGHT_SHIFT:
1738 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1740 switch (o->op_type) {
1748 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1761 Perl_refkids(pTHX_ OP *o, I32 type)
1764 if (o && o->op_flags & OPf_KIDS) {
1765 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1772 Perl_ref(pTHX_ OP *o, I32 type)
1776 if (!o || PL_error_count)
1779 switch (o->op_type) {
1781 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1782 !(o->op_flags & OPf_STACKED)) {
1783 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1784 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1785 assert(cUNOPo->op_first->op_type == OP_NULL);
1786 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1787 o->op_flags |= OPf_SPECIAL;
1792 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1796 if (type == OP_DEFINED)
1797 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1798 ref(cUNOPo->op_first, o->op_type);
1801 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1802 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1803 : type == OP_RV2HV ? OPpDEREF_HV
1805 o->op_flags |= OPf_MOD;
1810 o->op_flags |= OPf_MOD; /* XXX ??? */
1815 o->op_flags |= OPf_REF;
1818 if (type == OP_DEFINED)
1819 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1820 ref(cUNOPo->op_first, o->op_type);
1825 o->op_flags |= OPf_REF;
1830 if (!(o->op_flags & OPf_KIDS))
1832 ref(cBINOPo->op_first, type);
1836 ref(cBINOPo->op_first, o->op_type);
1837 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1838 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1839 : type == OP_RV2HV ? OPpDEREF_HV
1841 o->op_flags |= OPf_MOD;
1849 if (!(o->op_flags & OPf_KIDS))
1851 ref(cLISTOPo->op_last, type);
1861 S_dup_attrlist(pTHX_ OP *o)
1865 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1866 * where the first kid is OP_PUSHMARK and the remaining ones
1867 * are OP_CONST. We need to push the OP_CONST values.
1869 if (o->op_type == OP_CONST)
1870 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1872 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1873 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1874 if (o->op_type == OP_CONST)
1875 rop = append_elem(OP_LIST, rop,
1876 newSVOP(OP_CONST, o->op_flags,
1877 SvREFCNT_inc(cSVOPo->op_sv)));
1884 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1888 /* fake up C<use attributes $pkg,$rv,@attrs> */
1889 ENTER; /* need to protect against side-effects of 'use' */
1891 if (stash && HvNAME(stash))
1892 stashsv = newSVpv(HvNAME(stash), 0);
1894 stashsv = &PL_sv_no;
1896 #define ATTRSMODULE "attributes"
1898 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1899 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1901 prepend_elem(OP_LIST,
1902 newSVOP(OP_CONST, 0, stashsv),
1903 prepend_elem(OP_LIST,
1904 newSVOP(OP_CONST, 0,
1906 dup_attrlist(attrs))));
1911 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1912 char *attrstr, STRLEN len)
1917 len = strlen(attrstr);
1921 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1923 char *sstr = attrstr;
1924 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1925 attrs = append_elem(OP_LIST, attrs,
1926 newSVOP(OP_CONST, 0,
1927 newSVpvn(sstr, attrstr-sstr)));
1931 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1932 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1933 Nullsv, prepend_elem(OP_LIST,
1934 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1935 prepend_elem(OP_LIST,
1936 newSVOP(OP_CONST, 0,
1942 S_my_kid(pTHX_ OP *o, OP *attrs)
1947 if (!o || PL_error_count)
1951 if (type == OP_LIST) {
1952 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1954 } else if (type == OP_UNDEF) {
1956 } else if (type == OP_RV2SV || /* "our" declaration */
1958 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1960 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1962 PL_in_my_stash = Nullhv;
1963 apply_attrs(GvSTASH(gv),
1964 (type == OP_RV2SV ? GvSV(gv) :
1965 type == OP_RV2AV ? (SV*)GvAV(gv) :
1966 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1969 o->op_private |= OPpOUR_INTRO;
1971 } else if (type != OP_PADSV &&
1974 type != OP_PUSHMARK)
1976 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1977 PL_op_desc[o->op_type],
1978 PL_in_my == KEY_our ? "our" : "my"));
1981 else if (attrs && type != OP_PUSHMARK) {
1987 PL_in_my_stash = Nullhv;
1989 /* check for C<my Dog $spot> when deciding package */
1990 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1991 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1992 stash = SvSTASH(*namesvp);
1994 stash = PL_curstash;
1995 padsv = PAD_SV(o->op_targ);
1996 apply_attrs(stash, padsv, attrs);
1998 o->op_flags |= OPf_MOD;
1999 o->op_private |= OPpLVAL_INTRO;
2004 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2006 if (o->op_flags & OPf_PARENS)
2010 o = my_kid(o, attrs);
2012 PL_in_my_stash = Nullhv;
2017 Perl_my(pTHX_ OP *o)
2019 return my_kid(o, Nullop);
2023 Perl_sawparens(pTHX_ OP *o)
2026 o->op_flags |= OPf_PARENS;
2031 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2035 if (ckWARN(WARN_MISC) &&
2036 (left->op_type == OP_RV2AV ||
2037 left->op_type == OP_RV2HV ||
2038 left->op_type == OP_PADAV ||
2039 left->op_type == OP_PADHV)) {
2040 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2041 right->op_type == OP_TRANS)
2042 ? right->op_type : OP_MATCH];
2043 const char *sample = ((left->op_type == OP_RV2AV ||
2044 left->op_type == OP_PADAV)
2045 ? "@array" : "%hash");
2046 Perl_warner(aTHX_ WARN_MISC,
2047 "Applying %s to %s will act on scalar(%s)",
2048 desc, sample, sample);
2051 if (!(right->op_flags & OPf_STACKED) &&
2052 (right->op_type == OP_MATCH ||
2053 right->op_type == OP_SUBST ||
2054 right->op_type == OP_TRANS)) {
2055 right->op_flags |= OPf_STACKED;
2056 if (right->op_type != OP_MATCH &&
2057 ! (right->op_type == OP_TRANS &&
2058 right->op_private & OPpTRANS_IDENTICAL))
2059 left = mod(left, right->op_type);
2060 if (right->op_type == OP_TRANS)
2061 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2063 o = prepend_elem(right->op_type, scalar(left), right);
2065 return newUNOP(OP_NOT, 0, scalar(o));
2069 return bind_match(type, left,
2070 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2074 Perl_invert(pTHX_ OP *o)
2078 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2079 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2083 Perl_scope(pTHX_ OP *o)
2086 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2087 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2088 o->op_type = OP_LEAVE;
2089 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2092 if (o->op_type == OP_LINESEQ) {
2094 o->op_type = OP_SCOPE;
2095 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2096 kid = ((LISTOP*)o)->op_first;
2097 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2101 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2108 Perl_save_hints(pTHX)
2111 SAVESPTR(GvHV(PL_hintgv));
2112 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2113 SAVEFREESV(GvHV(PL_hintgv));
2117 Perl_block_start(pTHX_ int full)
2119 int retval = PL_savestack_ix;
2121 SAVEI32(PL_comppad_name_floor);
2122 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2124 PL_comppad_name_fill = PL_comppad_name_floor;
2125 if (PL_comppad_name_floor < 0)
2126 PL_comppad_name_floor = 0;
2127 SAVEI32(PL_min_intro_pending);
2128 SAVEI32(PL_max_intro_pending);
2129 PL_min_intro_pending = 0;
2130 SAVEI32(PL_comppad_name_fill);
2131 SAVEI32(PL_padix_floor);
2132 PL_padix_floor = PL_padix;
2133 PL_pad_reset_pending = FALSE;
2135 PL_hints &= ~HINT_BLOCK_SCOPE;
2136 SAVESPTR(PL_compiling.cop_warnings);
2137 if (! specialWARN(PL_compiling.cop_warnings)) {
2138 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2139 SAVEFREESV(PL_compiling.cop_warnings) ;
2141 SAVESPTR(PL_compiling.cop_io);
2142 if (! specialCopIO(PL_compiling.cop_io)) {
2143 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2144 SAVEFREESV(PL_compiling.cop_io) ;
2150 Perl_block_end(pTHX_ I32 floor, OP *seq)
2152 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2153 OP* retval = scalarseq(seq);
2155 PL_pad_reset_pending = FALSE;
2156 PL_compiling.op_private = PL_hints;
2158 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2159 pad_leavemy(PL_comppad_name_fill);
2168 OP *o = newOP(OP_THREADSV, 0);
2169 o->op_targ = find_threadsv("_");
2172 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2173 #endif /* USE_THREADS */
2177 Perl_newPROG(pTHX_ OP *o)
2182 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2183 ((PL_in_eval & EVAL_KEEPERR)
2184 ? OPf_SPECIAL : 0), o);
2185 PL_eval_start = linklist(PL_eval_root);
2186 PL_eval_root->op_private |= OPpREFCOUNTED;
2187 OpREFCNT_set(PL_eval_root, 1);
2188 PL_eval_root->op_next = 0;
2189 peep(PL_eval_start);
2194 PL_main_root = scope(sawparens(scalarvoid(o)));
2195 PL_curcop = &PL_compiling;
2196 PL_main_start = LINKLIST(PL_main_root);
2197 PL_main_root->op_private |= OPpREFCOUNTED;
2198 OpREFCNT_set(PL_main_root, 1);
2199 PL_main_root->op_next = 0;
2200 peep(PL_main_start);
2203 /* Register with debugger */
2205 CV *cv = get_cv("DB::postponed", FALSE);
2209 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2211 call_sv((SV*)cv, G_DISCARD);
2218 Perl_localize(pTHX_ OP *o, I32 lex)
2220 if (o->op_flags & OPf_PARENS)
2223 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2225 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2226 if (*s == ';' || *s == '=')
2227 Perl_warner(aTHX_ WARN_PARENTHESIS,
2228 "Parentheses missing around \"%s\" list",
2229 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2235 o = mod(o, OP_NULL); /* a bit kludgey */
2237 PL_in_my_stash = Nullhv;
2242 Perl_jmaybe(pTHX_ OP *o)
2244 if (o->op_type == OP_LIST) {
2247 o2 = newOP(OP_THREADSV, 0);
2248 o2->op_targ = find_threadsv(";");
2250 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2251 #endif /* USE_THREADS */
2252 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2258 Perl_fold_constants(pTHX_ register OP *o)
2261 I32 type = o->op_type;
2264 if (PL_opargs[type] & OA_RETSCALAR)
2266 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2267 o->op_targ = pad_alloc(type, SVs_PADTMP);
2269 /* integerize op, unless it happens to be C<-foo>.
2270 * XXX should pp_i_negate() do magic string negation instead? */
2271 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2272 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2273 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2275 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2278 if (!(PL_opargs[type] & OA_FOLDCONST))
2283 /* XXX might want a ck_negate() for this */
2284 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2297 if (o->op_private & OPpLOCALE)
2302 goto nope; /* Don't try to run w/ errors */
2304 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2305 if ((curop->op_type != OP_CONST ||
2306 (curop->op_private & OPpCONST_BARE)) &&
2307 curop->op_type != OP_LIST &&
2308 curop->op_type != OP_SCALAR &&
2309 curop->op_type != OP_NULL &&
2310 curop->op_type != OP_PUSHMARK)
2316 curop = LINKLIST(o);
2320 sv = *(PL_stack_sp--);
2321 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2322 pad_swipe(o->op_targ);
2323 else if (SvTEMP(sv)) { /* grab mortal temp? */
2324 (void)SvREFCNT_inc(sv);
2328 if (type == OP_RV2GV)
2329 return newGVOP(OP_GV, 0, (GV*)sv);
2331 /* try to smush double to int, but don't smush -2.0 to -2 */
2332 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2335 #ifdef PERL_PRESERVE_IVUV
2336 /* Only bother to attempt to fold to IV if
2337 most operators will benefit */
2341 return newSVOP(OP_CONST, 0, sv);
2345 if (!(PL_opargs[type] & OA_OTHERINT))
2348 if (!(PL_hints & HINT_INTEGER)) {
2349 if (type == OP_MODULO
2350 || type == OP_DIVIDE
2351 || !(o->op_flags & OPf_KIDS))
2356 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2357 if (curop->op_type == OP_CONST) {
2358 if (SvIOK(((SVOP*)curop)->op_sv))
2362 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2366 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2373 Perl_gen_constant_list(pTHX_ register OP *o)
2376 I32 oldtmps_floor = PL_tmps_floor;
2380 return o; /* Don't attempt to run with errors */
2382 PL_op = curop = LINKLIST(o);
2389 PL_tmps_floor = oldtmps_floor;
2391 o->op_type = OP_RV2AV;
2392 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2393 curop = ((UNOP*)o)->op_first;
2394 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2401 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2403 if (!o || o->op_type != OP_LIST)
2404 o = newLISTOP(OP_LIST, 0, o, Nullop);
2406 o->op_flags &= ~OPf_WANT;
2408 if (!(PL_opargs[type] & OA_MARK))
2409 null(cLISTOPo->op_first);
2412 o->op_ppaddr = PL_ppaddr[type];
2413 o->op_flags |= flags;
2415 o = CHECKOP(type, o);
2416 if (o->op_type != type)
2419 return fold_constants(o);
2422 /* List constructors */
2425 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2433 if (first->op_type != type
2434 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2436 return newLISTOP(type, 0, first, last);
2439 if (first->op_flags & OPf_KIDS)
2440 ((LISTOP*)first)->op_last->op_sibling = last;
2442 first->op_flags |= OPf_KIDS;
2443 ((LISTOP*)first)->op_first = last;
2445 ((LISTOP*)first)->op_last = last;
2450 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2458 if (first->op_type != type)
2459 return prepend_elem(type, (OP*)first, (OP*)last);
2461 if (last->op_type != type)
2462 return append_elem(type, (OP*)first, (OP*)last);
2464 first->op_last->op_sibling = last->op_first;
2465 first->op_last = last->op_last;
2466 first->op_flags |= (last->op_flags & OPf_KIDS);
2468 #ifdef PL_OP_SLAB_ALLOC
2476 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2484 if (last->op_type == type) {
2485 if (type == OP_LIST) { /* already a PUSHMARK there */
2486 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2487 ((LISTOP*)last)->op_first->op_sibling = first;
2488 if (!(first->op_flags & OPf_PARENS))
2489 last->op_flags &= ~OPf_PARENS;
2492 if (!(last->op_flags & OPf_KIDS)) {
2493 ((LISTOP*)last)->op_last = first;
2494 last->op_flags |= OPf_KIDS;
2496 first->op_sibling = ((LISTOP*)last)->op_first;
2497 ((LISTOP*)last)->op_first = first;
2499 last->op_flags |= OPf_KIDS;
2503 return newLISTOP(type, 0, first, last);
2509 Perl_newNULLLIST(pTHX)
2511 return newOP(OP_STUB, 0);
2515 Perl_force_list(pTHX_ OP *o)
2517 if (!o || o->op_type != OP_LIST)
2518 o = newLISTOP(OP_LIST, 0, o, Nullop);
2524 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2528 NewOp(1101, listop, 1, LISTOP);
2530 listop->op_type = type;
2531 listop->op_ppaddr = PL_ppaddr[type];
2534 listop->op_flags = flags;
2538 else if (!first && last)
2541 first->op_sibling = last;
2542 listop->op_first = first;
2543 listop->op_last = last;
2544 if (type == OP_LIST) {
2546 pushop = newOP(OP_PUSHMARK, 0);
2547 pushop->op_sibling = first;
2548 listop->op_first = pushop;
2549 listop->op_flags |= OPf_KIDS;
2551 listop->op_last = pushop;
2558 Perl_newOP(pTHX_ I32 type, I32 flags)
2561 NewOp(1101, o, 1, OP);
2563 o->op_ppaddr = PL_ppaddr[type];
2564 o->op_flags = flags;
2567 o->op_private = 0 + (flags >> 8);
2568 if (PL_opargs[type] & OA_RETSCALAR)
2570 if (PL_opargs[type] & OA_TARGET)
2571 o->op_targ = pad_alloc(type, SVs_PADTMP);
2572 return CHECKOP(type, o);
2576 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2581 first = newOP(OP_STUB, 0);
2582 if (PL_opargs[type] & OA_MARK)
2583 first = force_list(first);
2585 NewOp(1101, unop, 1, UNOP);
2586 unop->op_type = type;
2587 unop->op_ppaddr = PL_ppaddr[type];
2588 unop->op_first = first;
2589 unop->op_flags = flags | OPf_KIDS;
2590 unop->op_private = 1 | (flags >> 8);
2591 unop = (UNOP*) CHECKOP(type, unop);
2595 return fold_constants((OP *) unop);
2599 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2602 NewOp(1101, binop, 1, BINOP);
2605 first = newOP(OP_NULL, 0);
2607 binop->op_type = type;
2608 binop->op_ppaddr = PL_ppaddr[type];
2609 binop->op_first = first;
2610 binop->op_flags = flags | OPf_KIDS;
2613 binop->op_private = 1 | (flags >> 8);
2616 binop->op_private = 2 | (flags >> 8);
2617 first->op_sibling = last;
2620 binop = (BINOP*)CHECKOP(type, binop);
2621 if (binop->op_next || binop->op_type != type)
2624 binop->op_last = binop->op_first->op_sibling;
2626 return fold_constants((OP *)binop);
2630 utf8compare(const void *a, const void *b)
2633 for (i = 0; i < 10; i++) {
2634 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2636 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2643 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2645 SV *tstr = ((SVOP*)expr)->op_sv;
2646 SV *rstr = ((SVOP*)repl)->op_sv;
2649 U8 *t = (U8*)SvPV(tstr, tlen);
2650 U8 *r = (U8*)SvPV(rstr, rlen);
2657 register short *tbl;
2659 complement = o->op_private & OPpTRANS_COMPLEMENT;
2660 del = o->op_private & OPpTRANS_DELETE;
2661 squash = o->op_private & OPpTRANS_SQUASH;
2664 o->op_private |= OPpTRANS_FROM_UTF;
2667 o->op_private |= OPpTRANS_TO_UTF;
2669 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2670 SV* listsv = newSVpvn("# comment\n",10);
2672 U8* tend = t + tlen;
2673 U8* rend = r + rlen;
2687 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2688 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2689 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2690 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2693 U8 tmpbuf[UTF8_MAXLEN+1];
2696 New(1109, cp, tlen, U8*);
2698 transv = newSVpvn("",0);
2702 if (t < tend && *t == 0xff) {
2707 qsort(cp, i, sizeof(U8*), utf8compare);
2708 for (j = 0; j < i; j++) {
2710 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2711 /* CHECKME: Use unicode code points for ranges - needs more thought ... NI-S */
2712 UV val = utf8n_to_uvuni(s, cur, &ulen, 0);
2714 diff = val - nextmin;
2716 t = uvuni_to_utf8(tmpbuf,nextmin);
2717 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2719 t = uvuni_to_utf8(tmpbuf, val - 1);
2720 sv_catpvn(transv, "\377", 1);
2721 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2724 if (s < tend && *s == 0xff)
2725 val = utf8n_to_uvuni(s+1, cur - 1, &ulen, 0);
2729 t = uvuni_to_utf8(tmpbuf,nextmin);
2730 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2731 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2732 sv_catpvn(transv, "\377", 1);
2733 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2734 t = (U8*)SvPVX(transv);
2735 tlen = SvCUR(transv);
2739 else if (!rlen && !del) {
2740 r = t; rlen = tlen; rend = tend;
2744 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2746 o->op_private |= OPpTRANS_IDENTICAL;
2750 while (t < tend || tfirst <= tlast) {
2751 /* see if we need more "t" chars */
2752 if (tfirst > tlast) {
2753 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2755 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2757 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2764 /* now see if we need more "r" chars */
2765 if (rfirst > rlast) {
2767 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2769 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2771 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2780 rfirst = rlast = 0xffffffff;
2784 /* now see which range will peter our first, if either. */
2785 tdiff = tlast - tfirst;
2786 rdiff = rlast - rfirst;
2793 if (rfirst == 0xffffffff) {
2794 diff = tdiff; /* oops, pretend rdiff is infinite */
2796 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2797 (long)tfirst, (long)tlast);
2799 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2803 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2804 (long)tfirst, (long)(tfirst + diff),
2807 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2808 (long)tfirst, (long)rfirst);
2810 if (rfirst + diff > max)
2811 max = rfirst + diff;
2814 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2825 else if (max > 0xff)
2830 Safefree(cPVOPo->op_pv);
2831 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2832 SvREFCNT_dec(listsv);
2834 SvREFCNT_dec(transv);
2836 if (!del && havefinal)
2837 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2838 newSVuv((UV)final), 0);
2841 o->op_private |= OPpTRANS_GROWS;
2853 tbl = (short*)cPVOPo->op_pv;
2855 Zero(tbl, 256, short);
2856 for (i = 0; i < tlen; i++)
2858 for (i = 0, j = 0; i < 256; i++) {
2869 if (i < 128 && r[j] >= 128)
2879 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2880 tbl[0x100] = rlen - j;
2881 for (i=0; i < rlen - j; i++)
2882 tbl[0x101+i] = r[j+i];
2886 if (!rlen && !del) {
2889 o->op_private |= OPpTRANS_IDENTICAL;
2891 for (i = 0; i < 256; i++)
2893 for (i = 0, j = 0; i < tlen; i++,j++) {
2896 if (tbl[t[i]] == -1)
2902 if (tbl[t[i]] == -1) {
2903 if (t[i] < 128 && r[j] >= 128)
2910 o->op_private |= OPpTRANS_GROWS;
2918 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2922 NewOp(1101, pmop, 1, PMOP);
2923 pmop->op_type = type;
2924 pmop->op_ppaddr = PL_ppaddr[type];
2925 pmop->op_flags = flags;
2926 pmop->op_private = 0 | (flags >> 8);
2928 if (PL_hints & HINT_RE_TAINT)
2929 pmop->op_pmpermflags |= PMf_RETAINT;
2930 if (PL_hints & HINT_LOCALE)
2931 pmop->op_pmpermflags |= PMf_LOCALE;
2932 pmop->op_pmflags = pmop->op_pmpermflags;
2934 /* link into pm list */
2935 if (type != OP_TRANS && PL_curstash) {
2936 pmop->op_pmnext = HvPMROOT(PL_curstash);
2937 HvPMROOT(PL_curstash) = pmop;
2944 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2948 I32 repl_has_vars = 0;
2950 if (o->op_type == OP_TRANS)
2951 return pmtrans(o, expr, repl);
2953 PL_hints |= HINT_BLOCK_SCOPE;
2956 if (expr->op_type == OP_CONST) {
2958 SV *pat = ((SVOP*)expr)->op_sv;
2959 char *p = SvPV(pat, plen);
2960 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2961 sv_setpvn(pat, "\\s+", 3);
2962 p = SvPV(pat, plen);
2963 pm->op_pmflags |= PMf_SKIPWHITE;
2965 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2966 pm->op_pmdynflags |= PMdf_UTF8;
2967 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2968 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2969 pm->op_pmflags |= PMf_WHITE;
2973 if (PL_hints & HINT_UTF8)
2974 pm->op_pmdynflags |= PMdf_UTF8;
2975 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2976 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2978 : OP_REGCMAYBE),0,expr);
2980 NewOp(1101, rcop, 1, LOGOP);
2981 rcop->op_type = OP_REGCOMP;
2982 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2983 rcop->op_first = scalar(expr);
2984 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2985 ? (OPf_SPECIAL | OPf_KIDS)
2987 rcop->op_private = 1;
2990 /* establish postfix order */
2991 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2993 rcop->op_next = expr;
2994 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2997 rcop->op_next = LINKLIST(expr);
2998 expr->op_next = (OP*)rcop;
3001 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3006 if (pm->op_pmflags & PMf_EVAL) {
3008 if (CopLINE(PL_curcop) < PL_multi_end)
3009 CopLINE_set(PL_curcop, PL_multi_end);
3012 else if (repl->op_type == OP_THREADSV
3013 && strchr("&`'123456789+",
3014 PL_threadsv_names[repl->op_targ]))
3018 #endif /* USE_THREADS */
3019 else if (repl->op_type == OP_CONST)
3023 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3024 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3026 if (curop->op_type == OP_THREADSV) {
3028 if (strchr("&`'123456789+", curop->op_private))
3032 if (curop->op_type == OP_GV) {
3033 GV *gv = cGVOPx_gv(curop);
3035 if (strchr("&`'123456789+", *GvENAME(gv)))
3038 #endif /* USE_THREADS */
3039 else if (curop->op_type == OP_RV2CV)
3041 else if (curop->op_type == OP_RV2SV ||
3042 curop->op_type == OP_RV2AV ||
3043 curop->op_type == OP_RV2HV ||
3044 curop->op_type == OP_RV2GV) {
3045 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3048 else if (curop->op_type == OP_PADSV ||
3049 curop->op_type == OP_PADAV ||
3050 curop->op_type == OP_PADHV ||
3051 curop->op_type == OP_PADANY) {
3054 else if (curop->op_type == OP_PUSHRE)
3055 ; /* Okay here, dangerous in newASSIGNOP */
3064 && (!pm->op_pmregexp
3065 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3066 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3067 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3068 prepend_elem(o->op_type, scalar(repl), o);
3071 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3072 pm->op_pmflags |= PMf_MAYBE_CONST;
3073 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3075 NewOp(1101, rcop, 1, LOGOP);
3076 rcop->op_type = OP_SUBSTCONT;
3077 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3078 rcop->op_first = scalar(repl);
3079 rcop->op_flags |= OPf_KIDS;
3080 rcop->op_private = 1;
3083 /* establish postfix order */
3084 rcop->op_next = LINKLIST(repl);
3085 repl->op_next = (OP*)rcop;
3087 pm->op_pmreplroot = scalar((OP*)rcop);
3088 pm->op_pmreplstart = LINKLIST(rcop);
3097 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3100 NewOp(1101, svop, 1, SVOP);
3101 svop->op_type = type;
3102 svop->op_ppaddr = PL_ppaddr[type];
3104 svop->op_next = (OP*)svop;
3105 svop->op_flags = flags;
3106 if (PL_opargs[type] & OA_RETSCALAR)
3108 if (PL_opargs[type] & OA_TARGET)
3109 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3110 return CHECKOP(type, svop);
3114 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3117 NewOp(1101, padop, 1, PADOP);
3118 padop->op_type = type;
3119 padop->op_ppaddr = PL_ppaddr[type];
3120 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3121 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3122 PL_curpad[padop->op_padix] = sv;
3124 padop->op_next = (OP*)padop;
3125 padop->op_flags = flags;
3126 if (PL_opargs[type] & OA_RETSCALAR)
3128 if (PL_opargs[type] & OA_TARGET)
3129 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3130 return CHECKOP(type, padop);
3134 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3138 return newPADOP(type, flags, SvREFCNT_inc(gv));
3140 return newSVOP(type, flags, SvREFCNT_inc(gv));
3145 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3148 NewOp(1101, pvop, 1, PVOP);
3149 pvop->op_type = type;
3150 pvop->op_ppaddr = PL_ppaddr[type];
3152 pvop->op_next = (OP*)pvop;
3153 pvop->op_flags = flags;
3154 if (PL_opargs[type] & OA_RETSCALAR)
3156 if (PL_opargs[type] & OA_TARGET)
3157 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3158 return CHECKOP(type, pvop);
3162 Perl_package(pTHX_ OP *o)
3166 save_hptr(&PL_curstash);
3167 save_item(PL_curstname);
3172 name = SvPV(sv, len);
3173 PL_curstash = gv_stashpvn(name,len,TRUE);
3174 sv_setpvn(PL_curstname, name, len);
3178 sv_setpv(PL_curstname,"<none>");
3179 PL_curstash = Nullhv;
3181 PL_hints |= HINT_BLOCK_SCOPE;
3182 PL_copline = NOLINE;
3187 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3195 if (id->op_type != OP_CONST)
3196 Perl_croak(aTHX_ "Module name must be constant");
3200 if (version != Nullop) {
3201 SV *vesv = ((SVOP*)version)->op_sv;
3203 if (arg == Nullop && !SvNIOKp(vesv)) {
3210 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3211 Perl_croak(aTHX_ "Version number must be constant number");
3213 /* Make copy of id so we don't free it twice */
3214 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3216 /* Fake up a method call to VERSION */
3217 meth = newSVpvn("VERSION",7);
3218 sv_upgrade(meth, SVt_PVIV);
3219 (void)SvIOK_on(meth);
3220 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3221 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3222 append_elem(OP_LIST,
3223 prepend_elem(OP_LIST, pack, list(version)),
3224 newSVOP(OP_METHOD_NAMED, 0, meth)));
3228 /* Fake up an import/unimport */
3229 if (arg && arg->op_type == OP_STUB)
3230 imop = arg; /* no import on explicit () */
3231 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3232 imop = Nullop; /* use 5.0; */
3237 /* Make copy of id so we don't free it twice */
3238 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3240 /* Fake up a method call to import/unimport */
3241 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3242 sv_upgrade(meth, SVt_PVIV);
3243 (void)SvIOK_on(meth);
3244 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3245 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3246 append_elem(OP_LIST,
3247 prepend_elem(OP_LIST, pack, list(arg)),
3248 newSVOP(OP_METHOD_NAMED, 0, meth)));
3251 /* Fake up a require, handle override, if any */
3252 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3253 if (!(gv && GvIMPORTED_CV(gv)))
3254 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3256 if (gv && GvIMPORTED_CV(gv)) {
3257 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3258 append_elem(OP_LIST, id,
3259 scalar(newUNOP(OP_RV2CV, 0,
3264 rqop = newUNOP(OP_REQUIRE, 0, id);
3267 /* Fake up the BEGIN {}, which does its thing immediately. */
3269 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3272 append_elem(OP_LINESEQ,
3273 append_elem(OP_LINESEQ,
3274 newSTATEOP(0, Nullch, rqop),
3275 newSTATEOP(0, Nullch, veop)),
3276 newSTATEOP(0, Nullch, imop) ));
3278 PL_hints |= HINT_BLOCK_SCOPE;
3279 PL_copline = NOLINE;
3284 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3287 va_start(args, ver);
3288 vload_module(flags, name, ver, &args);
3292 #ifdef PERL_IMPLICIT_CONTEXT
3294 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3298 va_start(args, ver);
3299 vload_module(flags, name, ver, &args);
3305 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3307 OP *modname, *veop, *imop;
3309 modname = newSVOP(OP_CONST, 0, name);
3310 modname->op_private |= OPpCONST_BARE;
3312 veop = newSVOP(OP_CONST, 0, ver);
3316 if (flags & PERL_LOADMOD_NOIMPORT) {
3317 imop = sawparens(newNULLLIST());
3319 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3320 imop = va_arg(*args, OP*);
3325 sv = va_arg(*args, SV*);
3327 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3328 sv = va_arg(*args, SV*);
3332 line_t ocopline = PL_copline;
3333 int oexpect = PL_expect;
3335 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3336 veop, modname, imop);
3337 PL_expect = oexpect;
3338 PL_copline = ocopline;
3343 Perl_dofile(pTHX_ OP *term)
3348 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3349 if (!(gv && GvIMPORTED_CV(gv)))
3350 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3352 if (gv && GvIMPORTED_CV(gv)) {
3353 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3354 append_elem(OP_LIST, term,
3355 scalar(newUNOP(OP_RV2CV, 0,
3360 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3366 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3368 return newBINOP(OP_LSLICE, flags,
3369 list(force_list(subscript)),
3370 list(force_list(listval)) );
3374 S_list_assignment(pTHX_ register OP *o)
3379 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3380 o = cUNOPo->op_first;
3382 if (o->op_type == OP_COND_EXPR) {
3383 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3384 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3389 yyerror("Assignment to both a list and a scalar");
3393 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3394 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3395 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3398 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3401 if (o->op_type == OP_RV2SV)
3408 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3413 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3414 return newLOGOP(optype, 0,
3415 mod(scalar(left), optype),
3416 newUNOP(OP_SASSIGN, 0, scalar(right)));
3419 return newBINOP(optype, OPf_STACKED,
3420 mod(scalar(left), optype), scalar(right));
3424 if (list_assignment(left)) {
3428 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3429 left = mod(left, OP_AASSIGN);
3437 curop = list(force_list(left));
3438 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3439 o->op_private = 0 | (flags >> 8);
3440 for (curop = ((LISTOP*)curop)->op_first;
3441 curop; curop = curop->op_sibling)
3443 if (curop->op_type == OP_RV2HV &&
3444 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3445 o->op_private |= OPpASSIGN_HASH;
3449 if (!(left->op_private & OPpLVAL_INTRO)) {
3452 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3453 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3454 if (curop->op_type == OP_GV) {
3455 GV *gv = cGVOPx_gv(curop);
3456 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3458 SvCUR(gv) = PL_generation;
3460 else if (curop->op_type == OP_PADSV ||
3461 curop->op_type == OP_PADAV ||
3462 curop->op_type == OP_PADHV ||
3463 curop->op_type == OP_PADANY) {
3464 SV **svp = AvARRAY(PL_comppad_name);
3465 SV *sv = svp[curop->op_targ];
3466 if (SvCUR(sv) == PL_generation)
3468 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3470 else if (curop->op_type == OP_RV2CV)
3472 else if (curop->op_type == OP_RV2SV ||
3473 curop->op_type == OP_RV2AV ||
3474 curop->op_type == OP_RV2HV ||
3475 curop->op_type == OP_RV2GV) {
3476 if (lastop->op_type != OP_GV) /* funny deref? */
3479 else if (curop->op_type == OP_PUSHRE) {
3480 if (((PMOP*)curop)->op_pmreplroot) {
3482 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3484 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3486 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3488 SvCUR(gv) = PL_generation;
3497 o->op_private |= OPpASSIGN_COMMON;
3499 if (right && right->op_type == OP_SPLIT) {
3501 if ((tmpop = ((LISTOP*)right)->op_first) &&
3502 tmpop->op_type == OP_PUSHRE)
3504 PMOP *pm = (PMOP*)tmpop;
3505 if (left->op_type == OP_RV2AV &&
3506 !(left->op_private & OPpLVAL_INTRO) &&
3507 !(o->op_private & OPpASSIGN_COMMON) )
3509 tmpop = ((UNOP*)left)->op_first;
3510 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3512 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3513 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3515 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3516 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3518 pm->op_pmflags |= PMf_ONCE;
3519 tmpop = cUNOPo->op_first; /* to list (nulled) */
3520 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3521 tmpop->op_sibling = Nullop; /* don't free split */
3522 right->op_next = tmpop->op_next; /* fix starting loc */
3523 op_free(o); /* blow off assign */
3524 right->op_flags &= ~OPf_WANT;
3525 /* "I don't know and I don't care." */
3530 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3531 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3533 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3535 sv_setiv(sv, PL_modcount+1);
3543 right = newOP(OP_UNDEF, 0);
3544 if (right->op_type == OP_READLINE) {
3545 right->op_flags |= OPf_STACKED;
3546 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3549 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3550 o = newBINOP(OP_SASSIGN, flags,
3551 scalar(right), mod(scalar(left), OP_SASSIGN) );
3563 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3565 U32 seq = intro_my();
3568 NewOp(1101, cop, 1, COP);
3569 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3570 cop->op_type = OP_DBSTATE;
3571 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3574 cop->op_type = OP_NEXTSTATE;
3575 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3577 cop->op_flags = flags;
3578 cop->op_private = (PL_hints & HINT_BYTE);
3580 cop->op_private |= NATIVE_HINTS;
3582 PL_compiling.op_private = cop->op_private;
3583 cop->op_next = (OP*)cop;
3586 cop->cop_label = label;
3587 PL_hints |= HINT_BLOCK_SCOPE;
3590 cop->cop_arybase = PL_curcop->cop_arybase;
3591 if (specialWARN(PL_curcop->cop_warnings))
3592 cop->cop_warnings = PL_curcop->cop_warnings ;
3594 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3595 if (specialCopIO(PL_curcop->cop_io))
3596 cop->cop_io = PL_curcop->cop_io;
3598 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3601 if (PL_copline == NOLINE)
3602 CopLINE_set(cop, CopLINE(PL_curcop));
3604 CopLINE_set(cop, PL_copline);
3605 PL_copline = NOLINE;
3608 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3610 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3612 CopSTASH_set(cop, PL_curstash);
3614 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3615 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3616 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3617 (void)SvIOK_on(*svp);
3618 SvIVX(*svp) = PTR2IV(cop);
3622 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3625 /* "Introduce" my variables to visible status. */
3633 if (! PL_min_intro_pending)
3634 return PL_cop_seqmax;
3636 svp = AvARRAY(PL_comppad_name);
3637 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3638 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3639 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3640 SvNVX(sv) = (NV)PL_cop_seqmax;
3643 PL_min_intro_pending = 0;
3644 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3645 return PL_cop_seqmax++;
3649 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3651 return new_logop(type, flags, &first, &other);
3655 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3659 OP *first = *firstp;
3660 OP *other = *otherp;
3662 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3663 return newBINOP(type, flags, scalar(first), scalar(other));
3665 scalarboolean(first);
3666 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3667 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3668 if (type == OP_AND || type == OP_OR) {
3674 first = *firstp = cUNOPo->op_first;
3676 first->op_next = o->op_next;
3677 cUNOPo->op_first = Nullop;
3681 if (first->op_type == OP_CONST) {
3682 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3683 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3684 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3695 else if (first->op_type == OP_WANTARRAY) {
3701 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3702 OP *k1 = ((UNOP*)first)->op_first;
3703 OP *k2 = k1->op_sibling;
3705 switch (first->op_type)
3708 if (k2 && k2->op_type == OP_READLINE
3709 && (k2->op_flags & OPf_STACKED)
3710 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3712 warnop = k2->op_type;
3717 if (k1->op_type == OP_READDIR
3718 || k1->op_type == OP_GLOB
3719 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3720 || k1->op_type == OP_EACH)
3722 warnop = ((k1->op_type == OP_NULL)
3723 ? k1->op_targ : k1->op_type);
3728 line_t oldline = CopLINE(PL_curcop);
3729 CopLINE_set(PL_curcop, PL_copline);
3730 Perl_warner(aTHX_ WARN_MISC,
3731 "Value of %s%s can be \"0\"; test with defined()",
3733 ((warnop == OP_READLINE || warnop == OP_GLOB)
3734 ? " construct" : "() operator"));
3735 CopLINE_set(PL_curcop, oldline);
3742 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3743 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3745 NewOp(1101, logop, 1, LOGOP);
3747 logop->op_type = type;
3748 logop->op_ppaddr = PL_ppaddr[type];
3749 logop->op_first = first;
3750 logop->op_flags = flags | OPf_KIDS;
3751 logop->op_other = LINKLIST(other);
3752 logop->op_private = 1 | (flags >> 8);
3754 /* establish postfix order */
3755 logop->op_next = LINKLIST(first);
3756 first->op_next = (OP*)logop;
3757 first->op_sibling = other;
3759 o = newUNOP(OP_NULL, 0, (OP*)logop);
3766 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3773 return newLOGOP(OP_AND, 0, first, trueop);
3775 return newLOGOP(OP_OR, 0, first, falseop);
3777 scalarboolean(first);
3778 if (first->op_type == OP_CONST) {
3779 if (SvTRUE(((SVOP*)first)->op_sv)) {
3790 else if (first->op_type == OP_WANTARRAY) {
3794 NewOp(1101, logop, 1, LOGOP);
3795 logop->op_type = OP_COND_EXPR;
3796 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3797 logop->op_first = first;
3798 logop->op_flags = flags | OPf_KIDS;
3799 logop->op_private = 1 | (flags >> 8);
3800 logop->op_other = LINKLIST(trueop);
3801 logop->op_next = LINKLIST(falseop);
3804 /* establish postfix order */
3805 start = LINKLIST(first);
3806 first->op_next = (OP*)logop;
3808 first->op_sibling = trueop;
3809 trueop->op_sibling = falseop;
3810 o = newUNOP(OP_NULL, 0, (OP*)logop);
3812 trueop->op_next = falseop->op_next = o;
3819 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3827 NewOp(1101, range, 1, LOGOP);
3829 range->op_type = OP_RANGE;
3830 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3831 range->op_first = left;
3832 range->op_flags = OPf_KIDS;
3833 leftstart = LINKLIST(left);
3834 range->op_other = LINKLIST(right);
3835 range->op_private = 1 | (flags >> 8);
3837 left->op_sibling = right;
3839 range->op_next = (OP*)range;
3840 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3841 flop = newUNOP(OP_FLOP, 0, flip);
3842 o = newUNOP(OP_NULL, 0, flop);
3844 range->op_next = leftstart;
3846 left->op_next = flip;
3847 right->op_next = flop;
3849 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3850 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3851 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3852 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3854 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3855 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3858 if (!flip->op_private || !flop->op_private)
3859 linklist(o); /* blow off optimizer unless constant */
3865 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3869 int once = block && block->op_flags & OPf_SPECIAL &&
3870 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3873 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3874 return block; /* do {} while 0 does once */
3875 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3876 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3877 expr = newUNOP(OP_DEFINED, 0,
3878 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3879 } else if (expr->op_flags & OPf_KIDS) {
3880 OP *k1 = ((UNOP*)expr)->op_first;
3881 OP *k2 = (k1) ? k1->op_sibling : NULL;
3882 switch (expr->op_type) {
3884 if (k2 && k2->op_type == OP_READLINE
3885 && (k2->op_flags & OPf_STACKED)
3886 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3887 expr = newUNOP(OP_DEFINED, 0, expr);
3891 if (k1->op_type == OP_READDIR
3892 || k1->op_type == OP_GLOB
3893 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3894 || k1->op_type == OP_EACH)
3895 expr = newUNOP(OP_DEFINED, 0, expr);
3901 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3902 o = new_logop(OP_AND, 0, &expr, &listop);
3905 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3907 if (once && o != listop)
3908 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3911 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3913 o->op_flags |= flags;
3915 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3920 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3929 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3930 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3931 expr = newUNOP(OP_DEFINED, 0,
3932 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3933 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3934 OP *k1 = ((UNOP*)expr)->op_first;
3935 OP *k2 = (k1) ? k1->op_sibling : NULL;
3936 switch (expr->op_type) {
3938 if (k2 && k2->op_type == OP_READLINE
3939 && (k2->op_flags & OPf_STACKED)
3940 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3941 expr = newUNOP(OP_DEFINED, 0, expr);
3945 if (k1->op_type == OP_READDIR
3946 || k1->op_type == OP_GLOB
3947 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3948 || k1->op_type == OP_EACH)
3949 expr = newUNOP(OP_DEFINED, 0, expr);
3955 block = newOP(OP_NULL, 0);
3957 block = scope(block);
3961 next = LINKLIST(cont);
3964 OP *unstack = newOP(OP_UNSTACK, 0);
3967 cont = append_elem(OP_LINESEQ, cont, unstack);
3968 if ((line_t)whileline != NOLINE) {
3969 PL_copline = whileline;
3970 cont = append_elem(OP_LINESEQ, cont,
3971 newSTATEOP(0, Nullch, Nullop));
3975 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3976 redo = LINKLIST(listop);
3979 PL_copline = whileline;
3981 o = new_logop(OP_AND, 0, &expr, &listop);
3982 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3983 op_free(expr); /* oops, it's a while (0) */
3985 return Nullop; /* listop already freed by new_logop */
3988 ((LISTOP*)listop)->op_last->op_next = condop =
3989 (o == listop ? redo : LINKLIST(o));
3995 NewOp(1101,loop,1,LOOP);
3996 loop->op_type = OP_ENTERLOOP;
3997 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3998 loop->op_private = 0;
3999 loop->op_next = (OP*)loop;
4002 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4004 loop->op_redoop = redo;
4005 loop->op_lastop = o;
4006 o->op_private |= loopflags;
4009 loop->op_nextop = next;
4011 loop->op_nextop = o;
4013 o->op_flags |= flags;
4014 o->op_private |= (flags >> 8);
4019 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4027 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4028 sv->op_type = OP_RV2GV;
4029 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4031 else if (sv->op_type == OP_PADSV) { /* private variable */
4032 padoff = sv->op_targ;
4037 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4038 padoff = sv->op_targ;
4040 iterflags |= OPf_SPECIAL;
4045 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4049 padoff = find_threadsv("_");
4050 iterflags |= OPf_SPECIAL;
4052 sv = newGVOP(OP_GV, 0, PL_defgv);
4055 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4056 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4057 iterflags |= OPf_STACKED;
4059 else if (expr->op_type == OP_NULL &&
4060 (expr->op_flags & OPf_KIDS) &&
4061 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4063 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4064 * set the STACKED flag to indicate that these values are to be
4065 * treated as min/max values by 'pp_iterinit'.
4067 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4068 LOGOP* range = (LOGOP*) flip->op_first;
4069 OP* left = range->op_first;
4070 OP* right = left->op_sibling;
4073 range->op_flags &= ~OPf_KIDS;
4074 range->op_first = Nullop;
4076 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4077 listop->op_first->op_next = range->op_next;
4078 left->op_next = range->op_other;
4079 right->op_next = (OP*)listop;
4080 listop->op_next = listop->op_first;
4083 expr = (OP*)(listop);
4085 iterflags |= OPf_STACKED;
4088 expr = mod(force_list(expr), OP_GREPSTART);
4092 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4093 append_elem(OP_LIST, expr, scalar(sv))));
4094 assert(!loop->op_next);
4095 #ifdef PL_OP_SLAB_ALLOC
4098 NewOp(1234,tmp,1,LOOP);
4099 Copy(loop,tmp,1,LOOP);
4103 Renew(loop, 1, LOOP);
4105 loop->op_targ = padoff;
4106 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4107 PL_copline = forline;
4108 return newSTATEOP(0, label, wop);
4112 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4117 if (type != OP_GOTO || label->op_type == OP_CONST) {
4118 /* "last()" means "last" */
4119 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4120 o = newOP(type, OPf_SPECIAL);
4122 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4123 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4129 if (label->op_type == OP_ENTERSUB)
4130 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4131 o = newUNOP(type, OPf_STACKED, label);
4133 PL_hints |= HINT_BLOCK_SCOPE;
4138 Perl_cv_undef(pTHX_ CV *cv)
4142 MUTEX_DESTROY(CvMUTEXP(cv));
4143 Safefree(CvMUTEXP(cv));
4146 #endif /* USE_THREADS */
4148 if (!CvXSUB(cv) && CvROOT(cv)) {
4150 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4151 Perl_croak(aTHX_ "Can't undef active subroutine");
4154 Perl_croak(aTHX_ "Can't undef active subroutine");
4155 #endif /* USE_THREADS */
4158 SAVEVPTR(PL_curpad);
4162 op_free(CvROOT(cv));
4163 CvROOT(cv) = Nullop;
4166 SvPOK_off((SV*)cv); /* forget prototype */
4168 SvREFCNT_dec(CvOUTSIDE(cv));
4169 CvOUTSIDE(cv) = Nullcv;
4171 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4174 if (CvPADLIST(cv)) {
4175 /* may be during global destruction */
4176 if (SvREFCNT(CvPADLIST(cv))) {
4177 I32 i = AvFILLp(CvPADLIST(cv));
4179 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4180 SV* sv = svp ? *svp : Nullsv;
4183 if (sv == (SV*)PL_comppad_name)
4184 PL_comppad_name = Nullav;
4185 else if (sv == (SV*)PL_comppad) {
4186 PL_comppad = Nullav;
4187 PL_curpad = Null(SV**);
4191 SvREFCNT_dec((SV*)CvPADLIST(cv));
4193 CvPADLIST(cv) = Nullav;
4198 #ifdef DEBUG_CLOSURES
4200 S_cv_dump(pTHX_ CV *cv)
4203 CV *outside = CvOUTSIDE(cv);
4204 AV* padlist = CvPADLIST(cv);
4211 PerlIO_printf(Perl_debug_log,
4212 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4214 (CvANON(cv) ? "ANON"
4215 : (cv == PL_main_cv) ? "MAIN"
4216 : CvUNIQUE(cv) ? "UNIQUE"
4217 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4220 : CvANON(outside) ? "ANON"
4221 : (outside == PL_main_cv) ? "MAIN"
4222 : CvUNIQUE(outside) ? "UNIQUE"
4223 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4228 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4229 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4230 pname = AvARRAY(pad_name);
4231 ppad = AvARRAY(pad);
4233 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4234 if (SvPOK(pname[ix]))
4235 PerlIO_printf(Perl_debug_log,
4236 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4237 (int)ix, PTR2UV(ppad[ix]),
4238 SvFAKE(pname[ix]) ? "FAKE " : "",
4240 (IV)I_32(SvNVX(pname[ix])),
4243 #endif /* DEBUGGING */
4245 #endif /* DEBUG_CLOSURES */
4248 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4252 AV* protopadlist = CvPADLIST(proto);
4253 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4254 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4255 SV** pname = AvARRAY(protopad_name);
4256 SV** ppad = AvARRAY(protopad);
4257 I32 fname = AvFILLp(protopad_name);
4258 I32 fpad = AvFILLp(protopad);
4262 assert(!CvUNIQUE(proto));
4266 SAVESPTR(PL_comppad_name);
4267 SAVESPTR(PL_compcv);
4269 cv = PL_compcv = (CV*)NEWSV(1104,0);
4270 sv_upgrade((SV *)cv, SvTYPE(proto));
4271 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4275 New(666, CvMUTEXP(cv), 1, perl_mutex);
4276 MUTEX_INIT(CvMUTEXP(cv));
4278 #endif /* USE_THREADS */
4279 CvFILE(cv) = CvFILE(proto);
4280 CvGV(cv) = CvGV(proto);
4281 CvSTASH(cv) = CvSTASH(proto);
4282 CvROOT(cv) = CvROOT(proto);
4283 CvSTART(cv) = CvSTART(proto);
4285 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4288 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4290 PL_comppad_name = newAV();
4291 for (ix = fname; ix >= 0; ix--)
4292 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4294 PL_comppad = newAV();
4296 comppadlist = newAV();
4297 AvREAL_off(comppadlist);
4298 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4299 av_store(comppadlist, 1, (SV*)PL_comppad);
4300 CvPADLIST(cv) = comppadlist;
4301 av_fill(PL_comppad, AvFILLp(protopad));
4302 PL_curpad = AvARRAY(PL_comppad);
4304 av = newAV(); /* will be @_ */
4306 av_store(PL_comppad, 0, (SV*)av);
4307 AvFLAGS(av) = AVf_REIFY;
4309 for (ix = fpad; ix > 0; ix--) {
4310 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4311 if (namesv && namesv != &PL_sv_undef) {
4312 char *name = SvPVX(namesv); /* XXX */
4313 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4314 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4315 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4317 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4319 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4321 else { /* our own lexical */
4324 /* anon code -- we'll come back for it */
4325 sv = SvREFCNT_inc(ppad[ix]);
4327 else if (*name == '@')
4329 else if (*name == '%')
4338 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4339 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4342 SV* sv = NEWSV(0,0);
4348 /* Now that vars are all in place, clone nested closures. */
4350 for (ix = fpad; ix > 0; ix--) {
4351 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4353 && namesv != &PL_sv_undef
4354 && !(SvFLAGS(namesv) & SVf_FAKE)
4355 && *SvPVX(namesv) == '&'
4356 && CvCLONE(ppad[ix]))
4358 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4359 SvREFCNT_dec(ppad[ix]);
4362 PL_curpad[ix] = (SV*)kid;
4366 #ifdef DEBUG_CLOSURES
4367 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4369 PerlIO_printf(Perl_debug_log, " from:\n");
4371 PerlIO_printf(Perl_debug_log, " to:\n");
4378 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4380 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4382 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4389 Perl_cv_clone(pTHX_ CV *proto)
4392 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4393 cv = cv_clone2(proto, CvOUTSIDE(proto));
4394 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4399 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4401 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4402 SV* msg = sv_newmortal();
4406 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4407 sv_setpv(msg, "Prototype mismatch:");
4409 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4411 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4412 sv_catpv(msg, " vs ");
4414 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4416 sv_catpv(msg, "none");
4417 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4421 static void const_sv_xsub(pTHXo_ CV* cv);
4424 =for apidoc cv_const_sv
4426 If C<cv> is a constant sub eligible for inlining. returns the constant
4427 value returned by the sub. Otherwise, returns NULL.
4429 Constant subs can be created with C<newCONSTSUB> or as described in
4430 L<perlsub/"Constant Functions">.
4435 Perl_cv_const_sv(pTHX_ CV *cv)
4437 if (!cv || !CvCONST(cv))
4439 return (SV*)CvXSUBANY(cv).any_ptr;
4443 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4450 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4451 o = cLISTOPo->op_first->op_sibling;
4453 for (; o; o = o->op_next) {
4454 OPCODE type = o->op_type;
4456 if (sv && o->op_next == o)
4458 if (o->op_next != o) {
4459 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4461 if (type == OP_DBSTATE)
4464 if (type == OP_LEAVESUB || type == OP_RETURN)
4468 if (type == OP_CONST && cSVOPo->op_sv)
4470 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4471 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4472 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4476 /* We get here only from cv_clone2() while creating a closure.
4477 Copy the const value here instead of in cv_clone2 so that
4478 SvREADONLY_on doesn't lead to problems when leaving
4483 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4495 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4505 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4509 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4511 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4515 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4521 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4526 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4527 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4528 SV *sv = sv_newmortal();
4529 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4530 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4535 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4536 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4546 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4547 maximum a prototype before. */
4548 if (SvTYPE(gv) > SVt_NULL) {
4549 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4550 && ckWARN_d(WARN_PROTOTYPE))
4552 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4554 cv_ckproto((CV*)gv, NULL, ps);
4557 sv_setpv((SV*)gv, ps);
4559 sv_setiv((SV*)gv, -1);
4560 SvREFCNT_dec(PL_compcv);
4561 cv = PL_compcv = NULL;
4562 PL_sub_generation++;
4566 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4568 #ifdef GV_SHARED_CHECK
4569 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4570 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4574 if (!block || !ps || *ps || attrs)
4577 const_sv = op_const_sv(block, Nullcv);
4580 bool exists = CvROOT(cv) || CvXSUB(cv);
4582 #ifdef GV_SHARED_CHECK
4583 if (exists && GvSHARED(gv)) {
4584 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4588 /* if the subroutine doesn't exist and wasn't pre-declared
4589 * with a prototype, assume it will be AUTOLOADed,
4590 * skipping the prototype check
4592 if (exists || SvPOK(cv))
4593 cv_ckproto(cv, gv, ps);
4594 /* already defined (or promised)? */
4595 if (exists || GvASSUMECV(gv)) {
4596 if (!block && !attrs) {
4597 /* just a "sub foo;" when &foo is already defined */
4598 SAVEFREESV(PL_compcv);
4601 /* ahem, death to those who redefine active sort subs */
4602 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4603 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4605 if (ckWARN(WARN_REDEFINE)
4607 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4609 line_t oldline = CopLINE(PL_curcop);
4610 CopLINE_set(PL_curcop, PL_copline);
4611 Perl_warner(aTHX_ WARN_REDEFINE,
4612 CvCONST(cv) ? "Constant subroutine %s redefined"
4613 : "Subroutine %s redefined", name);
4614 CopLINE_set(PL_curcop, oldline);
4622 SvREFCNT_inc(const_sv);
4624 assert(!CvROOT(cv) && !CvCONST(cv));
4625 sv_setpv((SV*)cv, ""); /* prototype is "" */
4626 CvXSUBANY(cv).any_ptr = const_sv;
4627 CvXSUB(cv) = const_sv_xsub;
4632 cv = newCONSTSUB(NULL, name, const_sv);
4635 SvREFCNT_dec(PL_compcv);
4637 PL_sub_generation++;
4644 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4645 * before we clobber PL_compcv.
4649 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4650 stash = GvSTASH(CvGV(cv));
4651 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4652 stash = CvSTASH(cv);
4654 stash = PL_curstash;
4657 /* possibly about to re-define existing subr -- ignore old cv */
4658 rcv = (SV*)PL_compcv;
4659 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4660 stash = GvSTASH(gv);
4662 stash = PL_curstash;
4664 apply_attrs(stash, rcv, attrs);
4666 if (cv) { /* must reuse cv if autoloaded */
4668 /* got here with just attrs -- work done, so bug out */
4669 SAVEFREESV(PL_compcv);
4673 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4674 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4675 CvOUTSIDE(PL_compcv) = 0;
4676 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4677 CvPADLIST(PL_compcv) = 0;
4678 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4679 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4680 SvREFCNT_dec(PL_compcv);
4687 PL_sub_generation++;
4691 CvFILE(cv) = CopFILE(PL_curcop);
4692 CvSTASH(cv) = PL_curstash;
4695 if (!CvMUTEXP(cv)) {
4696 New(666, CvMUTEXP(cv), 1, perl_mutex);
4697 MUTEX_INIT(CvMUTEXP(cv));
4699 #endif /* USE_THREADS */
4702 sv_setpv((SV*)cv, ps);
4704 if (PL_error_count) {
4708 char *s = strrchr(name, ':');
4710 if (strEQ(s, "BEGIN")) {
4712 "BEGIN not safe after errors--compilation aborted";
4713 if (PL_in_eval & EVAL_KEEPERR)
4714 Perl_croak(aTHX_ not_safe);
4716 /* force display of errors found but not reported */
4717 sv_catpv(ERRSV, not_safe);
4718 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4726 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4727 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4730 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4731 mod(scalarseq(block), OP_LEAVESUBLV));
4734 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4736 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4737 OpREFCNT_set(CvROOT(cv), 1);
4738 CvSTART(cv) = LINKLIST(CvROOT(cv));
4739 CvROOT(cv)->op_next = 0;
4742 /* now that optimizer has done its work, adjust pad values */
4744 SV **namep = AvARRAY(PL_comppad_name);
4745 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4748 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4751 * The only things that a clonable function needs in its
4752 * pad are references to outer lexicals and anonymous subs.
4753 * The rest are created anew during cloning.
4755 if (!((namesv = namep[ix]) != Nullsv &&
4756 namesv != &PL_sv_undef &&
4758 *SvPVX(namesv) == '&')))
4760 SvREFCNT_dec(PL_curpad[ix]);
4761 PL_curpad[ix] = Nullsv;
4764 assert(!CvCONST(cv));
4765 if (ps && !*ps && op_const_sv(block, cv))
4769 AV *av = newAV(); /* Will be @_ */
4771 av_store(PL_comppad, 0, (SV*)av);
4772 AvFLAGS(av) = AVf_REIFY;
4774 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4775 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4777 if (!SvPADMY(PL_curpad[ix]))
4778 SvPADTMP_on(PL_curpad[ix]);
4782 if (name || aname) {
4784 char *tname = (name ? name : aname);
4786 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4787 SV *sv = NEWSV(0,0);
4788 SV *tmpstr = sv_newmortal();
4789 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4793 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4795 (long)PL_subline, (long)CopLINE(PL_curcop));
4796 gv_efullname3(tmpstr, gv, Nullch);
4797 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4798 hv = GvHVn(db_postponed);
4799 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4800 && (pcv = GvCV(db_postponed)))
4806 call_sv((SV*)pcv, G_DISCARD);
4810 if ((s = strrchr(tname,':')))
4815 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4818 if (strEQ(s, "BEGIN")) {
4819 I32 oldscope = PL_scopestack_ix;
4821 SAVECOPFILE(&PL_compiling);
4822 SAVECOPLINE(&PL_compiling);
4824 sv_setsv(PL_rs, PL_nrs);
4827 PL_beginav = newAV();
4828 DEBUG_x( dump_sub(gv) );
4829 av_push(PL_beginav, (SV*)cv);
4830 GvCV(gv) = 0; /* cv has been hijacked */
4831 call_list(oldscope, PL_beginav);
4833 PL_curcop = &PL_compiling;
4834 PL_compiling.op_private = PL_hints;
4837 else if (strEQ(s, "END") && !PL_error_count) {
4840 DEBUG_x( dump_sub(gv) );
4841 av_unshift(PL_endav, 1);
4842 av_store(PL_endav, 0, (SV*)cv);
4843 GvCV(gv) = 0; /* cv has been hijacked */
4845 else if (strEQ(s, "CHECK") && !PL_error_count) {
4847 PL_checkav = newAV();
4848 DEBUG_x( dump_sub(gv) );
4849 if (PL_main_start && ckWARN(WARN_VOID))
4850 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4851 av_unshift(PL_checkav, 1);
4852 av_store(PL_checkav, 0, (SV*)cv);
4853 GvCV(gv) = 0; /* cv has been hijacked */
4855 else if (strEQ(s, "INIT") && !PL_error_count) {
4857 PL_initav = newAV();
4858 DEBUG_x( dump_sub(gv) );
4859 if (PL_main_start && ckWARN(WARN_VOID))
4860 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4861 av_push(PL_initav, (SV*)cv);
4862 GvCV(gv) = 0; /* cv has been hijacked */
4867 PL_copline = NOLINE;
4872 /* XXX unsafe for threads if eval_owner isn't held */
4874 =for apidoc newCONSTSUB
4876 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4877 eligible for inlining at compile-time.
4883 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4889 SAVECOPLINE(PL_curcop);
4890 CopLINE_set(PL_curcop, PL_copline);
4893 PL_hints &= ~HINT_BLOCK_SCOPE;
4896 SAVESPTR(PL_curstash);
4897 SAVECOPSTASH(PL_curcop);
4898 PL_curstash = stash;
4900 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4902 CopSTASH(PL_curcop) = stash;
4906 cv = newXS(name, const_sv_xsub, __FILE__);
4907 CvXSUBANY(cv).any_ptr = sv;
4909 sv_setpv((SV*)cv, ""); /* prototype is "" */
4917 =for apidoc U||newXS
4919 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4925 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4927 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4930 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4932 /* just a cached method */
4936 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4937 /* already defined (or promised) */
4938 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4939 && HvNAME(GvSTASH(CvGV(cv)))
4940 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4941 line_t oldline = CopLINE(PL_curcop);
4942 if (PL_copline != NOLINE)
4943 CopLINE_set(PL_curcop, PL_copline);
4944 Perl_warner(aTHX_ WARN_REDEFINE,
4945 CvCONST(cv) ? "Constant subroutine %s redefined"
4946 : "Subroutine %s redefined"
4948 CopLINE_set(PL_curcop, oldline);
4955 if (cv) /* must reuse cv if autoloaded */
4958 cv = (CV*)NEWSV(1105,0);
4959 sv_upgrade((SV *)cv, SVt_PVCV);
4963 PL_sub_generation++;
4968 New(666, CvMUTEXP(cv), 1, perl_mutex);
4969 MUTEX_INIT(CvMUTEXP(cv));
4971 #endif /* USE_THREADS */
4972 (void)gv_fetchfile(filename);
4973 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4974 an external constant string */
4975 CvXSUB(cv) = subaddr;
4978 char *s = strrchr(name,':');
4984 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4987 if (strEQ(s, "BEGIN")) {
4989 PL_beginav = newAV();
4990 av_push(PL_beginav, (SV*)cv);
4991 GvCV(gv) = 0; /* cv has been hijacked */
4993 else if (strEQ(s, "END")) {
4996 av_unshift(PL_endav, 1);
4997 av_store(PL_endav, 0, (SV*)cv);
4998 GvCV(gv) = 0; /* cv has been hijacked */
5000 else if (strEQ(s, "CHECK")) {
5002 PL_checkav = newAV();
5003 if (PL_main_start && ckWARN(WARN_VOID))
5004 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5005 av_unshift(PL_checkav, 1);
5006 av_store(PL_checkav, 0, (SV*)cv);
5007 GvCV(gv) = 0; /* cv has been hijacked */
5009 else if (strEQ(s, "INIT")) {
5011 PL_initav = newAV();
5012 if (PL_main_start && ckWARN(WARN_VOID))
5013 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5014 av_push(PL_initav, (SV*)cv);
5015 GvCV(gv) = 0; /* cv has been hijacked */
5026 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5035 name = SvPVx(cSVOPo->op_sv, n_a);
5038 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5039 #ifdef GV_SHARED_CHECK
5041 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5045 if ((cv = GvFORM(gv))) {
5046 if (ckWARN(WARN_REDEFINE)) {
5047 line_t oldline = CopLINE(PL_curcop);
5049 CopLINE_set(PL_curcop, PL_copline);
5050 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5051 CopLINE_set(PL_curcop, oldline);
5058 CvFILE(cv) = CopFILE(PL_curcop);
5060 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5061 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5062 SvPADTMP_on(PL_curpad[ix]);
5065 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5066 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5067 OpREFCNT_set(CvROOT(cv), 1);
5068 CvSTART(cv) = LINKLIST(CvROOT(cv));
5069 CvROOT(cv)->op_next = 0;
5072 PL_copline = NOLINE;
5077 Perl_newANONLIST(pTHX_ OP *o)
5079 return newUNOP(OP_REFGEN, 0,
5080 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5084 Perl_newANONHASH(pTHX_ OP *o)
5086 return newUNOP(OP_REFGEN, 0,
5087 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5091 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5093 return newANONATTRSUB(floor, proto, Nullop, block);
5097 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5099 return newUNOP(OP_REFGEN, 0,
5100 newSVOP(OP_ANONCODE, 0,
5101 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5105 Perl_oopsAV(pTHX_ OP *o)
5107 switch (o->op_type) {
5109 o->op_type = OP_PADAV;
5110 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5111 return ref(o, OP_RV2AV);
5114 o->op_type = OP_RV2AV;
5115 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5120 if (ckWARN_d(WARN_INTERNAL))
5121 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5128 Perl_oopsHV(pTHX_ OP *o)
5130 switch (o->op_type) {
5133 o->op_type = OP_PADHV;
5134 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5135 return ref(o, OP_RV2HV);
5139 o->op_type = OP_RV2HV;
5140 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5145 if (ckWARN_d(WARN_INTERNAL))
5146 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5153 Perl_newAVREF(pTHX_ OP *o)
5155 if (o->op_type == OP_PADANY) {
5156 o->op_type = OP_PADAV;
5157 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5160 return newUNOP(OP_RV2AV, 0, scalar(o));
5164 Perl_newGVREF(pTHX_ I32 type, OP *o)
5166 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5167 return newUNOP(OP_NULL, 0, o);
5168 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5172 Perl_newHVREF(pTHX_ OP *o)
5174 if (o->op_type == OP_PADANY) {
5175 o->op_type = OP_PADHV;
5176 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5179 return newUNOP(OP_RV2HV, 0, scalar(o));
5183 Perl_oopsCV(pTHX_ OP *o)
5185 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5191 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5193 return newUNOP(OP_RV2CV, flags, scalar(o));
5197 Perl_newSVREF(pTHX_ OP *o)
5199 if (o->op_type == OP_PADANY) {
5200 o->op_type = OP_PADSV;
5201 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5204 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5205 o->op_flags |= OPpDONE_SVREF;
5208 return newUNOP(OP_RV2SV, 0, scalar(o));
5211 /* Check routines. */
5214 Perl_ck_anoncode(pTHX_ OP *o)
5219 name = NEWSV(1106,0);
5220 sv_upgrade(name, SVt_PVNV);
5221 sv_setpvn(name, "&", 1);
5224 ix = pad_alloc(o->op_type, SVs_PADMY);
5225 av_store(PL_comppad_name, ix, name);
5226 av_store(PL_comppad, ix, cSVOPo->op_sv);
5227 SvPADMY_on(cSVOPo->op_sv);
5228 cSVOPo->op_sv = Nullsv;
5229 cSVOPo->op_targ = ix;
5234 Perl_ck_bitop(pTHX_ OP *o)
5236 o->op_private = PL_hints;
5241 Perl_ck_concat(pTHX_ OP *o)
5243 if (cUNOPo->op_first->op_type == OP_CONCAT)
5244 o->op_flags |= OPf_STACKED;
5249 Perl_ck_spair(pTHX_ OP *o)
5251 if (o->op_flags & OPf_KIDS) {
5254 OPCODE type = o->op_type;
5255 o = modkids(ck_fun(o), type);
5256 kid = cUNOPo->op_first;
5257 newop = kUNOP->op_first->op_sibling;
5259 (newop->op_sibling ||
5260 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5261 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5262 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5266 op_free(kUNOP->op_first);
5267 kUNOP->op_first = newop;
5269 o->op_ppaddr = PL_ppaddr[++o->op_type];
5274 Perl_ck_delete(pTHX_ OP *o)
5278 if (o->op_flags & OPf_KIDS) {
5279 OP *kid = cUNOPo->op_first;
5280 switch (kid->op_type) {
5282 o->op_flags |= OPf_SPECIAL;
5285 o->op_private |= OPpSLICE;
5288 o->op_flags |= OPf_SPECIAL;
5293 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5294 PL_op_desc[o->op_type]);
5302 Perl_ck_eof(pTHX_ OP *o)
5304 I32 type = o->op_type;
5306 if (o->op_flags & OPf_KIDS) {
5307 if (cLISTOPo->op_first->op_type == OP_STUB) {
5309 o = newUNOP(type, OPf_SPECIAL,
5310 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5318 Perl_ck_eval(pTHX_ OP *o)
5320 PL_hints |= HINT_BLOCK_SCOPE;
5321 if (o->op_flags & OPf_KIDS) {
5322 SVOP *kid = (SVOP*)cUNOPo->op_first;
5325 o->op_flags &= ~OPf_KIDS;
5328 else if (kid->op_type == OP_LINESEQ) {
5331 kid->op_next = o->op_next;
5332 cUNOPo->op_first = 0;
5335 NewOp(1101, enter, 1, LOGOP);
5336 enter->op_type = OP_ENTERTRY;
5337 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5338 enter->op_private = 0;
5340 /* establish postfix order */
5341 enter->op_next = (OP*)enter;
5343 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5344 o->op_type = OP_LEAVETRY;
5345 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5346 enter->op_other = o;
5354 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5356 o->op_targ = (PADOFFSET)PL_hints;
5361 Perl_ck_exit(pTHX_ OP *o)
5364 HV *table = GvHV(PL_hintgv);
5366 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5367 if (svp && *svp && SvTRUE(*svp))
5368 o->op_private |= OPpEXIT_VMSISH;
5375 Perl_ck_exec(pTHX_ OP *o)
5378 if (o->op_flags & OPf_STACKED) {
5380 kid = cUNOPo->op_first->op_sibling;
5381 if (kid->op_type == OP_RV2GV)
5390 Perl_ck_exists(pTHX_ OP *o)
5393 if (o->op_flags & OPf_KIDS) {
5394 OP *kid = cUNOPo->op_first;
5395 if (kid->op_type == OP_ENTERSUB) {
5396 (void) ref(kid, o->op_type);
5397 if (kid->op_type != OP_RV2CV && !PL_error_count)
5398 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5399 PL_op_desc[o->op_type]);
5400 o->op_private |= OPpEXISTS_SUB;
5402 else if (kid->op_type == OP_AELEM)
5403 o->op_flags |= OPf_SPECIAL;
5404 else if (kid->op_type != OP_HELEM)
5405 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5406 PL_op_desc[o->op_type]);
5414 Perl_ck_gvconst(pTHX_ register OP *o)
5416 o = fold_constants(o);
5417 if (o->op_type == OP_CONST)
5424 Perl_ck_rvconst(pTHX_ register OP *o)
5426 SVOP *kid = (SVOP*)cUNOPo->op_first;
5428 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5429 if (kid->op_type == OP_CONST) {
5433 SV *kidsv = kid->op_sv;
5436 /* Is it a constant from cv_const_sv()? */
5437 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5438 SV *rsv = SvRV(kidsv);
5439 int svtype = SvTYPE(rsv);
5440 char *badtype = Nullch;
5442 switch (o->op_type) {
5444 if (svtype > SVt_PVMG)
5445 badtype = "a SCALAR";
5448 if (svtype != SVt_PVAV)
5449 badtype = "an ARRAY";
5452 if (svtype != SVt_PVHV) {
5453 if (svtype == SVt_PVAV) { /* pseudohash? */
5454 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5455 if (ksv && SvROK(*ksv)
5456 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5465 if (svtype != SVt_PVCV)
5470 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5473 name = SvPV(kidsv, n_a);
5474 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5475 char *badthing = Nullch;
5476 switch (o->op_type) {
5478 badthing = "a SCALAR";
5481 badthing = "an ARRAY";
5484 badthing = "a HASH";
5489 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5493 * This is a little tricky. We only want to add the symbol if we
5494 * didn't add it in the lexer. Otherwise we get duplicate strict
5495 * warnings. But if we didn't add it in the lexer, we must at
5496 * least pretend like we wanted to add it even if it existed before,
5497 * or we get possible typo warnings. OPpCONST_ENTERED says
5498 * whether the lexer already added THIS instance of this symbol.
5500 iscv = (o->op_type == OP_RV2CV) * 2;
5502 gv = gv_fetchpv(name,
5503 iscv | !(kid->op_private & OPpCONST_ENTERED),
5506 : o->op_type == OP_RV2SV
5508 : o->op_type == OP_RV2AV
5510 : o->op_type == OP_RV2HV
5513 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5515 kid->op_type = OP_GV;
5516 SvREFCNT_dec(kid->op_sv);
5518 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5519 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5520 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5522 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5524 kid->op_sv = SvREFCNT_inc(gv);
5526 kid->op_private = 0;
5527 kid->op_ppaddr = PL_ppaddr[OP_GV];
5534 Perl_ck_ftst(pTHX_ OP *o)
5536 I32 type = o->op_type;
5538 if (o->op_flags & OPf_REF) {
5541 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5542 SVOP *kid = (SVOP*)cUNOPo->op_first;
5544 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5546 OP *newop = newGVOP(type, OPf_REF,
5547 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5554 if (type == OP_FTTTY)
5555 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5558 o = newUNOP(type, 0, newDEFSVOP());
5561 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5563 if (PL_hints & HINT_LOCALE)
5564 o->op_private |= OPpLOCALE;
5571 Perl_ck_fun(pTHX_ OP *o)
5577 int type = o->op_type;
5578 register I32 oa = PL_opargs[type] >> OASHIFT;
5580 if (o->op_flags & OPf_STACKED) {
5581 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5584 return no_fh_allowed(o);
5587 if (o->op_flags & OPf_KIDS) {
5589 tokid = &cLISTOPo->op_first;
5590 kid = cLISTOPo->op_first;
5591 if (kid->op_type == OP_PUSHMARK ||
5592 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5594 tokid = &kid->op_sibling;
5595 kid = kid->op_sibling;
5597 if (!kid && PL_opargs[type] & OA_DEFGV)
5598 *tokid = kid = newDEFSVOP();
5602 sibl = kid->op_sibling;
5605 /* list seen where single (scalar) arg expected? */
5606 if (numargs == 1 && !(oa >> 4)
5607 && kid->op_type == OP_LIST && type != OP_SCALAR)
5609 return too_many_arguments(o,PL_op_desc[type]);
5622 if (kid->op_type == OP_CONST &&
5623 (kid->op_private & OPpCONST_BARE))
5625 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5626 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5627 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5628 if (ckWARN(WARN_DEPRECATED))
5629 Perl_warner(aTHX_ WARN_DEPRECATED,
5630 "Array @%s missing the @ in argument %"IVdf" of %s()",
5631 name, (IV)numargs, PL_op_desc[type]);
5634 kid->op_sibling = sibl;
5637 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5638 bad_type(numargs, "array", PL_op_desc[type], kid);
5642 if (kid->op_type == OP_CONST &&
5643 (kid->op_private & OPpCONST_BARE))
5645 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5646 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5647 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5648 if (ckWARN(WARN_DEPRECATED))
5649 Perl_warner(aTHX_ WARN_DEPRECATED,
5650 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5651 name, (IV)numargs, PL_op_desc[type]);
5654 kid->op_sibling = sibl;
5657 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5658 bad_type(numargs, "hash", PL_op_desc[type], kid);
5663 OP *newop = newUNOP(OP_NULL, 0, kid);
5664 kid->op_sibling = 0;
5666 newop->op_next = newop;
5668 kid->op_sibling = sibl;
5673 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5674 if (kid->op_type == OP_CONST &&
5675 (kid->op_private & OPpCONST_BARE))
5677 OP *newop = newGVOP(OP_GV, 0,
5678 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5683 else if (kid->op_type == OP_READLINE) {
5684 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5685 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5688 I32 flags = OPf_SPECIAL;
5692 /* is this op a FH constructor? */
5693 if (is_handle_constructor(o,numargs)) {
5694 char *name = Nullch;
5698 /* Set a flag to tell rv2gv to vivify
5699 * need to "prove" flag does not mean something
5700 * else already - NI-S 1999/05/07
5703 if (kid->op_type == OP_PADSV) {
5704 SV **namep = av_fetch(PL_comppad_name,
5706 if (namep && *namep)
5707 name = SvPV(*namep, len);
5709 else if (kid->op_type == OP_RV2SV
5710 && kUNOP->op_first->op_type == OP_GV)
5712 GV *gv = cGVOPx_gv(kUNOP->op_first);
5714 len = GvNAMELEN(gv);
5716 else if (kid->op_type == OP_AELEM
5717 || kid->op_type == OP_HELEM)
5719 name = "__ANONIO__";
5725 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5726 namesv = PL_curpad[targ];
5727 (void)SvUPGRADE(namesv, SVt_PV);
5729 sv_setpvn(namesv, "$", 1);
5730 sv_catpvn(namesv, name, len);
5733 kid->op_sibling = 0;
5734 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5735 kid->op_targ = targ;
5736 kid->op_private |= priv;
5738 kid->op_sibling = sibl;
5744 mod(scalar(kid), type);
5748 tokid = &kid->op_sibling;
5749 kid = kid->op_sibling;
5751 o->op_private |= numargs;
5753 return too_many_arguments(o,PL_op_desc[o->op_type]);
5756 else if (PL_opargs[type] & OA_DEFGV) {
5758 return newUNOP(type, 0, newDEFSVOP());
5762 while (oa & OA_OPTIONAL)
5764 if (oa && oa != OA_LIST)
5765 return too_few_arguments(o,PL_op_desc[o->op_type]);
5771 Perl_ck_glob(pTHX_ OP *o)
5776 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5777 append_elem(OP_GLOB, o, newDEFSVOP());
5779 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5780 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5782 #if !defined(PERL_EXTERNAL_GLOB)
5783 /* XXX this can be tightened up and made more failsafe. */
5786 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5787 /* null-terminated import list */
5788 newSVpvn(":globally", 9), Nullsv);
5789 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5792 #endif /* PERL_EXTERNAL_GLOB */
5794 if (gv && GvIMPORTED_CV(gv)) {
5795 append_elem(OP_GLOB, o,
5796 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5797 o->op_type = OP_LIST;
5798 o->op_ppaddr = PL_ppaddr[OP_LIST];
5799 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5800 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5801 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5802 append_elem(OP_LIST, o,
5803 scalar(newUNOP(OP_RV2CV, 0,
5804 newGVOP(OP_GV, 0, gv)))));
5805 o = newUNOP(OP_NULL, 0, ck_subr(o));
5806 o->op_targ = OP_GLOB; /* hint at what it used to be */
5809 gv = newGVgen("main");
5811 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5817 Perl_ck_grep(pTHX_ OP *o)
5821 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5823 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5824 NewOp(1101, gwop, 1, LOGOP);
5826 if (o->op_flags & OPf_STACKED) {
5829 kid = cLISTOPo->op_first->op_sibling;
5830 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5833 kid->op_next = (OP*)gwop;
5834 o->op_flags &= ~OPf_STACKED;
5836 kid = cLISTOPo->op_first->op_sibling;
5837 if (type == OP_MAPWHILE)
5844 kid = cLISTOPo->op_first->op_sibling;
5845 if (kid->op_type != OP_NULL)
5846 Perl_croak(aTHX_ "panic: ck_grep");
5847 kid = kUNOP->op_first;
5849 gwop->op_type = type;
5850 gwop->op_ppaddr = PL_ppaddr[type];
5851 gwop->op_first = listkids(o);
5852 gwop->op_flags |= OPf_KIDS;
5853 gwop->op_private = 1;
5854 gwop->op_other = LINKLIST(kid);
5855 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5856 kid->op_next = (OP*)gwop;
5858 kid = cLISTOPo->op_first->op_sibling;
5859 if (!kid || !kid->op_sibling)
5860 return too_few_arguments(o,PL_op_desc[o->op_type]);
5861 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5862 mod(kid, OP_GREPSTART);
5868 Perl_ck_index(pTHX_ OP *o)
5870 if (o->op_flags & OPf_KIDS) {
5871 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5873 kid = kid->op_sibling; /* get past "big" */
5874 if (kid && kid->op_type == OP_CONST)
5875 fbm_compile(((SVOP*)kid)->op_sv, 0);
5881 Perl_ck_lengthconst(pTHX_ OP *o)
5883 /* XXX length optimization goes here */
5888 Perl_ck_lfun(pTHX_ OP *o)
5890 OPCODE type = o->op_type;
5891 return modkids(ck_fun(o), type);
5895 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5897 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5898 switch (cUNOPo->op_first->op_type) {
5900 /* This is needed for
5901 if (defined %stash::)
5902 to work. Do not break Tk.
5904 break; /* Globals via GV can be undef */
5906 case OP_AASSIGN: /* Is this a good idea? */
5907 Perl_warner(aTHX_ WARN_DEPRECATED,
5908 "defined(@array) is deprecated");
5909 Perl_warner(aTHX_ WARN_DEPRECATED,
5910 "\t(Maybe you should just omit the defined()?)\n");
5913 /* This is needed for
5914 if (defined %stash::)
5915 to work. Do not break Tk.
5917 break; /* Globals via GV can be undef */
5919 Perl_warner(aTHX_ WARN_DEPRECATED,
5920 "defined(%%hash) is deprecated");
5921 Perl_warner(aTHX_ WARN_DEPRECATED,
5922 "\t(Maybe you should just omit the defined()?)\n");
5933 Perl_ck_rfun(pTHX_ OP *o)
5935 OPCODE type = o->op_type;
5936 return refkids(ck_fun(o), type);
5940 Perl_ck_listiob(pTHX_ OP *o)
5944 kid = cLISTOPo->op_first;
5947 kid = cLISTOPo->op_first;
5949 if (kid->op_type == OP_PUSHMARK)
5950 kid = kid->op_sibling;
5951 if (kid && o->op_flags & OPf_STACKED)
5952 kid = kid->op_sibling;
5953 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5954 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5955 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5956 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5957 cLISTOPo->op_first->op_sibling = kid;
5958 cLISTOPo->op_last = kid;
5959 kid = kid->op_sibling;
5964 append_elem(o->op_type, o, newDEFSVOP());
5970 if (PL_hints & HINT_LOCALE)
5971 o->op_private |= OPpLOCALE;
5978 Perl_ck_fun_locale(pTHX_ OP *o)
5984 if (PL_hints & HINT_LOCALE)
5985 o->op_private |= OPpLOCALE;
5992 Perl_ck_sassign(pTHX_ OP *o)
5994 OP *kid = cLISTOPo->op_first;
5995 /* has a disposable target? */
5996 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5997 && !(kid->op_flags & OPf_STACKED)
5998 /* Cannot steal the second time! */
5999 && !(kid->op_private & OPpTARGET_MY))
6001 OP *kkid = kid->op_sibling;
6003 /* Can just relocate the target. */
6004 if (kkid && kkid->op_type == OP_PADSV
6005 && !(kkid->op_private & OPpLVAL_INTRO))
6007 kid->op_targ = kkid->op_targ;
6009 /* Now we do not need PADSV and SASSIGN. */
6010 kid->op_sibling = o->op_sibling; /* NULL */
6011 cLISTOPo->op_first = NULL;
6014 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6022 Perl_ck_scmp(pTHX_ OP *o)
6026 if (PL_hints & HINT_LOCALE)
6027 o->op_private |= OPpLOCALE;
6034 Perl_ck_match(pTHX_ OP *o)
6036 o->op_private |= OPpRUNTIME;
6041 Perl_ck_method(pTHX_ OP *o)
6043 OP *kid = cUNOPo->op_first;
6044 if (kid->op_type == OP_CONST) {
6045 SV* sv = kSVOP->op_sv;
6046 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6048 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6049 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6052 kSVOP->op_sv = Nullsv;
6054 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6063 Perl_ck_null(pTHX_ OP *o)
6069 Perl_ck_open(pTHX_ OP *o)
6071 HV *table = GvHV(PL_hintgv);
6075 svp = hv_fetch(table, "open_IN", 7, FALSE);
6077 mode = mode_from_discipline(*svp);
6078 if (mode & O_BINARY)
6079 o->op_private |= OPpOPEN_IN_RAW;
6080 else if (mode & O_TEXT)
6081 o->op_private |= OPpOPEN_IN_CRLF;
6084 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6086 mode = mode_from_discipline(*svp);
6087 if (mode & O_BINARY)
6088 o->op_private |= OPpOPEN_OUT_RAW;
6089 else if (mode & O_TEXT)
6090 o->op_private |= OPpOPEN_OUT_CRLF;
6093 if (o->op_type == OP_BACKTICK)
6099 Perl_ck_repeat(pTHX_ OP *o)
6101 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6102 o->op_private |= OPpREPEAT_DOLIST;
6103 cBINOPo->op_first = force_list(cBINOPo->op_first);
6111 Perl_ck_require(pTHX_ OP *o)
6113 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6114 SVOP *kid = (SVOP*)cUNOPo->op_first;
6116 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6118 for (s = SvPVX(kid->op_sv); *s; s++) {
6119 if (*s == ':' && s[1] == ':') {
6121 Move(s+2, s+1, strlen(s+2)+1, char);
6122 --SvCUR(kid->op_sv);
6125 if (SvREADONLY(kid->op_sv)) {
6126 SvREADONLY_off(kid->op_sv);
6127 sv_catpvn(kid->op_sv, ".pm", 3);
6128 SvREADONLY_on(kid->op_sv);
6131 sv_catpvn(kid->op_sv, ".pm", 3);
6138 Perl_ck_return(pTHX_ OP *o)
6141 if (CvLVALUE(PL_compcv)) {
6142 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6143 mod(kid, OP_LEAVESUBLV);
6150 Perl_ck_retarget(pTHX_ OP *o)
6152 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6159 Perl_ck_select(pTHX_ OP *o)
6162 if (o->op_flags & OPf_KIDS) {
6163 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6164 if (kid && kid->op_sibling) {
6165 o->op_type = OP_SSELECT;
6166 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6168 return fold_constants(o);
6172 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6173 if (kid && kid->op_type == OP_RV2GV)
6174 kid->op_private &= ~HINT_STRICT_REFS;
6179 Perl_ck_shift(pTHX_ OP *o)
6181 I32 type = o->op_type;
6183 if (!(o->op_flags & OPf_KIDS)) {
6188 if (!CvUNIQUE(PL_compcv)) {
6189 argop = newOP(OP_PADAV, OPf_REF);
6190 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6193 argop = newUNOP(OP_RV2AV, 0,
6194 scalar(newGVOP(OP_GV, 0,
6195 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6198 argop = newUNOP(OP_RV2AV, 0,
6199 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6200 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6201 #endif /* USE_THREADS */
6202 return newUNOP(type, 0, scalar(argop));
6204 return scalar(modkids(ck_fun(o), type));
6208 Perl_ck_sort(pTHX_ OP *o)
6213 if (PL_hints & HINT_LOCALE)
6214 o->op_private |= OPpLOCALE;
6217 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6219 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6220 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6222 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6224 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6226 if (kid->op_type == OP_SCOPE) {
6230 else if (kid->op_type == OP_LEAVE) {
6231 if (o->op_type == OP_SORT) {
6232 null(kid); /* wipe out leave */
6235 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6236 if (k->op_next == kid)
6238 /* don't descend into loops */
6239 else if (k->op_type == OP_ENTERLOOP
6240 || k->op_type == OP_ENTERITER)
6242 k = cLOOPx(k)->op_lastop;
6247 kid->op_next = 0; /* just disconnect the leave */
6248 k = kLISTOP->op_first;
6253 if (o->op_type == OP_SORT) {
6254 /* provide scalar context for comparison function/block */
6260 o->op_flags |= OPf_SPECIAL;
6262 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6265 firstkid = firstkid->op_sibling;
6268 /* provide list context for arguments */
6269 if (o->op_type == OP_SORT)
6276 S_simplify_sort(pTHX_ OP *o)
6278 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6282 if (!(o->op_flags & OPf_STACKED))
6284 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6285 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6286 kid = kUNOP->op_first; /* get past null */
6287 if (kid->op_type != OP_SCOPE)
6289 kid = kLISTOP->op_last; /* get past scope */
6290 switch(kid->op_type) {
6298 k = kid; /* remember this node*/
6299 if (kBINOP->op_first->op_type != OP_RV2SV)
6301 kid = kBINOP->op_first; /* get past cmp */
6302 if (kUNOP->op_first->op_type != OP_GV)
6304 kid = kUNOP->op_first; /* get past rv2sv */
6306 if (GvSTASH(gv) != PL_curstash)
6308 if (strEQ(GvNAME(gv), "a"))
6310 else if (strEQ(GvNAME(gv), "b"))
6314 kid = k; /* back to cmp */
6315 if (kBINOP->op_last->op_type != OP_RV2SV)
6317 kid = kBINOP->op_last; /* down to 2nd arg */
6318 if (kUNOP->op_first->op_type != OP_GV)
6320 kid = kUNOP->op_first; /* get past rv2sv */
6322 if (GvSTASH(gv) != PL_curstash
6324 ? strNE(GvNAME(gv), "a")
6325 : strNE(GvNAME(gv), "b")))
6327 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6329 o->op_private |= OPpSORT_REVERSE;
6330 if (k->op_type == OP_NCMP)
6331 o->op_private |= OPpSORT_NUMERIC;
6332 if (k->op_type == OP_I_NCMP)
6333 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6334 kid = cLISTOPo->op_first->op_sibling;
6335 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6336 op_free(kid); /* then delete it */
6340 Perl_ck_split(pTHX_ OP *o)
6344 if (o->op_flags & OPf_STACKED)
6345 return no_fh_allowed(o);
6347 kid = cLISTOPo->op_first;
6348 if (kid->op_type != OP_NULL)
6349 Perl_croak(aTHX_ "panic: ck_split");
6350 kid = kid->op_sibling;
6351 op_free(cLISTOPo->op_first);
6352 cLISTOPo->op_first = kid;
6354 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6355 cLISTOPo->op_last = kid; /* There was only one element previously */
6358 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6359 OP *sibl = kid->op_sibling;
6360 kid->op_sibling = 0;
6361 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6362 if (cLISTOPo->op_first == cLISTOPo->op_last)
6363 cLISTOPo->op_last = kid;
6364 cLISTOPo->op_first = kid;
6365 kid->op_sibling = sibl;
6368 kid->op_type = OP_PUSHRE;
6369 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6372 if (!kid->op_sibling)
6373 append_elem(OP_SPLIT, o, newDEFSVOP());
6375 kid = kid->op_sibling;
6378 if (!kid->op_sibling)
6379 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6381 kid = kid->op_sibling;
6384 if (kid->op_sibling)
6385 return too_many_arguments(o,PL_op_desc[o->op_type]);
6391 Perl_ck_join(pTHX_ OP *o)
6393 if (ckWARN(WARN_SYNTAX)) {
6394 OP *kid = cLISTOPo->op_first->op_sibling;
6395 if (kid && kid->op_type == OP_MATCH) {
6396 char *pmstr = "STRING";
6397 if (kPMOP->op_pmregexp)
6398 pmstr = kPMOP->op_pmregexp->precomp;
6399 Perl_warner(aTHX_ WARN_SYNTAX,
6400 "/%s/ should probably be written as \"%s\"",
6408 Perl_ck_subr(pTHX_ OP *o)
6410 OP *prev = ((cUNOPo->op_first->op_sibling)
6411 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6412 OP *o2 = prev->op_sibling;
6421 o->op_private |= OPpENTERSUB_HASTARG;
6422 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6423 if (cvop->op_type == OP_RV2CV) {
6425 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6426 null(cvop); /* disable rv2cv */
6427 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6428 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6429 GV *gv = cGVOPx_gv(tmpop);
6432 tmpop->op_private |= OPpEARLY_CV;
6433 else if (SvPOK(cv)) {
6434 namegv = CvANON(cv) ? gv : CvGV(cv);
6435 proto = SvPV((SV*)cv, n_a);
6439 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6440 if (o2->op_type == OP_CONST)
6441 o2->op_private &= ~OPpCONST_STRICT;
6442 else if (o2->op_type == OP_LIST) {
6443 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6444 if (o && o->op_type == OP_CONST)
6445 o->op_private &= ~OPpCONST_STRICT;
6448 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6449 if (PERLDB_SUB && PL_curstash != PL_debstash)
6450 o->op_private |= OPpENTERSUB_DB;
6451 while (o2 != cvop) {
6455 return too_many_arguments(o, gv_ename(namegv));
6473 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6475 arg == 1 ? "block or sub {}" : "sub {}",
6476 gv_ename(namegv), o2);
6479 /* '*' allows any scalar type, including bareword */
6482 if (o2->op_type == OP_RV2GV)
6483 goto wrapref; /* autoconvert GLOB -> GLOBref */
6484 else if (o2->op_type == OP_CONST)
6485 o2->op_private &= ~OPpCONST_STRICT;
6486 else if (o2->op_type == OP_ENTERSUB) {
6487 /* accidental subroutine, revert to bareword */
6488 OP *gvop = ((UNOP*)o2)->op_first;
6489 if (gvop && gvop->op_type == OP_NULL) {
6490 gvop = ((UNOP*)gvop)->op_first;
6492 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6495 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6496 (gvop = ((UNOP*)gvop)->op_first) &&
6497 gvop->op_type == OP_GV)
6499 GV *gv = cGVOPx_gv(gvop);
6500 OP *sibling = o2->op_sibling;
6501 SV *n = newSVpvn("",0);
6503 gv_fullname3(n, gv, "");
6504 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6505 sv_chop(n, SvPVX(n)+6);
6506 o2 = newSVOP(OP_CONST, 0, n);
6507 prev->op_sibling = o2;
6508 o2->op_sibling = sibling;
6520 if (o2->op_type != OP_RV2GV)
6521 bad_type(arg, "symbol", gv_ename(namegv), o2);
6524 if (o2->op_type != OP_ENTERSUB)
6525 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6528 if (o2->op_type != OP_RV2SV
6529 && o2->op_type != OP_PADSV
6530 && o2->op_type != OP_HELEM
6531 && o2->op_type != OP_AELEM
6532 && o2->op_type != OP_THREADSV)
6534 bad_type(arg, "scalar", gv_ename(namegv), o2);
6538 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6539 bad_type(arg, "array", gv_ename(namegv), o2);
6542 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6543 bad_type(arg, "hash", gv_ename(namegv), o2);
6547 OP* sib = kid->op_sibling;
6548 kid->op_sibling = 0;
6549 o2 = newUNOP(OP_REFGEN, 0, kid);
6550 o2->op_sibling = sib;
6551 prev->op_sibling = o2;
6562 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6563 gv_ename(namegv), SvPV((SV*)cv, n_a));
6568 mod(o2, OP_ENTERSUB);
6570 o2 = o2->op_sibling;
6572 if (proto && !optional &&
6573 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6574 return too_few_arguments(o, gv_ename(namegv));
6579 Perl_ck_svconst(pTHX_ OP *o)
6581 SvREADONLY_on(cSVOPo->op_sv);
6586 Perl_ck_trunc(pTHX_ OP *o)
6588 if (o->op_flags & OPf_KIDS) {
6589 SVOP *kid = (SVOP*)cUNOPo->op_first;
6591 if (kid->op_type == OP_NULL)
6592 kid = (SVOP*)kid->op_sibling;
6593 if (kid && kid->op_type == OP_CONST &&
6594 (kid->op_private & OPpCONST_BARE))
6596 o->op_flags |= OPf_SPECIAL;
6597 kid->op_private &= ~OPpCONST_STRICT;
6604 Perl_ck_substr(pTHX_ OP *o)
6607 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6608 OP *kid = cLISTOPo->op_first;
6610 if (kid->op_type == OP_NULL)
6611 kid = kid->op_sibling;
6613 kid->op_flags |= OPf_MOD;
6619 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6622 Perl_peep(pTHX_ register OP *o)
6624 register OP* oldop = 0;
6627 if (!o || o->op_seq)
6631 SAVEVPTR(PL_curcop);
6632 for (; o; o = o->op_next) {
6638 switch (o->op_type) {
6642 PL_curcop = ((COP*)o); /* for warnings */
6643 o->op_seq = PL_op_seqmax++;
6647 if (cSVOPo->op_private & OPpCONST_STRICT)
6648 no_bareword_allowed(o);
6650 /* Relocate sv to the pad for thread safety.
6651 * Despite being a "constant", the SV is written to,
6652 * for reference counts, sv_upgrade() etc. */
6654 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6655 if (SvPADTMP(cSVOPo->op_sv)) {
6656 /* If op_sv is already a PADTMP then it is being used by
6657 * some pad, so make a copy. */
6658 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6659 SvREADONLY_on(PL_curpad[ix]);
6660 SvREFCNT_dec(cSVOPo->op_sv);
6663 SvREFCNT_dec(PL_curpad[ix]);
6664 SvPADTMP_on(cSVOPo->op_sv);
6665 PL_curpad[ix] = cSVOPo->op_sv;
6666 /* XXX I don't know how this isn't readonly already. */
6667 SvREADONLY_on(PL_curpad[ix]);
6669 cSVOPo->op_sv = Nullsv;
6673 o->op_seq = PL_op_seqmax++;
6677 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6678 if (o->op_next->op_private & OPpTARGET_MY) {
6679 if (o->op_flags & OPf_STACKED) /* chained concats */
6680 goto ignore_optimization;
6682 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6683 o->op_targ = o->op_next->op_targ;
6684 o->op_next->op_targ = 0;
6685 o->op_private |= OPpTARGET_MY;
6690 ignore_optimization:
6691 o->op_seq = PL_op_seqmax++;
6694 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6695 o->op_seq = PL_op_seqmax++;
6696 break; /* Scalar stub must produce undef. List stub is noop */
6700 if (o->op_targ == OP_NEXTSTATE
6701 || o->op_targ == OP_DBSTATE
6702 || o->op_targ == OP_SETSTATE)
6704 PL_curcop = ((COP*)o);
6711 if (oldop && o->op_next) {
6712 oldop->op_next = o->op_next;
6715 o->op_seq = PL_op_seqmax++;
6719 if (o->op_next->op_type == OP_RV2SV) {
6720 if (!(o->op_next->op_private & OPpDEREF)) {
6722 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6724 o->op_next = o->op_next->op_next;
6725 o->op_type = OP_GVSV;
6726 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6729 else if (o->op_next->op_type == OP_RV2AV) {
6730 OP* pop = o->op_next->op_next;
6732 if (pop->op_type == OP_CONST &&
6733 (PL_op = pop->op_next) &&
6734 pop->op_next->op_type == OP_AELEM &&
6735 !(pop->op_next->op_private &
6736 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6737 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6745 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6746 o->op_next = pop->op_next->op_next;
6747 o->op_type = OP_AELEMFAST;
6748 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6749 o->op_private = (U8)i;
6754 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6756 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6757 /* XXX could check prototype here instead of just carping */
6758 SV *sv = sv_newmortal();
6759 gv_efullname3(sv, gv, Nullch);
6760 Perl_warner(aTHX_ WARN_PROTOTYPE,
6761 "%s() called too early to check prototype",
6766 o->op_seq = PL_op_seqmax++;
6777 o->op_seq = PL_op_seqmax++;
6778 while (cLOGOP->op_other->op_type == OP_NULL)
6779 cLOGOP->op_other = cLOGOP->op_other->op_next;
6780 peep(cLOGOP->op_other);
6784 o->op_seq = PL_op_seqmax++;
6785 while (cLOOP->op_redoop->op_type == OP_NULL)
6786 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6787 peep(cLOOP->op_redoop);
6788 while (cLOOP->op_nextop->op_type == OP_NULL)
6789 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6790 peep(cLOOP->op_nextop);
6791 while (cLOOP->op_lastop->op_type == OP_NULL)
6792 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6793 peep(cLOOP->op_lastop);
6799 o->op_seq = PL_op_seqmax++;
6800 while (cPMOP->op_pmreplstart &&
6801 cPMOP->op_pmreplstart->op_type == OP_NULL)
6802 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6803 peep(cPMOP->op_pmreplstart);
6807 o->op_seq = PL_op_seqmax++;
6808 if (ckWARN(WARN_SYNTAX) && o->op_next
6809 && o->op_next->op_type == OP_NEXTSTATE) {
6810 if (o->op_next->op_sibling &&
6811 o->op_next->op_sibling->op_type != OP_EXIT &&
6812 o->op_next->op_sibling->op_type != OP_WARN &&
6813 o->op_next->op_sibling->op_type != OP_DIE) {
6814 line_t oldline = CopLINE(PL_curcop);
6816 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6817 Perl_warner(aTHX_ WARN_EXEC,
6818 "Statement unlikely to be reached");
6819 Perl_warner(aTHX_ WARN_EXEC,
6820 "\t(Maybe you meant system() when you said exec()?)\n");
6821 CopLINE_set(PL_curcop, oldline);
6830 SV **svp, **indsvp, *sv;
6835 o->op_seq = PL_op_seqmax++;
6837 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6840 /* Make the CONST have a shared SV */
6841 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6842 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6843 key = SvPV(sv, keylen);
6846 lexname = newSVpvn_share(key, keylen, 0);
6851 if ((o->op_private & (OPpLVAL_INTRO)))
6854 rop = (UNOP*)((BINOP*)o)->op_first;
6855 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6857 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6858 if (!SvOBJECT(lexname))
6860 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6861 if (!fields || !GvHV(*fields))
6863 key = SvPV(*svp, keylen);
6866 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6868 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6869 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6871 ind = SvIV(*indsvp);
6873 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6874 rop->op_type = OP_RV2AV;
6875 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6876 o->op_type = OP_AELEM;
6877 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6879 if (SvREADONLY(*svp))
6881 SvFLAGS(sv) |= (SvFLAGS(*svp)
6882 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6892 SV **svp, **indsvp, *sv;
6896 SVOP *first_key_op, *key_op;
6898 o->op_seq = PL_op_seqmax++;
6899 if ((o->op_private & (OPpLVAL_INTRO))
6900 /* I bet there's always a pushmark... */
6901 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6902 /* hmmm, no optimization if list contains only one key. */
6904 rop = (UNOP*)((LISTOP*)o)->op_last;
6905 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6907 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6908 if (!SvOBJECT(lexname))
6910 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6911 if (!fields || !GvHV(*fields))
6913 /* Again guessing that the pushmark can be jumped over.... */
6914 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6915 ->op_first->op_sibling;
6916 /* Check that the key list contains only constants. */
6917 for (key_op = first_key_op; key_op;
6918 key_op = (SVOP*)key_op->op_sibling)
6919 if (key_op->op_type != OP_CONST)
6923 rop->op_type = OP_RV2AV;
6924 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6925 o->op_type = OP_ASLICE;
6926 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6927 for (key_op = first_key_op; key_op;
6928 key_op = (SVOP*)key_op->op_sibling) {
6929 svp = cSVOPx_svp(key_op);
6930 key = SvPV(*svp, keylen);
6933 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6935 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6936 "in variable %s of type %s",
6937 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6939 ind = SvIV(*indsvp);
6941 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6943 if (SvREADONLY(*svp))
6945 SvFLAGS(sv) |= (SvFLAGS(*svp)
6946 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6954 o->op_seq = PL_op_seqmax++;
6964 /* Efficient sub that returns a constant scalar value. */
6966 const_sv_xsub(pTHXo_ CV* cv)
6971 Perl_croak(aTHX_ "usage: %s::%s()",
6972 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6976 ST(0) = (SV*)XSANY.any_ptr;