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 */
381 seq = cxstack[i].blk_oldcop->cop_seq;
384 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
392 Perl_pad_findmy(pTHX_ char *name)
397 SV **svp = AvARRAY(PL_comppad_name);
398 U32 seq = PL_cop_seqmax;
404 * Special case to get lexical (and hence per-thread) @_.
405 * XXX I need to find out how to tell at parse-time whether use
406 * of @_ should refer to a lexical (from a sub) or defgv (global
407 * scope and maybe weird sub-ish things like formats). See
408 * startsub in perly.y. It's possible that @_ could be lexical
409 * (at least from subs) even in non-threaded perl.
411 if (strEQ(name, "@_"))
412 return 0; /* success. (NOT_IN_PAD indicates failure) */
413 #endif /* USE_THREADS */
415 /* The one we're looking for is probably just before comppad_name_fill. */
416 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
417 if ((sv = svp[off]) &&
418 sv != &PL_sv_undef &&
421 seq > I_32(SvNVX(sv)))) &&
422 strEQ(SvPVX(sv), name))
424 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
425 return (PADOFFSET)off;
426 pendoff = off; /* this pending def. will override import */
430 outside = CvOUTSIDE(PL_compcv);
432 /* Check if if we're compiling an eval'', and adjust seq to be the
433 * eval's seq number. This depends on eval'' having a non-null
434 * CvOUTSIDE() while it is being compiled. The eval'' itself is
435 * identified by CvEVAL being true and CvGV being null. */
436 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
437 cx = &cxstack[cxstack_ix];
439 seq = cx->blk_oldcop->cop_seq;
442 /* See if it's in a nested scope */
443 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
445 /* If there is a pending local definition, this new alias must die */
447 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
448 return off; /* pad_findlex returns 0 for failure...*/
450 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
454 Perl_pad_leavemy(pTHX_ I32 fill)
457 SV **svp = AvARRAY(PL_comppad_name);
459 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
460 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
461 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
462 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
465 /* "Deintroduce" my variables that are leaving with this scope. */
466 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
467 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
468 SvIVX(sv) = PL_cop_seqmax;
473 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
478 if (AvARRAY(PL_comppad) != PL_curpad)
479 Perl_croak(aTHX_ "panic: pad_alloc");
480 if (PL_pad_reset_pending)
482 if (tmptype & SVs_PADMY) {
484 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
485 } while (SvPADBUSY(sv)); /* need a fresh one */
486 retval = AvFILLp(PL_comppad);
489 SV **names = AvARRAY(PL_comppad_name);
490 SSize_t names_fill = AvFILLp(PL_comppad_name);
493 * "foreach" index vars temporarily become aliases to non-"my"
494 * values. Thus we must skip, not just pad values that are
495 * marked as current pad values, but also those with names.
497 if (++PL_padix <= names_fill &&
498 (sv = names[PL_padix]) && sv != &PL_sv_undef)
500 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
501 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
502 !IS_PADGV(sv) && !IS_PADCONST(sv))
507 SvFLAGS(sv) |= tmptype;
508 PL_curpad = AvARRAY(PL_comppad);
510 DEBUG_X(PerlIO_printf(Perl_debug_log,
511 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
512 PTR2UV(thr), PTR2UV(PL_curpad),
513 (long) retval, PL_op_name[optype]));
515 DEBUG_X(PerlIO_printf(Perl_debug_log,
516 "Pad 0x%"UVxf" alloc %ld for %s\n",
518 (long) retval, PL_op_name[optype]));
519 #endif /* USE_THREADS */
520 return (PADOFFSET)retval;
524 Perl_pad_sv(pTHX_ PADOFFSET po)
527 DEBUG_X(PerlIO_printf(Perl_debug_log,
528 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
529 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
532 Perl_croak(aTHX_ "panic: pad_sv po");
533 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
534 PTR2UV(PL_curpad), (IV)po));
535 #endif /* USE_THREADS */
536 return PL_curpad[po]; /* eventually we'll turn this into a macro */
540 Perl_pad_free(pTHX_ PADOFFSET po)
544 if (AvARRAY(PL_comppad) != PL_curpad)
545 Perl_croak(aTHX_ "panic: pad_free curpad");
547 Perl_croak(aTHX_ "panic: pad_free po");
549 DEBUG_X(PerlIO_printf(Perl_debug_log,
550 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
551 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
553 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
554 PTR2UV(PL_curpad), (IV)po));
555 #endif /* USE_THREADS */
556 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
557 SvPADTMP_off(PL_curpad[po]);
559 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
562 if ((I32)po < PL_padix)
567 Perl_pad_swipe(pTHX_ PADOFFSET po)
569 if (AvARRAY(PL_comppad) != PL_curpad)
570 Perl_croak(aTHX_ "panic: pad_swipe curpad");
572 Perl_croak(aTHX_ "panic: pad_swipe po");
574 DEBUG_X(PerlIO_printf(Perl_debug_log,
575 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
576 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
578 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
579 PTR2UV(PL_curpad), (IV)po));
580 #endif /* USE_THREADS */
581 SvPADTMP_off(PL_curpad[po]);
582 PL_curpad[po] = NEWSV(1107,0);
583 SvPADTMP_on(PL_curpad[po]);
584 if ((I32)po < PL_padix)
588 /* XXX pad_reset() is currently disabled because it results in serious bugs.
589 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
590 * on the stack by OPs that use them, there are several ways to get an alias
591 * to a shared TARG. Such an alias will change randomly and unpredictably.
592 * We avoid doing this until we can think of a Better Way.
597 #ifdef USE_BROKEN_PAD_RESET
600 if (AvARRAY(PL_comppad) != PL_curpad)
601 Perl_croak(aTHX_ "panic: pad_reset curpad");
603 DEBUG_X(PerlIO_printf(Perl_debug_log,
604 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
605 PTR2UV(thr), PTR2UV(PL_curpad)));
607 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
609 #endif /* USE_THREADS */
610 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
611 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
612 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
613 SvPADTMP_off(PL_curpad[po]);
615 PL_padix = PL_padix_floor;
618 PL_pad_reset_pending = FALSE;
622 /* find_threadsv is not reentrant */
624 Perl_find_threadsv(pTHX_ const char *name)
629 /* We currently only handle names of a single character */
630 p = strchr(PL_threadsv_names, *name);
633 key = p - PL_threadsv_names;
634 MUTEX_LOCK(&thr->mutex);
635 svp = av_fetch(thr->threadsv, key, FALSE);
637 MUTEX_UNLOCK(&thr->mutex);
639 SV *sv = NEWSV(0, 0);
640 av_store(thr->threadsv, key, sv);
641 thr->threadsvp = AvARRAY(thr->threadsv);
642 MUTEX_UNLOCK(&thr->mutex);
644 * Some magic variables used to be automagically initialised
645 * in gv_fetchpv. Those which are now per-thread magicals get
646 * initialised here instead.
652 sv_setpv(sv, "\034");
653 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
658 PL_sawampersand = TRUE;
672 /* XXX %! tied to Errno.pm needs to be added here.
673 * See gv_fetchpv(). */
677 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
679 DEBUG_S(PerlIO_printf(Perl_error_log,
680 "find_threadsv: new SV %p for $%s%c\n",
681 sv, (*name < 32) ? "^" : "",
682 (*name < 32) ? toCTRL(*name) : *name));
686 #endif /* USE_THREADS */
691 Perl_op_free(pTHX_ OP *o)
693 register OP *kid, *nextkid;
696 if (!o || o->op_seq == (U16)-1)
699 if (o->op_private & OPpREFCOUNTED) {
700 switch (o->op_type) {
708 if (OpREFCNT_dec(o)) {
719 if (o->op_flags & OPf_KIDS) {
720 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
721 nextkid = kid->op_sibling; /* Get before next freeing kid */
729 /* COP* is not cleared by op_clear() so that we may track line
730 * numbers etc even after null() */
731 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
736 #ifdef PL_OP_SLAB_ALLOC
737 if ((char *) o == PL_OpPtr)
746 Perl_op_clear(pTHX_ OP *o)
748 switch (o->op_type) {
749 case OP_NULL: /* Was holding old type, if any. */
750 case OP_ENTEREVAL: /* Was holding hints. */
752 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
758 if (!(o->op_flags & OPf_SPECIAL))
761 #endif /* USE_THREADS */
763 if (!(o->op_flags & OPf_REF)
764 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
771 if (cPADOPo->op_padix > 0) {
774 pad_swipe(cPADOPo->op_padix);
775 /* No GvIN_PAD_off(gv) here, because other references may still
776 * exist on the pad */
779 cPADOPo->op_padix = 0;
782 SvREFCNT_dec(cSVOPo->op_sv);
783 cSVOPo->op_sv = Nullsv;
786 case OP_METHOD_NAMED:
788 SvREFCNT_dec(cSVOPo->op_sv);
789 cSVOPo->op_sv = Nullsv;
795 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
799 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
800 SvREFCNT_dec(cSVOPo->op_sv);
801 cSVOPo->op_sv = Nullsv;
804 Safefree(cPVOPo->op_pv);
805 cPVOPo->op_pv = Nullch;
809 op_free(cPMOPo->op_pmreplroot);
813 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
815 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
816 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
817 /* No GvIN_PAD_off(gv) here, because other references may still
818 * exist on the pad */
823 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
830 HV *pmstash = PmopSTASH(cPMOPo);
831 if (pmstash && SvREFCNT(pmstash)) {
832 PMOP *pmop = HvPMROOT(pmstash);
833 PMOP *lastpmop = NULL;
835 if (cPMOPo == pmop) {
837 lastpmop->op_pmnext = pmop->op_pmnext;
839 HvPMROOT(pmstash) = pmop->op_pmnext;
843 pmop = pmop->op_pmnext;
846 Safefree(PmopSTASHPV(cPMOPo));
848 /* NOTE: PMOP.op_pmstash is not refcounted */
852 cPMOPo->op_pmreplroot = Nullop;
853 ReREFCNT_dec(PM_GETRE(cPMOPo));
854 PM_SETRE(cPMOPo, (REGEXP*)NULL);
858 if (o->op_targ > 0) {
859 pad_free(o->op_targ);
865 S_cop_free(pTHX_ COP* cop)
867 Safefree(cop->cop_label);
869 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
870 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
872 /* NOTE: COP.cop_stash is not refcounted */
873 SvREFCNT_dec(CopFILEGV(cop));
875 if (! specialWARN(cop->cop_warnings))
876 SvREFCNT_dec(cop->cop_warnings);
877 if (! specialCopIO(cop->cop_io))
878 SvREFCNT_dec(cop->cop_io);
882 Perl_op_null(pTHX_ OP *o)
884 if (o->op_type == OP_NULL)
887 o->op_targ = o->op_type;
888 o->op_type = OP_NULL;
889 o->op_ppaddr = PL_ppaddr[OP_NULL];
892 /* Contextualizers */
894 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
897 Perl_linklist(pTHX_ OP *o)
904 /* establish postfix order */
905 if (cUNOPo->op_first) {
906 o->op_next = LINKLIST(cUNOPo->op_first);
907 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
909 kid->op_next = LINKLIST(kid->op_sibling);
921 Perl_scalarkids(pTHX_ OP *o)
924 if (o && o->op_flags & OPf_KIDS) {
925 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
932 S_scalarboolean(pTHX_ OP *o)
934 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
935 if (ckWARN(WARN_SYNTAX)) {
936 line_t oldline = CopLINE(PL_curcop);
938 if (PL_copline != NOLINE)
939 CopLINE_set(PL_curcop, PL_copline);
940 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
941 CopLINE_set(PL_curcop, oldline);
948 Perl_scalar(pTHX_ OP *o)
952 /* assumes no premature commitment */
953 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
954 || o->op_type == OP_RETURN)
959 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
961 switch (o->op_type) {
963 scalar(cBINOPo->op_first);
968 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
972 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
973 if (!kPMOP->op_pmreplroot)
974 deprecate("implicit split to @_");
982 if (o->op_flags & OPf_KIDS) {
983 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
989 kid = cLISTOPo->op_first;
991 while ((kid = kid->op_sibling)) {
997 WITH_THR(PL_curcop = &PL_compiling);
1002 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1003 if (kid->op_sibling)
1008 WITH_THR(PL_curcop = &PL_compiling);
1015 Perl_scalarvoid(pTHX_ OP *o)
1022 if (o->op_type == OP_NEXTSTATE
1023 || o->op_type == OP_SETSTATE
1024 || o->op_type == OP_DBSTATE
1025 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1026 || o->op_targ == OP_SETSTATE
1027 || o->op_targ == OP_DBSTATE)))
1028 PL_curcop = (COP*)o; /* for warning below */
1030 /* assumes no premature commitment */
1031 want = o->op_flags & OPf_WANT;
1032 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1033 || o->op_type == OP_RETURN)
1038 if ((o->op_private & OPpTARGET_MY)
1039 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1041 return scalar(o); /* As if inside SASSIGN */
1044 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1046 switch (o->op_type) {
1048 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1052 if (o->op_flags & OPf_STACKED)
1056 if (o->op_private == 4)
1098 case OP_GETSOCKNAME:
1099 case OP_GETPEERNAME:
1104 case OP_GETPRIORITY:
1127 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1128 useless = PL_op_desc[o->op_type];
1135 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1136 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1137 useless = "a variable";
1142 if (cSVOPo->op_private & OPpCONST_STRICT)
1143 no_bareword_allowed(o);
1145 if (ckWARN(WARN_VOID)) {
1146 useless = "a constant";
1147 /* the constants 0 and 1 are permitted as they are
1148 conventionally used as dummies in constructs like
1149 1 while some_condition_with_side_effects; */
1150 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1152 else if (SvPOK(sv)) {
1153 /* perl4's way of mixing documentation and code
1154 (before the invention of POD) was based on a
1155 trick to mix nroff and perl code. The trick was
1156 built upon these three nroff macros being used in
1157 void context. The pink camel has the details in
1158 the script wrapman near page 319. */
1159 if (strnEQ(SvPVX(sv), "di", 2) ||
1160 strnEQ(SvPVX(sv), "ds", 2) ||
1161 strnEQ(SvPVX(sv), "ig", 2))
1166 op_null(o); /* don't execute or even remember it */
1170 o->op_type = OP_PREINC; /* pre-increment is faster */
1171 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1175 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1176 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1182 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1187 if (o->op_flags & OPf_STACKED)
1194 if (!(o->op_flags & OPf_KIDS))
1203 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1210 /* all requires must return a boolean value */
1211 o->op_flags &= ~OPf_WANT;
1216 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1217 if (!kPMOP->op_pmreplroot)
1218 deprecate("implicit split to @_");
1222 if (useless && ckWARN(WARN_VOID))
1223 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1228 Perl_listkids(pTHX_ OP *o)
1231 if (o && o->op_flags & OPf_KIDS) {
1232 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1239 Perl_list(pTHX_ OP *o)
1243 /* assumes no premature commitment */
1244 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1245 || o->op_type == OP_RETURN)
1250 if ((o->op_private & OPpTARGET_MY)
1251 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1253 return o; /* As if inside SASSIGN */
1256 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1258 switch (o->op_type) {
1261 list(cBINOPo->op_first);
1266 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1274 if (!(o->op_flags & OPf_KIDS))
1276 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1277 list(cBINOPo->op_first);
1278 return gen_constant_list(o);
1285 kid = cLISTOPo->op_first;
1287 while ((kid = kid->op_sibling)) {
1288 if (kid->op_sibling)
1293 WITH_THR(PL_curcop = &PL_compiling);
1297 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1298 if (kid->op_sibling)
1303 WITH_THR(PL_curcop = &PL_compiling);
1306 /* all requires must return a boolean value */
1307 o->op_flags &= ~OPf_WANT;
1314 Perl_scalarseq(pTHX_ OP *o)
1319 if (o->op_type == OP_LINESEQ ||
1320 o->op_type == OP_SCOPE ||
1321 o->op_type == OP_LEAVE ||
1322 o->op_type == OP_LEAVETRY)
1324 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1325 if (kid->op_sibling) {
1329 PL_curcop = &PL_compiling;
1331 o->op_flags &= ~OPf_PARENS;
1332 if (PL_hints & HINT_BLOCK_SCOPE)
1333 o->op_flags |= OPf_PARENS;
1336 o = newOP(OP_STUB, 0);
1341 S_modkids(pTHX_ OP *o, I32 type)
1344 if (o && o->op_flags & OPf_KIDS) {
1345 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1352 Perl_mod(pTHX_ OP *o, I32 type)
1357 if (!o || PL_error_count)
1360 if ((o->op_private & OPpTARGET_MY)
1361 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1366 switch (o->op_type) {
1371 if (!(o->op_private & (OPpCONST_ARYBASE)))
1373 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1374 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1378 SAVEI32(PL_compiling.cop_arybase);
1379 PL_compiling.cop_arybase = 0;
1381 else if (type == OP_REFGEN)
1384 Perl_croak(aTHX_ "That use of $[ is unsupported");
1387 if (o->op_flags & OPf_PARENS)
1391 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1392 !(o->op_flags & OPf_STACKED)) {
1393 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1394 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1395 assert(cUNOPo->op_first->op_type == OP_NULL);
1396 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1399 else { /* lvalue subroutine call */
1400 o->op_private |= OPpLVAL_INTRO;
1401 PL_modcount = RETURN_UNLIMITED_NUMBER;
1402 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1403 /* Backward compatibility mode: */
1404 o->op_private |= OPpENTERSUB_INARGS;
1407 else { /* Compile-time error message: */
1408 OP *kid = cUNOPo->op_first;
1412 if (kid->op_type == OP_PUSHMARK)
1414 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1416 "panic: unexpected lvalue entersub "
1417 "args: type/targ %ld:%ld",
1418 (long)kid->op_type,kid->op_targ);
1419 kid = kLISTOP->op_first;
1421 while (kid->op_sibling)
1422 kid = kid->op_sibling;
1423 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1425 if (kid->op_type == OP_METHOD_NAMED
1426 || kid->op_type == OP_METHOD)
1430 if (kid->op_sibling || kid->op_next != kid) {
1431 yyerror("panic: unexpected optree near method call");
1435 NewOp(1101, newop, 1, UNOP);
1436 newop->op_type = OP_RV2CV;
1437 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1438 newop->op_first = Nullop;
1439 newop->op_next = (OP*)newop;
1440 kid->op_sibling = (OP*)newop;
1441 newop->op_private |= OPpLVAL_INTRO;
1445 if (kid->op_type != OP_RV2CV)
1447 "panic: unexpected lvalue entersub "
1448 "entry via type/targ %ld:%ld",
1449 (long)kid->op_type,kid->op_targ);
1450 kid->op_private |= OPpLVAL_INTRO;
1451 break; /* Postpone until runtime */
1455 kid = kUNOP->op_first;
1456 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1457 kid = kUNOP->op_first;
1458 if (kid->op_type == OP_NULL)
1460 "Unexpected constant lvalue entersub "
1461 "entry via type/targ %ld:%ld",
1462 (long)kid->op_type,kid->op_targ);
1463 if (kid->op_type != OP_GV) {
1464 /* Restore RV2CV to check lvalueness */
1466 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1467 okid->op_next = kid->op_next;
1468 kid->op_next = okid;
1471 okid->op_next = Nullop;
1472 okid->op_type = OP_RV2CV;
1474 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1475 okid->op_private |= OPpLVAL_INTRO;
1479 cv = GvCV(kGVOP_gv);
1489 /* grep, foreach, subcalls, refgen */
1490 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1492 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1493 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1495 : (o->op_type == OP_ENTERSUB
1496 ? "non-lvalue subroutine call"
1497 : PL_op_desc[o->op_type])),
1498 type ? PL_op_desc[type] : "local"));
1512 case OP_RIGHT_SHIFT:
1521 if (!(o->op_flags & OPf_STACKED))
1527 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1533 if (!type && cUNOPo->op_first->op_type != OP_GV)
1534 Perl_croak(aTHX_ "Can't localize through a reference");
1535 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1536 PL_modcount = RETURN_UNLIMITED_NUMBER;
1537 return o; /* Treat \(@foo) like ordinary list. */
1541 if (scalar_mod_type(o, type))
1543 ref(cUNOPo->op_first, o->op_type);
1547 if (type == OP_LEAVESUBLV)
1548 o->op_private |= OPpMAYBE_LVSUB;
1554 PL_modcount = RETURN_UNLIMITED_NUMBER;
1557 if (!type && cUNOPo->op_first->op_type != OP_GV)
1558 Perl_croak(aTHX_ "Can't localize through a reference");
1559 ref(cUNOPo->op_first, o->op_type);
1563 PL_hints |= HINT_BLOCK_SCOPE;
1573 PL_modcount = RETURN_UNLIMITED_NUMBER;
1574 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1575 return o; /* Treat \(@foo) like ordinary list. */
1576 if (scalar_mod_type(o, type))
1578 if (type == OP_LEAVESUBLV)
1579 o->op_private |= OPpMAYBE_LVSUB;
1584 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1585 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1590 PL_modcount++; /* XXX ??? */
1592 #endif /* USE_THREADS */
1598 if (type != OP_SASSIGN)
1602 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1607 if (type == OP_LEAVESUBLV)
1608 o->op_private |= OPpMAYBE_LVSUB;
1610 pad_free(o->op_targ);
1611 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1612 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1613 if (o->op_flags & OPf_KIDS)
1614 mod(cBINOPo->op_first->op_sibling, type);
1619 ref(cBINOPo->op_first, o->op_type);
1620 if (type == OP_ENTERSUB &&
1621 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1622 o->op_private |= OPpLVAL_DEFER;
1623 if (type == OP_LEAVESUBLV)
1624 o->op_private |= OPpMAYBE_LVSUB;
1632 if (o->op_flags & OPf_KIDS)
1633 mod(cLISTOPo->op_last, type);
1637 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1639 else if (!(o->op_flags & OPf_KIDS))
1641 if (o->op_targ != OP_LIST) {
1642 mod(cBINOPo->op_first, type);
1647 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1652 if (type != OP_LEAVESUBLV)
1654 break; /* mod()ing was handled by ck_return() */
1656 if (type != OP_LEAVESUBLV)
1657 o->op_flags |= OPf_MOD;
1659 if (type == OP_AASSIGN || type == OP_SASSIGN)
1660 o->op_flags |= OPf_SPECIAL|OPf_REF;
1662 o->op_private |= OPpLVAL_INTRO;
1663 o->op_flags &= ~OPf_SPECIAL;
1664 PL_hints |= HINT_BLOCK_SCOPE;
1666 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1667 && type != OP_LEAVESUBLV)
1668 o->op_flags |= OPf_REF;
1673 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1677 if (o->op_type == OP_RV2GV)
1701 case OP_RIGHT_SHIFT:
1720 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1722 switch (o->op_type) {
1730 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1743 Perl_refkids(pTHX_ OP *o, I32 type)
1746 if (o && o->op_flags & OPf_KIDS) {
1747 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1754 Perl_ref(pTHX_ OP *o, I32 type)
1758 if (!o || PL_error_count)
1761 switch (o->op_type) {
1763 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1764 !(o->op_flags & OPf_STACKED)) {
1765 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1766 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1767 assert(cUNOPo->op_first->op_type == OP_NULL);
1768 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1769 o->op_flags |= OPf_SPECIAL;
1774 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1778 if (type == OP_DEFINED)
1779 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1780 ref(cUNOPo->op_first, o->op_type);
1783 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1784 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1785 : type == OP_RV2HV ? OPpDEREF_HV
1787 o->op_flags |= OPf_MOD;
1792 o->op_flags |= OPf_MOD; /* XXX ??? */
1797 o->op_flags |= OPf_REF;
1800 if (type == OP_DEFINED)
1801 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1802 ref(cUNOPo->op_first, o->op_type);
1807 o->op_flags |= OPf_REF;
1812 if (!(o->op_flags & OPf_KIDS))
1814 ref(cBINOPo->op_first, type);
1818 ref(cBINOPo->op_first, o->op_type);
1819 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1820 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1821 : type == OP_RV2HV ? OPpDEREF_HV
1823 o->op_flags |= OPf_MOD;
1831 if (!(o->op_flags & OPf_KIDS))
1833 ref(cLISTOPo->op_last, type);
1843 S_dup_attrlist(pTHX_ OP *o)
1847 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1848 * where the first kid is OP_PUSHMARK and the remaining ones
1849 * are OP_CONST. We need to push the OP_CONST values.
1851 if (o->op_type == OP_CONST)
1852 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1854 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1855 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1856 if (o->op_type == OP_CONST)
1857 rop = append_elem(OP_LIST, rop,
1858 newSVOP(OP_CONST, o->op_flags,
1859 SvREFCNT_inc(cSVOPo->op_sv)));
1866 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1870 /* fake up C<use attributes $pkg,$rv,@attrs> */
1871 ENTER; /* need to protect against side-effects of 'use' */
1874 stashsv = newSVpv(HvNAME(stash), 0);
1876 stashsv = &PL_sv_no;
1878 #define ATTRSMODULE "attributes"
1880 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1881 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1883 prepend_elem(OP_LIST,
1884 newSVOP(OP_CONST, 0, stashsv),
1885 prepend_elem(OP_LIST,
1886 newSVOP(OP_CONST, 0,
1888 dup_attrlist(attrs))));
1893 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1894 char *attrstr, STRLEN len)
1899 len = strlen(attrstr);
1903 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1905 char *sstr = attrstr;
1906 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1907 attrs = append_elem(OP_LIST, attrs,
1908 newSVOP(OP_CONST, 0,
1909 newSVpvn(sstr, attrstr-sstr)));
1913 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1914 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1915 Nullsv, prepend_elem(OP_LIST,
1916 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1917 prepend_elem(OP_LIST,
1918 newSVOP(OP_CONST, 0,
1924 S_my_kid(pTHX_ OP *o, OP *attrs)
1929 if (!o || PL_error_count)
1933 if (type == OP_LIST) {
1934 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1936 } else if (type == OP_UNDEF) {
1938 } else if (type == OP_RV2SV || /* "our" declaration */
1940 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1942 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1944 PL_in_my_stash = Nullhv;
1945 apply_attrs(GvSTASH(gv),
1946 (type == OP_RV2SV ? GvSV(gv) :
1947 type == OP_RV2AV ? (SV*)GvAV(gv) :
1948 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1951 o->op_private |= OPpOUR_INTRO;
1953 } else if (type != OP_PADSV &&
1956 type != OP_PUSHMARK)
1958 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1959 PL_op_desc[o->op_type],
1960 PL_in_my == KEY_our ? "our" : "my"));
1963 else if (attrs && type != OP_PUSHMARK) {
1969 PL_in_my_stash = Nullhv;
1971 /* check for C<my Dog $spot> when deciding package */
1972 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1973 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1974 stash = SvSTASH(*namesvp);
1976 stash = PL_curstash;
1977 padsv = PAD_SV(o->op_targ);
1978 apply_attrs(stash, padsv, attrs);
1980 o->op_flags |= OPf_MOD;
1981 o->op_private |= OPpLVAL_INTRO;
1986 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1988 if (o->op_flags & OPf_PARENS)
1992 o = my_kid(o, attrs);
1994 PL_in_my_stash = Nullhv;
1999 Perl_my(pTHX_ OP *o)
2001 return my_kid(o, Nullop);
2005 Perl_sawparens(pTHX_ OP *o)
2008 o->op_flags |= OPf_PARENS;
2013 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2017 if (ckWARN(WARN_MISC) &&
2018 (left->op_type == OP_RV2AV ||
2019 left->op_type == OP_RV2HV ||
2020 left->op_type == OP_PADAV ||
2021 left->op_type == OP_PADHV)) {
2022 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2023 right->op_type == OP_TRANS)
2024 ? right->op_type : OP_MATCH];
2025 const char *sample = ((left->op_type == OP_RV2AV ||
2026 left->op_type == OP_PADAV)
2027 ? "@array" : "%hash");
2028 Perl_warner(aTHX_ WARN_MISC,
2029 "Applying %s to %s will act on scalar(%s)",
2030 desc, sample, sample);
2033 if (!(right->op_flags & OPf_STACKED) &&
2034 (right->op_type == OP_MATCH ||
2035 right->op_type == OP_SUBST ||
2036 right->op_type == OP_TRANS)) {
2037 right->op_flags |= OPf_STACKED;
2038 if ((right->op_type != OP_MATCH &&
2039 ! (right->op_type == OP_TRANS &&
2040 right->op_private & OPpTRANS_IDENTICAL)) ||
2041 /* if SV has magic, then match on original SV, not on its copy.
2042 see note in pp_helem() */
2043 (right->op_type == OP_MATCH &&
2044 (left->op_type == OP_AELEM ||
2045 left->op_type == OP_HELEM ||
2046 left->op_type == OP_AELEMFAST)))
2047 left = mod(left, right->op_type);
2048 if (right->op_type == OP_TRANS)
2049 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2051 o = prepend_elem(right->op_type, scalar(left), right);
2053 return newUNOP(OP_NOT, 0, scalar(o));
2057 return bind_match(type, left,
2058 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2062 Perl_invert(pTHX_ OP *o)
2066 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2067 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2071 Perl_scope(pTHX_ OP *o)
2074 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2075 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2076 o->op_type = OP_LEAVE;
2077 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2080 if (o->op_type == OP_LINESEQ) {
2082 o->op_type = OP_SCOPE;
2083 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2084 kid = ((LISTOP*)o)->op_first;
2085 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2089 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2096 Perl_save_hints(pTHX)
2099 SAVESPTR(GvHV(PL_hintgv));
2100 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2101 SAVEFREESV(GvHV(PL_hintgv));
2105 Perl_block_start(pTHX_ int full)
2107 int retval = PL_savestack_ix;
2109 SAVEI32(PL_comppad_name_floor);
2110 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2112 PL_comppad_name_fill = PL_comppad_name_floor;
2113 if (PL_comppad_name_floor < 0)
2114 PL_comppad_name_floor = 0;
2115 SAVEI32(PL_min_intro_pending);
2116 SAVEI32(PL_max_intro_pending);
2117 PL_min_intro_pending = 0;
2118 SAVEI32(PL_comppad_name_fill);
2119 SAVEI32(PL_padix_floor);
2120 PL_padix_floor = PL_padix;
2121 PL_pad_reset_pending = FALSE;
2123 PL_hints &= ~HINT_BLOCK_SCOPE;
2124 SAVESPTR(PL_compiling.cop_warnings);
2125 if (! specialWARN(PL_compiling.cop_warnings)) {
2126 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2127 SAVEFREESV(PL_compiling.cop_warnings) ;
2129 SAVESPTR(PL_compiling.cop_io);
2130 if (! specialCopIO(PL_compiling.cop_io)) {
2131 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2132 SAVEFREESV(PL_compiling.cop_io) ;
2138 Perl_block_end(pTHX_ I32 floor, OP *seq)
2140 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2141 OP* retval = scalarseq(seq);
2143 PL_pad_reset_pending = FALSE;
2144 PL_compiling.op_private = PL_hints;
2146 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2147 pad_leavemy(PL_comppad_name_fill);
2156 OP *o = newOP(OP_THREADSV, 0);
2157 o->op_targ = find_threadsv("_");
2160 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2161 #endif /* USE_THREADS */
2165 Perl_newPROG(pTHX_ OP *o)
2170 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2171 ((PL_in_eval & EVAL_KEEPERR)
2172 ? OPf_SPECIAL : 0), o);
2173 PL_eval_start = linklist(PL_eval_root);
2174 PL_eval_root->op_private |= OPpREFCOUNTED;
2175 OpREFCNT_set(PL_eval_root, 1);
2176 PL_eval_root->op_next = 0;
2177 peep(PL_eval_start);
2182 PL_main_root = scope(sawparens(scalarvoid(o)));
2183 PL_curcop = &PL_compiling;
2184 PL_main_start = LINKLIST(PL_main_root);
2185 PL_main_root->op_private |= OPpREFCOUNTED;
2186 OpREFCNT_set(PL_main_root, 1);
2187 PL_main_root->op_next = 0;
2188 peep(PL_main_start);
2191 /* Register with debugger */
2193 CV *cv = get_cv("DB::postponed", FALSE);
2197 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2199 call_sv((SV*)cv, G_DISCARD);
2206 Perl_localize(pTHX_ OP *o, I32 lex)
2208 if (o->op_flags & OPf_PARENS)
2211 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2213 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2214 if (*s == ';' || *s == '=')
2215 Perl_warner(aTHX_ WARN_PARENTHESIS,
2216 "Parentheses missing around \"%s\" list",
2217 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2223 o = mod(o, OP_NULL); /* a bit kludgey */
2225 PL_in_my_stash = Nullhv;
2230 Perl_jmaybe(pTHX_ OP *o)
2232 if (o->op_type == OP_LIST) {
2235 o2 = newOP(OP_THREADSV, 0);
2236 o2->op_targ = find_threadsv(";");
2238 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2239 #endif /* USE_THREADS */
2240 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2246 Perl_fold_constants(pTHX_ register OP *o)
2249 I32 type = o->op_type;
2252 if (PL_opargs[type] & OA_RETSCALAR)
2254 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2255 o->op_targ = pad_alloc(type, SVs_PADTMP);
2257 /* integerize op, unless it happens to be C<-foo>.
2258 * XXX should pp_i_negate() do magic string negation instead? */
2259 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2260 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2261 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2263 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2266 if (!(PL_opargs[type] & OA_FOLDCONST))
2271 /* XXX might want a ck_negate() for this */
2272 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2284 /* XXX what about the numeric ops? */
2285 if (PL_hints & HINT_LOCALE)
2290 goto nope; /* Don't try to run w/ errors */
2292 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2293 if ((curop->op_type != OP_CONST ||
2294 (curop->op_private & OPpCONST_BARE)) &&
2295 curop->op_type != OP_LIST &&
2296 curop->op_type != OP_SCALAR &&
2297 curop->op_type != OP_NULL &&
2298 curop->op_type != OP_PUSHMARK)
2304 curop = LINKLIST(o);
2308 sv = *(PL_stack_sp--);
2309 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2310 pad_swipe(o->op_targ);
2311 else if (SvTEMP(sv)) { /* grab mortal temp? */
2312 (void)SvREFCNT_inc(sv);
2316 if (type == OP_RV2GV)
2317 return newGVOP(OP_GV, 0, (GV*)sv);
2319 /* try to smush double to int, but don't smush -2.0 to -2 */
2320 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2323 #ifdef PERL_PRESERVE_IVUV
2324 /* Only bother to attempt to fold to IV if
2325 most operators will benefit */
2329 return newSVOP(OP_CONST, 0, sv);
2333 if (!(PL_opargs[type] & OA_OTHERINT))
2336 if (!(PL_hints & HINT_INTEGER)) {
2337 if (type == OP_MODULO
2338 || type == OP_DIVIDE
2339 || !(o->op_flags & OPf_KIDS))
2344 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2345 if (curop->op_type == OP_CONST) {
2346 if (SvIOK(((SVOP*)curop)->op_sv))
2350 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2354 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2361 Perl_gen_constant_list(pTHX_ register OP *o)
2364 I32 oldtmps_floor = PL_tmps_floor;
2368 return o; /* Don't attempt to run with errors */
2370 PL_op = curop = LINKLIST(o);
2377 PL_tmps_floor = oldtmps_floor;
2379 o->op_type = OP_RV2AV;
2380 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2381 curop = ((UNOP*)o)->op_first;
2382 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2389 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2391 if (!o || o->op_type != OP_LIST)
2392 o = newLISTOP(OP_LIST, 0, o, Nullop);
2394 o->op_flags &= ~OPf_WANT;
2396 if (!(PL_opargs[type] & OA_MARK))
2397 op_null(cLISTOPo->op_first);
2400 o->op_ppaddr = PL_ppaddr[type];
2401 o->op_flags |= flags;
2403 o = CHECKOP(type, o);
2404 if (o->op_type != type)
2407 return fold_constants(o);
2410 /* List constructors */
2413 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2421 if (first->op_type != type
2422 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2424 return newLISTOP(type, 0, first, last);
2427 if (first->op_flags & OPf_KIDS)
2428 ((LISTOP*)first)->op_last->op_sibling = last;
2430 first->op_flags |= OPf_KIDS;
2431 ((LISTOP*)first)->op_first = last;
2433 ((LISTOP*)first)->op_last = last;
2438 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2446 if (first->op_type != type)
2447 return prepend_elem(type, (OP*)first, (OP*)last);
2449 if (last->op_type != type)
2450 return append_elem(type, (OP*)first, (OP*)last);
2452 first->op_last->op_sibling = last->op_first;
2453 first->op_last = last->op_last;
2454 first->op_flags |= (last->op_flags & OPf_KIDS);
2456 #ifdef PL_OP_SLAB_ALLOC
2464 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2472 if (last->op_type == type) {
2473 if (type == OP_LIST) { /* already a PUSHMARK there */
2474 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2475 ((LISTOP*)last)->op_first->op_sibling = first;
2476 if (!(first->op_flags & OPf_PARENS))
2477 last->op_flags &= ~OPf_PARENS;
2480 if (!(last->op_flags & OPf_KIDS)) {
2481 ((LISTOP*)last)->op_last = first;
2482 last->op_flags |= OPf_KIDS;
2484 first->op_sibling = ((LISTOP*)last)->op_first;
2485 ((LISTOP*)last)->op_first = first;
2487 last->op_flags |= OPf_KIDS;
2491 return newLISTOP(type, 0, first, last);
2497 Perl_newNULLLIST(pTHX)
2499 return newOP(OP_STUB, 0);
2503 Perl_force_list(pTHX_ OP *o)
2505 if (!o || o->op_type != OP_LIST)
2506 o = newLISTOP(OP_LIST, 0, o, Nullop);
2512 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2516 NewOp(1101, listop, 1, LISTOP);
2518 listop->op_type = type;
2519 listop->op_ppaddr = PL_ppaddr[type];
2522 listop->op_flags = flags;
2526 else if (!first && last)
2529 first->op_sibling = last;
2530 listop->op_first = first;
2531 listop->op_last = last;
2532 if (type == OP_LIST) {
2534 pushop = newOP(OP_PUSHMARK, 0);
2535 pushop->op_sibling = first;
2536 listop->op_first = pushop;
2537 listop->op_flags |= OPf_KIDS;
2539 listop->op_last = pushop;
2546 Perl_newOP(pTHX_ I32 type, I32 flags)
2549 NewOp(1101, o, 1, OP);
2551 o->op_ppaddr = PL_ppaddr[type];
2552 o->op_flags = flags;
2555 o->op_private = 0 + (flags >> 8);
2556 if (PL_opargs[type] & OA_RETSCALAR)
2558 if (PL_opargs[type] & OA_TARGET)
2559 o->op_targ = pad_alloc(type, SVs_PADTMP);
2560 return CHECKOP(type, o);
2564 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2569 first = newOP(OP_STUB, 0);
2570 if (PL_opargs[type] & OA_MARK)
2571 first = force_list(first);
2573 NewOp(1101, unop, 1, UNOP);
2574 unop->op_type = type;
2575 unop->op_ppaddr = PL_ppaddr[type];
2576 unop->op_first = first;
2577 unop->op_flags = flags | OPf_KIDS;
2578 unop->op_private = 1 | (flags >> 8);
2579 unop = (UNOP*) CHECKOP(type, unop);
2583 return fold_constants((OP *) unop);
2587 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2590 NewOp(1101, binop, 1, BINOP);
2593 first = newOP(OP_NULL, 0);
2595 binop->op_type = type;
2596 binop->op_ppaddr = PL_ppaddr[type];
2597 binop->op_first = first;
2598 binop->op_flags = flags | OPf_KIDS;
2601 binop->op_private = 1 | (flags >> 8);
2604 binop->op_private = 2 | (flags >> 8);
2605 first->op_sibling = last;
2608 binop = (BINOP*)CHECKOP(type, binop);
2609 if (binop->op_next || binop->op_type != type)
2612 binop->op_last = binop->op_first->op_sibling;
2614 return fold_constants((OP *)binop);
2618 uvcompare(const void *a, const void *b)
2620 if (*((UV *)a) < (*(UV *)b))
2622 if (*((UV *)a) > (*(UV *)b))
2624 if (*((UV *)a+1) < (*(UV *)b+1))
2626 if (*((UV *)a+1) > (*(UV *)b+1))
2632 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2634 SV *tstr = ((SVOP*)expr)->op_sv;
2635 SV *rstr = ((SVOP*)repl)->op_sv;
2638 U8 *t = (U8*)SvPV(tstr, tlen);
2639 U8 *r = (U8*)SvPV(rstr, rlen);
2646 register short *tbl;
2648 PL_hints |= HINT_BLOCK_SCOPE;
2649 complement = o->op_private & OPpTRANS_COMPLEMENT;
2650 del = o->op_private & OPpTRANS_DELETE;
2651 squash = o->op_private & OPpTRANS_SQUASH;
2654 o->op_private |= OPpTRANS_FROM_UTF;
2657 o->op_private |= OPpTRANS_TO_UTF;
2659 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2660 SV* listsv = newSVpvn("# comment\n",10);
2662 U8* tend = t + tlen;
2663 U8* rend = r + rlen;
2677 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2678 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2684 tsave = t = bytes_to_utf8(t, &len);
2687 if (!to_utf && rlen) {
2689 rsave = r = bytes_to_utf8(r, &len);
2693 /* There are several snags with this code on EBCDIC:
2694 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2695 2. scan_const() in toke.c has encoded chars in native encoding which makes
2696 ranges at least in EBCDIC 0..255 range the bottom odd.
2700 U8 tmpbuf[UTF8_MAXLEN+1];
2703 New(1109, cp, 2*tlen, UV);
2705 transv = newSVpvn("",0);
2707 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2709 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2711 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2715 cp[2*i+1] = cp[2*i];
2719 qsort(cp, i, 2*sizeof(UV), uvcompare);
2720 for (j = 0; j < i; j++) {
2722 diff = val - nextmin;
2724 t = uvuni_to_utf8(tmpbuf,nextmin);
2725 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2727 U8 range_mark = UTF_TO_NATIVE(0xff);
2728 t = uvuni_to_utf8(tmpbuf, val - 1);
2729 sv_catpvn(transv, (char *)&range_mark, 1);
2730 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2737 t = uvuni_to_utf8(tmpbuf,nextmin);
2738 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2740 U8 range_mark = UTF_TO_NATIVE(0xff);
2741 sv_catpvn(transv, (char *)&range_mark, 1);
2743 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2744 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2745 t = (U8*)SvPVX(transv);
2746 tlen = SvCUR(transv);
2750 else if (!rlen && !del) {
2751 r = t; rlen = tlen; rend = tend;
2754 if ((!rlen && !del) || t == r ||
2755 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2757 o->op_private |= OPpTRANS_IDENTICAL;
2761 while (t < tend || tfirst <= tlast) {
2762 /* see if we need more "t" chars */
2763 if (tfirst > tlast) {
2764 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2766 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2768 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2775 /* now see if we need more "r" chars */
2776 if (rfirst > rlast) {
2778 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2780 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2782 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2791 rfirst = rlast = 0xffffffff;
2795 /* now see which range will peter our first, if either. */
2796 tdiff = tlast - tfirst;
2797 rdiff = rlast - rfirst;
2804 if (rfirst == 0xffffffff) {
2805 diff = tdiff; /* oops, pretend rdiff is infinite */
2807 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2808 (long)tfirst, (long)tlast);
2810 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2814 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2815 (long)tfirst, (long)(tfirst + diff),
2818 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2819 (long)tfirst, (long)rfirst);
2821 if (rfirst + diff > max)
2822 max = rfirst + diff;
2824 grows = (tfirst < rfirst &&
2825 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2837 else if (max > 0xff)
2842 Safefree(cPVOPo->op_pv);
2843 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2844 SvREFCNT_dec(listsv);
2846 SvREFCNT_dec(transv);
2848 if (!del && havefinal && rlen)
2849 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2850 newSVuv((UV)final), 0);
2853 o->op_private |= OPpTRANS_GROWS;
2865 tbl = (short*)cPVOPo->op_pv;
2867 Zero(tbl, 256, short);
2868 for (i = 0; i < tlen; i++)
2870 for (i = 0, j = 0; i < 256; i++) {
2881 if (i < 128 && r[j] >= 128)
2891 o->op_private |= OPpTRANS_IDENTICAL;
2896 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2897 tbl[0x100] = rlen - j;
2898 for (i=0; i < rlen - j; i++)
2899 tbl[0x101+i] = r[j+i];
2903 if (!rlen && !del) {
2906 o->op_private |= OPpTRANS_IDENTICAL;
2908 for (i = 0; i < 256; i++)
2910 for (i = 0, j = 0; i < tlen; i++,j++) {
2913 if (tbl[t[i]] == -1)
2919 if (tbl[t[i]] == -1) {
2920 if (t[i] < 128 && r[j] >= 128)
2927 o->op_private |= OPpTRANS_GROWS;
2935 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2939 NewOp(1101, pmop, 1, PMOP);
2940 pmop->op_type = type;
2941 pmop->op_ppaddr = PL_ppaddr[type];
2942 pmop->op_flags = flags;
2943 pmop->op_private = 0 | (flags >> 8);
2945 if (PL_hints & HINT_RE_TAINT)
2946 pmop->op_pmpermflags |= PMf_RETAINT;
2947 if (PL_hints & HINT_LOCALE)
2948 pmop->op_pmpermflags |= PMf_LOCALE;
2949 pmop->op_pmflags = pmop->op_pmpermflags;
2951 /* link into pm list */
2952 if (type != OP_TRANS && PL_curstash) {
2953 pmop->op_pmnext = HvPMROOT(PL_curstash);
2954 HvPMROOT(PL_curstash) = pmop;
2955 PmopSTASH_set(pmop,PL_curstash);
2962 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2966 I32 repl_has_vars = 0;
2968 if (o->op_type == OP_TRANS)
2969 return pmtrans(o, expr, repl);
2971 PL_hints |= HINT_BLOCK_SCOPE;
2974 if (expr->op_type == OP_CONST) {
2976 SV *pat = ((SVOP*)expr)->op_sv;
2977 char *p = SvPV(pat, plen);
2978 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2979 sv_setpvn(pat, "\\s+", 3);
2980 p = SvPV(pat, plen);
2981 pm->op_pmflags |= PMf_SKIPWHITE;
2983 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2984 pm->op_pmdynflags |= PMdf_UTF8;
2985 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2986 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2987 pm->op_pmflags |= PMf_WHITE;
2991 if (PL_hints & HINT_UTF8)
2992 pm->op_pmdynflags |= PMdf_UTF8;
2993 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2994 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2996 : OP_REGCMAYBE),0,expr);
2998 NewOp(1101, rcop, 1, LOGOP);
2999 rcop->op_type = OP_REGCOMP;
3000 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3001 rcop->op_first = scalar(expr);
3002 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3003 ? (OPf_SPECIAL | OPf_KIDS)
3005 rcop->op_private = 1;
3008 /* establish postfix order */
3009 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3011 rcop->op_next = expr;
3012 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3015 rcop->op_next = LINKLIST(expr);
3016 expr->op_next = (OP*)rcop;
3019 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3024 if (pm->op_pmflags & PMf_EVAL) {
3026 if (CopLINE(PL_curcop) < PL_multi_end)
3027 CopLINE_set(PL_curcop, PL_multi_end);
3030 else if (repl->op_type == OP_THREADSV
3031 && strchr("&`'123456789+",
3032 PL_threadsv_names[repl->op_targ]))
3036 #endif /* USE_THREADS */
3037 else if (repl->op_type == OP_CONST)
3041 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3042 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3044 if (curop->op_type == OP_THREADSV) {
3046 if (strchr("&`'123456789+", curop->op_private))
3050 if (curop->op_type == OP_GV) {
3051 GV *gv = cGVOPx_gv(curop);
3053 if (strchr("&`'123456789+", *GvENAME(gv)))
3056 #endif /* USE_THREADS */
3057 else if (curop->op_type == OP_RV2CV)
3059 else if (curop->op_type == OP_RV2SV ||
3060 curop->op_type == OP_RV2AV ||
3061 curop->op_type == OP_RV2HV ||
3062 curop->op_type == OP_RV2GV) {
3063 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3066 else if (curop->op_type == OP_PADSV ||
3067 curop->op_type == OP_PADAV ||
3068 curop->op_type == OP_PADHV ||
3069 curop->op_type == OP_PADANY) {
3072 else if (curop->op_type == OP_PUSHRE)
3073 ; /* Okay here, dangerous in newASSIGNOP */
3083 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3084 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3085 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3086 prepend_elem(o->op_type, scalar(repl), o);
3089 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3090 pm->op_pmflags |= PMf_MAYBE_CONST;
3091 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3093 NewOp(1101, rcop, 1, LOGOP);
3094 rcop->op_type = OP_SUBSTCONT;
3095 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3096 rcop->op_first = scalar(repl);
3097 rcop->op_flags |= OPf_KIDS;
3098 rcop->op_private = 1;
3101 /* establish postfix order */
3102 rcop->op_next = LINKLIST(repl);
3103 repl->op_next = (OP*)rcop;
3105 pm->op_pmreplroot = scalar((OP*)rcop);
3106 pm->op_pmreplstart = LINKLIST(rcop);
3115 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3118 NewOp(1101, svop, 1, SVOP);
3119 svop->op_type = type;
3120 svop->op_ppaddr = PL_ppaddr[type];
3122 svop->op_next = (OP*)svop;
3123 svop->op_flags = flags;
3124 if (PL_opargs[type] & OA_RETSCALAR)
3126 if (PL_opargs[type] & OA_TARGET)
3127 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3128 return CHECKOP(type, svop);
3132 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3135 NewOp(1101, padop, 1, PADOP);
3136 padop->op_type = type;
3137 padop->op_ppaddr = PL_ppaddr[type];
3138 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3139 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3140 PL_curpad[padop->op_padix] = sv;
3142 padop->op_next = (OP*)padop;
3143 padop->op_flags = flags;
3144 if (PL_opargs[type] & OA_RETSCALAR)
3146 if (PL_opargs[type] & OA_TARGET)
3147 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3148 return CHECKOP(type, padop);
3152 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3156 return newPADOP(type, flags, SvREFCNT_inc(gv));
3158 return newSVOP(type, flags, SvREFCNT_inc(gv));
3163 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3166 NewOp(1101, pvop, 1, PVOP);
3167 pvop->op_type = type;
3168 pvop->op_ppaddr = PL_ppaddr[type];
3170 pvop->op_next = (OP*)pvop;
3171 pvop->op_flags = flags;
3172 if (PL_opargs[type] & OA_RETSCALAR)
3174 if (PL_opargs[type] & OA_TARGET)
3175 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3176 return CHECKOP(type, pvop);
3180 Perl_package(pTHX_ OP *o)
3184 save_hptr(&PL_curstash);
3185 save_item(PL_curstname);
3190 name = SvPV(sv, len);
3191 PL_curstash = gv_stashpvn(name,len,TRUE);
3192 sv_setpvn(PL_curstname, name, len);
3196 sv_setpv(PL_curstname,"<none>");
3197 PL_curstash = Nullhv;
3199 PL_hints |= HINT_BLOCK_SCOPE;
3200 PL_copline = NOLINE;
3205 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3211 if (id->op_type != OP_CONST)
3212 Perl_croak(aTHX_ "Module name must be constant");
3216 if (version != Nullop) {
3217 SV *vesv = ((SVOP*)version)->op_sv;
3219 if (arg == Nullop && !SvNIOKp(vesv)) {
3226 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3227 Perl_croak(aTHX_ "Version number must be constant number");
3229 /* Make copy of id so we don't free it twice */
3230 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3232 /* Fake up a method call to VERSION */
3233 meth = newSVpvn("VERSION",7);
3234 sv_upgrade(meth, SVt_PVIV);
3235 (void)SvIOK_on(meth);
3236 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3237 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3238 append_elem(OP_LIST,
3239 prepend_elem(OP_LIST, pack, list(version)),
3240 newSVOP(OP_METHOD_NAMED, 0, meth)));
3244 /* Fake up an import/unimport */
3245 if (arg && arg->op_type == OP_STUB)
3246 imop = arg; /* no import on explicit () */
3247 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3248 imop = Nullop; /* use 5.0; */
3253 /* Make copy of id so we don't free it twice */
3254 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3256 /* Fake up a method call to import/unimport */
3257 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3258 sv_upgrade(meth, SVt_PVIV);
3259 (void)SvIOK_on(meth);
3260 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3261 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3262 append_elem(OP_LIST,
3263 prepend_elem(OP_LIST, pack, list(arg)),
3264 newSVOP(OP_METHOD_NAMED, 0, meth)));
3267 /* Fake up the BEGIN {}, which does its thing immediately. */
3269 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3272 append_elem(OP_LINESEQ,
3273 append_elem(OP_LINESEQ,
3274 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3275 newSTATEOP(0, Nullch, veop)),
3276 newSTATEOP(0, Nullch, imop) ));
3278 PL_hints |= HINT_BLOCK_SCOPE;
3279 PL_copline = NOLINE;
3284 =for apidoc load_module
3286 Loads the module whose name is pointed to by the string part of name.
3287 Note that the actual module name, not its filename, should be given.
3288 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3289 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3290 (or 0 for no flags). ver, if specified, provides version semantics
3291 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3292 arguments can be used to specify arguments to the module's import()
3293 method, similar to C<use Foo::Bar VERSION LIST>.
3298 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3301 va_start(args, ver);
3302 vload_module(flags, name, ver, &args);
3306 #ifdef PERL_IMPLICIT_CONTEXT
3308 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3312 va_start(args, ver);
3313 vload_module(flags, name, ver, &args);
3319 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3321 OP *modname, *veop, *imop;
3323 modname = newSVOP(OP_CONST, 0, name);
3324 modname->op_private |= OPpCONST_BARE;
3326 veop = newSVOP(OP_CONST, 0, ver);
3330 if (flags & PERL_LOADMOD_NOIMPORT) {
3331 imop = sawparens(newNULLLIST());
3333 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3334 imop = va_arg(*args, OP*);
3339 sv = va_arg(*args, SV*);
3341 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3342 sv = va_arg(*args, SV*);
3346 line_t ocopline = PL_copline;
3347 int oexpect = PL_expect;
3349 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3350 veop, modname, imop);
3351 PL_expect = oexpect;
3352 PL_copline = ocopline;
3357 Perl_dofile(pTHX_ OP *term)
3362 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3363 if (!(gv && GvIMPORTED_CV(gv)))
3364 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3366 if (gv && GvIMPORTED_CV(gv)) {
3367 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3368 append_elem(OP_LIST, term,
3369 scalar(newUNOP(OP_RV2CV, 0,
3374 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3380 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3382 return newBINOP(OP_LSLICE, flags,
3383 list(force_list(subscript)),
3384 list(force_list(listval)) );
3388 S_list_assignment(pTHX_ register OP *o)
3393 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3394 o = cUNOPo->op_first;
3396 if (o->op_type == OP_COND_EXPR) {
3397 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3398 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3403 yyerror("Assignment to both a list and a scalar");
3407 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3408 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3409 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3412 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3415 if (o->op_type == OP_RV2SV)
3422 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3427 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3428 return newLOGOP(optype, 0,
3429 mod(scalar(left), optype),
3430 newUNOP(OP_SASSIGN, 0, scalar(right)));
3433 return newBINOP(optype, OPf_STACKED,
3434 mod(scalar(left), optype), scalar(right));
3438 if (list_assignment(left)) {
3442 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3443 left = mod(left, OP_AASSIGN);
3451 curop = list(force_list(left));
3452 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3453 o->op_private = 0 | (flags >> 8);
3454 for (curop = ((LISTOP*)curop)->op_first;
3455 curop; curop = curop->op_sibling)
3457 if (curop->op_type == OP_RV2HV &&
3458 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3459 o->op_private |= OPpASSIGN_HASH;
3463 if (!(left->op_private & OPpLVAL_INTRO)) {
3466 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3467 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3468 if (curop->op_type == OP_GV) {
3469 GV *gv = cGVOPx_gv(curop);
3470 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3472 SvCUR(gv) = PL_generation;
3474 else if (curop->op_type == OP_PADSV ||
3475 curop->op_type == OP_PADAV ||
3476 curop->op_type == OP_PADHV ||
3477 curop->op_type == OP_PADANY) {
3478 SV **svp = AvARRAY(PL_comppad_name);
3479 SV *sv = svp[curop->op_targ];
3480 if (SvCUR(sv) == PL_generation)
3482 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3484 else if (curop->op_type == OP_RV2CV)
3486 else if (curop->op_type == OP_RV2SV ||
3487 curop->op_type == OP_RV2AV ||
3488 curop->op_type == OP_RV2HV ||
3489 curop->op_type == OP_RV2GV) {
3490 if (lastop->op_type != OP_GV) /* funny deref? */
3493 else if (curop->op_type == OP_PUSHRE) {
3494 if (((PMOP*)curop)->op_pmreplroot) {
3496 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3498 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3500 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3502 SvCUR(gv) = PL_generation;
3511 o->op_private |= OPpASSIGN_COMMON;
3513 if (right && right->op_type == OP_SPLIT) {
3515 if ((tmpop = ((LISTOP*)right)->op_first) &&
3516 tmpop->op_type == OP_PUSHRE)
3518 PMOP *pm = (PMOP*)tmpop;
3519 if (left->op_type == OP_RV2AV &&
3520 !(left->op_private & OPpLVAL_INTRO) &&
3521 !(o->op_private & OPpASSIGN_COMMON) )
3523 tmpop = ((UNOP*)left)->op_first;
3524 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3526 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3527 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3529 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3530 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3532 pm->op_pmflags |= PMf_ONCE;
3533 tmpop = cUNOPo->op_first; /* to list (nulled) */
3534 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3535 tmpop->op_sibling = Nullop; /* don't free split */
3536 right->op_next = tmpop->op_next; /* fix starting loc */
3537 op_free(o); /* blow off assign */
3538 right->op_flags &= ~OPf_WANT;
3539 /* "I don't know and I don't care." */
3544 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3545 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3547 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3549 sv_setiv(sv, PL_modcount+1);
3557 right = newOP(OP_UNDEF, 0);
3558 if (right->op_type == OP_READLINE) {
3559 right->op_flags |= OPf_STACKED;
3560 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3563 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3564 o = newBINOP(OP_SASSIGN, flags,
3565 scalar(right), mod(scalar(left), OP_SASSIGN) );
3577 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3579 U32 seq = intro_my();
3582 NewOp(1101, cop, 1, COP);
3583 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3584 cop->op_type = OP_DBSTATE;
3585 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3588 cop->op_type = OP_NEXTSTATE;
3589 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3591 cop->op_flags = flags;
3592 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3594 cop->op_private |= NATIVE_HINTS;
3596 PL_compiling.op_private = cop->op_private;
3597 cop->op_next = (OP*)cop;
3600 cop->cop_label = label;
3601 PL_hints |= HINT_BLOCK_SCOPE;
3604 cop->cop_arybase = PL_curcop->cop_arybase;
3605 if (specialWARN(PL_curcop->cop_warnings))
3606 cop->cop_warnings = PL_curcop->cop_warnings ;
3608 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3609 if (specialCopIO(PL_curcop->cop_io))
3610 cop->cop_io = PL_curcop->cop_io;
3612 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3615 if (PL_copline == NOLINE)
3616 CopLINE_set(cop, CopLINE(PL_curcop));
3618 CopLINE_set(cop, PL_copline);
3619 PL_copline = NOLINE;
3622 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3624 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3626 CopSTASH_set(cop, PL_curstash);
3628 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3629 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3630 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3631 (void)SvIOK_on(*svp);
3632 SvIVX(*svp) = PTR2IV(cop);
3636 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3639 /* "Introduce" my variables to visible status. */
3647 if (! PL_min_intro_pending)
3648 return PL_cop_seqmax;
3650 svp = AvARRAY(PL_comppad_name);
3651 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3652 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3653 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3654 SvNVX(sv) = (NV)PL_cop_seqmax;
3657 PL_min_intro_pending = 0;
3658 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3659 return PL_cop_seqmax++;
3663 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3665 return new_logop(type, flags, &first, &other);
3669 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3673 OP *first = *firstp;
3674 OP *other = *otherp;
3676 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3677 return newBINOP(type, flags, scalar(first), scalar(other));
3679 scalarboolean(first);
3680 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3681 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3682 if (type == OP_AND || type == OP_OR) {
3688 first = *firstp = cUNOPo->op_first;
3690 first->op_next = o->op_next;
3691 cUNOPo->op_first = Nullop;
3695 if (first->op_type == OP_CONST) {
3696 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3697 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3698 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3709 else if (first->op_type == OP_WANTARRAY) {
3715 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3716 OP *k1 = ((UNOP*)first)->op_first;
3717 OP *k2 = k1->op_sibling;
3719 switch (first->op_type)
3722 if (k2 && k2->op_type == OP_READLINE
3723 && (k2->op_flags & OPf_STACKED)
3724 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3726 warnop = k2->op_type;
3731 if (k1->op_type == OP_READDIR
3732 || k1->op_type == OP_GLOB
3733 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3734 || k1->op_type == OP_EACH)
3736 warnop = ((k1->op_type == OP_NULL)
3737 ? k1->op_targ : k1->op_type);
3742 line_t oldline = CopLINE(PL_curcop);
3743 CopLINE_set(PL_curcop, PL_copline);
3744 Perl_warner(aTHX_ WARN_MISC,
3745 "Value of %s%s can be \"0\"; test with defined()",
3747 ((warnop == OP_READLINE || warnop == OP_GLOB)
3748 ? " construct" : "() operator"));
3749 CopLINE_set(PL_curcop, oldline);
3756 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3757 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3759 NewOp(1101, logop, 1, LOGOP);
3761 logop->op_type = type;
3762 logop->op_ppaddr = PL_ppaddr[type];
3763 logop->op_first = first;
3764 logop->op_flags = flags | OPf_KIDS;
3765 logop->op_other = LINKLIST(other);
3766 logop->op_private = 1 | (flags >> 8);
3768 /* establish postfix order */
3769 logop->op_next = LINKLIST(first);
3770 first->op_next = (OP*)logop;
3771 first->op_sibling = other;
3773 o = newUNOP(OP_NULL, 0, (OP*)logop);
3780 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3787 return newLOGOP(OP_AND, 0, first, trueop);
3789 return newLOGOP(OP_OR, 0, first, falseop);
3791 scalarboolean(first);
3792 if (first->op_type == OP_CONST) {
3793 if (SvTRUE(((SVOP*)first)->op_sv)) {
3804 else if (first->op_type == OP_WANTARRAY) {
3808 NewOp(1101, logop, 1, LOGOP);
3809 logop->op_type = OP_COND_EXPR;
3810 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3811 logop->op_first = first;
3812 logop->op_flags = flags | OPf_KIDS;
3813 logop->op_private = 1 | (flags >> 8);
3814 logop->op_other = LINKLIST(trueop);
3815 logop->op_next = LINKLIST(falseop);
3818 /* establish postfix order */
3819 start = LINKLIST(first);
3820 first->op_next = (OP*)logop;
3822 first->op_sibling = trueop;
3823 trueop->op_sibling = falseop;
3824 o = newUNOP(OP_NULL, 0, (OP*)logop);
3826 trueop->op_next = falseop->op_next = o;
3833 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3841 NewOp(1101, range, 1, LOGOP);
3843 range->op_type = OP_RANGE;
3844 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3845 range->op_first = left;
3846 range->op_flags = OPf_KIDS;
3847 leftstart = LINKLIST(left);
3848 range->op_other = LINKLIST(right);
3849 range->op_private = 1 | (flags >> 8);
3851 left->op_sibling = right;
3853 range->op_next = (OP*)range;
3854 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3855 flop = newUNOP(OP_FLOP, 0, flip);
3856 o = newUNOP(OP_NULL, 0, flop);
3858 range->op_next = leftstart;
3860 left->op_next = flip;
3861 right->op_next = flop;
3863 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3864 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3865 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3866 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3868 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3869 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3872 if (!flip->op_private || !flop->op_private)
3873 linklist(o); /* blow off optimizer unless constant */
3879 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3883 int once = block && block->op_flags & OPf_SPECIAL &&
3884 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3887 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3888 return block; /* do {} while 0 does once */
3889 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3890 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3891 expr = newUNOP(OP_DEFINED, 0,
3892 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3893 } else if (expr->op_flags & OPf_KIDS) {
3894 OP *k1 = ((UNOP*)expr)->op_first;
3895 OP *k2 = (k1) ? k1->op_sibling : NULL;
3896 switch (expr->op_type) {
3898 if (k2 && k2->op_type == OP_READLINE
3899 && (k2->op_flags & OPf_STACKED)
3900 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3901 expr = newUNOP(OP_DEFINED, 0, expr);
3905 if (k1->op_type == OP_READDIR
3906 || k1->op_type == OP_GLOB
3907 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3908 || k1->op_type == OP_EACH)
3909 expr = newUNOP(OP_DEFINED, 0, expr);
3915 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3916 o = new_logop(OP_AND, 0, &expr, &listop);
3919 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3921 if (once && o != listop)
3922 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3925 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3927 o->op_flags |= flags;
3929 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3934 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3942 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3943 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3944 expr = newUNOP(OP_DEFINED, 0,
3945 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3946 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3947 OP *k1 = ((UNOP*)expr)->op_first;
3948 OP *k2 = (k1) ? k1->op_sibling : NULL;
3949 switch (expr->op_type) {
3951 if (k2 && k2->op_type == OP_READLINE
3952 && (k2->op_flags & OPf_STACKED)
3953 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3954 expr = newUNOP(OP_DEFINED, 0, expr);
3958 if (k1->op_type == OP_READDIR
3959 || k1->op_type == OP_GLOB
3960 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3961 || k1->op_type == OP_EACH)
3962 expr = newUNOP(OP_DEFINED, 0, expr);
3968 block = newOP(OP_NULL, 0);
3970 block = scope(block);
3974 next = LINKLIST(cont);
3977 OP *unstack = newOP(OP_UNSTACK, 0);
3980 cont = append_elem(OP_LINESEQ, cont, unstack);
3981 if ((line_t)whileline != NOLINE) {
3982 PL_copline = whileline;
3983 cont = append_elem(OP_LINESEQ, cont,
3984 newSTATEOP(0, Nullch, Nullop));
3988 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3989 redo = LINKLIST(listop);
3992 PL_copline = whileline;
3994 o = new_logop(OP_AND, 0, &expr, &listop);
3995 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3996 op_free(expr); /* oops, it's a while (0) */
3998 return Nullop; /* listop already freed by new_logop */
4001 ((LISTOP*)listop)->op_last->op_next =
4002 (o == listop ? redo : LINKLIST(o));
4008 NewOp(1101,loop,1,LOOP);
4009 loop->op_type = OP_ENTERLOOP;
4010 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4011 loop->op_private = 0;
4012 loop->op_next = (OP*)loop;
4015 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4017 loop->op_redoop = redo;
4018 loop->op_lastop = o;
4019 o->op_private |= loopflags;
4022 loop->op_nextop = next;
4024 loop->op_nextop = o;
4026 o->op_flags |= flags;
4027 o->op_private |= (flags >> 8);
4032 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4040 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4041 sv->op_type = OP_RV2GV;
4042 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4044 else if (sv->op_type == OP_PADSV) { /* private variable */
4045 padoff = sv->op_targ;
4050 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4051 padoff = sv->op_targ;
4053 iterflags |= OPf_SPECIAL;
4058 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4062 padoff = find_threadsv("_");
4063 iterflags |= OPf_SPECIAL;
4065 sv = newGVOP(OP_GV, 0, PL_defgv);
4068 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4069 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4070 iterflags |= OPf_STACKED;
4072 else if (expr->op_type == OP_NULL &&
4073 (expr->op_flags & OPf_KIDS) &&
4074 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4076 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4077 * set the STACKED flag to indicate that these values are to be
4078 * treated as min/max values by 'pp_iterinit'.
4080 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4081 LOGOP* range = (LOGOP*) flip->op_first;
4082 OP* left = range->op_first;
4083 OP* right = left->op_sibling;
4086 range->op_flags &= ~OPf_KIDS;
4087 range->op_first = Nullop;
4089 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4090 listop->op_first->op_next = range->op_next;
4091 left->op_next = range->op_other;
4092 right->op_next = (OP*)listop;
4093 listop->op_next = listop->op_first;
4096 expr = (OP*)(listop);
4098 iterflags |= OPf_STACKED;
4101 expr = mod(force_list(expr), OP_GREPSTART);
4105 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4106 append_elem(OP_LIST, expr, scalar(sv))));
4107 assert(!loop->op_next);
4108 #ifdef PL_OP_SLAB_ALLOC
4111 NewOp(1234,tmp,1,LOOP);
4112 Copy(loop,tmp,1,LOOP);
4116 Renew(loop, 1, LOOP);
4118 loop->op_targ = padoff;
4119 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4120 PL_copline = forline;
4121 return newSTATEOP(0, label, wop);
4125 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4130 if (type != OP_GOTO || label->op_type == OP_CONST) {
4131 /* "last()" means "last" */
4132 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4133 o = newOP(type, OPf_SPECIAL);
4135 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4136 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4142 if (label->op_type == OP_ENTERSUB)
4143 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4144 o = newUNOP(type, OPf_STACKED, label);
4146 PL_hints |= HINT_BLOCK_SCOPE;
4151 Perl_cv_undef(pTHX_ CV *cv)
4155 MUTEX_DESTROY(CvMUTEXP(cv));
4156 Safefree(CvMUTEXP(cv));
4159 #endif /* USE_THREADS */
4162 if (CvFILE(cv) && !CvXSUB(cv)) {
4163 Safefree(CvFILE(cv));
4168 if (!CvXSUB(cv) && CvROOT(cv)) {
4170 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4171 Perl_croak(aTHX_ "Can't undef active subroutine");
4174 Perl_croak(aTHX_ "Can't undef active subroutine");
4175 #endif /* USE_THREADS */
4178 SAVEVPTR(PL_curpad);
4181 op_free(CvROOT(cv));
4182 CvROOT(cv) = Nullop;
4185 SvPOK_off((SV*)cv); /* forget prototype */
4187 /* Since closure prototypes have the same lifetime as the containing
4188 * CV, they don't hold a refcount on the outside CV. This avoids
4189 * the refcount loop between the outer CV (which keeps a refcount to
4190 * the closure prototype in the pad entry for pp_anoncode()) and the
4191 * closure prototype, and the ensuing memory leak. This does not
4192 * apply to closures generated within eval"", since eval"" CVs are
4193 * ephemeral. --GSAR */
4194 if (!CvANON(cv) || CvCLONED(cv)
4195 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4196 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4198 SvREFCNT_dec(CvOUTSIDE(cv));
4200 CvOUTSIDE(cv) = Nullcv;
4202 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4205 if (CvPADLIST(cv)) {
4206 /* may be during global destruction */
4207 if (SvREFCNT(CvPADLIST(cv))) {
4208 I32 i = AvFILLp(CvPADLIST(cv));
4210 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4211 SV* sv = svp ? *svp : Nullsv;
4214 if (sv == (SV*)PL_comppad_name)
4215 PL_comppad_name = Nullav;
4216 else if (sv == (SV*)PL_comppad) {
4217 PL_comppad = Nullav;
4218 PL_curpad = Null(SV**);
4222 SvREFCNT_dec((SV*)CvPADLIST(cv));
4224 CvPADLIST(cv) = Nullav;
4232 #ifdef DEBUG_CLOSURES
4234 S_cv_dump(pTHX_ CV *cv)
4237 CV *outside = CvOUTSIDE(cv);
4238 AV* padlist = CvPADLIST(cv);
4245 PerlIO_printf(Perl_debug_log,
4246 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4248 (CvANON(cv) ? "ANON"
4249 : (cv == PL_main_cv) ? "MAIN"
4250 : CvUNIQUE(cv) ? "UNIQUE"
4251 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4254 : CvANON(outside) ? "ANON"
4255 : (outside == PL_main_cv) ? "MAIN"
4256 : CvUNIQUE(outside) ? "UNIQUE"
4257 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4262 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4263 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4264 pname = AvARRAY(pad_name);
4265 ppad = AvARRAY(pad);
4267 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4268 if (SvPOK(pname[ix]))
4269 PerlIO_printf(Perl_debug_log,
4270 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4271 (int)ix, PTR2UV(ppad[ix]),
4272 SvFAKE(pname[ix]) ? "FAKE " : "",
4274 (IV)I_32(SvNVX(pname[ix])),
4277 #endif /* DEBUGGING */
4279 #endif /* DEBUG_CLOSURES */
4282 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4286 AV* protopadlist = CvPADLIST(proto);
4287 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4288 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4289 SV** pname = AvARRAY(protopad_name);
4290 SV** ppad = AvARRAY(protopad);
4291 I32 fname = AvFILLp(protopad_name);
4292 I32 fpad = AvFILLp(protopad);
4296 assert(!CvUNIQUE(proto));
4300 SAVESPTR(PL_comppad_name);
4301 SAVESPTR(PL_compcv);
4303 cv = PL_compcv = (CV*)NEWSV(1104,0);
4304 sv_upgrade((SV *)cv, SvTYPE(proto));
4305 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4309 New(666, CvMUTEXP(cv), 1, perl_mutex);
4310 MUTEX_INIT(CvMUTEXP(cv));
4312 #endif /* USE_THREADS */
4314 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4315 : savepv(CvFILE(proto));
4317 CvFILE(cv) = CvFILE(proto);
4319 CvGV(cv) = CvGV(proto);
4320 CvSTASH(cv) = CvSTASH(proto);
4321 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4322 CvSTART(cv) = CvSTART(proto);
4324 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4327 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4329 PL_comppad_name = newAV();
4330 for (ix = fname; ix >= 0; ix--)
4331 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4333 PL_comppad = newAV();
4335 comppadlist = newAV();
4336 AvREAL_off(comppadlist);
4337 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4338 av_store(comppadlist, 1, (SV*)PL_comppad);
4339 CvPADLIST(cv) = comppadlist;
4340 av_fill(PL_comppad, AvFILLp(protopad));
4341 PL_curpad = AvARRAY(PL_comppad);
4343 av = newAV(); /* will be @_ */
4345 av_store(PL_comppad, 0, (SV*)av);
4346 AvFLAGS(av) = AVf_REIFY;
4348 for (ix = fpad; ix > 0; ix--) {
4349 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4350 if (namesv && namesv != &PL_sv_undef) {
4351 char *name = SvPVX(namesv); /* XXX */
4352 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4353 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4354 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4356 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4358 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4360 else { /* our own lexical */
4363 /* anon code -- we'll come back for it */
4364 sv = SvREFCNT_inc(ppad[ix]);
4366 else if (*name == '@')
4368 else if (*name == '%')
4377 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4378 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4381 SV* sv = NEWSV(0,0);
4387 /* Now that vars are all in place, clone nested closures. */
4389 for (ix = fpad; ix > 0; ix--) {
4390 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4392 && namesv != &PL_sv_undef
4393 && !(SvFLAGS(namesv) & SVf_FAKE)
4394 && *SvPVX(namesv) == '&'
4395 && CvCLONE(ppad[ix]))
4397 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4398 SvREFCNT_dec(ppad[ix]);
4401 PL_curpad[ix] = (SV*)kid;
4405 #ifdef DEBUG_CLOSURES
4406 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4408 PerlIO_printf(Perl_debug_log, " from:\n");
4410 PerlIO_printf(Perl_debug_log, " to:\n");
4417 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4419 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4421 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4428 Perl_cv_clone(pTHX_ CV *proto)
4431 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4432 cv = cv_clone2(proto, CvOUTSIDE(proto));
4433 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4438 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4440 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4441 SV* msg = sv_newmortal();
4445 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4446 sv_setpv(msg, "Prototype mismatch:");
4448 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4450 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4451 sv_catpv(msg, " vs ");
4453 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4455 sv_catpv(msg, "none");
4456 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4460 static void const_sv_xsub(pTHXo_ CV* cv);
4463 =for apidoc cv_const_sv
4465 If C<cv> is a constant sub eligible for inlining. returns the constant
4466 value returned by the sub. Otherwise, returns NULL.
4468 Constant subs can be created with C<newCONSTSUB> or as described in
4469 L<perlsub/"Constant Functions">.
4474 Perl_cv_const_sv(pTHX_ CV *cv)
4476 if (!cv || !CvCONST(cv))
4478 return (SV*)CvXSUBANY(cv).any_ptr;
4482 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4489 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4490 o = cLISTOPo->op_first->op_sibling;
4492 for (; o; o = o->op_next) {
4493 OPCODE type = o->op_type;
4495 if (sv && o->op_next == o)
4497 if (o->op_next != o) {
4498 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4500 if (type == OP_DBSTATE)
4503 if (type == OP_LEAVESUB || type == OP_RETURN)
4507 if (type == OP_CONST && cSVOPo->op_sv)
4509 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4510 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4511 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4515 /* We get here only from cv_clone2() while creating a closure.
4516 Copy the const value here instead of in cv_clone2 so that
4517 SvREADONLY_on doesn't lead to problems when leaving
4522 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4534 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4544 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4548 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4550 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4554 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4560 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4565 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4566 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4567 SV *sv = sv_newmortal();
4568 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4569 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4574 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4575 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4585 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4586 maximum a prototype before. */
4587 if (SvTYPE(gv) > SVt_NULL) {
4588 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4589 && ckWARN_d(WARN_PROTOTYPE))
4591 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4593 cv_ckproto((CV*)gv, NULL, ps);
4596 sv_setpv((SV*)gv, ps);
4598 sv_setiv((SV*)gv, -1);
4599 SvREFCNT_dec(PL_compcv);
4600 cv = PL_compcv = NULL;
4601 PL_sub_generation++;
4605 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4607 #ifdef GV_UNIQUE_CHECK
4608 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4609 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4613 if (!block || !ps || *ps || attrs)
4616 const_sv = op_const_sv(block, Nullcv);
4619 bool exists = CvROOT(cv) || CvXSUB(cv);
4621 #ifdef GV_UNIQUE_CHECK
4622 if (exists && GvUNIQUE(gv)) {
4623 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4627 /* if the subroutine doesn't exist and wasn't pre-declared
4628 * with a prototype, assume it will be AUTOLOADed,
4629 * skipping the prototype check
4631 if (exists || SvPOK(cv))
4632 cv_ckproto(cv, gv, ps);
4633 /* already defined (or promised)? */
4634 if (exists || GvASSUMECV(gv)) {
4635 if (!block && !attrs) {
4636 /* just a "sub foo;" when &foo is already defined */
4637 SAVEFREESV(PL_compcv);
4640 /* ahem, death to those who redefine active sort subs */
4641 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4642 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4644 if (ckWARN(WARN_REDEFINE)
4646 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4648 line_t oldline = CopLINE(PL_curcop);
4649 CopLINE_set(PL_curcop, PL_copline);
4650 Perl_warner(aTHX_ WARN_REDEFINE,
4651 CvCONST(cv) ? "Constant subroutine %s redefined"
4652 : "Subroutine %s redefined", name);
4653 CopLINE_set(PL_curcop, oldline);
4661 SvREFCNT_inc(const_sv);
4663 assert(!CvROOT(cv) && !CvCONST(cv));
4664 sv_setpv((SV*)cv, ""); /* prototype is "" */
4665 CvXSUBANY(cv).any_ptr = const_sv;
4666 CvXSUB(cv) = const_sv_xsub;
4671 cv = newCONSTSUB(NULL, name, const_sv);
4674 SvREFCNT_dec(PL_compcv);
4676 PL_sub_generation++;
4683 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4684 * before we clobber PL_compcv.
4688 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4689 stash = GvSTASH(CvGV(cv));
4690 else if (CvSTASH(cv))
4691 stash = CvSTASH(cv);
4693 stash = PL_curstash;
4696 /* possibly about to re-define existing subr -- ignore old cv */
4697 rcv = (SV*)PL_compcv;
4698 if (name && GvSTASH(gv))
4699 stash = GvSTASH(gv);
4701 stash = PL_curstash;
4703 apply_attrs(stash, rcv, attrs);
4705 if (cv) { /* must reuse cv if autoloaded */
4707 /* got here with just attrs -- work done, so bug out */
4708 SAVEFREESV(PL_compcv);
4712 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4713 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4714 CvOUTSIDE(PL_compcv) = 0;
4715 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4716 CvPADLIST(PL_compcv) = 0;
4717 /* inner references to PL_compcv must be fixed up ... */
4719 AV *padlist = CvPADLIST(cv);
4720 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4721 AV *comppad = (AV*)AvARRAY(padlist)[1];
4722 SV **namepad = AvARRAY(comppad_name);
4723 SV **curpad = AvARRAY(comppad);
4724 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4725 SV *namesv = namepad[ix];
4726 if (namesv && namesv != &PL_sv_undef
4727 && *SvPVX(namesv) == '&')
4729 CV *innercv = (CV*)curpad[ix];
4730 if (CvOUTSIDE(innercv) == PL_compcv) {
4731 CvOUTSIDE(innercv) = cv;
4732 if (!CvANON(innercv) || CvCLONED(innercv)) {
4733 (void)SvREFCNT_inc(cv);
4734 SvREFCNT_dec(PL_compcv);
4740 /* ... before we throw it away */
4741 SvREFCNT_dec(PL_compcv);
4748 PL_sub_generation++;
4752 CvFILE_set_from_cop(cv, PL_curcop);
4753 CvSTASH(cv) = PL_curstash;
4756 if (!CvMUTEXP(cv)) {
4757 New(666, CvMUTEXP(cv), 1, perl_mutex);
4758 MUTEX_INIT(CvMUTEXP(cv));
4760 #endif /* USE_THREADS */
4763 sv_setpv((SV*)cv, ps);
4765 if (PL_error_count) {
4769 char *s = strrchr(name, ':');
4771 if (strEQ(s, "BEGIN")) {
4773 "BEGIN not safe after errors--compilation aborted";
4774 if (PL_in_eval & EVAL_KEEPERR)
4775 Perl_croak(aTHX_ not_safe);
4777 /* force display of errors found but not reported */
4778 sv_catpv(ERRSV, not_safe);
4779 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4787 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4788 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4791 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4792 mod(scalarseq(block), OP_LEAVESUBLV));
4795 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4797 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4798 OpREFCNT_set(CvROOT(cv), 1);
4799 CvSTART(cv) = LINKLIST(CvROOT(cv));
4800 CvROOT(cv)->op_next = 0;
4803 /* now that optimizer has done its work, adjust pad values */
4805 SV **namep = AvARRAY(PL_comppad_name);
4806 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4809 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4812 * The only things that a clonable function needs in its
4813 * pad are references to outer lexicals and anonymous subs.
4814 * The rest are created anew during cloning.
4816 if (!((namesv = namep[ix]) != Nullsv &&
4817 namesv != &PL_sv_undef &&
4819 *SvPVX(namesv) == '&')))
4821 SvREFCNT_dec(PL_curpad[ix]);
4822 PL_curpad[ix] = Nullsv;
4825 assert(!CvCONST(cv));
4826 if (ps && !*ps && op_const_sv(block, cv))
4830 AV *av = newAV(); /* Will be @_ */
4832 av_store(PL_comppad, 0, (SV*)av);
4833 AvFLAGS(av) = AVf_REIFY;
4835 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4836 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4838 if (!SvPADMY(PL_curpad[ix]))
4839 SvPADTMP_on(PL_curpad[ix]);
4843 /* If a potential closure prototype, don't keep a refcount on
4844 * outer CV, unless the latter happens to be a passing eval"".
4845 * This is okay as the lifetime of the prototype is tied to the
4846 * lifetime of the outer CV. Avoids memory leak due to reference
4848 if (!name && CvOUTSIDE(cv)
4849 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4850 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4852 SvREFCNT_dec(CvOUTSIDE(cv));
4855 if (name || aname) {
4857 char *tname = (name ? name : aname);
4859 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4860 SV *sv = NEWSV(0,0);
4861 SV *tmpstr = sv_newmortal();
4862 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4866 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4868 (long)PL_subline, (long)CopLINE(PL_curcop));
4869 gv_efullname3(tmpstr, gv, Nullch);
4870 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4871 hv = GvHVn(db_postponed);
4872 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4873 && (pcv = GvCV(db_postponed)))
4879 call_sv((SV*)pcv, G_DISCARD);
4883 if ((s = strrchr(tname,':')))
4888 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4891 if (strEQ(s, "BEGIN")) {
4892 I32 oldscope = PL_scopestack_ix;
4894 SAVECOPFILE(&PL_compiling);
4895 SAVECOPLINE(&PL_compiling);
4897 sv_setsv(PL_rs, PL_nrs);
4900 PL_beginav = newAV();
4901 DEBUG_x( dump_sub(gv) );
4902 av_push(PL_beginav, (SV*)cv);
4903 GvCV(gv) = 0; /* cv has been hijacked */
4904 call_list(oldscope, PL_beginav);
4906 PL_curcop = &PL_compiling;
4907 PL_compiling.op_private = PL_hints;
4910 else if (strEQ(s, "END") && !PL_error_count) {
4913 DEBUG_x( dump_sub(gv) );
4914 av_unshift(PL_endav, 1);
4915 av_store(PL_endav, 0, (SV*)cv);
4916 GvCV(gv) = 0; /* cv has been hijacked */
4918 else if (strEQ(s, "CHECK") && !PL_error_count) {
4920 PL_checkav = newAV();
4921 DEBUG_x( dump_sub(gv) );
4922 if (PL_main_start && ckWARN(WARN_VOID))
4923 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4924 av_unshift(PL_checkav, 1);
4925 av_store(PL_checkav, 0, (SV*)cv);
4926 GvCV(gv) = 0; /* cv has been hijacked */
4928 else if (strEQ(s, "INIT") && !PL_error_count) {
4930 PL_initav = newAV();
4931 DEBUG_x( dump_sub(gv) );
4932 if (PL_main_start && ckWARN(WARN_VOID))
4933 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4934 av_push(PL_initav, (SV*)cv);
4935 GvCV(gv) = 0; /* cv has been hijacked */
4940 PL_copline = NOLINE;
4945 /* XXX unsafe for threads if eval_owner isn't held */
4947 =for apidoc newCONSTSUB
4949 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4950 eligible for inlining at compile-time.
4956 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4962 SAVECOPLINE(PL_curcop);
4963 CopLINE_set(PL_curcop, PL_copline);
4966 PL_hints &= ~HINT_BLOCK_SCOPE;
4969 SAVESPTR(PL_curstash);
4970 SAVECOPSTASH(PL_curcop);
4971 PL_curstash = stash;
4973 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4975 CopSTASH(PL_curcop) = stash;
4979 cv = newXS(name, const_sv_xsub, __FILE__);
4980 CvXSUBANY(cv).any_ptr = sv;
4982 sv_setpv((SV*)cv, ""); /* prototype is "" */
4990 =for apidoc U||newXS
4992 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4998 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5000 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5003 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5005 /* just a cached method */
5009 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5010 /* already defined (or promised) */
5011 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5012 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5013 line_t oldline = CopLINE(PL_curcop);
5014 if (PL_copline != NOLINE)
5015 CopLINE_set(PL_curcop, PL_copline);
5016 Perl_warner(aTHX_ WARN_REDEFINE,
5017 CvCONST(cv) ? "Constant subroutine %s redefined"
5018 : "Subroutine %s redefined"
5020 CopLINE_set(PL_curcop, oldline);
5027 if (cv) /* must reuse cv if autoloaded */
5030 cv = (CV*)NEWSV(1105,0);
5031 sv_upgrade((SV *)cv, SVt_PVCV);
5035 PL_sub_generation++;
5040 New(666, CvMUTEXP(cv), 1, perl_mutex);
5041 MUTEX_INIT(CvMUTEXP(cv));
5043 #endif /* USE_THREADS */
5044 (void)gv_fetchfile(filename);
5045 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5046 an external constant string */
5047 CvXSUB(cv) = subaddr;
5050 char *s = strrchr(name,':');
5056 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5059 if (strEQ(s, "BEGIN")) {
5061 PL_beginav = newAV();
5062 av_push(PL_beginav, (SV*)cv);
5063 GvCV(gv) = 0; /* cv has been hijacked */
5065 else if (strEQ(s, "END")) {
5068 av_unshift(PL_endav, 1);
5069 av_store(PL_endav, 0, (SV*)cv);
5070 GvCV(gv) = 0; /* cv has been hijacked */
5072 else if (strEQ(s, "CHECK")) {
5074 PL_checkav = newAV();
5075 if (PL_main_start && ckWARN(WARN_VOID))
5076 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5077 av_unshift(PL_checkav, 1);
5078 av_store(PL_checkav, 0, (SV*)cv);
5079 GvCV(gv) = 0; /* cv has been hijacked */
5081 else if (strEQ(s, "INIT")) {
5083 PL_initav = newAV();
5084 if (PL_main_start && ckWARN(WARN_VOID))
5085 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5086 av_push(PL_initav, (SV*)cv);
5087 GvCV(gv) = 0; /* cv has been hijacked */
5098 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5107 name = SvPVx(cSVOPo->op_sv, n_a);
5110 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5111 #ifdef GV_UNIQUE_CHECK
5113 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5117 if ((cv = GvFORM(gv))) {
5118 if (ckWARN(WARN_REDEFINE)) {
5119 line_t oldline = CopLINE(PL_curcop);
5121 CopLINE_set(PL_curcop, PL_copline);
5122 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5123 CopLINE_set(PL_curcop, oldline);
5130 CvFILE_set_from_cop(cv, PL_curcop);
5132 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5133 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5134 SvPADTMP_on(PL_curpad[ix]);
5137 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5138 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5139 OpREFCNT_set(CvROOT(cv), 1);
5140 CvSTART(cv) = LINKLIST(CvROOT(cv));
5141 CvROOT(cv)->op_next = 0;
5144 PL_copline = NOLINE;
5149 Perl_newANONLIST(pTHX_ OP *o)
5151 return newUNOP(OP_REFGEN, 0,
5152 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5156 Perl_newANONHASH(pTHX_ OP *o)
5158 return newUNOP(OP_REFGEN, 0,
5159 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5163 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5165 return newANONATTRSUB(floor, proto, Nullop, block);
5169 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5171 return newUNOP(OP_REFGEN, 0,
5172 newSVOP(OP_ANONCODE, 0,
5173 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5177 Perl_oopsAV(pTHX_ OP *o)
5179 switch (o->op_type) {
5181 o->op_type = OP_PADAV;
5182 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5183 return ref(o, OP_RV2AV);
5186 o->op_type = OP_RV2AV;
5187 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5192 if (ckWARN_d(WARN_INTERNAL))
5193 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5200 Perl_oopsHV(pTHX_ OP *o)
5202 switch (o->op_type) {
5205 o->op_type = OP_PADHV;
5206 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5207 return ref(o, OP_RV2HV);
5211 o->op_type = OP_RV2HV;
5212 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5217 if (ckWARN_d(WARN_INTERNAL))
5218 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5225 Perl_newAVREF(pTHX_ OP *o)
5227 if (o->op_type == OP_PADANY) {
5228 o->op_type = OP_PADAV;
5229 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5232 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5233 && ckWARN(WARN_DEPRECATED)) {
5234 Perl_warner(aTHX_ WARN_DEPRECATED,
5235 "Using an array as a reference is deprecated");
5237 return newUNOP(OP_RV2AV, 0, scalar(o));
5241 Perl_newGVREF(pTHX_ I32 type, OP *o)
5243 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5244 return newUNOP(OP_NULL, 0, o);
5245 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5249 Perl_newHVREF(pTHX_ OP *o)
5251 if (o->op_type == OP_PADANY) {
5252 o->op_type = OP_PADHV;
5253 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5256 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5257 && ckWARN(WARN_DEPRECATED)) {
5258 Perl_warner(aTHX_ WARN_DEPRECATED,
5259 "Using a hash as a reference is deprecated");
5261 return newUNOP(OP_RV2HV, 0, scalar(o));
5265 Perl_oopsCV(pTHX_ OP *o)
5267 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5273 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5275 return newUNOP(OP_RV2CV, flags, scalar(o));
5279 Perl_newSVREF(pTHX_ OP *o)
5281 if (o->op_type == OP_PADANY) {
5282 o->op_type = OP_PADSV;
5283 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5286 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5287 o->op_flags |= OPpDONE_SVREF;
5290 return newUNOP(OP_RV2SV, 0, scalar(o));
5293 /* Check routines. */
5296 Perl_ck_anoncode(pTHX_ OP *o)
5301 name = NEWSV(1106,0);
5302 sv_upgrade(name, SVt_PVNV);
5303 sv_setpvn(name, "&", 1);
5306 ix = pad_alloc(o->op_type, SVs_PADMY);
5307 av_store(PL_comppad_name, ix, name);
5308 av_store(PL_comppad, ix, cSVOPo->op_sv);
5309 SvPADMY_on(cSVOPo->op_sv);
5310 cSVOPo->op_sv = Nullsv;
5311 cSVOPo->op_targ = ix;
5316 Perl_ck_bitop(pTHX_ OP *o)
5318 o->op_private = PL_hints;
5323 Perl_ck_concat(pTHX_ OP *o)
5325 if (cUNOPo->op_first->op_type == OP_CONCAT)
5326 o->op_flags |= OPf_STACKED;
5331 Perl_ck_spair(pTHX_ OP *o)
5333 if (o->op_flags & OPf_KIDS) {
5336 OPCODE type = o->op_type;
5337 o = modkids(ck_fun(o), type);
5338 kid = cUNOPo->op_first;
5339 newop = kUNOP->op_first->op_sibling;
5341 (newop->op_sibling ||
5342 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5343 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5344 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5348 op_free(kUNOP->op_first);
5349 kUNOP->op_first = newop;
5351 o->op_ppaddr = PL_ppaddr[++o->op_type];
5356 Perl_ck_delete(pTHX_ OP *o)
5360 if (o->op_flags & OPf_KIDS) {
5361 OP *kid = cUNOPo->op_first;
5362 switch (kid->op_type) {
5364 o->op_flags |= OPf_SPECIAL;
5367 o->op_private |= OPpSLICE;
5370 o->op_flags |= OPf_SPECIAL;
5375 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5376 PL_op_desc[o->op_type]);
5384 Perl_ck_eof(pTHX_ OP *o)
5386 I32 type = o->op_type;
5388 if (o->op_flags & OPf_KIDS) {
5389 if (cLISTOPo->op_first->op_type == OP_STUB) {
5391 o = newUNOP(type, OPf_SPECIAL,
5392 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5400 Perl_ck_eval(pTHX_ OP *o)
5402 PL_hints |= HINT_BLOCK_SCOPE;
5403 if (o->op_flags & OPf_KIDS) {
5404 SVOP *kid = (SVOP*)cUNOPo->op_first;
5407 o->op_flags &= ~OPf_KIDS;
5410 else if (kid->op_type == OP_LINESEQ) {
5413 kid->op_next = o->op_next;
5414 cUNOPo->op_first = 0;
5417 NewOp(1101, enter, 1, LOGOP);
5418 enter->op_type = OP_ENTERTRY;
5419 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5420 enter->op_private = 0;
5422 /* establish postfix order */
5423 enter->op_next = (OP*)enter;
5425 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5426 o->op_type = OP_LEAVETRY;
5427 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5428 enter->op_other = o;
5436 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5438 o->op_targ = (PADOFFSET)PL_hints;
5443 Perl_ck_exit(pTHX_ OP *o)
5446 HV *table = GvHV(PL_hintgv);
5448 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5449 if (svp && *svp && SvTRUE(*svp))
5450 o->op_private |= OPpEXIT_VMSISH;
5457 Perl_ck_exec(pTHX_ OP *o)
5460 if (o->op_flags & OPf_STACKED) {
5462 kid = cUNOPo->op_first->op_sibling;
5463 if (kid->op_type == OP_RV2GV)
5472 Perl_ck_exists(pTHX_ OP *o)
5475 if (o->op_flags & OPf_KIDS) {
5476 OP *kid = cUNOPo->op_first;
5477 if (kid->op_type == OP_ENTERSUB) {
5478 (void) ref(kid, o->op_type);
5479 if (kid->op_type != OP_RV2CV && !PL_error_count)
5480 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5481 PL_op_desc[o->op_type]);
5482 o->op_private |= OPpEXISTS_SUB;
5484 else if (kid->op_type == OP_AELEM)
5485 o->op_flags |= OPf_SPECIAL;
5486 else if (kid->op_type != OP_HELEM)
5487 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5488 PL_op_desc[o->op_type]);
5496 Perl_ck_gvconst(pTHX_ register OP *o)
5498 o = fold_constants(o);
5499 if (o->op_type == OP_CONST)
5506 Perl_ck_rvconst(pTHX_ register OP *o)
5508 SVOP *kid = (SVOP*)cUNOPo->op_first;
5510 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5511 if (kid->op_type == OP_CONST) {
5515 SV *kidsv = kid->op_sv;
5518 /* Is it a constant from cv_const_sv()? */
5519 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5520 SV *rsv = SvRV(kidsv);
5521 int svtype = SvTYPE(rsv);
5522 char *badtype = Nullch;
5524 switch (o->op_type) {
5526 if (svtype > SVt_PVMG)
5527 badtype = "a SCALAR";
5530 if (svtype != SVt_PVAV)
5531 badtype = "an ARRAY";
5534 if (svtype != SVt_PVHV) {
5535 if (svtype == SVt_PVAV) { /* pseudohash? */
5536 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5537 if (ksv && SvROK(*ksv)
5538 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5547 if (svtype != SVt_PVCV)
5552 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5555 name = SvPV(kidsv, n_a);
5556 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5557 char *badthing = Nullch;
5558 switch (o->op_type) {
5560 badthing = "a SCALAR";
5563 badthing = "an ARRAY";
5566 badthing = "a HASH";
5571 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5575 * This is a little tricky. We only want to add the symbol if we
5576 * didn't add it in the lexer. Otherwise we get duplicate strict
5577 * warnings. But if we didn't add it in the lexer, we must at
5578 * least pretend like we wanted to add it even if it existed before,
5579 * or we get possible typo warnings. OPpCONST_ENTERED says
5580 * whether the lexer already added THIS instance of this symbol.
5582 iscv = (o->op_type == OP_RV2CV) * 2;
5584 gv = gv_fetchpv(name,
5585 iscv | !(kid->op_private & OPpCONST_ENTERED),
5588 : o->op_type == OP_RV2SV
5590 : o->op_type == OP_RV2AV
5592 : o->op_type == OP_RV2HV
5595 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5597 kid->op_type = OP_GV;
5598 SvREFCNT_dec(kid->op_sv);
5600 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5601 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5602 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5604 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5606 kid->op_sv = SvREFCNT_inc(gv);
5608 kid->op_private = 0;
5609 kid->op_ppaddr = PL_ppaddr[OP_GV];
5616 Perl_ck_ftst(pTHX_ OP *o)
5618 I32 type = o->op_type;
5620 if (o->op_flags & OPf_REF) {
5623 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5624 SVOP *kid = (SVOP*)cUNOPo->op_first;
5626 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5628 OP *newop = newGVOP(type, OPf_REF,
5629 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5636 if (type == OP_FTTTY)
5637 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5640 o = newUNOP(type, 0, newDEFSVOP());
5646 Perl_ck_fun(pTHX_ OP *o)
5652 int type = o->op_type;
5653 register I32 oa = PL_opargs[type] >> OASHIFT;
5655 if (o->op_flags & OPf_STACKED) {
5656 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5659 return no_fh_allowed(o);
5662 if (o->op_flags & OPf_KIDS) {
5664 tokid = &cLISTOPo->op_first;
5665 kid = cLISTOPo->op_first;
5666 if (kid->op_type == OP_PUSHMARK ||
5667 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5669 tokid = &kid->op_sibling;
5670 kid = kid->op_sibling;
5672 if (!kid && PL_opargs[type] & OA_DEFGV)
5673 *tokid = kid = newDEFSVOP();
5677 sibl = kid->op_sibling;
5680 /* list seen where single (scalar) arg expected? */
5681 if (numargs == 1 && !(oa >> 4)
5682 && kid->op_type == OP_LIST && type != OP_SCALAR)
5684 return too_many_arguments(o,PL_op_desc[type]);
5697 if ((type == OP_PUSH || type == OP_UNSHIFT)
5698 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5699 Perl_warner(aTHX_ WARN_SYNTAX,
5700 "Useless use of %s with no values",
5703 if (kid->op_type == OP_CONST &&
5704 (kid->op_private & OPpCONST_BARE))
5706 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5707 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5708 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5709 if (ckWARN(WARN_DEPRECATED))
5710 Perl_warner(aTHX_ WARN_DEPRECATED,
5711 "Array @%s missing the @ in argument %"IVdf" of %s()",
5712 name, (IV)numargs, PL_op_desc[type]);
5715 kid->op_sibling = sibl;
5718 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5719 bad_type(numargs, "array", PL_op_desc[type], kid);
5723 if (kid->op_type == OP_CONST &&
5724 (kid->op_private & OPpCONST_BARE))
5726 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5727 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5728 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5729 if (ckWARN(WARN_DEPRECATED))
5730 Perl_warner(aTHX_ WARN_DEPRECATED,
5731 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5732 name, (IV)numargs, PL_op_desc[type]);
5735 kid->op_sibling = sibl;
5738 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5739 bad_type(numargs, "hash", PL_op_desc[type], kid);
5744 OP *newop = newUNOP(OP_NULL, 0, kid);
5745 kid->op_sibling = 0;
5747 newop->op_next = newop;
5749 kid->op_sibling = sibl;
5754 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5755 if (kid->op_type == OP_CONST &&
5756 (kid->op_private & OPpCONST_BARE))
5758 OP *newop = newGVOP(OP_GV, 0,
5759 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5764 else if (kid->op_type == OP_READLINE) {
5765 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5766 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5769 I32 flags = OPf_SPECIAL;
5773 /* is this op a FH constructor? */
5774 if (is_handle_constructor(o,numargs)) {
5775 char *name = Nullch;
5779 /* Set a flag to tell rv2gv to vivify
5780 * need to "prove" flag does not mean something
5781 * else already - NI-S 1999/05/07
5784 if (kid->op_type == OP_PADSV) {
5785 SV **namep = av_fetch(PL_comppad_name,
5787 if (namep && *namep)
5788 name = SvPV(*namep, len);
5790 else if (kid->op_type == OP_RV2SV
5791 && kUNOP->op_first->op_type == OP_GV)
5793 GV *gv = cGVOPx_gv(kUNOP->op_first);
5795 len = GvNAMELEN(gv);
5797 else if (kid->op_type == OP_AELEM
5798 || kid->op_type == OP_HELEM)
5800 name = "__ANONIO__";
5806 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5807 namesv = PL_curpad[targ];
5808 (void)SvUPGRADE(namesv, SVt_PV);
5810 sv_setpvn(namesv, "$", 1);
5811 sv_catpvn(namesv, name, len);
5814 kid->op_sibling = 0;
5815 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5816 kid->op_targ = targ;
5817 kid->op_private |= priv;
5819 kid->op_sibling = sibl;
5825 mod(scalar(kid), type);
5829 tokid = &kid->op_sibling;
5830 kid = kid->op_sibling;
5832 o->op_private |= numargs;
5834 return too_many_arguments(o,PL_op_desc[o->op_type]);
5837 else if (PL_opargs[type] & OA_DEFGV) {
5839 return newUNOP(type, 0, newDEFSVOP());
5843 while (oa & OA_OPTIONAL)
5845 if (oa && oa != OA_LIST)
5846 return too_few_arguments(o,PL_op_desc[o->op_type]);
5852 Perl_ck_glob(pTHX_ OP *o)
5857 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5858 append_elem(OP_GLOB, o, newDEFSVOP());
5860 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5861 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5863 #if !defined(PERL_EXTERNAL_GLOB)
5864 /* XXX this can be tightened up and made more failsafe. */
5868 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5870 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5871 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5872 GvCV(gv) = GvCV(glob_gv);
5873 SvREFCNT_inc((SV*)GvCV(gv));
5874 GvIMPORTED_CV_on(gv);
5877 #endif /* PERL_EXTERNAL_GLOB */
5879 if (gv && GvIMPORTED_CV(gv)) {
5880 append_elem(OP_GLOB, o,
5881 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5882 o->op_type = OP_LIST;
5883 o->op_ppaddr = PL_ppaddr[OP_LIST];
5884 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5885 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5886 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5887 append_elem(OP_LIST, o,
5888 scalar(newUNOP(OP_RV2CV, 0,
5889 newGVOP(OP_GV, 0, gv)))));
5890 o = newUNOP(OP_NULL, 0, ck_subr(o));
5891 o->op_targ = OP_GLOB; /* hint at what it used to be */
5894 gv = newGVgen("main");
5896 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5902 Perl_ck_grep(pTHX_ OP *o)
5906 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5908 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5909 NewOp(1101, gwop, 1, LOGOP);
5911 if (o->op_flags & OPf_STACKED) {
5914 kid = cLISTOPo->op_first->op_sibling;
5915 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5918 kid->op_next = (OP*)gwop;
5919 o->op_flags &= ~OPf_STACKED;
5921 kid = cLISTOPo->op_first->op_sibling;
5922 if (type == OP_MAPWHILE)
5929 kid = cLISTOPo->op_first->op_sibling;
5930 if (kid->op_type != OP_NULL)
5931 Perl_croak(aTHX_ "panic: ck_grep");
5932 kid = kUNOP->op_first;
5934 gwop->op_type = type;
5935 gwop->op_ppaddr = PL_ppaddr[type];
5936 gwop->op_first = listkids(o);
5937 gwop->op_flags |= OPf_KIDS;
5938 gwop->op_private = 1;
5939 gwop->op_other = LINKLIST(kid);
5940 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5941 kid->op_next = (OP*)gwop;
5943 kid = cLISTOPo->op_first->op_sibling;
5944 if (!kid || !kid->op_sibling)
5945 return too_few_arguments(o,PL_op_desc[o->op_type]);
5946 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5947 mod(kid, OP_GREPSTART);
5953 Perl_ck_index(pTHX_ OP *o)
5955 if (o->op_flags & OPf_KIDS) {
5956 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5958 kid = kid->op_sibling; /* get past "big" */
5959 if (kid && kid->op_type == OP_CONST)
5960 fbm_compile(((SVOP*)kid)->op_sv, 0);
5966 Perl_ck_lengthconst(pTHX_ OP *o)
5968 /* XXX length optimization goes here */
5973 Perl_ck_lfun(pTHX_ OP *o)
5975 OPCODE type = o->op_type;
5976 return modkids(ck_fun(o), type);
5980 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5982 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5983 switch (cUNOPo->op_first->op_type) {
5985 /* This is needed for
5986 if (defined %stash::)
5987 to work. Do not break Tk.
5989 break; /* Globals via GV can be undef */
5991 case OP_AASSIGN: /* Is this a good idea? */
5992 Perl_warner(aTHX_ WARN_DEPRECATED,
5993 "defined(@array) is deprecated");
5994 Perl_warner(aTHX_ WARN_DEPRECATED,
5995 "\t(Maybe you should just omit the defined()?)\n");
5998 /* This is needed for
5999 if (defined %stash::)
6000 to work. Do not break Tk.
6002 break; /* Globals via GV can be undef */
6004 Perl_warner(aTHX_ WARN_DEPRECATED,
6005 "defined(%%hash) is deprecated");
6006 Perl_warner(aTHX_ WARN_DEPRECATED,
6007 "\t(Maybe you should just omit the defined()?)\n");
6018 Perl_ck_rfun(pTHX_ OP *o)
6020 OPCODE type = o->op_type;
6021 return refkids(ck_fun(o), type);
6025 Perl_ck_listiob(pTHX_ OP *o)
6029 kid = cLISTOPo->op_first;
6032 kid = cLISTOPo->op_first;
6034 if (kid->op_type == OP_PUSHMARK)
6035 kid = kid->op_sibling;
6036 if (kid && o->op_flags & OPf_STACKED)
6037 kid = kid->op_sibling;
6038 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6039 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6040 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6041 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6042 cLISTOPo->op_first->op_sibling = kid;
6043 cLISTOPo->op_last = kid;
6044 kid = kid->op_sibling;
6049 append_elem(o->op_type, o, newDEFSVOP());
6055 Perl_ck_sassign(pTHX_ OP *o)
6057 OP *kid = cLISTOPo->op_first;
6058 /* has a disposable target? */
6059 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6060 && !(kid->op_flags & OPf_STACKED)
6061 /* Cannot steal the second time! */
6062 && !(kid->op_private & OPpTARGET_MY))
6064 OP *kkid = kid->op_sibling;
6066 /* Can just relocate the target. */
6067 if (kkid && kkid->op_type == OP_PADSV
6068 && !(kkid->op_private & OPpLVAL_INTRO))
6070 kid->op_targ = kkid->op_targ;
6072 /* Now we do not need PADSV and SASSIGN. */
6073 kid->op_sibling = o->op_sibling; /* NULL */
6074 cLISTOPo->op_first = NULL;
6077 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6085 Perl_ck_match(pTHX_ OP *o)
6087 o->op_private |= OPpRUNTIME;
6092 Perl_ck_method(pTHX_ OP *o)
6094 OP *kid = cUNOPo->op_first;
6095 if (kid->op_type == OP_CONST) {
6096 SV* sv = kSVOP->op_sv;
6097 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6099 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6100 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6103 kSVOP->op_sv = Nullsv;
6105 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6114 Perl_ck_null(pTHX_ OP *o)
6120 Perl_ck_open(pTHX_ OP *o)
6122 HV *table = GvHV(PL_hintgv);
6126 svp = hv_fetch(table, "open_IN", 7, FALSE);
6128 mode = mode_from_discipline(*svp);
6129 if (mode & O_BINARY)
6130 o->op_private |= OPpOPEN_IN_RAW;
6131 else if (mode & O_TEXT)
6132 o->op_private |= OPpOPEN_IN_CRLF;
6135 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6137 mode = mode_from_discipline(*svp);
6138 if (mode & O_BINARY)
6139 o->op_private |= OPpOPEN_OUT_RAW;
6140 else if (mode & O_TEXT)
6141 o->op_private |= OPpOPEN_OUT_CRLF;
6144 if (o->op_type == OP_BACKTICK)
6150 Perl_ck_repeat(pTHX_ OP *o)
6152 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6153 o->op_private |= OPpREPEAT_DOLIST;
6154 cBINOPo->op_first = force_list(cBINOPo->op_first);
6162 Perl_ck_require(pTHX_ OP *o)
6166 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6167 SVOP *kid = (SVOP*)cUNOPo->op_first;
6169 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6171 for (s = SvPVX(kid->op_sv); *s; s++) {
6172 if (*s == ':' && s[1] == ':') {
6174 Move(s+2, s+1, strlen(s+2)+1, char);
6175 --SvCUR(kid->op_sv);
6178 if (SvREADONLY(kid->op_sv)) {
6179 SvREADONLY_off(kid->op_sv);
6180 sv_catpvn(kid->op_sv, ".pm", 3);
6181 SvREADONLY_on(kid->op_sv);
6184 sv_catpvn(kid->op_sv, ".pm", 3);
6188 /* handle override, if any */
6189 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6190 if (!(gv && GvIMPORTED_CV(gv)))
6191 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6193 if (gv && GvIMPORTED_CV(gv)) {
6194 OP *kid = cUNOPo->op_first;
6195 cUNOPo->op_first = 0;
6197 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6198 append_elem(OP_LIST, kid,
6199 scalar(newUNOP(OP_RV2CV, 0,
6208 Perl_ck_return(pTHX_ OP *o)
6211 if (CvLVALUE(PL_compcv)) {
6212 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6213 mod(kid, OP_LEAVESUBLV);
6220 Perl_ck_retarget(pTHX_ OP *o)
6222 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6229 Perl_ck_select(pTHX_ OP *o)
6232 if (o->op_flags & OPf_KIDS) {
6233 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6234 if (kid && kid->op_sibling) {
6235 o->op_type = OP_SSELECT;
6236 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6238 return fold_constants(o);
6242 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6243 if (kid && kid->op_type == OP_RV2GV)
6244 kid->op_private &= ~HINT_STRICT_REFS;
6249 Perl_ck_shift(pTHX_ OP *o)
6251 I32 type = o->op_type;
6253 if (!(o->op_flags & OPf_KIDS)) {
6258 if (!CvUNIQUE(PL_compcv)) {
6259 argop = newOP(OP_PADAV, OPf_REF);
6260 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6263 argop = newUNOP(OP_RV2AV, 0,
6264 scalar(newGVOP(OP_GV, 0,
6265 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6268 argop = newUNOP(OP_RV2AV, 0,
6269 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6270 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6271 #endif /* USE_THREADS */
6272 return newUNOP(type, 0, scalar(argop));
6274 return scalar(modkids(ck_fun(o), type));
6278 Perl_ck_sort(pTHX_ OP *o)
6282 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6284 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6285 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6287 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6289 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6291 if (kid->op_type == OP_SCOPE) {
6295 else if (kid->op_type == OP_LEAVE) {
6296 if (o->op_type == OP_SORT) {
6297 op_null(kid); /* wipe out leave */
6300 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6301 if (k->op_next == kid)
6303 /* don't descend into loops */
6304 else if (k->op_type == OP_ENTERLOOP
6305 || k->op_type == OP_ENTERITER)
6307 k = cLOOPx(k)->op_lastop;
6312 kid->op_next = 0; /* just disconnect the leave */
6313 k = kLISTOP->op_first;
6318 if (o->op_type == OP_SORT) {
6319 /* provide scalar context for comparison function/block */
6325 o->op_flags |= OPf_SPECIAL;
6327 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6330 firstkid = firstkid->op_sibling;
6333 /* provide list context for arguments */
6334 if (o->op_type == OP_SORT)
6341 S_simplify_sort(pTHX_ OP *o)
6343 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6347 if (!(o->op_flags & OPf_STACKED))
6349 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6350 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6351 kid = kUNOP->op_first; /* get past null */
6352 if (kid->op_type != OP_SCOPE)
6354 kid = kLISTOP->op_last; /* get past scope */
6355 switch(kid->op_type) {
6363 k = kid; /* remember this node*/
6364 if (kBINOP->op_first->op_type != OP_RV2SV)
6366 kid = kBINOP->op_first; /* get past cmp */
6367 if (kUNOP->op_first->op_type != OP_GV)
6369 kid = kUNOP->op_first; /* get past rv2sv */
6371 if (GvSTASH(gv) != PL_curstash)
6373 if (strEQ(GvNAME(gv), "a"))
6375 else if (strEQ(GvNAME(gv), "b"))
6379 kid = k; /* back to cmp */
6380 if (kBINOP->op_last->op_type != OP_RV2SV)
6382 kid = kBINOP->op_last; /* down to 2nd arg */
6383 if (kUNOP->op_first->op_type != OP_GV)
6385 kid = kUNOP->op_first; /* get past rv2sv */
6387 if (GvSTASH(gv) != PL_curstash
6389 ? strNE(GvNAME(gv), "a")
6390 : strNE(GvNAME(gv), "b")))
6392 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6394 o->op_private |= OPpSORT_REVERSE;
6395 if (k->op_type == OP_NCMP)
6396 o->op_private |= OPpSORT_NUMERIC;
6397 if (k->op_type == OP_I_NCMP)
6398 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6399 kid = cLISTOPo->op_first->op_sibling;
6400 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6401 op_free(kid); /* then delete it */
6405 Perl_ck_split(pTHX_ OP *o)
6409 if (o->op_flags & OPf_STACKED)
6410 return no_fh_allowed(o);
6412 kid = cLISTOPo->op_first;
6413 if (kid->op_type != OP_NULL)
6414 Perl_croak(aTHX_ "panic: ck_split");
6415 kid = kid->op_sibling;
6416 op_free(cLISTOPo->op_first);
6417 cLISTOPo->op_first = kid;
6419 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6420 cLISTOPo->op_last = kid; /* There was only one element previously */
6423 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6424 OP *sibl = kid->op_sibling;
6425 kid->op_sibling = 0;
6426 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6427 if (cLISTOPo->op_first == cLISTOPo->op_last)
6428 cLISTOPo->op_last = kid;
6429 cLISTOPo->op_first = kid;
6430 kid->op_sibling = sibl;
6433 kid->op_type = OP_PUSHRE;
6434 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6437 if (!kid->op_sibling)
6438 append_elem(OP_SPLIT, o, newDEFSVOP());
6440 kid = kid->op_sibling;
6443 if (!kid->op_sibling)
6444 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6446 kid = kid->op_sibling;
6449 if (kid->op_sibling)
6450 return too_many_arguments(o,PL_op_desc[o->op_type]);
6456 Perl_ck_join(pTHX_ OP *o)
6458 if (ckWARN(WARN_SYNTAX)) {
6459 OP *kid = cLISTOPo->op_first->op_sibling;
6460 if (kid && kid->op_type == OP_MATCH) {
6461 char *pmstr = "STRING";
6462 if (PM_GETRE(kPMOP))
6463 pmstr = PM_GETRE(kPMOP)->precomp;
6464 Perl_warner(aTHX_ WARN_SYNTAX,
6465 "/%s/ should probably be written as \"%s\"",
6473 Perl_ck_subr(pTHX_ OP *o)
6475 OP *prev = ((cUNOPo->op_first->op_sibling)
6476 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6477 OP *o2 = prev->op_sibling;
6486 o->op_private |= OPpENTERSUB_HASTARG;
6487 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6488 if (cvop->op_type == OP_RV2CV) {
6490 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6491 op_null(cvop); /* disable rv2cv */
6492 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6493 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6494 GV *gv = cGVOPx_gv(tmpop);
6497 tmpop->op_private |= OPpEARLY_CV;
6498 else if (SvPOK(cv)) {
6499 namegv = CvANON(cv) ? gv : CvGV(cv);
6500 proto = SvPV((SV*)cv, n_a);
6504 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6505 if (o2->op_type == OP_CONST)
6506 o2->op_private &= ~OPpCONST_STRICT;
6507 else if (o2->op_type == OP_LIST) {
6508 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6509 if (o && o->op_type == OP_CONST)
6510 o->op_private &= ~OPpCONST_STRICT;
6513 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6514 if (PERLDB_SUB && PL_curstash != PL_debstash)
6515 o->op_private |= OPpENTERSUB_DB;
6516 while (o2 != cvop) {
6520 return too_many_arguments(o, gv_ename(namegv));
6538 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6540 arg == 1 ? "block or sub {}" : "sub {}",
6541 gv_ename(namegv), o2);
6544 /* '*' allows any scalar type, including bareword */
6547 if (o2->op_type == OP_RV2GV)
6548 goto wrapref; /* autoconvert GLOB -> GLOBref */
6549 else if (o2->op_type == OP_CONST)
6550 o2->op_private &= ~OPpCONST_STRICT;
6551 else if (o2->op_type == OP_ENTERSUB) {
6552 /* accidental subroutine, revert to bareword */
6553 OP *gvop = ((UNOP*)o2)->op_first;
6554 if (gvop && gvop->op_type == OP_NULL) {
6555 gvop = ((UNOP*)gvop)->op_first;
6557 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6560 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6561 (gvop = ((UNOP*)gvop)->op_first) &&
6562 gvop->op_type == OP_GV)
6564 GV *gv = cGVOPx_gv(gvop);
6565 OP *sibling = o2->op_sibling;
6566 SV *n = newSVpvn("",0);
6568 gv_fullname3(n, gv, "");
6569 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6570 sv_chop(n, SvPVX(n)+6);
6571 o2 = newSVOP(OP_CONST, 0, n);
6572 prev->op_sibling = o2;
6573 o2->op_sibling = sibling;
6585 if (o2->op_type != OP_RV2GV)
6586 bad_type(arg, "symbol", gv_ename(namegv), o2);
6589 if (o2->op_type != OP_ENTERSUB)
6590 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6593 if (o2->op_type != OP_RV2SV
6594 && o2->op_type != OP_PADSV
6595 && o2->op_type != OP_HELEM
6596 && o2->op_type != OP_AELEM
6597 && o2->op_type != OP_THREADSV)
6599 bad_type(arg, "scalar", gv_ename(namegv), o2);
6603 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6604 bad_type(arg, "array", gv_ename(namegv), o2);
6607 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6608 bad_type(arg, "hash", gv_ename(namegv), o2);
6612 OP* sib = kid->op_sibling;
6613 kid->op_sibling = 0;
6614 o2 = newUNOP(OP_REFGEN, 0, kid);
6615 o2->op_sibling = sib;
6616 prev->op_sibling = o2;
6627 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6628 gv_ename(namegv), SvPV((SV*)cv, n_a));
6633 mod(o2, OP_ENTERSUB);
6635 o2 = o2->op_sibling;
6637 if (proto && !optional &&
6638 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6639 return too_few_arguments(o, gv_ename(namegv));
6644 Perl_ck_svconst(pTHX_ OP *o)
6646 SvREADONLY_on(cSVOPo->op_sv);
6651 Perl_ck_trunc(pTHX_ OP *o)
6653 if (o->op_flags & OPf_KIDS) {
6654 SVOP *kid = (SVOP*)cUNOPo->op_first;
6656 if (kid->op_type == OP_NULL)
6657 kid = (SVOP*)kid->op_sibling;
6658 if (kid && kid->op_type == OP_CONST &&
6659 (kid->op_private & OPpCONST_BARE))
6661 o->op_flags |= OPf_SPECIAL;
6662 kid->op_private &= ~OPpCONST_STRICT;
6669 Perl_ck_substr(pTHX_ OP *o)
6672 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6673 OP *kid = cLISTOPo->op_first;
6675 if (kid->op_type == OP_NULL)
6676 kid = kid->op_sibling;
6678 kid->op_flags |= OPf_MOD;
6684 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6687 Perl_peep(pTHX_ register OP *o)
6689 register OP* oldop = 0;
6692 if (!o || o->op_seq)
6696 SAVEVPTR(PL_curcop);
6697 for (; o; o = o->op_next) {
6703 switch (o->op_type) {
6707 PL_curcop = ((COP*)o); /* for warnings */
6708 o->op_seq = PL_op_seqmax++;
6712 if (cSVOPo->op_private & OPpCONST_STRICT)
6713 no_bareword_allowed(o);
6715 /* Relocate sv to the pad for thread safety.
6716 * Despite being a "constant", the SV is written to,
6717 * for reference counts, sv_upgrade() etc. */
6719 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6720 if (SvPADTMP(cSVOPo->op_sv)) {
6721 /* If op_sv is already a PADTMP then it is being used by
6722 * some pad, so make a copy. */
6723 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6724 SvREADONLY_on(PL_curpad[ix]);
6725 SvREFCNT_dec(cSVOPo->op_sv);
6728 SvREFCNT_dec(PL_curpad[ix]);
6729 SvPADTMP_on(cSVOPo->op_sv);
6730 PL_curpad[ix] = cSVOPo->op_sv;
6731 /* XXX I don't know how this isn't readonly already. */
6732 SvREADONLY_on(PL_curpad[ix]);
6734 cSVOPo->op_sv = Nullsv;
6738 o->op_seq = PL_op_seqmax++;
6742 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6743 if (o->op_next->op_private & OPpTARGET_MY) {
6744 if (o->op_flags & OPf_STACKED) /* chained concats */
6745 goto ignore_optimization;
6747 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6748 o->op_targ = o->op_next->op_targ;
6749 o->op_next->op_targ = 0;
6750 o->op_private |= OPpTARGET_MY;
6753 op_null(o->op_next);
6755 ignore_optimization:
6756 o->op_seq = PL_op_seqmax++;
6759 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6760 o->op_seq = PL_op_seqmax++;
6761 break; /* Scalar stub must produce undef. List stub is noop */
6765 if (o->op_targ == OP_NEXTSTATE
6766 || o->op_targ == OP_DBSTATE
6767 || o->op_targ == OP_SETSTATE)
6769 PL_curcop = ((COP*)o);
6776 if (oldop && o->op_next) {
6777 oldop->op_next = o->op_next;
6780 o->op_seq = PL_op_seqmax++;
6784 if (o->op_next->op_type == OP_RV2SV) {
6785 if (!(o->op_next->op_private & OPpDEREF)) {
6786 op_null(o->op_next);
6787 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6789 o->op_next = o->op_next->op_next;
6790 o->op_type = OP_GVSV;
6791 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6794 else if (o->op_next->op_type == OP_RV2AV) {
6795 OP* pop = o->op_next->op_next;
6797 if (pop->op_type == OP_CONST &&
6798 (PL_op = pop->op_next) &&
6799 pop->op_next->op_type == OP_AELEM &&
6800 !(pop->op_next->op_private &
6801 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6802 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6807 op_null(o->op_next);
6808 op_null(pop->op_next);
6810 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6811 o->op_next = pop->op_next->op_next;
6812 o->op_type = OP_AELEMFAST;
6813 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6814 o->op_private = (U8)i;
6819 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6821 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6822 /* XXX could check prototype here instead of just carping */
6823 SV *sv = sv_newmortal();
6824 gv_efullname3(sv, gv, Nullch);
6825 Perl_warner(aTHX_ WARN_PROTOTYPE,
6826 "%s() called too early to check prototype",
6831 o->op_seq = PL_op_seqmax++;
6842 o->op_seq = PL_op_seqmax++;
6843 while (cLOGOP->op_other->op_type == OP_NULL)
6844 cLOGOP->op_other = cLOGOP->op_other->op_next;
6845 peep(cLOGOP->op_other);
6850 o->op_seq = PL_op_seqmax++;
6851 while (cLOOP->op_redoop->op_type == OP_NULL)
6852 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6853 peep(cLOOP->op_redoop);
6854 while (cLOOP->op_nextop->op_type == OP_NULL)
6855 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6856 peep(cLOOP->op_nextop);
6857 while (cLOOP->op_lastop->op_type == OP_NULL)
6858 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6859 peep(cLOOP->op_lastop);
6865 o->op_seq = PL_op_seqmax++;
6866 while (cPMOP->op_pmreplstart &&
6867 cPMOP->op_pmreplstart->op_type == OP_NULL)
6868 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6869 peep(cPMOP->op_pmreplstart);
6873 o->op_seq = PL_op_seqmax++;
6874 if (ckWARN(WARN_SYNTAX) && o->op_next
6875 && o->op_next->op_type == OP_NEXTSTATE) {
6876 if (o->op_next->op_sibling &&
6877 o->op_next->op_sibling->op_type != OP_EXIT &&
6878 o->op_next->op_sibling->op_type != OP_WARN &&
6879 o->op_next->op_sibling->op_type != OP_DIE) {
6880 line_t oldline = CopLINE(PL_curcop);
6882 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6883 Perl_warner(aTHX_ WARN_EXEC,
6884 "Statement unlikely to be reached");
6885 Perl_warner(aTHX_ WARN_EXEC,
6886 "\t(Maybe you meant system() when you said exec()?)\n");
6887 CopLINE_set(PL_curcop, oldline);
6896 SV **svp, **indsvp, *sv;
6901 o->op_seq = PL_op_seqmax++;
6903 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6906 /* Make the CONST have a shared SV */
6907 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6908 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6909 key = SvPV(sv, keylen);
6910 lexname = newSVpvn_share(key,
6911 SvUTF8(sv) ? -(I32)keylen : keylen,
6917 if ((o->op_private & (OPpLVAL_INTRO)))
6920 rop = (UNOP*)((BINOP*)o)->op_first;
6921 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6923 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6924 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6926 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6927 if (!fields || !GvHV(*fields))
6929 key = SvPV(*svp, keylen);
6930 indsvp = hv_fetch(GvHV(*fields), key,
6931 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6933 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6934 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6936 ind = SvIV(*indsvp);
6938 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6939 rop->op_type = OP_RV2AV;
6940 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6941 o->op_type = OP_AELEM;
6942 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6944 if (SvREADONLY(*svp))
6946 SvFLAGS(sv) |= (SvFLAGS(*svp)
6947 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6957 SV **svp, **indsvp, *sv;
6961 SVOP *first_key_op, *key_op;
6963 o->op_seq = PL_op_seqmax++;
6964 if ((o->op_private & (OPpLVAL_INTRO))
6965 /* I bet there's always a pushmark... */
6966 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6967 /* hmmm, no optimization if list contains only one key. */
6969 rop = (UNOP*)((LISTOP*)o)->op_last;
6970 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6972 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6973 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6975 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6976 if (!fields || !GvHV(*fields))
6978 /* Again guessing that the pushmark can be jumped over.... */
6979 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6980 ->op_first->op_sibling;
6981 /* Check that the key list contains only constants. */
6982 for (key_op = first_key_op; key_op;
6983 key_op = (SVOP*)key_op->op_sibling)
6984 if (key_op->op_type != OP_CONST)
6988 rop->op_type = OP_RV2AV;
6989 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6990 o->op_type = OP_ASLICE;
6991 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6992 for (key_op = first_key_op; key_op;
6993 key_op = (SVOP*)key_op->op_sibling) {
6994 svp = cSVOPx_svp(key_op);
6995 key = SvPV(*svp, keylen);
6996 indsvp = hv_fetch(GvHV(*fields), key,
6997 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6999 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7000 "in variable %s of type %s",
7001 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7003 ind = SvIV(*indsvp);
7005 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7007 if (SvREADONLY(*svp))
7009 SvFLAGS(sv) |= (SvFLAGS(*svp)
7010 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7018 o->op_seq = PL_op_seqmax++;
7028 /* Efficient sub that returns a constant scalar value. */
7030 const_sv_xsub(pTHXo_ CV* cv)
7035 Perl_croak(aTHX_ "usage: %s::%s()",
7036 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7040 ST(0) = (SV*)XSANY.any_ptr;