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 (NATIVE_IS_INVARIANT(*s) || NATIVE_TO_UTF(*s) == 0xff)
120 U8 c = NATIVE_TO_ASCII(*s++);
121 *d++ = UTF8_EIGHT_BIT_HI(c);
122 *d++ = UTF8_EIGHT_BIT_LO(c);
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 scalar(cBINOPo->op_first);
985 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
989 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
990 if (!kPMOP->op_pmreplroot)
991 deprecate("implicit split to @_");
999 if (o->op_flags & OPf_KIDS) {
1000 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1006 kid = cLISTOPo->op_first;
1008 while ((kid = kid->op_sibling)) {
1009 if (kid->op_sibling)
1014 WITH_THR(PL_curcop = &PL_compiling);
1019 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1020 if (kid->op_sibling)
1025 WITH_THR(PL_curcop = &PL_compiling);
1032 Perl_scalarvoid(pTHX_ OP *o)
1039 if (o->op_type == OP_NEXTSTATE
1040 || o->op_type == OP_SETSTATE
1041 || o->op_type == OP_DBSTATE
1042 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1043 || o->op_targ == OP_SETSTATE
1044 || o->op_targ == OP_DBSTATE)))
1045 PL_curcop = (COP*)o; /* for warning below */
1047 /* assumes no premature commitment */
1048 want = o->op_flags & OPf_WANT;
1049 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1050 || o->op_type == OP_RETURN)
1055 if ((o->op_private & OPpTARGET_MY)
1056 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1058 return scalar(o); /* As if inside SASSIGN */
1061 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1063 switch (o->op_type) {
1065 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1069 if (o->op_flags & OPf_STACKED)
1073 if (o->op_private == 4)
1115 case OP_GETSOCKNAME:
1116 case OP_GETPEERNAME:
1121 case OP_GETPRIORITY:
1144 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1145 useless = PL_op_desc[o->op_type];
1152 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1153 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1154 useless = "a variable";
1159 if (cSVOPo->op_private & OPpCONST_STRICT)
1160 no_bareword_allowed(o);
1162 if (ckWARN(WARN_VOID)) {
1163 useless = "a constant";
1164 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1166 else if (SvPOK(sv)) {
1167 /* perl4's way of mixing documentation and code
1168 (before the invention of POD) was based on a
1169 trick to mix nroff and perl code. The trick was
1170 built upon these three nroff macros being used in
1171 void context. The pink camel has the details in
1172 the script wrapman near page 319. */
1173 if (strnEQ(SvPVX(sv), "di", 2) ||
1174 strnEQ(SvPVX(sv), "ds", 2) ||
1175 strnEQ(SvPVX(sv), "ig", 2))
1180 null(o); /* don't execute or even remember it */
1184 o->op_type = OP_PREINC; /* pre-increment is faster */
1185 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1189 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1190 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1196 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1201 if (o->op_flags & OPf_STACKED)
1208 if (!(o->op_flags & OPf_KIDS))
1217 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1224 /* all requires must return a boolean value */
1225 o->op_flags &= ~OPf_WANT;
1230 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1231 if (!kPMOP->op_pmreplroot)
1232 deprecate("implicit split to @_");
1236 if (useless && ckWARN(WARN_VOID))
1237 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1242 Perl_listkids(pTHX_ OP *o)
1245 if (o && o->op_flags & OPf_KIDS) {
1246 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1253 Perl_list(pTHX_ OP *o)
1257 /* assumes no premature commitment */
1258 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1259 || o->op_type == OP_RETURN)
1264 if ((o->op_private & OPpTARGET_MY)
1265 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1267 return o; /* As if inside SASSIGN */
1270 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1272 switch (o->op_type) {
1275 list(cBINOPo->op_first);
1280 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1288 if (!(o->op_flags & OPf_KIDS))
1290 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1291 list(cBINOPo->op_first);
1292 return gen_constant_list(o);
1299 kid = cLISTOPo->op_first;
1301 while ((kid = kid->op_sibling)) {
1302 if (kid->op_sibling)
1307 WITH_THR(PL_curcop = &PL_compiling);
1311 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1312 if (kid->op_sibling)
1317 WITH_THR(PL_curcop = &PL_compiling);
1320 /* all requires must return a boolean value */
1321 o->op_flags &= ~OPf_WANT;
1328 Perl_scalarseq(pTHX_ OP *o)
1333 if (o->op_type == OP_LINESEQ ||
1334 o->op_type == OP_SCOPE ||
1335 o->op_type == OP_LEAVE ||
1336 o->op_type == OP_LEAVETRY)
1338 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1339 if (kid->op_sibling) {
1343 PL_curcop = &PL_compiling;
1345 o->op_flags &= ~OPf_PARENS;
1346 if (PL_hints & HINT_BLOCK_SCOPE)
1347 o->op_flags |= OPf_PARENS;
1350 o = newOP(OP_STUB, 0);
1355 S_modkids(pTHX_ OP *o, I32 type)
1358 if (o && o->op_flags & OPf_KIDS) {
1359 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1366 Perl_mod(pTHX_ OP *o, I32 type)
1371 if (!o || PL_error_count)
1374 if ((o->op_private & OPpTARGET_MY)
1375 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1380 switch (o->op_type) {
1385 if (o->op_private & (OPpCONST_BARE) &&
1386 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1387 SV *sv = ((SVOP*)o)->op_sv;
1390 /* Could be a filehandle */
1391 if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1392 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1396 /* OK, it's a sub */
1398 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1400 enter = newUNOP(OP_ENTERSUB,0,
1401 newUNOP(OP_RV2CV, 0,
1402 newGVOP(OP_GV, 0, gv)
1404 enter->op_private |= OPpLVAL_INTRO;
1410 if (!(o->op_private & (OPpCONST_ARYBASE)))
1412 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1413 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1417 SAVEI32(PL_compiling.cop_arybase);
1418 PL_compiling.cop_arybase = 0;
1420 else if (type == OP_REFGEN)
1423 Perl_croak(aTHX_ "That use of $[ is unsupported");
1426 if (o->op_flags & OPf_PARENS)
1430 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1431 !(o->op_flags & OPf_STACKED)) {
1432 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1433 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1434 assert(cUNOPo->op_first->op_type == OP_NULL);
1435 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1438 else { /* lvalue subroutine call */
1439 o->op_private |= OPpLVAL_INTRO;
1440 PL_modcount = RETURN_UNLIMITED_NUMBER;
1441 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1442 /* Backward compatibility mode: */
1443 o->op_private |= OPpENTERSUB_INARGS;
1446 else { /* Compile-time error message: */
1447 OP *kid = cUNOPo->op_first;
1451 if (kid->op_type == OP_PUSHMARK)
1453 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1455 "panic: unexpected lvalue entersub "
1456 "args: type/targ %ld:%ld",
1457 (long)kid->op_type,kid->op_targ);
1458 kid = kLISTOP->op_first;
1460 while (kid->op_sibling)
1461 kid = kid->op_sibling;
1462 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1464 if (kid->op_type == OP_METHOD_NAMED
1465 || kid->op_type == OP_METHOD)
1469 if (kid->op_sibling || kid->op_next != kid) {
1470 yyerror("panic: unexpected optree near method call");
1474 NewOp(1101, newop, 1, UNOP);
1475 newop->op_type = OP_RV2CV;
1476 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1477 newop->op_first = Nullop;
1478 newop->op_next = (OP*)newop;
1479 kid->op_sibling = (OP*)newop;
1480 newop->op_private |= OPpLVAL_INTRO;
1484 if (kid->op_type != OP_RV2CV)
1486 "panic: unexpected lvalue entersub "
1487 "entry via type/targ %ld:%ld",
1488 (long)kid->op_type,kid->op_targ);
1489 kid->op_private |= OPpLVAL_INTRO;
1490 break; /* Postpone until runtime */
1494 kid = kUNOP->op_first;
1495 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1496 kid = kUNOP->op_first;
1497 if (kid->op_type == OP_NULL)
1499 "Unexpected constant lvalue entersub "
1500 "entry via type/targ %ld:%ld",
1501 (long)kid->op_type,kid->op_targ);
1502 if (kid->op_type != OP_GV) {
1503 /* Restore RV2CV to check lvalueness */
1505 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1506 okid->op_next = kid->op_next;
1507 kid->op_next = okid;
1510 okid->op_next = Nullop;
1511 okid->op_type = OP_RV2CV;
1513 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1514 okid->op_private |= OPpLVAL_INTRO;
1518 cv = GvCV(kGVOP_gv);
1528 /* grep, foreach, subcalls, refgen */
1529 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1531 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1532 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1534 : (o->op_type == OP_ENTERSUB
1535 ? "non-lvalue subroutine call"
1536 : PL_op_desc[o->op_type])),
1537 type ? PL_op_desc[type] : "local"));
1551 case OP_RIGHT_SHIFT:
1560 if (!(o->op_flags & OPf_STACKED))
1566 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1572 if (!type && cUNOPo->op_first->op_type != OP_GV)
1573 Perl_croak(aTHX_ "Can't localize through a reference");
1574 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1575 PL_modcount = RETURN_UNLIMITED_NUMBER;
1576 return o; /* Treat \(@foo) like ordinary list. */
1580 if (scalar_mod_type(o, type))
1582 ref(cUNOPo->op_first, o->op_type);
1586 if (type == OP_LEAVESUBLV)
1587 o->op_private |= OPpMAYBE_LVSUB;
1593 PL_modcount = RETURN_UNLIMITED_NUMBER;
1596 if (!type && cUNOPo->op_first->op_type != OP_GV)
1597 Perl_croak(aTHX_ "Can't localize through a reference");
1598 ref(cUNOPo->op_first, o->op_type);
1602 PL_hints |= HINT_BLOCK_SCOPE;
1612 PL_modcount = RETURN_UNLIMITED_NUMBER;
1613 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1614 return o; /* Treat \(@foo) like ordinary list. */
1615 if (scalar_mod_type(o, type))
1617 if (type == OP_LEAVESUBLV)
1618 o->op_private |= OPpMAYBE_LVSUB;
1623 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1624 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1629 PL_modcount++; /* XXX ??? */
1631 #endif /* USE_THREADS */
1637 if (type != OP_SASSIGN)
1641 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1646 if (type == OP_LEAVESUBLV)
1647 o->op_private |= OPpMAYBE_LVSUB;
1649 pad_free(o->op_targ);
1650 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1651 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1652 if (o->op_flags & OPf_KIDS)
1653 mod(cBINOPo->op_first->op_sibling, type);
1658 ref(cBINOPo->op_first, o->op_type);
1659 if (type == OP_ENTERSUB &&
1660 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1661 o->op_private |= OPpLVAL_DEFER;
1662 if (type == OP_LEAVESUBLV)
1663 o->op_private |= OPpMAYBE_LVSUB;
1671 if (o->op_flags & OPf_KIDS)
1672 mod(cLISTOPo->op_last, type);
1676 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1678 else if (!(o->op_flags & OPf_KIDS))
1680 if (o->op_targ != OP_LIST) {
1681 mod(cBINOPo->op_first, type);
1686 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1691 if (type != OP_LEAVESUBLV)
1693 break; /* mod()ing was handled by ck_return() */
1695 if (type != OP_LEAVESUBLV)
1696 o->op_flags |= OPf_MOD;
1698 if (type == OP_AASSIGN || type == OP_SASSIGN)
1699 o->op_flags |= OPf_SPECIAL|OPf_REF;
1701 o->op_private |= OPpLVAL_INTRO;
1702 o->op_flags &= ~OPf_SPECIAL;
1703 PL_hints |= HINT_BLOCK_SCOPE;
1705 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1706 && type != OP_LEAVESUBLV)
1707 o->op_flags |= OPf_REF;
1712 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1716 if (o->op_type == OP_RV2GV)
1740 case OP_RIGHT_SHIFT:
1759 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1761 switch (o->op_type) {
1769 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1782 Perl_refkids(pTHX_ OP *o, I32 type)
1785 if (o && o->op_flags & OPf_KIDS) {
1786 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1793 Perl_ref(pTHX_ OP *o, I32 type)
1797 if (!o || PL_error_count)
1800 switch (o->op_type) {
1802 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1803 !(o->op_flags & OPf_STACKED)) {
1804 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1805 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1806 assert(cUNOPo->op_first->op_type == OP_NULL);
1807 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1808 o->op_flags |= OPf_SPECIAL;
1813 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1817 if (type == OP_DEFINED)
1818 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1819 ref(cUNOPo->op_first, o->op_type);
1822 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1823 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1824 : type == OP_RV2HV ? OPpDEREF_HV
1826 o->op_flags |= OPf_MOD;
1831 o->op_flags |= OPf_MOD; /* XXX ??? */
1836 o->op_flags |= OPf_REF;
1839 if (type == OP_DEFINED)
1840 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1841 ref(cUNOPo->op_first, o->op_type);
1846 o->op_flags |= OPf_REF;
1851 if (!(o->op_flags & OPf_KIDS))
1853 ref(cBINOPo->op_first, type);
1857 ref(cBINOPo->op_first, o->op_type);
1858 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1859 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1860 : type == OP_RV2HV ? OPpDEREF_HV
1862 o->op_flags |= OPf_MOD;
1870 if (!(o->op_flags & OPf_KIDS))
1872 ref(cLISTOPo->op_last, type);
1882 S_dup_attrlist(pTHX_ OP *o)
1886 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1887 * where the first kid is OP_PUSHMARK and the remaining ones
1888 * are OP_CONST. We need to push the OP_CONST values.
1890 if (o->op_type == OP_CONST)
1891 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1893 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1894 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1895 if (o->op_type == OP_CONST)
1896 rop = append_elem(OP_LIST, rop,
1897 newSVOP(OP_CONST, o->op_flags,
1898 SvREFCNT_inc(cSVOPo->op_sv)));
1905 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1909 /* fake up C<use attributes $pkg,$rv,@attrs> */
1910 ENTER; /* need to protect against side-effects of 'use' */
1912 if (stash && HvNAME(stash))
1913 stashsv = newSVpv(HvNAME(stash), 0);
1915 stashsv = &PL_sv_no;
1917 #define ATTRSMODULE "attributes"
1919 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1920 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1922 prepend_elem(OP_LIST,
1923 newSVOP(OP_CONST, 0, stashsv),
1924 prepend_elem(OP_LIST,
1925 newSVOP(OP_CONST, 0,
1927 dup_attrlist(attrs))));
1932 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1933 char *attrstr, STRLEN len)
1938 len = strlen(attrstr);
1942 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1944 char *sstr = attrstr;
1945 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1946 attrs = append_elem(OP_LIST, attrs,
1947 newSVOP(OP_CONST, 0,
1948 newSVpvn(sstr, attrstr-sstr)));
1952 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1953 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1954 Nullsv, prepend_elem(OP_LIST,
1955 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1956 prepend_elem(OP_LIST,
1957 newSVOP(OP_CONST, 0,
1963 S_my_kid(pTHX_ OP *o, OP *attrs)
1968 if (!o || PL_error_count)
1972 if (type == OP_LIST) {
1973 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1975 } else if (type == OP_UNDEF) {
1977 } else if (type == OP_RV2SV || /* "our" declaration */
1979 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1981 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1983 PL_in_my_stash = Nullhv;
1984 apply_attrs(GvSTASH(gv),
1985 (type == OP_RV2SV ? GvSV(gv) :
1986 type == OP_RV2AV ? (SV*)GvAV(gv) :
1987 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1990 o->op_private |= OPpOUR_INTRO;
1992 } else if (type != OP_PADSV &&
1995 type != OP_PUSHMARK)
1997 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1998 PL_op_desc[o->op_type],
1999 PL_in_my == KEY_our ? "our" : "my"));
2002 else if (attrs && type != OP_PUSHMARK) {
2008 PL_in_my_stash = Nullhv;
2010 /* check for C<my Dog $spot> when deciding package */
2011 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2012 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
2013 stash = SvSTASH(*namesvp);
2015 stash = PL_curstash;
2016 padsv = PAD_SV(o->op_targ);
2017 apply_attrs(stash, padsv, attrs);
2019 o->op_flags |= OPf_MOD;
2020 o->op_private |= OPpLVAL_INTRO;
2025 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2027 if (o->op_flags & OPf_PARENS)
2031 o = my_kid(o, attrs);
2033 PL_in_my_stash = Nullhv;
2038 Perl_my(pTHX_ OP *o)
2040 return my_kid(o, Nullop);
2044 Perl_sawparens(pTHX_ OP *o)
2047 o->op_flags |= OPf_PARENS;
2052 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2056 if (ckWARN(WARN_MISC) &&
2057 (left->op_type == OP_RV2AV ||
2058 left->op_type == OP_RV2HV ||
2059 left->op_type == OP_PADAV ||
2060 left->op_type == OP_PADHV)) {
2061 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2062 right->op_type == OP_TRANS)
2063 ? right->op_type : OP_MATCH];
2064 const char *sample = ((left->op_type == OP_RV2AV ||
2065 left->op_type == OP_PADAV)
2066 ? "@array" : "%hash");
2067 Perl_warner(aTHX_ WARN_MISC,
2068 "Applying %s to %s will act on scalar(%s)",
2069 desc, sample, sample);
2072 if (!(right->op_flags & OPf_STACKED) &&
2073 (right->op_type == OP_MATCH ||
2074 right->op_type == OP_SUBST ||
2075 right->op_type == OP_TRANS)) {
2076 right->op_flags |= OPf_STACKED;
2077 if (right->op_type != OP_MATCH &&
2078 ! (right->op_type == OP_TRANS &&
2079 right->op_private & OPpTRANS_IDENTICAL))
2080 left = mod(left, right->op_type);
2081 if (right->op_type == OP_TRANS)
2082 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2084 o = prepend_elem(right->op_type, scalar(left), right);
2086 return newUNOP(OP_NOT, 0, scalar(o));
2090 return bind_match(type, left,
2091 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2095 Perl_invert(pTHX_ OP *o)
2099 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2100 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2104 Perl_scope(pTHX_ OP *o)
2107 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2108 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2109 o->op_type = OP_LEAVE;
2110 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2113 if (o->op_type == OP_LINESEQ) {
2115 o->op_type = OP_SCOPE;
2116 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2117 kid = ((LISTOP*)o)->op_first;
2118 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2122 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2129 Perl_save_hints(pTHX)
2132 SAVESPTR(GvHV(PL_hintgv));
2133 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2134 SAVEFREESV(GvHV(PL_hintgv));
2138 Perl_block_start(pTHX_ int full)
2140 int retval = PL_savestack_ix;
2142 SAVEI32(PL_comppad_name_floor);
2143 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2145 PL_comppad_name_fill = PL_comppad_name_floor;
2146 if (PL_comppad_name_floor < 0)
2147 PL_comppad_name_floor = 0;
2148 SAVEI32(PL_min_intro_pending);
2149 SAVEI32(PL_max_intro_pending);
2150 PL_min_intro_pending = 0;
2151 SAVEI32(PL_comppad_name_fill);
2152 SAVEI32(PL_padix_floor);
2153 PL_padix_floor = PL_padix;
2154 PL_pad_reset_pending = FALSE;
2156 PL_hints &= ~HINT_BLOCK_SCOPE;
2157 SAVESPTR(PL_compiling.cop_warnings);
2158 if (! specialWARN(PL_compiling.cop_warnings)) {
2159 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2160 SAVEFREESV(PL_compiling.cop_warnings) ;
2162 SAVESPTR(PL_compiling.cop_io);
2163 if (! specialCopIO(PL_compiling.cop_io)) {
2164 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2165 SAVEFREESV(PL_compiling.cop_io) ;
2171 Perl_block_end(pTHX_ I32 floor, OP *seq)
2173 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2174 OP* retval = scalarseq(seq);
2176 PL_pad_reset_pending = FALSE;
2177 PL_compiling.op_private = PL_hints;
2179 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2180 pad_leavemy(PL_comppad_name_fill);
2189 OP *o = newOP(OP_THREADSV, 0);
2190 o->op_targ = find_threadsv("_");
2193 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2194 #endif /* USE_THREADS */
2198 Perl_newPROG(pTHX_ OP *o)
2203 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2204 ((PL_in_eval & EVAL_KEEPERR)
2205 ? OPf_SPECIAL : 0), o);
2206 PL_eval_start = linklist(PL_eval_root);
2207 PL_eval_root->op_private |= OPpREFCOUNTED;
2208 OpREFCNT_set(PL_eval_root, 1);
2209 PL_eval_root->op_next = 0;
2210 peep(PL_eval_start);
2215 PL_main_root = scope(sawparens(scalarvoid(o)));
2216 PL_curcop = &PL_compiling;
2217 PL_main_start = LINKLIST(PL_main_root);
2218 PL_main_root->op_private |= OPpREFCOUNTED;
2219 OpREFCNT_set(PL_main_root, 1);
2220 PL_main_root->op_next = 0;
2221 peep(PL_main_start);
2224 /* Register with debugger */
2226 CV *cv = get_cv("DB::postponed", FALSE);
2230 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2232 call_sv((SV*)cv, G_DISCARD);
2239 Perl_localize(pTHX_ OP *o, I32 lex)
2241 if (o->op_flags & OPf_PARENS)
2244 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2246 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2247 if (*s == ';' || *s == '=')
2248 Perl_warner(aTHX_ WARN_PARENTHESIS,
2249 "Parentheses missing around \"%s\" list",
2250 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2256 o = mod(o, OP_NULL); /* a bit kludgey */
2258 PL_in_my_stash = Nullhv;
2263 Perl_jmaybe(pTHX_ OP *o)
2265 if (o->op_type == OP_LIST) {
2268 o2 = newOP(OP_THREADSV, 0);
2269 o2->op_targ = find_threadsv(";");
2271 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2272 #endif /* USE_THREADS */
2273 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2279 Perl_fold_constants(pTHX_ register OP *o)
2282 I32 type = o->op_type;
2285 if (PL_opargs[type] & OA_RETSCALAR)
2287 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2288 o->op_targ = pad_alloc(type, SVs_PADTMP);
2290 /* integerize op, unless it happens to be C<-foo>.
2291 * XXX should pp_i_negate() do magic string negation instead? */
2292 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2293 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2294 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2296 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2299 if (!(PL_opargs[type] & OA_FOLDCONST))
2304 /* XXX might want a ck_negate() for this */
2305 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2318 if (o->op_private & OPpLOCALE)
2323 goto nope; /* Don't try to run w/ errors */
2325 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2326 if ((curop->op_type != OP_CONST ||
2327 (curop->op_private & OPpCONST_BARE)) &&
2328 curop->op_type != OP_LIST &&
2329 curop->op_type != OP_SCALAR &&
2330 curop->op_type != OP_NULL &&
2331 curop->op_type != OP_PUSHMARK)
2337 curop = LINKLIST(o);
2341 sv = *(PL_stack_sp--);
2342 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2343 pad_swipe(o->op_targ);
2344 else if (SvTEMP(sv)) { /* grab mortal temp? */
2345 (void)SvREFCNT_inc(sv);
2349 if (type == OP_RV2GV)
2350 return newGVOP(OP_GV, 0, (GV*)sv);
2352 /* try to smush double to int, but don't smush -2.0 to -2 */
2353 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2356 #ifdef PERL_PRESERVE_IVUV
2357 /* Only bother to attempt to fold to IV if
2358 most operators will benefit */
2362 return newSVOP(OP_CONST, 0, sv);
2366 if (!(PL_opargs[type] & OA_OTHERINT))
2369 if (!(PL_hints & HINT_INTEGER)) {
2370 if (type == OP_MODULO
2371 || type == OP_DIVIDE
2372 || !(o->op_flags & OPf_KIDS))
2377 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2378 if (curop->op_type == OP_CONST) {
2379 if (SvIOK(((SVOP*)curop)->op_sv))
2383 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2387 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2394 Perl_gen_constant_list(pTHX_ register OP *o)
2397 I32 oldtmps_floor = PL_tmps_floor;
2401 return o; /* Don't attempt to run with errors */
2403 PL_op = curop = LINKLIST(o);
2410 PL_tmps_floor = oldtmps_floor;
2412 o->op_type = OP_RV2AV;
2413 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2414 curop = ((UNOP*)o)->op_first;
2415 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2422 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2424 if (!o || o->op_type != OP_LIST)
2425 o = newLISTOP(OP_LIST, 0, o, Nullop);
2427 o->op_flags &= ~OPf_WANT;
2429 if (!(PL_opargs[type] & OA_MARK))
2430 null(cLISTOPo->op_first);
2433 o->op_ppaddr = PL_ppaddr[type];
2434 o->op_flags |= flags;
2436 o = CHECKOP(type, o);
2437 if (o->op_type != type)
2440 return fold_constants(o);
2443 /* List constructors */
2446 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2454 if (first->op_type != type
2455 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2457 return newLISTOP(type, 0, first, last);
2460 if (first->op_flags & OPf_KIDS)
2461 ((LISTOP*)first)->op_last->op_sibling = last;
2463 first->op_flags |= OPf_KIDS;
2464 ((LISTOP*)first)->op_first = last;
2466 ((LISTOP*)first)->op_last = last;
2471 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2479 if (first->op_type != type)
2480 return prepend_elem(type, (OP*)first, (OP*)last);
2482 if (last->op_type != type)
2483 return append_elem(type, (OP*)first, (OP*)last);
2485 first->op_last->op_sibling = last->op_first;
2486 first->op_last = last->op_last;
2487 first->op_flags |= (last->op_flags & OPf_KIDS);
2489 #ifdef PL_OP_SLAB_ALLOC
2497 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2505 if (last->op_type == type) {
2506 if (type == OP_LIST) { /* already a PUSHMARK there */
2507 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2508 ((LISTOP*)last)->op_first->op_sibling = first;
2509 if (!(first->op_flags & OPf_PARENS))
2510 last->op_flags &= ~OPf_PARENS;
2513 if (!(last->op_flags & OPf_KIDS)) {
2514 ((LISTOP*)last)->op_last = first;
2515 last->op_flags |= OPf_KIDS;
2517 first->op_sibling = ((LISTOP*)last)->op_first;
2518 ((LISTOP*)last)->op_first = first;
2520 last->op_flags |= OPf_KIDS;
2524 return newLISTOP(type, 0, first, last);
2530 Perl_newNULLLIST(pTHX)
2532 return newOP(OP_STUB, 0);
2536 Perl_force_list(pTHX_ OP *o)
2538 if (!o || o->op_type != OP_LIST)
2539 o = newLISTOP(OP_LIST, 0, o, Nullop);
2545 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2549 NewOp(1101, listop, 1, LISTOP);
2551 listop->op_type = type;
2552 listop->op_ppaddr = PL_ppaddr[type];
2555 listop->op_flags = flags;
2559 else if (!first && last)
2562 first->op_sibling = last;
2563 listop->op_first = first;
2564 listop->op_last = last;
2565 if (type == OP_LIST) {
2567 pushop = newOP(OP_PUSHMARK, 0);
2568 pushop->op_sibling = first;
2569 listop->op_first = pushop;
2570 listop->op_flags |= OPf_KIDS;
2572 listop->op_last = pushop;
2579 Perl_newOP(pTHX_ I32 type, I32 flags)
2582 NewOp(1101, o, 1, OP);
2584 o->op_ppaddr = PL_ppaddr[type];
2585 o->op_flags = flags;
2588 o->op_private = 0 + (flags >> 8);
2589 if (PL_opargs[type] & OA_RETSCALAR)
2591 if (PL_opargs[type] & OA_TARGET)
2592 o->op_targ = pad_alloc(type, SVs_PADTMP);
2593 return CHECKOP(type, o);
2597 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2602 first = newOP(OP_STUB, 0);
2603 if (PL_opargs[type] & OA_MARK)
2604 first = force_list(first);
2606 NewOp(1101, unop, 1, UNOP);
2607 unop->op_type = type;
2608 unop->op_ppaddr = PL_ppaddr[type];
2609 unop->op_first = first;
2610 unop->op_flags = flags | OPf_KIDS;
2611 unop->op_private = 1 | (flags >> 8);
2612 unop = (UNOP*) CHECKOP(type, unop);
2616 return fold_constants((OP *) unop);
2620 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2623 NewOp(1101, binop, 1, BINOP);
2626 first = newOP(OP_NULL, 0);
2628 binop->op_type = type;
2629 binop->op_ppaddr = PL_ppaddr[type];
2630 binop->op_first = first;
2631 binop->op_flags = flags | OPf_KIDS;
2634 binop->op_private = 1 | (flags >> 8);
2637 binop->op_private = 2 | (flags >> 8);
2638 first->op_sibling = last;
2641 binop = (BINOP*)CHECKOP(type, binop);
2642 if (binop->op_next || binop->op_type != type)
2645 binop->op_last = binop->op_first->op_sibling;
2647 return fold_constants((OP *)binop);
2651 uvcompare(const void *a, const void *b)
2653 if (*((UV *)a) < (*(UV *)b))
2655 if (*((UV *)a) > (*(UV *)b))
2657 if (*((UV *)a+1) < (*(UV *)b+1))
2659 if (*((UV *)a+1) > (*(UV *)b+1))
2665 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2667 SV *tstr = ((SVOP*)expr)->op_sv;
2668 SV *rstr = ((SVOP*)repl)->op_sv;
2671 U8 *t = (U8*)SvPV(tstr, tlen);
2672 U8 *r = (U8*)SvPV(rstr, rlen);
2679 register short *tbl;
2681 complement = o->op_private & OPpTRANS_COMPLEMENT;
2682 del = o->op_private & OPpTRANS_DELETE;
2683 squash = o->op_private & OPpTRANS_SQUASH;
2686 o->op_private |= OPpTRANS_FROM_UTF;
2689 o->op_private |= OPpTRANS_TO_UTF;
2691 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2692 SV* listsv = newSVpvn("# comment\n",10);
2694 U8* tend = t + tlen;
2695 U8* rend = r + rlen;
2709 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2710 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2711 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2712 U8* rsave = (to_utf || !rlen) ? NULL : trlist_upgrade(&r, &rend);
2714 /* There are several snags with this code on EBCDIC:
2715 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2716 2. scan_const() in toke.c has encoded chars in native encoding which makes
2717 ranges at least in EBCDIC 0..255 range the bottom odd.
2721 U8 tmpbuf[UTF8_MAXLEN+1];
2724 New(1109, cp, 2*tlen, UV);
2726 transv = newSVpvn("",0);
2728 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2730 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2732 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2736 cp[2*i+1] = cp[2*i];
2740 qsort(cp, i, 2*sizeof(UV), uvcompare);
2741 for (j = 0; j < i; j++) {
2743 diff = val - nextmin;
2745 t = uvuni_to_utf8(tmpbuf,nextmin);
2746 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2748 U8 range_mark = UTF_TO_NATIVE(0xff);
2749 t = uvuni_to_utf8(tmpbuf, val - 1);
2750 sv_catpvn(transv, (char *)&range_mark, 1);
2751 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2758 t = uvuni_to_utf8(tmpbuf,nextmin);
2759 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2761 U8 range_mark = UTF_TO_NATIVE(0xff);
2762 sv_catpvn(transv, (char *)&range_mark, 1);
2764 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2765 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2766 t = (U8*)SvPVX(transv);
2767 tlen = SvCUR(transv);
2771 else if (!rlen && !del) {
2772 r = t; rlen = tlen; rend = tend;
2775 if ((!rlen && !del) || t == r ||
2776 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2778 o->op_private |= OPpTRANS_IDENTICAL;
2782 while (t < tend || tfirst <= tlast) {
2783 /* see if we need more "t" chars */
2784 if (tfirst > tlast) {
2785 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2787 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2789 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2796 /* now see if we need more "r" chars */
2797 if (rfirst > rlast) {
2799 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2801 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2803 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2812 rfirst = rlast = 0xffffffff;
2816 /* now see which range will peter our first, if either. */
2817 tdiff = tlast - tfirst;
2818 rdiff = rlast - rfirst;
2825 if (rfirst == 0xffffffff) {
2826 diff = tdiff; /* oops, pretend rdiff is infinite */
2828 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2829 (long)tfirst, (long)tlast);
2831 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2835 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2836 (long)tfirst, (long)(tfirst + diff),
2839 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2840 (long)tfirst, (long)rfirst);
2842 if (rfirst + diff > max)
2843 max = rfirst + diff;
2845 grows = (tfirst < rfirst &&
2846 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2858 else if (max > 0xff)
2863 Safefree(cPVOPo->op_pv);
2864 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2865 SvREFCNT_dec(listsv);
2867 SvREFCNT_dec(transv);
2869 if (!del && havefinal && rlen)
2870 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2871 newSVuv((UV)final), 0);
2874 o->op_private |= OPpTRANS_GROWS;
2886 tbl = (short*)cPVOPo->op_pv;
2888 Zero(tbl, 256, short);
2889 for (i = 0; i < tlen; i++)
2891 for (i = 0, j = 0; i < 256; i++) {
2902 if (i < 128 && r[j] >= 128)
2912 o->op_private |= OPpTRANS_IDENTICAL;
2917 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2918 tbl[0x100] = rlen - j;
2919 for (i=0; i < rlen - j; i++)
2920 tbl[0x101+i] = r[j+i];
2924 if (!rlen && !del) {
2927 o->op_private |= OPpTRANS_IDENTICAL;
2929 for (i = 0; i < 256; i++)
2931 for (i = 0, j = 0; i < tlen; i++,j++) {
2934 if (tbl[t[i]] == -1)
2940 if (tbl[t[i]] == -1) {
2941 if (t[i] < 128 && r[j] >= 128)
2948 o->op_private |= OPpTRANS_GROWS;
2956 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2960 NewOp(1101, pmop, 1, PMOP);
2961 pmop->op_type = type;
2962 pmop->op_ppaddr = PL_ppaddr[type];
2963 pmop->op_flags = flags;
2964 pmop->op_private = 0 | (flags >> 8);
2966 if (PL_hints & HINT_RE_TAINT)
2967 pmop->op_pmpermflags |= PMf_RETAINT;
2968 if (PL_hints & HINT_LOCALE)
2969 pmop->op_pmpermflags |= PMf_LOCALE;
2970 pmop->op_pmflags = pmop->op_pmpermflags;
2972 /* link into pm list */
2973 if (type != OP_TRANS && PL_curstash) {
2974 pmop->op_pmnext = HvPMROOT(PL_curstash);
2975 HvPMROOT(PL_curstash) = pmop;
2976 PmopSTASH_set(pmop,PL_curstash);
2983 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2987 I32 repl_has_vars = 0;
2989 if (o->op_type == OP_TRANS)
2990 return pmtrans(o, expr, repl);
2992 PL_hints |= HINT_BLOCK_SCOPE;
2995 if (expr->op_type == OP_CONST) {
2997 SV *pat = ((SVOP*)expr)->op_sv;
2998 char *p = SvPV(pat, plen);
2999 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3000 sv_setpvn(pat, "\\s+", 3);
3001 p = SvPV(pat, plen);
3002 pm->op_pmflags |= PMf_SKIPWHITE;
3004 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
3005 pm->op_pmdynflags |= PMdf_UTF8;
3006 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
3007 if (strEQ("\\s+", pm->op_pmregexp->precomp))
3008 pm->op_pmflags |= PMf_WHITE;
3012 if (PL_hints & HINT_UTF8)
3013 pm->op_pmdynflags |= PMdf_UTF8;
3014 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3015 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3017 : OP_REGCMAYBE),0,expr);
3019 NewOp(1101, rcop, 1, LOGOP);
3020 rcop->op_type = OP_REGCOMP;
3021 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3022 rcop->op_first = scalar(expr);
3023 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3024 ? (OPf_SPECIAL | OPf_KIDS)
3026 rcop->op_private = 1;
3029 /* establish postfix order */
3030 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3032 rcop->op_next = expr;
3033 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3036 rcop->op_next = LINKLIST(expr);
3037 expr->op_next = (OP*)rcop;
3040 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3045 if (pm->op_pmflags & PMf_EVAL) {
3047 if (CopLINE(PL_curcop) < PL_multi_end)
3048 CopLINE_set(PL_curcop, PL_multi_end);
3051 else if (repl->op_type == OP_THREADSV
3052 && strchr("&`'123456789+",
3053 PL_threadsv_names[repl->op_targ]))
3057 #endif /* USE_THREADS */
3058 else if (repl->op_type == OP_CONST)
3062 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3063 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3065 if (curop->op_type == OP_THREADSV) {
3067 if (strchr("&`'123456789+", curop->op_private))
3071 if (curop->op_type == OP_GV) {
3072 GV *gv = cGVOPx_gv(curop);
3074 if (strchr("&`'123456789+", *GvENAME(gv)))
3077 #endif /* USE_THREADS */
3078 else if (curop->op_type == OP_RV2CV)
3080 else if (curop->op_type == OP_RV2SV ||
3081 curop->op_type == OP_RV2AV ||
3082 curop->op_type == OP_RV2HV ||
3083 curop->op_type == OP_RV2GV) {
3084 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3087 else if (curop->op_type == OP_PADSV ||
3088 curop->op_type == OP_PADAV ||
3089 curop->op_type == OP_PADHV ||
3090 curop->op_type == OP_PADANY) {
3093 else if (curop->op_type == OP_PUSHRE)
3094 ; /* Okay here, dangerous in newASSIGNOP */
3103 && (!pm->op_pmregexp
3104 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3105 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3106 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3107 prepend_elem(o->op_type, scalar(repl), o);
3110 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3111 pm->op_pmflags |= PMf_MAYBE_CONST;
3112 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3114 NewOp(1101, rcop, 1, LOGOP);
3115 rcop->op_type = OP_SUBSTCONT;
3116 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3117 rcop->op_first = scalar(repl);
3118 rcop->op_flags |= OPf_KIDS;
3119 rcop->op_private = 1;
3122 /* establish postfix order */
3123 rcop->op_next = LINKLIST(repl);
3124 repl->op_next = (OP*)rcop;
3126 pm->op_pmreplroot = scalar((OP*)rcop);
3127 pm->op_pmreplstart = LINKLIST(rcop);
3136 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3139 NewOp(1101, svop, 1, SVOP);
3140 svop->op_type = type;
3141 svop->op_ppaddr = PL_ppaddr[type];
3143 svop->op_next = (OP*)svop;
3144 svop->op_flags = flags;
3145 if (PL_opargs[type] & OA_RETSCALAR)
3147 if (PL_opargs[type] & OA_TARGET)
3148 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3149 return CHECKOP(type, svop);
3153 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3156 NewOp(1101, padop, 1, PADOP);
3157 padop->op_type = type;
3158 padop->op_ppaddr = PL_ppaddr[type];
3159 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3160 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3161 PL_curpad[padop->op_padix] = sv;
3163 padop->op_next = (OP*)padop;
3164 padop->op_flags = flags;
3165 if (PL_opargs[type] & OA_RETSCALAR)
3167 if (PL_opargs[type] & OA_TARGET)
3168 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3169 return CHECKOP(type, padop);
3173 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3177 return newPADOP(type, flags, SvREFCNT_inc(gv));
3179 return newSVOP(type, flags, SvREFCNT_inc(gv));
3184 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3187 NewOp(1101, pvop, 1, PVOP);
3188 pvop->op_type = type;
3189 pvop->op_ppaddr = PL_ppaddr[type];
3191 pvop->op_next = (OP*)pvop;
3192 pvop->op_flags = flags;
3193 if (PL_opargs[type] & OA_RETSCALAR)
3195 if (PL_opargs[type] & OA_TARGET)
3196 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3197 return CHECKOP(type, pvop);
3201 Perl_package(pTHX_ OP *o)
3205 save_hptr(&PL_curstash);
3206 save_item(PL_curstname);
3211 name = SvPV(sv, len);
3212 PL_curstash = gv_stashpvn(name,len,TRUE);
3213 sv_setpvn(PL_curstname, name, len);
3217 sv_setpv(PL_curstname,"<none>");
3218 PL_curstash = Nullhv;
3220 PL_hints |= HINT_BLOCK_SCOPE;
3221 PL_copline = NOLINE;
3226 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3234 if (id->op_type != OP_CONST)
3235 Perl_croak(aTHX_ "Module name must be constant");
3239 if (version != Nullop) {
3240 SV *vesv = ((SVOP*)version)->op_sv;
3242 if (arg == Nullop && !SvNIOKp(vesv)) {
3249 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3250 Perl_croak(aTHX_ "Version number must be constant number");
3252 /* Make copy of id so we don't free it twice */
3253 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3255 /* Fake up a method call to VERSION */
3256 meth = newSVpvn("VERSION",7);
3257 sv_upgrade(meth, SVt_PVIV);
3258 (void)SvIOK_on(meth);
3259 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3260 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3261 append_elem(OP_LIST,
3262 prepend_elem(OP_LIST, pack, list(version)),
3263 newSVOP(OP_METHOD_NAMED, 0, meth)));
3267 /* Fake up an import/unimport */
3268 if (arg && arg->op_type == OP_STUB)
3269 imop = arg; /* no import on explicit () */
3270 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3271 imop = Nullop; /* use 5.0; */
3276 /* Make copy of id so we don't free it twice */
3277 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3279 /* Fake up a method call to import/unimport */
3280 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3281 sv_upgrade(meth, SVt_PVIV);
3282 (void)SvIOK_on(meth);
3283 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3284 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3285 append_elem(OP_LIST,
3286 prepend_elem(OP_LIST, pack, list(arg)),
3287 newSVOP(OP_METHOD_NAMED, 0, meth)));
3290 /* Fake up a require, handle override, if any */
3291 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3292 if (!(gv && GvIMPORTED_CV(gv)))
3293 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3295 if (gv && GvIMPORTED_CV(gv)) {
3296 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3297 append_elem(OP_LIST, id,
3298 scalar(newUNOP(OP_RV2CV, 0,
3303 rqop = newUNOP(OP_REQUIRE, 0, id);
3306 /* Fake up the BEGIN {}, which does its thing immediately. */
3308 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3311 append_elem(OP_LINESEQ,
3312 append_elem(OP_LINESEQ,
3313 newSTATEOP(0, Nullch, rqop),
3314 newSTATEOP(0, Nullch, veop)),
3315 newSTATEOP(0, Nullch, imop) ));
3317 PL_hints |= HINT_BLOCK_SCOPE;
3318 PL_copline = NOLINE;
3323 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3326 va_start(args, ver);
3327 vload_module(flags, name, ver, &args);
3331 #ifdef PERL_IMPLICIT_CONTEXT
3333 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3337 va_start(args, ver);
3338 vload_module(flags, name, ver, &args);
3344 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3346 OP *modname, *veop, *imop;
3348 modname = newSVOP(OP_CONST, 0, name);
3349 modname->op_private |= OPpCONST_BARE;
3351 veop = newSVOP(OP_CONST, 0, ver);
3355 if (flags & PERL_LOADMOD_NOIMPORT) {
3356 imop = sawparens(newNULLLIST());
3358 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3359 imop = va_arg(*args, OP*);
3364 sv = va_arg(*args, SV*);
3366 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3367 sv = va_arg(*args, SV*);
3371 line_t ocopline = PL_copline;
3372 int oexpect = PL_expect;
3374 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3375 veop, modname, imop);
3376 PL_expect = oexpect;
3377 PL_copline = ocopline;
3382 Perl_dofile(pTHX_ OP *term)
3387 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3388 if (!(gv && GvIMPORTED_CV(gv)))
3389 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3391 if (gv && GvIMPORTED_CV(gv)) {
3392 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3393 append_elem(OP_LIST, term,
3394 scalar(newUNOP(OP_RV2CV, 0,
3399 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3405 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3407 return newBINOP(OP_LSLICE, flags,
3408 list(force_list(subscript)),
3409 list(force_list(listval)) );
3413 S_list_assignment(pTHX_ register OP *o)
3418 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3419 o = cUNOPo->op_first;
3421 if (o->op_type == OP_COND_EXPR) {
3422 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3423 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3428 yyerror("Assignment to both a list and a scalar");
3432 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3433 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3434 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3437 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3440 if (o->op_type == OP_RV2SV)
3447 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3452 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3453 return newLOGOP(optype, 0,
3454 mod(scalar(left), optype),
3455 newUNOP(OP_SASSIGN, 0, scalar(right)));
3458 return newBINOP(optype, OPf_STACKED,
3459 mod(scalar(left), optype), scalar(right));
3463 if (list_assignment(left)) {
3467 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3468 left = mod(left, OP_AASSIGN);
3476 curop = list(force_list(left));
3477 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3478 o->op_private = 0 | (flags >> 8);
3479 for (curop = ((LISTOP*)curop)->op_first;
3480 curop; curop = curop->op_sibling)
3482 if (curop->op_type == OP_RV2HV &&
3483 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3484 o->op_private |= OPpASSIGN_HASH;
3488 if (!(left->op_private & OPpLVAL_INTRO)) {
3491 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3492 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3493 if (curop->op_type == OP_GV) {
3494 GV *gv = cGVOPx_gv(curop);
3495 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3497 SvCUR(gv) = PL_generation;
3499 else if (curop->op_type == OP_PADSV ||
3500 curop->op_type == OP_PADAV ||
3501 curop->op_type == OP_PADHV ||
3502 curop->op_type == OP_PADANY) {
3503 SV **svp = AvARRAY(PL_comppad_name);
3504 SV *sv = svp[curop->op_targ];
3505 if (SvCUR(sv) == PL_generation)
3507 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3509 else if (curop->op_type == OP_RV2CV)
3511 else if (curop->op_type == OP_RV2SV ||
3512 curop->op_type == OP_RV2AV ||
3513 curop->op_type == OP_RV2HV ||
3514 curop->op_type == OP_RV2GV) {
3515 if (lastop->op_type != OP_GV) /* funny deref? */
3518 else if (curop->op_type == OP_PUSHRE) {
3519 if (((PMOP*)curop)->op_pmreplroot) {
3521 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3523 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3525 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3527 SvCUR(gv) = PL_generation;
3536 o->op_private |= OPpASSIGN_COMMON;
3538 if (right && right->op_type == OP_SPLIT) {
3540 if ((tmpop = ((LISTOP*)right)->op_first) &&
3541 tmpop->op_type == OP_PUSHRE)
3543 PMOP *pm = (PMOP*)tmpop;
3544 if (left->op_type == OP_RV2AV &&
3545 !(left->op_private & OPpLVAL_INTRO) &&
3546 !(o->op_private & OPpASSIGN_COMMON) )
3548 tmpop = ((UNOP*)left)->op_first;
3549 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3551 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3552 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3554 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3555 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3557 pm->op_pmflags |= PMf_ONCE;
3558 tmpop = cUNOPo->op_first; /* to list (nulled) */
3559 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3560 tmpop->op_sibling = Nullop; /* don't free split */
3561 right->op_next = tmpop->op_next; /* fix starting loc */
3562 op_free(o); /* blow off assign */
3563 right->op_flags &= ~OPf_WANT;
3564 /* "I don't know and I don't care." */
3569 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3570 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3572 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3574 sv_setiv(sv, PL_modcount+1);
3582 right = newOP(OP_UNDEF, 0);
3583 if (right->op_type == OP_READLINE) {
3584 right->op_flags |= OPf_STACKED;
3585 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3588 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3589 o = newBINOP(OP_SASSIGN, flags,
3590 scalar(right), mod(scalar(left), OP_SASSIGN) );
3602 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3604 U32 seq = intro_my();
3607 NewOp(1101, cop, 1, COP);
3608 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3609 cop->op_type = OP_DBSTATE;
3610 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3613 cop->op_type = OP_NEXTSTATE;
3614 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3616 cop->op_flags = flags;
3617 cop->op_private = (PL_hints & HINT_BYTE);
3619 cop->op_private |= NATIVE_HINTS;
3621 PL_compiling.op_private = cop->op_private;
3622 cop->op_next = (OP*)cop;
3625 cop->cop_label = label;
3626 PL_hints |= HINT_BLOCK_SCOPE;
3629 cop->cop_arybase = PL_curcop->cop_arybase;
3630 if (specialWARN(PL_curcop->cop_warnings))
3631 cop->cop_warnings = PL_curcop->cop_warnings ;
3633 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3634 if (specialCopIO(PL_curcop->cop_io))
3635 cop->cop_io = PL_curcop->cop_io;
3637 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3640 if (PL_copline == NOLINE)
3641 CopLINE_set(cop, CopLINE(PL_curcop));
3643 CopLINE_set(cop, PL_copline);
3644 PL_copline = NOLINE;
3647 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3649 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3651 CopSTASH_set(cop, PL_curstash);
3653 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3654 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3655 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3656 (void)SvIOK_on(*svp);
3657 SvIVX(*svp) = PTR2IV(cop);
3661 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3664 /* "Introduce" my variables to visible status. */
3672 if (! PL_min_intro_pending)
3673 return PL_cop_seqmax;
3675 svp = AvARRAY(PL_comppad_name);
3676 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3677 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3678 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3679 SvNVX(sv) = (NV)PL_cop_seqmax;
3682 PL_min_intro_pending = 0;
3683 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3684 return PL_cop_seqmax++;
3688 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3690 return new_logop(type, flags, &first, &other);
3694 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3698 OP *first = *firstp;
3699 OP *other = *otherp;
3701 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3702 return newBINOP(type, flags, scalar(first), scalar(other));
3704 scalarboolean(first);
3705 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3706 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3707 if (type == OP_AND || type == OP_OR) {
3713 first = *firstp = cUNOPo->op_first;
3715 first->op_next = o->op_next;
3716 cUNOPo->op_first = Nullop;
3720 if (first->op_type == OP_CONST) {
3721 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3722 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3723 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3734 else if (first->op_type == OP_WANTARRAY) {
3740 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3741 OP *k1 = ((UNOP*)first)->op_first;
3742 OP *k2 = k1->op_sibling;
3744 switch (first->op_type)
3747 if (k2 && k2->op_type == OP_READLINE
3748 && (k2->op_flags & OPf_STACKED)
3749 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3751 warnop = k2->op_type;
3756 if (k1->op_type == OP_READDIR
3757 || k1->op_type == OP_GLOB
3758 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3759 || k1->op_type == OP_EACH)
3761 warnop = ((k1->op_type == OP_NULL)
3762 ? k1->op_targ : k1->op_type);
3767 line_t oldline = CopLINE(PL_curcop);
3768 CopLINE_set(PL_curcop, PL_copline);
3769 Perl_warner(aTHX_ WARN_MISC,
3770 "Value of %s%s can be \"0\"; test with defined()",
3772 ((warnop == OP_READLINE || warnop == OP_GLOB)
3773 ? " construct" : "() operator"));
3774 CopLINE_set(PL_curcop, oldline);
3781 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3782 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3784 NewOp(1101, logop, 1, LOGOP);
3786 logop->op_type = type;
3787 logop->op_ppaddr = PL_ppaddr[type];
3788 logop->op_first = first;
3789 logop->op_flags = flags | OPf_KIDS;
3790 logop->op_other = LINKLIST(other);
3791 logop->op_private = 1 | (flags >> 8);
3793 /* establish postfix order */
3794 logop->op_next = LINKLIST(first);
3795 first->op_next = (OP*)logop;
3796 first->op_sibling = other;
3798 o = newUNOP(OP_NULL, 0, (OP*)logop);
3805 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3812 return newLOGOP(OP_AND, 0, first, trueop);
3814 return newLOGOP(OP_OR, 0, first, falseop);
3816 scalarboolean(first);
3817 if (first->op_type == OP_CONST) {
3818 if (SvTRUE(((SVOP*)first)->op_sv)) {
3829 else if (first->op_type == OP_WANTARRAY) {
3833 NewOp(1101, logop, 1, LOGOP);
3834 logop->op_type = OP_COND_EXPR;
3835 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3836 logop->op_first = first;
3837 logop->op_flags = flags | OPf_KIDS;
3838 logop->op_private = 1 | (flags >> 8);
3839 logop->op_other = LINKLIST(trueop);
3840 logop->op_next = LINKLIST(falseop);
3843 /* establish postfix order */
3844 start = LINKLIST(first);
3845 first->op_next = (OP*)logop;
3847 first->op_sibling = trueop;
3848 trueop->op_sibling = falseop;
3849 o = newUNOP(OP_NULL, 0, (OP*)logop);
3851 trueop->op_next = falseop->op_next = o;
3858 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3866 NewOp(1101, range, 1, LOGOP);
3868 range->op_type = OP_RANGE;
3869 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3870 range->op_first = left;
3871 range->op_flags = OPf_KIDS;
3872 leftstart = LINKLIST(left);
3873 range->op_other = LINKLIST(right);
3874 range->op_private = 1 | (flags >> 8);
3876 left->op_sibling = right;
3878 range->op_next = (OP*)range;
3879 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3880 flop = newUNOP(OP_FLOP, 0, flip);
3881 o = newUNOP(OP_NULL, 0, flop);
3883 range->op_next = leftstart;
3885 left->op_next = flip;
3886 right->op_next = flop;
3888 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3889 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3890 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3891 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3893 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3894 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3897 if (!flip->op_private || !flop->op_private)
3898 linklist(o); /* blow off optimizer unless constant */
3904 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3908 int once = block && block->op_flags & OPf_SPECIAL &&
3909 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3912 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3913 return block; /* do {} while 0 does once */
3914 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3915 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3916 expr = newUNOP(OP_DEFINED, 0,
3917 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3918 } else if (expr->op_flags & OPf_KIDS) {
3919 OP *k1 = ((UNOP*)expr)->op_first;
3920 OP *k2 = (k1) ? k1->op_sibling : NULL;
3921 switch (expr->op_type) {
3923 if (k2 && k2->op_type == OP_READLINE
3924 && (k2->op_flags & OPf_STACKED)
3925 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3926 expr = newUNOP(OP_DEFINED, 0, expr);
3930 if (k1->op_type == OP_READDIR
3931 || k1->op_type == OP_GLOB
3932 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3933 || k1->op_type == OP_EACH)
3934 expr = newUNOP(OP_DEFINED, 0, expr);
3940 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3941 o = new_logop(OP_AND, 0, &expr, &listop);
3944 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3946 if (once && o != listop)
3947 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3950 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3952 o->op_flags |= flags;
3954 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3959 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3968 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3969 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3970 expr = newUNOP(OP_DEFINED, 0,
3971 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3972 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3973 OP *k1 = ((UNOP*)expr)->op_first;
3974 OP *k2 = (k1) ? k1->op_sibling : NULL;
3975 switch (expr->op_type) {
3977 if (k2 && k2->op_type == OP_READLINE
3978 && (k2->op_flags & OPf_STACKED)
3979 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3980 expr = newUNOP(OP_DEFINED, 0, expr);
3984 if (k1->op_type == OP_READDIR
3985 || k1->op_type == OP_GLOB
3986 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3987 || k1->op_type == OP_EACH)
3988 expr = newUNOP(OP_DEFINED, 0, expr);
3994 block = newOP(OP_NULL, 0);
3996 block = scope(block);
4000 next = LINKLIST(cont);
4003 OP *unstack = newOP(OP_UNSTACK, 0);
4006 cont = append_elem(OP_LINESEQ, cont, unstack);
4007 if ((line_t)whileline != NOLINE) {
4008 PL_copline = whileline;
4009 cont = append_elem(OP_LINESEQ, cont,
4010 newSTATEOP(0, Nullch, Nullop));
4014 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4015 redo = LINKLIST(listop);
4018 PL_copline = whileline;
4020 o = new_logop(OP_AND, 0, &expr, &listop);
4021 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4022 op_free(expr); /* oops, it's a while (0) */
4024 return Nullop; /* listop already freed by new_logop */
4027 ((LISTOP*)listop)->op_last->op_next = condop =
4028 (o == listop ? redo : LINKLIST(o));
4034 NewOp(1101,loop,1,LOOP);
4035 loop->op_type = OP_ENTERLOOP;
4036 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4037 loop->op_private = 0;
4038 loop->op_next = (OP*)loop;
4041 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4043 loop->op_redoop = redo;
4044 loop->op_lastop = o;
4045 o->op_private |= loopflags;
4048 loop->op_nextop = next;
4050 loop->op_nextop = o;
4052 o->op_flags |= flags;
4053 o->op_private |= (flags >> 8);
4058 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4066 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4067 sv->op_type = OP_RV2GV;
4068 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4070 else if (sv->op_type == OP_PADSV) { /* private variable */
4071 padoff = sv->op_targ;
4076 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4077 padoff = sv->op_targ;
4079 iterflags |= OPf_SPECIAL;
4084 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4088 padoff = find_threadsv("_");
4089 iterflags |= OPf_SPECIAL;
4091 sv = newGVOP(OP_GV, 0, PL_defgv);
4094 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4095 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4096 iterflags |= OPf_STACKED;
4098 else if (expr->op_type == OP_NULL &&
4099 (expr->op_flags & OPf_KIDS) &&
4100 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4102 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4103 * set the STACKED flag to indicate that these values are to be
4104 * treated as min/max values by 'pp_iterinit'.
4106 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4107 LOGOP* range = (LOGOP*) flip->op_first;
4108 OP* left = range->op_first;
4109 OP* right = left->op_sibling;
4112 range->op_flags &= ~OPf_KIDS;
4113 range->op_first = Nullop;
4115 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4116 listop->op_first->op_next = range->op_next;
4117 left->op_next = range->op_other;
4118 right->op_next = (OP*)listop;
4119 listop->op_next = listop->op_first;
4122 expr = (OP*)(listop);
4124 iterflags |= OPf_STACKED;
4127 expr = mod(force_list(expr), OP_GREPSTART);
4131 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4132 append_elem(OP_LIST, expr, scalar(sv))));
4133 assert(!loop->op_next);
4134 #ifdef PL_OP_SLAB_ALLOC
4137 NewOp(1234,tmp,1,LOOP);
4138 Copy(loop,tmp,1,LOOP);
4142 Renew(loop, 1, LOOP);
4144 loop->op_targ = padoff;
4145 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4146 PL_copline = forline;
4147 return newSTATEOP(0, label, wop);
4151 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4156 if (type != OP_GOTO || label->op_type == OP_CONST) {
4157 /* "last()" means "last" */
4158 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4159 o = newOP(type, OPf_SPECIAL);
4161 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4162 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4168 if (label->op_type == OP_ENTERSUB)
4169 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4170 o = newUNOP(type, OPf_STACKED, label);
4172 PL_hints |= HINT_BLOCK_SCOPE;
4177 Perl_cv_undef(pTHX_ CV *cv)
4181 MUTEX_DESTROY(CvMUTEXP(cv));
4182 Safefree(CvMUTEXP(cv));
4185 #endif /* USE_THREADS */
4187 if (!CvXSUB(cv) && CvROOT(cv)) {
4189 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4190 Perl_croak(aTHX_ "Can't undef active subroutine");
4193 Perl_croak(aTHX_ "Can't undef active subroutine");
4194 #endif /* USE_THREADS */
4197 SAVEVPTR(PL_curpad);
4200 op_free(CvROOT(cv));
4201 CvROOT(cv) = Nullop;
4204 SvPOK_off((SV*)cv); /* forget prototype */
4206 /* Since closure prototypes have the same lifetime as the containing
4207 * CV, they don't hold a refcount on the outside CV. This avoids
4208 * the refcount loop between the outer CV (which keeps a refcount to
4209 * the closure prototype in the pad entry for pp_anoncode()) and the
4210 * closure prototype, and the ensuing memory leak. --GSAR */
4211 if (!CvANON(cv) || CvCLONED(cv))
4212 SvREFCNT_dec(CvOUTSIDE(cv));
4213 CvOUTSIDE(cv) = Nullcv;
4215 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4218 if (CvPADLIST(cv)) {
4219 /* may be during global destruction */
4220 if (SvREFCNT(CvPADLIST(cv))) {
4221 I32 i = AvFILLp(CvPADLIST(cv));
4223 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4224 SV* sv = svp ? *svp : Nullsv;
4227 if (sv == (SV*)PL_comppad_name)
4228 PL_comppad_name = Nullav;
4229 else if (sv == (SV*)PL_comppad) {
4230 PL_comppad = Nullav;
4231 PL_curpad = Null(SV**);
4235 SvREFCNT_dec((SV*)CvPADLIST(cv));
4237 CvPADLIST(cv) = Nullav;
4242 #ifdef DEBUG_CLOSURES
4244 S_cv_dump(pTHX_ CV *cv)
4247 CV *outside = CvOUTSIDE(cv);
4248 AV* padlist = CvPADLIST(cv);
4255 PerlIO_printf(Perl_debug_log,
4256 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4258 (CvANON(cv) ? "ANON"
4259 : (cv == PL_main_cv) ? "MAIN"
4260 : CvUNIQUE(cv) ? "UNIQUE"
4261 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4264 : CvANON(outside) ? "ANON"
4265 : (outside == PL_main_cv) ? "MAIN"
4266 : CvUNIQUE(outside) ? "UNIQUE"
4267 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4272 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4273 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4274 pname = AvARRAY(pad_name);
4275 ppad = AvARRAY(pad);
4277 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4278 if (SvPOK(pname[ix]))
4279 PerlIO_printf(Perl_debug_log,
4280 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4281 (int)ix, PTR2UV(ppad[ix]),
4282 SvFAKE(pname[ix]) ? "FAKE " : "",
4284 (IV)I_32(SvNVX(pname[ix])),
4287 #endif /* DEBUGGING */
4289 #endif /* DEBUG_CLOSURES */
4292 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4296 AV* protopadlist = CvPADLIST(proto);
4297 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4298 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4299 SV** pname = AvARRAY(protopad_name);
4300 SV** ppad = AvARRAY(protopad);
4301 I32 fname = AvFILLp(protopad_name);
4302 I32 fpad = AvFILLp(protopad);
4306 assert(!CvUNIQUE(proto));
4310 SAVESPTR(PL_comppad_name);
4311 SAVESPTR(PL_compcv);
4313 cv = PL_compcv = (CV*)NEWSV(1104,0);
4314 sv_upgrade((SV *)cv, SvTYPE(proto));
4315 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4319 New(666, CvMUTEXP(cv), 1, perl_mutex);
4320 MUTEX_INIT(CvMUTEXP(cv));
4322 #endif /* USE_THREADS */
4323 CvFILE(cv) = CvFILE(proto);
4324 CvGV(cv) = CvGV(proto);
4325 CvSTASH(cv) = CvSTASH(proto);
4326 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4327 CvSTART(cv) = CvSTART(proto);
4329 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4332 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4334 PL_comppad_name = newAV();
4335 for (ix = fname; ix >= 0; ix--)
4336 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4338 PL_comppad = newAV();
4340 comppadlist = newAV();
4341 AvREAL_off(comppadlist);
4342 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4343 av_store(comppadlist, 1, (SV*)PL_comppad);
4344 CvPADLIST(cv) = comppadlist;
4345 av_fill(PL_comppad, AvFILLp(protopad));
4346 PL_curpad = AvARRAY(PL_comppad);
4348 av = newAV(); /* will be @_ */
4350 av_store(PL_comppad, 0, (SV*)av);
4351 AvFLAGS(av) = AVf_REIFY;
4353 for (ix = fpad; ix > 0; ix--) {
4354 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4355 if (namesv && namesv != &PL_sv_undef) {
4356 char *name = SvPVX(namesv); /* XXX */
4357 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4358 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4359 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4361 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4363 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4365 else { /* our own lexical */
4368 /* anon code -- we'll come back for it */
4369 sv = SvREFCNT_inc(ppad[ix]);
4371 else if (*name == '@')
4373 else if (*name == '%')
4382 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4383 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4386 SV* sv = NEWSV(0,0);
4392 /* Now that vars are all in place, clone nested closures. */
4394 for (ix = fpad; ix > 0; ix--) {
4395 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4397 && namesv != &PL_sv_undef
4398 && !(SvFLAGS(namesv) & SVf_FAKE)
4399 && *SvPVX(namesv) == '&'
4400 && CvCLONE(ppad[ix]))
4402 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4403 SvREFCNT_dec(ppad[ix]);
4406 PL_curpad[ix] = (SV*)kid;
4410 #ifdef DEBUG_CLOSURES
4411 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4413 PerlIO_printf(Perl_debug_log, " from:\n");
4415 PerlIO_printf(Perl_debug_log, " to:\n");
4422 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4424 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4426 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4433 Perl_cv_clone(pTHX_ CV *proto)
4436 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4437 cv = cv_clone2(proto, CvOUTSIDE(proto));
4438 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4443 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4445 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4446 SV* msg = sv_newmortal();
4450 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4451 sv_setpv(msg, "Prototype mismatch:");
4453 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4455 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4456 sv_catpv(msg, " vs ");
4458 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4460 sv_catpv(msg, "none");
4461 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4465 static void const_sv_xsub(pTHXo_ CV* cv);
4468 =for apidoc cv_const_sv
4470 If C<cv> is a constant sub eligible for inlining. returns the constant
4471 value returned by the sub. Otherwise, returns NULL.
4473 Constant subs can be created with C<newCONSTSUB> or as described in
4474 L<perlsub/"Constant Functions">.
4479 Perl_cv_const_sv(pTHX_ CV *cv)
4481 if (!cv || !CvCONST(cv))
4483 return (SV*)CvXSUBANY(cv).any_ptr;
4487 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4494 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4495 o = cLISTOPo->op_first->op_sibling;
4497 for (; o; o = o->op_next) {
4498 OPCODE type = o->op_type;
4500 if (sv && o->op_next == o)
4502 if (o->op_next != o) {
4503 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4505 if (type == OP_DBSTATE)
4508 if (type == OP_LEAVESUB || type == OP_RETURN)
4512 if (type == OP_CONST && cSVOPo->op_sv)
4514 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4515 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4516 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4520 /* We get here only from cv_clone2() while creating a closure.
4521 Copy the const value here instead of in cv_clone2 so that
4522 SvREADONLY_on doesn't lead to problems when leaving
4527 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4539 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4549 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4553 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4555 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4559 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4565 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4570 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4571 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4572 SV *sv = sv_newmortal();
4573 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4574 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4579 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4580 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4590 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4591 maximum a prototype before. */
4592 if (SvTYPE(gv) > SVt_NULL) {
4593 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4594 && ckWARN_d(WARN_PROTOTYPE))
4596 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4598 cv_ckproto((CV*)gv, NULL, ps);
4601 sv_setpv((SV*)gv, ps);
4603 sv_setiv((SV*)gv, -1);
4604 SvREFCNT_dec(PL_compcv);
4605 cv = PL_compcv = NULL;
4606 PL_sub_generation++;
4610 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4612 #ifdef GV_SHARED_CHECK
4613 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4614 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4618 if (!block || !ps || *ps || attrs)
4621 const_sv = op_const_sv(block, Nullcv);
4624 bool exists = CvROOT(cv) || CvXSUB(cv);
4626 #ifdef GV_SHARED_CHECK
4627 if (exists && GvSHARED(gv)) {
4628 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4632 /* if the subroutine doesn't exist and wasn't pre-declared
4633 * with a prototype, assume it will be AUTOLOADed,
4634 * skipping the prototype check
4636 if (exists || SvPOK(cv))
4637 cv_ckproto(cv, gv, ps);
4638 /* already defined (or promised)? */
4639 if (exists || GvASSUMECV(gv)) {
4640 if (!block && !attrs) {
4641 /* just a "sub foo;" when &foo is already defined */
4642 SAVEFREESV(PL_compcv);
4645 /* ahem, death to those who redefine active sort subs */
4646 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4647 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4649 if (ckWARN(WARN_REDEFINE)
4651 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4653 line_t oldline = CopLINE(PL_curcop);
4654 CopLINE_set(PL_curcop, PL_copline);
4655 Perl_warner(aTHX_ WARN_REDEFINE,
4656 CvCONST(cv) ? "Constant subroutine %s redefined"
4657 : "Subroutine %s redefined", name);
4658 CopLINE_set(PL_curcop, oldline);
4666 SvREFCNT_inc(const_sv);
4668 assert(!CvROOT(cv) && !CvCONST(cv));
4669 sv_setpv((SV*)cv, ""); /* prototype is "" */
4670 CvXSUBANY(cv).any_ptr = const_sv;
4671 CvXSUB(cv) = const_sv_xsub;
4676 cv = newCONSTSUB(NULL, name, const_sv);
4679 SvREFCNT_dec(PL_compcv);
4681 PL_sub_generation++;
4688 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4689 * before we clobber PL_compcv.
4693 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4694 stash = GvSTASH(CvGV(cv));
4695 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4696 stash = CvSTASH(cv);
4698 stash = PL_curstash;
4701 /* possibly about to re-define existing subr -- ignore old cv */
4702 rcv = (SV*)PL_compcv;
4703 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4704 stash = GvSTASH(gv);
4706 stash = PL_curstash;
4708 apply_attrs(stash, rcv, attrs);
4710 if (cv) { /* must reuse cv if autoloaded */
4712 /* got here with just attrs -- work done, so bug out */
4713 SAVEFREESV(PL_compcv);
4717 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4718 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4719 CvOUTSIDE(PL_compcv) = 0;
4720 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4721 CvPADLIST(PL_compcv) = 0;
4722 /* inner references to PL_compcv must be fixed up ... */
4724 AV *padlist = CvPADLIST(cv);
4725 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4726 AV *comppad = (AV*)AvARRAY(padlist)[1];
4727 SV **namepad = AvARRAY(comppad_name);
4728 SV **curpad = AvARRAY(comppad);
4729 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4730 SV *namesv = namepad[ix];
4731 if (namesv && namesv != &PL_sv_undef
4732 && *SvPVX(namesv) == '&')
4734 CV *innercv = (CV*)curpad[ix];
4735 if (CvOUTSIDE(innercv) == PL_compcv) {
4736 CvOUTSIDE(innercv) = cv;
4737 if (!CvANON(innercv) || CvCLONED(innercv)) {
4738 (void)SvREFCNT_inc(cv);
4739 SvREFCNT_dec(PL_compcv);
4745 /* ... before we throw it away */
4746 SvREFCNT_dec(PL_compcv);
4753 PL_sub_generation++;
4757 CvFILE(cv) = CopFILE(PL_curcop);
4758 CvSTASH(cv) = PL_curstash;
4761 if (!CvMUTEXP(cv)) {
4762 New(666, CvMUTEXP(cv), 1, perl_mutex);
4763 MUTEX_INIT(CvMUTEXP(cv));
4765 #endif /* USE_THREADS */
4768 sv_setpv((SV*)cv, ps);
4770 if (PL_error_count) {
4774 char *s = strrchr(name, ':');
4776 if (strEQ(s, "BEGIN")) {
4778 "BEGIN not safe after errors--compilation aborted";
4779 if (PL_in_eval & EVAL_KEEPERR)
4780 Perl_croak(aTHX_ not_safe);
4782 /* force display of errors found but not reported */
4783 sv_catpv(ERRSV, not_safe);
4784 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4792 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4793 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4796 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4797 mod(scalarseq(block), OP_LEAVESUBLV));
4800 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4802 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4803 OpREFCNT_set(CvROOT(cv), 1);
4804 CvSTART(cv) = LINKLIST(CvROOT(cv));
4805 CvROOT(cv)->op_next = 0;
4808 /* now that optimizer has done its work, adjust pad values */
4810 SV **namep = AvARRAY(PL_comppad_name);
4811 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4814 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4817 * The only things that a clonable function needs in its
4818 * pad are references to outer lexicals and anonymous subs.
4819 * The rest are created anew during cloning.
4821 if (!((namesv = namep[ix]) != Nullsv &&
4822 namesv != &PL_sv_undef &&
4824 *SvPVX(namesv) == '&')))
4826 SvREFCNT_dec(PL_curpad[ix]);
4827 PL_curpad[ix] = Nullsv;
4830 assert(!CvCONST(cv));
4831 if (ps && !*ps && op_const_sv(block, cv))
4835 AV *av = newAV(); /* Will be @_ */
4837 av_store(PL_comppad, 0, (SV*)av);
4838 AvFLAGS(av) = AVf_REIFY;
4840 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4841 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4843 if (!SvPADMY(PL_curpad[ix]))
4844 SvPADTMP_on(PL_curpad[ix]);
4848 /* If a potential closure prototype, don't keep a refcount on outer CV.
4849 * This is okay as the lifetime of the prototype is tied to the
4850 * lifetime of the outer CV. Avoids memory leak due to reference
4853 SvREFCNT_dec(CvOUTSIDE(cv));
4855 if (name || aname) {
4857 char *tname = (name ? name : aname);
4859 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4860 SV *sv = NEWSV(0,0);
4861 SV *tmpstr = sv_newmortal();
4862 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4866 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4868 (long)PL_subline, (long)CopLINE(PL_curcop));
4869 gv_efullname3(tmpstr, gv, Nullch);
4870 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4871 hv = GvHVn(db_postponed);
4872 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4873 && (pcv = GvCV(db_postponed)))
4879 call_sv((SV*)pcv, G_DISCARD);
4883 if ((s = strrchr(tname,':')))
4888 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4891 if (strEQ(s, "BEGIN")) {
4892 I32 oldscope = PL_scopestack_ix;
4894 SAVECOPFILE(&PL_compiling);
4895 SAVECOPLINE(&PL_compiling);
4897 sv_setsv(PL_rs, PL_nrs);
4900 PL_beginav = newAV();
4901 DEBUG_x( dump_sub(gv) );
4902 av_push(PL_beginav, (SV*)cv);
4903 GvCV(gv) = 0; /* cv has been hijacked */
4904 call_list(oldscope, PL_beginav);
4906 PL_curcop = &PL_compiling;
4907 PL_compiling.op_private = PL_hints;
4910 else if (strEQ(s, "END") && !PL_error_count) {
4913 DEBUG_x( dump_sub(gv) );
4914 av_unshift(PL_endav, 1);
4915 av_store(PL_endav, 0, (SV*)cv);
4916 GvCV(gv) = 0; /* cv has been hijacked */
4918 else if (strEQ(s, "CHECK") && !PL_error_count) {
4920 PL_checkav = 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 CHECK block");
4924 av_unshift(PL_checkav, 1);
4925 av_store(PL_checkav, 0, (SV*)cv);
4926 GvCV(gv) = 0; /* cv has been hijacked */
4928 else if (strEQ(s, "INIT") && !PL_error_count) {
4930 PL_initav = newAV();
4931 DEBUG_x( dump_sub(gv) );
4932 if (PL_main_start && ckWARN(WARN_VOID))
4933 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4934 av_push(PL_initav, (SV*)cv);
4935 GvCV(gv) = 0; /* cv has been hijacked */
4940 PL_copline = NOLINE;
4945 /* XXX unsafe for threads if eval_owner isn't held */
4947 =for apidoc newCONSTSUB
4949 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4950 eligible for inlining at compile-time.
4956 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4962 SAVECOPLINE(PL_curcop);
4963 CopLINE_set(PL_curcop, PL_copline);
4966 PL_hints &= ~HINT_BLOCK_SCOPE;
4969 SAVESPTR(PL_curstash);
4970 SAVECOPSTASH(PL_curcop);
4971 PL_curstash = stash;
4973 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4975 CopSTASH(PL_curcop) = stash;
4979 cv = newXS(name, const_sv_xsub, __FILE__);
4980 CvXSUBANY(cv).any_ptr = sv;
4982 sv_setpv((SV*)cv, ""); /* prototype is "" */
4990 =for apidoc U||newXS
4992 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4998 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5000 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5003 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5005 /* just a cached method */
5009 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5010 /* already defined (or promised) */
5011 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5012 && HvNAME(GvSTASH(CvGV(cv)))
5013 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5014 line_t oldline = CopLINE(PL_curcop);
5015 if (PL_copline != NOLINE)
5016 CopLINE_set(PL_curcop, PL_copline);
5017 Perl_warner(aTHX_ WARN_REDEFINE,
5018 CvCONST(cv) ? "Constant subroutine %s redefined"
5019 : "Subroutine %s redefined"
5021 CopLINE_set(PL_curcop, oldline);
5028 if (cv) /* must reuse cv if autoloaded */
5031 cv = (CV*)NEWSV(1105,0);
5032 sv_upgrade((SV *)cv, SVt_PVCV);
5036 PL_sub_generation++;
5041 New(666, CvMUTEXP(cv), 1, perl_mutex);
5042 MUTEX_INIT(CvMUTEXP(cv));
5044 #endif /* USE_THREADS */
5045 (void)gv_fetchfile(filename);
5046 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5047 an external constant string */
5048 CvXSUB(cv) = subaddr;
5051 char *s = strrchr(name,':');
5057 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5060 if (strEQ(s, "BEGIN")) {
5062 PL_beginav = newAV();
5063 av_push(PL_beginav, (SV*)cv);
5064 GvCV(gv) = 0; /* cv has been hijacked */
5066 else if (strEQ(s, "END")) {
5069 av_unshift(PL_endav, 1);
5070 av_store(PL_endav, 0, (SV*)cv);
5071 GvCV(gv) = 0; /* cv has been hijacked */
5073 else if (strEQ(s, "CHECK")) {
5075 PL_checkav = newAV();
5076 if (PL_main_start && ckWARN(WARN_VOID))
5077 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5078 av_unshift(PL_checkav, 1);
5079 av_store(PL_checkav, 0, (SV*)cv);
5080 GvCV(gv) = 0; /* cv has been hijacked */
5082 else if (strEQ(s, "INIT")) {
5084 PL_initav = newAV();
5085 if (PL_main_start && ckWARN(WARN_VOID))
5086 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5087 av_push(PL_initav, (SV*)cv);
5088 GvCV(gv) = 0; /* cv has been hijacked */
5099 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5108 name = SvPVx(cSVOPo->op_sv, n_a);
5111 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5112 #ifdef GV_SHARED_CHECK
5114 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5118 if ((cv = GvFORM(gv))) {
5119 if (ckWARN(WARN_REDEFINE)) {
5120 line_t oldline = CopLINE(PL_curcop);
5122 CopLINE_set(PL_curcop, PL_copline);
5123 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5124 CopLINE_set(PL_curcop, oldline);
5131 CvFILE(cv) = CopFILE(PL_curcop);
5133 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5134 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5135 SvPADTMP_on(PL_curpad[ix]);
5138 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5139 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5140 OpREFCNT_set(CvROOT(cv), 1);
5141 CvSTART(cv) = LINKLIST(CvROOT(cv));
5142 CvROOT(cv)->op_next = 0;
5145 PL_copline = NOLINE;
5150 Perl_newANONLIST(pTHX_ OP *o)
5152 return newUNOP(OP_REFGEN, 0,
5153 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5157 Perl_newANONHASH(pTHX_ OP *o)
5159 return newUNOP(OP_REFGEN, 0,
5160 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5164 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5166 return newANONATTRSUB(floor, proto, Nullop, block);
5170 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5172 return newUNOP(OP_REFGEN, 0,
5173 newSVOP(OP_ANONCODE, 0,
5174 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5178 Perl_oopsAV(pTHX_ OP *o)
5180 switch (o->op_type) {
5182 o->op_type = OP_PADAV;
5183 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5184 return ref(o, OP_RV2AV);
5187 o->op_type = OP_RV2AV;
5188 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5193 if (ckWARN_d(WARN_INTERNAL))
5194 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5201 Perl_oopsHV(pTHX_ OP *o)
5203 switch (o->op_type) {
5206 o->op_type = OP_PADHV;
5207 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5208 return ref(o, OP_RV2HV);
5212 o->op_type = OP_RV2HV;
5213 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5218 if (ckWARN_d(WARN_INTERNAL))
5219 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5226 Perl_newAVREF(pTHX_ OP *o)
5228 if (o->op_type == OP_PADANY) {
5229 o->op_type = OP_PADAV;
5230 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5233 return newUNOP(OP_RV2AV, 0, scalar(o));
5237 Perl_newGVREF(pTHX_ I32 type, OP *o)
5239 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5240 return newUNOP(OP_NULL, 0, o);
5241 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5245 Perl_newHVREF(pTHX_ OP *o)
5247 if (o->op_type == OP_PADANY) {
5248 o->op_type = OP_PADHV;
5249 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5252 return newUNOP(OP_RV2HV, 0, scalar(o));
5256 Perl_oopsCV(pTHX_ OP *o)
5258 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5264 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5266 return newUNOP(OP_RV2CV, flags, scalar(o));
5270 Perl_newSVREF(pTHX_ OP *o)
5272 if (o->op_type == OP_PADANY) {
5273 o->op_type = OP_PADSV;
5274 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5277 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5278 o->op_flags |= OPpDONE_SVREF;
5281 return newUNOP(OP_RV2SV, 0, scalar(o));
5284 /* Check routines. */
5287 Perl_ck_anoncode(pTHX_ OP *o)
5292 name = NEWSV(1106,0);
5293 sv_upgrade(name, SVt_PVNV);
5294 sv_setpvn(name, "&", 1);
5297 ix = pad_alloc(o->op_type, SVs_PADMY);
5298 av_store(PL_comppad_name, ix, name);
5299 av_store(PL_comppad, ix, cSVOPo->op_sv);
5300 SvPADMY_on(cSVOPo->op_sv);
5301 cSVOPo->op_sv = Nullsv;
5302 cSVOPo->op_targ = ix;
5307 Perl_ck_bitop(pTHX_ OP *o)
5309 o->op_private = PL_hints;
5314 Perl_ck_concat(pTHX_ OP *o)
5316 if (cUNOPo->op_first->op_type == OP_CONCAT)
5317 o->op_flags |= OPf_STACKED;
5322 Perl_ck_spair(pTHX_ OP *o)
5324 if (o->op_flags & OPf_KIDS) {
5327 OPCODE type = o->op_type;
5328 o = modkids(ck_fun(o), type);
5329 kid = cUNOPo->op_first;
5330 newop = kUNOP->op_first->op_sibling;
5332 (newop->op_sibling ||
5333 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5334 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5335 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5339 op_free(kUNOP->op_first);
5340 kUNOP->op_first = newop;
5342 o->op_ppaddr = PL_ppaddr[++o->op_type];
5347 Perl_ck_delete(pTHX_ OP *o)
5351 if (o->op_flags & OPf_KIDS) {
5352 OP *kid = cUNOPo->op_first;
5353 switch (kid->op_type) {
5355 o->op_flags |= OPf_SPECIAL;
5358 o->op_private |= OPpSLICE;
5361 o->op_flags |= OPf_SPECIAL;
5366 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5367 PL_op_desc[o->op_type]);
5375 Perl_ck_eof(pTHX_ OP *o)
5377 I32 type = o->op_type;
5379 if (o->op_flags & OPf_KIDS) {
5380 if (cLISTOPo->op_first->op_type == OP_STUB) {
5382 o = newUNOP(type, OPf_SPECIAL,
5383 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5391 Perl_ck_eval(pTHX_ OP *o)
5393 PL_hints |= HINT_BLOCK_SCOPE;
5394 if (o->op_flags & OPf_KIDS) {
5395 SVOP *kid = (SVOP*)cUNOPo->op_first;
5398 o->op_flags &= ~OPf_KIDS;
5401 else if (kid->op_type == OP_LINESEQ) {
5404 kid->op_next = o->op_next;
5405 cUNOPo->op_first = 0;
5408 NewOp(1101, enter, 1, LOGOP);
5409 enter->op_type = OP_ENTERTRY;
5410 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5411 enter->op_private = 0;
5413 /* establish postfix order */
5414 enter->op_next = (OP*)enter;
5416 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5417 o->op_type = OP_LEAVETRY;
5418 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5419 enter->op_other = o;
5427 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5429 o->op_targ = (PADOFFSET)PL_hints;
5434 Perl_ck_exit(pTHX_ OP *o)
5437 HV *table = GvHV(PL_hintgv);
5439 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5440 if (svp && *svp && SvTRUE(*svp))
5441 o->op_private |= OPpEXIT_VMSISH;
5448 Perl_ck_exec(pTHX_ OP *o)
5451 if (o->op_flags & OPf_STACKED) {
5453 kid = cUNOPo->op_first->op_sibling;
5454 if (kid->op_type == OP_RV2GV)
5463 Perl_ck_exists(pTHX_ OP *o)
5466 if (o->op_flags & OPf_KIDS) {
5467 OP *kid = cUNOPo->op_first;
5468 if (kid->op_type == OP_ENTERSUB) {
5469 (void) ref(kid, o->op_type);
5470 if (kid->op_type != OP_RV2CV && !PL_error_count)
5471 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5472 PL_op_desc[o->op_type]);
5473 o->op_private |= OPpEXISTS_SUB;
5475 else if (kid->op_type == OP_AELEM)
5476 o->op_flags |= OPf_SPECIAL;
5477 else if (kid->op_type != OP_HELEM)
5478 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5479 PL_op_desc[o->op_type]);
5487 Perl_ck_gvconst(pTHX_ register OP *o)
5489 o = fold_constants(o);
5490 if (o->op_type == OP_CONST)
5497 Perl_ck_rvconst(pTHX_ register OP *o)
5499 SVOP *kid = (SVOP*)cUNOPo->op_first;
5501 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5502 if (kid->op_type == OP_CONST) {
5506 SV *kidsv = kid->op_sv;
5509 /* Is it a constant from cv_const_sv()? */
5510 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5511 SV *rsv = SvRV(kidsv);
5512 int svtype = SvTYPE(rsv);
5513 char *badtype = Nullch;
5515 switch (o->op_type) {
5517 if (svtype > SVt_PVMG)
5518 badtype = "a SCALAR";
5521 if (svtype != SVt_PVAV)
5522 badtype = "an ARRAY";
5525 if (svtype != SVt_PVHV) {
5526 if (svtype == SVt_PVAV) { /* pseudohash? */
5527 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5528 if (ksv && SvROK(*ksv)
5529 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5538 if (svtype != SVt_PVCV)
5543 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5546 name = SvPV(kidsv, n_a);
5547 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5548 char *badthing = Nullch;
5549 switch (o->op_type) {
5551 badthing = "a SCALAR";
5554 badthing = "an ARRAY";
5557 badthing = "a HASH";
5562 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5566 * This is a little tricky. We only want to add the symbol if we
5567 * didn't add it in the lexer. Otherwise we get duplicate strict
5568 * warnings. But if we didn't add it in the lexer, we must at
5569 * least pretend like we wanted to add it even if it existed before,
5570 * or we get possible typo warnings. OPpCONST_ENTERED says
5571 * whether the lexer already added THIS instance of this symbol.
5573 iscv = (o->op_type == OP_RV2CV) * 2;
5575 gv = gv_fetchpv(name,
5576 iscv | !(kid->op_private & OPpCONST_ENTERED),
5579 : o->op_type == OP_RV2SV
5581 : o->op_type == OP_RV2AV
5583 : o->op_type == OP_RV2HV
5586 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5588 kid->op_type = OP_GV;
5589 SvREFCNT_dec(kid->op_sv);
5591 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5592 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5593 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5595 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5597 kid->op_sv = SvREFCNT_inc(gv);
5599 kid->op_private = 0;
5600 kid->op_ppaddr = PL_ppaddr[OP_GV];
5607 Perl_ck_ftst(pTHX_ OP *o)
5609 I32 type = o->op_type;
5611 if (o->op_flags & OPf_REF) {
5614 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5615 SVOP *kid = (SVOP*)cUNOPo->op_first;
5617 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5619 OP *newop = newGVOP(type, OPf_REF,
5620 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5627 if (type == OP_FTTTY)
5628 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5631 o = newUNOP(type, 0, newDEFSVOP());
5634 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5636 if (PL_hints & HINT_LOCALE)
5637 o->op_private |= OPpLOCALE;
5644 Perl_ck_fun(pTHX_ OP *o)
5650 int type = o->op_type;
5651 register I32 oa = PL_opargs[type] >> OASHIFT;
5653 if (o->op_flags & OPf_STACKED) {
5654 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5657 return no_fh_allowed(o);
5660 if (o->op_flags & OPf_KIDS) {
5662 tokid = &cLISTOPo->op_first;
5663 kid = cLISTOPo->op_first;
5664 if (kid->op_type == OP_PUSHMARK ||
5665 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5667 tokid = &kid->op_sibling;
5668 kid = kid->op_sibling;
5670 if (!kid && PL_opargs[type] & OA_DEFGV)
5671 *tokid = kid = newDEFSVOP();
5675 sibl = kid->op_sibling;
5678 /* list seen where single (scalar) arg expected? */
5679 if (numargs == 1 && !(oa >> 4)
5680 && kid->op_type == OP_LIST && type != OP_SCALAR)
5682 return too_many_arguments(o,PL_op_desc[type]);
5695 if (kid->op_type == OP_CONST &&
5696 (kid->op_private & OPpCONST_BARE))
5698 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5699 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5700 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5701 if (ckWARN(WARN_DEPRECATED))
5702 Perl_warner(aTHX_ WARN_DEPRECATED,
5703 "Array @%s missing the @ in argument %"IVdf" of %s()",
5704 name, (IV)numargs, PL_op_desc[type]);
5707 kid->op_sibling = sibl;
5710 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5711 bad_type(numargs, "array", PL_op_desc[type], kid);
5715 if (kid->op_type == OP_CONST &&
5716 (kid->op_private & OPpCONST_BARE))
5718 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5719 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5720 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5721 if (ckWARN(WARN_DEPRECATED))
5722 Perl_warner(aTHX_ WARN_DEPRECATED,
5723 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5724 name, (IV)numargs, PL_op_desc[type]);
5727 kid->op_sibling = sibl;
5730 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5731 bad_type(numargs, "hash", PL_op_desc[type], kid);
5736 OP *newop = newUNOP(OP_NULL, 0, kid);
5737 kid->op_sibling = 0;
5739 newop->op_next = newop;
5741 kid->op_sibling = sibl;
5746 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5747 if (kid->op_type == OP_CONST &&
5748 (kid->op_private & OPpCONST_BARE))
5750 OP *newop = newGVOP(OP_GV, 0,
5751 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5756 else if (kid->op_type == OP_READLINE) {
5757 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5758 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5761 I32 flags = OPf_SPECIAL;
5765 /* is this op a FH constructor? */
5766 if (is_handle_constructor(o,numargs)) {
5767 char *name = Nullch;
5771 /* Set a flag to tell rv2gv to vivify
5772 * need to "prove" flag does not mean something
5773 * else already - NI-S 1999/05/07
5776 if (kid->op_type == OP_PADSV) {
5777 SV **namep = av_fetch(PL_comppad_name,
5779 if (namep && *namep)
5780 name = SvPV(*namep, len);
5782 else if (kid->op_type == OP_RV2SV
5783 && kUNOP->op_first->op_type == OP_GV)
5785 GV *gv = cGVOPx_gv(kUNOP->op_first);
5787 len = GvNAMELEN(gv);
5789 else if (kid->op_type == OP_AELEM
5790 || kid->op_type == OP_HELEM)
5792 name = "__ANONIO__";
5798 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5799 namesv = PL_curpad[targ];
5800 (void)SvUPGRADE(namesv, SVt_PV);
5802 sv_setpvn(namesv, "$", 1);
5803 sv_catpvn(namesv, name, len);
5806 kid->op_sibling = 0;
5807 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5808 kid->op_targ = targ;
5809 kid->op_private |= priv;
5811 kid->op_sibling = sibl;
5817 mod(scalar(kid), type);
5821 tokid = &kid->op_sibling;
5822 kid = kid->op_sibling;
5824 o->op_private |= numargs;
5826 return too_many_arguments(o,PL_op_desc[o->op_type]);
5829 else if (PL_opargs[type] & OA_DEFGV) {
5831 return newUNOP(type, 0, newDEFSVOP());
5835 while (oa & OA_OPTIONAL)
5837 if (oa && oa != OA_LIST)
5838 return too_few_arguments(o,PL_op_desc[o->op_type]);
5844 Perl_ck_glob(pTHX_ OP *o)
5849 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5850 append_elem(OP_GLOB, o, newDEFSVOP());
5852 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5853 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5855 #if !defined(PERL_EXTERNAL_GLOB)
5856 /* XXX this can be tightened up and made more failsafe. */
5859 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5860 /* null-terminated import list */
5861 newSVpvn(":globally", 9), Nullsv);
5862 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5865 #endif /* PERL_EXTERNAL_GLOB */
5867 if (gv && GvIMPORTED_CV(gv)) {
5868 append_elem(OP_GLOB, o,
5869 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5870 o->op_type = OP_LIST;
5871 o->op_ppaddr = PL_ppaddr[OP_LIST];
5872 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5873 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5874 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5875 append_elem(OP_LIST, o,
5876 scalar(newUNOP(OP_RV2CV, 0,
5877 newGVOP(OP_GV, 0, gv)))));
5878 o = newUNOP(OP_NULL, 0, ck_subr(o));
5879 o->op_targ = OP_GLOB; /* hint at what it used to be */
5882 gv = newGVgen("main");
5884 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5890 Perl_ck_grep(pTHX_ OP *o)
5894 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5896 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5897 NewOp(1101, gwop, 1, LOGOP);
5899 if (o->op_flags & OPf_STACKED) {
5902 kid = cLISTOPo->op_first->op_sibling;
5903 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5906 kid->op_next = (OP*)gwop;
5907 o->op_flags &= ~OPf_STACKED;
5909 kid = cLISTOPo->op_first->op_sibling;
5910 if (type == OP_MAPWHILE)
5917 kid = cLISTOPo->op_first->op_sibling;
5918 if (kid->op_type != OP_NULL)
5919 Perl_croak(aTHX_ "panic: ck_grep");
5920 kid = kUNOP->op_first;
5922 gwop->op_type = type;
5923 gwop->op_ppaddr = PL_ppaddr[type];
5924 gwop->op_first = listkids(o);
5925 gwop->op_flags |= OPf_KIDS;
5926 gwop->op_private = 1;
5927 gwop->op_other = LINKLIST(kid);
5928 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5929 kid->op_next = (OP*)gwop;
5931 kid = cLISTOPo->op_first->op_sibling;
5932 if (!kid || !kid->op_sibling)
5933 return too_few_arguments(o,PL_op_desc[o->op_type]);
5934 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5935 mod(kid, OP_GREPSTART);
5941 Perl_ck_index(pTHX_ OP *o)
5943 if (o->op_flags & OPf_KIDS) {
5944 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5946 kid = kid->op_sibling; /* get past "big" */
5947 if (kid && kid->op_type == OP_CONST)
5948 fbm_compile(((SVOP*)kid)->op_sv, 0);
5954 Perl_ck_lengthconst(pTHX_ OP *o)
5956 /* XXX length optimization goes here */
5961 Perl_ck_lfun(pTHX_ OP *o)
5963 OPCODE type = o->op_type;
5964 return modkids(ck_fun(o), type);
5968 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5970 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5971 switch (cUNOPo->op_first->op_type) {
5973 /* This is needed for
5974 if (defined %stash::)
5975 to work. Do not break Tk.
5977 break; /* Globals via GV can be undef */
5979 case OP_AASSIGN: /* Is this a good idea? */
5980 Perl_warner(aTHX_ WARN_DEPRECATED,
5981 "defined(@array) is deprecated");
5982 Perl_warner(aTHX_ WARN_DEPRECATED,
5983 "\t(Maybe you should just omit the defined()?)\n");
5986 /* This is needed for
5987 if (defined %stash::)
5988 to work. Do not break Tk.
5990 break; /* Globals via GV can be undef */
5992 Perl_warner(aTHX_ WARN_DEPRECATED,
5993 "defined(%%hash) is deprecated");
5994 Perl_warner(aTHX_ WARN_DEPRECATED,
5995 "\t(Maybe you should just omit the defined()?)\n");
6006 Perl_ck_rfun(pTHX_ OP *o)
6008 OPCODE type = o->op_type;
6009 return refkids(ck_fun(o), type);
6013 Perl_ck_listiob(pTHX_ OP *o)
6017 kid = cLISTOPo->op_first;
6020 kid = cLISTOPo->op_first;
6022 if (kid->op_type == OP_PUSHMARK)
6023 kid = kid->op_sibling;
6024 if (kid && o->op_flags & OPf_STACKED)
6025 kid = kid->op_sibling;
6026 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6027 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6028 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6029 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6030 cLISTOPo->op_first->op_sibling = kid;
6031 cLISTOPo->op_last = kid;
6032 kid = kid->op_sibling;
6037 append_elem(o->op_type, o, newDEFSVOP());
6043 if (PL_hints & HINT_LOCALE)
6044 o->op_private |= OPpLOCALE;
6051 Perl_ck_fun_locale(pTHX_ OP *o)
6057 if (PL_hints & HINT_LOCALE)
6058 o->op_private |= OPpLOCALE;
6065 Perl_ck_sassign(pTHX_ OP *o)
6067 OP *kid = cLISTOPo->op_first;
6068 /* has a disposable target? */
6069 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6070 && !(kid->op_flags & OPf_STACKED)
6071 /* Cannot steal the second time! */
6072 && !(kid->op_private & OPpTARGET_MY))
6074 OP *kkid = kid->op_sibling;
6076 /* Can just relocate the target. */
6077 if (kkid && kkid->op_type == OP_PADSV
6078 && !(kkid->op_private & OPpLVAL_INTRO))
6080 kid->op_targ = kkid->op_targ;
6082 /* Now we do not need PADSV and SASSIGN. */
6083 kid->op_sibling = o->op_sibling; /* NULL */
6084 cLISTOPo->op_first = NULL;
6087 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6095 Perl_ck_scmp(pTHX_ OP *o)
6099 if (PL_hints & HINT_LOCALE)
6100 o->op_private |= OPpLOCALE;
6107 Perl_ck_match(pTHX_ OP *o)
6109 o->op_private |= OPpRUNTIME;
6114 Perl_ck_method(pTHX_ OP *o)
6116 OP *kid = cUNOPo->op_first;
6117 if (kid->op_type == OP_CONST) {
6118 SV* sv = kSVOP->op_sv;
6119 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6121 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6122 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6125 kSVOP->op_sv = Nullsv;
6127 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6136 Perl_ck_null(pTHX_ OP *o)
6142 Perl_ck_open(pTHX_ OP *o)
6144 HV *table = GvHV(PL_hintgv);
6148 svp = hv_fetch(table, "open_IN", 7, FALSE);
6150 mode = mode_from_discipline(*svp);
6151 if (mode & O_BINARY)
6152 o->op_private |= OPpOPEN_IN_RAW;
6153 else if (mode & O_TEXT)
6154 o->op_private |= OPpOPEN_IN_CRLF;
6157 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6159 mode = mode_from_discipline(*svp);
6160 if (mode & O_BINARY)
6161 o->op_private |= OPpOPEN_OUT_RAW;
6162 else if (mode & O_TEXT)
6163 o->op_private |= OPpOPEN_OUT_CRLF;
6166 if (o->op_type == OP_BACKTICK)
6172 Perl_ck_repeat(pTHX_ OP *o)
6174 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6175 o->op_private |= OPpREPEAT_DOLIST;
6176 cBINOPo->op_first = force_list(cBINOPo->op_first);
6184 Perl_ck_require(pTHX_ OP *o)
6186 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6187 SVOP *kid = (SVOP*)cUNOPo->op_first;
6189 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6191 for (s = SvPVX(kid->op_sv); *s; s++) {
6192 if (*s == ':' && s[1] == ':') {
6194 Move(s+2, s+1, strlen(s+2)+1, char);
6195 --SvCUR(kid->op_sv);
6198 if (SvREADONLY(kid->op_sv)) {
6199 SvREADONLY_off(kid->op_sv);
6200 sv_catpvn(kid->op_sv, ".pm", 3);
6201 SvREADONLY_on(kid->op_sv);
6204 sv_catpvn(kid->op_sv, ".pm", 3);
6211 Perl_ck_return(pTHX_ OP *o)
6214 if (CvLVALUE(PL_compcv)) {
6215 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6216 mod(kid, OP_LEAVESUBLV);
6223 Perl_ck_retarget(pTHX_ OP *o)
6225 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6232 Perl_ck_select(pTHX_ OP *o)
6235 if (o->op_flags & OPf_KIDS) {
6236 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6237 if (kid && kid->op_sibling) {
6238 o->op_type = OP_SSELECT;
6239 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6241 return fold_constants(o);
6245 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6246 if (kid && kid->op_type == OP_RV2GV)
6247 kid->op_private &= ~HINT_STRICT_REFS;
6252 Perl_ck_shift(pTHX_ OP *o)
6254 I32 type = o->op_type;
6256 if (!(o->op_flags & OPf_KIDS)) {
6261 if (!CvUNIQUE(PL_compcv)) {
6262 argop = newOP(OP_PADAV, OPf_REF);
6263 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6266 argop = newUNOP(OP_RV2AV, 0,
6267 scalar(newGVOP(OP_GV, 0,
6268 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6271 argop = newUNOP(OP_RV2AV, 0,
6272 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6273 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6274 #endif /* USE_THREADS */
6275 return newUNOP(type, 0, scalar(argop));
6277 return scalar(modkids(ck_fun(o), type));
6281 Perl_ck_sort(pTHX_ OP *o)
6286 if (PL_hints & HINT_LOCALE)
6287 o->op_private |= OPpLOCALE;
6290 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6292 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6293 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6295 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6297 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6299 if (kid->op_type == OP_SCOPE) {
6303 else if (kid->op_type == OP_LEAVE) {
6304 if (o->op_type == OP_SORT) {
6305 null(kid); /* wipe out leave */
6308 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6309 if (k->op_next == kid)
6311 /* don't descend into loops */
6312 else if (k->op_type == OP_ENTERLOOP
6313 || k->op_type == OP_ENTERITER)
6315 k = cLOOPx(k)->op_lastop;
6320 kid->op_next = 0; /* just disconnect the leave */
6321 k = kLISTOP->op_first;
6326 if (o->op_type == OP_SORT) {
6327 /* provide scalar context for comparison function/block */
6333 o->op_flags |= OPf_SPECIAL;
6335 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6338 firstkid = firstkid->op_sibling;
6341 /* provide list context for arguments */
6342 if (o->op_type == OP_SORT)
6349 S_simplify_sort(pTHX_ OP *o)
6351 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6355 if (!(o->op_flags & OPf_STACKED))
6357 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6358 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6359 kid = kUNOP->op_first; /* get past null */
6360 if (kid->op_type != OP_SCOPE)
6362 kid = kLISTOP->op_last; /* get past scope */
6363 switch(kid->op_type) {
6371 k = kid; /* remember this node*/
6372 if (kBINOP->op_first->op_type != OP_RV2SV)
6374 kid = kBINOP->op_first; /* get past cmp */
6375 if (kUNOP->op_first->op_type != OP_GV)
6377 kid = kUNOP->op_first; /* get past rv2sv */
6379 if (GvSTASH(gv) != PL_curstash)
6381 if (strEQ(GvNAME(gv), "a"))
6383 else if (strEQ(GvNAME(gv), "b"))
6387 kid = k; /* back to cmp */
6388 if (kBINOP->op_last->op_type != OP_RV2SV)
6390 kid = kBINOP->op_last; /* down to 2nd arg */
6391 if (kUNOP->op_first->op_type != OP_GV)
6393 kid = kUNOP->op_first; /* get past rv2sv */
6395 if (GvSTASH(gv) != PL_curstash
6397 ? strNE(GvNAME(gv), "a")
6398 : strNE(GvNAME(gv), "b")))
6400 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6402 o->op_private |= OPpSORT_REVERSE;
6403 if (k->op_type == OP_NCMP)
6404 o->op_private |= OPpSORT_NUMERIC;
6405 if (k->op_type == OP_I_NCMP)
6406 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6407 kid = cLISTOPo->op_first->op_sibling;
6408 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6409 op_free(kid); /* then delete it */
6413 Perl_ck_split(pTHX_ OP *o)
6417 if (o->op_flags & OPf_STACKED)
6418 return no_fh_allowed(o);
6420 kid = cLISTOPo->op_first;
6421 if (kid->op_type != OP_NULL)
6422 Perl_croak(aTHX_ "panic: ck_split");
6423 kid = kid->op_sibling;
6424 op_free(cLISTOPo->op_first);
6425 cLISTOPo->op_first = kid;
6427 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6428 cLISTOPo->op_last = kid; /* There was only one element previously */
6431 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6432 OP *sibl = kid->op_sibling;
6433 kid->op_sibling = 0;
6434 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6435 if (cLISTOPo->op_first == cLISTOPo->op_last)
6436 cLISTOPo->op_last = kid;
6437 cLISTOPo->op_first = kid;
6438 kid->op_sibling = sibl;
6441 kid->op_type = OP_PUSHRE;
6442 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6445 if (!kid->op_sibling)
6446 append_elem(OP_SPLIT, o, newDEFSVOP());
6448 kid = kid->op_sibling;
6451 if (!kid->op_sibling)
6452 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6454 kid = kid->op_sibling;
6457 if (kid->op_sibling)
6458 return too_many_arguments(o,PL_op_desc[o->op_type]);
6464 Perl_ck_join(pTHX_ OP *o)
6466 if (ckWARN(WARN_SYNTAX)) {
6467 OP *kid = cLISTOPo->op_first->op_sibling;
6468 if (kid && kid->op_type == OP_MATCH) {
6469 char *pmstr = "STRING";
6470 if (kPMOP->op_pmregexp)
6471 pmstr = kPMOP->op_pmregexp->precomp;
6472 Perl_warner(aTHX_ WARN_SYNTAX,
6473 "/%s/ should probably be written as \"%s\"",
6481 Perl_ck_subr(pTHX_ OP *o)
6483 OP *prev = ((cUNOPo->op_first->op_sibling)
6484 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6485 OP *o2 = prev->op_sibling;
6494 o->op_private |= OPpENTERSUB_HASTARG;
6495 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6496 if (cvop->op_type == OP_RV2CV) {
6498 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6499 null(cvop); /* disable rv2cv */
6500 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6501 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6502 GV *gv = cGVOPx_gv(tmpop);
6505 tmpop->op_private |= OPpEARLY_CV;
6506 else if (SvPOK(cv)) {
6507 namegv = CvANON(cv) ? gv : CvGV(cv);
6508 proto = SvPV((SV*)cv, n_a);
6512 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6513 if (o2->op_type == OP_CONST)
6514 o2->op_private &= ~OPpCONST_STRICT;
6515 else if (o2->op_type == OP_LIST) {
6516 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6517 if (o && o->op_type == OP_CONST)
6518 o->op_private &= ~OPpCONST_STRICT;
6521 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6522 if (PERLDB_SUB && PL_curstash != PL_debstash)
6523 o->op_private |= OPpENTERSUB_DB;
6524 while (o2 != cvop) {
6528 return too_many_arguments(o, gv_ename(namegv));
6546 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6548 arg == 1 ? "block or sub {}" : "sub {}",
6549 gv_ename(namegv), o2);
6552 /* '*' allows any scalar type, including bareword */
6555 if (o2->op_type == OP_RV2GV)
6556 goto wrapref; /* autoconvert GLOB -> GLOBref */
6557 else if (o2->op_type == OP_CONST)
6558 o2->op_private &= ~OPpCONST_STRICT;
6559 else if (o2->op_type == OP_ENTERSUB) {
6560 /* accidental subroutine, revert to bareword */
6561 OP *gvop = ((UNOP*)o2)->op_first;
6562 if (gvop && gvop->op_type == OP_NULL) {
6563 gvop = ((UNOP*)gvop)->op_first;
6565 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6568 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6569 (gvop = ((UNOP*)gvop)->op_first) &&
6570 gvop->op_type == OP_GV)
6572 GV *gv = cGVOPx_gv(gvop);
6573 OP *sibling = o2->op_sibling;
6574 SV *n = newSVpvn("",0);
6576 gv_fullname3(n, gv, "");
6577 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6578 sv_chop(n, SvPVX(n)+6);
6579 o2 = newSVOP(OP_CONST, 0, n);
6580 prev->op_sibling = o2;
6581 o2->op_sibling = sibling;
6593 if (o2->op_type != OP_RV2GV)
6594 bad_type(arg, "symbol", gv_ename(namegv), o2);
6597 if (o2->op_type != OP_ENTERSUB)
6598 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6601 if (o2->op_type != OP_RV2SV
6602 && o2->op_type != OP_PADSV
6603 && o2->op_type != OP_HELEM
6604 && o2->op_type != OP_AELEM
6605 && o2->op_type != OP_THREADSV)
6607 bad_type(arg, "scalar", gv_ename(namegv), o2);
6611 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6612 bad_type(arg, "array", gv_ename(namegv), o2);
6615 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6616 bad_type(arg, "hash", gv_ename(namegv), o2);
6620 OP* sib = kid->op_sibling;
6621 kid->op_sibling = 0;
6622 o2 = newUNOP(OP_REFGEN, 0, kid);
6623 o2->op_sibling = sib;
6624 prev->op_sibling = o2;
6635 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6636 gv_ename(namegv), SvPV((SV*)cv, n_a));
6641 mod(o2, OP_ENTERSUB);
6643 o2 = o2->op_sibling;
6645 if (proto && !optional &&
6646 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6647 return too_few_arguments(o, gv_ename(namegv));
6652 Perl_ck_svconst(pTHX_ OP *o)
6654 SvREADONLY_on(cSVOPo->op_sv);
6659 Perl_ck_trunc(pTHX_ OP *o)
6661 if (o->op_flags & OPf_KIDS) {
6662 SVOP *kid = (SVOP*)cUNOPo->op_first;
6664 if (kid->op_type == OP_NULL)
6665 kid = (SVOP*)kid->op_sibling;
6666 if (kid && kid->op_type == OP_CONST &&
6667 (kid->op_private & OPpCONST_BARE))
6669 o->op_flags |= OPf_SPECIAL;
6670 kid->op_private &= ~OPpCONST_STRICT;
6677 Perl_ck_substr(pTHX_ OP *o)
6680 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6681 OP *kid = cLISTOPo->op_first;
6683 if (kid->op_type == OP_NULL)
6684 kid = kid->op_sibling;
6686 kid->op_flags |= OPf_MOD;
6692 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6695 Perl_peep(pTHX_ register OP *o)
6697 register OP* oldop = 0;
6700 if (!o || o->op_seq)
6704 SAVEVPTR(PL_curcop);
6705 for (; o; o = o->op_next) {
6711 switch (o->op_type) {
6715 PL_curcop = ((COP*)o); /* for warnings */
6716 o->op_seq = PL_op_seqmax++;
6720 if (cSVOPo->op_private & OPpCONST_STRICT)
6721 no_bareword_allowed(o);
6723 /* Relocate sv to the pad for thread safety.
6724 * Despite being a "constant", the SV is written to,
6725 * for reference counts, sv_upgrade() etc. */
6727 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6728 if (SvPADTMP(cSVOPo->op_sv)) {
6729 /* If op_sv is already a PADTMP then it is being used by
6730 * some pad, so make a copy. */
6731 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6732 SvREADONLY_on(PL_curpad[ix]);
6733 SvREFCNT_dec(cSVOPo->op_sv);
6736 SvREFCNT_dec(PL_curpad[ix]);
6737 SvPADTMP_on(cSVOPo->op_sv);
6738 PL_curpad[ix] = cSVOPo->op_sv;
6739 /* XXX I don't know how this isn't readonly already. */
6740 SvREADONLY_on(PL_curpad[ix]);
6742 cSVOPo->op_sv = Nullsv;
6746 o->op_seq = PL_op_seqmax++;
6750 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6751 if (o->op_next->op_private & OPpTARGET_MY) {
6752 if (o->op_flags & OPf_STACKED) /* chained concats */
6753 goto ignore_optimization;
6755 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6756 o->op_targ = o->op_next->op_targ;
6757 o->op_next->op_targ = 0;
6758 o->op_private |= OPpTARGET_MY;
6763 ignore_optimization:
6764 o->op_seq = PL_op_seqmax++;
6767 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6768 o->op_seq = PL_op_seqmax++;
6769 break; /* Scalar stub must produce undef. List stub is noop */
6773 if (o->op_targ == OP_NEXTSTATE
6774 || o->op_targ == OP_DBSTATE
6775 || o->op_targ == OP_SETSTATE)
6777 PL_curcop = ((COP*)o);
6784 if (oldop && o->op_next) {
6785 oldop->op_next = o->op_next;
6788 o->op_seq = PL_op_seqmax++;
6792 if (o->op_next->op_type == OP_RV2SV) {
6793 if (!(o->op_next->op_private & OPpDEREF)) {
6795 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6797 o->op_next = o->op_next->op_next;
6798 o->op_type = OP_GVSV;
6799 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6802 else if (o->op_next->op_type == OP_RV2AV) {
6803 OP* pop = o->op_next->op_next;
6805 if (pop->op_type == OP_CONST &&
6806 (PL_op = pop->op_next) &&
6807 pop->op_next->op_type == OP_AELEM &&
6808 !(pop->op_next->op_private &
6809 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6810 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6818 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6819 o->op_next = pop->op_next->op_next;
6820 o->op_type = OP_AELEMFAST;
6821 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6822 o->op_private = (U8)i;
6827 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6829 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6830 /* XXX could check prototype here instead of just carping */
6831 SV *sv = sv_newmortal();
6832 gv_efullname3(sv, gv, Nullch);
6833 Perl_warner(aTHX_ WARN_PROTOTYPE,
6834 "%s() called too early to check prototype",
6839 o->op_seq = PL_op_seqmax++;
6850 o->op_seq = PL_op_seqmax++;
6851 while (cLOGOP->op_other->op_type == OP_NULL)
6852 cLOGOP->op_other = cLOGOP->op_other->op_next;
6853 peep(cLOGOP->op_other);
6858 o->op_seq = PL_op_seqmax++;
6859 while (cLOOP->op_redoop->op_type == OP_NULL)
6860 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6861 peep(cLOOP->op_redoop);
6862 while (cLOOP->op_nextop->op_type == OP_NULL)
6863 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6864 peep(cLOOP->op_nextop);
6865 while (cLOOP->op_lastop->op_type == OP_NULL)
6866 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6867 peep(cLOOP->op_lastop);
6873 o->op_seq = PL_op_seqmax++;
6874 while (cPMOP->op_pmreplstart &&
6875 cPMOP->op_pmreplstart->op_type == OP_NULL)
6876 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6877 peep(cPMOP->op_pmreplstart);
6881 o->op_seq = PL_op_seqmax++;
6882 if (ckWARN(WARN_SYNTAX) && o->op_next
6883 && o->op_next->op_type == OP_NEXTSTATE) {
6884 if (o->op_next->op_sibling &&
6885 o->op_next->op_sibling->op_type != OP_EXIT &&
6886 o->op_next->op_sibling->op_type != OP_WARN &&
6887 o->op_next->op_sibling->op_type != OP_DIE) {
6888 line_t oldline = CopLINE(PL_curcop);
6890 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6891 Perl_warner(aTHX_ WARN_EXEC,
6892 "Statement unlikely to be reached");
6893 Perl_warner(aTHX_ WARN_EXEC,
6894 "\t(Maybe you meant system() when you said exec()?)\n");
6895 CopLINE_set(PL_curcop, oldline);
6904 SV **svp, **indsvp, *sv;
6909 o->op_seq = PL_op_seqmax++;
6911 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6914 /* Make the CONST have a shared SV */
6915 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6916 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6917 key = SvPV(sv, keylen);
6920 lexname = newSVpvn_share(key, keylen, 0);
6925 if ((o->op_private & (OPpLVAL_INTRO)))
6928 rop = (UNOP*)((BINOP*)o)->op_first;
6929 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6931 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6932 if (!SvOBJECT(lexname))
6934 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6935 if (!fields || !GvHV(*fields))
6937 key = SvPV(*svp, keylen);
6940 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6942 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6943 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6945 ind = SvIV(*indsvp);
6947 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6948 rop->op_type = OP_RV2AV;
6949 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6950 o->op_type = OP_AELEM;
6951 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6953 if (SvREADONLY(*svp))
6955 SvFLAGS(sv) |= (SvFLAGS(*svp)
6956 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6966 SV **svp, **indsvp, *sv;
6970 SVOP *first_key_op, *key_op;
6972 o->op_seq = PL_op_seqmax++;
6973 if ((o->op_private & (OPpLVAL_INTRO))
6974 /* I bet there's always a pushmark... */
6975 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6976 /* hmmm, no optimization if list contains only one key. */
6978 rop = (UNOP*)((LISTOP*)o)->op_last;
6979 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6981 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6982 if (!SvOBJECT(lexname))
6984 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6985 if (!fields || !GvHV(*fields))
6987 /* Again guessing that the pushmark can be jumped over.... */
6988 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6989 ->op_first->op_sibling;
6990 /* Check that the key list contains only constants. */
6991 for (key_op = first_key_op; key_op;
6992 key_op = (SVOP*)key_op->op_sibling)
6993 if (key_op->op_type != OP_CONST)
6997 rop->op_type = OP_RV2AV;
6998 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6999 o->op_type = OP_ASLICE;
7000 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7001 for (key_op = first_key_op; key_op;
7002 key_op = (SVOP*)key_op->op_sibling) {
7003 svp = cSVOPx_svp(key_op);
7004 key = SvPV(*svp, keylen);
7007 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7009 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7010 "in variable %s of type %s",
7011 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7013 ind = SvIV(*indsvp);
7015 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7017 if (SvREADONLY(*svp))
7019 SvFLAGS(sv) |= (SvFLAGS(*svp)
7020 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7028 o->op_seq = PL_op_seqmax++;
7038 /* Efficient sub that returns a constant scalar value. */
7040 const_sv_xsub(pTHXo_ CV* cv)
7045 Perl_croak(aTHX_ "usage: %s::%s()",
7046 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7050 ST(0) = (SV*)XSANY.any_ptr;