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)
2406 if (!o || o->op_type != OP_LIST)
2407 o = newLISTOP(OP_LIST, 0, o, Nullop);
2409 o->op_flags &= ~OPf_WANT;
2411 if (!(PL_opargs[type] & OA_MARK))
2412 null(cLISTOPo->op_first);
2415 o->op_ppaddr = PL_ppaddr[type];
2416 o->op_flags |= flags;
2418 o = CHECKOP(type, o);
2419 if (o->op_type != type)
2422 return fold_constants(o);
2425 /* List constructors */
2428 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2436 if (first->op_type != type
2437 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2439 return newLISTOP(type, 0, first, last);
2442 if (first->op_flags & OPf_KIDS)
2443 ((LISTOP*)first)->op_last->op_sibling = last;
2445 first->op_flags |= OPf_KIDS;
2446 ((LISTOP*)first)->op_first = last;
2448 ((LISTOP*)first)->op_last = last;
2453 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2461 if (first->op_type != type)
2462 return prepend_elem(type, (OP*)first, (OP*)last);
2464 if (last->op_type != type)
2465 return append_elem(type, (OP*)first, (OP*)last);
2467 first->op_last->op_sibling = last->op_first;
2468 first->op_last = last->op_last;
2469 first->op_flags |= (last->op_flags & OPf_KIDS);
2471 #ifdef PL_OP_SLAB_ALLOC
2479 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2487 if (last->op_type == type) {
2488 if (type == OP_LIST) { /* already a PUSHMARK there */
2489 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2490 ((LISTOP*)last)->op_first->op_sibling = first;
2491 if (!(first->op_flags & OPf_PARENS))
2492 last->op_flags &= ~OPf_PARENS;
2495 if (!(last->op_flags & OPf_KIDS)) {
2496 ((LISTOP*)last)->op_last = first;
2497 last->op_flags |= OPf_KIDS;
2499 first->op_sibling = ((LISTOP*)last)->op_first;
2500 ((LISTOP*)last)->op_first = first;
2502 last->op_flags |= OPf_KIDS;
2506 return newLISTOP(type, 0, first, last);
2512 Perl_newNULLLIST(pTHX)
2514 return newOP(OP_STUB, 0);
2518 Perl_force_list(pTHX_ OP *o)
2520 if (!o || o->op_type != OP_LIST)
2521 o = newLISTOP(OP_LIST, 0, o, Nullop);
2527 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2531 NewOp(1101, listop, 1, LISTOP);
2533 listop->op_type = type;
2534 listop->op_ppaddr = PL_ppaddr[type];
2537 listop->op_flags = flags;
2541 else if (!first && last)
2544 first->op_sibling = last;
2545 listop->op_first = first;
2546 listop->op_last = last;
2547 if (type == OP_LIST) {
2549 pushop = newOP(OP_PUSHMARK, 0);
2550 pushop->op_sibling = first;
2551 listop->op_first = pushop;
2552 listop->op_flags |= OPf_KIDS;
2554 listop->op_last = pushop;
2561 Perl_newOP(pTHX_ I32 type, I32 flags)
2564 NewOp(1101, o, 1, OP);
2566 o->op_ppaddr = PL_ppaddr[type];
2567 o->op_flags = flags;
2570 o->op_private = 0 + (flags >> 8);
2571 if (PL_opargs[type] & OA_RETSCALAR)
2573 if (PL_opargs[type] & OA_TARGET)
2574 o->op_targ = pad_alloc(type, SVs_PADTMP);
2575 return CHECKOP(type, o);
2579 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2584 first = newOP(OP_STUB, 0);
2585 if (PL_opargs[type] & OA_MARK)
2586 first = force_list(first);
2588 NewOp(1101, unop, 1, UNOP);
2589 unop->op_type = type;
2590 unop->op_ppaddr = PL_ppaddr[type];
2591 unop->op_first = first;
2592 unop->op_flags = flags | OPf_KIDS;
2593 unop->op_private = 1 | (flags >> 8);
2594 unop = (UNOP*) CHECKOP(type, unop);
2598 return fold_constants((OP *) unop);
2602 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2605 NewOp(1101, binop, 1, BINOP);
2608 first = newOP(OP_NULL, 0);
2610 binop->op_type = type;
2611 binop->op_ppaddr = PL_ppaddr[type];
2612 binop->op_first = first;
2613 binop->op_flags = flags | OPf_KIDS;
2616 binop->op_private = 1 | (flags >> 8);
2619 binop->op_private = 2 | (flags >> 8);
2620 first->op_sibling = last;
2623 binop = (BINOP*)CHECKOP(type, binop);
2624 if (binop->op_next || binop->op_type != type)
2627 binop->op_last = binop->op_first->op_sibling;
2629 return fold_constants((OP *)binop);
2633 utf8compare(const void *a, const void *b)
2636 for (i = 0; i < 10; i++) {
2637 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2639 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2646 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2648 SV *tstr = ((SVOP*)expr)->op_sv;
2649 SV *rstr = ((SVOP*)repl)->op_sv;
2652 U8 *t = (U8*)SvPV(tstr, tlen);
2653 U8 *r = (U8*)SvPV(rstr, rlen);
2660 register short *tbl;
2662 complement = o->op_private & OPpTRANS_COMPLEMENT;
2663 del = o->op_private & OPpTRANS_DELETE;
2664 squash = o->op_private & OPpTRANS_SQUASH;
2667 o->op_private |= OPpTRANS_FROM_UTF;
2670 o->op_private |= OPpTRANS_TO_UTF;
2672 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2673 SV* listsv = newSVpvn("# comment\n",10);
2675 U8* tend = t + tlen;
2676 U8* rend = r + rlen;
2690 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2691 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2692 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2693 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2696 U8 tmpbuf[UTF8_MAXLEN+1];
2700 New(1109, cp, tlen, U8*);
2702 transv = newSVpvn("",0);
2706 if (t < tend && *t == 0xff) {
2711 qsort(cp, i, sizeof(U8*), utf8compare);
2712 for (j = 0; j < i; j++) {
2714 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2715 UV val = utf8_to_uv(s, cur, &ulen, 0);
2717 diff = val - nextmin;
2719 t = uv_to_utf8(tmpbuf,nextmin);
2720 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2722 t = uv_to_utf8(tmpbuf, val - 1);
2723 sv_catpvn(transv, "\377", 1);
2724 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2727 if (s < tend && *s == 0xff)
2728 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2732 t = uv_to_utf8(tmpbuf,nextmin);
2733 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2734 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2735 sv_catpvn(transv, "\377", 1);
2736 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2737 t = (U8*)SvPVX(transv);
2738 tlen = SvCUR(transv);
2742 else if (!rlen && !del) {
2743 r = t; rlen = tlen; rend = tend;
2747 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2749 o->op_private |= OPpTRANS_IDENTICAL;
2753 while (t < tend || tfirst <= tlast) {
2754 /* see if we need more "t" chars */
2755 if (tfirst > tlast) {
2756 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2758 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2760 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2767 /* now see if we need more "r" chars */
2768 if (rfirst > rlast) {
2770 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2772 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2774 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2783 rfirst = rlast = 0xffffffff;
2787 /* now see which range will peter our first, if either. */
2788 tdiff = tlast - tfirst;
2789 rdiff = rlast - rfirst;
2796 if (rfirst == 0xffffffff) {
2797 diff = tdiff; /* oops, pretend rdiff is infinite */
2799 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2800 (long)tfirst, (long)tlast);
2802 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2806 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2807 (long)tfirst, (long)(tfirst + diff),
2810 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2811 (long)tfirst, (long)rfirst);
2813 if (rfirst + diff > max)
2814 max = rfirst + diff;
2817 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2828 else if (max > 0xff)
2833 Safefree(cPVOPo->op_pv);
2834 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2835 SvREFCNT_dec(listsv);
2837 SvREFCNT_dec(transv);
2839 if (!del && havefinal)
2840 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2841 newSVuv((UV)final), 0);
2844 o->op_private |= OPpTRANS_GROWS;
2856 tbl = (short*)cPVOPo->op_pv;
2858 Zero(tbl, 256, short);
2859 for (i = 0; i < tlen; i++)
2861 for (i = 0, j = 0; i < 256; i++) {
2872 if (i < 128 && r[j] >= 128)
2880 if (!rlen && !del) {
2883 o->op_private |= OPpTRANS_IDENTICAL;
2885 for (i = 0; i < 256; i++)
2887 for (i = 0, j = 0; i < tlen; i++,j++) {
2890 if (tbl[t[i]] == -1)
2896 if (tbl[t[i]] == -1) {
2897 if (t[i] < 128 && r[j] >= 128)
2904 o->op_private |= OPpTRANS_GROWS;
2912 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2916 NewOp(1101, pmop, 1, PMOP);
2917 pmop->op_type = type;
2918 pmop->op_ppaddr = PL_ppaddr[type];
2919 pmop->op_flags = flags;
2920 pmop->op_private = 0 | (flags >> 8);
2922 if (PL_hints & HINT_RE_TAINT)
2923 pmop->op_pmpermflags |= PMf_RETAINT;
2924 if (PL_hints & HINT_LOCALE)
2925 pmop->op_pmpermflags |= PMf_LOCALE;
2926 pmop->op_pmflags = pmop->op_pmpermflags;
2928 /* link into pm list */
2929 if (type != OP_TRANS && PL_curstash) {
2930 pmop->op_pmnext = HvPMROOT(PL_curstash);
2931 HvPMROOT(PL_curstash) = pmop;
2938 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2942 I32 repl_has_vars = 0;
2944 if (o->op_type == OP_TRANS)
2945 return pmtrans(o, expr, repl);
2947 PL_hints |= HINT_BLOCK_SCOPE;
2950 if (expr->op_type == OP_CONST) {
2952 SV *pat = ((SVOP*)expr)->op_sv;
2953 char *p = SvPV(pat, plen);
2954 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2955 sv_setpvn(pat, "\\s+", 3);
2956 p = SvPV(pat, plen);
2957 pm->op_pmflags |= PMf_SKIPWHITE;
2959 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2960 pm->op_pmdynflags |= PMdf_UTF8;
2961 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2962 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2963 pm->op_pmflags |= PMf_WHITE;
2967 if (PL_hints & HINT_UTF8)
2968 pm->op_pmdynflags |= PMdf_UTF8;
2969 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2970 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2972 : OP_REGCMAYBE),0,expr);
2974 NewOp(1101, rcop, 1, LOGOP);
2975 rcop->op_type = OP_REGCOMP;
2976 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2977 rcop->op_first = scalar(expr);
2978 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2979 ? (OPf_SPECIAL | OPf_KIDS)
2981 rcop->op_private = 1;
2984 /* establish postfix order */
2985 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2987 rcop->op_next = expr;
2988 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2991 rcop->op_next = LINKLIST(expr);
2992 expr->op_next = (OP*)rcop;
2995 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3000 if (pm->op_pmflags & PMf_EVAL) {
3002 if (CopLINE(PL_curcop) < PL_multi_end)
3003 CopLINE_set(PL_curcop, PL_multi_end);
3006 else if (repl->op_type == OP_THREADSV
3007 && strchr("&`'123456789+",
3008 PL_threadsv_names[repl->op_targ]))
3012 #endif /* USE_THREADS */
3013 else if (repl->op_type == OP_CONST)
3017 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3018 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3020 if (curop->op_type == OP_THREADSV) {
3022 if (strchr("&`'123456789+", curop->op_private))
3026 if (curop->op_type == OP_GV) {
3027 GV *gv = cGVOPx_gv(curop);
3029 if (strchr("&`'123456789+", *GvENAME(gv)))
3032 #endif /* USE_THREADS */
3033 else if (curop->op_type == OP_RV2CV)
3035 else if (curop->op_type == OP_RV2SV ||
3036 curop->op_type == OP_RV2AV ||
3037 curop->op_type == OP_RV2HV ||
3038 curop->op_type == OP_RV2GV) {
3039 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3042 else if (curop->op_type == OP_PADSV ||
3043 curop->op_type == OP_PADAV ||
3044 curop->op_type == OP_PADHV ||
3045 curop->op_type == OP_PADANY) {
3048 else if (curop->op_type == OP_PUSHRE)
3049 ; /* Okay here, dangerous in newASSIGNOP */
3058 && (!pm->op_pmregexp
3059 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3060 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3061 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3062 prepend_elem(o->op_type, scalar(repl), o);
3065 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3066 pm->op_pmflags |= PMf_MAYBE_CONST;
3067 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3069 NewOp(1101, rcop, 1, LOGOP);
3070 rcop->op_type = OP_SUBSTCONT;
3071 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3072 rcop->op_first = scalar(repl);
3073 rcop->op_flags |= OPf_KIDS;
3074 rcop->op_private = 1;
3077 /* establish postfix order */
3078 rcop->op_next = LINKLIST(repl);
3079 repl->op_next = (OP*)rcop;
3081 pm->op_pmreplroot = scalar((OP*)rcop);
3082 pm->op_pmreplstart = LINKLIST(rcop);
3091 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3094 NewOp(1101, svop, 1, SVOP);
3095 svop->op_type = type;
3096 svop->op_ppaddr = PL_ppaddr[type];
3098 svop->op_next = (OP*)svop;
3099 svop->op_flags = flags;
3100 if (PL_opargs[type] & OA_RETSCALAR)
3102 if (PL_opargs[type] & OA_TARGET)
3103 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3104 return CHECKOP(type, svop);
3108 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3111 NewOp(1101, padop, 1, PADOP);
3112 padop->op_type = type;
3113 padop->op_ppaddr = PL_ppaddr[type];
3114 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3115 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3116 PL_curpad[padop->op_padix] = sv;
3118 padop->op_next = (OP*)padop;
3119 padop->op_flags = flags;
3120 if (PL_opargs[type] & OA_RETSCALAR)
3122 if (PL_opargs[type] & OA_TARGET)
3123 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3124 return CHECKOP(type, padop);
3128 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3132 return newPADOP(type, flags, SvREFCNT_inc(gv));
3134 return newSVOP(type, flags, SvREFCNT_inc(gv));
3139 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3142 NewOp(1101, pvop, 1, PVOP);
3143 pvop->op_type = type;
3144 pvop->op_ppaddr = PL_ppaddr[type];
3146 pvop->op_next = (OP*)pvop;
3147 pvop->op_flags = flags;
3148 if (PL_opargs[type] & OA_RETSCALAR)
3150 if (PL_opargs[type] & OA_TARGET)
3151 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3152 return CHECKOP(type, pvop);
3156 Perl_package(pTHX_ OP *o)
3160 save_hptr(&PL_curstash);
3161 save_item(PL_curstname);
3166 name = SvPV(sv, len);
3167 PL_curstash = gv_stashpvn(name,len,TRUE);
3168 sv_setpvn(PL_curstname, name, len);
3172 sv_setpv(PL_curstname,"<none>");
3173 PL_curstash = Nullhv;
3175 PL_hints |= HINT_BLOCK_SCOPE;
3176 PL_copline = NOLINE;
3181 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3189 if (id->op_type != OP_CONST)
3190 Perl_croak(aTHX_ "Module name must be constant");
3194 if (version != Nullop) {
3195 SV *vesv = ((SVOP*)version)->op_sv;
3197 if (arg == Nullop && !SvNIOKp(vesv)) {
3204 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3205 Perl_croak(aTHX_ "Version number must be constant number");
3207 /* Make copy of id so we don't free it twice */
3208 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3210 /* Fake up a method call to VERSION */
3211 meth = newSVpvn("VERSION",7);
3212 sv_upgrade(meth, SVt_PVIV);
3213 (void)SvIOK_on(meth);
3214 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3215 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3216 append_elem(OP_LIST,
3217 prepend_elem(OP_LIST, pack, list(version)),
3218 newSVOP(OP_METHOD_NAMED, 0, meth)));
3222 /* Fake up an import/unimport */
3223 if (arg && arg->op_type == OP_STUB)
3224 imop = arg; /* no import on explicit () */
3225 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3226 imop = Nullop; /* use 5.0; */
3231 /* Make copy of id so we don't free it twice */
3232 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3234 /* Fake up a method call to import/unimport */
3235 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3236 sv_upgrade(meth, SVt_PVIV);
3237 (void)SvIOK_on(meth);
3238 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3239 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3240 append_elem(OP_LIST,
3241 prepend_elem(OP_LIST, pack, list(arg)),
3242 newSVOP(OP_METHOD_NAMED, 0, meth)));
3245 /* Fake up a require, handle override, if any */
3246 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3247 if (!(gv && GvIMPORTED_CV(gv)))
3248 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3250 if (gv && GvIMPORTED_CV(gv)) {
3251 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3252 append_elem(OP_LIST, id,
3253 scalar(newUNOP(OP_RV2CV, 0,
3258 rqop = newUNOP(OP_REQUIRE, 0, id);
3261 /* Fake up the BEGIN {}, which does its thing immediately. */
3263 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3266 append_elem(OP_LINESEQ,
3267 append_elem(OP_LINESEQ,
3268 newSTATEOP(0, Nullch, rqop),
3269 newSTATEOP(0, Nullch, veop)),
3270 newSTATEOP(0, Nullch, imop) ));
3272 PL_hints |= HINT_BLOCK_SCOPE;
3273 PL_copline = NOLINE;
3278 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3281 va_start(args, ver);
3282 vload_module(flags, name, ver, &args);
3286 #ifdef PERL_IMPLICIT_CONTEXT
3288 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3292 va_start(args, ver);
3293 vload_module(flags, name, ver, &args);
3299 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3301 OP *modname, *veop, *imop;
3303 modname = newSVOP(OP_CONST, 0, name);
3304 modname->op_private |= OPpCONST_BARE;
3306 veop = newSVOP(OP_CONST, 0, ver);
3310 if (flags & PERL_LOADMOD_NOIMPORT) {
3311 imop = sawparens(newNULLLIST());
3313 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3314 imop = va_arg(*args, OP*);
3319 sv = va_arg(*args, SV*);
3321 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3322 sv = va_arg(*args, SV*);
3326 line_t ocopline = PL_copline;
3327 int oexpect = PL_expect;
3329 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3330 veop, modname, imop);
3331 PL_expect = oexpect;
3332 PL_copline = ocopline;
3337 Perl_dofile(pTHX_ OP *term)
3342 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3343 if (!(gv && GvIMPORTED_CV(gv)))
3344 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3346 if (gv && GvIMPORTED_CV(gv)) {
3347 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3348 append_elem(OP_LIST, term,
3349 scalar(newUNOP(OP_RV2CV, 0,
3354 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3360 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3362 return newBINOP(OP_LSLICE, flags,
3363 list(force_list(subscript)),
3364 list(force_list(listval)) );
3368 S_list_assignment(pTHX_ register OP *o)
3373 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3374 o = cUNOPo->op_first;
3376 if (o->op_type == OP_COND_EXPR) {
3377 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3378 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3383 yyerror("Assignment to both a list and a scalar");
3387 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3388 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3389 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3392 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3395 if (o->op_type == OP_RV2SV)
3402 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3407 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3408 return newLOGOP(optype, 0,
3409 mod(scalar(left), optype),
3410 newUNOP(OP_SASSIGN, 0, scalar(right)));
3413 return newBINOP(optype, OPf_STACKED,
3414 mod(scalar(left), optype), scalar(right));
3418 if (list_assignment(left)) {
3422 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3423 left = mod(left, OP_AASSIGN);
3431 curop = list(force_list(left));
3432 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3433 o->op_private = 0 | (flags >> 8);
3434 for (curop = ((LISTOP*)curop)->op_first;
3435 curop; curop = curop->op_sibling)
3437 if (curop->op_type == OP_RV2HV &&
3438 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3439 o->op_private |= OPpASSIGN_HASH;
3443 if (!(left->op_private & OPpLVAL_INTRO)) {
3446 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3447 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3448 if (curop->op_type == OP_GV) {
3449 GV *gv = cGVOPx_gv(curop);
3450 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3452 SvCUR(gv) = PL_generation;
3454 else if (curop->op_type == OP_PADSV ||
3455 curop->op_type == OP_PADAV ||
3456 curop->op_type == OP_PADHV ||
3457 curop->op_type == OP_PADANY) {
3458 SV **svp = AvARRAY(PL_comppad_name);
3459 SV *sv = svp[curop->op_targ];
3460 if (SvCUR(sv) == PL_generation)
3462 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3464 else if (curop->op_type == OP_RV2CV)
3466 else if (curop->op_type == OP_RV2SV ||
3467 curop->op_type == OP_RV2AV ||
3468 curop->op_type == OP_RV2HV ||
3469 curop->op_type == OP_RV2GV) {
3470 if (lastop->op_type != OP_GV) /* funny deref? */
3473 else if (curop->op_type == OP_PUSHRE) {
3474 if (((PMOP*)curop)->op_pmreplroot) {
3476 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3478 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3480 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3482 SvCUR(gv) = PL_generation;
3491 o->op_private |= OPpASSIGN_COMMON;
3493 if (right && right->op_type == OP_SPLIT) {
3495 if ((tmpop = ((LISTOP*)right)->op_first) &&
3496 tmpop->op_type == OP_PUSHRE)
3498 PMOP *pm = (PMOP*)tmpop;
3499 if (left->op_type == OP_RV2AV &&
3500 !(left->op_private & OPpLVAL_INTRO) &&
3501 !(o->op_private & OPpASSIGN_COMMON) )
3503 tmpop = ((UNOP*)left)->op_first;
3504 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3506 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3507 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3509 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3510 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3512 pm->op_pmflags |= PMf_ONCE;
3513 tmpop = cUNOPo->op_first; /* to list (nulled) */
3514 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3515 tmpop->op_sibling = Nullop; /* don't free split */
3516 right->op_next = tmpop->op_next; /* fix starting loc */
3517 op_free(o); /* blow off assign */
3518 right->op_flags &= ~OPf_WANT;
3519 /* "I don't know and I don't care." */
3524 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3525 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3527 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3529 sv_setiv(sv, PL_modcount+1);
3537 right = newOP(OP_UNDEF, 0);
3538 if (right->op_type == OP_READLINE) {
3539 right->op_flags |= OPf_STACKED;
3540 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3543 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3544 o = newBINOP(OP_SASSIGN, flags,
3545 scalar(right), mod(scalar(left), OP_SASSIGN) );
3557 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3559 U32 seq = intro_my();
3562 NewOp(1101, cop, 1, COP);
3563 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3564 cop->op_type = OP_DBSTATE;
3565 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3568 cop->op_type = OP_NEXTSTATE;
3569 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3571 cop->op_flags = flags;
3572 cop->op_private = (PL_hints & HINT_BYTE);
3574 cop->op_private |= NATIVE_HINTS;
3576 PL_compiling.op_private = cop->op_private;
3577 cop->op_next = (OP*)cop;
3580 cop->cop_label = label;
3581 PL_hints |= HINT_BLOCK_SCOPE;
3584 cop->cop_arybase = PL_curcop->cop_arybase;
3585 if (specialWARN(PL_curcop->cop_warnings))
3586 cop->cop_warnings = PL_curcop->cop_warnings ;
3588 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3589 if (specialCopIO(PL_curcop->cop_io))
3590 cop->cop_io = PL_curcop->cop_io;
3592 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3595 if (PL_copline == NOLINE)
3596 CopLINE_set(cop, CopLINE(PL_curcop));
3598 CopLINE_set(cop, PL_copline);
3599 PL_copline = NOLINE;
3602 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3604 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3606 CopSTASH_set(cop, PL_curstash);
3608 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3609 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3610 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3611 (void)SvIOK_on(*svp);
3612 SvIVX(*svp) = PTR2IV(cop);
3616 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3619 /* "Introduce" my variables to visible status. */
3627 if (! PL_min_intro_pending)
3628 return PL_cop_seqmax;
3630 svp = AvARRAY(PL_comppad_name);
3631 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3632 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3633 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3634 SvNVX(sv) = (NV)PL_cop_seqmax;
3637 PL_min_intro_pending = 0;
3638 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3639 return PL_cop_seqmax++;
3643 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3645 return new_logop(type, flags, &first, &other);
3649 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3653 OP *first = *firstp;
3654 OP *other = *otherp;
3656 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3657 return newBINOP(type, flags, scalar(first), scalar(other));
3659 scalarboolean(first);
3660 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3661 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3662 if (type == OP_AND || type == OP_OR) {
3668 first = *firstp = cUNOPo->op_first;
3670 first->op_next = o->op_next;
3671 cUNOPo->op_first = Nullop;
3675 if (first->op_type == OP_CONST) {
3676 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3677 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3678 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3689 else if (first->op_type == OP_WANTARRAY) {
3695 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3696 OP *k1 = ((UNOP*)first)->op_first;
3697 OP *k2 = k1->op_sibling;
3699 switch (first->op_type)
3702 if (k2 && k2->op_type == OP_READLINE
3703 && (k2->op_flags & OPf_STACKED)
3704 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3706 warnop = k2->op_type;
3711 if (k1->op_type == OP_READDIR
3712 || k1->op_type == OP_GLOB
3713 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3714 || k1->op_type == OP_EACH)
3716 warnop = ((k1->op_type == OP_NULL)
3717 ? k1->op_targ : k1->op_type);
3722 line_t oldline = CopLINE(PL_curcop);
3723 CopLINE_set(PL_curcop, PL_copline);
3724 Perl_warner(aTHX_ WARN_MISC,
3725 "Value of %s%s can be \"0\"; test with defined()",
3727 ((warnop == OP_READLINE || warnop == OP_GLOB)
3728 ? " construct" : "() operator"));
3729 CopLINE_set(PL_curcop, oldline);
3736 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3737 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3739 NewOp(1101, logop, 1, LOGOP);
3741 logop->op_type = type;
3742 logop->op_ppaddr = PL_ppaddr[type];
3743 logop->op_first = first;
3744 logop->op_flags = flags | OPf_KIDS;
3745 logop->op_other = LINKLIST(other);
3746 logop->op_private = 1 | (flags >> 8);
3748 /* establish postfix order */
3749 logop->op_next = LINKLIST(first);
3750 first->op_next = (OP*)logop;
3751 first->op_sibling = other;
3753 o = newUNOP(OP_NULL, 0, (OP*)logop);
3760 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3767 return newLOGOP(OP_AND, 0, first, trueop);
3769 return newLOGOP(OP_OR, 0, first, falseop);
3771 scalarboolean(first);
3772 if (first->op_type == OP_CONST) {
3773 if (SvTRUE(((SVOP*)first)->op_sv)) {
3784 else if (first->op_type == OP_WANTARRAY) {
3788 NewOp(1101, logop, 1, LOGOP);
3789 logop->op_type = OP_COND_EXPR;
3790 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3791 logop->op_first = first;
3792 logop->op_flags = flags | OPf_KIDS;
3793 logop->op_private = 1 | (flags >> 8);
3794 logop->op_other = LINKLIST(trueop);
3795 logop->op_next = LINKLIST(falseop);
3798 /* establish postfix order */
3799 start = LINKLIST(first);
3800 first->op_next = (OP*)logop;
3802 first->op_sibling = trueop;
3803 trueop->op_sibling = falseop;
3804 o = newUNOP(OP_NULL, 0, (OP*)logop);
3806 trueop->op_next = falseop->op_next = o;
3813 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3821 NewOp(1101, range, 1, LOGOP);
3823 range->op_type = OP_RANGE;
3824 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3825 range->op_first = left;
3826 range->op_flags = OPf_KIDS;
3827 leftstart = LINKLIST(left);
3828 range->op_other = LINKLIST(right);
3829 range->op_private = 1 | (flags >> 8);
3831 left->op_sibling = right;
3833 range->op_next = (OP*)range;
3834 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3835 flop = newUNOP(OP_FLOP, 0, flip);
3836 o = newUNOP(OP_NULL, 0, flop);
3838 range->op_next = leftstart;
3840 left->op_next = flip;
3841 right->op_next = flop;
3843 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3844 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3845 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3846 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3848 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3849 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3852 if (!flip->op_private || !flop->op_private)
3853 linklist(o); /* blow off optimizer unless constant */
3859 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3863 int once = block && block->op_flags & OPf_SPECIAL &&
3864 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3867 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3868 return block; /* do {} while 0 does once */
3869 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3870 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3871 expr = newUNOP(OP_DEFINED, 0,
3872 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3873 } else if (expr->op_flags & OPf_KIDS) {
3874 OP *k1 = ((UNOP*)expr)->op_first;
3875 OP *k2 = (k1) ? k1->op_sibling : NULL;
3876 switch (expr->op_type) {
3878 if (k2 && k2->op_type == OP_READLINE
3879 && (k2->op_flags & OPf_STACKED)
3880 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3881 expr = newUNOP(OP_DEFINED, 0, expr);
3885 if (k1->op_type == OP_READDIR
3886 || k1->op_type == OP_GLOB
3887 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3888 || k1->op_type == OP_EACH)
3889 expr = newUNOP(OP_DEFINED, 0, expr);
3895 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3896 o = new_logop(OP_AND, 0, &expr, &listop);
3899 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3901 if (once && o != listop)
3902 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3905 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3907 o->op_flags |= flags;
3909 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3914 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3923 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3924 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3925 expr = newUNOP(OP_DEFINED, 0,
3926 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3927 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3928 OP *k1 = ((UNOP*)expr)->op_first;
3929 OP *k2 = (k1) ? k1->op_sibling : NULL;
3930 switch (expr->op_type) {
3932 if (k2 && k2->op_type == OP_READLINE
3933 && (k2->op_flags & OPf_STACKED)
3934 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3935 expr = newUNOP(OP_DEFINED, 0, expr);
3939 if (k1->op_type == OP_READDIR
3940 || k1->op_type == OP_GLOB
3941 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3942 || k1->op_type == OP_EACH)
3943 expr = newUNOP(OP_DEFINED, 0, expr);
3949 block = newOP(OP_NULL, 0);
3951 block = scope(block);
3955 next = LINKLIST(cont);
3958 OP *unstack = newOP(OP_UNSTACK, 0);
3961 cont = append_elem(OP_LINESEQ, cont, unstack);
3962 if ((line_t)whileline != NOLINE) {
3963 PL_copline = whileline;
3964 cont = append_elem(OP_LINESEQ, cont,
3965 newSTATEOP(0, Nullch, Nullop));
3969 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3970 redo = LINKLIST(listop);
3973 PL_copline = whileline;
3975 o = new_logop(OP_AND, 0, &expr, &listop);
3976 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3977 op_free(expr); /* oops, it's a while (0) */
3979 return Nullop; /* listop already freed by new_logop */
3982 ((LISTOP*)listop)->op_last->op_next = condop =
3983 (o == listop ? redo : LINKLIST(o));
3989 NewOp(1101,loop,1,LOOP);
3990 loop->op_type = OP_ENTERLOOP;
3991 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3992 loop->op_private = 0;
3993 loop->op_next = (OP*)loop;
3996 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3998 loop->op_redoop = redo;
3999 loop->op_lastop = o;
4000 o->op_private |= loopflags;
4003 loop->op_nextop = next;
4005 loop->op_nextop = o;
4007 o->op_flags |= flags;
4008 o->op_private |= (flags >> 8);
4013 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4021 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4022 sv->op_type = OP_RV2GV;
4023 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4025 else if (sv->op_type == OP_PADSV) { /* private variable */
4026 padoff = sv->op_targ;
4031 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4032 padoff = sv->op_targ;
4034 iterflags |= OPf_SPECIAL;
4039 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4043 padoff = find_threadsv("_");
4044 iterflags |= OPf_SPECIAL;
4046 sv = newGVOP(OP_GV, 0, PL_defgv);
4049 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4050 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4051 iterflags |= OPf_STACKED;
4053 else if (expr->op_type == OP_NULL &&
4054 (expr->op_flags & OPf_KIDS) &&
4055 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4057 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4058 * set the STACKED flag to indicate that these values are to be
4059 * treated as min/max values by 'pp_iterinit'.
4061 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4062 LOGOP* range = (LOGOP*) flip->op_first;
4063 OP* left = range->op_first;
4064 OP* right = left->op_sibling;
4067 range->op_flags &= ~OPf_KIDS;
4068 range->op_first = Nullop;
4070 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4071 listop->op_first->op_next = range->op_next;
4072 left->op_next = range->op_other;
4073 right->op_next = (OP*)listop;
4074 listop->op_next = listop->op_first;
4077 expr = (OP*)(listop);
4079 iterflags |= OPf_STACKED;
4082 expr = mod(force_list(expr), OP_GREPSTART);
4086 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4087 append_elem(OP_LIST, expr, scalar(sv))));
4088 assert(!loop->op_next);
4089 #ifdef PL_OP_SLAB_ALLOC
4092 NewOp(1234,tmp,1,LOOP);
4093 Copy(loop,tmp,1,LOOP);
4097 Renew(loop, 1, LOOP);
4099 loop->op_targ = padoff;
4100 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4101 PL_copline = forline;
4102 return newSTATEOP(0, label, wop);
4106 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4111 if (type != OP_GOTO || label->op_type == OP_CONST) {
4112 /* "last()" means "last" */
4113 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4114 o = newOP(type, OPf_SPECIAL);
4116 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4117 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4123 if (label->op_type == OP_ENTERSUB)
4124 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4125 o = newUNOP(type, OPf_STACKED, label);
4127 PL_hints |= HINT_BLOCK_SCOPE;
4132 Perl_cv_undef(pTHX_ CV *cv)
4136 MUTEX_DESTROY(CvMUTEXP(cv));
4137 Safefree(CvMUTEXP(cv));
4140 #endif /* USE_THREADS */
4142 if (!CvXSUB(cv) && CvROOT(cv)) {
4144 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4145 Perl_croak(aTHX_ "Can't undef active subroutine");
4148 Perl_croak(aTHX_ "Can't undef active subroutine");
4149 #endif /* USE_THREADS */
4152 SAVEVPTR(PL_curpad);
4156 op_free(CvROOT(cv));
4157 CvROOT(cv) = Nullop;
4160 SvPOK_off((SV*)cv); /* forget prototype */
4162 SvREFCNT_dec(CvGV(cv));
4164 SvREFCNT_dec(CvOUTSIDE(cv));
4165 CvOUTSIDE(cv) = Nullcv;
4167 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4170 if (CvPADLIST(cv)) {
4171 /* may be during global destruction */
4172 if (SvREFCNT(CvPADLIST(cv))) {
4173 I32 i = AvFILLp(CvPADLIST(cv));
4175 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4176 SV* sv = svp ? *svp : Nullsv;
4179 if (sv == (SV*)PL_comppad_name)
4180 PL_comppad_name = Nullav;
4181 else if (sv == (SV*)PL_comppad) {
4182 PL_comppad = Nullav;
4183 PL_curpad = Null(SV**);
4187 SvREFCNT_dec((SV*)CvPADLIST(cv));
4189 CvPADLIST(cv) = Nullav;
4194 S_cv_dump(pTHX_ CV *cv)
4197 CV *outside = CvOUTSIDE(cv);
4198 AV* padlist = CvPADLIST(cv);
4205 PerlIO_printf(Perl_debug_log,
4206 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4208 (CvANON(cv) ? "ANON"
4209 : (cv == PL_main_cv) ? "MAIN"
4210 : CvUNIQUE(cv) ? "UNIQUE"
4211 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4214 : CvANON(outside) ? "ANON"
4215 : (outside == PL_main_cv) ? "MAIN"
4216 : CvUNIQUE(outside) ? "UNIQUE"
4217 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4222 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4223 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4224 pname = AvARRAY(pad_name);
4225 ppad = AvARRAY(pad);
4227 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4228 if (SvPOK(pname[ix]))
4229 PerlIO_printf(Perl_debug_log,
4230 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4231 (int)ix, PTR2UV(ppad[ix]),
4232 SvFAKE(pname[ix]) ? "FAKE " : "",
4234 (IV)I_32(SvNVX(pname[ix])),
4237 #endif /* DEBUGGING */
4241 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4245 AV* protopadlist = CvPADLIST(proto);
4246 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4247 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4248 SV** pname = AvARRAY(protopad_name);
4249 SV** ppad = AvARRAY(protopad);
4250 I32 fname = AvFILLp(protopad_name);
4251 I32 fpad = AvFILLp(protopad);
4255 assert(!CvUNIQUE(proto));
4259 SAVESPTR(PL_comppad_name);
4260 SAVESPTR(PL_compcv);
4262 cv = PL_compcv = (CV*)NEWSV(1104,0);
4263 sv_upgrade((SV *)cv, SvTYPE(proto));
4264 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4268 New(666, CvMUTEXP(cv), 1, perl_mutex);
4269 MUTEX_INIT(CvMUTEXP(cv));
4271 #endif /* USE_THREADS */
4272 CvFILE(cv) = CvFILE(proto);
4273 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4274 CvSTASH(cv) = CvSTASH(proto);
4275 CvROOT(cv) = CvROOT(proto);
4276 CvSTART(cv) = CvSTART(proto);
4278 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4281 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4283 PL_comppad_name = newAV();
4284 for (ix = fname; ix >= 0; ix--)
4285 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4287 PL_comppad = newAV();
4289 comppadlist = newAV();
4290 AvREAL_off(comppadlist);
4291 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4292 av_store(comppadlist, 1, (SV*)PL_comppad);
4293 CvPADLIST(cv) = comppadlist;
4294 av_fill(PL_comppad, AvFILLp(protopad));
4295 PL_curpad = AvARRAY(PL_comppad);
4297 av = newAV(); /* will be @_ */
4299 av_store(PL_comppad, 0, (SV*)av);
4300 AvFLAGS(av) = AVf_REIFY;
4302 for (ix = fpad; ix > 0; ix--) {
4303 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4304 if (namesv && namesv != &PL_sv_undef) {
4305 char *name = SvPVX(namesv); /* XXX */
4306 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4307 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4308 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4310 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4312 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4314 else { /* our own lexical */
4317 /* anon code -- we'll come back for it */
4318 sv = SvREFCNT_inc(ppad[ix]);
4320 else if (*name == '@')
4322 else if (*name == '%')
4331 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4332 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4335 SV* sv = NEWSV(0,0);
4341 /* Now that vars are all in place, clone nested closures. */
4343 for (ix = fpad; ix > 0; ix--) {
4344 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4346 && namesv != &PL_sv_undef
4347 && !(SvFLAGS(namesv) & SVf_FAKE)
4348 && *SvPVX(namesv) == '&'
4349 && CvCLONE(ppad[ix]))
4351 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4352 SvREFCNT_dec(ppad[ix]);
4355 PL_curpad[ix] = (SV*)kid;
4359 #ifdef DEBUG_CLOSURES
4360 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4362 PerlIO_printf(Perl_debug_log, " from:\n");
4364 PerlIO_printf(Perl_debug_log, " to:\n");
4371 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4373 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4375 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4382 Perl_cv_clone(pTHX_ CV *proto)
4385 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4386 cv = cv_clone2(proto, CvOUTSIDE(proto));
4387 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4392 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4394 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4395 SV* msg = sv_newmortal();
4399 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4400 sv_setpv(msg, "Prototype mismatch:");
4402 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4404 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4405 sv_catpv(msg, " vs ");
4407 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4409 sv_catpv(msg, "none");
4410 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4414 static void const_sv_xsub(pTHXo_ CV* cv);
4417 =for apidoc cv_const_sv
4419 If C<cv> is a constant sub eligible for inlining. returns the constant
4420 value returned by the sub. Otherwise, returns NULL.
4422 Constant subs can be created with C<newCONSTSUB> or as described in
4423 L<perlsub/"Constant Functions">.
4428 Perl_cv_const_sv(pTHX_ CV *cv)
4430 if (!cv || !CvCONST(cv))
4432 return (SV*)CvXSUBANY(cv).any_ptr;
4436 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4443 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4444 o = cLISTOPo->op_first->op_sibling;
4446 for (; o; o = o->op_next) {
4447 OPCODE type = o->op_type;
4449 if (sv && o->op_next == o)
4451 if (o->op_next != o) {
4452 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4454 if (type == OP_DBSTATE)
4457 if (type == OP_LEAVESUB || type == OP_RETURN)
4461 if (type == OP_CONST && cSVOPo->op_sv)
4463 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4464 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4465 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4469 /* We get here only from cv_clone2() while creating a closure.
4470 Copy the const value here instead of in cv_clone2 so that
4471 SvREADONLY_on doesn't lead to problems when leaving
4476 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4488 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4498 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4502 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4504 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4508 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4514 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4519 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4520 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4521 SV *sv = sv_newmortal();
4522 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4523 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4528 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4529 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4539 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4540 maximum a prototype before. */
4541 if (SvTYPE(gv) > SVt_NULL) {
4542 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4543 && ckWARN_d(WARN_PROTOTYPE))
4545 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4547 cv_ckproto((CV*)gv, NULL, ps);
4550 sv_setpv((SV*)gv, ps);
4552 sv_setiv((SV*)gv, -1);
4553 SvREFCNT_dec(PL_compcv);
4554 cv = PL_compcv = NULL;
4555 PL_sub_generation++;
4559 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4561 #ifdef GV_SHARED_CHECK
4562 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4563 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4567 if (!block || !ps || *ps || attrs)
4570 const_sv = op_const_sv(block, Nullcv);
4573 bool exists = CvROOT(cv) || CvXSUB(cv);
4575 #ifdef GV_SHARED_CHECK
4576 if (exists && GvSHARED(gv)) {
4577 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4581 /* if the subroutine doesn't exist and wasn't pre-declared
4582 * with a prototype, assume it will be AUTOLOADed,
4583 * skipping the prototype check
4585 if (exists || SvPOK(cv))
4586 cv_ckproto(cv, gv, ps);
4587 /* already defined (or promised)? */
4588 if (exists || GvASSUMECV(gv)) {
4589 if (!block && !attrs) {
4590 /* just a "sub foo;" when &foo is already defined */
4591 SAVEFREESV(PL_compcv);
4594 /* ahem, death to those who redefine active sort subs */
4595 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4596 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4598 if (ckWARN(WARN_REDEFINE)
4600 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4602 line_t oldline = CopLINE(PL_curcop);
4603 CopLINE_set(PL_curcop, PL_copline);
4604 Perl_warner(aTHX_ WARN_REDEFINE,
4605 CvCONST(cv) ? "Constant subroutine %s redefined"
4606 : "Subroutine %s redefined", name);
4607 CopLINE_set(PL_curcop, oldline);
4615 SvREFCNT_inc(const_sv);
4617 assert(!CvROOT(cv) && !CvCONST(cv));
4618 sv_setpv((SV*)cv, ""); /* prototype is "" */
4619 CvXSUBANY(cv).any_ptr = const_sv;
4620 CvXSUB(cv) = const_sv_xsub;
4625 cv = newCONSTSUB(NULL, name, const_sv);
4628 SvREFCNT_dec(PL_compcv);
4630 PL_sub_generation++;
4637 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4638 * before we clobber PL_compcv.
4642 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4643 stash = GvSTASH(CvGV(cv));
4644 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4645 stash = CvSTASH(cv);
4647 stash = PL_curstash;
4650 /* possibly about to re-define existing subr -- ignore old cv */
4651 rcv = (SV*)PL_compcv;
4652 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4653 stash = GvSTASH(gv);
4655 stash = PL_curstash;
4657 apply_attrs(stash, rcv, attrs);
4659 if (cv) { /* must reuse cv if autoloaded */
4661 /* got here with just attrs -- work done, so bug out */
4662 SAVEFREESV(PL_compcv);
4666 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4667 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4668 CvOUTSIDE(PL_compcv) = 0;
4669 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4670 CvPADLIST(PL_compcv) = 0;
4671 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4672 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4673 SvREFCNT_dec(PL_compcv);
4680 PL_sub_generation++;
4683 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4684 CvFILE(cv) = CopFILE(PL_curcop);
4685 CvSTASH(cv) = PL_curstash;
4688 if (!CvMUTEXP(cv)) {
4689 New(666, CvMUTEXP(cv), 1, perl_mutex);
4690 MUTEX_INIT(CvMUTEXP(cv));
4692 #endif /* USE_THREADS */
4695 sv_setpv((SV*)cv, ps);
4697 if (PL_error_count) {
4701 char *s = strrchr(name, ':');
4703 if (strEQ(s, "BEGIN")) {
4705 "BEGIN not safe after errors--compilation aborted";
4706 if (PL_in_eval & EVAL_KEEPERR)
4707 Perl_croak(aTHX_ not_safe);
4709 /* force display of errors found but not reported */
4710 sv_catpv(ERRSV, not_safe);
4711 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4719 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4720 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4723 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4724 mod(scalarseq(block), OP_LEAVESUBLV));
4727 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4729 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4730 OpREFCNT_set(CvROOT(cv), 1);
4731 CvSTART(cv) = LINKLIST(CvROOT(cv));
4732 CvROOT(cv)->op_next = 0;
4735 /* now that optimizer has done its work, adjust pad values */
4737 SV **namep = AvARRAY(PL_comppad_name);
4738 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4741 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4744 * The only things that a clonable function needs in its
4745 * pad are references to outer lexicals and anonymous subs.
4746 * The rest are created anew during cloning.
4748 if (!((namesv = namep[ix]) != Nullsv &&
4749 namesv != &PL_sv_undef &&
4751 *SvPVX(namesv) == '&')))
4753 SvREFCNT_dec(PL_curpad[ix]);
4754 PL_curpad[ix] = Nullsv;
4757 assert(!CvCONST(cv));
4758 if (ps && !*ps && op_const_sv(block, cv))
4762 AV *av = newAV(); /* Will be @_ */
4764 av_store(PL_comppad, 0, (SV*)av);
4765 AvFLAGS(av) = AVf_REIFY;
4767 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4768 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4770 if (!SvPADMY(PL_curpad[ix]))
4771 SvPADTMP_on(PL_curpad[ix]);
4775 if (name || aname) {
4777 char *tname = (name ? name : aname);
4779 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4780 SV *sv = NEWSV(0,0);
4781 SV *tmpstr = sv_newmortal();
4782 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4786 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4788 (long)PL_subline, (long)CopLINE(PL_curcop));
4789 gv_efullname3(tmpstr, gv, Nullch);
4790 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4791 hv = GvHVn(db_postponed);
4792 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4793 && (pcv = GvCV(db_postponed)))
4799 call_sv((SV*)pcv, G_DISCARD);
4803 if ((s = strrchr(tname,':')))
4808 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4811 if (strEQ(s, "BEGIN")) {
4812 I32 oldscope = PL_scopestack_ix;
4814 SAVECOPFILE(&PL_compiling);
4815 SAVECOPLINE(&PL_compiling);
4817 sv_setsv(PL_rs, PL_nrs);
4820 PL_beginav = newAV();
4821 DEBUG_x( dump_sub(gv) );
4822 av_push(PL_beginav, (SV*)cv);
4823 GvCV(gv) = 0; /* cv has been hijacked */
4824 call_list(oldscope, PL_beginav);
4826 PL_curcop = &PL_compiling;
4827 PL_compiling.op_private = PL_hints;
4830 else if (strEQ(s, "END") && !PL_error_count) {
4833 DEBUG_x( dump_sub(gv) );
4834 av_unshift(PL_endav, 1);
4835 av_store(PL_endav, 0, (SV*)cv);
4836 GvCV(gv) = 0; /* cv has been hijacked */
4838 else if (strEQ(s, "CHECK") && !PL_error_count) {
4840 PL_checkav = newAV();
4841 DEBUG_x( dump_sub(gv) );
4842 if (PL_main_start && ckWARN(WARN_VOID))
4843 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4844 av_unshift(PL_checkav, 1);
4845 av_store(PL_checkav, 0, (SV*)cv);
4846 GvCV(gv) = 0; /* cv has been hijacked */
4848 else if (strEQ(s, "INIT") && !PL_error_count) {
4850 PL_initav = newAV();
4851 DEBUG_x( dump_sub(gv) );
4852 if (PL_main_start && ckWARN(WARN_VOID))
4853 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4854 av_push(PL_initav, (SV*)cv);
4855 GvCV(gv) = 0; /* cv has been hijacked */
4860 PL_copline = NOLINE;
4865 /* XXX unsafe for threads if eval_owner isn't held */
4867 =for apidoc newCONSTSUB
4869 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4870 eligible for inlining at compile-time.
4876 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4882 SAVECOPLINE(PL_curcop);
4883 CopLINE_set(PL_curcop, PL_copline);
4886 PL_hints &= ~HINT_BLOCK_SCOPE;
4889 SAVESPTR(PL_curstash);
4890 SAVECOPSTASH(PL_curcop);
4891 PL_curstash = stash;
4893 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4895 CopSTASH(PL_curcop) = stash;
4899 cv = newXS(name, const_sv_xsub, __FILE__);
4900 CvXSUBANY(cv).any_ptr = sv;
4902 sv_setpv((SV*)cv, ""); /* prototype is "" */
4910 =for apidoc U||newXS
4912 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4918 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4920 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4923 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4925 /* just a cached method */
4929 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4930 /* already defined (or promised) */
4931 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4932 && HvNAME(GvSTASH(CvGV(cv)))
4933 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4934 line_t oldline = CopLINE(PL_curcop);
4935 if (PL_copline != NOLINE)
4936 CopLINE_set(PL_curcop, PL_copline);
4937 Perl_warner(aTHX_ WARN_REDEFINE,
4938 CvCONST(cv) ? "Constant subroutine %s redefined"
4939 : "Subroutine %s redefined"
4941 CopLINE_set(PL_curcop, oldline);
4948 if (cv) /* must reuse cv if autoloaded */
4951 cv = (CV*)NEWSV(1105,0);
4952 sv_upgrade((SV *)cv, SVt_PVCV);
4956 PL_sub_generation++;
4959 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4961 New(666, CvMUTEXP(cv), 1, perl_mutex);
4962 MUTEX_INIT(CvMUTEXP(cv));
4964 #endif /* USE_THREADS */
4965 (void)gv_fetchfile(filename);
4966 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4967 an external constant string */
4968 CvXSUB(cv) = subaddr;
4971 char *s = strrchr(name,':');
4977 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4980 if (strEQ(s, "BEGIN")) {
4982 PL_beginav = newAV();
4983 av_push(PL_beginav, (SV*)cv);
4984 GvCV(gv) = 0; /* cv has been hijacked */
4986 else if (strEQ(s, "END")) {
4989 av_unshift(PL_endav, 1);
4990 av_store(PL_endav, 0, (SV*)cv);
4991 GvCV(gv) = 0; /* cv has been hijacked */
4993 else if (strEQ(s, "CHECK")) {
4995 PL_checkav = newAV();
4996 if (PL_main_start && ckWARN(WARN_VOID))
4997 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4998 av_unshift(PL_checkav, 1);
4999 av_store(PL_checkav, 0, (SV*)cv);
5000 GvCV(gv) = 0; /* cv has been hijacked */
5002 else if (strEQ(s, "INIT")) {
5004 PL_initav = newAV();
5005 if (PL_main_start && ckWARN(WARN_VOID))
5006 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5007 av_push(PL_initav, (SV*)cv);
5008 GvCV(gv) = 0; /* cv has been hijacked */
5019 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5028 name = SvPVx(cSVOPo->op_sv, n_a);
5031 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5032 #ifdef GV_SHARED_CHECK
5034 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5038 if ((cv = GvFORM(gv))) {
5039 if (ckWARN(WARN_REDEFINE)) {
5040 line_t oldline = CopLINE(PL_curcop);
5042 CopLINE_set(PL_curcop, PL_copline);
5043 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5044 CopLINE_set(PL_curcop, oldline);
5050 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
5051 CvFILE(cv) = CopFILE(PL_curcop);
5053 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5054 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5055 SvPADTMP_on(PL_curpad[ix]);
5058 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5059 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5060 OpREFCNT_set(CvROOT(cv), 1);
5061 CvSTART(cv) = LINKLIST(CvROOT(cv));
5062 CvROOT(cv)->op_next = 0;
5065 PL_copline = NOLINE;
5070 Perl_newANONLIST(pTHX_ OP *o)
5072 return newUNOP(OP_REFGEN, 0,
5073 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5077 Perl_newANONHASH(pTHX_ OP *o)
5079 return newUNOP(OP_REFGEN, 0,
5080 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5084 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5086 return newANONATTRSUB(floor, proto, Nullop, block);
5090 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5092 return newUNOP(OP_REFGEN, 0,
5093 newSVOP(OP_ANONCODE, 0,
5094 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5098 Perl_oopsAV(pTHX_ OP *o)
5100 switch (o->op_type) {
5102 o->op_type = OP_PADAV;
5103 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5104 return ref(o, OP_RV2AV);
5107 o->op_type = OP_RV2AV;
5108 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5113 if (ckWARN_d(WARN_INTERNAL))
5114 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5121 Perl_oopsHV(pTHX_ OP *o)
5123 switch (o->op_type) {
5126 o->op_type = OP_PADHV;
5127 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5128 return ref(o, OP_RV2HV);
5132 o->op_type = OP_RV2HV;
5133 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5138 if (ckWARN_d(WARN_INTERNAL))
5139 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5146 Perl_newAVREF(pTHX_ OP *o)
5148 if (o->op_type == OP_PADANY) {
5149 o->op_type = OP_PADAV;
5150 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5153 return newUNOP(OP_RV2AV, 0, scalar(o));
5157 Perl_newGVREF(pTHX_ I32 type, OP *o)
5159 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5160 return newUNOP(OP_NULL, 0, o);
5161 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5165 Perl_newHVREF(pTHX_ OP *o)
5167 if (o->op_type == OP_PADANY) {
5168 o->op_type = OP_PADHV;
5169 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5172 return newUNOP(OP_RV2HV, 0, scalar(o));
5176 Perl_oopsCV(pTHX_ OP *o)
5178 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5184 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5186 return newUNOP(OP_RV2CV, flags, scalar(o));
5190 Perl_newSVREF(pTHX_ OP *o)
5192 if (o->op_type == OP_PADANY) {
5193 o->op_type = OP_PADSV;
5194 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5197 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5198 o->op_flags |= OPpDONE_SVREF;
5201 return newUNOP(OP_RV2SV, 0, scalar(o));
5204 /* Check routines. */
5207 Perl_ck_anoncode(pTHX_ OP *o)
5212 name = NEWSV(1106,0);
5213 sv_upgrade(name, SVt_PVNV);
5214 sv_setpvn(name, "&", 1);
5217 ix = pad_alloc(o->op_type, SVs_PADMY);
5218 av_store(PL_comppad_name, ix, name);
5219 av_store(PL_comppad, ix, cSVOPo->op_sv);
5220 SvPADMY_on(cSVOPo->op_sv);
5221 cSVOPo->op_sv = Nullsv;
5222 cSVOPo->op_targ = ix;
5227 Perl_ck_bitop(pTHX_ OP *o)
5229 o->op_private = PL_hints;
5234 Perl_ck_concat(pTHX_ OP *o)
5236 if (cUNOPo->op_first->op_type == OP_CONCAT)
5237 o->op_flags |= OPf_STACKED;
5242 Perl_ck_spair(pTHX_ OP *o)
5244 if (o->op_flags & OPf_KIDS) {
5247 OPCODE type = o->op_type;
5248 o = modkids(ck_fun(o), type);
5249 kid = cUNOPo->op_first;
5250 newop = kUNOP->op_first->op_sibling;
5252 (newop->op_sibling ||
5253 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5254 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5255 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5259 op_free(kUNOP->op_first);
5260 kUNOP->op_first = newop;
5262 o->op_ppaddr = PL_ppaddr[++o->op_type];
5267 Perl_ck_delete(pTHX_ OP *o)
5271 if (o->op_flags & OPf_KIDS) {
5272 OP *kid = cUNOPo->op_first;
5273 switch (kid->op_type) {
5275 o->op_flags |= OPf_SPECIAL;
5278 o->op_private |= OPpSLICE;
5281 o->op_flags |= OPf_SPECIAL;
5286 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5287 PL_op_desc[o->op_type]);
5295 Perl_ck_eof(pTHX_ OP *o)
5297 I32 type = o->op_type;
5299 if (o->op_flags & OPf_KIDS) {
5300 if (cLISTOPo->op_first->op_type == OP_STUB) {
5302 o = newUNOP(type, OPf_SPECIAL,
5303 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5311 Perl_ck_eval(pTHX_ OP *o)
5313 PL_hints |= HINT_BLOCK_SCOPE;
5314 if (o->op_flags & OPf_KIDS) {
5315 SVOP *kid = (SVOP*)cUNOPo->op_first;
5318 o->op_flags &= ~OPf_KIDS;
5321 else if (kid->op_type == OP_LINESEQ) {
5324 kid->op_next = o->op_next;
5325 cUNOPo->op_first = 0;
5328 NewOp(1101, enter, 1, LOGOP);
5329 enter->op_type = OP_ENTERTRY;
5330 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5331 enter->op_private = 0;
5333 /* establish postfix order */
5334 enter->op_next = (OP*)enter;
5336 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5337 o->op_type = OP_LEAVETRY;
5338 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5339 enter->op_other = o;
5347 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5349 o->op_targ = (PADOFFSET)PL_hints;
5354 Perl_ck_exit(pTHX_ OP *o)
5357 HV *table = GvHV(PL_hintgv);
5359 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5360 if (svp && *svp && SvTRUE(*svp))
5361 o->op_private |= OPpEXIT_VMSISH;
5368 Perl_ck_exec(pTHX_ OP *o)
5371 if (o->op_flags & OPf_STACKED) {
5373 kid = cUNOPo->op_first->op_sibling;
5374 if (kid->op_type == OP_RV2GV)
5383 Perl_ck_exists(pTHX_ OP *o)
5386 if (o->op_flags & OPf_KIDS) {
5387 OP *kid = cUNOPo->op_first;
5388 if (kid->op_type == OP_ENTERSUB) {
5389 (void) ref(kid, o->op_type);
5390 if (kid->op_type != OP_RV2CV && !PL_error_count)
5391 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5392 PL_op_desc[o->op_type]);
5393 o->op_private |= OPpEXISTS_SUB;
5395 else if (kid->op_type == OP_AELEM)
5396 o->op_flags |= OPf_SPECIAL;
5397 else if (kid->op_type != OP_HELEM)
5398 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5399 PL_op_desc[o->op_type]);
5407 Perl_ck_gvconst(pTHX_ register OP *o)
5409 o = fold_constants(o);
5410 if (o->op_type == OP_CONST)
5417 Perl_ck_rvconst(pTHX_ register OP *o)
5419 SVOP *kid = (SVOP*)cUNOPo->op_first;
5421 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5422 if (kid->op_type == OP_CONST) {
5426 SV *kidsv = kid->op_sv;
5429 /* Is it a constant from cv_const_sv()? */
5430 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5431 SV *rsv = SvRV(kidsv);
5432 int svtype = SvTYPE(rsv);
5433 char *badtype = Nullch;
5435 switch (o->op_type) {
5437 if (svtype > SVt_PVMG)
5438 badtype = "a SCALAR";
5441 if (svtype != SVt_PVAV)
5442 badtype = "an ARRAY";
5445 if (svtype != SVt_PVHV) {
5446 if (svtype == SVt_PVAV) { /* pseudohash? */
5447 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5448 if (ksv && SvROK(*ksv)
5449 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5458 if (svtype != SVt_PVCV)
5463 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5466 name = SvPV(kidsv, n_a);
5467 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5468 char *badthing = Nullch;
5469 switch (o->op_type) {
5471 badthing = "a SCALAR";
5474 badthing = "an ARRAY";
5477 badthing = "a HASH";
5482 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5486 * This is a little tricky. We only want to add the symbol if we
5487 * didn't add it in the lexer. Otherwise we get duplicate strict
5488 * warnings. But if we didn't add it in the lexer, we must at
5489 * least pretend like we wanted to add it even if it existed before,
5490 * or we get possible typo warnings. OPpCONST_ENTERED says
5491 * whether the lexer already added THIS instance of this symbol.
5493 iscv = (o->op_type == OP_RV2CV) * 2;
5495 gv = gv_fetchpv(name,
5496 iscv | !(kid->op_private & OPpCONST_ENTERED),
5499 : o->op_type == OP_RV2SV
5501 : o->op_type == OP_RV2AV
5503 : o->op_type == OP_RV2HV
5506 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5508 kid->op_type = OP_GV;
5509 SvREFCNT_dec(kid->op_sv);
5511 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5512 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5513 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5515 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5517 kid->op_sv = SvREFCNT_inc(gv);
5519 kid->op_private = 0;
5520 kid->op_ppaddr = PL_ppaddr[OP_GV];
5527 Perl_ck_ftst(pTHX_ OP *o)
5529 I32 type = o->op_type;
5531 if (o->op_flags & OPf_REF) {
5534 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5535 SVOP *kid = (SVOP*)cUNOPo->op_first;
5537 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5539 OP *newop = newGVOP(type, OPf_REF,
5540 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5547 if (type == OP_FTTTY)
5548 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5551 o = newUNOP(type, 0, newDEFSVOP());
5554 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5556 if (PL_hints & HINT_LOCALE)
5557 o->op_private |= OPpLOCALE;
5564 Perl_ck_fun(pTHX_ OP *o)
5570 int type = o->op_type;
5571 register I32 oa = PL_opargs[type] >> OASHIFT;
5573 if (o->op_flags & OPf_STACKED) {
5574 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5577 return no_fh_allowed(o);
5580 if (o->op_flags & OPf_KIDS) {
5582 tokid = &cLISTOPo->op_first;
5583 kid = cLISTOPo->op_first;
5584 if (kid->op_type == OP_PUSHMARK ||
5585 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5587 tokid = &kid->op_sibling;
5588 kid = kid->op_sibling;
5590 if (!kid && PL_opargs[type] & OA_DEFGV)
5591 *tokid = kid = newDEFSVOP();
5595 sibl = kid->op_sibling;
5598 /* list seen where single (scalar) arg expected? */
5599 if (numargs == 1 && !(oa >> 4)
5600 && kid->op_type == OP_LIST && type != OP_SCALAR)
5602 return too_many_arguments(o,PL_op_desc[type]);
5615 if (kid->op_type == OP_CONST &&
5616 (kid->op_private & OPpCONST_BARE))
5618 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5619 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5620 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5621 if (ckWARN(WARN_DEPRECATED))
5622 Perl_warner(aTHX_ WARN_DEPRECATED,
5623 "Array @%s missing the @ in argument %"IVdf" of %s()",
5624 name, (IV)numargs, PL_op_desc[type]);
5627 kid->op_sibling = sibl;
5630 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5631 bad_type(numargs, "array", PL_op_desc[type], kid);
5635 if (kid->op_type == OP_CONST &&
5636 (kid->op_private & OPpCONST_BARE))
5638 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5639 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5640 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5641 if (ckWARN(WARN_DEPRECATED))
5642 Perl_warner(aTHX_ WARN_DEPRECATED,
5643 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5644 name, (IV)numargs, PL_op_desc[type]);
5647 kid->op_sibling = sibl;
5650 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5651 bad_type(numargs, "hash", PL_op_desc[type], kid);
5656 OP *newop = newUNOP(OP_NULL, 0, kid);
5657 kid->op_sibling = 0;
5659 newop->op_next = newop;
5661 kid->op_sibling = sibl;
5666 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5667 if (kid->op_type == OP_CONST &&
5668 (kid->op_private & OPpCONST_BARE))
5670 OP *newop = newGVOP(OP_GV, 0,
5671 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5676 else if (kid->op_type == OP_READLINE) {
5677 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5678 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5681 I32 flags = OPf_SPECIAL;
5685 /* is this op a FH constructor? */
5686 if (is_handle_constructor(o,numargs)) {
5687 char *name = Nullch;
5691 /* Set a flag to tell rv2gv to vivify
5692 * need to "prove" flag does not mean something
5693 * else already - NI-S 1999/05/07
5696 if (kid->op_type == OP_PADSV) {
5697 SV **namep = av_fetch(PL_comppad_name,
5699 if (namep && *namep)
5700 name = SvPV(*namep, len);
5702 else if (kid->op_type == OP_RV2SV
5703 && kUNOP->op_first->op_type == OP_GV)
5705 GV *gv = cGVOPx_gv(kUNOP->op_first);
5707 len = GvNAMELEN(gv);
5709 else if (kid->op_type == OP_AELEM
5710 || kid->op_type == OP_HELEM)
5712 name = "__ANONIO__";
5718 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5719 namesv = PL_curpad[targ];
5720 (void)SvUPGRADE(namesv, SVt_PV);
5722 sv_setpvn(namesv, "$", 1);
5723 sv_catpvn(namesv, name, len);
5726 kid->op_sibling = 0;
5727 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5728 kid->op_targ = targ;
5729 kid->op_private |= priv;
5731 kid->op_sibling = sibl;
5737 mod(scalar(kid), type);
5741 tokid = &kid->op_sibling;
5742 kid = kid->op_sibling;
5744 o->op_private |= numargs;
5746 return too_many_arguments(o,PL_op_desc[o->op_type]);
5749 else if (PL_opargs[type] & OA_DEFGV) {
5751 return newUNOP(type, 0, newDEFSVOP());
5755 while (oa & OA_OPTIONAL)
5757 if (oa && oa != OA_LIST)
5758 return too_few_arguments(o,PL_op_desc[o->op_type]);
5764 Perl_ck_glob(pTHX_ OP *o)
5769 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5770 append_elem(OP_GLOB, o, newDEFSVOP());
5772 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5773 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5775 #if !defined(PERL_EXTERNAL_GLOB)
5776 /* XXX this can be tightened up and made more failsafe. */
5779 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5780 /* null-terminated import list */
5781 newSVpvn(":globally", 9), Nullsv);
5782 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5785 #endif /* PERL_EXTERNAL_GLOB */
5787 if (gv && GvIMPORTED_CV(gv)) {
5788 append_elem(OP_GLOB, o,
5789 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5790 o->op_type = OP_LIST;
5791 o->op_ppaddr = PL_ppaddr[OP_LIST];
5792 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5793 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5794 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5795 append_elem(OP_LIST, o,
5796 scalar(newUNOP(OP_RV2CV, 0,
5797 newGVOP(OP_GV, 0, gv)))));
5798 o = newUNOP(OP_NULL, 0, ck_subr(o));
5799 o->op_targ = OP_GLOB; /* hint at what it used to be */
5802 gv = newGVgen("main");
5804 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5810 Perl_ck_grep(pTHX_ OP *o)
5814 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5816 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5817 NewOp(1101, gwop, 1, LOGOP);
5819 if (o->op_flags & OPf_STACKED) {
5822 kid = cLISTOPo->op_first->op_sibling;
5823 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5826 kid->op_next = (OP*)gwop;
5827 o->op_flags &= ~OPf_STACKED;
5829 kid = cLISTOPo->op_first->op_sibling;
5830 if (type == OP_MAPWHILE)
5837 kid = cLISTOPo->op_first->op_sibling;
5838 if (kid->op_type != OP_NULL)
5839 Perl_croak(aTHX_ "panic: ck_grep");
5840 kid = kUNOP->op_first;
5842 gwop->op_type = type;
5843 gwop->op_ppaddr = PL_ppaddr[type];
5844 gwop->op_first = listkids(o);
5845 gwop->op_flags |= OPf_KIDS;
5846 gwop->op_private = 1;
5847 gwop->op_other = LINKLIST(kid);
5848 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5849 kid->op_next = (OP*)gwop;
5851 kid = cLISTOPo->op_first->op_sibling;
5852 if (!kid || !kid->op_sibling)
5853 return too_few_arguments(o,PL_op_desc[o->op_type]);
5854 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5855 mod(kid, OP_GREPSTART);
5861 Perl_ck_index(pTHX_ OP *o)
5863 if (o->op_flags & OPf_KIDS) {
5864 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5866 kid = kid->op_sibling; /* get past "big" */
5867 if (kid && kid->op_type == OP_CONST)
5868 fbm_compile(((SVOP*)kid)->op_sv, 0);
5874 Perl_ck_lengthconst(pTHX_ OP *o)
5876 /* XXX length optimization goes here */
5881 Perl_ck_lfun(pTHX_ OP *o)
5883 OPCODE type = o->op_type;
5884 return modkids(ck_fun(o), type);
5888 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5890 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5891 switch (cUNOPo->op_first->op_type) {
5893 /* This is needed for
5894 if (defined %stash::)
5895 to work. Do not break Tk.
5897 break; /* Globals via GV can be undef */
5899 case OP_AASSIGN: /* Is this a good idea? */
5900 Perl_warner(aTHX_ WARN_DEPRECATED,
5901 "defined(@array) is deprecated");
5902 Perl_warner(aTHX_ WARN_DEPRECATED,
5903 "\t(Maybe you should just omit the defined()?)\n");
5906 /* This is needed for
5907 if (defined %stash::)
5908 to work. Do not break Tk.
5910 break; /* Globals via GV can be undef */
5912 Perl_warner(aTHX_ WARN_DEPRECATED,
5913 "defined(%%hash) is deprecated");
5914 Perl_warner(aTHX_ WARN_DEPRECATED,
5915 "\t(Maybe you should just omit the defined()?)\n");
5926 Perl_ck_rfun(pTHX_ OP *o)
5928 OPCODE type = o->op_type;
5929 return refkids(ck_fun(o), type);
5933 Perl_ck_listiob(pTHX_ OP *o)
5937 kid = cLISTOPo->op_first;
5940 kid = cLISTOPo->op_first;
5942 if (kid->op_type == OP_PUSHMARK)
5943 kid = kid->op_sibling;
5944 if (kid && o->op_flags & OPf_STACKED)
5945 kid = kid->op_sibling;
5946 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5947 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5948 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5949 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5950 cLISTOPo->op_first->op_sibling = kid;
5951 cLISTOPo->op_last = kid;
5952 kid = kid->op_sibling;
5957 append_elem(o->op_type, o, newDEFSVOP());
5963 if (PL_hints & HINT_LOCALE)
5964 o->op_private |= OPpLOCALE;
5971 Perl_ck_fun_locale(pTHX_ OP *o)
5977 if (PL_hints & HINT_LOCALE)
5978 o->op_private |= OPpLOCALE;
5985 Perl_ck_sassign(pTHX_ OP *o)
5987 OP *kid = cLISTOPo->op_first;
5988 /* has a disposable target? */
5989 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5990 && !(kid->op_flags & OPf_STACKED)
5991 /* Cannot steal the second time! */
5992 && !(kid->op_private & OPpTARGET_MY))
5994 OP *kkid = kid->op_sibling;
5996 /* Can just relocate the target. */
5997 if (kkid && kkid->op_type == OP_PADSV
5998 && !(kkid->op_private & OPpLVAL_INTRO))
6000 kid->op_targ = kkid->op_targ;
6002 /* Now we do not need PADSV and SASSIGN. */
6003 kid->op_sibling = o->op_sibling; /* NULL */
6004 cLISTOPo->op_first = NULL;
6007 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6015 Perl_ck_scmp(pTHX_ OP *o)
6019 if (PL_hints & HINT_LOCALE)
6020 o->op_private |= OPpLOCALE;
6027 Perl_ck_match(pTHX_ OP *o)
6029 o->op_private |= OPpRUNTIME;
6034 Perl_ck_method(pTHX_ OP *o)
6036 OP *kid = cUNOPo->op_first;
6037 if (kid->op_type == OP_CONST) {
6038 SV* sv = kSVOP->op_sv;
6039 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6041 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6042 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6045 kSVOP->op_sv = Nullsv;
6047 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6056 Perl_ck_null(pTHX_ OP *o)
6062 Perl_ck_open(pTHX_ OP *o)
6064 HV *table = GvHV(PL_hintgv);
6068 svp = hv_fetch(table, "open_IN", 7, FALSE);
6070 mode = mode_from_discipline(*svp);
6071 if (mode & O_BINARY)
6072 o->op_private |= OPpOPEN_IN_RAW;
6073 else if (mode & O_TEXT)
6074 o->op_private |= OPpOPEN_IN_CRLF;
6077 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6079 mode = mode_from_discipline(*svp);
6080 if (mode & O_BINARY)
6081 o->op_private |= OPpOPEN_OUT_RAW;
6082 else if (mode & O_TEXT)
6083 o->op_private |= OPpOPEN_OUT_CRLF;
6086 if (o->op_type == OP_BACKTICK)
6092 Perl_ck_repeat(pTHX_ OP *o)
6094 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6095 o->op_private |= OPpREPEAT_DOLIST;
6096 cBINOPo->op_first = force_list(cBINOPo->op_first);
6104 Perl_ck_require(pTHX_ OP *o)
6106 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6107 SVOP *kid = (SVOP*)cUNOPo->op_first;
6109 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6111 for (s = SvPVX(kid->op_sv); *s; s++) {
6112 if (*s == ':' && s[1] == ':') {
6114 Move(s+2, s+1, strlen(s+2)+1, char);
6115 --SvCUR(kid->op_sv);
6118 if (SvREADONLY(kid->op_sv)) {
6119 SvREADONLY_off(kid->op_sv);
6120 sv_catpvn(kid->op_sv, ".pm", 3);
6121 SvREADONLY_on(kid->op_sv);
6124 sv_catpvn(kid->op_sv, ".pm", 3);
6131 Perl_ck_return(pTHX_ OP *o)
6134 if (CvLVALUE(PL_compcv)) {
6135 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6136 mod(kid, OP_LEAVESUBLV);
6143 Perl_ck_retarget(pTHX_ OP *o)
6145 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6152 Perl_ck_select(pTHX_ OP *o)
6155 if (o->op_flags & OPf_KIDS) {
6156 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6157 if (kid && kid->op_sibling) {
6158 o->op_type = OP_SSELECT;
6159 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6161 return fold_constants(o);
6165 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6166 if (kid && kid->op_type == OP_RV2GV)
6167 kid->op_private &= ~HINT_STRICT_REFS;
6172 Perl_ck_shift(pTHX_ OP *o)
6174 I32 type = o->op_type;
6176 if (!(o->op_flags & OPf_KIDS)) {
6181 if (!CvUNIQUE(PL_compcv)) {
6182 argop = newOP(OP_PADAV, OPf_REF);
6183 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6186 argop = newUNOP(OP_RV2AV, 0,
6187 scalar(newGVOP(OP_GV, 0,
6188 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6191 argop = newUNOP(OP_RV2AV, 0,
6192 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6193 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6194 #endif /* USE_THREADS */
6195 return newUNOP(type, 0, scalar(argop));
6197 return scalar(modkids(ck_fun(o), type));
6201 Perl_ck_sort(pTHX_ OP *o)
6206 if (PL_hints & HINT_LOCALE)
6207 o->op_private |= OPpLOCALE;
6210 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6212 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6213 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6215 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6217 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6219 if (kid->op_type == OP_SCOPE) {
6223 else if (kid->op_type == OP_LEAVE) {
6224 if (o->op_type == OP_SORT) {
6225 null(kid); /* wipe out leave */
6228 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6229 if (k->op_next == kid)
6231 /* don't descend into loops */
6232 else if (k->op_type == OP_ENTERLOOP
6233 || k->op_type == OP_ENTERITER)
6235 k = cLOOPx(k)->op_lastop;
6240 kid->op_next = 0; /* just disconnect the leave */
6241 k = kLISTOP->op_first;
6246 if (o->op_type == OP_SORT) {
6247 /* provide scalar context for comparison function/block */
6253 o->op_flags |= OPf_SPECIAL;
6255 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6258 firstkid = firstkid->op_sibling;
6261 /* provide list context for arguments */
6262 if (o->op_type == OP_SORT)
6269 S_simplify_sort(pTHX_ OP *o)
6271 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6275 if (!(o->op_flags & OPf_STACKED))
6277 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6278 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6279 kid = kUNOP->op_first; /* get past null */
6280 if (kid->op_type != OP_SCOPE)
6282 kid = kLISTOP->op_last; /* get past scope */
6283 switch(kid->op_type) {
6291 k = kid; /* remember this node*/
6292 if (kBINOP->op_first->op_type != OP_RV2SV)
6294 kid = kBINOP->op_first; /* get past cmp */
6295 if (kUNOP->op_first->op_type != OP_GV)
6297 kid = kUNOP->op_first; /* get past rv2sv */
6299 if (GvSTASH(gv) != PL_curstash)
6301 if (strEQ(GvNAME(gv), "a"))
6303 else if (strEQ(GvNAME(gv), "b"))
6307 kid = k; /* back to cmp */
6308 if (kBINOP->op_last->op_type != OP_RV2SV)
6310 kid = kBINOP->op_last; /* down to 2nd arg */
6311 if (kUNOP->op_first->op_type != OP_GV)
6313 kid = kUNOP->op_first; /* get past rv2sv */
6315 if (GvSTASH(gv) != PL_curstash
6317 ? strNE(GvNAME(gv), "a")
6318 : strNE(GvNAME(gv), "b")))
6320 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6322 o->op_private |= OPpSORT_REVERSE;
6323 if (k->op_type == OP_NCMP)
6324 o->op_private |= OPpSORT_NUMERIC;
6325 if (k->op_type == OP_I_NCMP)
6326 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6327 kid = cLISTOPo->op_first->op_sibling;
6328 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6329 op_free(kid); /* then delete it */
6333 Perl_ck_split(pTHX_ OP *o)
6337 if (o->op_flags & OPf_STACKED)
6338 return no_fh_allowed(o);
6340 kid = cLISTOPo->op_first;
6341 if (kid->op_type != OP_NULL)
6342 Perl_croak(aTHX_ "panic: ck_split");
6343 kid = kid->op_sibling;
6344 op_free(cLISTOPo->op_first);
6345 cLISTOPo->op_first = kid;
6347 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6348 cLISTOPo->op_last = kid; /* There was only one element previously */
6351 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6352 OP *sibl = kid->op_sibling;
6353 kid->op_sibling = 0;
6354 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6355 if (cLISTOPo->op_first == cLISTOPo->op_last)
6356 cLISTOPo->op_last = kid;
6357 cLISTOPo->op_first = kid;
6358 kid->op_sibling = sibl;
6361 kid->op_type = OP_PUSHRE;
6362 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6365 if (!kid->op_sibling)
6366 append_elem(OP_SPLIT, o, newDEFSVOP());
6368 kid = kid->op_sibling;
6371 if (!kid->op_sibling)
6372 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6374 kid = kid->op_sibling;
6377 if (kid->op_sibling)
6378 return too_many_arguments(o,PL_op_desc[o->op_type]);
6384 Perl_ck_join(pTHX_ OP *o)
6386 if (ckWARN(WARN_SYNTAX)) {
6387 OP *kid = cLISTOPo->op_first->op_sibling;
6388 if (kid && kid->op_type == OP_MATCH) {
6389 char *pmstr = "STRING";
6390 if (kPMOP->op_pmregexp)
6391 pmstr = kPMOP->op_pmregexp->precomp;
6392 Perl_warner(aTHX_ WARN_SYNTAX,
6393 "/%s/ should probably be written as \"%s\"",
6401 Perl_ck_subr(pTHX_ OP *o)
6403 OP *prev = ((cUNOPo->op_first->op_sibling)
6404 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6405 OP *o2 = prev->op_sibling;
6414 o->op_private |= OPpENTERSUB_HASTARG;
6415 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6416 if (cvop->op_type == OP_RV2CV) {
6418 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6419 null(cvop); /* disable rv2cv */
6420 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6421 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6422 GV *gv = cGVOPx_gv(tmpop);
6425 tmpop->op_private |= OPpEARLY_CV;
6426 else if (SvPOK(cv)) {
6427 namegv = CvANON(cv) ? gv : CvGV(cv);
6428 proto = SvPV((SV*)cv, n_a);
6432 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6433 if (o2->op_type == OP_CONST)
6434 o2->op_private &= ~OPpCONST_STRICT;
6435 else if (o2->op_type == OP_LIST) {
6436 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6437 if (o && o->op_type == OP_CONST)
6438 o->op_private &= ~OPpCONST_STRICT;
6441 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6442 if (PERLDB_SUB && PL_curstash != PL_debstash)
6443 o->op_private |= OPpENTERSUB_DB;
6444 while (o2 != cvop) {
6448 return too_many_arguments(o, gv_ename(namegv));
6466 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6468 arg == 1 ? "block or sub {}" : "sub {}",
6469 gv_ename(namegv), o2);
6472 /* '*' allows any scalar type, including bareword */
6475 if (o2->op_type == OP_RV2GV)
6476 goto wrapref; /* autoconvert GLOB -> GLOBref */
6477 else if (o2->op_type == OP_CONST)
6478 o2->op_private &= ~OPpCONST_STRICT;
6479 else if (o2->op_type == OP_ENTERSUB) {
6480 /* accidental subroutine, revert to bareword */
6481 OP *gvop = ((UNOP*)o2)->op_first;
6482 if (gvop && gvop->op_type == OP_NULL) {
6483 gvop = ((UNOP*)gvop)->op_first;
6485 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6488 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6489 (gvop = ((UNOP*)gvop)->op_first) &&
6490 gvop->op_type == OP_GV)
6492 GV *gv = cGVOPx_gv(gvop);
6493 OP *sibling = o2->op_sibling;
6494 SV *n = newSVpvn("",0);
6496 gv_fullname3(n, gv, "");
6497 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6498 sv_chop(n, SvPVX(n)+6);
6499 o2 = newSVOP(OP_CONST, 0, n);
6500 prev->op_sibling = o2;
6501 o2->op_sibling = sibling;
6513 if (o2->op_type != OP_RV2GV)
6514 bad_type(arg, "symbol", gv_ename(namegv), o2);
6517 if (o2->op_type != OP_ENTERSUB)
6518 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6521 if (o2->op_type != OP_RV2SV
6522 && o2->op_type != OP_PADSV
6523 && o2->op_type != OP_HELEM
6524 && o2->op_type != OP_AELEM
6525 && o2->op_type != OP_THREADSV)
6527 bad_type(arg, "scalar", gv_ename(namegv), o2);
6531 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6532 bad_type(arg, "array", gv_ename(namegv), o2);
6535 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6536 bad_type(arg, "hash", gv_ename(namegv), o2);
6540 OP* sib = kid->op_sibling;
6541 kid->op_sibling = 0;
6542 o2 = newUNOP(OP_REFGEN, 0, kid);
6543 o2->op_sibling = sib;
6544 prev->op_sibling = o2;
6555 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6556 gv_ename(namegv), SvPV((SV*)cv, n_a));
6561 mod(o2, OP_ENTERSUB);
6563 o2 = o2->op_sibling;
6565 if (proto && !optional &&
6566 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6567 return too_few_arguments(o, gv_ename(namegv));
6572 Perl_ck_svconst(pTHX_ OP *o)
6574 SvREADONLY_on(cSVOPo->op_sv);
6579 Perl_ck_trunc(pTHX_ OP *o)
6581 if (o->op_flags & OPf_KIDS) {
6582 SVOP *kid = (SVOP*)cUNOPo->op_first;
6584 if (kid->op_type == OP_NULL)
6585 kid = (SVOP*)kid->op_sibling;
6586 if (kid && kid->op_type == OP_CONST &&
6587 (kid->op_private & OPpCONST_BARE))
6589 o->op_flags |= OPf_SPECIAL;
6590 kid->op_private &= ~OPpCONST_STRICT;
6597 Perl_ck_substr(pTHX_ OP *o)
6600 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6601 OP *kid = cLISTOPo->op_first;
6603 if (kid->op_type == OP_NULL)
6604 kid = kid->op_sibling;
6606 kid->op_flags |= OPf_MOD;
6612 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6615 Perl_peep(pTHX_ register OP *o)
6617 register OP* oldop = 0;
6620 if (!o || o->op_seq)
6624 SAVEVPTR(PL_curcop);
6625 for (; o; o = o->op_next) {
6631 switch (o->op_type) {
6635 PL_curcop = ((COP*)o); /* for warnings */
6636 o->op_seq = PL_op_seqmax++;
6640 if (cSVOPo->op_private & OPpCONST_STRICT)
6641 no_bareword_allowed(o);
6643 /* Relocate sv to the pad for thread safety.
6644 * Despite being a "constant", the SV is written to,
6645 * for reference counts, sv_upgrade() etc. */
6647 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6648 if (SvPADTMP(cSVOPo->op_sv)) {
6649 /* If op_sv is already a PADTMP then it is being used by
6650 * some pad, so make a copy. */
6651 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6652 SvREADONLY_on(PL_curpad[ix]);
6653 SvREFCNT_dec(cSVOPo->op_sv);
6656 SvREFCNT_dec(PL_curpad[ix]);
6657 SvPADTMP_on(cSVOPo->op_sv);
6658 PL_curpad[ix] = cSVOPo->op_sv;
6659 /* XXX I don't know how this isn't readonly already. */
6660 SvREADONLY_on(PL_curpad[ix]);
6662 cSVOPo->op_sv = Nullsv;
6666 o->op_seq = PL_op_seqmax++;
6670 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6671 if (o->op_next->op_private & OPpTARGET_MY) {
6672 if (o->op_flags & OPf_STACKED) /* chained concats */
6673 goto ignore_optimization;
6675 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6676 o->op_targ = o->op_next->op_targ;
6677 o->op_next->op_targ = 0;
6678 o->op_private |= OPpTARGET_MY;
6683 ignore_optimization:
6684 o->op_seq = PL_op_seqmax++;
6687 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6688 o->op_seq = PL_op_seqmax++;
6689 break; /* Scalar stub must produce undef. List stub is noop */
6693 if (o->op_targ == OP_NEXTSTATE
6694 || o->op_targ == OP_DBSTATE
6695 || o->op_targ == OP_SETSTATE)
6697 PL_curcop = ((COP*)o);
6704 if (oldop && o->op_next) {
6705 oldop->op_next = o->op_next;
6708 o->op_seq = PL_op_seqmax++;
6712 if (o->op_next->op_type == OP_RV2SV) {
6713 if (!(o->op_next->op_private & OPpDEREF)) {
6715 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6717 o->op_next = o->op_next->op_next;
6718 o->op_type = OP_GVSV;
6719 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6722 else if (o->op_next->op_type == OP_RV2AV) {
6723 OP* pop = o->op_next->op_next;
6725 if (pop->op_type == OP_CONST &&
6726 (PL_op = pop->op_next) &&
6727 pop->op_next->op_type == OP_AELEM &&
6728 !(pop->op_next->op_private &
6729 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6730 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6738 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6739 o->op_next = pop->op_next->op_next;
6740 o->op_type = OP_AELEMFAST;
6741 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6742 o->op_private = (U8)i;
6747 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6749 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6750 /* XXX could check prototype here instead of just carping */
6751 SV *sv = sv_newmortal();
6752 gv_efullname3(sv, gv, Nullch);
6753 Perl_warner(aTHX_ WARN_PROTOTYPE,
6754 "%s() called too early to check prototype",
6759 o->op_seq = PL_op_seqmax++;
6770 o->op_seq = PL_op_seqmax++;
6771 while (cLOGOP->op_other->op_type == OP_NULL)
6772 cLOGOP->op_other = cLOGOP->op_other->op_next;
6773 peep(cLOGOP->op_other);
6777 o->op_seq = PL_op_seqmax++;
6778 while (cLOOP->op_redoop->op_type == OP_NULL)
6779 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6780 peep(cLOOP->op_redoop);
6781 while (cLOOP->op_nextop->op_type == OP_NULL)
6782 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6783 peep(cLOOP->op_nextop);
6784 while (cLOOP->op_lastop->op_type == OP_NULL)
6785 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6786 peep(cLOOP->op_lastop);
6792 o->op_seq = PL_op_seqmax++;
6793 while (cPMOP->op_pmreplstart &&
6794 cPMOP->op_pmreplstart->op_type == OP_NULL)
6795 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6796 peep(cPMOP->op_pmreplstart);
6800 o->op_seq = PL_op_seqmax++;
6801 if (ckWARN(WARN_SYNTAX) && o->op_next
6802 && o->op_next->op_type == OP_NEXTSTATE) {
6803 if (o->op_next->op_sibling &&
6804 o->op_next->op_sibling->op_type != OP_EXIT &&
6805 o->op_next->op_sibling->op_type != OP_WARN &&
6806 o->op_next->op_sibling->op_type != OP_DIE) {
6807 line_t oldline = CopLINE(PL_curcop);
6809 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6810 Perl_warner(aTHX_ WARN_EXEC,
6811 "Statement unlikely to be reached");
6812 Perl_warner(aTHX_ WARN_EXEC,
6813 "\t(Maybe you meant system() when you said exec()?)\n");
6814 CopLINE_set(PL_curcop, oldline);
6823 SV **svp, **indsvp, *sv;
6828 o->op_seq = PL_op_seqmax++;
6830 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6833 /* Make the CONST have a shared SV */
6834 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6835 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6836 key = SvPV(sv, keylen);
6839 lexname = newSVpvn_share(key, keylen, 0);
6844 if ((o->op_private & (OPpLVAL_INTRO)))
6847 rop = (UNOP*)((BINOP*)o)->op_first;
6848 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6850 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6851 if (!SvOBJECT(lexname))
6853 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6854 if (!fields || !GvHV(*fields))
6856 key = SvPV(*svp, keylen);
6859 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6861 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6862 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6864 ind = SvIV(*indsvp);
6866 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6867 rop->op_type = OP_RV2AV;
6868 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6869 o->op_type = OP_AELEM;
6870 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6872 if (SvREADONLY(*svp))
6874 SvFLAGS(sv) |= (SvFLAGS(*svp)
6875 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6885 SV **svp, **indsvp, *sv;
6889 SVOP *first_key_op, *key_op;
6891 o->op_seq = PL_op_seqmax++;
6892 if ((o->op_private & (OPpLVAL_INTRO))
6893 /* I bet there's always a pushmark... */
6894 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6895 /* hmmm, no optimization if list contains only one key. */
6897 rop = (UNOP*)((LISTOP*)o)->op_last;
6898 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6900 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6901 if (!SvOBJECT(lexname))
6903 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6904 if (!fields || !GvHV(*fields))
6906 /* Again guessing that the pushmark can be jumped over.... */
6907 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6908 ->op_first->op_sibling;
6909 /* Check that the key list contains only constants. */
6910 for (key_op = first_key_op; key_op;
6911 key_op = (SVOP*)key_op->op_sibling)
6912 if (key_op->op_type != OP_CONST)
6916 rop->op_type = OP_RV2AV;
6917 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6918 o->op_type = OP_ASLICE;
6919 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6920 for (key_op = first_key_op; key_op;
6921 key_op = (SVOP*)key_op->op_sibling) {
6922 svp = cSVOPx_svp(key_op);
6923 key = SvPV(*svp, keylen);
6926 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6928 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6929 "in variable %s of type %s",
6930 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6932 ind = SvIV(*indsvp);
6934 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6936 if (SvREADONLY(*svp))
6938 SvFLAGS(sv) |= (SvFLAGS(*svp)
6939 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6947 o->op_seq = PL_op_seqmax++;
6957 /* Efficient sub that returns a constant scalar value. */
6959 const_sv_xsub(pTHXo_ CV* cv)
6963 ST(0) = (SV*)XSANY.any_ptr;