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);
847 HV *pmstash = PmopSTASH(cPMOPo);
848 if (pmstash && SvREFCNT(pmstash)) {
849 PMOP *pmop = HvPMROOT(pmstash);
850 PMOP *lastpmop = NULL;
852 if (cPMOPo == pmop) {
854 lastpmop->op_pmnext = pmop->op_pmnext;
856 HvPMROOT(pmstash) = pmop->op_pmnext;
860 pmop = pmop->op_pmnext;
863 Safefree(PmopSTASHPV(cPMOPo));
865 /* NOTE: PMOP.op_pmstash is not refcounted */
869 cPMOPo->op_pmreplroot = Nullop;
870 ReREFCNT_dec(cPMOPo->op_pmregexp);
871 cPMOPo->op_pmregexp = (REGEXP*)NULL;
875 if (o->op_targ > 0) {
876 pad_free(o->op_targ);
882 S_cop_free(pTHX_ COP* cop)
884 Safefree(cop->cop_label);
886 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
887 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
889 /* NOTE: COP.cop_stash is not refcounted */
890 SvREFCNT_dec(CopFILEGV(cop));
892 if (! specialWARN(cop->cop_warnings))
893 SvREFCNT_dec(cop->cop_warnings);
894 if (! specialCopIO(cop->cop_io))
895 SvREFCNT_dec(cop->cop_io);
901 if (o->op_type == OP_NULL)
904 o->op_targ = o->op_type;
905 o->op_type = OP_NULL;
906 o->op_ppaddr = PL_ppaddr[OP_NULL];
909 /* Contextualizers */
911 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
914 Perl_linklist(pTHX_ OP *o)
921 /* establish postfix order */
922 if (cUNOPo->op_first) {
923 o->op_next = LINKLIST(cUNOPo->op_first);
924 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
926 kid->op_next = LINKLIST(kid->op_sibling);
938 Perl_scalarkids(pTHX_ OP *o)
941 if (o && o->op_flags & OPf_KIDS) {
942 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
949 S_scalarboolean(pTHX_ OP *o)
951 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
952 if (ckWARN(WARN_SYNTAX)) {
953 line_t oldline = CopLINE(PL_curcop);
955 if (PL_copline != NOLINE)
956 CopLINE_set(PL_curcop, PL_copline);
957 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
958 CopLINE_set(PL_curcop, oldline);
965 Perl_scalar(pTHX_ OP *o)
969 /* assumes no premature commitment */
970 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
971 || o->op_type == OP_RETURN)
976 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
978 switch (o->op_type) {
980 if (o->op_private & OPpREPEAT_DOLIST)
981 null(((LISTOP*)cBINOPo->op_first)->op_first);
982 scalar(cBINOPo->op_first);
987 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
991 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
992 if (!kPMOP->op_pmreplroot)
993 deprecate("implicit split to @_");
1001 if (o->op_flags & OPf_KIDS) {
1002 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1008 kid = cLISTOPo->op_first;
1010 while ((kid = kid->op_sibling)) {
1011 if (kid->op_sibling)
1016 WITH_THR(PL_curcop = &PL_compiling);
1021 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1022 if (kid->op_sibling)
1027 WITH_THR(PL_curcop = &PL_compiling);
1034 Perl_scalarvoid(pTHX_ OP *o)
1041 if (o->op_type == OP_NEXTSTATE
1042 || o->op_type == OP_SETSTATE
1043 || o->op_type == OP_DBSTATE
1044 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1045 || o->op_targ == OP_SETSTATE
1046 || o->op_targ == OP_DBSTATE)))
1047 PL_curcop = (COP*)o; /* for warning below */
1049 /* assumes no premature commitment */
1050 want = o->op_flags & OPf_WANT;
1051 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1052 || o->op_type == OP_RETURN)
1057 if ((o->op_private & OPpTARGET_MY)
1058 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1060 return scalar(o); /* As if inside SASSIGN */
1063 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1065 switch (o->op_type) {
1067 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1071 if (o->op_flags & OPf_STACKED)
1075 if (o->op_private == 4)
1117 case OP_GETSOCKNAME:
1118 case OP_GETPEERNAME:
1123 case OP_GETPRIORITY:
1146 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1147 useless = PL_op_desc[o->op_type];
1154 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1155 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1156 useless = "a variable";
1161 if (cSVOPo->op_private & OPpCONST_STRICT)
1162 no_bareword_allowed(o);
1164 if (ckWARN(WARN_VOID)) {
1165 useless = "a constant";
1166 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1168 else if (SvPOK(sv)) {
1169 /* perl4's way of mixing documentation and code
1170 (before the invention of POD) was based on a
1171 trick to mix nroff and perl code. The trick was
1172 built upon these three nroff macros being used in
1173 void context. The pink camel has the details in
1174 the script wrapman near page 319. */
1175 if (strnEQ(SvPVX(sv), "di", 2) ||
1176 strnEQ(SvPVX(sv), "ds", 2) ||
1177 strnEQ(SvPVX(sv), "ig", 2))
1182 null(o); /* don't execute or even remember it */
1186 o->op_type = OP_PREINC; /* pre-increment is faster */
1187 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1191 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1192 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1198 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1203 if (o->op_flags & OPf_STACKED)
1210 if (!(o->op_flags & OPf_KIDS))
1219 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1226 /* all requires must return a boolean value */
1227 o->op_flags &= ~OPf_WANT;
1232 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1233 if (!kPMOP->op_pmreplroot)
1234 deprecate("implicit split to @_");
1238 if (useless && ckWARN(WARN_VOID))
1239 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1244 Perl_listkids(pTHX_ OP *o)
1247 if (o && o->op_flags & OPf_KIDS) {
1248 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1255 Perl_list(pTHX_ OP *o)
1259 /* assumes no premature commitment */
1260 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1261 || o->op_type == OP_RETURN)
1266 if ((o->op_private & OPpTARGET_MY)
1267 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1269 return o; /* As if inside SASSIGN */
1272 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1274 switch (o->op_type) {
1277 list(cBINOPo->op_first);
1282 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1290 if (!(o->op_flags & OPf_KIDS))
1292 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1293 list(cBINOPo->op_first);
1294 return gen_constant_list(o);
1301 kid = cLISTOPo->op_first;
1303 while ((kid = kid->op_sibling)) {
1304 if (kid->op_sibling)
1309 WITH_THR(PL_curcop = &PL_compiling);
1313 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1314 if (kid->op_sibling)
1319 WITH_THR(PL_curcop = &PL_compiling);
1322 /* all requires must return a boolean value */
1323 o->op_flags &= ~OPf_WANT;
1330 Perl_scalarseq(pTHX_ OP *o)
1335 if (o->op_type == OP_LINESEQ ||
1336 o->op_type == OP_SCOPE ||
1337 o->op_type == OP_LEAVE ||
1338 o->op_type == OP_LEAVETRY)
1340 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1341 if (kid->op_sibling) {
1345 PL_curcop = &PL_compiling;
1347 o->op_flags &= ~OPf_PARENS;
1348 if (PL_hints & HINT_BLOCK_SCOPE)
1349 o->op_flags |= OPf_PARENS;
1352 o = newOP(OP_STUB, 0);
1357 S_modkids(pTHX_ OP *o, I32 type)
1360 if (o && o->op_flags & OPf_KIDS) {
1361 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1368 Perl_mod(pTHX_ OP *o, I32 type)
1373 if (!o || PL_error_count)
1376 if ((o->op_private & OPpTARGET_MY)
1377 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1382 switch (o->op_type) {
1387 if (o->op_private & (OPpCONST_BARE) &&
1388 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1389 SV *sv = ((SVOP*)o)->op_sv;
1392 /* Could be a filehandle */
1393 if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1394 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1398 /* OK, it's a sub */
1400 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1402 enter = newUNOP(OP_ENTERSUB,0,
1403 newUNOP(OP_RV2CV, 0,
1404 newGVOP(OP_GV, 0, gv)
1406 enter->op_private |= OPpLVAL_INTRO;
1412 if (!(o->op_private & (OPpCONST_ARYBASE)))
1414 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1415 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1419 SAVEI32(PL_compiling.cop_arybase);
1420 PL_compiling.cop_arybase = 0;
1422 else if (type == OP_REFGEN)
1425 Perl_croak(aTHX_ "That use of $[ is unsupported");
1428 if (o->op_flags & OPf_PARENS)
1432 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1433 !(o->op_flags & OPf_STACKED)) {
1434 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1435 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1436 assert(cUNOPo->op_first->op_type == OP_NULL);
1437 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1440 else { /* lvalue subroutine call */
1441 o->op_private |= OPpLVAL_INTRO;
1442 PL_modcount = RETURN_UNLIMITED_NUMBER;
1443 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1444 /* Backward compatibility mode: */
1445 o->op_private |= OPpENTERSUB_INARGS;
1448 else { /* Compile-time error message: */
1449 OP *kid = cUNOPo->op_first;
1453 if (kid->op_type == OP_PUSHMARK)
1455 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1457 "panic: unexpected lvalue entersub "
1458 "args: type/targ %ld:%ld",
1459 (long)kid->op_type,kid->op_targ);
1460 kid = kLISTOP->op_first;
1462 while (kid->op_sibling)
1463 kid = kid->op_sibling;
1464 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1466 if (kid->op_type == OP_METHOD_NAMED
1467 || kid->op_type == OP_METHOD)
1471 if (kid->op_sibling || kid->op_next != kid) {
1472 yyerror("panic: unexpected optree near method call");
1476 NewOp(1101, newop, 1, UNOP);
1477 newop->op_type = OP_RV2CV;
1478 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1479 newop->op_first = Nullop;
1480 newop->op_next = (OP*)newop;
1481 kid->op_sibling = (OP*)newop;
1482 newop->op_private |= OPpLVAL_INTRO;
1486 if (kid->op_type != OP_RV2CV)
1488 "panic: unexpected lvalue entersub "
1489 "entry via type/targ %ld:%ld",
1490 (long)kid->op_type,kid->op_targ);
1491 kid->op_private |= OPpLVAL_INTRO;
1492 break; /* Postpone until runtime */
1496 kid = kUNOP->op_first;
1497 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1498 kid = kUNOP->op_first;
1499 if (kid->op_type == OP_NULL)
1501 "Unexpected constant lvalue entersub "
1502 "entry via type/targ %ld:%ld",
1503 (long)kid->op_type,kid->op_targ);
1504 if (kid->op_type != OP_GV) {
1505 /* Restore RV2CV to check lvalueness */
1507 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1508 okid->op_next = kid->op_next;
1509 kid->op_next = okid;
1512 okid->op_next = Nullop;
1513 okid->op_type = OP_RV2CV;
1515 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1516 okid->op_private |= OPpLVAL_INTRO;
1520 cv = GvCV(kGVOP_gv);
1530 /* grep, foreach, subcalls, refgen */
1531 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1533 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1534 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1536 : (o->op_type == OP_ENTERSUB
1537 ? "non-lvalue subroutine call"
1538 : PL_op_desc[o->op_type])),
1539 type ? PL_op_desc[type] : "local"));
1553 case OP_RIGHT_SHIFT:
1562 if (!(o->op_flags & OPf_STACKED))
1568 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1574 if (!type && cUNOPo->op_first->op_type != OP_GV)
1575 Perl_croak(aTHX_ "Can't localize through a reference");
1576 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1577 PL_modcount = RETURN_UNLIMITED_NUMBER;
1578 return o; /* Treat \(@foo) like ordinary list. */
1582 if (scalar_mod_type(o, type))
1584 ref(cUNOPo->op_first, o->op_type);
1588 if (type == OP_LEAVESUBLV)
1589 o->op_private |= OPpMAYBE_LVSUB;
1595 PL_modcount = RETURN_UNLIMITED_NUMBER;
1598 if (!type && cUNOPo->op_first->op_type != OP_GV)
1599 Perl_croak(aTHX_ "Can't localize through a reference");
1600 ref(cUNOPo->op_first, o->op_type);
1604 PL_hints |= HINT_BLOCK_SCOPE;
1614 PL_modcount = RETURN_UNLIMITED_NUMBER;
1615 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1616 return o; /* Treat \(@foo) like ordinary list. */
1617 if (scalar_mod_type(o, type))
1619 if (type == OP_LEAVESUBLV)
1620 o->op_private |= OPpMAYBE_LVSUB;
1625 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1626 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1631 PL_modcount++; /* XXX ??? */
1633 #endif /* USE_THREADS */
1639 if (type != OP_SASSIGN)
1643 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1648 if (type == OP_LEAVESUBLV)
1649 o->op_private |= OPpMAYBE_LVSUB;
1651 pad_free(o->op_targ);
1652 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1653 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1654 if (o->op_flags & OPf_KIDS)
1655 mod(cBINOPo->op_first->op_sibling, type);
1660 ref(cBINOPo->op_first, o->op_type);
1661 if (type == OP_ENTERSUB &&
1662 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1663 o->op_private |= OPpLVAL_DEFER;
1664 if (type == OP_LEAVESUBLV)
1665 o->op_private |= OPpMAYBE_LVSUB;
1673 if (o->op_flags & OPf_KIDS)
1674 mod(cLISTOPo->op_last, type);
1678 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1680 else if (!(o->op_flags & OPf_KIDS))
1682 if (o->op_targ != OP_LIST) {
1683 mod(cBINOPo->op_first, type);
1688 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1693 if (type != OP_LEAVESUBLV)
1695 break; /* mod()ing was handled by ck_return() */
1697 if (type != OP_LEAVESUBLV)
1698 o->op_flags |= OPf_MOD;
1700 if (type == OP_AASSIGN || type == OP_SASSIGN)
1701 o->op_flags |= OPf_SPECIAL|OPf_REF;
1703 o->op_private |= OPpLVAL_INTRO;
1704 o->op_flags &= ~OPf_SPECIAL;
1705 PL_hints |= HINT_BLOCK_SCOPE;
1707 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1708 && type != OP_LEAVESUBLV)
1709 o->op_flags |= OPf_REF;
1714 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1718 if (o->op_type == OP_RV2GV)
1742 case OP_RIGHT_SHIFT:
1761 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1763 switch (o->op_type) {
1771 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1784 Perl_refkids(pTHX_ OP *o, I32 type)
1787 if (o && o->op_flags & OPf_KIDS) {
1788 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1795 Perl_ref(pTHX_ OP *o, I32 type)
1799 if (!o || PL_error_count)
1802 switch (o->op_type) {
1804 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1805 !(o->op_flags & OPf_STACKED)) {
1806 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1807 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1808 assert(cUNOPo->op_first->op_type == OP_NULL);
1809 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1810 o->op_flags |= OPf_SPECIAL;
1815 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1819 if (type == OP_DEFINED)
1820 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1821 ref(cUNOPo->op_first, o->op_type);
1824 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1825 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1826 : type == OP_RV2HV ? OPpDEREF_HV
1828 o->op_flags |= OPf_MOD;
1833 o->op_flags |= OPf_MOD; /* XXX ??? */
1838 o->op_flags |= OPf_REF;
1841 if (type == OP_DEFINED)
1842 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1843 ref(cUNOPo->op_first, o->op_type);
1848 o->op_flags |= OPf_REF;
1853 if (!(o->op_flags & OPf_KIDS))
1855 ref(cBINOPo->op_first, type);
1859 ref(cBINOPo->op_first, o->op_type);
1860 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1861 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1862 : type == OP_RV2HV ? OPpDEREF_HV
1864 o->op_flags |= OPf_MOD;
1872 if (!(o->op_flags & OPf_KIDS))
1874 ref(cLISTOPo->op_last, type);
1884 S_dup_attrlist(pTHX_ OP *o)
1888 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1889 * where the first kid is OP_PUSHMARK and the remaining ones
1890 * are OP_CONST. We need to push the OP_CONST values.
1892 if (o->op_type == OP_CONST)
1893 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1895 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1896 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1897 if (o->op_type == OP_CONST)
1898 rop = append_elem(OP_LIST, rop,
1899 newSVOP(OP_CONST, o->op_flags,
1900 SvREFCNT_inc(cSVOPo->op_sv)));
1907 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1911 /* fake up C<use attributes $pkg,$rv,@attrs> */
1912 ENTER; /* need to protect against side-effects of 'use' */
1914 if (stash && HvNAME(stash))
1915 stashsv = newSVpv(HvNAME(stash), 0);
1917 stashsv = &PL_sv_no;
1919 #define ATTRSMODULE "attributes"
1921 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1922 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1924 prepend_elem(OP_LIST,
1925 newSVOP(OP_CONST, 0, stashsv),
1926 prepend_elem(OP_LIST,
1927 newSVOP(OP_CONST, 0,
1929 dup_attrlist(attrs))));
1934 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1935 char *attrstr, STRLEN len)
1940 len = strlen(attrstr);
1944 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1946 char *sstr = attrstr;
1947 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1948 attrs = append_elem(OP_LIST, attrs,
1949 newSVOP(OP_CONST, 0,
1950 newSVpvn(sstr, attrstr-sstr)));
1954 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1955 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1956 Nullsv, prepend_elem(OP_LIST,
1957 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1958 prepend_elem(OP_LIST,
1959 newSVOP(OP_CONST, 0,
1965 S_my_kid(pTHX_ OP *o, OP *attrs)
1970 if (!o || PL_error_count)
1974 if (type == OP_LIST) {
1975 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1977 } else if (type == OP_UNDEF) {
1979 } else if (type == OP_RV2SV || /* "our" declaration */
1981 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1983 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1985 PL_in_my_stash = Nullhv;
1986 apply_attrs(GvSTASH(gv),
1987 (type == OP_RV2SV ? GvSV(gv) :
1988 type == OP_RV2AV ? (SV*)GvAV(gv) :
1989 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1992 o->op_private |= OPpOUR_INTRO;
1994 } else if (type != OP_PADSV &&
1997 type != OP_PUSHMARK)
1999 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2000 PL_op_desc[o->op_type],
2001 PL_in_my == KEY_our ? "our" : "my"));
2004 else if (attrs && type != OP_PUSHMARK) {
2010 PL_in_my_stash = Nullhv;
2012 /* check for C<my Dog $spot> when deciding package */
2013 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2014 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
2015 stash = SvSTASH(*namesvp);
2017 stash = PL_curstash;
2018 padsv = PAD_SV(o->op_targ);
2019 apply_attrs(stash, padsv, attrs);
2021 o->op_flags |= OPf_MOD;
2022 o->op_private |= OPpLVAL_INTRO;
2027 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2029 if (o->op_flags & OPf_PARENS)
2033 o = my_kid(o, attrs);
2035 PL_in_my_stash = Nullhv;
2040 Perl_my(pTHX_ OP *o)
2042 return my_kid(o, Nullop);
2046 Perl_sawparens(pTHX_ OP *o)
2049 o->op_flags |= OPf_PARENS;
2054 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2058 if (ckWARN(WARN_MISC) &&
2059 (left->op_type == OP_RV2AV ||
2060 left->op_type == OP_RV2HV ||
2061 left->op_type == OP_PADAV ||
2062 left->op_type == OP_PADHV)) {
2063 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2064 right->op_type == OP_TRANS)
2065 ? right->op_type : OP_MATCH];
2066 const char *sample = ((left->op_type == OP_RV2AV ||
2067 left->op_type == OP_PADAV)
2068 ? "@array" : "%hash");
2069 Perl_warner(aTHX_ WARN_MISC,
2070 "Applying %s to %s will act on scalar(%s)",
2071 desc, sample, sample);
2074 if (!(right->op_flags & OPf_STACKED) &&
2075 (right->op_type == OP_MATCH ||
2076 right->op_type == OP_SUBST ||
2077 right->op_type == OP_TRANS)) {
2078 right->op_flags |= OPf_STACKED;
2079 if (right->op_type != OP_MATCH &&
2080 ! (right->op_type == OP_TRANS &&
2081 right->op_private & OPpTRANS_IDENTICAL))
2082 left = mod(left, right->op_type);
2083 if (right->op_type == OP_TRANS)
2084 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2086 o = prepend_elem(right->op_type, scalar(left), right);
2088 return newUNOP(OP_NOT, 0, scalar(o));
2092 return bind_match(type, left,
2093 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2097 Perl_invert(pTHX_ OP *o)
2101 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2102 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2106 Perl_scope(pTHX_ OP *o)
2109 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2110 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2111 o->op_type = OP_LEAVE;
2112 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2115 if (o->op_type == OP_LINESEQ) {
2117 o->op_type = OP_SCOPE;
2118 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2119 kid = ((LISTOP*)o)->op_first;
2120 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2124 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2131 Perl_save_hints(pTHX)
2134 SAVESPTR(GvHV(PL_hintgv));
2135 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2136 SAVEFREESV(GvHV(PL_hintgv));
2140 Perl_block_start(pTHX_ int full)
2142 int retval = PL_savestack_ix;
2144 SAVEI32(PL_comppad_name_floor);
2145 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2147 PL_comppad_name_fill = PL_comppad_name_floor;
2148 if (PL_comppad_name_floor < 0)
2149 PL_comppad_name_floor = 0;
2150 SAVEI32(PL_min_intro_pending);
2151 SAVEI32(PL_max_intro_pending);
2152 PL_min_intro_pending = 0;
2153 SAVEI32(PL_comppad_name_fill);
2154 SAVEI32(PL_padix_floor);
2155 PL_padix_floor = PL_padix;
2156 PL_pad_reset_pending = FALSE;
2158 PL_hints &= ~HINT_BLOCK_SCOPE;
2159 SAVESPTR(PL_compiling.cop_warnings);
2160 if (! specialWARN(PL_compiling.cop_warnings)) {
2161 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2162 SAVEFREESV(PL_compiling.cop_warnings) ;
2164 SAVESPTR(PL_compiling.cop_io);
2165 if (! specialCopIO(PL_compiling.cop_io)) {
2166 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2167 SAVEFREESV(PL_compiling.cop_io) ;
2173 Perl_block_end(pTHX_ I32 floor, OP *seq)
2175 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2176 OP* retval = scalarseq(seq);
2178 PL_pad_reset_pending = FALSE;
2179 PL_compiling.op_private = PL_hints;
2181 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2182 pad_leavemy(PL_comppad_name_fill);
2191 OP *o = newOP(OP_THREADSV, 0);
2192 o->op_targ = find_threadsv("_");
2195 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2196 #endif /* USE_THREADS */
2200 Perl_newPROG(pTHX_ OP *o)
2205 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2206 ((PL_in_eval & EVAL_KEEPERR)
2207 ? OPf_SPECIAL : 0), o);
2208 PL_eval_start = linklist(PL_eval_root);
2209 PL_eval_root->op_private |= OPpREFCOUNTED;
2210 OpREFCNT_set(PL_eval_root, 1);
2211 PL_eval_root->op_next = 0;
2212 peep(PL_eval_start);
2217 PL_main_root = scope(sawparens(scalarvoid(o)));
2218 PL_curcop = &PL_compiling;
2219 PL_main_start = LINKLIST(PL_main_root);
2220 PL_main_root->op_private |= OPpREFCOUNTED;
2221 OpREFCNT_set(PL_main_root, 1);
2222 PL_main_root->op_next = 0;
2223 peep(PL_main_start);
2226 /* Register with debugger */
2228 CV *cv = get_cv("DB::postponed", FALSE);
2232 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2234 call_sv((SV*)cv, G_DISCARD);
2241 Perl_localize(pTHX_ OP *o, I32 lex)
2243 if (o->op_flags & OPf_PARENS)
2246 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2248 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2249 if (*s == ';' || *s == '=')
2250 Perl_warner(aTHX_ WARN_PARENTHESIS,
2251 "Parentheses missing around \"%s\" list",
2252 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2258 o = mod(o, OP_NULL); /* a bit kludgey */
2260 PL_in_my_stash = Nullhv;
2265 Perl_jmaybe(pTHX_ OP *o)
2267 if (o->op_type == OP_LIST) {
2270 o2 = newOP(OP_THREADSV, 0);
2271 o2->op_targ = find_threadsv(";");
2273 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2274 #endif /* USE_THREADS */
2275 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2281 Perl_fold_constants(pTHX_ register OP *o)
2284 I32 type = o->op_type;
2287 if (PL_opargs[type] & OA_RETSCALAR)
2289 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2290 o->op_targ = pad_alloc(type, SVs_PADTMP);
2292 /* integerize op, unless it happens to be C<-foo>.
2293 * XXX should pp_i_negate() do magic string negation instead? */
2294 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2295 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2296 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2298 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2301 if (!(PL_opargs[type] & OA_FOLDCONST))
2306 /* XXX might want a ck_negate() for this */
2307 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2320 if (o->op_private & OPpLOCALE)
2325 goto nope; /* Don't try to run w/ errors */
2327 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2328 if ((curop->op_type != OP_CONST ||
2329 (curop->op_private & OPpCONST_BARE)) &&
2330 curop->op_type != OP_LIST &&
2331 curop->op_type != OP_SCALAR &&
2332 curop->op_type != OP_NULL &&
2333 curop->op_type != OP_PUSHMARK)
2339 curop = LINKLIST(o);
2343 sv = *(PL_stack_sp--);
2344 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2345 pad_swipe(o->op_targ);
2346 else if (SvTEMP(sv)) { /* grab mortal temp? */
2347 (void)SvREFCNT_inc(sv);
2351 if (type == OP_RV2GV)
2352 return newGVOP(OP_GV, 0, (GV*)sv);
2354 /* try to smush double to int, but don't smush -2.0 to -2 */
2355 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2358 #ifdef PERL_PRESERVE_IVUV
2359 /* Only bother to attempt to fold to IV if
2360 most operators will benefit */
2364 return newSVOP(OP_CONST, 0, sv);
2368 if (!(PL_opargs[type] & OA_OTHERINT))
2371 if (!(PL_hints & HINT_INTEGER)) {
2372 if (type == OP_MODULO
2373 || type == OP_DIVIDE
2374 || !(o->op_flags & OPf_KIDS))
2379 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2380 if (curop->op_type == OP_CONST) {
2381 if (SvIOK(((SVOP*)curop)->op_sv))
2385 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2389 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2396 Perl_gen_constant_list(pTHX_ register OP *o)
2399 I32 oldtmps_floor = PL_tmps_floor;
2403 return o; /* Don't attempt to run with errors */
2405 PL_op = curop = LINKLIST(o);
2412 PL_tmps_floor = oldtmps_floor;
2414 o->op_type = OP_RV2AV;
2415 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2416 curop = ((UNOP*)o)->op_first;
2417 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2424 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2426 if (!o || o->op_type != OP_LIST)
2427 o = newLISTOP(OP_LIST, 0, o, Nullop);
2429 o->op_flags &= ~OPf_WANT;
2431 if (!(PL_opargs[type] & OA_MARK))
2432 null(cLISTOPo->op_first);
2435 o->op_ppaddr = PL_ppaddr[type];
2436 o->op_flags |= flags;
2438 o = CHECKOP(type, o);
2439 if (o->op_type != type)
2442 return fold_constants(o);
2445 /* List constructors */
2448 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2456 if (first->op_type != type
2457 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2459 return newLISTOP(type, 0, first, last);
2462 if (first->op_flags & OPf_KIDS)
2463 ((LISTOP*)first)->op_last->op_sibling = last;
2465 first->op_flags |= OPf_KIDS;
2466 ((LISTOP*)first)->op_first = last;
2468 ((LISTOP*)first)->op_last = last;
2473 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2481 if (first->op_type != type)
2482 return prepend_elem(type, (OP*)first, (OP*)last);
2484 if (last->op_type != type)
2485 return append_elem(type, (OP*)first, (OP*)last);
2487 first->op_last->op_sibling = last->op_first;
2488 first->op_last = last->op_last;
2489 first->op_flags |= (last->op_flags & OPf_KIDS);
2491 #ifdef PL_OP_SLAB_ALLOC
2499 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2507 if (last->op_type == type) {
2508 if (type == OP_LIST) { /* already a PUSHMARK there */
2509 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2510 ((LISTOP*)last)->op_first->op_sibling = first;
2511 if (!(first->op_flags & OPf_PARENS))
2512 last->op_flags &= ~OPf_PARENS;
2515 if (!(last->op_flags & OPf_KIDS)) {
2516 ((LISTOP*)last)->op_last = first;
2517 last->op_flags |= OPf_KIDS;
2519 first->op_sibling = ((LISTOP*)last)->op_first;
2520 ((LISTOP*)last)->op_first = first;
2522 last->op_flags |= OPf_KIDS;
2526 return newLISTOP(type, 0, first, last);
2532 Perl_newNULLLIST(pTHX)
2534 return newOP(OP_STUB, 0);
2538 Perl_force_list(pTHX_ OP *o)
2540 if (!o || o->op_type != OP_LIST)
2541 o = newLISTOP(OP_LIST, 0, o, Nullop);
2547 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2551 NewOp(1101, listop, 1, LISTOP);
2553 listop->op_type = type;
2554 listop->op_ppaddr = PL_ppaddr[type];
2557 listop->op_flags = flags;
2561 else if (!first && last)
2564 first->op_sibling = last;
2565 listop->op_first = first;
2566 listop->op_last = last;
2567 if (type == OP_LIST) {
2569 pushop = newOP(OP_PUSHMARK, 0);
2570 pushop->op_sibling = first;
2571 listop->op_first = pushop;
2572 listop->op_flags |= OPf_KIDS;
2574 listop->op_last = pushop;
2581 Perl_newOP(pTHX_ I32 type, I32 flags)
2584 NewOp(1101, o, 1, OP);
2586 o->op_ppaddr = PL_ppaddr[type];
2587 o->op_flags = flags;
2590 o->op_private = 0 + (flags >> 8);
2591 if (PL_opargs[type] & OA_RETSCALAR)
2593 if (PL_opargs[type] & OA_TARGET)
2594 o->op_targ = pad_alloc(type, SVs_PADTMP);
2595 return CHECKOP(type, o);
2599 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2604 first = newOP(OP_STUB, 0);
2605 if (PL_opargs[type] & OA_MARK)
2606 first = force_list(first);
2608 NewOp(1101, unop, 1, UNOP);
2609 unop->op_type = type;
2610 unop->op_ppaddr = PL_ppaddr[type];
2611 unop->op_first = first;
2612 unop->op_flags = flags | OPf_KIDS;
2613 unop->op_private = 1 | (flags >> 8);
2614 unop = (UNOP*) CHECKOP(type, unop);
2618 return fold_constants((OP *) unop);
2622 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2625 NewOp(1101, binop, 1, BINOP);
2628 first = newOP(OP_NULL, 0);
2630 binop->op_type = type;
2631 binop->op_ppaddr = PL_ppaddr[type];
2632 binop->op_first = first;
2633 binop->op_flags = flags | OPf_KIDS;
2636 binop->op_private = 1 | (flags >> 8);
2639 binop->op_private = 2 | (flags >> 8);
2640 first->op_sibling = last;
2643 binop = (BINOP*)CHECKOP(type, binop);
2644 if (binop->op_next || binop->op_type != type)
2647 binop->op_last = binop->op_first->op_sibling;
2649 return fold_constants((OP *)binop);
2653 utf8compare(const void *a, const void *b)
2656 for (i = 0; i < 10; i++) {
2657 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2659 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2666 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2668 SV *tstr = ((SVOP*)expr)->op_sv;
2669 SV *rstr = ((SVOP*)repl)->op_sv;
2672 U8 *t = (U8*)SvPV(tstr, tlen);
2673 U8 *r = (U8*)SvPV(rstr, rlen);
2680 register short *tbl;
2682 complement = o->op_private & OPpTRANS_COMPLEMENT;
2683 del = o->op_private & OPpTRANS_DELETE;
2684 squash = o->op_private & OPpTRANS_SQUASH;
2687 o->op_private |= OPpTRANS_FROM_UTF;
2690 o->op_private |= OPpTRANS_TO_UTF;
2692 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2693 SV* listsv = newSVpvn("# comment\n",10);
2695 U8* tend = t + tlen;
2696 U8* rend = r + rlen;
2710 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2711 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2712 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2713 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2716 U8 tmpbuf[UTF8_MAXLEN+1];
2719 New(1109, cp, tlen, U8*);
2721 transv = newSVpvn("",0);
2725 if (t < tend && *t == 0xff) {
2730 qsort(cp, i, sizeof(U8*), utf8compare);
2731 for (j = 0; j < i; j++) {
2733 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2734 /* CHECKME: Use unicode code points for ranges - needs more thought ... NI-S */
2735 UV val = utf8n_to_uvuni(s, cur, &ulen, 0);
2737 diff = val - nextmin;
2739 t = uvuni_to_utf8(tmpbuf,nextmin);
2740 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2742 t = uvuni_to_utf8(tmpbuf, val - 1);
2743 sv_catpvn(transv, "\377", 1);
2744 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2747 if (s < tend && *s == 0xff)
2748 val = utf8n_to_uvuni(s+1, cur - 1, &ulen, 0);
2752 t = uvuni_to_utf8(tmpbuf,nextmin);
2753 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2754 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2755 sv_catpvn(transv, "\377", 1);
2756 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2757 t = (U8*)SvPVX(transv);
2758 tlen = SvCUR(transv);
2762 else if (!rlen && !del) {
2763 r = t; rlen = tlen; rend = tend;
2766 if ((!rlen && !del) || t == r ||
2767 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2769 o->op_private |= OPpTRANS_IDENTICAL;
2773 while (t < tend || tfirst <= tlast) {
2774 /* see if we need more "t" chars */
2775 if (tfirst > tlast) {
2776 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2778 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2780 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2787 /* now see if we need more "r" chars */
2788 if (rfirst > rlast) {
2790 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2792 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2794 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2803 rfirst = rlast = 0xffffffff;
2807 /* now see which range will peter our first, if either. */
2808 tdiff = tlast - tfirst;
2809 rdiff = rlast - rfirst;
2816 if (rfirst == 0xffffffff) {
2817 diff = tdiff; /* oops, pretend rdiff is infinite */
2819 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2820 (long)tfirst, (long)tlast);
2822 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2826 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2827 (long)tfirst, (long)(tfirst + diff),
2830 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2831 (long)tfirst, (long)rfirst);
2833 if (rfirst + diff > max)
2834 max = rfirst + diff;
2837 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2848 else if (max > 0xff)
2853 Safefree(cPVOPo->op_pv);
2854 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2855 SvREFCNT_dec(listsv);
2857 SvREFCNT_dec(transv);
2859 if (!del && havefinal)
2860 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2861 newSVuv((UV)final), 0);
2864 o->op_private |= OPpTRANS_GROWS;
2876 tbl = (short*)cPVOPo->op_pv;
2878 Zero(tbl, 256, short);
2879 for (i = 0; i < tlen; i++)
2881 for (i = 0, j = 0; i < 256; i++) {
2892 if (i < 128 && r[j] >= 128)
2902 o->op_private |= OPpTRANS_IDENTICAL;
2907 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2908 tbl[0x100] = rlen - j;
2909 for (i=0; i < rlen - j; i++)
2910 tbl[0x101+i] = r[j+i];
2914 if (!rlen && !del) {
2917 o->op_private |= OPpTRANS_IDENTICAL;
2919 for (i = 0; i < 256; i++)
2921 for (i = 0, j = 0; i < tlen; i++,j++) {
2924 if (tbl[t[i]] == -1)
2930 if (tbl[t[i]] == -1) {
2931 if (t[i] < 128 && r[j] >= 128)
2938 o->op_private |= OPpTRANS_GROWS;
2946 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2950 NewOp(1101, pmop, 1, PMOP);
2951 pmop->op_type = type;
2952 pmop->op_ppaddr = PL_ppaddr[type];
2953 pmop->op_flags = flags;
2954 pmop->op_private = 0 | (flags >> 8);
2956 if (PL_hints & HINT_RE_TAINT)
2957 pmop->op_pmpermflags |= PMf_RETAINT;
2958 if (PL_hints & HINT_LOCALE)
2959 pmop->op_pmpermflags |= PMf_LOCALE;
2960 pmop->op_pmflags = pmop->op_pmpermflags;
2962 /* link into pm list */
2963 if (type != OP_TRANS && PL_curstash) {
2964 pmop->op_pmnext = HvPMROOT(PL_curstash);
2965 HvPMROOT(PL_curstash) = pmop;
2966 PmopSTASH_set(pmop,PL_curstash);
2973 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2977 I32 repl_has_vars = 0;
2979 if (o->op_type == OP_TRANS)
2980 return pmtrans(o, expr, repl);
2982 PL_hints |= HINT_BLOCK_SCOPE;
2985 if (expr->op_type == OP_CONST) {
2987 SV *pat = ((SVOP*)expr)->op_sv;
2988 char *p = SvPV(pat, plen);
2989 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2990 sv_setpvn(pat, "\\s+", 3);
2991 p = SvPV(pat, plen);
2992 pm->op_pmflags |= PMf_SKIPWHITE;
2994 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2995 pm->op_pmdynflags |= PMdf_UTF8;
2996 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2997 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2998 pm->op_pmflags |= PMf_WHITE;
3002 if (PL_hints & HINT_UTF8)
3003 pm->op_pmdynflags |= PMdf_UTF8;
3004 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3005 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3007 : OP_REGCMAYBE),0,expr);
3009 NewOp(1101, rcop, 1, LOGOP);
3010 rcop->op_type = OP_REGCOMP;
3011 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3012 rcop->op_first = scalar(expr);
3013 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3014 ? (OPf_SPECIAL | OPf_KIDS)
3016 rcop->op_private = 1;
3019 /* establish postfix order */
3020 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3022 rcop->op_next = expr;
3023 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3026 rcop->op_next = LINKLIST(expr);
3027 expr->op_next = (OP*)rcop;
3030 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3035 if (pm->op_pmflags & PMf_EVAL) {
3037 if (CopLINE(PL_curcop) < PL_multi_end)
3038 CopLINE_set(PL_curcop, PL_multi_end);
3041 else if (repl->op_type == OP_THREADSV
3042 && strchr("&`'123456789+",
3043 PL_threadsv_names[repl->op_targ]))
3047 #endif /* USE_THREADS */
3048 else if (repl->op_type == OP_CONST)
3052 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3053 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3055 if (curop->op_type == OP_THREADSV) {
3057 if (strchr("&`'123456789+", curop->op_private))
3061 if (curop->op_type == OP_GV) {
3062 GV *gv = cGVOPx_gv(curop);
3064 if (strchr("&`'123456789+", *GvENAME(gv)))
3067 #endif /* USE_THREADS */
3068 else if (curop->op_type == OP_RV2CV)
3070 else if (curop->op_type == OP_RV2SV ||
3071 curop->op_type == OP_RV2AV ||
3072 curop->op_type == OP_RV2HV ||
3073 curop->op_type == OP_RV2GV) {
3074 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3077 else if (curop->op_type == OP_PADSV ||
3078 curop->op_type == OP_PADAV ||
3079 curop->op_type == OP_PADHV ||
3080 curop->op_type == OP_PADANY) {
3083 else if (curop->op_type == OP_PUSHRE)
3084 ; /* Okay here, dangerous in newASSIGNOP */
3093 && (!pm->op_pmregexp
3094 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3095 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3096 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3097 prepend_elem(o->op_type, scalar(repl), o);
3100 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3101 pm->op_pmflags |= PMf_MAYBE_CONST;
3102 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3104 NewOp(1101, rcop, 1, LOGOP);
3105 rcop->op_type = OP_SUBSTCONT;
3106 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3107 rcop->op_first = scalar(repl);
3108 rcop->op_flags |= OPf_KIDS;
3109 rcop->op_private = 1;
3112 /* establish postfix order */
3113 rcop->op_next = LINKLIST(repl);
3114 repl->op_next = (OP*)rcop;
3116 pm->op_pmreplroot = scalar((OP*)rcop);
3117 pm->op_pmreplstart = LINKLIST(rcop);
3126 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3129 NewOp(1101, svop, 1, SVOP);
3130 svop->op_type = type;
3131 svop->op_ppaddr = PL_ppaddr[type];
3133 svop->op_next = (OP*)svop;
3134 svop->op_flags = flags;
3135 if (PL_opargs[type] & OA_RETSCALAR)
3137 if (PL_opargs[type] & OA_TARGET)
3138 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3139 return CHECKOP(type, svop);
3143 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3146 NewOp(1101, padop, 1, PADOP);
3147 padop->op_type = type;
3148 padop->op_ppaddr = PL_ppaddr[type];
3149 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3150 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3151 PL_curpad[padop->op_padix] = sv;
3153 padop->op_next = (OP*)padop;
3154 padop->op_flags = flags;
3155 if (PL_opargs[type] & OA_RETSCALAR)
3157 if (PL_opargs[type] & OA_TARGET)
3158 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3159 return CHECKOP(type, padop);
3163 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3167 return newPADOP(type, flags, SvREFCNT_inc(gv));
3169 return newSVOP(type, flags, SvREFCNT_inc(gv));
3174 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3177 NewOp(1101, pvop, 1, PVOP);
3178 pvop->op_type = type;
3179 pvop->op_ppaddr = PL_ppaddr[type];
3181 pvop->op_next = (OP*)pvop;
3182 pvop->op_flags = flags;
3183 if (PL_opargs[type] & OA_RETSCALAR)
3185 if (PL_opargs[type] & OA_TARGET)
3186 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3187 return CHECKOP(type, pvop);
3191 Perl_package(pTHX_ OP *o)
3195 save_hptr(&PL_curstash);
3196 save_item(PL_curstname);
3201 name = SvPV(sv, len);
3202 PL_curstash = gv_stashpvn(name,len,TRUE);
3203 sv_setpvn(PL_curstname, name, len);
3207 sv_setpv(PL_curstname,"<none>");
3208 PL_curstash = Nullhv;
3210 PL_hints |= HINT_BLOCK_SCOPE;
3211 PL_copline = NOLINE;
3216 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3224 if (id->op_type != OP_CONST)
3225 Perl_croak(aTHX_ "Module name must be constant");
3229 if (version != Nullop) {
3230 SV *vesv = ((SVOP*)version)->op_sv;
3232 if (arg == Nullop && !SvNIOKp(vesv)) {
3239 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3240 Perl_croak(aTHX_ "Version number must be constant number");
3242 /* Make copy of id so we don't free it twice */
3243 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3245 /* Fake up a method call to VERSION */
3246 meth = newSVpvn("VERSION",7);
3247 sv_upgrade(meth, SVt_PVIV);
3248 (void)SvIOK_on(meth);
3249 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3250 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3251 append_elem(OP_LIST,
3252 prepend_elem(OP_LIST, pack, list(version)),
3253 newSVOP(OP_METHOD_NAMED, 0, meth)));
3257 /* Fake up an import/unimport */
3258 if (arg && arg->op_type == OP_STUB)
3259 imop = arg; /* no import on explicit () */
3260 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3261 imop = Nullop; /* use 5.0; */
3266 /* Make copy of id so we don't free it twice */
3267 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3269 /* Fake up a method call to import/unimport */
3270 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3271 sv_upgrade(meth, SVt_PVIV);
3272 (void)SvIOK_on(meth);
3273 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3274 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3275 append_elem(OP_LIST,
3276 prepend_elem(OP_LIST, pack, list(arg)),
3277 newSVOP(OP_METHOD_NAMED, 0, meth)));
3280 /* Fake up a require, handle override, if any */
3281 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3282 if (!(gv && GvIMPORTED_CV(gv)))
3283 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3285 if (gv && GvIMPORTED_CV(gv)) {
3286 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3287 append_elem(OP_LIST, id,
3288 scalar(newUNOP(OP_RV2CV, 0,
3293 rqop = newUNOP(OP_REQUIRE, 0, id);
3296 /* Fake up the BEGIN {}, which does its thing immediately. */
3298 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3301 append_elem(OP_LINESEQ,
3302 append_elem(OP_LINESEQ,
3303 newSTATEOP(0, Nullch, rqop),
3304 newSTATEOP(0, Nullch, veop)),
3305 newSTATEOP(0, Nullch, imop) ));
3307 PL_hints |= HINT_BLOCK_SCOPE;
3308 PL_copline = NOLINE;
3313 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3316 va_start(args, ver);
3317 vload_module(flags, name, ver, &args);
3321 #ifdef PERL_IMPLICIT_CONTEXT
3323 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3327 va_start(args, ver);
3328 vload_module(flags, name, ver, &args);
3334 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3336 OP *modname, *veop, *imop;
3338 modname = newSVOP(OP_CONST, 0, name);
3339 modname->op_private |= OPpCONST_BARE;
3341 veop = newSVOP(OP_CONST, 0, ver);
3345 if (flags & PERL_LOADMOD_NOIMPORT) {
3346 imop = sawparens(newNULLLIST());
3348 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3349 imop = va_arg(*args, OP*);
3354 sv = va_arg(*args, SV*);
3356 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3357 sv = va_arg(*args, SV*);
3361 line_t ocopline = PL_copline;
3362 int oexpect = PL_expect;
3364 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3365 veop, modname, imop);
3366 PL_expect = oexpect;
3367 PL_copline = ocopline;
3372 Perl_dofile(pTHX_ OP *term)
3377 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3378 if (!(gv && GvIMPORTED_CV(gv)))
3379 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3381 if (gv && GvIMPORTED_CV(gv)) {
3382 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3383 append_elem(OP_LIST, term,
3384 scalar(newUNOP(OP_RV2CV, 0,
3389 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3395 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3397 return newBINOP(OP_LSLICE, flags,
3398 list(force_list(subscript)),
3399 list(force_list(listval)) );
3403 S_list_assignment(pTHX_ register OP *o)
3408 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3409 o = cUNOPo->op_first;
3411 if (o->op_type == OP_COND_EXPR) {
3412 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3413 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3418 yyerror("Assignment to both a list and a scalar");
3422 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3423 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3424 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3427 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3430 if (o->op_type == OP_RV2SV)
3437 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3442 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3443 return newLOGOP(optype, 0,
3444 mod(scalar(left), optype),
3445 newUNOP(OP_SASSIGN, 0, scalar(right)));
3448 return newBINOP(optype, OPf_STACKED,
3449 mod(scalar(left), optype), scalar(right));
3453 if (list_assignment(left)) {
3457 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3458 left = mod(left, OP_AASSIGN);
3466 curop = list(force_list(left));
3467 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3468 o->op_private = 0 | (flags >> 8);
3469 for (curop = ((LISTOP*)curop)->op_first;
3470 curop; curop = curop->op_sibling)
3472 if (curop->op_type == OP_RV2HV &&
3473 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3474 o->op_private |= OPpASSIGN_HASH;
3478 if (!(left->op_private & OPpLVAL_INTRO)) {
3481 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3482 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3483 if (curop->op_type == OP_GV) {
3484 GV *gv = cGVOPx_gv(curop);
3485 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3487 SvCUR(gv) = PL_generation;
3489 else if (curop->op_type == OP_PADSV ||
3490 curop->op_type == OP_PADAV ||
3491 curop->op_type == OP_PADHV ||
3492 curop->op_type == OP_PADANY) {
3493 SV **svp = AvARRAY(PL_comppad_name);
3494 SV *sv = svp[curop->op_targ];
3495 if (SvCUR(sv) == PL_generation)
3497 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3499 else if (curop->op_type == OP_RV2CV)
3501 else if (curop->op_type == OP_RV2SV ||
3502 curop->op_type == OP_RV2AV ||
3503 curop->op_type == OP_RV2HV ||
3504 curop->op_type == OP_RV2GV) {
3505 if (lastop->op_type != OP_GV) /* funny deref? */
3508 else if (curop->op_type == OP_PUSHRE) {
3509 if (((PMOP*)curop)->op_pmreplroot) {
3511 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3513 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3515 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3517 SvCUR(gv) = PL_generation;
3526 o->op_private |= OPpASSIGN_COMMON;
3528 if (right && right->op_type == OP_SPLIT) {
3530 if ((tmpop = ((LISTOP*)right)->op_first) &&
3531 tmpop->op_type == OP_PUSHRE)
3533 PMOP *pm = (PMOP*)tmpop;
3534 if (left->op_type == OP_RV2AV &&
3535 !(left->op_private & OPpLVAL_INTRO) &&
3536 !(o->op_private & OPpASSIGN_COMMON) )
3538 tmpop = ((UNOP*)left)->op_first;
3539 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3541 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3542 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3544 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3545 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3547 pm->op_pmflags |= PMf_ONCE;
3548 tmpop = cUNOPo->op_first; /* to list (nulled) */
3549 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3550 tmpop->op_sibling = Nullop; /* don't free split */
3551 right->op_next = tmpop->op_next; /* fix starting loc */
3552 op_free(o); /* blow off assign */
3553 right->op_flags &= ~OPf_WANT;
3554 /* "I don't know and I don't care." */
3559 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3560 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3562 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3564 sv_setiv(sv, PL_modcount+1);
3572 right = newOP(OP_UNDEF, 0);
3573 if (right->op_type == OP_READLINE) {
3574 right->op_flags |= OPf_STACKED;
3575 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3578 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3579 o = newBINOP(OP_SASSIGN, flags,
3580 scalar(right), mod(scalar(left), OP_SASSIGN) );
3592 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3594 U32 seq = intro_my();
3597 NewOp(1101, cop, 1, COP);
3598 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3599 cop->op_type = OP_DBSTATE;
3600 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3603 cop->op_type = OP_NEXTSTATE;
3604 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3606 cop->op_flags = flags;
3607 cop->op_private = (PL_hints & HINT_BYTE);
3609 cop->op_private |= NATIVE_HINTS;
3611 PL_compiling.op_private = cop->op_private;
3612 cop->op_next = (OP*)cop;
3615 cop->cop_label = label;
3616 PL_hints |= HINT_BLOCK_SCOPE;
3619 cop->cop_arybase = PL_curcop->cop_arybase;
3620 if (specialWARN(PL_curcop->cop_warnings))
3621 cop->cop_warnings = PL_curcop->cop_warnings ;
3623 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3624 if (specialCopIO(PL_curcop->cop_io))
3625 cop->cop_io = PL_curcop->cop_io;
3627 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3630 if (PL_copline == NOLINE)
3631 CopLINE_set(cop, CopLINE(PL_curcop));
3633 CopLINE_set(cop, PL_copline);
3634 PL_copline = NOLINE;
3637 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3639 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3641 CopSTASH_set(cop, PL_curstash);
3643 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3644 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3645 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3646 (void)SvIOK_on(*svp);
3647 SvIVX(*svp) = PTR2IV(cop);
3651 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3654 /* "Introduce" my variables to visible status. */
3662 if (! PL_min_intro_pending)
3663 return PL_cop_seqmax;
3665 svp = AvARRAY(PL_comppad_name);
3666 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3667 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3668 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3669 SvNVX(sv) = (NV)PL_cop_seqmax;
3672 PL_min_intro_pending = 0;
3673 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3674 return PL_cop_seqmax++;
3678 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3680 return new_logop(type, flags, &first, &other);
3684 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3688 OP *first = *firstp;
3689 OP *other = *otherp;
3691 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3692 return newBINOP(type, flags, scalar(first), scalar(other));
3694 scalarboolean(first);
3695 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3696 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3697 if (type == OP_AND || type == OP_OR) {
3703 first = *firstp = cUNOPo->op_first;
3705 first->op_next = o->op_next;
3706 cUNOPo->op_first = Nullop;
3710 if (first->op_type == OP_CONST) {
3711 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3712 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3713 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3724 else if (first->op_type == OP_WANTARRAY) {
3730 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3731 OP *k1 = ((UNOP*)first)->op_first;
3732 OP *k2 = k1->op_sibling;
3734 switch (first->op_type)
3737 if (k2 && k2->op_type == OP_READLINE
3738 && (k2->op_flags & OPf_STACKED)
3739 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3741 warnop = k2->op_type;
3746 if (k1->op_type == OP_READDIR
3747 || k1->op_type == OP_GLOB
3748 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3749 || k1->op_type == OP_EACH)
3751 warnop = ((k1->op_type == OP_NULL)
3752 ? k1->op_targ : k1->op_type);
3757 line_t oldline = CopLINE(PL_curcop);
3758 CopLINE_set(PL_curcop, PL_copline);
3759 Perl_warner(aTHX_ WARN_MISC,
3760 "Value of %s%s can be \"0\"; test with defined()",
3762 ((warnop == OP_READLINE || warnop == OP_GLOB)
3763 ? " construct" : "() operator"));
3764 CopLINE_set(PL_curcop, oldline);
3771 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3772 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3774 NewOp(1101, logop, 1, LOGOP);
3776 logop->op_type = type;
3777 logop->op_ppaddr = PL_ppaddr[type];
3778 logop->op_first = first;
3779 logop->op_flags = flags | OPf_KIDS;
3780 logop->op_other = LINKLIST(other);
3781 logop->op_private = 1 | (flags >> 8);
3783 /* establish postfix order */
3784 logop->op_next = LINKLIST(first);
3785 first->op_next = (OP*)logop;
3786 first->op_sibling = other;
3788 o = newUNOP(OP_NULL, 0, (OP*)logop);
3795 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3802 return newLOGOP(OP_AND, 0, first, trueop);
3804 return newLOGOP(OP_OR, 0, first, falseop);
3806 scalarboolean(first);
3807 if (first->op_type == OP_CONST) {
3808 if (SvTRUE(((SVOP*)first)->op_sv)) {
3819 else if (first->op_type == OP_WANTARRAY) {
3823 NewOp(1101, logop, 1, LOGOP);
3824 logop->op_type = OP_COND_EXPR;
3825 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3826 logop->op_first = first;
3827 logop->op_flags = flags | OPf_KIDS;
3828 logop->op_private = 1 | (flags >> 8);
3829 logop->op_other = LINKLIST(trueop);
3830 logop->op_next = LINKLIST(falseop);
3833 /* establish postfix order */
3834 start = LINKLIST(first);
3835 first->op_next = (OP*)logop;
3837 first->op_sibling = trueop;
3838 trueop->op_sibling = falseop;
3839 o = newUNOP(OP_NULL, 0, (OP*)logop);
3841 trueop->op_next = falseop->op_next = o;
3848 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3856 NewOp(1101, range, 1, LOGOP);
3858 range->op_type = OP_RANGE;
3859 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3860 range->op_first = left;
3861 range->op_flags = OPf_KIDS;
3862 leftstart = LINKLIST(left);
3863 range->op_other = LINKLIST(right);
3864 range->op_private = 1 | (flags >> 8);
3866 left->op_sibling = right;
3868 range->op_next = (OP*)range;
3869 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3870 flop = newUNOP(OP_FLOP, 0, flip);
3871 o = newUNOP(OP_NULL, 0, flop);
3873 range->op_next = leftstart;
3875 left->op_next = flip;
3876 right->op_next = flop;
3878 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3879 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3880 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3881 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3883 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3884 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3887 if (!flip->op_private || !flop->op_private)
3888 linklist(o); /* blow off optimizer unless constant */
3894 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3898 int once = block && block->op_flags & OPf_SPECIAL &&
3899 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3902 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3903 return block; /* do {} while 0 does once */
3904 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3905 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3906 expr = newUNOP(OP_DEFINED, 0,
3907 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3908 } else if (expr->op_flags & OPf_KIDS) {
3909 OP *k1 = ((UNOP*)expr)->op_first;
3910 OP *k2 = (k1) ? k1->op_sibling : NULL;
3911 switch (expr->op_type) {
3913 if (k2 && k2->op_type == OP_READLINE
3914 && (k2->op_flags & OPf_STACKED)
3915 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3916 expr = newUNOP(OP_DEFINED, 0, expr);
3920 if (k1->op_type == OP_READDIR
3921 || k1->op_type == OP_GLOB
3922 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3923 || k1->op_type == OP_EACH)
3924 expr = newUNOP(OP_DEFINED, 0, expr);
3930 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3931 o = new_logop(OP_AND, 0, &expr, &listop);
3934 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3936 if (once && o != listop)
3937 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3940 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3942 o->op_flags |= flags;
3944 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3949 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3958 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3959 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3960 expr = newUNOP(OP_DEFINED, 0,
3961 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3962 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3963 OP *k1 = ((UNOP*)expr)->op_first;
3964 OP *k2 = (k1) ? k1->op_sibling : NULL;
3965 switch (expr->op_type) {
3967 if (k2 && k2->op_type == OP_READLINE
3968 && (k2->op_flags & OPf_STACKED)
3969 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3970 expr = newUNOP(OP_DEFINED, 0, expr);
3974 if (k1->op_type == OP_READDIR
3975 || k1->op_type == OP_GLOB
3976 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3977 || k1->op_type == OP_EACH)
3978 expr = newUNOP(OP_DEFINED, 0, expr);
3984 block = newOP(OP_NULL, 0);
3986 block = scope(block);
3990 next = LINKLIST(cont);
3993 OP *unstack = newOP(OP_UNSTACK, 0);
3996 cont = append_elem(OP_LINESEQ, cont, unstack);
3997 if ((line_t)whileline != NOLINE) {
3998 PL_copline = whileline;
3999 cont = append_elem(OP_LINESEQ, cont,
4000 newSTATEOP(0, Nullch, Nullop));
4004 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4005 redo = LINKLIST(listop);
4008 PL_copline = whileline;
4010 o = new_logop(OP_AND, 0, &expr, &listop);
4011 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4012 op_free(expr); /* oops, it's a while (0) */
4014 return Nullop; /* listop already freed by new_logop */
4017 ((LISTOP*)listop)->op_last->op_next = condop =
4018 (o == listop ? redo : LINKLIST(o));
4024 NewOp(1101,loop,1,LOOP);
4025 loop->op_type = OP_ENTERLOOP;
4026 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4027 loop->op_private = 0;
4028 loop->op_next = (OP*)loop;
4031 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4033 loop->op_redoop = redo;
4034 loop->op_lastop = o;
4035 o->op_private |= loopflags;
4038 loop->op_nextop = next;
4040 loop->op_nextop = o;
4042 o->op_flags |= flags;
4043 o->op_private |= (flags >> 8);
4048 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4056 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4057 sv->op_type = OP_RV2GV;
4058 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4060 else if (sv->op_type == OP_PADSV) { /* private variable */
4061 padoff = sv->op_targ;
4066 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4067 padoff = sv->op_targ;
4069 iterflags |= OPf_SPECIAL;
4074 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4078 padoff = find_threadsv("_");
4079 iterflags |= OPf_SPECIAL;
4081 sv = newGVOP(OP_GV, 0, PL_defgv);
4084 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4085 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4086 iterflags |= OPf_STACKED;
4088 else if (expr->op_type == OP_NULL &&
4089 (expr->op_flags & OPf_KIDS) &&
4090 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4092 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4093 * set the STACKED flag to indicate that these values are to be
4094 * treated as min/max values by 'pp_iterinit'.
4096 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4097 LOGOP* range = (LOGOP*) flip->op_first;
4098 OP* left = range->op_first;
4099 OP* right = left->op_sibling;
4102 range->op_flags &= ~OPf_KIDS;
4103 range->op_first = Nullop;
4105 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4106 listop->op_first->op_next = range->op_next;
4107 left->op_next = range->op_other;
4108 right->op_next = (OP*)listop;
4109 listop->op_next = listop->op_first;
4112 expr = (OP*)(listop);
4114 iterflags |= OPf_STACKED;
4117 expr = mod(force_list(expr), OP_GREPSTART);
4121 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4122 append_elem(OP_LIST, expr, scalar(sv))));
4123 assert(!loop->op_next);
4124 #ifdef PL_OP_SLAB_ALLOC
4127 NewOp(1234,tmp,1,LOOP);
4128 Copy(loop,tmp,1,LOOP);
4132 Renew(loop, 1, LOOP);
4134 loop->op_targ = padoff;
4135 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4136 PL_copline = forline;
4137 return newSTATEOP(0, label, wop);
4141 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4146 if (type != OP_GOTO || label->op_type == OP_CONST) {
4147 /* "last()" means "last" */
4148 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4149 o = newOP(type, OPf_SPECIAL);
4151 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4152 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4158 if (label->op_type == OP_ENTERSUB)
4159 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4160 o = newUNOP(type, OPf_STACKED, label);
4162 PL_hints |= HINT_BLOCK_SCOPE;
4167 Perl_cv_undef(pTHX_ CV *cv)
4171 MUTEX_DESTROY(CvMUTEXP(cv));
4172 Safefree(CvMUTEXP(cv));
4175 #endif /* USE_THREADS */
4177 if (!CvXSUB(cv) && CvROOT(cv)) {
4179 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4180 Perl_croak(aTHX_ "Can't undef active subroutine");
4183 Perl_croak(aTHX_ "Can't undef active subroutine");
4184 #endif /* USE_THREADS */
4187 SAVEVPTR(PL_curpad);
4190 op_free(CvROOT(cv));
4191 CvROOT(cv) = Nullop;
4194 SvPOK_off((SV*)cv); /* forget prototype */
4196 /* Since closure prototypes have the same lifetime as the containing
4197 * CV, they don't hold a refcount on the outside CV. This avoids
4198 * the refcount loop between the outer CV (which keeps a refcount to
4199 * the closure prototype in the pad entry for pp_anoncode()) and the
4200 * closure prototype, and the ensuing memory leak. --GSAR */
4201 if (!CvANON(cv) || CvCLONED(cv))
4202 SvREFCNT_dec(CvOUTSIDE(cv));
4203 CvOUTSIDE(cv) = Nullcv;
4205 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4208 if (CvPADLIST(cv)) {
4209 /* may be during global destruction */
4210 if (SvREFCNT(CvPADLIST(cv))) {
4211 I32 i = AvFILLp(CvPADLIST(cv));
4213 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4214 SV* sv = svp ? *svp : Nullsv;
4217 if (sv == (SV*)PL_comppad_name)
4218 PL_comppad_name = Nullav;
4219 else if (sv == (SV*)PL_comppad) {
4220 PL_comppad = Nullav;
4221 PL_curpad = Null(SV**);
4225 SvREFCNT_dec((SV*)CvPADLIST(cv));
4227 CvPADLIST(cv) = Nullav;
4232 #ifdef DEBUG_CLOSURES
4234 S_cv_dump(pTHX_ CV *cv)
4237 CV *outside = CvOUTSIDE(cv);
4238 AV* padlist = CvPADLIST(cv);
4245 PerlIO_printf(Perl_debug_log,
4246 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4248 (CvANON(cv) ? "ANON"
4249 : (cv == PL_main_cv) ? "MAIN"
4250 : CvUNIQUE(cv) ? "UNIQUE"
4251 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4254 : CvANON(outside) ? "ANON"
4255 : (outside == PL_main_cv) ? "MAIN"
4256 : CvUNIQUE(outside) ? "UNIQUE"
4257 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4262 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4263 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4264 pname = AvARRAY(pad_name);
4265 ppad = AvARRAY(pad);
4267 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4268 if (SvPOK(pname[ix]))
4269 PerlIO_printf(Perl_debug_log,
4270 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4271 (int)ix, PTR2UV(ppad[ix]),
4272 SvFAKE(pname[ix]) ? "FAKE " : "",
4274 (IV)I_32(SvNVX(pname[ix])),
4277 #endif /* DEBUGGING */
4279 #endif /* DEBUG_CLOSURES */
4282 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4286 AV* protopadlist = CvPADLIST(proto);
4287 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4288 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4289 SV** pname = AvARRAY(protopad_name);
4290 SV** ppad = AvARRAY(protopad);
4291 I32 fname = AvFILLp(protopad_name);
4292 I32 fpad = AvFILLp(protopad);
4296 assert(!CvUNIQUE(proto));
4300 SAVESPTR(PL_comppad_name);
4301 SAVESPTR(PL_compcv);
4303 cv = PL_compcv = (CV*)NEWSV(1104,0);
4304 sv_upgrade((SV *)cv, SvTYPE(proto));
4305 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4309 New(666, CvMUTEXP(cv), 1, perl_mutex);
4310 MUTEX_INIT(CvMUTEXP(cv));
4312 #endif /* USE_THREADS */
4313 CvFILE(cv) = CvFILE(proto);
4314 CvGV(cv) = CvGV(proto);
4315 CvSTASH(cv) = CvSTASH(proto);
4316 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4317 CvSTART(cv) = CvSTART(proto);
4319 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4322 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4324 PL_comppad_name = newAV();
4325 for (ix = fname; ix >= 0; ix--)
4326 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4328 PL_comppad = newAV();
4330 comppadlist = newAV();
4331 AvREAL_off(comppadlist);
4332 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4333 av_store(comppadlist, 1, (SV*)PL_comppad);
4334 CvPADLIST(cv) = comppadlist;
4335 av_fill(PL_comppad, AvFILLp(protopad));
4336 PL_curpad = AvARRAY(PL_comppad);
4338 av = newAV(); /* will be @_ */
4340 av_store(PL_comppad, 0, (SV*)av);
4341 AvFLAGS(av) = AVf_REIFY;
4343 for (ix = fpad; ix > 0; ix--) {
4344 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4345 if (namesv && namesv != &PL_sv_undef) {
4346 char *name = SvPVX(namesv); /* XXX */
4347 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4348 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4349 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4351 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4353 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4355 else { /* our own lexical */
4358 /* anon code -- we'll come back for it */
4359 sv = SvREFCNT_inc(ppad[ix]);
4361 else if (*name == '@')
4363 else if (*name == '%')
4372 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4373 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4376 SV* sv = NEWSV(0,0);
4382 /* Now that vars are all in place, clone nested closures. */
4384 for (ix = fpad; ix > 0; ix--) {
4385 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4387 && namesv != &PL_sv_undef
4388 && !(SvFLAGS(namesv) & SVf_FAKE)
4389 && *SvPVX(namesv) == '&'
4390 && CvCLONE(ppad[ix]))
4392 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4393 SvREFCNT_dec(ppad[ix]);
4396 PL_curpad[ix] = (SV*)kid;
4400 #ifdef DEBUG_CLOSURES
4401 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4403 PerlIO_printf(Perl_debug_log, " from:\n");
4405 PerlIO_printf(Perl_debug_log, " to:\n");
4412 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4414 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4416 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4423 Perl_cv_clone(pTHX_ CV *proto)
4426 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4427 cv = cv_clone2(proto, CvOUTSIDE(proto));
4428 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4433 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4435 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4436 SV* msg = sv_newmortal();
4440 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4441 sv_setpv(msg, "Prototype mismatch:");
4443 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4445 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4446 sv_catpv(msg, " vs ");
4448 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4450 sv_catpv(msg, "none");
4451 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4455 static void const_sv_xsub(pTHXo_ CV* cv);
4458 =for apidoc cv_const_sv
4460 If C<cv> is a constant sub eligible for inlining. returns the constant
4461 value returned by the sub. Otherwise, returns NULL.
4463 Constant subs can be created with C<newCONSTSUB> or as described in
4464 L<perlsub/"Constant Functions">.
4469 Perl_cv_const_sv(pTHX_ CV *cv)
4471 if (!cv || !CvCONST(cv))
4473 return (SV*)CvXSUBANY(cv).any_ptr;
4477 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4484 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4485 o = cLISTOPo->op_first->op_sibling;
4487 for (; o; o = o->op_next) {
4488 OPCODE type = o->op_type;
4490 if (sv && o->op_next == o)
4492 if (o->op_next != o) {
4493 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4495 if (type == OP_DBSTATE)
4498 if (type == OP_LEAVESUB || type == OP_RETURN)
4502 if (type == OP_CONST && cSVOPo->op_sv)
4504 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4505 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4506 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4510 /* We get here only from cv_clone2() while creating a closure.
4511 Copy the const value here instead of in cv_clone2 so that
4512 SvREADONLY_on doesn't lead to problems when leaving
4517 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4529 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4539 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4543 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4545 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4549 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4555 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4560 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4561 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4562 SV *sv = sv_newmortal();
4563 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4564 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4569 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4570 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4580 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4581 maximum a prototype before. */
4582 if (SvTYPE(gv) > SVt_NULL) {
4583 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4584 && ckWARN_d(WARN_PROTOTYPE))
4586 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4588 cv_ckproto((CV*)gv, NULL, ps);
4591 sv_setpv((SV*)gv, ps);
4593 sv_setiv((SV*)gv, -1);
4594 SvREFCNT_dec(PL_compcv);
4595 cv = PL_compcv = NULL;
4596 PL_sub_generation++;
4600 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4602 #ifdef GV_SHARED_CHECK
4603 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4604 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4608 if (!block || !ps || *ps || attrs)
4611 const_sv = op_const_sv(block, Nullcv);
4614 bool exists = CvROOT(cv) || CvXSUB(cv);
4616 #ifdef GV_SHARED_CHECK
4617 if (exists && GvSHARED(gv)) {
4618 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4622 /* if the subroutine doesn't exist and wasn't pre-declared
4623 * with a prototype, assume it will be AUTOLOADed,
4624 * skipping the prototype check
4626 if (exists || SvPOK(cv))
4627 cv_ckproto(cv, gv, ps);
4628 /* already defined (or promised)? */
4629 if (exists || GvASSUMECV(gv)) {
4630 if (!block && !attrs) {
4631 /* just a "sub foo;" when &foo is already defined */
4632 SAVEFREESV(PL_compcv);
4635 /* ahem, death to those who redefine active sort subs */
4636 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4637 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4639 if (ckWARN(WARN_REDEFINE)
4641 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4643 line_t oldline = CopLINE(PL_curcop);
4644 CopLINE_set(PL_curcop, PL_copline);
4645 Perl_warner(aTHX_ WARN_REDEFINE,
4646 CvCONST(cv) ? "Constant subroutine %s redefined"
4647 : "Subroutine %s redefined", name);
4648 CopLINE_set(PL_curcop, oldline);
4656 SvREFCNT_inc(const_sv);
4658 assert(!CvROOT(cv) && !CvCONST(cv));
4659 sv_setpv((SV*)cv, ""); /* prototype is "" */
4660 CvXSUBANY(cv).any_ptr = const_sv;
4661 CvXSUB(cv) = const_sv_xsub;
4666 cv = newCONSTSUB(NULL, name, const_sv);
4669 SvREFCNT_dec(PL_compcv);
4671 PL_sub_generation++;
4678 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4679 * before we clobber PL_compcv.
4683 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4684 stash = GvSTASH(CvGV(cv));
4685 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4686 stash = CvSTASH(cv);
4688 stash = PL_curstash;
4691 /* possibly about to re-define existing subr -- ignore old cv */
4692 rcv = (SV*)PL_compcv;
4693 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4694 stash = GvSTASH(gv);
4696 stash = PL_curstash;
4698 apply_attrs(stash, rcv, attrs);
4700 if (cv) { /* must reuse cv if autoloaded */
4702 /* got here with just attrs -- work done, so bug out */
4703 SAVEFREESV(PL_compcv);
4707 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4708 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4709 CvOUTSIDE(PL_compcv) = 0;
4710 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4711 CvPADLIST(PL_compcv) = 0;
4712 /* inner references to PL_compcv must be fixed up ... */
4714 AV *padlist = CvPADLIST(cv);
4715 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4716 AV *comppad = (AV*)AvARRAY(padlist)[1];
4717 SV **namepad = AvARRAY(comppad_name);
4718 SV **curpad = AvARRAY(comppad);
4719 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4720 SV *namesv = namepad[ix];
4721 if (namesv && namesv != &PL_sv_undef
4722 && *SvPVX(namesv) == '&')
4724 CV *innercv = (CV*)curpad[ix];
4725 if (CvOUTSIDE(innercv) == PL_compcv) {
4726 CvOUTSIDE(innercv) = cv;
4727 if (!CvANON(innercv) || CvCLONED(innercv)) {
4728 (void)SvREFCNT_inc(cv);
4729 SvREFCNT_dec(PL_compcv);
4735 /* ... before we throw it away */
4736 SvREFCNT_dec(PL_compcv);
4743 PL_sub_generation++;
4747 CvFILE(cv) = CopFILE(PL_curcop);
4748 CvSTASH(cv) = PL_curstash;
4751 if (!CvMUTEXP(cv)) {
4752 New(666, CvMUTEXP(cv), 1, perl_mutex);
4753 MUTEX_INIT(CvMUTEXP(cv));
4755 #endif /* USE_THREADS */
4758 sv_setpv((SV*)cv, ps);
4760 if (PL_error_count) {
4764 char *s = strrchr(name, ':');
4766 if (strEQ(s, "BEGIN")) {
4768 "BEGIN not safe after errors--compilation aborted";
4769 if (PL_in_eval & EVAL_KEEPERR)
4770 Perl_croak(aTHX_ not_safe);
4772 /* force display of errors found but not reported */
4773 sv_catpv(ERRSV, not_safe);
4774 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4782 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4783 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4786 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4787 mod(scalarseq(block), OP_LEAVESUBLV));
4790 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4792 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4793 OpREFCNT_set(CvROOT(cv), 1);
4794 CvSTART(cv) = LINKLIST(CvROOT(cv));
4795 CvROOT(cv)->op_next = 0;
4798 /* now that optimizer has done its work, adjust pad values */
4800 SV **namep = AvARRAY(PL_comppad_name);
4801 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4804 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4807 * The only things that a clonable function needs in its
4808 * pad are references to outer lexicals and anonymous subs.
4809 * The rest are created anew during cloning.
4811 if (!((namesv = namep[ix]) != Nullsv &&
4812 namesv != &PL_sv_undef &&
4814 *SvPVX(namesv) == '&')))
4816 SvREFCNT_dec(PL_curpad[ix]);
4817 PL_curpad[ix] = Nullsv;
4820 assert(!CvCONST(cv));
4821 if (ps && !*ps && op_const_sv(block, cv))
4825 AV *av = newAV(); /* Will be @_ */
4827 av_store(PL_comppad, 0, (SV*)av);
4828 AvFLAGS(av) = AVf_REIFY;
4830 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4831 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4833 if (!SvPADMY(PL_curpad[ix]))
4834 SvPADTMP_on(PL_curpad[ix]);
4838 /* If a potential closure prototype, don't keep a refcount on outer CV.
4839 * This is okay as the lifetime of the prototype is tied to the
4840 * lifetime of the outer CV. Avoids memory leak due to reference
4843 SvREFCNT_dec(CvOUTSIDE(cv));
4845 if (name || aname) {
4847 char *tname = (name ? name : aname);
4849 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4850 SV *sv = NEWSV(0,0);
4851 SV *tmpstr = sv_newmortal();
4852 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4856 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4858 (long)PL_subline, (long)CopLINE(PL_curcop));
4859 gv_efullname3(tmpstr, gv, Nullch);
4860 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4861 hv = GvHVn(db_postponed);
4862 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4863 && (pcv = GvCV(db_postponed)))
4869 call_sv((SV*)pcv, G_DISCARD);
4873 if ((s = strrchr(tname,':')))
4878 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4881 if (strEQ(s, "BEGIN")) {
4882 I32 oldscope = PL_scopestack_ix;
4884 SAVECOPFILE(&PL_compiling);
4885 SAVECOPLINE(&PL_compiling);
4887 sv_setsv(PL_rs, PL_nrs);
4890 PL_beginav = newAV();
4891 DEBUG_x( dump_sub(gv) );
4892 av_push(PL_beginav, (SV*)cv);
4893 GvCV(gv) = 0; /* cv has been hijacked */
4894 call_list(oldscope, PL_beginav);
4896 PL_curcop = &PL_compiling;
4897 PL_compiling.op_private = PL_hints;
4900 else if (strEQ(s, "END") && !PL_error_count) {
4903 DEBUG_x( dump_sub(gv) );
4904 av_unshift(PL_endav, 1);
4905 av_store(PL_endav, 0, (SV*)cv);
4906 GvCV(gv) = 0; /* cv has been hijacked */
4908 else if (strEQ(s, "CHECK") && !PL_error_count) {
4910 PL_checkav = newAV();
4911 DEBUG_x( dump_sub(gv) );
4912 if (PL_main_start && ckWARN(WARN_VOID))
4913 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4914 av_unshift(PL_checkav, 1);
4915 av_store(PL_checkav, 0, (SV*)cv);
4916 GvCV(gv) = 0; /* cv has been hijacked */
4918 else if (strEQ(s, "INIT") && !PL_error_count) {
4920 PL_initav = newAV();
4921 DEBUG_x( dump_sub(gv) );
4922 if (PL_main_start && ckWARN(WARN_VOID))
4923 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4924 av_push(PL_initav, (SV*)cv);
4925 GvCV(gv) = 0; /* cv has been hijacked */
4930 PL_copline = NOLINE;
4935 /* XXX unsafe for threads if eval_owner isn't held */
4937 =for apidoc newCONSTSUB
4939 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4940 eligible for inlining at compile-time.
4946 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4952 SAVECOPLINE(PL_curcop);
4953 CopLINE_set(PL_curcop, PL_copline);
4956 PL_hints &= ~HINT_BLOCK_SCOPE;
4959 SAVESPTR(PL_curstash);
4960 SAVECOPSTASH(PL_curcop);
4961 PL_curstash = stash;
4963 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4965 CopSTASH(PL_curcop) = stash;
4969 cv = newXS(name, const_sv_xsub, __FILE__);
4970 CvXSUBANY(cv).any_ptr = sv;
4972 sv_setpv((SV*)cv, ""); /* prototype is "" */
4980 =for apidoc U||newXS
4982 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4988 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4990 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4993 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4995 /* just a cached method */
4999 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5000 /* already defined (or promised) */
5001 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5002 && HvNAME(GvSTASH(CvGV(cv)))
5003 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5004 line_t oldline = CopLINE(PL_curcop);
5005 if (PL_copline != NOLINE)
5006 CopLINE_set(PL_curcop, PL_copline);
5007 Perl_warner(aTHX_ WARN_REDEFINE,
5008 CvCONST(cv) ? "Constant subroutine %s redefined"
5009 : "Subroutine %s redefined"
5011 CopLINE_set(PL_curcop, oldline);
5018 if (cv) /* must reuse cv if autoloaded */
5021 cv = (CV*)NEWSV(1105,0);
5022 sv_upgrade((SV *)cv, SVt_PVCV);
5026 PL_sub_generation++;
5031 New(666, CvMUTEXP(cv), 1, perl_mutex);
5032 MUTEX_INIT(CvMUTEXP(cv));
5034 #endif /* USE_THREADS */
5035 (void)gv_fetchfile(filename);
5036 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5037 an external constant string */
5038 CvXSUB(cv) = subaddr;
5041 char *s = strrchr(name,':');
5047 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5050 if (strEQ(s, "BEGIN")) {
5052 PL_beginav = newAV();
5053 av_push(PL_beginav, (SV*)cv);
5054 GvCV(gv) = 0; /* cv has been hijacked */
5056 else if (strEQ(s, "END")) {
5059 av_unshift(PL_endav, 1);
5060 av_store(PL_endav, 0, (SV*)cv);
5061 GvCV(gv) = 0; /* cv has been hijacked */
5063 else if (strEQ(s, "CHECK")) {
5065 PL_checkav = newAV();
5066 if (PL_main_start && ckWARN(WARN_VOID))
5067 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5068 av_unshift(PL_checkav, 1);
5069 av_store(PL_checkav, 0, (SV*)cv);
5070 GvCV(gv) = 0; /* cv has been hijacked */
5072 else if (strEQ(s, "INIT")) {
5074 PL_initav = newAV();
5075 if (PL_main_start && ckWARN(WARN_VOID))
5076 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5077 av_push(PL_initav, (SV*)cv);
5078 GvCV(gv) = 0; /* cv has been hijacked */
5089 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5098 name = SvPVx(cSVOPo->op_sv, n_a);
5101 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5102 #ifdef GV_SHARED_CHECK
5104 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5108 if ((cv = GvFORM(gv))) {
5109 if (ckWARN(WARN_REDEFINE)) {
5110 line_t oldline = CopLINE(PL_curcop);
5112 CopLINE_set(PL_curcop, PL_copline);
5113 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5114 CopLINE_set(PL_curcop, oldline);
5121 CvFILE(cv) = CopFILE(PL_curcop);
5123 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5124 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5125 SvPADTMP_on(PL_curpad[ix]);
5128 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5129 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5130 OpREFCNT_set(CvROOT(cv), 1);
5131 CvSTART(cv) = LINKLIST(CvROOT(cv));
5132 CvROOT(cv)->op_next = 0;
5135 PL_copline = NOLINE;
5140 Perl_newANONLIST(pTHX_ OP *o)
5142 return newUNOP(OP_REFGEN, 0,
5143 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5147 Perl_newANONHASH(pTHX_ OP *o)
5149 return newUNOP(OP_REFGEN, 0,
5150 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5154 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5156 return newANONATTRSUB(floor, proto, Nullop, block);
5160 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5162 return newUNOP(OP_REFGEN, 0,
5163 newSVOP(OP_ANONCODE, 0,
5164 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5168 Perl_oopsAV(pTHX_ OP *o)
5170 switch (o->op_type) {
5172 o->op_type = OP_PADAV;
5173 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5174 return ref(o, OP_RV2AV);
5177 o->op_type = OP_RV2AV;
5178 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5183 if (ckWARN_d(WARN_INTERNAL))
5184 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5191 Perl_oopsHV(pTHX_ OP *o)
5193 switch (o->op_type) {
5196 o->op_type = OP_PADHV;
5197 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5198 return ref(o, OP_RV2HV);
5202 o->op_type = OP_RV2HV;
5203 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5208 if (ckWARN_d(WARN_INTERNAL))
5209 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5216 Perl_newAVREF(pTHX_ OP *o)
5218 if (o->op_type == OP_PADANY) {
5219 o->op_type = OP_PADAV;
5220 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5223 return newUNOP(OP_RV2AV, 0, scalar(o));
5227 Perl_newGVREF(pTHX_ I32 type, OP *o)
5229 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5230 return newUNOP(OP_NULL, 0, o);
5231 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5235 Perl_newHVREF(pTHX_ OP *o)
5237 if (o->op_type == OP_PADANY) {
5238 o->op_type = OP_PADHV;
5239 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5242 return newUNOP(OP_RV2HV, 0, scalar(o));
5246 Perl_oopsCV(pTHX_ OP *o)
5248 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5254 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5256 return newUNOP(OP_RV2CV, flags, scalar(o));
5260 Perl_newSVREF(pTHX_ OP *o)
5262 if (o->op_type == OP_PADANY) {
5263 o->op_type = OP_PADSV;
5264 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5267 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5268 o->op_flags |= OPpDONE_SVREF;
5271 return newUNOP(OP_RV2SV, 0, scalar(o));
5274 /* Check routines. */
5277 Perl_ck_anoncode(pTHX_ OP *o)
5282 name = NEWSV(1106,0);
5283 sv_upgrade(name, SVt_PVNV);
5284 sv_setpvn(name, "&", 1);
5287 ix = pad_alloc(o->op_type, SVs_PADMY);
5288 av_store(PL_comppad_name, ix, name);
5289 av_store(PL_comppad, ix, cSVOPo->op_sv);
5290 SvPADMY_on(cSVOPo->op_sv);
5291 cSVOPo->op_sv = Nullsv;
5292 cSVOPo->op_targ = ix;
5297 Perl_ck_bitop(pTHX_ OP *o)
5299 o->op_private = PL_hints;
5304 Perl_ck_concat(pTHX_ OP *o)
5306 if (cUNOPo->op_first->op_type == OP_CONCAT)
5307 o->op_flags |= OPf_STACKED;
5312 Perl_ck_spair(pTHX_ OP *o)
5314 if (o->op_flags & OPf_KIDS) {
5317 OPCODE type = o->op_type;
5318 o = modkids(ck_fun(o), type);
5319 kid = cUNOPo->op_first;
5320 newop = kUNOP->op_first->op_sibling;
5322 (newop->op_sibling ||
5323 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5324 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5325 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5329 op_free(kUNOP->op_first);
5330 kUNOP->op_first = newop;
5332 o->op_ppaddr = PL_ppaddr[++o->op_type];
5337 Perl_ck_delete(pTHX_ OP *o)
5341 if (o->op_flags & OPf_KIDS) {
5342 OP *kid = cUNOPo->op_first;
5343 switch (kid->op_type) {
5345 o->op_flags |= OPf_SPECIAL;
5348 o->op_private |= OPpSLICE;
5351 o->op_flags |= OPf_SPECIAL;
5356 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5357 PL_op_desc[o->op_type]);
5365 Perl_ck_eof(pTHX_ OP *o)
5367 I32 type = o->op_type;
5369 if (o->op_flags & OPf_KIDS) {
5370 if (cLISTOPo->op_first->op_type == OP_STUB) {
5372 o = newUNOP(type, OPf_SPECIAL,
5373 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5381 Perl_ck_eval(pTHX_ OP *o)
5383 PL_hints |= HINT_BLOCK_SCOPE;
5384 if (o->op_flags & OPf_KIDS) {
5385 SVOP *kid = (SVOP*)cUNOPo->op_first;
5388 o->op_flags &= ~OPf_KIDS;
5391 else if (kid->op_type == OP_LINESEQ) {
5394 kid->op_next = o->op_next;
5395 cUNOPo->op_first = 0;
5398 NewOp(1101, enter, 1, LOGOP);
5399 enter->op_type = OP_ENTERTRY;
5400 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5401 enter->op_private = 0;
5403 /* establish postfix order */
5404 enter->op_next = (OP*)enter;
5406 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5407 o->op_type = OP_LEAVETRY;
5408 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5409 enter->op_other = o;
5417 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5419 o->op_targ = (PADOFFSET)PL_hints;
5424 Perl_ck_exit(pTHX_ OP *o)
5427 HV *table = GvHV(PL_hintgv);
5429 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5430 if (svp && *svp && SvTRUE(*svp))
5431 o->op_private |= OPpEXIT_VMSISH;
5438 Perl_ck_exec(pTHX_ OP *o)
5441 if (o->op_flags & OPf_STACKED) {
5443 kid = cUNOPo->op_first->op_sibling;
5444 if (kid->op_type == OP_RV2GV)
5453 Perl_ck_exists(pTHX_ OP *o)
5456 if (o->op_flags & OPf_KIDS) {
5457 OP *kid = cUNOPo->op_first;
5458 if (kid->op_type == OP_ENTERSUB) {
5459 (void) ref(kid, o->op_type);
5460 if (kid->op_type != OP_RV2CV && !PL_error_count)
5461 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5462 PL_op_desc[o->op_type]);
5463 o->op_private |= OPpEXISTS_SUB;
5465 else if (kid->op_type == OP_AELEM)
5466 o->op_flags |= OPf_SPECIAL;
5467 else if (kid->op_type != OP_HELEM)
5468 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5469 PL_op_desc[o->op_type]);
5477 Perl_ck_gvconst(pTHX_ register OP *o)
5479 o = fold_constants(o);
5480 if (o->op_type == OP_CONST)
5487 Perl_ck_rvconst(pTHX_ register OP *o)
5489 SVOP *kid = (SVOP*)cUNOPo->op_first;
5491 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5492 if (kid->op_type == OP_CONST) {
5496 SV *kidsv = kid->op_sv;
5499 /* Is it a constant from cv_const_sv()? */
5500 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5501 SV *rsv = SvRV(kidsv);
5502 int svtype = SvTYPE(rsv);
5503 char *badtype = Nullch;
5505 switch (o->op_type) {
5507 if (svtype > SVt_PVMG)
5508 badtype = "a SCALAR";
5511 if (svtype != SVt_PVAV)
5512 badtype = "an ARRAY";
5515 if (svtype != SVt_PVHV) {
5516 if (svtype == SVt_PVAV) { /* pseudohash? */
5517 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5518 if (ksv && SvROK(*ksv)
5519 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5528 if (svtype != SVt_PVCV)
5533 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5536 name = SvPV(kidsv, n_a);
5537 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5538 char *badthing = Nullch;
5539 switch (o->op_type) {
5541 badthing = "a SCALAR";
5544 badthing = "an ARRAY";
5547 badthing = "a HASH";
5552 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5556 * This is a little tricky. We only want to add the symbol if we
5557 * didn't add it in the lexer. Otherwise we get duplicate strict
5558 * warnings. But if we didn't add it in the lexer, we must at
5559 * least pretend like we wanted to add it even if it existed before,
5560 * or we get possible typo warnings. OPpCONST_ENTERED says
5561 * whether the lexer already added THIS instance of this symbol.
5563 iscv = (o->op_type == OP_RV2CV) * 2;
5565 gv = gv_fetchpv(name,
5566 iscv | !(kid->op_private & OPpCONST_ENTERED),
5569 : o->op_type == OP_RV2SV
5571 : o->op_type == OP_RV2AV
5573 : o->op_type == OP_RV2HV
5576 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5578 kid->op_type = OP_GV;
5579 SvREFCNT_dec(kid->op_sv);
5581 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5582 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5583 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5585 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5587 kid->op_sv = SvREFCNT_inc(gv);
5589 kid->op_private = 0;
5590 kid->op_ppaddr = PL_ppaddr[OP_GV];
5597 Perl_ck_ftst(pTHX_ OP *o)
5599 I32 type = o->op_type;
5601 if (o->op_flags & OPf_REF) {
5604 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5605 SVOP *kid = (SVOP*)cUNOPo->op_first;
5607 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5609 OP *newop = newGVOP(type, OPf_REF,
5610 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5617 if (type == OP_FTTTY)
5618 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5621 o = newUNOP(type, 0, newDEFSVOP());
5624 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5626 if (PL_hints & HINT_LOCALE)
5627 o->op_private |= OPpLOCALE;
5634 Perl_ck_fun(pTHX_ OP *o)
5640 int type = o->op_type;
5641 register I32 oa = PL_opargs[type] >> OASHIFT;
5643 if (o->op_flags & OPf_STACKED) {
5644 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5647 return no_fh_allowed(o);
5650 if (o->op_flags & OPf_KIDS) {
5652 tokid = &cLISTOPo->op_first;
5653 kid = cLISTOPo->op_first;
5654 if (kid->op_type == OP_PUSHMARK ||
5655 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5657 tokid = &kid->op_sibling;
5658 kid = kid->op_sibling;
5660 if (!kid && PL_opargs[type] & OA_DEFGV)
5661 *tokid = kid = newDEFSVOP();
5665 sibl = kid->op_sibling;
5668 /* list seen where single (scalar) arg expected? */
5669 if (numargs == 1 && !(oa >> 4)
5670 && kid->op_type == OP_LIST && type != OP_SCALAR)
5672 return too_many_arguments(o,PL_op_desc[type]);
5685 if (kid->op_type == OP_CONST &&
5686 (kid->op_private & OPpCONST_BARE))
5688 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5689 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5690 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5691 if (ckWARN(WARN_DEPRECATED))
5692 Perl_warner(aTHX_ WARN_DEPRECATED,
5693 "Array @%s missing the @ in argument %"IVdf" of %s()",
5694 name, (IV)numargs, PL_op_desc[type]);
5697 kid->op_sibling = sibl;
5700 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5701 bad_type(numargs, "array", PL_op_desc[type], kid);
5705 if (kid->op_type == OP_CONST &&
5706 (kid->op_private & OPpCONST_BARE))
5708 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5709 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5710 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5711 if (ckWARN(WARN_DEPRECATED))
5712 Perl_warner(aTHX_ WARN_DEPRECATED,
5713 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5714 name, (IV)numargs, PL_op_desc[type]);
5717 kid->op_sibling = sibl;
5720 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5721 bad_type(numargs, "hash", PL_op_desc[type], kid);
5726 OP *newop = newUNOP(OP_NULL, 0, kid);
5727 kid->op_sibling = 0;
5729 newop->op_next = newop;
5731 kid->op_sibling = sibl;
5736 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5737 if (kid->op_type == OP_CONST &&
5738 (kid->op_private & OPpCONST_BARE))
5740 OP *newop = newGVOP(OP_GV, 0,
5741 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5746 else if (kid->op_type == OP_READLINE) {
5747 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5748 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5751 I32 flags = OPf_SPECIAL;
5755 /* is this op a FH constructor? */
5756 if (is_handle_constructor(o,numargs)) {
5757 char *name = Nullch;
5761 /* Set a flag to tell rv2gv to vivify
5762 * need to "prove" flag does not mean something
5763 * else already - NI-S 1999/05/07
5766 if (kid->op_type == OP_PADSV) {
5767 SV **namep = av_fetch(PL_comppad_name,
5769 if (namep && *namep)
5770 name = SvPV(*namep, len);
5772 else if (kid->op_type == OP_RV2SV
5773 && kUNOP->op_first->op_type == OP_GV)
5775 GV *gv = cGVOPx_gv(kUNOP->op_first);
5777 len = GvNAMELEN(gv);
5779 else if (kid->op_type == OP_AELEM
5780 || kid->op_type == OP_HELEM)
5782 name = "__ANONIO__";
5788 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5789 namesv = PL_curpad[targ];
5790 (void)SvUPGRADE(namesv, SVt_PV);
5792 sv_setpvn(namesv, "$", 1);
5793 sv_catpvn(namesv, name, len);
5796 kid->op_sibling = 0;
5797 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5798 kid->op_targ = targ;
5799 kid->op_private |= priv;
5801 kid->op_sibling = sibl;
5807 mod(scalar(kid), type);
5811 tokid = &kid->op_sibling;
5812 kid = kid->op_sibling;
5814 o->op_private |= numargs;
5816 return too_many_arguments(o,PL_op_desc[o->op_type]);
5819 else if (PL_opargs[type] & OA_DEFGV) {
5821 return newUNOP(type, 0, newDEFSVOP());
5825 while (oa & OA_OPTIONAL)
5827 if (oa && oa != OA_LIST)
5828 return too_few_arguments(o,PL_op_desc[o->op_type]);
5834 Perl_ck_glob(pTHX_ OP *o)
5839 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5840 append_elem(OP_GLOB, o, newDEFSVOP());
5842 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5843 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5845 #if !defined(PERL_EXTERNAL_GLOB)
5846 /* XXX this can be tightened up and made more failsafe. */
5849 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5850 /* null-terminated import list */
5851 newSVpvn(":globally", 9), Nullsv);
5852 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5855 #endif /* PERL_EXTERNAL_GLOB */
5857 if (gv && GvIMPORTED_CV(gv)) {
5858 append_elem(OP_GLOB, o,
5859 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5860 o->op_type = OP_LIST;
5861 o->op_ppaddr = PL_ppaddr[OP_LIST];
5862 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5863 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5864 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5865 append_elem(OP_LIST, o,
5866 scalar(newUNOP(OP_RV2CV, 0,
5867 newGVOP(OP_GV, 0, gv)))));
5868 o = newUNOP(OP_NULL, 0, ck_subr(o));
5869 o->op_targ = OP_GLOB; /* hint at what it used to be */
5872 gv = newGVgen("main");
5874 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5880 Perl_ck_grep(pTHX_ OP *o)
5884 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5886 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5887 NewOp(1101, gwop, 1, LOGOP);
5889 if (o->op_flags & OPf_STACKED) {
5892 kid = cLISTOPo->op_first->op_sibling;
5893 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5896 kid->op_next = (OP*)gwop;
5897 o->op_flags &= ~OPf_STACKED;
5899 kid = cLISTOPo->op_first->op_sibling;
5900 if (type == OP_MAPWHILE)
5907 kid = cLISTOPo->op_first->op_sibling;
5908 if (kid->op_type != OP_NULL)
5909 Perl_croak(aTHX_ "panic: ck_grep");
5910 kid = kUNOP->op_first;
5912 gwop->op_type = type;
5913 gwop->op_ppaddr = PL_ppaddr[type];
5914 gwop->op_first = listkids(o);
5915 gwop->op_flags |= OPf_KIDS;
5916 gwop->op_private = 1;
5917 gwop->op_other = LINKLIST(kid);
5918 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5919 kid->op_next = (OP*)gwop;
5921 kid = cLISTOPo->op_first->op_sibling;
5922 if (!kid || !kid->op_sibling)
5923 return too_few_arguments(o,PL_op_desc[o->op_type]);
5924 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5925 mod(kid, OP_GREPSTART);
5931 Perl_ck_index(pTHX_ OP *o)
5933 if (o->op_flags & OPf_KIDS) {
5934 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5936 kid = kid->op_sibling; /* get past "big" */
5937 if (kid && kid->op_type == OP_CONST)
5938 fbm_compile(((SVOP*)kid)->op_sv, 0);
5944 Perl_ck_lengthconst(pTHX_ OP *o)
5946 /* XXX length optimization goes here */
5951 Perl_ck_lfun(pTHX_ OP *o)
5953 OPCODE type = o->op_type;
5954 return modkids(ck_fun(o), type);
5958 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5960 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5961 switch (cUNOPo->op_first->op_type) {
5963 /* This is needed for
5964 if (defined %stash::)
5965 to work. Do not break Tk.
5967 break; /* Globals via GV can be undef */
5969 case OP_AASSIGN: /* Is this a good idea? */
5970 Perl_warner(aTHX_ WARN_DEPRECATED,
5971 "defined(@array) is deprecated");
5972 Perl_warner(aTHX_ WARN_DEPRECATED,
5973 "\t(Maybe you should just omit the defined()?)\n");
5976 /* This is needed for
5977 if (defined %stash::)
5978 to work. Do not break Tk.
5980 break; /* Globals via GV can be undef */
5982 Perl_warner(aTHX_ WARN_DEPRECATED,
5983 "defined(%%hash) is deprecated");
5984 Perl_warner(aTHX_ WARN_DEPRECATED,
5985 "\t(Maybe you should just omit the defined()?)\n");
5996 Perl_ck_rfun(pTHX_ OP *o)
5998 OPCODE type = o->op_type;
5999 return refkids(ck_fun(o), type);
6003 Perl_ck_listiob(pTHX_ OP *o)
6007 kid = cLISTOPo->op_first;
6010 kid = cLISTOPo->op_first;
6012 if (kid->op_type == OP_PUSHMARK)
6013 kid = kid->op_sibling;
6014 if (kid && o->op_flags & OPf_STACKED)
6015 kid = kid->op_sibling;
6016 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6017 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6018 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6019 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6020 cLISTOPo->op_first->op_sibling = kid;
6021 cLISTOPo->op_last = kid;
6022 kid = kid->op_sibling;
6027 append_elem(o->op_type, o, newDEFSVOP());
6033 if (PL_hints & HINT_LOCALE)
6034 o->op_private |= OPpLOCALE;
6041 Perl_ck_fun_locale(pTHX_ OP *o)
6047 if (PL_hints & HINT_LOCALE)
6048 o->op_private |= OPpLOCALE;
6055 Perl_ck_sassign(pTHX_ OP *o)
6057 OP *kid = cLISTOPo->op_first;
6058 /* has a disposable target? */
6059 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6060 && !(kid->op_flags & OPf_STACKED)
6061 /* Cannot steal the second time! */
6062 && !(kid->op_private & OPpTARGET_MY))
6064 OP *kkid = kid->op_sibling;
6066 /* Can just relocate the target. */
6067 if (kkid && kkid->op_type == OP_PADSV
6068 && !(kkid->op_private & OPpLVAL_INTRO))
6070 kid->op_targ = kkid->op_targ;
6072 /* Now we do not need PADSV and SASSIGN. */
6073 kid->op_sibling = o->op_sibling; /* NULL */
6074 cLISTOPo->op_first = NULL;
6077 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6085 Perl_ck_scmp(pTHX_ OP *o)
6089 if (PL_hints & HINT_LOCALE)
6090 o->op_private |= OPpLOCALE;
6097 Perl_ck_match(pTHX_ OP *o)
6099 o->op_private |= OPpRUNTIME;
6104 Perl_ck_method(pTHX_ OP *o)
6106 OP *kid = cUNOPo->op_first;
6107 if (kid->op_type == OP_CONST) {
6108 SV* sv = kSVOP->op_sv;
6109 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6111 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6112 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6115 kSVOP->op_sv = Nullsv;
6117 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6126 Perl_ck_null(pTHX_ OP *o)
6132 Perl_ck_open(pTHX_ OP *o)
6134 HV *table = GvHV(PL_hintgv);
6138 svp = hv_fetch(table, "open_IN", 7, FALSE);
6140 mode = mode_from_discipline(*svp);
6141 if (mode & O_BINARY)
6142 o->op_private |= OPpOPEN_IN_RAW;
6143 else if (mode & O_TEXT)
6144 o->op_private |= OPpOPEN_IN_CRLF;
6147 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6149 mode = mode_from_discipline(*svp);
6150 if (mode & O_BINARY)
6151 o->op_private |= OPpOPEN_OUT_RAW;
6152 else if (mode & O_TEXT)
6153 o->op_private |= OPpOPEN_OUT_CRLF;
6156 if (o->op_type == OP_BACKTICK)
6162 Perl_ck_repeat(pTHX_ OP *o)
6164 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6165 o->op_private |= OPpREPEAT_DOLIST;
6166 cBINOPo->op_first = force_list(cBINOPo->op_first);
6174 Perl_ck_require(pTHX_ OP *o)
6176 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6177 SVOP *kid = (SVOP*)cUNOPo->op_first;
6179 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6181 for (s = SvPVX(kid->op_sv); *s; s++) {
6182 if (*s == ':' && s[1] == ':') {
6184 Move(s+2, s+1, strlen(s+2)+1, char);
6185 --SvCUR(kid->op_sv);
6188 if (SvREADONLY(kid->op_sv)) {
6189 SvREADONLY_off(kid->op_sv);
6190 sv_catpvn(kid->op_sv, ".pm", 3);
6191 SvREADONLY_on(kid->op_sv);
6194 sv_catpvn(kid->op_sv, ".pm", 3);
6201 Perl_ck_return(pTHX_ OP *o)
6204 if (CvLVALUE(PL_compcv)) {
6205 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6206 mod(kid, OP_LEAVESUBLV);
6213 Perl_ck_retarget(pTHX_ OP *o)
6215 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6222 Perl_ck_select(pTHX_ OP *o)
6225 if (o->op_flags & OPf_KIDS) {
6226 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6227 if (kid && kid->op_sibling) {
6228 o->op_type = OP_SSELECT;
6229 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6231 return fold_constants(o);
6235 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6236 if (kid && kid->op_type == OP_RV2GV)
6237 kid->op_private &= ~HINT_STRICT_REFS;
6242 Perl_ck_shift(pTHX_ OP *o)
6244 I32 type = o->op_type;
6246 if (!(o->op_flags & OPf_KIDS)) {
6251 if (!CvUNIQUE(PL_compcv)) {
6252 argop = newOP(OP_PADAV, OPf_REF);
6253 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6256 argop = newUNOP(OP_RV2AV, 0,
6257 scalar(newGVOP(OP_GV, 0,
6258 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6261 argop = newUNOP(OP_RV2AV, 0,
6262 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6263 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6264 #endif /* USE_THREADS */
6265 return newUNOP(type, 0, scalar(argop));
6267 return scalar(modkids(ck_fun(o), type));
6271 Perl_ck_sort(pTHX_ OP *o)
6276 if (PL_hints & HINT_LOCALE)
6277 o->op_private |= OPpLOCALE;
6280 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6282 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6283 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6285 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6287 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6289 if (kid->op_type == OP_SCOPE) {
6293 else if (kid->op_type == OP_LEAVE) {
6294 if (o->op_type == OP_SORT) {
6295 null(kid); /* wipe out leave */
6298 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6299 if (k->op_next == kid)
6301 /* don't descend into loops */
6302 else if (k->op_type == OP_ENTERLOOP
6303 || k->op_type == OP_ENTERITER)
6305 k = cLOOPx(k)->op_lastop;
6310 kid->op_next = 0; /* just disconnect the leave */
6311 k = kLISTOP->op_first;
6316 if (o->op_type == OP_SORT) {
6317 /* provide scalar context for comparison function/block */
6323 o->op_flags |= OPf_SPECIAL;
6325 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6328 firstkid = firstkid->op_sibling;
6331 /* provide list context for arguments */
6332 if (o->op_type == OP_SORT)
6339 S_simplify_sort(pTHX_ OP *o)
6341 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6345 if (!(o->op_flags & OPf_STACKED))
6347 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6348 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6349 kid = kUNOP->op_first; /* get past null */
6350 if (kid->op_type != OP_SCOPE)
6352 kid = kLISTOP->op_last; /* get past scope */
6353 switch(kid->op_type) {
6361 k = kid; /* remember this node*/
6362 if (kBINOP->op_first->op_type != OP_RV2SV)
6364 kid = kBINOP->op_first; /* get past cmp */
6365 if (kUNOP->op_first->op_type != OP_GV)
6367 kid = kUNOP->op_first; /* get past rv2sv */
6369 if (GvSTASH(gv) != PL_curstash)
6371 if (strEQ(GvNAME(gv), "a"))
6373 else if (strEQ(GvNAME(gv), "b"))
6377 kid = k; /* back to cmp */
6378 if (kBINOP->op_last->op_type != OP_RV2SV)
6380 kid = kBINOP->op_last; /* down to 2nd arg */
6381 if (kUNOP->op_first->op_type != OP_GV)
6383 kid = kUNOP->op_first; /* get past rv2sv */
6385 if (GvSTASH(gv) != PL_curstash
6387 ? strNE(GvNAME(gv), "a")
6388 : strNE(GvNAME(gv), "b")))
6390 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6392 o->op_private |= OPpSORT_REVERSE;
6393 if (k->op_type == OP_NCMP)
6394 o->op_private |= OPpSORT_NUMERIC;
6395 if (k->op_type == OP_I_NCMP)
6396 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6397 kid = cLISTOPo->op_first->op_sibling;
6398 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6399 op_free(kid); /* then delete it */
6403 Perl_ck_split(pTHX_ OP *o)
6407 if (o->op_flags & OPf_STACKED)
6408 return no_fh_allowed(o);
6410 kid = cLISTOPo->op_first;
6411 if (kid->op_type != OP_NULL)
6412 Perl_croak(aTHX_ "panic: ck_split");
6413 kid = kid->op_sibling;
6414 op_free(cLISTOPo->op_first);
6415 cLISTOPo->op_first = kid;
6417 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6418 cLISTOPo->op_last = kid; /* There was only one element previously */
6421 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6422 OP *sibl = kid->op_sibling;
6423 kid->op_sibling = 0;
6424 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6425 if (cLISTOPo->op_first == cLISTOPo->op_last)
6426 cLISTOPo->op_last = kid;
6427 cLISTOPo->op_first = kid;
6428 kid->op_sibling = sibl;
6431 kid->op_type = OP_PUSHRE;
6432 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6435 if (!kid->op_sibling)
6436 append_elem(OP_SPLIT, o, newDEFSVOP());
6438 kid = kid->op_sibling;
6441 if (!kid->op_sibling)
6442 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6444 kid = kid->op_sibling;
6447 if (kid->op_sibling)
6448 return too_many_arguments(o,PL_op_desc[o->op_type]);
6454 Perl_ck_join(pTHX_ OP *o)
6456 if (ckWARN(WARN_SYNTAX)) {
6457 OP *kid = cLISTOPo->op_first->op_sibling;
6458 if (kid && kid->op_type == OP_MATCH) {
6459 char *pmstr = "STRING";
6460 if (kPMOP->op_pmregexp)
6461 pmstr = kPMOP->op_pmregexp->precomp;
6462 Perl_warner(aTHX_ WARN_SYNTAX,
6463 "/%s/ should probably be written as \"%s\"",
6471 Perl_ck_subr(pTHX_ OP *o)
6473 OP *prev = ((cUNOPo->op_first->op_sibling)
6474 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6475 OP *o2 = prev->op_sibling;
6484 o->op_private |= OPpENTERSUB_HASTARG;
6485 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6486 if (cvop->op_type == OP_RV2CV) {
6488 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6489 null(cvop); /* disable rv2cv */
6490 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6491 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6492 GV *gv = cGVOPx_gv(tmpop);
6495 tmpop->op_private |= OPpEARLY_CV;
6496 else if (SvPOK(cv)) {
6497 namegv = CvANON(cv) ? gv : CvGV(cv);
6498 proto = SvPV((SV*)cv, n_a);
6502 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6503 if (o2->op_type == OP_CONST)
6504 o2->op_private &= ~OPpCONST_STRICT;
6505 else if (o2->op_type == OP_LIST) {
6506 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6507 if (o && o->op_type == OP_CONST)
6508 o->op_private &= ~OPpCONST_STRICT;
6511 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6512 if (PERLDB_SUB && PL_curstash != PL_debstash)
6513 o->op_private |= OPpENTERSUB_DB;
6514 while (o2 != cvop) {
6518 return too_many_arguments(o, gv_ename(namegv));
6536 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6538 arg == 1 ? "block or sub {}" : "sub {}",
6539 gv_ename(namegv), o2);
6542 /* '*' allows any scalar type, including bareword */
6545 if (o2->op_type == OP_RV2GV)
6546 goto wrapref; /* autoconvert GLOB -> GLOBref */
6547 else if (o2->op_type == OP_CONST)
6548 o2->op_private &= ~OPpCONST_STRICT;
6549 else if (o2->op_type == OP_ENTERSUB) {
6550 /* accidental subroutine, revert to bareword */
6551 OP *gvop = ((UNOP*)o2)->op_first;
6552 if (gvop && gvop->op_type == OP_NULL) {
6553 gvop = ((UNOP*)gvop)->op_first;
6555 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6558 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6559 (gvop = ((UNOP*)gvop)->op_first) &&
6560 gvop->op_type == OP_GV)
6562 GV *gv = cGVOPx_gv(gvop);
6563 OP *sibling = o2->op_sibling;
6564 SV *n = newSVpvn("",0);
6566 gv_fullname3(n, gv, "");
6567 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6568 sv_chop(n, SvPVX(n)+6);
6569 o2 = newSVOP(OP_CONST, 0, n);
6570 prev->op_sibling = o2;
6571 o2->op_sibling = sibling;
6583 if (o2->op_type != OP_RV2GV)
6584 bad_type(arg, "symbol", gv_ename(namegv), o2);
6587 if (o2->op_type != OP_ENTERSUB)
6588 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6591 if (o2->op_type != OP_RV2SV
6592 && o2->op_type != OP_PADSV
6593 && o2->op_type != OP_HELEM
6594 && o2->op_type != OP_AELEM
6595 && o2->op_type != OP_THREADSV)
6597 bad_type(arg, "scalar", gv_ename(namegv), o2);
6601 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6602 bad_type(arg, "array", gv_ename(namegv), o2);
6605 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6606 bad_type(arg, "hash", gv_ename(namegv), o2);
6610 OP* sib = kid->op_sibling;
6611 kid->op_sibling = 0;
6612 o2 = newUNOP(OP_REFGEN, 0, kid);
6613 o2->op_sibling = sib;
6614 prev->op_sibling = o2;
6625 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6626 gv_ename(namegv), SvPV((SV*)cv, n_a));
6631 mod(o2, OP_ENTERSUB);
6633 o2 = o2->op_sibling;
6635 if (proto && !optional &&
6636 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6637 return too_few_arguments(o, gv_ename(namegv));
6642 Perl_ck_svconst(pTHX_ OP *o)
6644 SvREADONLY_on(cSVOPo->op_sv);
6649 Perl_ck_trunc(pTHX_ OP *o)
6651 if (o->op_flags & OPf_KIDS) {
6652 SVOP *kid = (SVOP*)cUNOPo->op_first;
6654 if (kid->op_type == OP_NULL)
6655 kid = (SVOP*)kid->op_sibling;
6656 if (kid && kid->op_type == OP_CONST &&
6657 (kid->op_private & OPpCONST_BARE))
6659 o->op_flags |= OPf_SPECIAL;
6660 kid->op_private &= ~OPpCONST_STRICT;
6667 Perl_ck_substr(pTHX_ OP *o)
6670 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6671 OP *kid = cLISTOPo->op_first;
6673 if (kid->op_type == OP_NULL)
6674 kid = kid->op_sibling;
6676 kid->op_flags |= OPf_MOD;
6682 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6685 Perl_peep(pTHX_ register OP *o)
6687 register OP* oldop = 0;
6690 if (!o || o->op_seq)
6694 SAVEVPTR(PL_curcop);
6695 for (; o; o = o->op_next) {
6701 switch (o->op_type) {
6705 PL_curcop = ((COP*)o); /* for warnings */
6706 o->op_seq = PL_op_seqmax++;
6710 if (cSVOPo->op_private & OPpCONST_STRICT)
6711 no_bareword_allowed(o);
6713 /* Relocate sv to the pad for thread safety.
6714 * Despite being a "constant", the SV is written to,
6715 * for reference counts, sv_upgrade() etc. */
6717 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6718 if (SvPADTMP(cSVOPo->op_sv)) {
6719 /* If op_sv is already a PADTMP then it is being used by
6720 * some pad, so make a copy. */
6721 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6722 SvREADONLY_on(PL_curpad[ix]);
6723 SvREFCNT_dec(cSVOPo->op_sv);
6726 SvREFCNT_dec(PL_curpad[ix]);
6727 SvPADTMP_on(cSVOPo->op_sv);
6728 PL_curpad[ix] = cSVOPo->op_sv;
6729 /* XXX I don't know how this isn't readonly already. */
6730 SvREADONLY_on(PL_curpad[ix]);
6732 cSVOPo->op_sv = Nullsv;
6736 o->op_seq = PL_op_seqmax++;
6740 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6741 if (o->op_next->op_private & OPpTARGET_MY) {
6742 if (o->op_flags & OPf_STACKED) /* chained concats */
6743 goto ignore_optimization;
6745 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6746 o->op_targ = o->op_next->op_targ;
6747 o->op_next->op_targ = 0;
6748 o->op_private |= OPpTARGET_MY;
6753 ignore_optimization:
6754 o->op_seq = PL_op_seqmax++;
6757 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6758 o->op_seq = PL_op_seqmax++;
6759 break; /* Scalar stub must produce undef. List stub is noop */
6763 if (o->op_targ == OP_NEXTSTATE
6764 || o->op_targ == OP_DBSTATE
6765 || o->op_targ == OP_SETSTATE)
6767 PL_curcop = ((COP*)o);
6774 if (oldop && o->op_next) {
6775 oldop->op_next = o->op_next;
6778 o->op_seq = PL_op_seqmax++;
6782 if (o->op_next->op_type == OP_RV2SV) {
6783 if (!(o->op_next->op_private & OPpDEREF)) {
6785 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6787 o->op_next = o->op_next->op_next;
6788 o->op_type = OP_GVSV;
6789 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6792 else if (o->op_next->op_type == OP_RV2AV) {
6793 OP* pop = o->op_next->op_next;
6795 if (pop->op_type == OP_CONST &&
6796 (PL_op = pop->op_next) &&
6797 pop->op_next->op_type == OP_AELEM &&
6798 !(pop->op_next->op_private &
6799 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6800 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6808 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6809 o->op_next = pop->op_next->op_next;
6810 o->op_type = OP_AELEMFAST;
6811 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6812 o->op_private = (U8)i;
6817 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6819 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6820 /* XXX could check prototype here instead of just carping */
6821 SV *sv = sv_newmortal();
6822 gv_efullname3(sv, gv, Nullch);
6823 Perl_warner(aTHX_ WARN_PROTOTYPE,
6824 "%s() called too early to check prototype",
6829 o->op_seq = PL_op_seqmax++;
6840 o->op_seq = PL_op_seqmax++;
6841 while (cLOGOP->op_other->op_type == OP_NULL)
6842 cLOGOP->op_other = cLOGOP->op_other->op_next;
6843 peep(cLOGOP->op_other);
6847 o->op_seq = PL_op_seqmax++;
6848 while (cLOOP->op_redoop->op_type == OP_NULL)
6849 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6850 peep(cLOOP->op_redoop);
6851 while (cLOOP->op_nextop->op_type == OP_NULL)
6852 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6853 peep(cLOOP->op_nextop);
6854 while (cLOOP->op_lastop->op_type == OP_NULL)
6855 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6856 peep(cLOOP->op_lastop);
6862 o->op_seq = PL_op_seqmax++;
6863 while (cPMOP->op_pmreplstart &&
6864 cPMOP->op_pmreplstart->op_type == OP_NULL)
6865 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6866 peep(cPMOP->op_pmreplstart);
6870 o->op_seq = PL_op_seqmax++;
6871 if (ckWARN(WARN_SYNTAX) && o->op_next
6872 && o->op_next->op_type == OP_NEXTSTATE) {
6873 if (o->op_next->op_sibling &&
6874 o->op_next->op_sibling->op_type != OP_EXIT &&
6875 o->op_next->op_sibling->op_type != OP_WARN &&
6876 o->op_next->op_sibling->op_type != OP_DIE) {
6877 line_t oldline = CopLINE(PL_curcop);
6879 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6880 Perl_warner(aTHX_ WARN_EXEC,
6881 "Statement unlikely to be reached");
6882 Perl_warner(aTHX_ WARN_EXEC,
6883 "\t(Maybe you meant system() when you said exec()?)\n");
6884 CopLINE_set(PL_curcop, oldline);
6893 SV **svp, **indsvp, *sv;
6898 o->op_seq = PL_op_seqmax++;
6900 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6903 /* Make the CONST have a shared SV */
6904 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6905 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6906 key = SvPV(sv, keylen);
6909 lexname = newSVpvn_share(key, keylen, 0);
6914 if ((o->op_private & (OPpLVAL_INTRO)))
6917 rop = (UNOP*)((BINOP*)o)->op_first;
6918 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6920 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6921 if (!SvOBJECT(lexname))
6923 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6924 if (!fields || !GvHV(*fields))
6926 key = SvPV(*svp, keylen);
6929 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6931 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6932 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6934 ind = SvIV(*indsvp);
6936 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6937 rop->op_type = OP_RV2AV;
6938 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6939 o->op_type = OP_AELEM;
6940 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6942 if (SvREADONLY(*svp))
6944 SvFLAGS(sv) |= (SvFLAGS(*svp)
6945 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6955 SV **svp, **indsvp, *sv;
6959 SVOP *first_key_op, *key_op;
6961 o->op_seq = PL_op_seqmax++;
6962 if ((o->op_private & (OPpLVAL_INTRO))
6963 /* I bet there's always a pushmark... */
6964 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6965 /* hmmm, no optimization if list contains only one key. */
6967 rop = (UNOP*)((LISTOP*)o)->op_last;
6968 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6970 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6971 if (!SvOBJECT(lexname))
6973 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6974 if (!fields || !GvHV(*fields))
6976 /* Again guessing that the pushmark can be jumped over.... */
6977 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6978 ->op_first->op_sibling;
6979 /* Check that the key list contains only constants. */
6980 for (key_op = first_key_op; key_op;
6981 key_op = (SVOP*)key_op->op_sibling)
6982 if (key_op->op_type != OP_CONST)
6986 rop->op_type = OP_RV2AV;
6987 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6988 o->op_type = OP_ASLICE;
6989 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6990 for (key_op = first_key_op; key_op;
6991 key_op = (SVOP*)key_op->op_sibling) {
6992 svp = cSVOPx_svp(key_op);
6993 key = SvPV(*svp, keylen);
6996 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6998 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6999 "in variable %s of type %s",
7000 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7002 ind = SvIV(*indsvp);
7004 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7006 if (SvREADONLY(*svp))
7008 SvFLAGS(sv) |= (SvFLAGS(*svp)
7009 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7017 o->op_seq = PL_op_seqmax++;
7027 /* Efficient sub that returns a constant scalar value. */
7029 const_sv_xsub(pTHXo_ CV* cv)
7034 Perl_croak(aTHX_ "usage: %s::%s()",
7035 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7039 ST(0) = (SV*)XSANY.any_ptr;