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)));
106 /* "register" allocation */
109 Perl_pad_allocmy(pTHX_ char *name)
114 if (!(PL_in_my == KEY_our ||
116 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
117 (name[1] == '_' && (int)strlen(name) > 2)))
119 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
120 /* 1999-02-27 mjd@plover.com */
122 p = strchr(name, '\0');
123 /* The next block assumes the buffer is at least 205 chars
124 long. At present, it's always at least 256 chars. */
126 strcpy(name+200, "...");
132 /* Move everything else down one character */
133 for (; p-name > 2; p--)
135 name[2] = toCTRL(name[1]);
138 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
140 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
141 SV **svp = AvARRAY(PL_comppad_name);
142 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
143 PADOFFSET top = AvFILLp(PL_comppad_name);
144 for (off = top; off > PL_comppad_name_floor; off--) {
146 && sv != &PL_sv_undef
147 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
148 && (PL_in_my != KEY_our
149 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
150 && strEQ(name, SvPVX(sv)))
152 Perl_warner(aTHX_ WARN_MISC,
153 "\"%s\" variable %s masks earlier declaration in same %s",
154 (PL_in_my == KEY_our ? "our" : "my"),
156 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
161 if (PL_in_my == KEY_our) {
164 && sv != &PL_sv_undef
165 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
166 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
167 && strEQ(name, SvPVX(sv)))
169 Perl_warner(aTHX_ WARN_MISC,
170 "\"our\" variable %s redeclared", name);
171 Perl_warner(aTHX_ WARN_MISC,
172 "\t(Did you mean \"local\" instead of \"our\"?)\n");
175 } while ( off-- > 0 );
178 off = pad_alloc(OP_PADSV, SVs_PADMY);
180 sv_upgrade(sv, SVt_PVNV);
182 if (PL_in_my_stash) {
184 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
185 name, PL_in_my == KEY_our ? "our" : "my"));
186 SvFLAGS(sv) |= SVpad_TYPED;
187 (void)SvUPGRADE(sv, SVt_PVMG);
188 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
190 if (PL_in_my == KEY_our) {
191 (void)SvUPGRADE(sv, SVt_PVGV);
192 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
193 SvFLAGS(sv) |= SVpad_OUR;
195 av_store(PL_comppad_name, off, sv);
196 SvNVX(sv) = (NV)PAD_MAX;
197 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
198 if (!PL_min_intro_pending)
199 PL_min_intro_pending = off;
200 PL_max_intro_pending = off;
202 av_store(PL_comppad, off, (SV*)newAV());
203 else if (*name == '%')
204 av_store(PL_comppad, off, (SV*)newHV());
205 SvPADMY_on(PL_curpad[off]);
210 S_pad_addlex(pTHX_ SV *proto_namesv)
212 SV *namesv = NEWSV(1103,0);
213 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
214 sv_upgrade(namesv, SVt_PVNV);
215 sv_setpv(namesv, SvPVX(proto_namesv));
216 av_store(PL_comppad_name, newoff, namesv);
217 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
218 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
219 SvFAKE_on(namesv); /* A ref, not a real var */
220 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
221 SvFLAGS(namesv) |= SVpad_OUR;
222 (void)SvUPGRADE(namesv, SVt_PVGV);
223 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
225 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
226 SvFLAGS(namesv) |= SVpad_TYPED;
227 (void)SvUPGRADE(namesv, SVt_PVMG);
228 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
233 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
236 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
237 I32 cx_ix, I32 saweval, U32 flags)
243 register PERL_CONTEXT *cx;
245 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
246 AV *curlist = CvPADLIST(cv);
247 SV **svp = av_fetch(curlist, 0, FALSE);
250 if (!svp || *svp == &PL_sv_undef)
253 svp = AvARRAY(curname);
254 for (off = AvFILLp(curname); off > 0; off--) {
255 if ((sv = svp[off]) &&
256 sv != &PL_sv_undef &&
258 seq > I_32(SvNVX(sv)) &&
259 strEQ(SvPVX(sv), name))
270 return 0; /* don't clone from inactive stack frame */
274 oldpad = (AV*)AvARRAY(curlist)[depth];
275 oldsv = *av_fetch(oldpad, off, TRUE);
276 if (!newoff) { /* Not a mere clone operation. */
277 newoff = pad_addlex(sv);
278 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
279 /* "It's closures all the way down." */
280 CvCLONE_on(PL_compcv);
282 if (CvANON(PL_compcv))
283 oldsv = Nullsv; /* no need to keep ref */
288 bcv && bcv != cv && !CvCLONE(bcv);
289 bcv = CvOUTSIDE(bcv))
292 /* install the missing pad entry in intervening
293 * nested subs and mark them cloneable.
294 * XXX fix pad_foo() to not use globals */
295 AV *ocomppad_name = PL_comppad_name;
296 AV *ocomppad = PL_comppad;
297 SV **ocurpad = PL_curpad;
298 AV *padlist = CvPADLIST(bcv);
299 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
300 PL_comppad = (AV*)AvARRAY(padlist)[1];
301 PL_curpad = AvARRAY(PL_comppad);
303 PL_comppad_name = ocomppad_name;
304 PL_comppad = ocomppad;
309 if (ckWARN(WARN_CLOSURE)
310 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
312 Perl_warner(aTHX_ WARN_CLOSURE,
313 "Variable \"%s\" may be unavailable",
321 else if (!CvUNIQUE(PL_compcv)) {
322 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
323 && !(SvFLAGS(sv) & SVpad_OUR))
325 Perl_warner(aTHX_ WARN_CLOSURE,
326 "Variable \"%s\" will not stay shared", name);
330 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
336 if (flags & FINDLEX_NOSEARCH)
339 /* Nothing in current lexical context--try eval's context, if any.
340 * This is necessary to let the perldb get at lexically scoped variables.
341 * XXX This will also probably interact badly with eval tree caching.
344 for (i = cx_ix; i >= 0; i--) {
346 switch (CxTYPE(cx)) {
348 if (i == 0 && saweval) {
349 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
353 switch (cx->blk_eval.old_op_type) {
355 if (CxREALEVAL(cx)) {
358 seq = cxstack[i].blk_oldcop->cop_seq;
359 startcv = cxstack[i].blk_eval.cv;
360 if (startcv && CvOUTSIDE(startcv)) {
361 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
363 if (off) /* continue looking if not found here */
370 /* require/do must have their own scope */
379 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
380 saweval = i; /* so we know where we were called from */
383 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
391 Perl_pad_findmy(pTHX_ char *name)
396 SV **svp = AvARRAY(PL_comppad_name);
397 U32 seq = PL_cop_seqmax;
403 * Special case to get lexical (and hence per-thread) @_.
404 * XXX I need to find out how to tell at parse-time whether use
405 * of @_ should refer to a lexical (from a sub) or defgv (global
406 * scope and maybe weird sub-ish things like formats). See
407 * startsub in perly.y. It's possible that @_ could be lexical
408 * (at least from subs) even in non-threaded perl.
410 if (strEQ(name, "@_"))
411 return 0; /* success. (NOT_IN_PAD indicates failure) */
412 #endif /* USE_THREADS */
414 /* The one we're looking for is probably just before comppad_name_fill. */
415 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
416 if ((sv = svp[off]) &&
417 sv != &PL_sv_undef &&
420 seq > I_32(SvNVX(sv)))) &&
421 strEQ(SvPVX(sv), name))
423 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
424 return (PADOFFSET)off;
425 pendoff = off; /* this pending def. will override import */
429 outside = CvOUTSIDE(PL_compcv);
431 /* Check if if we're compiling an eval'', and adjust seq to be the
432 * eval's seq number. This depends on eval'' having a non-null
433 * CvOUTSIDE() while it is being compiled. The eval'' itself is
434 * identified by CvEVAL being true and CvGV being null. */
435 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
436 cx = &cxstack[cxstack_ix];
438 seq = cx->blk_oldcop->cop_seq;
441 /* See if it's in a nested scope */
442 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
444 /* If there is a pending local definition, this new alias must die */
446 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
447 return off; /* pad_findlex returns 0 for failure...*/
449 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
453 Perl_pad_leavemy(pTHX_ I32 fill)
456 SV **svp = AvARRAY(PL_comppad_name);
458 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
459 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
460 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
461 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
464 /* "Deintroduce" my variables that are leaving with this scope. */
465 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
466 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
467 SvIVX(sv) = PL_cop_seqmax;
472 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
477 if (AvARRAY(PL_comppad) != PL_curpad)
478 Perl_croak(aTHX_ "panic: pad_alloc");
479 if (PL_pad_reset_pending)
481 if (tmptype & SVs_PADMY) {
483 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
484 } while (SvPADBUSY(sv)); /* need a fresh one */
485 retval = AvFILLp(PL_comppad);
488 SV **names = AvARRAY(PL_comppad_name);
489 SSize_t names_fill = AvFILLp(PL_comppad_name);
492 * "foreach" index vars temporarily become aliases to non-"my"
493 * values. Thus we must skip, not just pad values that are
494 * marked as current pad values, but also those with names.
496 if (++PL_padix <= names_fill &&
497 (sv = names[PL_padix]) && sv != &PL_sv_undef)
499 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
500 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
501 !IS_PADGV(sv) && !IS_PADCONST(sv))
506 SvFLAGS(sv) |= tmptype;
507 PL_curpad = AvARRAY(PL_comppad);
509 DEBUG_X(PerlIO_printf(Perl_debug_log,
510 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
511 PTR2UV(thr), PTR2UV(PL_curpad),
512 (long) retval, PL_op_name[optype]));
514 DEBUG_X(PerlIO_printf(Perl_debug_log,
515 "Pad 0x%"UVxf" alloc %ld for %s\n",
517 (long) retval, PL_op_name[optype]));
518 #endif /* USE_THREADS */
519 return (PADOFFSET)retval;
523 Perl_pad_sv(pTHX_ PADOFFSET po)
526 DEBUG_X(PerlIO_printf(Perl_debug_log,
527 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
528 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
531 Perl_croak(aTHX_ "panic: pad_sv po");
532 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
533 PTR2UV(PL_curpad), (IV)po));
534 #endif /* USE_THREADS */
535 return PL_curpad[po]; /* eventually we'll turn this into a macro */
539 Perl_pad_free(pTHX_ PADOFFSET po)
543 if (AvARRAY(PL_comppad) != PL_curpad)
544 Perl_croak(aTHX_ "panic: pad_free curpad");
546 Perl_croak(aTHX_ "panic: pad_free po");
548 DEBUG_X(PerlIO_printf(Perl_debug_log,
549 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
550 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
552 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
553 PTR2UV(PL_curpad), (IV)po));
554 #endif /* USE_THREADS */
555 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
556 SvPADTMP_off(PL_curpad[po]);
558 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
561 if ((I32)po < PL_padix)
566 Perl_pad_swipe(pTHX_ PADOFFSET po)
568 if (AvARRAY(PL_comppad) != PL_curpad)
569 Perl_croak(aTHX_ "panic: pad_swipe curpad");
571 Perl_croak(aTHX_ "panic: pad_swipe po");
573 DEBUG_X(PerlIO_printf(Perl_debug_log,
574 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
575 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
577 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(PL_curpad), (IV)po));
579 #endif /* USE_THREADS */
580 SvPADTMP_off(PL_curpad[po]);
581 PL_curpad[po] = NEWSV(1107,0);
582 SvPADTMP_on(PL_curpad[po]);
583 if ((I32)po < PL_padix)
587 /* XXX pad_reset() is currently disabled because it results in serious bugs.
588 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
589 * on the stack by OPs that use them, there are several ways to get an alias
590 * to a shared TARG. Such an alias will change randomly and unpredictably.
591 * We avoid doing this until we can think of a Better Way.
596 #ifdef USE_BROKEN_PAD_RESET
599 if (AvARRAY(PL_comppad) != PL_curpad)
600 Perl_croak(aTHX_ "panic: pad_reset curpad");
602 DEBUG_X(PerlIO_printf(Perl_debug_log,
603 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
604 PTR2UV(thr), PTR2UV(PL_curpad)));
606 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
608 #endif /* USE_THREADS */
609 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
610 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
611 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
612 SvPADTMP_off(PL_curpad[po]);
614 PL_padix = PL_padix_floor;
617 PL_pad_reset_pending = FALSE;
621 /* find_threadsv is not reentrant */
623 Perl_find_threadsv(pTHX_ const char *name)
628 /* We currently only handle names of a single character */
629 p = strchr(PL_threadsv_names, *name);
632 key = p - PL_threadsv_names;
633 MUTEX_LOCK(&thr->mutex);
634 svp = av_fetch(thr->threadsv, key, FALSE);
636 MUTEX_UNLOCK(&thr->mutex);
638 SV *sv = NEWSV(0, 0);
639 av_store(thr->threadsv, key, sv);
640 thr->threadsvp = AvARRAY(thr->threadsv);
641 MUTEX_UNLOCK(&thr->mutex);
643 * Some magic variables used to be automagically initialised
644 * in gv_fetchpv. Those which are now per-thread magicals get
645 * initialised here instead.
651 sv_setpv(sv, "\034");
652 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
657 PL_sawampersand = TRUE;
671 /* XXX %! tied to Errno.pm needs to be added here.
672 * See gv_fetchpv(). */
676 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
678 DEBUG_S(PerlIO_printf(Perl_error_log,
679 "find_threadsv: new SV %p for $%s%c\n",
680 sv, (*name < 32) ? "^" : "",
681 (*name < 32) ? toCTRL(*name) : *name));
685 #endif /* USE_THREADS */
690 Perl_op_free(pTHX_ OP *o)
692 register OP *kid, *nextkid;
695 if (!o || o->op_seq == (U16)-1)
698 if (o->op_private & OPpREFCOUNTED) {
699 switch (o->op_type) {
707 if (OpREFCNT_dec(o)) {
718 if (o->op_flags & OPf_KIDS) {
719 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
720 nextkid = kid->op_sibling; /* Get before next freeing kid */
728 /* COP* is not cleared by op_clear() so that we may track line
729 * numbers etc even after null() */
730 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
735 #ifdef PL_OP_SLAB_ALLOC
736 if ((char *) o == PL_OpPtr)
745 Perl_op_clear(pTHX_ OP *o)
747 switch (o->op_type) {
748 case OP_NULL: /* Was holding old type, if any. */
749 case OP_ENTEREVAL: /* Was holding hints. */
751 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
757 if (!(o->op_flags & OPf_SPECIAL))
760 #endif /* USE_THREADS */
762 if (!(o->op_flags & OPf_REF)
763 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
770 if (cPADOPo->op_padix > 0) {
773 pad_swipe(cPADOPo->op_padix);
774 /* No GvIN_PAD_off(gv) here, because other references may still
775 * exist on the pad */
778 cPADOPo->op_padix = 0;
781 SvREFCNT_dec(cSVOPo->op_sv);
782 cSVOPo->op_sv = Nullsv;
785 case OP_METHOD_NAMED:
787 SvREFCNT_dec(cSVOPo->op_sv);
788 cSVOPo->op_sv = Nullsv;
794 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
798 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
799 SvREFCNT_dec(cSVOPo->op_sv);
800 cSVOPo->op_sv = Nullsv;
803 Safefree(cPVOPo->op_pv);
804 cPVOPo->op_pv = Nullch;
808 op_free(cPMOPo->op_pmreplroot);
812 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
814 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
815 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
816 /* No GvIN_PAD_off(gv) here, because other references may still
817 * exist on the pad */
822 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
829 HV *pmstash = PmopSTASH(cPMOPo);
830 if (pmstash && SvREFCNT(pmstash)) {
831 PMOP *pmop = HvPMROOT(pmstash);
832 PMOP *lastpmop = NULL;
834 if (cPMOPo == pmop) {
836 lastpmop->op_pmnext = pmop->op_pmnext;
838 HvPMROOT(pmstash) = pmop->op_pmnext;
842 pmop = pmop->op_pmnext;
845 Safefree(PmopSTASHPV(cPMOPo));
847 /* NOTE: PMOP.op_pmstash is not refcounted */
851 cPMOPo->op_pmreplroot = Nullop;
852 ReREFCNT_dec(cPMOPo->op_pmregexp);
853 cPMOPo->op_pmregexp = (REGEXP*)NULL;
857 if (o->op_targ > 0) {
858 pad_free(o->op_targ);
864 S_cop_free(pTHX_ COP* cop)
866 Safefree(cop->cop_label);
868 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
869 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
871 /* NOTE: COP.cop_stash is not refcounted */
872 SvREFCNT_dec(CopFILEGV(cop));
874 if (! specialWARN(cop->cop_warnings))
875 SvREFCNT_dec(cop->cop_warnings);
876 if (! specialCopIO(cop->cop_io))
877 SvREFCNT_dec(cop->cop_io);
881 Perl_op_null(pTHX_ OP *o)
883 if (o->op_type == OP_NULL)
886 o->op_targ = o->op_type;
887 o->op_type = OP_NULL;
888 o->op_ppaddr = PL_ppaddr[OP_NULL];
891 /* Contextualizers */
893 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
896 Perl_linklist(pTHX_ OP *o)
903 /* establish postfix order */
904 if (cUNOPo->op_first) {
905 o->op_next = LINKLIST(cUNOPo->op_first);
906 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
908 kid->op_next = LINKLIST(kid->op_sibling);
920 Perl_scalarkids(pTHX_ OP *o)
923 if (o && o->op_flags & OPf_KIDS) {
924 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
931 S_scalarboolean(pTHX_ OP *o)
933 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
934 if (ckWARN(WARN_SYNTAX)) {
935 line_t oldline = CopLINE(PL_curcop);
937 if (PL_copline != NOLINE)
938 CopLINE_set(PL_curcop, PL_copline);
939 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
940 CopLINE_set(PL_curcop, oldline);
947 Perl_scalar(pTHX_ OP *o)
951 /* assumes no premature commitment */
952 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
953 || o->op_type == OP_RETURN)
958 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
960 switch (o->op_type) {
962 scalar(cBINOPo->op_first);
967 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
971 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
972 if (!kPMOP->op_pmreplroot)
973 deprecate("implicit split to @_");
981 if (o->op_flags & OPf_KIDS) {
982 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
988 kid = cLISTOPo->op_first;
990 while ((kid = kid->op_sibling)) {
996 WITH_THR(PL_curcop = &PL_compiling);
1001 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1002 if (kid->op_sibling)
1007 WITH_THR(PL_curcop = &PL_compiling);
1014 Perl_scalarvoid(pTHX_ OP *o)
1021 if (o->op_type == OP_NEXTSTATE
1022 || o->op_type == OP_SETSTATE
1023 || o->op_type == OP_DBSTATE
1024 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1025 || o->op_targ == OP_SETSTATE
1026 || o->op_targ == OP_DBSTATE)))
1027 PL_curcop = (COP*)o; /* for warning below */
1029 /* assumes no premature commitment */
1030 want = o->op_flags & OPf_WANT;
1031 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1032 || o->op_type == OP_RETURN)
1037 if ((o->op_private & OPpTARGET_MY)
1038 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1040 return scalar(o); /* As if inside SASSIGN */
1043 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1045 switch (o->op_type) {
1047 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1051 if (o->op_flags & OPf_STACKED)
1055 if (o->op_private == 4)
1097 case OP_GETSOCKNAME:
1098 case OP_GETPEERNAME:
1103 case OP_GETPRIORITY:
1126 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1127 useless = PL_op_desc[o->op_type];
1134 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1135 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1136 useless = "a variable";
1141 if (cSVOPo->op_private & OPpCONST_STRICT)
1142 no_bareword_allowed(o);
1144 if (ckWARN(WARN_VOID)) {
1145 useless = "a constant";
1146 /* the constants 0 and 1 are permitted as they are
1147 conventionally used as dummies in constructs like
1148 1 while some_condition_with_side_effects; */
1149 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1151 else if (SvPOK(sv)) {
1152 /* perl4's way of mixing documentation and code
1153 (before the invention of POD) was based on a
1154 trick to mix nroff and perl code. The trick was
1155 built upon these three nroff macros being used in
1156 void context. The pink camel has the details in
1157 the script wrapman near page 319. */
1158 if (strnEQ(SvPVX(sv), "di", 2) ||
1159 strnEQ(SvPVX(sv), "ds", 2) ||
1160 strnEQ(SvPVX(sv), "ig", 2))
1165 op_null(o); /* don't execute or even remember it */
1169 o->op_type = OP_PREINC; /* pre-increment is faster */
1170 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1174 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1175 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1181 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1186 if (o->op_flags & OPf_STACKED)
1193 if (!(o->op_flags & OPf_KIDS))
1202 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1209 /* all requires must return a boolean value */
1210 o->op_flags &= ~OPf_WANT;
1215 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1216 if (!kPMOP->op_pmreplroot)
1217 deprecate("implicit split to @_");
1221 if (useless && ckWARN(WARN_VOID))
1222 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1227 Perl_listkids(pTHX_ OP *o)
1230 if (o && o->op_flags & OPf_KIDS) {
1231 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1238 Perl_list(pTHX_ OP *o)
1242 /* assumes no premature commitment */
1243 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1244 || o->op_type == OP_RETURN)
1249 if ((o->op_private & OPpTARGET_MY)
1250 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1252 return o; /* As if inside SASSIGN */
1255 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1257 switch (o->op_type) {
1260 list(cBINOPo->op_first);
1265 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1273 if (!(o->op_flags & OPf_KIDS))
1275 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1276 list(cBINOPo->op_first);
1277 return gen_constant_list(o);
1284 kid = cLISTOPo->op_first;
1286 while ((kid = kid->op_sibling)) {
1287 if (kid->op_sibling)
1292 WITH_THR(PL_curcop = &PL_compiling);
1296 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1297 if (kid->op_sibling)
1302 WITH_THR(PL_curcop = &PL_compiling);
1305 /* all requires must return a boolean value */
1306 o->op_flags &= ~OPf_WANT;
1313 Perl_scalarseq(pTHX_ OP *o)
1318 if (o->op_type == OP_LINESEQ ||
1319 o->op_type == OP_SCOPE ||
1320 o->op_type == OP_LEAVE ||
1321 o->op_type == OP_LEAVETRY)
1323 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1324 if (kid->op_sibling) {
1328 PL_curcop = &PL_compiling;
1330 o->op_flags &= ~OPf_PARENS;
1331 if (PL_hints & HINT_BLOCK_SCOPE)
1332 o->op_flags |= OPf_PARENS;
1335 o = newOP(OP_STUB, 0);
1340 S_modkids(pTHX_ OP *o, I32 type)
1343 if (o && o->op_flags & OPf_KIDS) {
1344 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1351 Perl_mod(pTHX_ OP *o, I32 type)
1356 if (!o || PL_error_count)
1359 if ((o->op_private & OPpTARGET_MY)
1360 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1365 switch (o->op_type) {
1370 if (!(o->op_private & (OPpCONST_ARYBASE)))
1372 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1373 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1377 SAVEI32(PL_compiling.cop_arybase);
1378 PL_compiling.cop_arybase = 0;
1380 else if (type == OP_REFGEN)
1383 Perl_croak(aTHX_ "That use of $[ is unsupported");
1386 if (o->op_flags & OPf_PARENS)
1390 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1391 !(o->op_flags & OPf_STACKED)) {
1392 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1393 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1394 assert(cUNOPo->op_first->op_type == OP_NULL);
1395 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1398 else { /* lvalue subroutine call */
1399 o->op_private |= OPpLVAL_INTRO;
1400 PL_modcount = RETURN_UNLIMITED_NUMBER;
1401 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1402 /* Backward compatibility mode: */
1403 o->op_private |= OPpENTERSUB_INARGS;
1406 else { /* Compile-time error message: */
1407 OP *kid = cUNOPo->op_first;
1411 if (kid->op_type == OP_PUSHMARK)
1413 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1415 "panic: unexpected lvalue entersub "
1416 "args: type/targ %ld:%ld",
1417 (long)kid->op_type,kid->op_targ);
1418 kid = kLISTOP->op_first;
1420 while (kid->op_sibling)
1421 kid = kid->op_sibling;
1422 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1424 if (kid->op_type == OP_METHOD_NAMED
1425 || kid->op_type == OP_METHOD)
1429 if (kid->op_sibling || kid->op_next != kid) {
1430 yyerror("panic: unexpected optree near method call");
1434 NewOp(1101, newop, 1, UNOP);
1435 newop->op_type = OP_RV2CV;
1436 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1437 newop->op_first = Nullop;
1438 newop->op_next = (OP*)newop;
1439 kid->op_sibling = (OP*)newop;
1440 newop->op_private |= OPpLVAL_INTRO;
1444 if (kid->op_type != OP_RV2CV)
1446 "panic: unexpected lvalue entersub "
1447 "entry via type/targ %ld:%ld",
1448 (long)kid->op_type,kid->op_targ);
1449 kid->op_private |= OPpLVAL_INTRO;
1450 break; /* Postpone until runtime */
1454 kid = kUNOP->op_first;
1455 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1456 kid = kUNOP->op_first;
1457 if (kid->op_type == OP_NULL)
1459 "Unexpected constant lvalue entersub "
1460 "entry via type/targ %ld:%ld",
1461 (long)kid->op_type,kid->op_targ);
1462 if (kid->op_type != OP_GV) {
1463 /* Restore RV2CV to check lvalueness */
1465 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1466 okid->op_next = kid->op_next;
1467 kid->op_next = okid;
1470 okid->op_next = Nullop;
1471 okid->op_type = OP_RV2CV;
1473 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1474 okid->op_private |= OPpLVAL_INTRO;
1478 cv = GvCV(kGVOP_gv);
1488 /* grep, foreach, subcalls, refgen */
1489 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1491 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1492 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1494 : (o->op_type == OP_ENTERSUB
1495 ? "non-lvalue subroutine call"
1496 : PL_op_desc[o->op_type])),
1497 type ? PL_op_desc[type] : "local"));
1511 case OP_RIGHT_SHIFT:
1520 if (!(o->op_flags & OPf_STACKED))
1526 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1532 if (!type && cUNOPo->op_first->op_type != OP_GV)
1533 Perl_croak(aTHX_ "Can't localize through a reference");
1534 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1535 PL_modcount = RETURN_UNLIMITED_NUMBER;
1536 return o; /* Treat \(@foo) like ordinary list. */
1540 if (scalar_mod_type(o, type))
1542 ref(cUNOPo->op_first, o->op_type);
1546 if (type == OP_LEAVESUBLV)
1547 o->op_private |= OPpMAYBE_LVSUB;
1553 PL_modcount = RETURN_UNLIMITED_NUMBER;
1556 if (!type && cUNOPo->op_first->op_type != OP_GV)
1557 Perl_croak(aTHX_ "Can't localize through a reference");
1558 ref(cUNOPo->op_first, o->op_type);
1562 PL_hints |= HINT_BLOCK_SCOPE;
1572 PL_modcount = RETURN_UNLIMITED_NUMBER;
1573 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1574 return o; /* Treat \(@foo) like ordinary list. */
1575 if (scalar_mod_type(o, type))
1577 if (type == OP_LEAVESUBLV)
1578 o->op_private |= OPpMAYBE_LVSUB;
1583 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1584 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1589 PL_modcount++; /* XXX ??? */
1591 #endif /* USE_THREADS */
1597 if (type != OP_SASSIGN)
1601 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1606 if (type == OP_LEAVESUBLV)
1607 o->op_private |= OPpMAYBE_LVSUB;
1609 pad_free(o->op_targ);
1610 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1611 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1612 if (o->op_flags & OPf_KIDS)
1613 mod(cBINOPo->op_first->op_sibling, type);
1618 ref(cBINOPo->op_first, o->op_type);
1619 if (type == OP_ENTERSUB &&
1620 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1621 o->op_private |= OPpLVAL_DEFER;
1622 if (type == OP_LEAVESUBLV)
1623 o->op_private |= OPpMAYBE_LVSUB;
1631 if (o->op_flags & OPf_KIDS)
1632 mod(cLISTOPo->op_last, type);
1636 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1638 else if (!(o->op_flags & OPf_KIDS))
1640 if (o->op_targ != OP_LIST) {
1641 mod(cBINOPo->op_first, type);
1646 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1651 if (type != OP_LEAVESUBLV)
1653 break; /* mod()ing was handled by ck_return() */
1655 if (type != OP_LEAVESUBLV)
1656 o->op_flags |= OPf_MOD;
1658 if (type == OP_AASSIGN || type == OP_SASSIGN)
1659 o->op_flags |= OPf_SPECIAL|OPf_REF;
1661 o->op_private |= OPpLVAL_INTRO;
1662 o->op_flags &= ~OPf_SPECIAL;
1663 PL_hints |= HINT_BLOCK_SCOPE;
1665 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1666 && type != OP_LEAVESUBLV)
1667 o->op_flags |= OPf_REF;
1672 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1676 if (o->op_type == OP_RV2GV)
1700 case OP_RIGHT_SHIFT:
1719 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1721 switch (o->op_type) {
1729 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1742 Perl_refkids(pTHX_ OP *o, I32 type)
1745 if (o && o->op_flags & OPf_KIDS) {
1746 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1753 Perl_ref(pTHX_ OP *o, I32 type)
1757 if (!o || PL_error_count)
1760 switch (o->op_type) {
1762 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1763 !(o->op_flags & OPf_STACKED)) {
1764 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1765 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1766 assert(cUNOPo->op_first->op_type == OP_NULL);
1767 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1768 o->op_flags |= OPf_SPECIAL;
1773 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1777 if (type == OP_DEFINED)
1778 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1779 ref(cUNOPo->op_first, o->op_type);
1782 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1783 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1784 : type == OP_RV2HV ? OPpDEREF_HV
1786 o->op_flags |= OPf_MOD;
1791 o->op_flags |= OPf_MOD; /* XXX ??? */
1796 o->op_flags |= OPf_REF;
1799 if (type == OP_DEFINED)
1800 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1801 ref(cUNOPo->op_first, o->op_type);
1806 o->op_flags |= OPf_REF;
1811 if (!(o->op_flags & OPf_KIDS))
1813 ref(cBINOPo->op_first, type);
1817 ref(cBINOPo->op_first, o->op_type);
1818 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1819 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1820 : type == OP_RV2HV ? OPpDEREF_HV
1822 o->op_flags |= OPf_MOD;
1830 if (!(o->op_flags & OPf_KIDS))
1832 ref(cLISTOPo->op_last, type);
1842 S_dup_attrlist(pTHX_ OP *o)
1846 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1847 * where the first kid is OP_PUSHMARK and the remaining ones
1848 * are OP_CONST. We need to push the OP_CONST values.
1850 if (o->op_type == OP_CONST)
1851 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1853 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1854 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1855 if (o->op_type == OP_CONST)
1856 rop = append_elem(OP_LIST, rop,
1857 newSVOP(OP_CONST, o->op_flags,
1858 SvREFCNT_inc(cSVOPo->op_sv)));
1865 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1869 /* fake up C<use attributes $pkg,$rv,@attrs> */
1870 ENTER; /* need to protect against side-effects of 'use' */
1873 stashsv = newSVpv(HvNAME(stash), 0);
1875 stashsv = &PL_sv_no;
1877 #define ATTRSMODULE "attributes"
1879 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1880 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1882 prepend_elem(OP_LIST,
1883 newSVOP(OP_CONST, 0, stashsv),
1884 prepend_elem(OP_LIST,
1885 newSVOP(OP_CONST, 0,
1887 dup_attrlist(attrs))));
1892 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1893 char *attrstr, STRLEN len)
1898 len = strlen(attrstr);
1902 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1904 char *sstr = attrstr;
1905 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1906 attrs = append_elem(OP_LIST, attrs,
1907 newSVOP(OP_CONST, 0,
1908 newSVpvn(sstr, attrstr-sstr)));
1912 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1913 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1914 Nullsv, prepend_elem(OP_LIST,
1915 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1916 prepend_elem(OP_LIST,
1917 newSVOP(OP_CONST, 0,
1923 S_my_kid(pTHX_ OP *o, OP *attrs)
1928 if (!o || PL_error_count)
1932 if (type == OP_LIST) {
1933 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1935 } else if (type == OP_UNDEF) {
1937 } else if (type == OP_RV2SV || /* "our" declaration */
1939 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1941 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1943 PL_in_my_stash = Nullhv;
1944 apply_attrs(GvSTASH(gv),
1945 (type == OP_RV2SV ? GvSV(gv) :
1946 type == OP_RV2AV ? (SV*)GvAV(gv) :
1947 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1950 o->op_private |= OPpOUR_INTRO;
1952 } else if (type != OP_PADSV &&
1955 type != OP_PUSHMARK)
1957 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1958 PL_op_desc[o->op_type],
1959 PL_in_my == KEY_our ? "our" : "my"));
1962 else if (attrs && type != OP_PUSHMARK) {
1968 PL_in_my_stash = Nullhv;
1970 /* check for C<my Dog $spot> when deciding package */
1971 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1972 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1973 stash = SvSTASH(*namesvp);
1975 stash = PL_curstash;
1976 padsv = PAD_SV(o->op_targ);
1977 apply_attrs(stash, padsv, attrs);
1979 o->op_flags |= OPf_MOD;
1980 o->op_private |= OPpLVAL_INTRO;
1985 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1987 if (o->op_flags & OPf_PARENS)
1991 o = my_kid(o, attrs);
1993 PL_in_my_stash = Nullhv;
1998 Perl_my(pTHX_ OP *o)
2000 return my_kid(o, Nullop);
2004 Perl_sawparens(pTHX_ OP *o)
2007 o->op_flags |= OPf_PARENS;
2012 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2016 if (ckWARN(WARN_MISC) &&
2017 (left->op_type == OP_RV2AV ||
2018 left->op_type == OP_RV2HV ||
2019 left->op_type == OP_PADAV ||
2020 left->op_type == OP_PADHV)) {
2021 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2022 right->op_type == OP_TRANS)
2023 ? right->op_type : OP_MATCH];
2024 const char *sample = ((left->op_type == OP_RV2AV ||
2025 left->op_type == OP_PADAV)
2026 ? "@array" : "%hash");
2027 Perl_warner(aTHX_ WARN_MISC,
2028 "Applying %s to %s will act on scalar(%s)",
2029 desc, sample, sample);
2032 if (!(right->op_flags & OPf_STACKED) &&
2033 (right->op_type == OP_MATCH ||
2034 right->op_type == OP_SUBST ||
2035 right->op_type == OP_TRANS)) {
2036 right->op_flags |= OPf_STACKED;
2037 if (right->op_type != OP_MATCH &&
2038 ! (right->op_type == OP_TRANS &&
2039 right->op_private & OPpTRANS_IDENTICAL))
2040 left = mod(left, right->op_type);
2041 if (right->op_type == OP_TRANS)
2042 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2044 o = prepend_elem(right->op_type, scalar(left), right);
2046 return newUNOP(OP_NOT, 0, scalar(o));
2050 return bind_match(type, left,
2051 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2055 Perl_invert(pTHX_ OP *o)
2059 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2060 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2064 Perl_scope(pTHX_ OP *o)
2067 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2068 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2069 o->op_type = OP_LEAVE;
2070 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2073 if (o->op_type == OP_LINESEQ) {
2075 o->op_type = OP_SCOPE;
2076 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2077 kid = ((LISTOP*)o)->op_first;
2078 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2082 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2089 Perl_save_hints(pTHX)
2092 SAVESPTR(GvHV(PL_hintgv));
2093 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2094 SAVEFREESV(GvHV(PL_hintgv));
2098 Perl_block_start(pTHX_ int full)
2100 int retval = PL_savestack_ix;
2102 SAVEI32(PL_comppad_name_floor);
2103 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2105 PL_comppad_name_fill = PL_comppad_name_floor;
2106 if (PL_comppad_name_floor < 0)
2107 PL_comppad_name_floor = 0;
2108 SAVEI32(PL_min_intro_pending);
2109 SAVEI32(PL_max_intro_pending);
2110 PL_min_intro_pending = 0;
2111 SAVEI32(PL_comppad_name_fill);
2112 SAVEI32(PL_padix_floor);
2113 PL_padix_floor = PL_padix;
2114 PL_pad_reset_pending = FALSE;
2116 PL_hints &= ~HINT_BLOCK_SCOPE;
2117 SAVESPTR(PL_compiling.cop_warnings);
2118 if (! specialWARN(PL_compiling.cop_warnings)) {
2119 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2120 SAVEFREESV(PL_compiling.cop_warnings) ;
2122 SAVESPTR(PL_compiling.cop_io);
2123 if (! specialCopIO(PL_compiling.cop_io)) {
2124 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2125 SAVEFREESV(PL_compiling.cop_io) ;
2131 Perl_block_end(pTHX_ I32 floor, OP *seq)
2133 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2134 OP* retval = scalarseq(seq);
2136 PL_pad_reset_pending = FALSE;
2137 PL_compiling.op_private = PL_hints;
2139 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2140 pad_leavemy(PL_comppad_name_fill);
2149 OP *o = newOP(OP_THREADSV, 0);
2150 o->op_targ = find_threadsv("_");
2153 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2154 #endif /* USE_THREADS */
2158 Perl_newPROG(pTHX_ OP *o)
2163 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2164 ((PL_in_eval & EVAL_KEEPERR)
2165 ? OPf_SPECIAL : 0), o);
2166 PL_eval_start = linklist(PL_eval_root);
2167 PL_eval_root->op_private |= OPpREFCOUNTED;
2168 OpREFCNT_set(PL_eval_root, 1);
2169 PL_eval_root->op_next = 0;
2170 peep(PL_eval_start);
2175 PL_main_root = scope(sawparens(scalarvoid(o)));
2176 PL_curcop = &PL_compiling;
2177 PL_main_start = LINKLIST(PL_main_root);
2178 PL_main_root->op_private |= OPpREFCOUNTED;
2179 OpREFCNT_set(PL_main_root, 1);
2180 PL_main_root->op_next = 0;
2181 peep(PL_main_start);
2184 /* Register with debugger */
2186 CV *cv = get_cv("DB::postponed", FALSE);
2190 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2192 call_sv((SV*)cv, G_DISCARD);
2199 Perl_localize(pTHX_ OP *o, I32 lex)
2201 if (o->op_flags & OPf_PARENS)
2204 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2206 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2207 if (*s == ';' || *s == '=')
2208 Perl_warner(aTHX_ WARN_PARENTHESIS,
2209 "Parentheses missing around \"%s\" list",
2210 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2216 o = mod(o, OP_NULL); /* a bit kludgey */
2218 PL_in_my_stash = Nullhv;
2223 Perl_jmaybe(pTHX_ OP *o)
2225 if (o->op_type == OP_LIST) {
2228 o2 = newOP(OP_THREADSV, 0);
2229 o2->op_targ = find_threadsv(";");
2231 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2232 #endif /* USE_THREADS */
2233 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2239 Perl_fold_constants(pTHX_ register OP *o)
2242 I32 type = o->op_type;
2245 if (PL_opargs[type] & OA_RETSCALAR)
2247 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2248 o->op_targ = pad_alloc(type, SVs_PADTMP);
2250 /* integerize op, unless it happens to be C<-foo>.
2251 * XXX should pp_i_negate() do magic string negation instead? */
2252 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2253 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2254 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2256 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2259 if (!(PL_opargs[type] & OA_FOLDCONST))
2264 /* XXX might want a ck_negate() for this */
2265 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2277 /* XXX what about the numeric ops? */
2278 if (PL_hints & HINT_LOCALE)
2283 goto nope; /* Don't try to run w/ errors */
2285 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2286 if ((curop->op_type != OP_CONST ||
2287 (curop->op_private & OPpCONST_BARE)) &&
2288 curop->op_type != OP_LIST &&
2289 curop->op_type != OP_SCALAR &&
2290 curop->op_type != OP_NULL &&
2291 curop->op_type != OP_PUSHMARK)
2297 curop = LINKLIST(o);
2301 sv = *(PL_stack_sp--);
2302 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2303 pad_swipe(o->op_targ);
2304 else if (SvTEMP(sv)) { /* grab mortal temp? */
2305 (void)SvREFCNT_inc(sv);
2309 if (type == OP_RV2GV)
2310 return newGVOP(OP_GV, 0, (GV*)sv);
2312 /* try to smush double to int, but don't smush -2.0 to -2 */
2313 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2316 #ifdef PERL_PRESERVE_IVUV
2317 /* Only bother to attempt to fold to IV if
2318 most operators will benefit */
2322 return newSVOP(OP_CONST, 0, sv);
2326 if (!(PL_opargs[type] & OA_OTHERINT))
2329 if (!(PL_hints & HINT_INTEGER)) {
2330 if (type == OP_MODULO
2331 || type == OP_DIVIDE
2332 || !(o->op_flags & OPf_KIDS))
2337 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2338 if (curop->op_type == OP_CONST) {
2339 if (SvIOK(((SVOP*)curop)->op_sv))
2343 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2347 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2354 Perl_gen_constant_list(pTHX_ register OP *o)
2357 I32 oldtmps_floor = PL_tmps_floor;
2361 return o; /* Don't attempt to run with errors */
2363 PL_op = curop = LINKLIST(o);
2370 PL_tmps_floor = oldtmps_floor;
2372 o->op_type = OP_RV2AV;
2373 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2374 curop = ((UNOP*)o)->op_first;
2375 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2382 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2384 if (!o || o->op_type != OP_LIST)
2385 o = newLISTOP(OP_LIST, 0, o, Nullop);
2387 o->op_flags &= ~OPf_WANT;
2389 if (!(PL_opargs[type] & OA_MARK))
2390 op_null(cLISTOPo->op_first);
2393 o->op_ppaddr = PL_ppaddr[type];
2394 o->op_flags |= flags;
2396 o = CHECKOP(type, o);
2397 if (o->op_type != type)
2400 return fold_constants(o);
2403 /* List constructors */
2406 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2414 if (first->op_type != type
2415 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2417 return newLISTOP(type, 0, first, last);
2420 if (first->op_flags & OPf_KIDS)
2421 ((LISTOP*)first)->op_last->op_sibling = last;
2423 first->op_flags |= OPf_KIDS;
2424 ((LISTOP*)first)->op_first = last;
2426 ((LISTOP*)first)->op_last = last;
2431 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2439 if (first->op_type != type)
2440 return prepend_elem(type, (OP*)first, (OP*)last);
2442 if (last->op_type != type)
2443 return append_elem(type, (OP*)first, (OP*)last);
2445 first->op_last->op_sibling = last->op_first;
2446 first->op_last = last->op_last;
2447 first->op_flags |= (last->op_flags & OPf_KIDS);
2449 #ifdef PL_OP_SLAB_ALLOC
2457 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2465 if (last->op_type == type) {
2466 if (type == OP_LIST) { /* already a PUSHMARK there */
2467 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2468 ((LISTOP*)last)->op_first->op_sibling = first;
2469 if (!(first->op_flags & OPf_PARENS))
2470 last->op_flags &= ~OPf_PARENS;
2473 if (!(last->op_flags & OPf_KIDS)) {
2474 ((LISTOP*)last)->op_last = first;
2475 last->op_flags |= OPf_KIDS;
2477 first->op_sibling = ((LISTOP*)last)->op_first;
2478 ((LISTOP*)last)->op_first = first;
2480 last->op_flags |= OPf_KIDS;
2484 return newLISTOP(type, 0, first, last);
2490 Perl_newNULLLIST(pTHX)
2492 return newOP(OP_STUB, 0);
2496 Perl_force_list(pTHX_ OP *o)
2498 if (!o || o->op_type != OP_LIST)
2499 o = newLISTOP(OP_LIST, 0, o, Nullop);
2505 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2509 NewOp(1101, listop, 1, LISTOP);
2511 listop->op_type = type;
2512 listop->op_ppaddr = PL_ppaddr[type];
2515 listop->op_flags = flags;
2519 else if (!first && last)
2522 first->op_sibling = last;
2523 listop->op_first = first;
2524 listop->op_last = last;
2525 if (type == OP_LIST) {
2527 pushop = newOP(OP_PUSHMARK, 0);
2528 pushop->op_sibling = first;
2529 listop->op_first = pushop;
2530 listop->op_flags |= OPf_KIDS;
2532 listop->op_last = pushop;
2539 Perl_newOP(pTHX_ I32 type, I32 flags)
2542 NewOp(1101, o, 1, OP);
2544 o->op_ppaddr = PL_ppaddr[type];
2545 o->op_flags = flags;
2548 o->op_private = 0 + (flags >> 8);
2549 if (PL_opargs[type] & OA_RETSCALAR)
2551 if (PL_opargs[type] & OA_TARGET)
2552 o->op_targ = pad_alloc(type, SVs_PADTMP);
2553 return CHECKOP(type, o);
2557 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2562 first = newOP(OP_STUB, 0);
2563 if (PL_opargs[type] & OA_MARK)
2564 first = force_list(first);
2566 NewOp(1101, unop, 1, UNOP);
2567 unop->op_type = type;
2568 unop->op_ppaddr = PL_ppaddr[type];
2569 unop->op_first = first;
2570 unop->op_flags = flags | OPf_KIDS;
2571 unop->op_private = 1 | (flags >> 8);
2572 unop = (UNOP*) CHECKOP(type, unop);
2576 return fold_constants((OP *) unop);
2580 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2583 NewOp(1101, binop, 1, BINOP);
2586 first = newOP(OP_NULL, 0);
2588 binop->op_type = type;
2589 binop->op_ppaddr = PL_ppaddr[type];
2590 binop->op_first = first;
2591 binop->op_flags = flags | OPf_KIDS;
2594 binop->op_private = 1 | (flags >> 8);
2597 binop->op_private = 2 | (flags >> 8);
2598 first->op_sibling = last;
2601 binop = (BINOP*)CHECKOP(type, binop);
2602 if (binop->op_next || binop->op_type != type)
2605 binop->op_last = binop->op_first->op_sibling;
2607 return fold_constants((OP *)binop);
2611 uvcompare(const void *a, const void *b)
2613 if (*((UV *)a) < (*(UV *)b))
2615 if (*((UV *)a) > (*(UV *)b))
2617 if (*((UV *)a+1) < (*(UV *)b+1))
2619 if (*((UV *)a+1) > (*(UV *)b+1))
2625 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2627 SV *tstr = ((SVOP*)expr)->op_sv;
2628 SV *rstr = ((SVOP*)repl)->op_sv;
2631 U8 *t = (U8*)SvPV(tstr, tlen);
2632 U8 *r = (U8*)SvPV(rstr, rlen);
2639 register short *tbl;
2641 PL_hints |= HINT_BLOCK_SCOPE;
2642 complement = o->op_private & OPpTRANS_COMPLEMENT;
2643 del = o->op_private & OPpTRANS_DELETE;
2644 squash = o->op_private & OPpTRANS_SQUASH;
2647 o->op_private |= OPpTRANS_FROM_UTF;
2650 o->op_private |= OPpTRANS_TO_UTF;
2652 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2653 SV* listsv = newSVpvn("# comment\n",10);
2655 U8* tend = t + tlen;
2656 U8* rend = r + rlen;
2670 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2671 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2677 tsave = t = bytes_to_utf8(t, &len);
2680 if (!to_utf && rlen) {
2682 rsave = r = bytes_to_utf8(r, &len);
2686 /* There are several snags with this code on EBCDIC:
2687 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2688 2. scan_const() in toke.c has encoded chars in native encoding which makes
2689 ranges at least in EBCDIC 0..255 range the bottom odd.
2693 U8 tmpbuf[UTF8_MAXLEN+1];
2696 New(1109, cp, 2*tlen, UV);
2698 transv = newSVpvn("",0);
2700 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2702 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2704 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2708 cp[2*i+1] = cp[2*i];
2712 qsort(cp, i, 2*sizeof(UV), uvcompare);
2713 for (j = 0; j < i; j++) {
2715 diff = val - nextmin;
2717 t = uvuni_to_utf8(tmpbuf,nextmin);
2718 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2720 U8 range_mark = UTF_TO_NATIVE(0xff);
2721 t = uvuni_to_utf8(tmpbuf, val - 1);
2722 sv_catpvn(transv, (char *)&range_mark, 1);
2723 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2730 t = uvuni_to_utf8(tmpbuf,nextmin);
2731 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2733 U8 range_mark = UTF_TO_NATIVE(0xff);
2734 sv_catpvn(transv, (char *)&range_mark, 1);
2736 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2737 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2738 t = (U8*)SvPVX(transv);
2739 tlen = SvCUR(transv);
2743 else if (!rlen && !del) {
2744 r = t; rlen = tlen; rend = tend;
2747 if ((!rlen && !del) || t == r ||
2748 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2750 o->op_private |= OPpTRANS_IDENTICAL;
2754 while (t < tend || tfirst <= tlast) {
2755 /* see if we need more "t" chars */
2756 if (tfirst > tlast) {
2757 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2759 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2761 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2768 /* now see if we need more "r" chars */
2769 if (rfirst > rlast) {
2771 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2773 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2775 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2784 rfirst = rlast = 0xffffffff;
2788 /* now see which range will peter our first, if either. */
2789 tdiff = tlast - tfirst;
2790 rdiff = rlast - rfirst;
2797 if (rfirst == 0xffffffff) {
2798 diff = tdiff; /* oops, pretend rdiff is infinite */
2800 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2801 (long)tfirst, (long)tlast);
2803 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2807 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2808 (long)tfirst, (long)(tfirst + diff),
2811 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2812 (long)tfirst, (long)rfirst);
2814 if (rfirst + diff > max)
2815 max = rfirst + diff;
2817 grows = (tfirst < rfirst &&
2818 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2830 else if (max > 0xff)
2835 Safefree(cPVOPo->op_pv);
2836 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2837 SvREFCNT_dec(listsv);
2839 SvREFCNT_dec(transv);
2841 if (!del && havefinal && rlen)
2842 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2843 newSVuv((UV)final), 0);
2846 o->op_private |= OPpTRANS_GROWS;
2858 tbl = (short*)cPVOPo->op_pv;
2860 Zero(tbl, 256, short);
2861 for (i = 0; i < tlen; i++)
2863 for (i = 0, j = 0; i < 256; i++) {
2874 if (i < 128 && r[j] >= 128)
2884 o->op_private |= OPpTRANS_IDENTICAL;
2889 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2890 tbl[0x100] = rlen - j;
2891 for (i=0; i < rlen - j; i++)
2892 tbl[0x101+i] = r[j+i];
2896 if (!rlen && !del) {
2899 o->op_private |= OPpTRANS_IDENTICAL;
2901 for (i = 0; i < 256; i++)
2903 for (i = 0, j = 0; i < tlen; i++,j++) {
2906 if (tbl[t[i]] == -1)
2912 if (tbl[t[i]] == -1) {
2913 if (t[i] < 128 && r[j] >= 128)
2920 o->op_private |= OPpTRANS_GROWS;
2928 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2932 NewOp(1101, pmop, 1, PMOP);
2933 pmop->op_type = type;
2934 pmop->op_ppaddr = PL_ppaddr[type];
2935 pmop->op_flags = flags;
2936 pmop->op_private = 0 | (flags >> 8);
2938 if (PL_hints & HINT_RE_TAINT)
2939 pmop->op_pmpermflags |= PMf_RETAINT;
2940 if (PL_hints & HINT_LOCALE)
2941 pmop->op_pmpermflags |= PMf_LOCALE;
2942 pmop->op_pmflags = pmop->op_pmpermflags;
2944 /* link into pm list */
2945 if (type != OP_TRANS && PL_curstash) {
2946 pmop->op_pmnext = HvPMROOT(PL_curstash);
2947 HvPMROOT(PL_curstash) = pmop;
2948 PmopSTASH_set(pmop,PL_curstash);
2955 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2959 I32 repl_has_vars = 0;
2961 if (o->op_type == OP_TRANS)
2962 return pmtrans(o, expr, repl);
2964 PL_hints |= HINT_BLOCK_SCOPE;
2967 if (expr->op_type == OP_CONST) {
2969 SV *pat = ((SVOP*)expr)->op_sv;
2970 char *p = SvPV(pat, plen);
2971 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2972 sv_setpvn(pat, "\\s+", 3);
2973 p = SvPV(pat, plen);
2974 pm->op_pmflags |= PMf_SKIPWHITE;
2976 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2977 pm->op_pmdynflags |= PMdf_UTF8;
2978 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2979 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2980 pm->op_pmflags |= PMf_WHITE;
2984 if (PL_hints & HINT_UTF8)
2985 pm->op_pmdynflags |= PMdf_UTF8;
2986 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2987 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2989 : OP_REGCMAYBE),0,expr);
2991 NewOp(1101, rcop, 1, LOGOP);
2992 rcop->op_type = OP_REGCOMP;
2993 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2994 rcop->op_first = scalar(expr);
2995 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2996 ? (OPf_SPECIAL | OPf_KIDS)
2998 rcop->op_private = 1;
3001 /* establish postfix order */
3002 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3004 rcop->op_next = expr;
3005 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3008 rcop->op_next = LINKLIST(expr);
3009 expr->op_next = (OP*)rcop;
3012 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3017 if (pm->op_pmflags & PMf_EVAL) {
3019 if (CopLINE(PL_curcop) < PL_multi_end)
3020 CopLINE_set(PL_curcop, PL_multi_end);
3023 else if (repl->op_type == OP_THREADSV
3024 && strchr("&`'123456789+",
3025 PL_threadsv_names[repl->op_targ]))
3029 #endif /* USE_THREADS */
3030 else if (repl->op_type == OP_CONST)
3034 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3035 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3037 if (curop->op_type == OP_THREADSV) {
3039 if (strchr("&`'123456789+", curop->op_private))
3043 if (curop->op_type == OP_GV) {
3044 GV *gv = cGVOPx_gv(curop);
3046 if (strchr("&`'123456789+", *GvENAME(gv)))
3049 #endif /* USE_THREADS */
3050 else if (curop->op_type == OP_RV2CV)
3052 else if (curop->op_type == OP_RV2SV ||
3053 curop->op_type == OP_RV2AV ||
3054 curop->op_type == OP_RV2HV ||
3055 curop->op_type == OP_RV2GV) {
3056 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3059 else if (curop->op_type == OP_PADSV ||
3060 curop->op_type == OP_PADAV ||
3061 curop->op_type == OP_PADHV ||
3062 curop->op_type == OP_PADANY) {
3065 else if (curop->op_type == OP_PUSHRE)
3066 ; /* Okay here, dangerous in newASSIGNOP */
3075 && (!pm->op_pmregexp
3076 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3077 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3078 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3079 prepend_elem(o->op_type, scalar(repl), o);
3082 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3083 pm->op_pmflags |= PMf_MAYBE_CONST;
3084 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3086 NewOp(1101, rcop, 1, LOGOP);
3087 rcop->op_type = OP_SUBSTCONT;
3088 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3089 rcop->op_first = scalar(repl);
3090 rcop->op_flags |= OPf_KIDS;
3091 rcop->op_private = 1;
3094 /* establish postfix order */
3095 rcop->op_next = LINKLIST(repl);
3096 repl->op_next = (OP*)rcop;
3098 pm->op_pmreplroot = scalar((OP*)rcop);
3099 pm->op_pmreplstart = LINKLIST(rcop);
3108 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3111 NewOp(1101, svop, 1, SVOP);
3112 svop->op_type = type;
3113 svop->op_ppaddr = PL_ppaddr[type];
3115 svop->op_next = (OP*)svop;
3116 svop->op_flags = flags;
3117 if (PL_opargs[type] & OA_RETSCALAR)
3119 if (PL_opargs[type] & OA_TARGET)
3120 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3121 return CHECKOP(type, svop);
3125 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3128 NewOp(1101, padop, 1, PADOP);
3129 padop->op_type = type;
3130 padop->op_ppaddr = PL_ppaddr[type];
3131 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3132 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3133 PL_curpad[padop->op_padix] = sv;
3135 padop->op_next = (OP*)padop;
3136 padop->op_flags = flags;
3137 if (PL_opargs[type] & OA_RETSCALAR)
3139 if (PL_opargs[type] & OA_TARGET)
3140 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3141 return CHECKOP(type, padop);
3145 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3149 return newPADOP(type, flags, SvREFCNT_inc(gv));
3151 return newSVOP(type, flags, SvREFCNT_inc(gv));
3156 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3159 NewOp(1101, pvop, 1, PVOP);
3160 pvop->op_type = type;
3161 pvop->op_ppaddr = PL_ppaddr[type];
3163 pvop->op_next = (OP*)pvop;
3164 pvop->op_flags = flags;
3165 if (PL_opargs[type] & OA_RETSCALAR)
3167 if (PL_opargs[type] & OA_TARGET)
3168 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3169 return CHECKOP(type, pvop);
3173 Perl_package(pTHX_ OP *o)
3177 save_hptr(&PL_curstash);
3178 save_item(PL_curstname);
3183 name = SvPV(sv, len);
3184 PL_curstash = gv_stashpvn(name,len,TRUE);
3185 sv_setpvn(PL_curstname, name, len);
3189 sv_setpv(PL_curstname,"<none>");
3190 PL_curstash = Nullhv;
3192 PL_hints |= HINT_BLOCK_SCOPE;
3193 PL_copline = NOLINE;
3198 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3204 if (id->op_type != OP_CONST)
3205 Perl_croak(aTHX_ "Module name must be constant");
3209 if (version != Nullop) {
3210 SV *vesv = ((SVOP*)version)->op_sv;
3212 if (arg == Nullop && !SvNIOKp(vesv)) {
3219 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3220 Perl_croak(aTHX_ "Version number must be constant number");
3222 /* Make copy of id so we don't free it twice */
3223 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3225 /* Fake up a method call to VERSION */
3226 meth = newSVpvn("VERSION",7);
3227 sv_upgrade(meth, SVt_PVIV);
3228 (void)SvIOK_on(meth);
3229 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3230 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3231 append_elem(OP_LIST,
3232 prepend_elem(OP_LIST, pack, list(version)),
3233 newSVOP(OP_METHOD_NAMED, 0, meth)));
3237 /* Fake up an import/unimport */
3238 if (arg && arg->op_type == OP_STUB)
3239 imop = arg; /* no import on explicit () */
3240 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3241 imop = Nullop; /* use 5.0; */
3246 /* Make copy of id so we don't free it twice */
3247 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3249 /* Fake up a method call to import/unimport */
3250 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3251 sv_upgrade(meth, SVt_PVIV);
3252 (void)SvIOK_on(meth);
3253 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3254 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3255 append_elem(OP_LIST,
3256 prepend_elem(OP_LIST, pack, list(arg)),
3257 newSVOP(OP_METHOD_NAMED, 0, meth)));
3260 /* Fake up the BEGIN {}, which does its thing immediately. */
3262 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3265 append_elem(OP_LINESEQ,
3266 append_elem(OP_LINESEQ,
3267 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3268 newSTATEOP(0, Nullch, veop)),
3269 newSTATEOP(0, Nullch, imop) ));
3271 PL_hints |= HINT_BLOCK_SCOPE;
3272 PL_copline = NOLINE;
3277 =for apidoc load_module
3279 Loads the module whose name is pointed to by the string part of name.
3280 Note that the actual module name, not its filename, should be given.
3281 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3282 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3283 (or 0 for no flags). ver, if specified, provides version semantics
3284 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3285 arguments can be used to specify arguments to the module's import()
3286 method, similar to C<use Foo::Bar VERSION LIST>.
3291 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3294 va_start(args, ver);
3295 vload_module(flags, name, ver, &args);
3299 #ifdef PERL_IMPLICIT_CONTEXT
3301 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3305 va_start(args, ver);
3306 vload_module(flags, name, ver, &args);
3312 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3314 OP *modname, *veop, *imop;
3316 modname = newSVOP(OP_CONST, 0, name);
3317 modname->op_private |= OPpCONST_BARE;
3319 veop = newSVOP(OP_CONST, 0, ver);
3323 if (flags & PERL_LOADMOD_NOIMPORT) {
3324 imop = sawparens(newNULLLIST());
3326 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3327 imop = va_arg(*args, OP*);
3332 sv = va_arg(*args, SV*);
3334 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3335 sv = va_arg(*args, SV*);
3339 line_t ocopline = PL_copline;
3340 int oexpect = PL_expect;
3342 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3343 veop, modname, imop);
3344 PL_expect = oexpect;
3345 PL_copline = ocopline;
3350 Perl_dofile(pTHX_ OP *term)
3355 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3356 if (!(gv && GvIMPORTED_CV(gv)))
3357 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3359 if (gv && GvIMPORTED_CV(gv)) {
3360 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3361 append_elem(OP_LIST, term,
3362 scalar(newUNOP(OP_RV2CV, 0,
3367 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3373 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3375 return newBINOP(OP_LSLICE, flags,
3376 list(force_list(subscript)),
3377 list(force_list(listval)) );
3381 S_list_assignment(pTHX_ register OP *o)
3386 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3387 o = cUNOPo->op_first;
3389 if (o->op_type == OP_COND_EXPR) {
3390 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3391 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3396 yyerror("Assignment to both a list and a scalar");
3400 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3401 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3402 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3405 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3408 if (o->op_type == OP_RV2SV)
3415 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3420 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3421 return newLOGOP(optype, 0,
3422 mod(scalar(left), optype),
3423 newUNOP(OP_SASSIGN, 0, scalar(right)));
3426 return newBINOP(optype, OPf_STACKED,
3427 mod(scalar(left), optype), scalar(right));
3431 if (list_assignment(left)) {
3435 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3436 left = mod(left, OP_AASSIGN);
3444 curop = list(force_list(left));
3445 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3446 o->op_private = 0 | (flags >> 8);
3447 for (curop = ((LISTOP*)curop)->op_first;
3448 curop; curop = curop->op_sibling)
3450 if (curop->op_type == OP_RV2HV &&
3451 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3452 o->op_private |= OPpASSIGN_HASH;
3456 if (!(left->op_private & OPpLVAL_INTRO)) {
3459 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3460 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3461 if (curop->op_type == OP_GV) {
3462 GV *gv = cGVOPx_gv(curop);
3463 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3465 SvCUR(gv) = PL_generation;
3467 else if (curop->op_type == OP_PADSV ||
3468 curop->op_type == OP_PADAV ||
3469 curop->op_type == OP_PADHV ||
3470 curop->op_type == OP_PADANY) {
3471 SV **svp = AvARRAY(PL_comppad_name);
3472 SV *sv = svp[curop->op_targ];
3473 if (SvCUR(sv) == PL_generation)
3475 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3477 else if (curop->op_type == OP_RV2CV)
3479 else if (curop->op_type == OP_RV2SV ||
3480 curop->op_type == OP_RV2AV ||
3481 curop->op_type == OP_RV2HV ||
3482 curop->op_type == OP_RV2GV) {
3483 if (lastop->op_type != OP_GV) /* funny deref? */
3486 else if (curop->op_type == OP_PUSHRE) {
3487 if (((PMOP*)curop)->op_pmreplroot) {
3489 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3491 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3493 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3495 SvCUR(gv) = PL_generation;
3504 o->op_private |= OPpASSIGN_COMMON;
3506 if (right && right->op_type == OP_SPLIT) {
3508 if ((tmpop = ((LISTOP*)right)->op_first) &&
3509 tmpop->op_type == OP_PUSHRE)
3511 PMOP *pm = (PMOP*)tmpop;
3512 if (left->op_type == OP_RV2AV &&
3513 !(left->op_private & OPpLVAL_INTRO) &&
3514 !(o->op_private & OPpASSIGN_COMMON) )
3516 tmpop = ((UNOP*)left)->op_first;
3517 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3519 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3520 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3522 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3523 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3525 pm->op_pmflags |= PMf_ONCE;
3526 tmpop = cUNOPo->op_first; /* to list (nulled) */
3527 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3528 tmpop->op_sibling = Nullop; /* don't free split */
3529 right->op_next = tmpop->op_next; /* fix starting loc */
3530 op_free(o); /* blow off assign */
3531 right->op_flags &= ~OPf_WANT;
3532 /* "I don't know and I don't care." */
3537 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3538 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3540 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3542 sv_setiv(sv, PL_modcount+1);
3550 right = newOP(OP_UNDEF, 0);
3551 if (right->op_type == OP_READLINE) {
3552 right->op_flags |= OPf_STACKED;
3553 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3556 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3557 o = newBINOP(OP_SASSIGN, flags,
3558 scalar(right), mod(scalar(left), OP_SASSIGN) );
3570 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3572 U32 seq = intro_my();
3575 NewOp(1101, cop, 1, COP);
3576 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3577 cop->op_type = OP_DBSTATE;
3578 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3581 cop->op_type = OP_NEXTSTATE;
3582 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3584 cop->op_flags = flags;
3585 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3587 cop->op_private |= NATIVE_HINTS;
3589 PL_compiling.op_private = cop->op_private;
3590 cop->op_next = (OP*)cop;
3593 cop->cop_label = label;
3594 PL_hints |= HINT_BLOCK_SCOPE;
3597 cop->cop_arybase = PL_curcop->cop_arybase;
3598 if (specialWARN(PL_curcop->cop_warnings))
3599 cop->cop_warnings = PL_curcop->cop_warnings ;
3601 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3602 if (specialCopIO(PL_curcop->cop_io))
3603 cop->cop_io = PL_curcop->cop_io;
3605 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3608 if (PL_copline == NOLINE)
3609 CopLINE_set(cop, CopLINE(PL_curcop));
3611 CopLINE_set(cop, PL_copline);
3612 PL_copline = NOLINE;
3615 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3617 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3619 CopSTASH_set(cop, PL_curstash);
3621 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3622 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3623 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3624 (void)SvIOK_on(*svp);
3625 SvIVX(*svp) = PTR2IV(cop);
3629 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3632 /* "Introduce" my variables to visible status. */
3640 if (! PL_min_intro_pending)
3641 return PL_cop_seqmax;
3643 svp = AvARRAY(PL_comppad_name);
3644 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3645 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3646 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3647 SvNVX(sv) = (NV)PL_cop_seqmax;
3650 PL_min_intro_pending = 0;
3651 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3652 return PL_cop_seqmax++;
3656 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3658 return new_logop(type, flags, &first, &other);
3662 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3666 OP *first = *firstp;
3667 OP *other = *otherp;
3669 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3670 return newBINOP(type, flags, scalar(first), scalar(other));
3672 scalarboolean(first);
3673 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3674 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3675 if (type == OP_AND || type == OP_OR) {
3681 first = *firstp = cUNOPo->op_first;
3683 first->op_next = o->op_next;
3684 cUNOPo->op_first = Nullop;
3688 if (first->op_type == OP_CONST) {
3689 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3690 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3691 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3702 else if (first->op_type == OP_WANTARRAY) {
3708 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3709 OP *k1 = ((UNOP*)first)->op_first;
3710 OP *k2 = k1->op_sibling;
3712 switch (first->op_type)
3715 if (k2 && k2->op_type == OP_READLINE
3716 && (k2->op_flags & OPf_STACKED)
3717 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3719 warnop = k2->op_type;
3724 if (k1->op_type == OP_READDIR
3725 || k1->op_type == OP_GLOB
3726 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3727 || k1->op_type == OP_EACH)
3729 warnop = ((k1->op_type == OP_NULL)
3730 ? k1->op_targ : k1->op_type);
3735 line_t oldline = CopLINE(PL_curcop);
3736 CopLINE_set(PL_curcop, PL_copline);
3737 Perl_warner(aTHX_ WARN_MISC,
3738 "Value of %s%s can be \"0\"; test with defined()",
3740 ((warnop == OP_READLINE || warnop == OP_GLOB)
3741 ? " construct" : "() operator"));
3742 CopLINE_set(PL_curcop, oldline);
3749 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3750 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3752 NewOp(1101, logop, 1, LOGOP);
3754 logop->op_type = type;
3755 logop->op_ppaddr = PL_ppaddr[type];
3756 logop->op_first = first;
3757 logop->op_flags = flags | OPf_KIDS;
3758 logop->op_other = LINKLIST(other);
3759 logop->op_private = 1 | (flags >> 8);
3761 /* establish postfix order */
3762 logop->op_next = LINKLIST(first);
3763 first->op_next = (OP*)logop;
3764 first->op_sibling = other;
3766 o = newUNOP(OP_NULL, 0, (OP*)logop);
3773 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3780 return newLOGOP(OP_AND, 0, first, trueop);
3782 return newLOGOP(OP_OR, 0, first, falseop);
3784 scalarboolean(first);
3785 if (first->op_type == OP_CONST) {
3786 if (SvTRUE(((SVOP*)first)->op_sv)) {
3797 else if (first->op_type == OP_WANTARRAY) {
3801 NewOp(1101, logop, 1, LOGOP);
3802 logop->op_type = OP_COND_EXPR;
3803 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3804 logop->op_first = first;
3805 logop->op_flags = flags | OPf_KIDS;
3806 logop->op_private = 1 | (flags >> 8);
3807 logop->op_other = LINKLIST(trueop);
3808 logop->op_next = LINKLIST(falseop);
3811 /* establish postfix order */
3812 start = LINKLIST(first);
3813 first->op_next = (OP*)logop;
3815 first->op_sibling = trueop;
3816 trueop->op_sibling = falseop;
3817 o = newUNOP(OP_NULL, 0, (OP*)logop);
3819 trueop->op_next = falseop->op_next = o;
3826 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3834 NewOp(1101, range, 1, LOGOP);
3836 range->op_type = OP_RANGE;
3837 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3838 range->op_first = left;
3839 range->op_flags = OPf_KIDS;
3840 leftstart = LINKLIST(left);
3841 range->op_other = LINKLIST(right);
3842 range->op_private = 1 | (flags >> 8);
3844 left->op_sibling = right;
3846 range->op_next = (OP*)range;
3847 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3848 flop = newUNOP(OP_FLOP, 0, flip);
3849 o = newUNOP(OP_NULL, 0, flop);
3851 range->op_next = leftstart;
3853 left->op_next = flip;
3854 right->op_next = flop;
3856 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3857 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3858 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3859 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3861 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3862 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3865 if (!flip->op_private || !flop->op_private)
3866 linklist(o); /* blow off optimizer unless constant */
3872 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3876 int once = block && block->op_flags & OPf_SPECIAL &&
3877 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3880 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3881 return block; /* do {} while 0 does once */
3882 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3883 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3884 expr = newUNOP(OP_DEFINED, 0,
3885 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3886 } else if (expr->op_flags & OPf_KIDS) {
3887 OP *k1 = ((UNOP*)expr)->op_first;
3888 OP *k2 = (k1) ? k1->op_sibling : NULL;
3889 switch (expr->op_type) {
3891 if (k2 && k2->op_type == OP_READLINE
3892 && (k2->op_flags & OPf_STACKED)
3893 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3894 expr = newUNOP(OP_DEFINED, 0, expr);
3898 if (k1->op_type == OP_READDIR
3899 || k1->op_type == OP_GLOB
3900 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3901 || k1->op_type == OP_EACH)
3902 expr = newUNOP(OP_DEFINED, 0, expr);
3908 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3909 o = new_logop(OP_AND, 0, &expr, &listop);
3912 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3914 if (once && o != listop)
3915 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3918 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3920 o->op_flags |= flags;
3922 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3927 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3936 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3937 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3938 expr = newUNOP(OP_DEFINED, 0,
3939 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3940 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3941 OP *k1 = ((UNOP*)expr)->op_first;
3942 OP *k2 = (k1) ? k1->op_sibling : NULL;
3943 switch (expr->op_type) {
3945 if (k2 && k2->op_type == OP_READLINE
3946 && (k2->op_flags & OPf_STACKED)
3947 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3948 expr = newUNOP(OP_DEFINED, 0, expr);
3952 if (k1->op_type == OP_READDIR
3953 || k1->op_type == OP_GLOB
3954 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3955 || k1->op_type == OP_EACH)
3956 expr = newUNOP(OP_DEFINED, 0, expr);
3962 block = newOP(OP_NULL, 0);
3964 block = scope(block);
3968 next = LINKLIST(cont);
3971 OP *unstack = newOP(OP_UNSTACK, 0);
3974 cont = append_elem(OP_LINESEQ, cont, unstack);
3975 if ((line_t)whileline != NOLINE) {
3976 PL_copline = whileline;
3977 cont = append_elem(OP_LINESEQ, cont,
3978 newSTATEOP(0, Nullch, Nullop));
3982 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3983 redo = LINKLIST(listop);
3986 PL_copline = whileline;
3988 o = new_logop(OP_AND, 0, &expr, &listop);
3989 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3990 op_free(expr); /* oops, it's a while (0) */
3992 return Nullop; /* listop already freed by new_logop */
3995 ((LISTOP*)listop)->op_last->op_next = condop =
3996 (o == listop ? redo : LINKLIST(o));
4002 NewOp(1101,loop,1,LOOP);
4003 loop->op_type = OP_ENTERLOOP;
4004 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4005 loop->op_private = 0;
4006 loop->op_next = (OP*)loop;
4009 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4011 loop->op_redoop = redo;
4012 loop->op_lastop = o;
4013 o->op_private |= loopflags;
4016 loop->op_nextop = next;
4018 loop->op_nextop = o;
4020 o->op_flags |= flags;
4021 o->op_private |= (flags >> 8);
4026 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4034 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4035 sv->op_type = OP_RV2GV;
4036 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4038 else if (sv->op_type == OP_PADSV) { /* private variable */
4039 padoff = sv->op_targ;
4044 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4045 padoff = sv->op_targ;
4047 iterflags |= OPf_SPECIAL;
4052 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4056 padoff = find_threadsv("_");
4057 iterflags |= OPf_SPECIAL;
4059 sv = newGVOP(OP_GV, 0, PL_defgv);
4062 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4063 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4064 iterflags |= OPf_STACKED;
4066 else if (expr->op_type == OP_NULL &&
4067 (expr->op_flags & OPf_KIDS) &&
4068 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4070 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4071 * set the STACKED flag to indicate that these values are to be
4072 * treated as min/max values by 'pp_iterinit'.
4074 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4075 LOGOP* range = (LOGOP*) flip->op_first;
4076 OP* left = range->op_first;
4077 OP* right = left->op_sibling;
4080 range->op_flags &= ~OPf_KIDS;
4081 range->op_first = Nullop;
4083 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4084 listop->op_first->op_next = range->op_next;
4085 left->op_next = range->op_other;
4086 right->op_next = (OP*)listop;
4087 listop->op_next = listop->op_first;
4090 expr = (OP*)(listop);
4092 iterflags |= OPf_STACKED;
4095 expr = mod(force_list(expr), OP_GREPSTART);
4099 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4100 append_elem(OP_LIST, expr, scalar(sv))));
4101 assert(!loop->op_next);
4102 #ifdef PL_OP_SLAB_ALLOC
4105 NewOp(1234,tmp,1,LOOP);
4106 Copy(loop,tmp,1,LOOP);
4110 Renew(loop, 1, LOOP);
4112 loop->op_targ = padoff;
4113 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4114 PL_copline = forline;
4115 return newSTATEOP(0, label, wop);
4119 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4124 if (type != OP_GOTO || label->op_type == OP_CONST) {
4125 /* "last()" means "last" */
4126 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4127 o = newOP(type, OPf_SPECIAL);
4129 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4130 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4136 if (label->op_type == OP_ENTERSUB)
4137 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4138 o = newUNOP(type, OPf_STACKED, label);
4140 PL_hints |= HINT_BLOCK_SCOPE;
4145 Perl_cv_undef(pTHX_ CV *cv)
4149 MUTEX_DESTROY(CvMUTEXP(cv));
4150 Safefree(CvMUTEXP(cv));
4153 #endif /* USE_THREADS */
4155 if (!CvXSUB(cv) && CvROOT(cv)) {
4157 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4158 Perl_croak(aTHX_ "Can't undef active subroutine");
4161 Perl_croak(aTHX_ "Can't undef active subroutine");
4162 #endif /* USE_THREADS */
4165 SAVEVPTR(PL_curpad);
4168 op_free(CvROOT(cv));
4169 CvROOT(cv) = Nullop;
4172 SvPOK_off((SV*)cv); /* forget prototype */
4174 /* Since closure prototypes have the same lifetime as the containing
4175 * CV, they don't hold a refcount on the outside CV. This avoids
4176 * the refcount loop between the outer CV (which keeps a refcount to
4177 * the closure prototype in the pad entry for pp_anoncode()) and the
4178 * closure prototype, and the ensuing memory leak. This does not
4179 * apply to closures generated within eval"", since eval"" CVs are
4180 * ephemeral. --GSAR */
4181 if (!CvANON(cv) || CvCLONED(cv)
4182 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4183 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4185 SvREFCNT_dec(CvOUTSIDE(cv));
4187 CvOUTSIDE(cv) = Nullcv;
4189 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4192 if (CvPADLIST(cv)) {
4193 /* may be during global destruction */
4194 if (SvREFCNT(CvPADLIST(cv))) {
4195 I32 i = AvFILLp(CvPADLIST(cv));
4197 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4198 SV* sv = svp ? *svp : Nullsv;
4201 if (sv == (SV*)PL_comppad_name)
4202 PL_comppad_name = Nullav;
4203 else if (sv == (SV*)PL_comppad) {
4204 PL_comppad = Nullav;
4205 PL_curpad = Null(SV**);
4209 SvREFCNT_dec((SV*)CvPADLIST(cv));
4211 CvPADLIST(cv) = Nullav;
4219 #ifdef DEBUG_CLOSURES
4221 S_cv_dump(pTHX_ CV *cv)
4224 CV *outside = CvOUTSIDE(cv);
4225 AV* padlist = CvPADLIST(cv);
4232 PerlIO_printf(Perl_debug_log,
4233 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4235 (CvANON(cv) ? "ANON"
4236 : (cv == PL_main_cv) ? "MAIN"
4237 : CvUNIQUE(cv) ? "UNIQUE"
4238 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4241 : CvANON(outside) ? "ANON"
4242 : (outside == PL_main_cv) ? "MAIN"
4243 : CvUNIQUE(outside) ? "UNIQUE"
4244 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4249 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4250 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4251 pname = AvARRAY(pad_name);
4252 ppad = AvARRAY(pad);
4254 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4255 if (SvPOK(pname[ix]))
4256 PerlIO_printf(Perl_debug_log,
4257 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4258 (int)ix, PTR2UV(ppad[ix]),
4259 SvFAKE(pname[ix]) ? "FAKE " : "",
4261 (IV)I_32(SvNVX(pname[ix])),
4264 #endif /* DEBUGGING */
4266 #endif /* DEBUG_CLOSURES */
4269 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4273 AV* protopadlist = CvPADLIST(proto);
4274 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4275 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4276 SV** pname = AvARRAY(protopad_name);
4277 SV** ppad = AvARRAY(protopad);
4278 I32 fname = AvFILLp(protopad_name);
4279 I32 fpad = AvFILLp(protopad);
4283 assert(!CvUNIQUE(proto));
4287 SAVESPTR(PL_comppad_name);
4288 SAVESPTR(PL_compcv);
4290 cv = PL_compcv = (CV*)NEWSV(1104,0);
4291 sv_upgrade((SV *)cv, SvTYPE(proto));
4292 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4296 New(666, CvMUTEXP(cv), 1, perl_mutex);
4297 MUTEX_INIT(CvMUTEXP(cv));
4299 #endif /* USE_THREADS */
4300 CvFILE(cv) = CvFILE(proto);
4301 CvGV(cv) = CvGV(proto);
4302 CvSTASH(cv) = CvSTASH(proto);
4303 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4304 CvSTART(cv) = CvSTART(proto);
4306 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4309 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4311 PL_comppad_name = newAV();
4312 for (ix = fname; ix >= 0; ix--)
4313 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4315 PL_comppad = newAV();
4317 comppadlist = newAV();
4318 AvREAL_off(comppadlist);
4319 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4320 av_store(comppadlist, 1, (SV*)PL_comppad);
4321 CvPADLIST(cv) = comppadlist;
4322 av_fill(PL_comppad, AvFILLp(protopad));
4323 PL_curpad = AvARRAY(PL_comppad);
4325 av = newAV(); /* will be @_ */
4327 av_store(PL_comppad, 0, (SV*)av);
4328 AvFLAGS(av) = AVf_REIFY;
4330 for (ix = fpad; ix > 0; ix--) {
4331 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4332 if (namesv && namesv != &PL_sv_undef) {
4333 char *name = SvPVX(namesv); /* XXX */
4334 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4335 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4336 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4338 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4340 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4342 else { /* our own lexical */
4345 /* anon code -- we'll come back for it */
4346 sv = SvREFCNT_inc(ppad[ix]);
4348 else if (*name == '@')
4350 else if (*name == '%')
4359 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4360 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4363 SV* sv = NEWSV(0,0);
4369 /* Now that vars are all in place, clone nested closures. */
4371 for (ix = fpad; ix > 0; ix--) {
4372 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4374 && namesv != &PL_sv_undef
4375 && !(SvFLAGS(namesv) & SVf_FAKE)
4376 && *SvPVX(namesv) == '&'
4377 && CvCLONE(ppad[ix]))
4379 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4380 SvREFCNT_dec(ppad[ix]);
4383 PL_curpad[ix] = (SV*)kid;
4387 #ifdef DEBUG_CLOSURES
4388 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4390 PerlIO_printf(Perl_debug_log, " from:\n");
4392 PerlIO_printf(Perl_debug_log, " to:\n");
4399 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4401 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4403 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4410 Perl_cv_clone(pTHX_ CV *proto)
4413 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4414 cv = cv_clone2(proto, CvOUTSIDE(proto));
4415 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4420 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4422 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4423 SV* msg = sv_newmortal();
4427 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4428 sv_setpv(msg, "Prototype mismatch:");
4430 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4432 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4433 sv_catpv(msg, " vs ");
4435 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4437 sv_catpv(msg, "none");
4438 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4442 static void const_sv_xsub(pTHXo_ CV* cv);
4445 =for apidoc cv_const_sv
4447 If C<cv> is a constant sub eligible for inlining. returns the constant
4448 value returned by the sub. Otherwise, returns NULL.
4450 Constant subs can be created with C<newCONSTSUB> or as described in
4451 L<perlsub/"Constant Functions">.
4456 Perl_cv_const_sv(pTHX_ CV *cv)
4458 if (!cv || !CvCONST(cv))
4460 return (SV*)CvXSUBANY(cv).any_ptr;
4464 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4471 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4472 o = cLISTOPo->op_first->op_sibling;
4474 for (; o; o = o->op_next) {
4475 OPCODE type = o->op_type;
4477 if (sv && o->op_next == o)
4479 if (o->op_next != o) {
4480 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4482 if (type == OP_DBSTATE)
4485 if (type == OP_LEAVESUB || type == OP_RETURN)
4489 if (type == OP_CONST && cSVOPo->op_sv)
4491 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4492 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4493 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4497 /* We get here only from cv_clone2() while creating a closure.
4498 Copy the const value here instead of in cv_clone2 so that
4499 SvREADONLY_on doesn't lead to problems when leaving
4504 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4516 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4526 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4530 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4532 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4536 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4542 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4547 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4548 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4549 SV *sv = sv_newmortal();
4550 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4551 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4556 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4557 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4567 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4568 maximum a prototype before. */
4569 if (SvTYPE(gv) > SVt_NULL) {
4570 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4571 && ckWARN_d(WARN_PROTOTYPE))
4573 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4575 cv_ckproto((CV*)gv, NULL, ps);
4578 sv_setpv((SV*)gv, ps);
4580 sv_setiv((SV*)gv, -1);
4581 SvREFCNT_dec(PL_compcv);
4582 cv = PL_compcv = NULL;
4583 PL_sub_generation++;
4587 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4589 #ifdef GV_SHARED_CHECK
4590 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4591 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4595 if (!block || !ps || *ps || attrs)
4598 const_sv = op_const_sv(block, Nullcv);
4601 bool exists = CvROOT(cv) || CvXSUB(cv);
4603 #ifdef GV_SHARED_CHECK
4604 if (exists && GvSHARED(gv)) {
4605 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4609 /* if the subroutine doesn't exist and wasn't pre-declared
4610 * with a prototype, assume it will be AUTOLOADed,
4611 * skipping the prototype check
4613 if (exists || SvPOK(cv))
4614 cv_ckproto(cv, gv, ps);
4615 /* already defined (or promised)? */
4616 if (exists || GvASSUMECV(gv)) {
4617 if (!block && !attrs) {
4618 /* just a "sub foo;" when &foo is already defined */
4619 SAVEFREESV(PL_compcv);
4622 /* ahem, death to those who redefine active sort subs */
4623 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4624 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4626 if (ckWARN(WARN_REDEFINE)
4628 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4630 line_t oldline = CopLINE(PL_curcop);
4631 CopLINE_set(PL_curcop, PL_copline);
4632 Perl_warner(aTHX_ WARN_REDEFINE,
4633 CvCONST(cv) ? "Constant subroutine %s redefined"
4634 : "Subroutine %s redefined", name);
4635 CopLINE_set(PL_curcop, oldline);
4643 SvREFCNT_inc(const_sv);
4645 assert(!CvROOT(cv) && !CvCONST(cv));
4646 sv_setpv((SV*)cv, ""); /* prototype is "" */
4647 CvXSUBANY(cv).any_ptr = const_sv;
4648 CvXSUB(cv) = const_sv_xsub;
4653 cv = newCONSTSUB(NULL, name, const_sv);
4656 SvREFCNT_dec(PL_compcv);
4658 PL_sub_generation++;
4665 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4666 * before we clobber PL_compcv.
4670 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4671 stash = GvSTASH(CvGV(cv));
4672 else if (CvSTASH(cv))
4673 stash = CvSTASH(cv);
4675 stash = PL_curstash;
4678 /* possibly about to re-define existing subr -- ignore old cv */
4679 rcv = (SV*)PL_compcv;
4680 if (name && GvSTASH(gv))
4681 stash = GvSTASH(gv);
4683 stash = PL_curstash;
4685 apply_attrs(stash, rcv, attrs);
4687 if (cv) { /* must reuse cv if autoloaded */
4689 /* got here with just attrs -- work done, so bug out */
4690 SAVEFREESV(PL_compcv);
4694 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4695 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4696 CvOUTSIDE(PL_compcv) = 0;
4697 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4698 CvPADLIST(PL_compcv) = 0;
4699 /* inner references to PL_compcv must be fixed up ... */
4701 AV *padlist = CvPADLIST(cv);
4702 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4703 AV *comppad = (AV*)AvARRAY(padlist)[1];
4704 SV **namepad = AvARRAY(comppad_name);
4705 SV **curpad = AvARRAY(comppad);
4706 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4707 SV *namesv = namepad[ix];
4708 if (namesv && namesv != &PL_sv_undef
4709 && *SvPVX(namesv) == '&')
4711 CV *innercv = (CV*)curpad[ix];
4712 if (CvOUTSIDE(innercv) == PL_compcv) {
4713 CvOUTSIDE(innercv) = cv;
4714 if (!CvANON(innercv) || CvCLONED(innercv)) {
4715 (void)SvREFCNT_inc(cv);
4716 SvREFCNT_dec(PL_compcv);
4722 /* ... before we throw it away */
4723 SvREFCNT_dec(PL_compcv);
4730 PL_sub_generation++;
4734 CvFILE(cv) = CopFILE(PL_curcop);
4735 CvSTASH(cv) = PL_curstash;
4738 if (!CvMUTEXP(cv)) {
4739 New(666, CvMUTEXP(cv), 1, perl_mutex);
4740 MUTEX_INIT(CvMUTEXP(cv));
4742 #endif /* USE_THREADS */
4745 sv_setpv((SV*)cv, ps);
4747 if (PL_error_count) {
4751 char *s = strrchr(name, ':');
4753 if (strEQ(s, "BEGIN")) {
4755 "BEGIN not safe after errors--compilation aborted";
4756 if (PL_in_eval & EVAL_KEEPERR)
4757 Perl_croak(aTHX_ not_safe);
4759 /* force display of errors found but not reported */
4760 sv_catpv(ERRSV, not_safe);
4761 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4769 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4770 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4773 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4774 mod(scalarseq(block), OP_LEAVESUBLV));
4777 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4779 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4780 OpREFCNT_set(CvROOT(cv), 1);
4781 CvSTART(cv) = LINKLIST(CvROOT(cv));
4782 CvROOT(cv)->op_next = 0;
4785 /* now that optimizer has done its work, adjust pad values */
4787 SV **namep = AvARRAY(PL_comppad_name);
4788 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4791 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4794 * The only things that a clonable function needs in its
4795 * pad are references to outer lexicals and anonymous subs.
4796 * The rest are created anew during cloning.
4798 if (!((namesv = namep[ix]) != Nullsv &&
4799 namesv != &PL_sv_undef &&
4801 *SvPVX(namesv) == '&')))
4803 SvREFCNT_dec(PL_curpad[ix]);
4804 PL_curpad[ix] = Nullsv;
4807 assert(!CvCONST(cv));
4808 if (ps && !*ps && op_const_sv(block, cv))
4812 AV *av = newAV(); /* Will be @_ */
4814 av_store(PL_comppad, 0, (SV*)av);
4815 AvFLAGS(av) = AVf_REIFY;
4817 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4818 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4820 if (!SvPADMY(PL_curpad[ix]))
4821 SvPADTMP_on(PL_curpad[ix]);
4825 /* If a potential closure prototype, don't keep a refcount on
4826 * outer CV, unless the latter happens to be a passing eval"".
4827 * This is okay as the lifetime of the prototype is tied to the
4828 * lifetime of the outer CV. Avoids memory leak due to reference
4830 if (!name && CvOUTSIDE(cv)
4831 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4832 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4834 SvREFCNT_dec(CvOUTSIDE(cv));
4837 if (name || aname) {
4839 char *tname = (name ? name : aname);
4841 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4842 SV *sv = NEWSV(0,0);
4843 SV *tmpstr = sv_newmortal();
4844 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4848 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4850 (long)PL_subline, (long)CopLINE(PL_curcop));
4851 gv_efullname3(tmpstr, gv, Nullch);
4852 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4853 hv = GvHVn(db_postponed);
4854 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4855 && (pcv = GvCV(db_postponed)))
4861 call_sv((SV*)pcv, G_DISCARD);
4865 if ((s = strrchr(tname,':')))
4870 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4873 if (strEQ(s, "BEGIN")) {
4874 I32 oldscope = PL_scopestack_ix;
4876 SAVECOPFILE(&PL_compiling);
4877 SAVECOPLINE(&PL_compiling);
4879 sv_setsv(PL_rs, PL_nrs);
4882 PL_beginav = newAV();
4883 DEBUG_x( dump_sub(gv) );
4884 av_push(PL_beginav, (SV*)cv);
4885 GvCV(gv) = 0; /* cv has been hijacked */
4886 call_list(oldscope, PL_beginav);
4888 PL_curcop = &PL_compiling;
4889 PL_compiling.op_private = PL_hints;
4892 else if (strEQ(s, "END") && !PL_error_count) {
4895 DEBUG_x( dump_sub(gv) );
4896 av_unshift(PL_endav, 1);
4897 av_store(PL_endav, 0, (SV*)cv);
4898 GvCV(gv) = 0; /* cv has been hijacked */
4900 else if (strEQ(s, "CHECK") && !PL_error_count) {
4902 PL_checkav = newAV();
4903 DEBUG_x( dump_sub(gv) );
4904 if (PL_main_start && ckWARN(WARN_VOID))
4905 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4906 av_unshift(PL_checkav, 1);
4907 av_store(PL_checkav, 0, (SV*)cv);
4908 GvCV(gv) = 0; /* cv has been hijacked */
4910 else if (strEQ(s, "INIT") && !PL_error_count) {
4912 PL_initav = newAV();
4913 DEBUG_x( dump_sub(gv) );
4914 if (PL_main_start && ckWARN(WARN_VOID))
4915 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4916 av_push(PL_initav, (SV*)cv);
4917 GvCV(gv) = 0; /* cv has been hijacked */
4922 PL_copline = NOLINE;
4927 /* XXX unsafe for threads if eval_owner isn't held */
4929 =for apidoc newCONSTSUB
4931 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4932 eligible for inlining at compile-time.
4938 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4944 SAVECOPLINE(PL_curcop);
4945 CopLINE_set(PL_curcop, PL_copline);
4948 PL_hints &= ~HINT_BLOCK_SCOPE;
4951 SAVESPTR(PL_curstash);
4952 SAVECOPSTASH(PL_curcop);
4953 PL_curstash = stash;
4955 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4957 CopSTASH(PL_curcop) = stash;
4961 cv = newXS(name, const_sv_xsub, __FILE__);
4962 CvXSUBANY(cv).any_ptr = sv;
4964 sv_setpv((SV*)cv, ""); /* prototype is "" */
4972 =for apidoc U||newXS
4974 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4980 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4982 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4985 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4987 /* just a cached method */
4991 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4992 /* already defined (or promised) */
4993 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4994 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4995 line_t oldline = CopLINE(PL_curcop);
4996 if (PL_copline != NOLINE)
4997 CopLINE_set(PL_curcop, PL_copline);
4998 Perl_warner(aTHX_ WARN_REDEFINE,
4999 CvCONST(cv) ? "Constant subroutine %s redefined"
5000 : "Subroutine %s redefined"
5002 CopLINE_set(PL_curcop, oldline);
5009 if (cv) /* must reuse cv if autoloaded */
5012 cv = (CV*)NEWSV(1105,0);
5013 sv_upgrade((SV *)cv, SVt_PVCV);
5017 PL_sub_generation++;
5022 New(666, CvMUTEXP(cv), 1, perl_mutex);
5023 MUTEX_INIT(CvMUTEXP(cv));
5025 #endif /* USE_THREADS */
5026 (void)gv_fetchfile(filename);
5027 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5028 an external constant string */
5029 CvXSUB(cv) = subaddr;
5032 char *s = strrchr(name,':');
5038 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5041 if (strEQ(s, "BEGIN")) {
5043 PL_beginav = newAV();
5044 av_push(PL_beginav, (SV*)cv);
5045 GvCV(gv) = 0; /* cv has been hijacked */
5047 else if (strEQ(s, "END")) {
5050 av_unshift(PL_endav, 1);
5051 av_store(PL_endav, 0, (SV*)cv);
5052 GvCV(gv) = 0; /* cv has been hijacked */
5054 else if (strEQ(s, "CHECK")) {
5056 PL_checkav = newAV();
5057 if (PL_main_start && ckWARN(WARN_VOID))
5058 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5059 av_unshift(PL_checkav, 1);
5060 av_store(PL_checkav, 0, (SV*)cv);
5061 GvCV(gv) = 0; /* cv has been hijacked */
5063 else if (strEQ(s, "INIT")) {
5065 PL_initav = newAV();
5066 if (PL_main_start && ckWARN(WARN_VOID))
5067 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5068 av_push(PL_initav, (SV*)cv);
5069 GvCV(gv) = 0; /* cv has been hijacked */
5080 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5089 name = SvPVx(cSVOPo->op_sv, n_a);
5092 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5093 #ifdef GV_SHARED_CHECK
5095 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5099 if ((cv = GvFORM(gv))) {
5100 if (ckWARN(WARN_REDEFINE)) {
5101 line_t oldline = CopLINE(PL_curcop);
5103 CopLINE_set(PL_curcop, PL_copline);
5104 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5105 CopLINE_set(PL_curcop, oldline);
5112 CvFILE(cv) = CopFILE(PL_curcop);
5114 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5115 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5116 SvPADTMP_on(PL_curpad[ix]);
5119 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5120 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5121 OpREFCNT_set(CvROOT(cv), 1);
5122 CvSTART(cv) = LINKLIST(CvROOT(cv));
5123 CvROOT(cv)->op_next = 0;
5126 PL_copline = NOLINE;
5131 Perl_newANONLIST(pTHX_ OP *o)
5133 return newUNOP(OP_REFGEN, 0,
5134 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5138 Perl_newANONHASH(pTHX_ OP *o)
5140 return newUNOP(OP_REFGEN, 0,
5141 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5145 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5147 return newANONATTRSUB(floor, proto, Nullop, block);
5151 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5153 return newUNOP(OP_REFGEN, 0,
5154 newSVOP(OP_ANONCODE, 0,
5155 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5159 Perl_oopsAV(pTHX_ OP *o)
5161 switch (o->op_type) {
5163 o->op_type = OP_PADAV;
5164 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5165 return ref(o, OP_RV2AV);
5168 o->op_type = OP_RV2AV;
5169 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5174 if (ckWARN_d(WARN_INTERNAL))
5175 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5182 Perl_oopsHV(pTHX_ OP *o)
5184 switch (o->op_type) {
5187 o->op_type = OP_PADHV;
5188 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5189 return ref(o, OP_RV2HV);
5193 o->op_type = OP_RV2HV;
5194 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5199 if (ckWARN_d(WARN_INTERNAL))
5200 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5207 Perl_newAVREF(pTHX_ OP *o)
5209 if (o->op_type == OP_PADANY) {
5210 o->op_type = OP_PADAV;
5211 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5214 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5215 && ckWARN(WARN_DEPRECATED)) {
5216 Perl_warner(aTHX_ WARN_DEPRECATED,
5217 "Using an array as a reference is deprecated");
5219 return newUNOP(OP_RV2AV, 0, scalar(o));
5223 Perl_newGVREF(pTHX_ I32 type, OP *o)
5225 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5226 return newUNOP(OP_NULL, 0, o);
5227 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5231 Perl_newHVREF(pTHX_ OP *o)
5233 if (o->op_type == OP_PADANY) {
5234 o->op_type = OP_PADHV;
5235 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5238 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5239 && ckWARN(WARN_DEPRECATED)) {
5240 Perl_warner(aTHX_ WARN_DEPRECATED,
5241 "Using a hash as a reference is deprecated");
5243 return newUNOP(OP_RV2HV, 0, scalar(o));
5247 Perl_oopsCV(pTHX_ OP *o)
5249 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5255 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5257 return newUNOP(OP_RV2CV, flags, scalar(o));
5261 Perl_newSVREF(pTHX_ OP *o)
5263 if (o->op_type == OP_PADANY) {
5264 o->op_type = OP_PADSV;
5265 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5268 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5269 o->op_flags |= OPpDONE_SVREF;
5272 return newUNOP(OP_RV2SV, 0, scalar(o));
5275 /* Check routines. */
5278 Perl_ck_anoncode(pTHX_ OP *o)
5283 name = NEWSV(1106,0);
5284 sv_upgrade(name, SVt_PVNV);
5285 sv_setpvn(name, "&", 1);
5288 ix = pad_alloc(o->op_type, SVs_PADMY);
5289 av_store(PL_comppad_name, ix, name);
5290 av_store(PL_comppad, ix, cSVOPo->op_sv);
5291 SvPADMY_on(cSVOPo->op_sv);
5292 cSVOPo->op_sv = Nullsv;
5293 cSVOPo->op_targ = ix;
5298 Perl_ck_bitop(pTHX_ OP *o)
5300 o->op_private = PL_hints;
5305 Perl_ck_concat(pTHX_ OP *o)
5307 if (cUNOPo->op_first->op_type == OP_CONCAT)
5308 o->op_flags |= OPf_STACKED;
5313 Perl_ck_spair(pTHX_ OP *o)
5315 if (o->op_flags & OPf_KIDS) {
5318 OPCODE type = o->op_type;
5319 o = modkids(ck_fun(o), type);
5320 kid = cUNOPo->op_first;
5321 newop = kUNOP->op_first->op_sibling;
5323 (newop->op_sibling ||
5324 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5325 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5326 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5330 op_free(kUNOP->op_first);
5331 kUNOP->op_first = newop;
5333 o->op_ppaddr = PL_ppaddr[++o->op_type];
5338 Perl_ck_delete(pTHX_ OP *o)
5342 if (o->op_flags & OPf_KIDS) {
5343 OP *kid = cUNOPo->op_first;
5344 switch (kid->op_type) {
5346 o->op_flags |= OPf_SPECIAL;
5349 o->op_private |= OPpSLICE;
5352 o->op_flags |= OPf_SPECIAL;
5357 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5358 PL_op_desc[o->op_type]);
5366 Perl_ck_eof(pTHX_ OP *o)
5368 I32 type = o->op_type;
5370 if (o->op_flags & OPf_KIDS) {
5371 if (cLISTOPo->op_first->op_type == OP_STUB) {
5373 o = newUNOP(type, OPf_SPECIAL,
5374 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5382 Perl_ck_eval(pTHX_ OP *o)
5384 PL_hints |= HINT_BLOCK_SCOPE;
5385 if (o->op_flags & OPf_KIDS) {
5386 SVOP *kid = (SVOP*)cUNOPo->op_first;
5389 o->op_flags &= ~OPf_KIDS;
5392 else if (kid->op_type == OP_LINESEQ) {
5395 kid->op_next = o->op_next;
5396 cUNOPo->op_first = 0;
5399 NewOp(1101, enter, 1, LOGOP);
5400 enter->op_type = OP_ENTERTRY;
5401 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5402 enter->op_private = 0;
5404 /* establish postfix order */
5405 enter->op_next = (OP*)enter;
5407 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5408 o->op_type = OP_LEAVETRY;
5409 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5410 enter->op_other = o;
5418 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5420 o->op_targ = (PADOFFSET)PL_hints;
5425 Perl_ck_exit(pTHX_ OP *o)
5428 HV *table = GvHV(PL_hintgv);
5430 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5431 if (svp && *svp && SvTRUE(*svp))
5432 o->op_private |= OPpEXIT_VMSISH;
5439 Perl_ck_exec(pTHX_ OP *o)
5442 if (o->op_flags & OPf_STACKED) {
5444 kid = cUNOPo->op_first->op_sibling;
5445 if (kid->op_type == OP_RV2GV)
5454 Perl_ck_exists(pTHX_ OP *o)
5457 if (o->op_flags & OPf_KIDS) {
5458 OP *kid = cUNOPo->op_first;
5459 if (kid->op_type == OP_ENTERSUB) {
5460 (void) ref(kid, o->op_type);
5461 if (kid->op_type != OP_RV2CV && !PL_error_count)
5462 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5463 PL_op_desc[o->op_type]);
5464 o->op_private |= OPpEXISTS_SUB;
5466 else if (kid->op_type == OP_AELEM)
5467 o->op_flags |= OPf_SPECIAL;
5468 else if (kid->op_type != OP_HELEM)
5469 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5470 PL_op_desc[o->op_type]);
5478 Perl_ck_gvconst(pTHX_ register OP *o)
5480 o = fold_constants(o);
5481 if (o->op_type == OP_CONST)
5488 Perl_ck_rvconst(pTHX_ register OP *o)
5490 SVOP *kid = (SVOP*)cUNOPo->op_first;
5492 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5493 if (kid->op_type == OP_CONST) {
5497 SV *kidsv = kid->op_sv;
5500 /* Is it a constant from cv_const_sv()? */
5501 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5502 SV *rsv = SvRV(kidsv);
5503 int svtype = SvTYPE(rsv);
5504 char *badtype = Nullch;
5506 switch (o->op_type) {
5508 if (svtype > SVt_PVMG)
5509 badtype = "a SCALAR";
5512 if (svtype != SVt_PVAV)
5513 badtype = "an ARRAY";
5516 if (svtype != SVt_PVHV) {
5517 if (svtype == SVt_PVAV) { /* pseudohash? */
5518 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5519 if (ksv && SvROK(*ksv)
5520 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5529 if (svtype != SVt_PVCV)
5534 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5537 name = SvPV(kidsv, n_a);
5538 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5539 char *badthing = Nullch;
5540 switch (o->op_type) {
5542 badthing = "a SCALAR";
5545 badthing = "an ARRAY";
5548 badthing = "a HASH";
5553 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5557 * This is a little tricky. We only want to add the symbol if we
5558 * didn't add it in the lexer. Otherwise we get duplicate strict
5559 * warnings. But if we didn't add it in the lexer, we must at
5560 * least pretend like we wanted to add it even if it existed before,
5561 * or we get possible typo warnings. OPpCONST_ENTERED says
5562 * whether the lexer already added THIS instance of this symbol.
5564 iscv = (o->op_type == OP_RV2CV) * 2;
5566 gv = gv_fetchpv(name,
5567 iscv | !(kid->op_private & OPpCONST_ENTERED),
5570 : o->op_type == OP_RV2SV
5572 : o->op_type == OP_RV2AV
5574 : o->op_type == OP_RV2HV
5577 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5579 kid->op_type = OP_GV;
5580 SvREFCNT_dec(kid->op_sv);
5582 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5583 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5584 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5586 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5588 kid->op_sv = SvREFCNT_inc(gv);
5590 kid->op_private = 0;
5591 kid->op_ppaddr = PL_ppaddr[OP_GV];
5598 Perl_ck_ftst(pTHX_ OP *o)
5600 I32 type = o->op_type;
5602 if (o->op_flags & OPf_REF) {
5605 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5606 SVOP *kid = (SVOP*)cUNOPo->op_first;
5608 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5610 OP *newop = newGVOP(type, OPf_REF,
5611 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5618 if (type == OP_FTTTY)
5619 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5622 o = newUNOP(type, 0, newDEFSVOP());
5628 Perl_ck_fun(pTHX_ OP *o)
5634 int type = o->op_type;
5635 register I32 oa = PL_opargs[type] >> OASHIFT;
5637 if (o->op_flags & OPf_STACKED) {
5638 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5641 return no_fh_allowed(o);
5644 if (o->op_flags & OPf_KIDS) {
5646 tokid = &cLISTOPo->op_first;
5647 kid = cLISTOPo->op_first;
5648 if (kid->op_type == OP_PUSHMARK ||
5649 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5651 tokid = &kid->op_sibling;
5652 kid = kid->op_sibling;
5654 if (!kid && PL_opargs[type] & OA_DEFGV)
5655 *tokid = kid = newDEFSVOP();
5659 sibl = kid->op_sibling;
5662 /* list seen where single (scalar) arg expected? */
5663 if (numargs == 1 && !(oa >> 4)
5664 && kid->op_type == OP_LIST && type != OP_SCALAR)
5666 return too_many_arguments(o,PL_op_desc[type]);
5679 if ((type == OP_PUSH || type == OP_UNSHIFT)
5680 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5681 Perl_warner(aTHX_ WARN_SYNTAX,
5682 "Useless use of %s with no values",
5685 if (kid->op_type == OP_CONST &&
5686 (kid->op_private & OPpCONST_BARE))
5688 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5689 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5690 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5691 if (ckWARN(WARN_DEPRECATED))
5692 Perl_warner(aTHX_ WARN_DEPRECATED,
5693 "Array @%s missing the @ in argument %"IVdf" of %s()",
5694 name, (IV)numargs, PL_op_desc[type]);
5697 kid->op_sibling = sibl;
5700 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5701 bad_type(numargs, "array", PL_op_desc[type], kid);
5705 if (kid->op_type == OP_CONST &&
5706 (kid->op_private & OPpCONST_BARE))
5708 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5709 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5710 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5711 if (ckWARN(WARN_DEPRECATED))
5712 Perl_warner(aTHX_ WARN_DEPRECATED,
5713 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5714 name, (IV)numargs, PL_op_desc[type]);
5717 kid->op_sibling = sibl;
5720 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5721 bad_type(numargs, "hash", PL_op_desc[type], kid);
5726 OP *newop = newUNOP(OP_NULL, 0, kid);
5727 kid->op_sibling = 0;
5729 newop->op_next = newop;
5731 kid->op_sibling = sibl;
5736 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5737 if (kid->op_type == OP_CONST &&
5738 (kid->op_private & OPpCONST_BARE))
5740 OP *newop = newGVOP(OP_GV, 0,
5741 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5746 else if (kid->op_type == OP_READLINE) {
5747 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5748 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5751 I32 flags = OPf_SPECIAL;
5755 /* is this op a FH constructor? */
5756 if (is_handle_constructor(o,numargs)) {
5757 char *name = Nullch;
5761 /* Set a flag to tell rv2gv to vivify
5762 * need to "prove" flag does not mean something
5763 * else already - NI-S 1999/05/07
5766 if (kid->op_type == OP_PADSV) {
5767 SV **namep = av_fetch(PL_comppad_name,
5769 if (namep && *namep)
5770 name = SvPV(*namep, len);
5772 else if (kid->op_type == OP_RV2SV
5773 && kUNOP->op_first->op_type == OP_GV)
5775 GV *gv = cGVOPx_gv(kUNOP->op_first);
5777 len = GvNAMELEN(gv);
5779 else if (kid->op_type == OP_AELEM
5780 || kid->op_type == OP_HELEM)
5782 name = "__ANONIO__";
5788 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5789 namesv = PL_curpad[targ];
5790 (void)SvUPGRADE(namesv, SVt_PV);
5792 sv_setpvn(namesv, "$", 1);
5793 sv_catpvn(namesv, name, len);
5796 kid->op_sibling = 0;
5797 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5798 kid->op_targ = targ;
5799 kid->op_private |= priv;
5801 kid->op_sibling = sibl;
5807 mod(scalar(kid), type);
5811 tokid = &kid->op_sibling;
5812 kid = kid->op_sibling;
5814 o->op_private |= numargs;
5816 return too_many_arguments(o,PL_op_desc[o->op_type]);
5819 else if (PL_opargs[type] & OA_DEFGV) {
5821 return newUNOP(type, 0, newDEFSVOP());
5825 while (oa & OA_OPTIONAL)
5827 if (oa && oa != OA_LIST)
5828 return too_few_arguments(o,PL_op_desc[o->op_type]);
5834 Perl_ck_glob(pTHX_ OP *o)
5839 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5840 append_elem(OP_GLOB, o, newDEFSVOP());
5842 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5843 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5845 #if !defined(PERL_EXTERNAL_GLOB)
5846 /* XXX this can be tightened up and made more failsafe. */
5850 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5852 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5853 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5854 GvCV(gv) = GvCV(glob_gv);
5855 SvREFCNT_inc((SV*)GvCV(gv));
5856 GvIMPORTED_CV_on(gv);
5859 #endif /* PERL_EXTERNAL_GLOB */
5861 if (gv && GvIMPORTED_CV(gv)) {
5862 append_elem(OP_GLOB, o,
5863 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5864 o->op_type = OP_LIST;
5865 o->op_ppaddr = PL_ppaddr[OP_LIST];
5866 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5867 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5868 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5869 append_elem(OP_LIST, o,
5870 scalar(newUNOP(OP_RV2CV, 0,
5871 newGVOP(OP_GV, 0, gv)))));
5872 o = newUNOP(OP_NULL, 0, ck_subr(o));
5873 o->op_targ = OP_GLOB; /* hint at what it used to be */
5876 gv = newGVgen("main");
5878 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5884 Perl_ck_grep(pTHX_ OP *o)
5888 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5890 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5891 NewOp(1101, gwop, 1, LOGOP);
5893 if (o->op_flags & OPf_STACKED) {
5896 kid = cLISTOPo->op_first->op_sibling;
5897 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5900 kid->op_next = (OP*)gwop;
5901 o->op_flags &= ~OPf_STACKED;
5903 kid = cLISTOPo->op_first->op_sibling;
5904 if (type == OP_MAPWHILE)
5911 kid = cLISTOPo->op_first->op_sibling;
5912 if (kid->op_type != OP_NULL)
5913 Perl_croak(aTHX_ "panic: ck_grep");
5914 kid = kUNOP->op_first;
5916 gwop->op_type = type;
5917 gwop->op_ppaddr = PL_ppaddr[type];
5918 gwop->op_first = listkids(o);
5919 gwop->op_flags |= OPf_KIDS;
5920 gwop->op_private = 1;
5921 gwop->op_other = LINKLIST(kid);
5922 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5923 kid->op_next = (OP*)gwop;
5925 kid = cLISTOPo->op_first->op_sibling;
5926 if (!kid || !kid->op_sibling)
5927 return too_few_arguments(o,PL_op_desc[o->op_type]);
5928 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5929 mod(kid, OP_GREPSTART);
5935 Perl_ck_index(pTHX_ OP *o)
5937 if (o->op_flags & OPf_KIDS) {
5938 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5940 kid = kid->op_sibling; /* get past "big" */
5941 if (kid && kid->op_type == OP_CONST)
5942 fbm_compile(((SVOP*)kid)->op_sv, 0);
5948 Perl_ck_lengthconst(pTHX_ OP *o)
5950 /* XXX length optimization goes here */
5955 Perl_ck_lfun(pTHX_ OP *o)
5957 OPCODE type = o->op_type;
5958 return modkids(ck_fun(o), type);
5962 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5964 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5965 switch (cUNOPo->op_first->op_type) {
5967 /* This is needed for
5968 if (defined %stash::)
5969 to work. Do not break Tk.
5971 break; /* Globals via GV can be undef */
5973 case OP_AASSIGN: /* Is this a good idea? */
5974 Perl_warner(aTHX_ WARN_DEPRECATED,
5975 "defined(@array) is deprecated");
5976 Perl_warner(aTHX_ WARN_DEPRECATED,
5977 "\t(Maybe you should just omit the defined()?)\n");
5980 /* This is needed for
5981 if (defined %stash::)
5982 to work. Do not break Tk.
5984 break; /* Globals via GV can be undef */
5986 Perl_warner(aTHX_ WARN_DEPRECATED,
5987 "defined(%%hash) is deprecated");
5988 Perl_warner(aTHX_ WARN_DEPRECATED,
5989 "\t(Maybe you should just omit the defined()?)\n");
6000 Perl_ck_rfun(pTHX_ OP *o)
6002 OPCODE type = o->op_type;
6003 return refkids(ck_fun(o), type);
6007 Perl_ck_listiob(pTHX_ OP *o)
6011 kid = cLISTOPo->op_first;
6014 kid = cLISTOPo->op_first;
6016 if (kid->op_type == OP_PUSHMARK)
6017 kid = kid->op_sibling;
6018 if (kid && o->op_flags & OPf_STACKED)
6019 kid = kid->op_sibling;
6020 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6021 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6022 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6023 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6024 cLISTOPo->op_first->op_sibling = kid;
6025 cLISTOPo->op_last = kid;
6026 kid = kid->op_sibling;
6031 append_elem(o->op_type, o, newDEFSVOP());
6037 Perl_ck_sassign(pTHX_ OP *o)
6039 OP *kid = cLISTOPo->op_first;
6040 /* has a disposable target? */
6041 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6042 && !(kid->op_flags & OPf_STACKED)
6043 /* Cannot steal the second time! */
6044 && !(kid->op_private & OPpTARGET_MY))
6046 OP *kkid = kid->op_sibling;
6048 /* Can just relocate the target. */
6049 if (kkid && kkid->op_type == OP_PADSV
6050 && !(kkid->op_private & OPpLVAL_INTRO))
6052 kid->op_targ = kkid->op_targ;
6054 /* Now we do not need PADSV and SASSIGN. */
6055 kid->op_sibling = o->op_sibling; /* NULL */
6056 cLISTOPo->op_first = NULL;
6059 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6067 Perl_ck_match(pTHX_ OP *o)
6069 o->op_private |= OPpRUNTIME;
6074 Perl_ck_method(pTHX_ OP *o)
6076 OP *kid = cUNOPo->op_first;
6077 if (kid->op_type == OP_CONST) {
6078 SV* sv = kSVOP->op_sv;
6079 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6081 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6082 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6085 kSVOP->op_sv = Nullsv;
6087 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6096 Perl_ck_null(pTHX_ OP *o)
6102 Perl_ck_open(pTHX_ OP *o)
6104 HV *table = GvHV(PL_hintgv);
6108 svp = hv_fetch(table, "open_IN", 7, FALSE);
6110 mode = mode_from_discipline(*svp);
6111 if (mode & O_BINARY)
6112 o->op_private |= OPpOPEN_IN_RAW;
6113 else if (mode & O_TEXT)
6114 o->op_private |= OPpOPEN_IN_CRLF;
6117 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6119 mode = mode_from_discipline(*svp);
6120 if (mode & O_BINARY)
6121 o->op_private |= OPpOPEN_OUT_RAW;
6122 else if (mode & O_TEXT)
6123 o->op_private |= OPpOPEN_OUT_CRLF;
6126 if (o->op_type == OP_BACKTICK)
6132 Perl_ck_repeat(pTHX_ OP *o)
6134 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6135 o->op_private |= OPpREPEAT_DOLIST;
6136 cBINOPo->op_first = force_list(cBINOPo->op_first);
6144 Perl_ck_require(pTHX_ OP *o)
6148 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6149 SVOP *kid = (SVOP*)cUNOPo->op_first;
6151 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6153 for (s = SvPVX(kid->op_sv); *s; s++) {
6154 if (*s == ':' && s[1] == ':') {
6156 Move(s+2, s+1, strlen(s+2)+1, char);
6157 --SvCUR(kid->op_sv);
6160 if (SvREADONLY(kid->op_sv)) {
6161 SvREADONLY_off(kid->op_sv);
6162 sv_catpvn(kid->op_sv, ".pm", 3);
6163 SvREADONLY_on(kid->op_sv);
6166 sv_catpvn(kid->op_sv, ".pm", 3);
6170 /* handle override, if any */
6171 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6172 if (!(gv && GvIMPORTED_CV(gv)))
6173 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6175 if (gv && GvIMPORTED_CV(gv)) {
6176 OP *kid = cUNOPo->op_first;
6177 cUNOPo->op_first = 0;
6179 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6180 append_elem(OP_LIST, kid,
6181 scalar(newUNOP(OP_RV2CV, 0,
6190 Perl_ck_return(pTHX_ OP *o)
6193 if (CvLVALUE(PL_compcv)) {
6194 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6195 mod(kid, OP_LEAVESUBLV);
6202 Perl_ck_retarget(pTHX_ OP *o)
6204 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6211 Perl_ck_select(pTHX_ OP *o)
6214 if (o->op_flags & OPf_KIDS) {
6215 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6216 if (kid && kid->op_sibling) {
6217 o->op_type = OP_SSELECT;
6218 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6220 return fold_constants(o);
6224 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6225 if (kid && kid->op_type == OP_RV2GV)
6226 kid->op_private &= ~HINT_STRICT_REFS;
6231 Perl_ck_shift(pTHX_ OP *o)
6233 I32 type = o->op_type;
6235 if (!(o->op_flags & OPf_KIDS)) {
6240 if (!CvUNIQUE(PL_compcv)) {
6241 argop = newOP(OP_PADAV, OPf_REF);
6242 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6245 argop = newUNOP(OP_RV2AV, 0,
6246 scalar(newGVOP(OP_GV, 0,
6247 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6250 argop = newUNOP(OP_RV2AV, 0,
6251 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6252 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6253 #endif /* USE_THREADS */
6254 return newUNOP(type, 0, scalar(argop));
6256 return scalar(modkids(ck_fun(o), type));
6260 Perl_ck_sort(pTHX_ OP *o)
6264 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6266 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6267 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6269 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6271 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6273 if (kid->op_type == OP_SCOPE) {
6277 else if (kid->op_type == OP_LEAVE) {
6278 if (o->op_type == OP_SORT) {
6279 op_null(kid); /* wipe out leave */
6282 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6283 if (k->op_next == kid)
6285 /* don't descend into loops */
6286 else if (k->op_type == OP_ENTERLOOP
6287 || k->op_type == OP_ENTERITER)
6289 k = cLOOPx(k)->op_lastop;
6294 kid->op_next = 0; /* just disconnect the leave */
6295 k = kLISTOP->op_first;
6300 if (o->op_type == OP_SORT) {
6301 /* provide scalar context for comparison function/block */
6307 o->op_flags |= OPf_SPECIAL;
6309 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6312 firstkid = firstkid->op_sibling;
6315 /* provide list context for arguments */
6316 if (o->op_type == OP_SORT)
6323 S_simplify_sort(pTHX_ OP *o)
6325 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6329 if (!(o->op_flags & OPf_STACKED))
6331 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6332 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6333 kid = kUNOP->op_first; /* get past null */
6334 if (kid->op_type != OP_SCOPE)
6336 kid = kLISTOP->op_last; /* get past scope */
6337 switch(kid->op_type) {
6345 k = kid; /* remember this node*/
6346 if (kBINOP->op_first->op_type != OP_RV2SV)
6348 kid = kBINOP->op_first; /* get past cmp */
6349 if (kUNOP->op_first->op_type != OP_GV)
6351 kid = kUNOP->op_first; /* get past rv2sv */
6353 if (GvSTASH(gv) != PL_curstash)
6355 if (strEQ(GvNAME(gv), "a"))
6357 else if (strEQ(GvNAME(gv), "b"))
6361 kid = k; /* back to cmp */
6362 if (kBINOP->op_last->op_type != OP_RV2SV)
6364 kid = kBINOP->op_last; /* down to 2nd arg */
6365 if (kUNOP->op_first->op_type != OP_GV)
6367 kid = kUNOP->op_first; /* get past rv2sv */
6369 if (GvSTASH(gv) != PL_curstash
6371 ? strNE(GvNAME(gv), "a")
6372 : strNE(GvNAME(gv), "b")))
6374 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6376 o->op_private |= OPpSORT_REVERSE;
6377 if (k->op_type == OP_NCMP)
6378 o->op_private |= OPpSORT_NUMERIC;
6379 if (k->op_type == OP_I_NCMP)
6380 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6381 kid = cLISTOPo->op_first->op_sibling;
6382 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6383 op_free(kid); /* then delete it */
6387 Perl_ck_split(pTHX_ OP *o)
6391 if (o->op_flags & OPf_STACKED)
6392 return no_fh_allowed(o);
6394 kid = cLISTOPo->op_first;
6395 if (kid->op_type != OP_NULL)
6396 Perl_croak(aTHX_ "panic: ck_split");
6397 kid = kid->op_sibling;
6398 op_free(cLISTOPo->op_first);
6399 cLISTOPo->op_first = kid;
6401 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6402 cLISTOPo->op_last = kid; /* There was only one element previously */
6405 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6406 OP *sibl = kid->op_sibling;
6407 kid->op_sibling = 0;
6408 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6409 if (cLISTOPo->op_first == cLISTOPo->op_last)
6410 cLISTOPo->op_last = kid;
6411 cLISTOPo->op_first = kid;
6412 kid->op_sibling = sibl;
6415 kid->op_type = OP_PUSHRE;
6416 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6419 if (!kid->op_sibling)
6420 append_elem(OP_SPLIT, o, newDEFSVOP());
6422 kid = kid->op_sibling;
6425 if (!kid->op_sibling)
6426 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6428 kid = kid->op_sibling;
6431 if (kid->op_sibling)
6432 return too_many_arguments(o,PL_op_desc[o->op_type]);
6438 Perl_ck_join(pTHX_ OP *o)
6440 if (ckWARN(WARN_SYNTAX)) {
6441 OP *kid = cLISTOPo->op_first->op_sibling;
6442 if (kid && kid->op_type == OP_MATCH) {
6443 char *pmstr = "STRING";
6444 if (kPMOP->op_pmregexp)
6445 pmstr = kPMOP->op_pmregexp->precomp;
6446 Perl_warner(aTHX_ WARN_SYNTAX,
6447 "/%s/ should probably be written as \"%s\"",
6455 Perl_ck_subr(pTHX_ OP *o)
6457 OP *prev = ((cUNOPo->op_first->op_sibling)
6458 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6459 OP *o2 = prev->op_sibling;
6468 o->op_private |= OPpENTERSUB_HASTARG;
6469 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6470 if (cvop->op_type == OP_RV2CV) {
6472 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6473 op_null(cvop); /* disable rv2cv */
6474 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6475 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6476 GV *gv = cGVOPx_gv(tmpop);
6479 tmpop->op_private |= OPpEARLY_CV;
6480 else if (SvPOK(cv)) {
6481 namegv = CvANON(cv) ? gv : CvGV(cv);
6482 proto = SvPV((SV*)cv, n_a);
6486 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6487 if (o2->op_type == OP_CONST)
6488 o2->op_private &= ~OPpCONST_STRICT;
6489 else if (o2->op_type == OP_LIST) {
6490 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6491 if (o && o->op_type == OP_CONST)
6492 o->op_private &= ~OPpCONST_STRICT;
6495 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6496 if (PERLDB_SUB && PL_curstash != PL_debstash)
6497 o->op_private |= OPpENTERSUB_DB;
6498 while (o2 != cvop) {
6502 return too_many_arguments(o, gv_ename(namegv));
6520 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6522 arg == 1 ? "block or sub {}" : "sub {}",
6523 gv_ename(namegv), o2);
6526 /* '*' allows any scalar type, including bareword */
6529 if (o2->op_type == OP_RV2GV)
6530 goto wrapref; /* autoconvert GLOB -> GLOBref */
6531 else if (o2->op_type == OP_CONST)
6532 o2->op_private &= ~OPpCONST_STRICT;
6533 else if (o2->op_type == OP_ENTERSUB) {
6534 /* accidental subroutine, revert to bareword */
6535 OP *gvop = ((UNOP*)o2)->op_first;
6536 if (gvop && gvop->op_type == OP_NULL) {
6537 gvop = ((UNOP*)gvop)->op_first;
6539 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6542 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6543 (gvop = ((UNOP*)gvop)->op_first) &&
6544 gvop->op_type == OP_GV)
6546 GV *gv = cGVOPx_gv(gvop);
6547 OP *sibling = o2->op_sibling;
6548 SV *n = newSVpvn("",0);
6550 gv_fullname3(n, gv, "");
6551 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6552 sv_chop(n, SvPVX(n)+6);
6553 o2 = newSVOP(OP_CONST, 0, n);
6554 prev->op_sibling = o2;
6555 o2->op_sibling = sibling;
6567 if (o2->op_type != OP_RV2GV)
6568 bad_type(arg, "symbol", gv_ename(namegv), o2);
6571 if (o2->op_type != OP_ENTERSUB)
6572 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6575 if (o2->op_type != OP_RV2SV
6576 && o2->op_type != OP_PADSV
6577 && o2->op_type != OP_HELEM
6578 && o2->op_type != OP_AELEM
6579 && o2->op_type != OP_THREADSV)
6581 bad_type(arg, "scalar", gv_ename(namegv), o2);
6585 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6586 bad_type(arg, "array", gv_ename(namegv), o2);
6589 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6590 bad_type(arg, "hash", gv_ename(namegv), o2);
6594 OP* sib = kid->op_sibling;
6595 kid->op_sibling = 0;
6596 o2 = newUNOP(OP_REFGEN, 0, kid);
6597 o2->op_sibling = sib;
6598 prev->op_sibling = o2;
6609 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6610 gv_ename(namegv), SvPV((SV*)cv, n_a));
6615 mod(o2, OP_ENTERSUB);
6617 o2 = o2->op_sibling;
6619 if (proto && !optional &&
6620 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6621 return too_few_arguments(o, gv_ename(namegv));
6626 Perl_ck_svconst(pTHX_ OP *o)
6628 SvREADONLY_on(cSVOPo->op_sv);
6633 Perl_ck_trunc(pTHX_ OP *o)
6635 if (o->op_flags & OPf_KIDS) {
6636 SVOP *kid = (SVOP*)cUNOPo->op_first;
6638 if (kid->op_type == OP_NULL)
6639 kid = (SVOP*)kid->op_sibling;
6640 if (kid && kid->op_type == OP_CONST &&
6641 (kid->op_private & OPpCONST_BARE))
6643 o->op_flags |= OPf_SPECIAL;
6644 kid->op_private &= ~OPpCONST_STRICT;
6651 Perl_ck_substr(pTHX_ OP *o)
6654 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6655 OP *kid = cLISTOPo->op_first;
6657 if (kid->op_type == OP_NULL)
6658 kid = kid->op_sibling;
6660 kid->op_flags |= OPf_MOD;
6666 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6669 Perl_peep(pTHX_ register OP *o)
6671 register OP* oldop = 0;
6674 if (!o || o->op_seq)
6678 SAVEVPTR(PL_curcop);
6679 for (; o; o = o->op_next) {
6685 switch (o->op_type) {
6689 PL_curcop = ((COP*)o); /* for warnings */
6690 o->op_seq = PL_op_seqmax++;
6694 if (cSVOPo->op_private & OPpCONST_STRICT)
6695 no_bareword_allowed(o);
6697 /* Relocate sv to the pad for thread safety.
6698 * Despite being a "constant", the SV is written to,
6699 * for reference counts, sv_upgrade() etc. */
6701 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6702 if (SvPADTMP(cSVOPo->op_sv)) {
6703 /* If op_sv is already a PADTMP then it is being used by
6704 * some pad, so make a copy. */
6705 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6706 SvREADONLY_on(PL_curpad[ix]);
6707 SvREFCNT_dec(cSVOPo->op_sv);
6710 SvREFCNT_dec(PL_curpad[ix]);
6711 SvPADTMP_on(cSVOPo->op_sv);
6712 PL_curpad[ix] = cSVOPo->op_sv;
6713 /* XXX I don't know how this isn't readonly already. */
6714 SvREADONLY_on(PL_curpad[ix]);
6716 cSVOPo->op_sv = Nullsv;
6720 o->op_seq = PL_op_seqmax++;
6724 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6725 if (o->op_next->op_private & OPpTARGET_MY) {
6726 if (o->op_flags & OPf_STACKED) /* chained concats */
6727 goto ignore_optimization;
6729 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6730 o->op_targ = o->op_next->op_targ;
6731 o->op_next->op_targ = 0;
6732 o->op_private |= OPpTARGET_MY;
6735 op_null(o->op_next);
6737 ignore_optimization:
6738 o->op_seq = PL_op_seqmax++;
6741 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6742 o->op_seq = PL_op_seqmax++;
6743 break; /* Scalar stub must produce undef. List stub is noop */
6747 if (o->op_targ == OP_NEXTSTATE
6748 || o->op_targ == OP_DBSTATE
6749 || o->op_targ == OP_SETSTATE)
6751 PL_curcop = ((COP*)o);
6758 if (oldop && o->op_next) {
6759 oldop->op_next = o->op_next;
6762 o->op_seq = PL_op_seqmax++;
6766 if (o->op_next->op_type == OP_RV2SV) {
6767 if (!(o->op_next->op_private & OPpDEREF)) {
6768 op_null(o->op_next);
6769 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6771 o->op_next = o->op_next->op_next;
6772 o->op_type = OP_GVSV;
6773 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6776 else if (o->op_next->op_type == OP_RV2AV) {
6777 OP* pop = o->op_next->op_next;
6779 if (pop->op_type == OP_CONST &&
6780 (PL_op = pop->op_next) &&
6781 pop->op_next->op_type == OP_AELEM &&
6782 !(pop->op_next->op_private &
6783 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6784 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6789 op_null(o->op_next);
6790 op_null(pop->op_next);
6792 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6793 o->op_next = pop->op_next->op_next;
6794 o->op_type = OP_AELEMFAST;
6795 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6796 o->op_private = (U8)i;
6801 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6803 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6804 /* XXX could check prototype here instead of just carping */
6805 SV *sv = sv_newmortal();
6806 gv_efullname3(sv, gv, Nullch);
6807 Perl_warner(aTHX_ WARN_PROTOTYPE,
6808 "%s() called too early to check prototype",
6813 o->op_seq = PL_op_seqmax++;
6824 o->op_seq = PL_op_seqmax++;
6825 while (cLOGOP->op_other->op_type == OP_NULL)
6826 cLOGOP->op_other = cLOGOP->op_other->op_next;
6827 peep(cLOGOP->op_other);
6832 o->op_seq = PL_op_seqmax++;
6833 while (cLOOP->op_redoop->op_type == OP_NULL)
6834 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6835 peep(cLOOP->op_redoop);
6836 while (cLOOP->op_nextop->op_type == OP_NULL)
6837 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6838 peep(cLOOP->op_nextop);
6839 while (cLOOP->op_lastop->op_type == OP_NULL)
6840 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6841 peep(cLOOP->op_lastop);
6847 o->op_seq = PL_op_seqmax++;
6848 while (cPMOP->op_pmreplstart &&
6849 cPMOP->op_pmreplstart->op_type == OP_NULL)
6850 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6851 peep(cPMOP->op_pmreplstart);
6855 o->op_seq = PL_op_seqmax++;
6856 if (ckWARN(WARN_SYNTAX) && o->op_next
6857 && o->op_next->op_type == OP_NEXTSTATE) {
6858 if (o->op_next->op_sibling &&
6859 o->op_next->op_sibling->op_type != OP_EXIT &&
6860 o->op_next->op_sibling->op_type != OP_WARN &&
6861 o->op_next->op_sibling->op_type != OP_DIE) {
6862 line_t oldline = CopLINE(PL_curcop);
6864 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6865 Perl_warner(aTHX_ WARN_EXEC,
6866 "Statement unlikely to be reached");
6867 Perl_warner(aTHX_ WARN_EXEC,
6868 "\t(Maybe you meant system() when you said exec()?)\n");
6869 CopLINE_set(PL_curcop, oldline);
6878 SV **svp, **indsvp, *sv;
6883 o->op_seq = PL_op_seqmax++;
6885 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6888 /* Make the CONST have a shared SV */
6889 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6890 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6891 key = SvPV(sv, keylen);
6894 lexname = newSVpvn_share(key, keylen, 0);
6899 if ((o->op_private & (OPpLVAL_INTRO)))
6902 rop = (UNOP*)((BINOP*)o)->op_first;
6903 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6905 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6906 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6908 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6909 if (!fields || !GvHV(*fields))
6911 key = SvPV(*svp, keylen);
6914 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6916 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6917 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6919 ind = SvIV(*indsvp);
6921 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6922 rop->op_type = OP_RV2AV;
6923 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6924 o->op_type = OP_AELEM;
6925 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6927 if (SvREADONLY(*svp))
6929 SvFLAGS(sv) |= (SvFLAGS(*svp)
6930 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6940 SV **svp, **indsvp, *sv;
6944 SVOP *first_key_op, *key_op;
6946 o->op_seq = PL_op_seqmax++;
6947 if ((o->op_private & (OPpLVAL_INTRO))
6948 /* I bet there's always a pushmark... */
6949 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6950 /* hmmm, no optimization if list contains only one key. */
6952 rop = (UNOP*)((LISTOP*)o)->op_last;
6953 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6955 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6956 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6958 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6959 if (!fields || !GvHV(*fields))
6961 /* Again guessing that the pushmark can be jumped over.... */
6962 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6963 ->op_first->op_sibling;
6964 /* Check that the key list contains only constants. */
6965 for (key_op = first_key_op; key_op;
6966 key_op = (SVOP*)key_op->op_sibling)
6967 if (key_op->op_type != OP_CONST)
6971 rop->op_type = OP_RV2AV;
6972 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6973 o->op_type = OP_ASLICE;
6974 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6975 for (key_op = first_key_op; key_op;
6976 key_op = (SVOP*)key_op->op_sibling) {
6977 svp = cSVOPx_svp(key_op);
6978 key = SvPV(*svp, keylen);
6981 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6983 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6984 "in variable %s of type %s",
6985 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6987 ind = SvIV(*indsvp);
6989 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6991 if (SvREADONLY(*svp))
6993 SvFLAGS(sv) |= (SvFLAGS(*svp)
6994 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7002 o->op_seq = PL_op_seqmax++;
7012 /* Efficient sub that returns a constant scalar value. */
7014 const_sv_xsub(pTHXo_ CV* cv)
7019 Perl_croak(aTHX_ "usage: %s::%s()",
7020 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7024 ST(0) = (SV*)XSANY.any_ptr;