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 left = mod(left, right->op_type);
2042 if (right->op_type == OP_TRANS)
2043 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2045 o = prepend_elem(right->op_type, scalar(left), right);
2047 return newUNOP(OP_NOT, 0, scalar(o));
2051 return bind_match(type, left,
2052 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2056 Perl_invert(pTHX_ OP *o)
2060 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2061 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2065 Perl_scope(pTHX_ OP *o)
2068 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2069 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2070 o->op_type = OP_LEAVE;
2071 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2074 if (o->op_type == OP_LINESEQ) {
2076 o->op_type = OP_SCOPE;
2077 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2078 kid = ((LISTOP*)o)->op_first;
2079 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2083 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2090 Perl_save_hints(pTHX)
2093 SAVESPTR(GvHV(PL_hintgv));
2094 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2095 SAVEFREESV(GvHV(PL_hintgv));
2099 Perl_block_start(pTHX_ int full)
2101 int retval = PL_savestack_ix;
2103 SAVEI32(PL_comppad_name_floor);
2104 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2106 PL_comppad_name_fill = PL_comppad_name_floor;
2107 if (PL_comppad_name_floor < 0)
2108 PL_comppad_name_floor = 0;
2109 SAVEI32(PL_min_intro_pending);
2110 SAVEI32(PL_max_intro_pending);
2111 PL_min_intro_pending = 0;
2112 SAVEI32(PL_comppad_name_fill);
2113 SAVEI32(PL_padix_floor);
2114 PL_padix_floor = PL_padix;
2115 PL_pad_reset_pending = FALSE;
2117 PL_hints &= ~HINT_BLOCK_SCOPE;
2118 SAVESPTR(PL_compiling.cop_warnings);
2119 if (! specialWARN(PL_compiling.cop_warnings)) {
2120 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2121 SAVEFREESV(PL_compiling.cop_warnings) ;
2123 SAVESPTR(PL_compiling.cop_io);
2124 if (! specialCopIO(PL_compiling.cop_io)) {
2125 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2126 SAVEFREESV(PL_compiling.cop_io) ;
2132 Perl_block_end(pTHX_ I32 floor, OP *seq)
2134 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2135 OP* retval = scalarseq(seq);
2137 PL_pad_reset_pending = FALSE;
2138 PL_compiling.op_private = PL_hints;
2140 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2141 pad_leavemy(PL_comppad_name_fill);
2150 OP *o = newOP(OP_THREADSV, 0);
2151 o->op_targ = find_threadsv("_");
2154 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2155 #endif /* USE_THREADS */
2159 Perl_newPROG(pTHX_ OP *o)
2164 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2165 ((PL_in_eval & EVAL_KEEPERR)
2166 ? OPf_SPECIAL : 0), o);
2167 PL_eval_start = linklist(PL_eval_root);
2168 PL_eval_root->op_private |= OPpREFCOUNTED;
2169 OpREFCNT_set(PL_eval_root, 1);
2170 PL_eval_root->op_next = 0;
2171 peep(PL_eval_start);
2176 PL_main_root = scope(sawparens(scalarvoid(o)));
2177 PL_curcop = &PL_compiling;
2178 PL_main_start = LINKLIST(PL_main_root);
2179 PL_main_root->op_private |= OPpREFCOUNTED;
2180 OpREFCNT_set(PL_main_root, 1);
2181 PL_main_root->op_next = 0;
2182 peep(PL_main_start);
2185 /* Register with debugger */
2187 CV *cv = get_cv("DB::postponed", FALSE);
2191 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2193 call_sv((SV*)cv, G_DISCARD);
2200 Perl_localize(pTHX_ OP *o, I32 lex)
2202 if (o->op_flags & OPf_PARENS)
2205 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2207 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2208 if (*s == ';' || *s == '=')
2209 Perl_warner(aTHX_ WARN_PARENTHESIS,
2210 "Parentheses missing around \"%s\" list",
2211 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2217 o = mod(o, OP_NULL); /* a bit kludgey */
2219 PL_in_my_stash = Nullhv;
2224 Perl_jmaybe(pTHX_ OP *o)
2226 if (o->op_type == OP_LIST) {
2229 o2 = newOP(OP_THREADSV, 0);
2230 o2->op_targ = find_threadsv(";");
2232 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2233 #endif /* USE_THREADS */
2234 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2240 Perl_fold_constants(pTHX_ register OP *o)
2243 I32 type = o->op_type;
2246 if (PL_opargs[type] & OA_RETSCALAR)
2248 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2249 o->op_targ = pad_alloc(type, SVs_PADTMP);
2251 /* integerize op, unless it happens to be C<-foo>.
2252 * XXX should pp_i_negate() do magic string negation instead? */
2253 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2254 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2255 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2257 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2260 if (!(PL_opargs[type] & OA_FOLDCONST))
2265 /* XXX might want a ck_negate() for this */
2266 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2278 /* XXX what about the numeric ops? */
2279 if (PL_hints & HINT_LOCALE)
2284 goto nope; /* Don't try to run w/ errors */
2286 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2287 if ((curop->op_type != OP_CONST ||
2288 (curop->op_private & OPpCONST_BARE)) &&
2289 curop->op_type != OP_LIST &&
2290 curop->op_type != OP_SCALAR &&
2291 curop->op_type != OP_NULL &&
2292 curop->op_type != OP_PUSHMARK)
2298 curop = LINKLIST(o);
2302 sv = *(PL_stack_sp--);
2303 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2304 pad_swipe(o->op_targ);
2305 else if (SvTEMP(sv)) { /* grab mortal temp? */
2306 (void)SvREFCNT_inc(sv);
2310 if (type == OP_RV2GV)
2311 return newGVOP(OP_GV, 0, (GV*)sv);
2313 /* try to smush double to int, but don't smush -2.0 to -2 */
2314 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2317 #ifdef PERL_PRESERVE_IVUV
2318 /* Only bother to attempt to fold to IV if
2319 most operators will benefit */
2323 return newSVOP(OP_CONST, 0, sv);
2327 if (!(PL_opargs[type] & OA_OTHERINT))
2330 if (!(PL_hints & HINT_INTEGER)) {
2331 if (type == OP_MODULO
2332 || type == OP_DIVIDE
2333 || !(o->op_flags & OPf_KIDS))
2338 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2339 if (curop->op_type == OP_CONST) {
2340 if (SvIOK(((SVOP*)curop)->op_sv))
2344 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2348 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2355 Perl_gen_constant_list(pTHX_ register OP *o)
2358 I32 oldtmps_floor = PL_tmps_floor;
2362 return o; /* Don't attempt to run with errors */
2364 PL_op = curop = LINKLIST(o);
2371 PL_tmps_floor = oldtmps_floor;
2373 o->op_type = OP_RV2AV;
2374 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2375 curop = ((UNOP*)o)->op_first;
2376 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2383 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2385 if (!o || o->op_type != OP_LIST)
2386 o = newLISTOP(OP_LIST, 0, o, Nullop);
2388 o->op_flags &= ~OPf_WANT;
2390 if (!(PL_opargs[type] & OA_MARK))
2391 op_null(cLISTOPo->op_first);
2394 o->op_ppaddr = PL_ppaddr[type];
2395 o->op_flags |= flags;
2397 o = CHECKOP(type, o);
2398 if (o->op_type != type)
2401 return fold_constants(o);
2404 /* List constructors */
2407 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2415 if (first->op_type != type
2416 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2418 return newLISTOP(type, 0, first, last);
2421 if (first->op_flags & OPf_KIDS)
2422 ((LISTOP*)first)->op_last->op_sibling = last;
2424 first->op_flags |= OPf_KIDS;
2425 ((LISTOP*)first)->op_first = last;
2427 ((LISTOP*)first)->op_last = last;
2432 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2440 if (first->op_type != type)
2441 return prepend_elem(type, (OP*)first, (OP*)last);
2443 if (last->op_type != type)
2444 return append_elem(type, (OP*)first, (OP*)last);
2446 first->op_last->op_sibling = last->op_first;
2447 first->op_last = last->op_last;
2448 first->op_flags |= (last->op_flags & OPf_KIDS);
2450 #ifdef PL_OP_SLAB_ALLOC
2458 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2466 if (last->op_type == type) {
2467 if (type == OP_LIST) { /* already a PUSHMARK there */
2468 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2469 ((LISTOP*)last)->op_first->op_sibling = first;
2470 if (!(first->op_flags & OPf_PARENS))
2471 last->op_flags &= ~OPf_PARENS;
2474 if (!(last->op_flags & OPf_KIDS)) {
2475 ((LISTOP*)last)->op_last = first;
2476 last->op_flags |= OPf_KIDS;
2478 first->op_sibling = ((LISTOP*)last)->op_first;
2479 ((LISTOP*)last)->op_first = first;
2481 last->op_flags |= OPf_KIDS;
2485 return newLISTOP(type, 0, first, last);
2491 Perl_newNULLLIST(pTHX)
2493 return newOP(OP_STUB, 0);
2497 Perl_force_list(pTHX_ OP *o)
2499 if (!o || o->op_type != OP_LIST)
2500 o = newLISTOP(OP_LIST, 0, o, Nullop);
2506 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2510 NewOp(1101, listop, 1, LISTOP);
2512 listop->op_type = type;
2513 listop->op_ppaddr = PL_ppaddr[type];
2516 listop->op_flags = flags;
2520 else if (!first && last)
2523 first->op_sibling = last;
2524 listop->op_first = first;
2525 listop->op_last = last;
2526 if (type == OP_LIST) {
2528 pushop = newOP(OP_PUSHMARK, 0);
2529 pushop->op_sibling = first;
2530 listop->op_first = pushop;
2531 listop->op_flags |= OPf_KIDS;
2533 listop->op_last = pushop;
2540 Perl_newOP(pTHX_ I32 type, I32 flags)
2543 NewOp(1101, o, 1, OP);
2545 o->op_ppaddr = PL_ppaddr[type];
2546 o->op_flags = flags;
2549 o->op_private = 0 + (flags >> 8);
2550 if (PL_opargs[type] & OA_RETSCALAR)
2552 if (PL_opargs[type] & OA_TARGET)
2553 o->op_targ = pad_alloc(type, SVs_PADTMP);
2554 return CHECKOP(type, o);
2558 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2563 first = newOP(OP_STUB, 0);
2564 if (PL_opargs[type] & OA_MARK)
2565 first = force_list(first);
2567 NewOp(1101, unop, 1, UNOP);
2568 unop->op_type = type;
2569 unop->op_ppaddr = PL_ppaddr[type];
2570 unop->op_first = first;
2571 unop->op_flags = flags | OPf_KIDS;
2572 unop->op_private = 1 | (flags >> 8);
2573 unop = (UNOP*) CHECKOP(type, unop);
2577 return fold_constants((OP *) unop);
2581 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2584 NewOp(1101, binop, 1, BINOP);
2587 first = newOP(OP_NULL, 0);
2589 binop->op_type = type;
2590 binop->op_ppaddr = PL_ppaddr[type];
2591 binop->op_first = first;
2592 binop->op_flags = flags | OPf_KIDS;
2595 binop->op_private = 1 | (flags >> 8);
2598 binop->op_private = 2 | (flags >> 8);
2599 first->op_sibling = last;
2602 binop = (BINOP*)CHECKOP(type, binop);
2603 if (binop->op_next || binop->op_type != type)
2606 binop->op_last = binop->op_first->op_sibling;
2608 return fold_constants((OP *)binop);
2612 uvcompare(const void *a, const void *b)
2614 if (*((UV *)a) < (*(UV *)b))
2616 if (*((UV *)a) > (*(UV *)b))
2618 if (*((UV *)a+1) < (*(UV *)b+1))
2620 if (*((UV *)a+1) > (*(UV *)b+1))
2626 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2628 SV *tstr = ((SVOP*)expr)->op_sv;
2629 SV *rstr = ((SVOP*)repl)->op_sv;
2632 U8 *t = (U8*)SvPV(tstr, tlen);
2633 U8 *r = (U8*)SvPV(rstr, rlen);
2640 register short *tbl;
2642 PL_hints |= HINT_BLOCK_SCOPE;
2643 complement = o->op_private & OPpTRANS_COMPLEMENT;
2644 del = o->op_private & OPpTRANS_DELETE;
2645 squash = o->op_private & OPpTRANS_SQUASH;
2648 o->op_private |= OPpTRANS_FROM_UTF;
2651 o->op_private |= OPpTRANS_TO_UTF;
2653 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2654 SV* listsv = newSVpvn("# comment\n",10);
2656 U8* tend = t + tlen;
2657 U8* rend = r + rlen;
2671 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2672 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2678 tsave = t = bytes_to_utf8(t, &len);
2681 if (!to_utf && rlen) {
2683 rsave = r = bytes_to_utf8(r, &len);
2687 /* There are several snags with this code on EBCDIC:
2688 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2689 2. scan_const() in toke.c has encoded chars in native encoding which makes
2690 ranges at least in EBCDIC 0..255 range the bottom odd.
2694 U8 tmpbuf[UTF8_MAXLEN+1];
2697 New(1109, cp, 2*tlen, UV);
2699 transv = newSVpvn("",0);
2701 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2703 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2705 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2709 cp[2*i+1] = cp[2*i];
2713 qsort(cp, i, 2*sizeof(UV), uvcompare);
2714 for (j = 0; j < i; j++) {
2716 diff = val - nextmin;
2718 t = uvuni_to_utf8(tmpbuf,nextmin);
2719 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2721 U8 range_mark = UTF_TO_NATIVE(0xff);
2722 t = uvuni_to_utf8(tmpbuf, val - 1);
2723 sv_catpvn(transv, (char *)&range_mark, 1);
2724 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2731 t = uvuni_to_utf8(tmpbuf,nextmin);
2732 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2734 U8 range_mark = UTF_TO_NATIVE(0xff);
2735 sv_catpvn(transv, (char *)&range_mark, 1);
2737 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2738 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2739 t = (U8*)SvPVX(transv);
2740 tlen = SvCUR(transv);
2744 else if (!rlen && !del) {
2745 r = t; rlen = tlen; rend = tend;
2748 if ((!rlen && !del) || t == r ||
2749 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2751 o->op_private |= OPpTRANS_IDENTICAL;
2755 while (t < tend || tfirst <= tlast) {
2756 /* see if we need more "t" chars */
2757 if (tfirst > tlast) {
2758 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2760 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2762 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2769 /* now see if we need more "r" chars */
2770 if (rfirst > rlast) {
2772 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2774 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2776 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2785 rfirst = rlast = 0xffffffff;
2789 /* now see which range will peter our first, if either. */
2790 tdiff = tlast - tfirst;
2791 rdiff = rlast - rfirst;
2798 if (rfirst == 0xffffffff) {
2799 diff = tdiff; /* oops, pretend rdiff is infinite */
2801 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2802 (long)tfirst, (long)tlast);
2804 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2808 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2809 (long)tfirst, (long)(tfirst + diff),
2812 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2813 (long)tfirst, (long)rfirst);
2815 if (rfirst + diff > max)
2816 max = rfirst + diff;
2818 grows = (tfirst < rfirst &&
2819 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2831 else if (max > 0xff)
2836 Safefree(cPVOPo->op_pv);
2837 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2838 SvREFCNT_dec(listsv);
2840 SvREFCNT_dec(transv);
2842 if (!del && havefinal && rlen)
2843 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2844 newSVuv((UV)final), 0);
2847 o->op_private |= OPpTRANS_GROWS;
2859 tbl = (short*)cPVOPo->op_pv;
2861 Zero(tbl, 256, short);
2862 for (i = 0; i < tlen; i++)
2864 for (i = 0, j = 0; i < 256; i++) {
2875 if (i < 128 && r[j] >= 128)
2885 o->op_private |= OPpTRANS_IDENTICAL;
2890 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2891 tbl[0x100] = rlen - j;
2892 for (i=0; i < rlen - j; i++)
2893 tbl[0x101+i] = r[j+i];
2897 if (!rlen && !del) {
2900 o->op_private |= OPpTRANS_IDENTICAL;
2902 for (i = 0; i < 256; i++)
2904 for (i = 0, j = 0; i < tlen; i++,j++) {
2907 if (tbl[t[i]] == -1)
2913 if (tbl[t[i]] == -1) {
2914 if (t[i] < 128 && r[j] >= 128)
2921 o->op_private |= OPpTRANS_GROWS;
2929 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2933 NewOp(1101, pmop, 1, PMOP);
2934 pmop->op_type = type;
2935 pmop->op_ppaddr = PL_ppaddr[type];
2936 pmop->op_flags = flags;
2937 pmop->op_private = 0 | (flags >> 8);
2939 if (PL_hints & HINT_RE_TAINT)
2940 pmop->op_pmpermflags |= PMf_RETAINT;
2941 if (PL_hints & HINT_LOCALE)
2942 pmop->op_pmpermflags |= PMf_LOCALE;
2943 pmop->op_pmflags = pmop->op_pmpermflags;
2945 /* link into pm list */
2946 if (type != OP_TRANS && PL_curstash) {
2947 pmop->op_pmnext = HvPMROOT(PL_curstash);
2948 HvPMROOT(PL_curstash) = pmop;
2949 PmopSTASH_set(pmop,PL_curstash);
2956 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2960 I32 repl_has_vars = 0;
2962 if (o->op_type == OP_TRANS)
2963 return pmtrans(o, expr, repl);
2965 PL_hints |= HINT_BLOCK_SCOPE;
2968 if (expr->op_type == OP_CONST) {
2970 SV *pat = ((SVOP*)expr)->op_sv;
2971 char *p = SvPV(pat, plen);
2972 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2973 sv_setpvn(pat, "\\s+", 3);
2974 p = SvPV(pat, plen);
2975 pm->op_pmflags |= PMf_SKIPWHITE;
2977 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2978 pm->op_pmdynflags |= PMdf_UTF8;
2979 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2980 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2981 pm->op_pmflags |= PMf_WHITE;
2985 if (PL_hints & HINT_UTF8)
2986 pm->op_pmdynflags |= PMdf_UTF8;
2987 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2988 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2990 : OP_REGCMAYBE),0,expr);
2992 NewOp(1101, rcop, 1, LOGOP);
2993 rcop->op_type = OP_REGCOMP;
2994 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2995 rcop->op_first = scalar(expr);
2996 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2997 ? (OPf_SPECIAL | OPf_KIDS)
2999 rcop->op_private = 1;
3002 /* establish postfix order */
3003 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3005 rcop->op_next = expr;
3006 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3009 rcop->op_next = LINKLIST(expr);
3010 expr->op_next = (OP*)rcop;
3013 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3018 if (pm->op_pmflags & PMf_EVAL) {
3020 if (CopLINE(PL_curcop) < PL_multi_end)
3021 CopLINE_set(PL_curcop, PL_multi_end);
3024 else if (repl->op_type == OP_THREADSV
3025 && strchr("&`'123456789+",
3026 PL_threadsv_names[repl->op_targ]))
3030 #endif /* USE_THREADS */
3031 else if (repl->op_type == OP_CONST)
3035 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3036 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3038 if (curop->op_type == OP_THREADSV) {
3040 if (strchr("&`'123456789+", curop->op_private))
3044 if (curop->op_type == OP_GV) {
3045 GV *gv = cGVOPx_gv(curop);
3047 if (strchr("&`'123456789+", *GvENAME(gv)))
3050 #endif /* USE_THREADS */
3051 else if (curop->op_type == OP_RV2CV)
3053 else if (curop->op_type == OP_RV2SV ||
3054 curop->op_type == OP_RV2AV ||
3055 curop->op_type == OP_RV2HV ||
3056 curop->op_type == OP_RV2GV) {
3057 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3060 else if (curop->op_type == OP_PADSV ||
3061 curop->op_type == OP_PADAV ||
3062 curop->op_type == OP_PADHV ||
3063 curop->op_type == OP_PADANY) {
3066 else if (curop->op_type == OP_PUSHRE)
3067 ; /* Okay here, dangerous in newASSIGNOP */
3077 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3078 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3079 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3080 prepend_elem(o->op_type, scalar(repl), o);
3083 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3084 pm->op_pmflags |= PMf_MAYBE_CONST;
3085 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3087 NewOp(1101, rcop, 1, LOGOP);
3088 rcop->op_type = OP_SUBSTCONT;
3089 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3090 rcop->op_first = scalar(repl);
3091 rcop->op_flags |= OPf_KIDS;
3092 rcop->op_private = 1;
3095 /* establish postfix order */
3096 rcop->op_next = LINKLIST(repl);
3097 repl->op_next = (OP*)rcop;
3099 pm->op_pmreplroot = scalar((OP*)rcop);
3100 pm->op_pmreplstart = LINKLIST(rcop);
3109 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3112 NewOp(1101, svop, 1, SVOP);
3113 svop->op_type = type;
3114 svop->op_ppaddr = PL_ppaddr[type];
3116 svop->op_next = (OP*)svop;
3117 svop->op_flags = flags;
3118 if (PL_opargs[type] & OA_RETSCALAR)
3120 if (PL_opargs[type] & OA_TARGET)
3121 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3122 return CHECKOP(type, svop);
3126 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3129 NewOp(1101, padop, 1, PADOP);
3130 padop->op_type = type;
3131 padop->op_ppaddr = PL_ppaddr[type];
3132 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3133 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3134 PL_curpad[padop->op_padix] = sv;
3136 padop->op_next = (OP*)padop;
3137 padop->op_flags = flags;
3138 if (PL_opargs[type] & OA_RETSCALAR)
3140 if (PL_opargs[type] & OA_TARGET)
3141 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3142 return CHECKOP(type, padop);
3146 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3150 return newPADOP(type, flags, SvREFCNT_inc(gv));
3152 return newSVOP(type, flags, SvREFCNT_inc(gv));
3157 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3160 NewOp(1101, pvop, 1, PVOP);
3161 pvop->op_type = type;
3162 pvop->op_ppaddr = PL_ppaddr[type];
3164 pvop->op_next = (OP*)pvop;
3165 pvop->op_flags = flags;
3166 if (PL_opargs[type] & OA_RETSCALAR)
3168 if (PL_opargs[type] & OA_TARGET)
3169 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3170 return CHECKOP(type, pvop);
3174 Perl_package(pTHX_ OP *o)
3178 save_hptr(&PL_curstash);
3179 save_item(PL_curstname);
3184 name = SvPV(sv, len);
3185 PL_curstash = gv_stashpvn(name,len,TRUE);
3186 sv_setpvn(PL_curstname, name, len);
3190 sv_setpv(PL_curstname,"<none>");
3191 PL_curstash = Nullhv;
3193 PL_hints |= HINT_BLOCK_SCOPE;
3194 PL_copline = NOLINE;
3199 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3205 if (id->op_type != OP_CONST)
3206 Perl_croak(aTHX_ "Module name must be constant");
3210 if (version != Nullop) {
3211 SV *vesv = ((SVOP*)version)->op_sv;
3213 if (arg == Nullop && !SvNIOKp(vesv)) {
3220 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3221 Perl_croak(aTHX_ "Version number must be constant number");
3223 /* Make copy of id so we don't free it twice */
3224 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3226 /* Fake up a method call to VERSION */
3227 meth = newSVpvn("VERSION",7);
3228 sv_upgrade(meth, SVt_PVIV);
3229 (void)SvIOK_on(meth);
3230 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3231 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3232 append_elem(OP_LIST,
3233 prepend_elem(OP_LIST, pack, list(version)),
3234 newSVOP(OP_METHOD_NAMED, 0, meth)));
3238 /* Fake up an import/unimport */
3239 if (arg && arg->op_type == OP_STUB)
3240 imop = arg; /* no import on explicit () */
3241 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3242 imop = Nullop; /* use 5.0; */
3247 /* Make copy of id so we don't free it twice */
3248 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3250 /* Fake up a method call to import/unimport */
3251 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3252 sv_upgrade(meth, SVt_PVIV);
3253 (void)SvIOK_on(meth);
3254 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3255 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3256 append_elem(OP_LIST,
3257 prepend_elem(OP_LIST, pack, list(arg)),
3258 newSVOP(OP_METHOD_NAMED, 0, meth)));
3261 /* Fake up the BEGIN {}, which does its thing immediately. */
3263 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3266 append_elem(OP_LINESEQ,
3267 append_elem(OP_LINESEQ,
3268 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3269 newSTATEOP(0, Nullch, veop)),
3270 newSTATEOP(0, Nullch, imop) ));
3272 PL_hints |= HINT_BLOCK_SCOPE;
3273 PL_copline = NOLINE;
3278 =for apidoc load_module
3280 Loads the module whose name is pointed to by the string part of name.
3281 Note that the actual module name, not its filename, should be given.
3282 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3283 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3284 (or 0 for no flags). ver, if specified, provides version semantics
3285 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3286 arguments can be used to specify arguments to the module's import()
3287 method, similar to C<use Foo::Bar VERSION LIST>.
3292 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3295 va_start(args, ver);
3296 vload_module(flags, name, ver, &args);
3300 #ifdef PERL_IMPLICIT_CONTEXT
3302 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3306 va_start(args, ver);
3307 vload_module(flags, name, ver, &args);
3313 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3315 OP *modname, *veop, *imop;
3317 modname = newSVOP(OP_CONST, 0, name);
3318 modname->op_private |= OPpCONST_BARE;
3320 veop = newSVOP(OP_CONST, 0, ver);
3324 if (flags & PERL_LOADMOD_NOIMPORT) {
3325 imop = sawparens(newNULLLIST());
3327 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3328 imop = va_arg(*args, OP*);
3333 sv = va_arg(*args, SV*);
3335 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3336 sv = va_arg(*args, SV*);
3340 line_t ocopline = PL_copline;
3341 int oexpect = PL_expect;
3343 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3344 veop, modname, imop);
3345 PL_expect = oexpect;
3346 PL_copline = ocopline;
3351 Perl_dofile(pTHX_ OP *term)
3356 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3357 if (!(gv && GvIMPORTED_CV(gv)))
3358 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3360 if (gv && GvIMPORTED_CV(gv)) {
3361 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3362 append_elem(OP_LIST, term,
3363 scalar(newUNOP(OP_RV2CV, 0,
3368 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3374 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3376 return newBINOP(OP_LSLICE, flags,
3377 list(force_list(subscript)),
3378 list(force_list(listval)) );
3382 S_list_assignment(pTHX_ register OP *o)
3387 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3388 o = cUNOPo->op_first;
3390 if (o->op_type == OP_COND_EXPR) {
3391 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3392 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3397 yyerror("Assignment to both a list and a scalar");
3401 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3402 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3403 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3406 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3409 if (o->op_type == OP_RV2SV)
3416 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3421 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3422 return newLOGOP(optype, 0,
3423 mod(scalar(left), optype),
3424 newUNOP(OP_SASSIGN, 0, scalar(right)));
3427 return newBINOP(optype, OPf_STACKED,
3428 mod(scalar(left), optype), scalar(right));
3432 if (list_assignment(left)) {
3436 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3437 left = mod(left, OP_AASSIGN);
3445 curop = list(force_list(left));
3446 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3447 o->op_private = 0 | (flags >> 8);
3448 for (curop = ((LISTOP*)curop)->op_first;
3449 curop; curop = curop->op_sibling)
3451 if (curop->op_type == OP_RV2HV &&
3452 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3453 o->op_private |= OPpASSIGN_HASH;
3457 if (!(left->op_private & OPpLVAL_INTRO)) {
3460 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3461 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3462 if (curop->op_type == OP_GV) {
3463 GV *gv = cGVOPx_gv(curop);
3464 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3466 SvCUR(gv) = PL_generation;
3468 else if (curop->op_type == OP_PADSV ||
3469 curop->op_type == OP_PADAV ||
3470 curop->op_type == OP_PADHV ||
3471 curop->op_type == OP_PADANY) {
3472 SV **svp = AvARRAY(PL_comppad_name);
3473 SV *sv = svp[curop->op_targ];
3474 if (SvCUR(sv) == PL_generation)
3476 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3478 else if (curop->op_type == OP_RV2CV)
3480 else if (curop->op_type == OP_RV2SV ||
3481 curop->op_type == OP_RV2AV ||
3482 curop->op_type == OP_RV2HV ||
3483 curop->op_type == OP_RV2GV) {
3484 if (lastop->op_type != OP_GV) /* funny deref? */
3487 else if (curop->op_type == OP_PUSHRE) {
3488 if (((PMOP*)curop)->op_pmreplroot) {
3490 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3492 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3494 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3496 SvCUR(gv) = PL_generation;
3505 o->op_private |= OPpASSIGN_COMMON;
3507 if (right && right->op_type == OP_SPLIT) {
3509 if ((tmpop = ((LISTOP*)right)->op_first) &&
3510 tmpop->op_type == OP_PUSHRE)
3512 PMOP *pm = (PMOP*)tmpop;
3513 if (left->op_type == OP_RV2AV &&
3514 !(left->op_private & OPpLVAL_INTRO) &&
3515 !(o->op_private & OPpASSIGN_COMMON) )
3517 tmpop = ((UNOP*)left)->op_first;
3518 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3520 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3521 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3523 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3524 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3526 pm->op_pmflags |= PMf_ONCE;
3527 tmpop = cUNOPo->op_first; /* to list (nulled) */
3528 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3529 tmpop->op_sibling = Nullop; /* don't free split */
3530 right->op_next = tmpop->op_next; /* fix starting loc */
3531 op_free(o); /* blow off assign */
3532 right->op_flags &= ~OPf_WANT;
3533 /* "I don't know and I don't care." */
3538 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3539 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3541 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3543 sv_setiv(sv, PL_modcount+1);
3551 right = newOP(OP_UNDEF, 0);
3552 if (right->op_type == OP_READLINE) {
3553 right->op_flags |= OPf_STACKED;
3554 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3557 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3558 o = newBINOP(OP_SASSIGN, flags,
3559 scalar(right), mod(scalar(left), OP_SASSIGN) );
3571 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3573 U32 seq = intro_my();
3576 NewOp(1101, cop, 1, COP);
3577 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3578 cop->op_type = OP_DBSTATE;
3579 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3582 cop->op_type = OP_NEXTSTATE;
3583 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3585 cop->op_flags = flags;
3586 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3588 cop->op_private |= NATIVE_HINTS;
3590 PL_compiling.op_private = cop->op_private;
3591 cop->op_next = (OP*)cop;
3594 cop->cop_label = label;
3595 PL_hints |= HINT_BLOCK_SCOPE;
3598 cop->cop_arybase = PL_curcop->cop_arybase;
3599 if (specialWARN(PL_curcop->cop_warnings))
3600 cop->cop_warnings = PL_curcop->cop_warnings ;
3602 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3603 if (specialCopIO(PL_curcop->cop_io))
3604 cop->cop_io = PL_curcop->cop_io;
3606 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3609 if (PL_copline == NOLINE)
3610 CopLINE_set(cop, CopLINE(PL_curcop));
3612 CopLINE_set(cop, PL_copline);
3613 PL_copline = NOLINE;
3616 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3618 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3620 CopSTASH_set(cop, PL_curstash);
3622 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3623 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3624 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3625 (void)SvIOK_on(*svp);
3626 SvIVX(*svp) = PTR2IV(cop);
3630 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3633 /* "Introduce" my variables to visible status. */
3641 if (! PL_min_intro_pending)
3642 return PL_cop_seqmax;
3644 svp = AvARRAY(PL_comppad_name);
3645 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3646 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3647 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3648 SvNVX(sv) = (NV)PL_cop_seqmax;
3651 PL_min_intro_pending = 0;
3652 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3653 return PL_cop_seqmax++;
3657 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3659 return new_logop(type, flags, &first, &other);
3663 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3667 OP *first = *firstp;
3668 OP *other = *otherp;
3670 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3671 return newBINOP(type, flags, scalar(first), scalar(other));
3673 scalarboolean(first);
3674 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3675 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3676 if (type == OP_AND || type == OP_OR) {
3682 first = *firstp = cUNOPo->op_first;
3684 first->op_next = o->op_next;
3685 cUNOPo->op_first = Nullop;
3689 if (first->op_type == OP_CONST) {
3690 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3691 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3692 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3703 else if (first->op_type == OP_WANTARRAY) {
3709 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3710 OP *k1 = ((UNOP*)first)->op_first;
3711 OP *k2 = k1->op_sibling;
3713 switch (first->op_type)
3716 if (k2 && k2->op_type == OP_READLINE
3717 && (k2->op_flags & OPf_STACKED)
3718 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3720 warnop = k2->op_type;
3725 if (k1->op_type == OP_READDIR
3726 || k1->op_type == OP_GLOB
3727 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3728 || k1->op_type == OP_EACH)
3730 warnop = ((k1->op_type == OP_NULL)
3731 ? k1->op_targ : k1->op_type);
3736 line_t oldline = CopLINE(PL_curcop);
3737 CopLINE_set(PL_curcop, PL_copline);
3738 Perl_warner(aTHX_ WARN_MISC,
3739 "Value of %s%s can be \"0\"; test with defined()",
3741 ((warnop == OP_READLINE || warnop == OP_GLOB)
3742 ? " construct" : "() operator"));
3743 CopLINE_set(PL_curcop, oldline);
3750 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3751 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3753 NewOp(1101, logop, 1, LOGOP);
3755 logop->op_type = type;
3756 logop->op_ppaddr = PL_ppaddr[type];
3757 logop->op_first = first;
3758 logop->op_flags = flags | OPf_KIDS;
3759 logop->op_other = LINKLIST(other);
3760 logop->op_private = 1 | (flags >> 8);
3762 /* establish postfix order */
3763 logop->op_next = LINKLIST(first);
3764 first->op_next = (OP*)logop;
3765 first->op_sibling = other;
3767 o = newUNOP(OP_NULL, 0, (OP*)logop);
3774 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3781 return newLOGOP(OP_AND, 0, first, trueop);
3783 return newLOGOP(OP_OR, 0, first, falseop);
3785 scalarboolean(first);
3786 if (first->op_type == OP_CONST) {
3787 if (SvTRUE(((SVOP*)first)->op_sv)) {
3798 else if (first->op_type == OP_WANTARRAY) {
3802 NewOp(1101, logop, 1, LOGOP);
3803 logop->op_type = OP_COND_EXPR;
3804 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3805 logop->op_first = first;
3806 logop->op_flags = flags | OPf_KIDS;
3807 logop->op_private = 1 | (flags >> 8);
3808 logop->op_other = LINKLIST(trueop);
3809 logop->op_next = LINKLIST(falseop);
3812 /* establish postfix order */
3813 start = LINKLIST(first);
3814 first->op_next = (OP*)logop;
3816 first->op_sibling = trueop;
3817 trueop->op_sibling = falseop;
3818 o = newUNOP(OP_NULL, 0, (OP*)logop);
3820 trueop->op_next = falseop->op_next = o;
3827 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3835 NewOp(1101, range, 1, LOGOP);
3837 range->op_type = OP_RANGE;
3838 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3839 range->op_first = left;
3840 range->op_flags = OPf_KIDS;
3841 leftstart = LINKLIST(left);
3842 range->op_other = LINKLIST(right);
3843 range->op_private = 1 | (flags >> 8);
3845 left->op_sibling = right;
3847 range->op_next = (OP*)range;
3848 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3849 flop = newUNOP(OP_FLOP, 0, flip);
3850 o = newUNOP(OP_NULL, 0, flop);
3852 range->op_next = leftstart;
3854 left->op_next = flip;
3855 right->op_next = flop;
3857 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3858 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3859 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3860 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3862 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3863 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3866 if (!flip->op_private || !flop->op_private)
3867 linklist(o); /* blow off optimizer unless constant */
3873 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3877 int once = block && block->op_flags & OPf_SPECIAL &&
3878 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3881 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3882 return block; /* do {} while 0 does once */
3883 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3884 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3885 expr = newUNOP(OP_DEFINED, 0,
3886 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3887 } else if (expr->op_flags & OPf_KIDS) {
3888 OP *k1 = ((UNOP*)expr)->op_first;
3889 OP *k2 = (k1) ? k1->op_sibling : NULL;
3890 switch (expr->op_type) {
3892 if (k2 && k2->op_type == OP_READLINE
3893 && (k2->op_flags & OPf_STACKED)
3894 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3895 expr = newUNOP(OP_DEFINED, 0, expr);
3899 if (k1->op_type == OP_READDIR
3900 || k1->op_type == OP_GLOB
3901 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3902 || k1->op_type == OP_EACH)
3903 expr = newUNOP(OP_DEFINED, 0, expr);
3909 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3910 o = new_logop(OP_AND, 0, &expr, &listop);
3913 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3915 if (once && o != listop)
3916 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3919 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3921 o->op_flags |= flags;
3923 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3928 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3936 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3937 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3938 expr = newUNOP(OP_DEFINED, 0,
3939 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3940 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3941 OP *k1 = ((UNOP*)expr)->op_first;
3942 OP *k2 = (k1) ? k1->op_sibling : NULL;
3943 switch (expr->op_type) {
3945 if (k2 && k2->op_type == OP_READLINE
3946 && (k2->op_flags & OPf_STACKED)
3947 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3948 expr = newUNOP(OP_DEFINED, 0, expr);
3952 if (k1->op_type == OP_READDIR
3953 || k1->op_type == OP_GLOB
3954 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3955 || k1->op_type == OP_EACH)
3956 expr = newUNOP(OP_DEFINED, 0, expr);
3962 block = newOP(OP_NULL, 0);
3964 block = scope(block);
3968 next = LINKLIST(cont);
3971 OP *unstack = newOP(OP_UNSTACK, 0);
3974 cont = append_elem(OP_LINESEQ, cont, unstack);
3975 if ((line_t)whileline != NOLINE) {
3976 PL_copline = whileline;
3977 cont = append_elem(OP_LINESEQ, cont,
3978 newSTATEOP(0, Nullch, Nullop));
3982 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3983 redo = LINKLIST(listop);
3986 PL_copline = whileline;
3988 o = new_logop(OP_AND, 0, &expr, &listop);
3989 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3990 op_free(expr); /* oops, it's a while (0) */
3992 return Nullop; /* listop already freed by new_logop */
3995 ((LISTOP*)listop)->op_last->op_next =
3996 (o == listop ? redo : LINKLIST(o));
4002 NewOp(1101,loop,1,LOOP);
4003 loop->op_type = OP_ENTERLOOP;
4004 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4005 loop->op_private = 0;
4006 loop->op_next = (OP*)loop;
4009 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4011 loop->op_redoop = redo;
4012 loop->op_lastop = o;
4013 o->op_private |= loopflags;
4016 loop->op_nextop = next;
4018 loop->op_nextop = o;
4020 o->op_flags |= flags;
4021 o->op_private |= (flags >> 8);
4026 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4034 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4035 sv->op_type = OP_RV2GV;
4036 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4038 else if (sv->op_type == OP_PADSV) { /* private variable */
4039 padoff = sv->op_targ;
4044 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4045 padoff = sv->op_targ;
4047 iterflags |= OPf_SPECIAL;
4052 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4056 padoff = find_threadsv("_");
4057 iterflags |= OPf_SPECIAL;
4059 sv = newGVOP(OP_GV, 0, PL_defgv);
4062 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4063 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4064 iterflags |= OPf_STACKED;
4066 else if (expr->op_type == OP_NULL &&
4067 (expr->op_flags & OPf_KIDS) &&
4068 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4070 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4071 * set the STACKED flag to indicate that these values are to be
4072 * treated as min/max values by 'pp_iterinit'.
4074 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4075 LOGOP* range = (LOGOP*) flip->op_first;
4076 OP* left = range->op_first;
4077 OP* right = left->op_sibling;
4080 range->op_flags &= ~OPf_KIDS;
4081 range->op_first = Nullop;
4083 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4084 listop->op_first->op_next = range->op_next;
4085 left->op_next = range->op_other;
4086 right->op_next = (OP*)listop;
4087 listop->op_next = listop->op_first;
4090 expr = (OP*)(listop);
4092 iterflags |= OPf_STACKED;
4095 expr = mod(force_list(expr), OP_GREPSTART);
4099 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4100 append_elem(OP_LIST, expr, scalar(sv))));
4101 assert(!loop->op_next);
4102 #ifdef PL_OP_SLAB_ALLOC
4105 NewOp(1234,tmp,1,LOOP);
4106 Copy(loop,tmp,1,LOOP);
4110 Renew(loop, 1, LOOP);
4112 loop->op_targ = padoff;
4113 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4114 PL_copline = forline;
4115 return newSTATEOP(0, label, wop);
4119 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4124 if (type != OP_GOTO || label->op_type == OP_CONST) {
4125 /* "last()" means "last" */
4126 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4127 o = newOP(type, OPf_SPECIAL);
4129 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4130 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4136 if (label->op_type == OP_ENTERSUB)
4137 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4138 o = newUNOP(type, OPf_STACKED, label);
4140 PL_hints |= HINT_BLOCK_SCOPE;
4145 Perl_cv_undef(pTHX_ CV *cv)
4149 MUTEX_DESTROY(CvMUTEXP(cv));
4150 Safefree(CvMUTEXP(cv));
4153 #endif /* USE_THREADS */
4156 if (CvFILE(cv) && !CvXSUB(cv)) {
4157 Safefree(CvFILE(cv));
4162 if (!CvXSUB(cv) && CvROOT(cv)) {
4164 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4165 Perl_croak(aTHX_ "Can't undef active subroutine");
4168 Perl_croak(aTHX_ "Can't undef active subroutine");
4169 #endif /* USE_THREADS */
4172 SAVEVPTR(PL_curpad);
4175 op_free(CvROOT(cv));
4176 CvROOT(cv) = Nullop;
4179 SvPOK_off((SV*)cv); /* forget prototype */
4181 /* Since closure prototypes have the same lifetime as the containing
4182 * CV, they don't hold a refcount on the outside CV. This avoids
4183 * the refcount loop between the outer CV (which keeps a refcount to
4184 * the closure prototype in the pad entry for pp_anoncode()) and the
4185 * closure prototype, and the ensuing memory leak. This does not
4186 * apply to closures generated within eval"", since eval"" CVs are
4187 * ephemeral. --GSAR */
4188 if (!CvANON(cv) || CvCLONED(cv)
4189 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4190 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4192 SvREFCNT_dec(CvOUTSIDE(cv));
4194 CvOUTSIDE(cv) = Nullcv;
4196 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4199 if (CvPADLIST(cv)) {
4200 /* may be during global destruction */
4201 if (SvREFCNT(CvPADLIST(cv))) {
4202 I32 i = AvFILLp(CvPADLIST(cv));
4204 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4205 SV* sv = svp ? *svp : Nullsv;
4208 if (sv == (SV*)PL_comppad_name)
4209 PL_comppad_name = Nullav;
4210 else if (sv == (SV*)PL_comppad) {
4211 PL_comppad = Nullav;
4212 PL_curpad = Null(SV**);
4216 SvREFCNT_dec((SV*)CvPADLIST(cv));
4218 CvPADLIST(cv) = Nullav;
4226 #ifdef DEBUG_CLOSURES
4228 S_cv_dump(pTHX_ CV *cv)
4231 CV *outside = CvOUTSIDE(cv);
4232 AV* padlist = CvPADLIST(cv);
4239 PerlIO_printf(Perl_debug_log,
4240 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4242 (CvANON(cv) ? "ANON"
4243 : (cv == PL_main_cv) ? "MAIN"
4244 : CvUNIQUE(cv) ? "UNIQUE"
4245 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4248 : CvANON(outside) ? "ANON"
4249 : (outside == PL_main_cv) ? "MAIN"
4250 : CvUNIQUE(outside) ? "UNIQUE"
4251 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4256 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4257 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4258 pname = AvARRAY(pad_name);
4259 ppad = AvARRAY(pad);
4261 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4262 if (SvPOK(pname[ix]))
4263 PerlIO_printf(Perl_debug_log,
4264 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4265 (int)ix, PTR2UV(ppad[ix]),
4266 SvFAKE(pname[ix]) ? "FAKE " : "",
4268 (IV)I_32(SvNVX(pname[ix])),
4271 #endif /* DEBUGGING */
4273 #endif /* DEBUG_CLOSURES */
4276 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4280 AV* protopadlist = CvPADLIST(proto);
4281 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4282 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4283 SV** pname = AvARRAY(protopad_name);
4284 SV** ppad = AvARRAY(protopad);
4285 I32 fname = AvFILLp(protopad_name);
4286 I32 fpad = AvFILLp(protopad);
4290 assert(!CvUNIQUE(proto));
4294 SAVESPTR(PL_comppad_name);
4295 SAVESPTR(PL_compcv);
4297 cv = PL_compcv = (CV*)NEWSV(1104,0);
4298 sv_upgrade((SV *)cv, SvTYPE(proto));
4299 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4303 New(666, CvMUTEXP(cv), 1, perl_mutex);
4304 MUTEX_INIT(CvMUTEXP(cv));
4306 #endif /* USE_THREADS */
4308 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4309 : savepv(CvFILE(proto));
4311 CvFILE(cv) = CvFILE(proto);
4313 CvGV(cv) = CvGV(proto);
4314 CvSTASH(cv) = CvSTASH(proto);
4315 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4316 CvSTART(cv) = CvSTART(proto);
4318 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4321 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4323 PL_comppad_name = newAV();
4324 for (ix = fname; ix >= 0; ix--)
4325 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4327 PL_comppad = newAV();
4329 comppadlist = newAV();
4330 AvREAL_off(comppadlist);
4331 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4332 av_store(comppadlist, 1, (SV*)PL_comppad);
4333 CvPADLIST(cv) = comppadlist;
4334 av_fill(PL_comppad, AvFILLp(protopad));
4335 PL_curpad = AvARRAY(PL_comppad);
4337 av = newAV(); /* will be @_ */
4339 av_store(PL_comppad, 0, (SV*)av);
4340 AvFLAGS(av) = AVf_REIFY;
4342 for (ix = fpad; ix > 0; ix--) {
4343 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4344 if (namesv && namesv != &PL_sv_undef) {
4345 char *name = SvPVX(namesv); /* XXX */
4346 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4347 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4348 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4350 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4352 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4354 else { /* our own lexical */
4357 /* anon code -- we'll come back for it */
4358 sv = SvREFCNT_inc(ppad[ix]);
4360 else if (*name == '@')
4362 else if (*name == '%')
4371 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4372 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4375 SV* sv = NEWSV(0,0);
4381 /* Now that vars are all in place, clone nested closures. */
4383 for (ix = fpad; ix > 0; ix--) {
4384 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4386 && namesv != &PL_sv_undef
4387 && !(SvFLAGS(namesv) & SVf_FAKE)
4388 && *SvPVX(namesv) == '&'
4389 && CvCLONE(ppad[ix]))
4391 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4392 SvREFCNT_dec(ppad[ix]);
4395 PL_curpad[ix] = (SV*)kid;
4399 #ifdef DEBUG_CLOSURES
4400 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4402 PerlIO_printf(Perl_debug_log, " from:\n");
4404 PerlIO_printf(Perl_debug_log, " to:\n");
4411 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4413 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4415 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4422 Perl_cv_clone(pTHX_ CV *proto)
4425 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4426 cv = cv_clone2(proto, CvOUTSIDE(proto));
4427 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4432 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4434 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4435 SV* msg = sv_newmortal();
4439 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4440 sv_setpv(msg, "Prototype mismatch:");
4442 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4444 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4445 sv_catpv(msg, " vs ");
4447 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4449 sv_catpv(msg, "none");
4450 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4454 static void const_sv_xsub(pTHXo_ CV* cv);
4457 =for apidoc cv_const_sv
4459 If C<cv> is a constant sub eligible for inlining. returns the constant
4460 value returned by the sub. Otherwise, returns NULL.
4462 Constant subs can be created with C<newCONSTSUB> or as described in
4463 L<perlsub/"Constant Functions">.
4468 Perl_cv_const_sv(pTHX_ CV *cv)
4470 if (!cv || !CvCONST(cv))
4472 return (SV*)CvXSUBANY(cv).any_ptr;
4476 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4483 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4484 o = cLISTOPo->op_first->op_sibling;
4486 for (; o; o = o->op_next) {
4487 OPCODE type = o->op_type;
4489 if (sv && o->op_next == o)
4491 if (o->op_next != o) {
4492 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4494 if (type == OP_DBSTATE)
4497 if (type == OP_LEAVESUB || type == OP_RETURN)
4501 if (type == OP_CONST && cSVOPo->op_sv)
4503 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4504 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4505 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4509 /* We get here only from cv_clone2() while creating a closure.
4510 Copy the const value here instead of in cv_clone2 so that
4511 SvREADONLY_on doesn't lead to problems when leaving
4516 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4528 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4538 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4542 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4544 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4548 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4554 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4559 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4560 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4561 SV *sv = sv_newmortal();
4562 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4563 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4568 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4569 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4579 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4580 maximum a prototype before. */
4581 if (SvTYPE(gv) > SVt_NULL) {
4582 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4583 && ckWARN_d(WARN_PROTOTYPE))
4585 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4587 cv_ckproto((CV*)gv, NULL, ps);
4590 sv_setpv((SV*)gv, ps);
4592 sv_setiv((SV*)gv, -1);
4593 SvREFCNT_dec(PL_compcv);
4594 cv = PL_compcv = NULL;
4595 PL_sub_generation++;
4599 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4601 #ifdef GV_UNIQUE_CHECK
4602 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4603 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4607 if (!block || !ps || *ps || attrs)
4610 const_sv = op_const_sv(block, Nullcv);
4613 bool exists = CvROOT(cv) || CvXSUB(cv);
4615 #ifdef GV_UNIQUE_CHECK
4616 if (exists && GvUNIQUE(gv)) {
4617 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4621 /* if the subroutine doesn't exist and wasn't pre-declared
4622 * with a prototype, assume it will be AUTOLOADed,
4623 * skipping the prototype check
4625 if (exists || SvPOK(cv))
4626 cv_ckproto(cv, gv, ps);
4627 /* already defined (or promised)? */
4628 if (exists || GvASSUMECV(gv)) {
4629 if (!block && !attrs) {
4630 /* just a "sub foo;" when &foo is already defined */
4631 SAVEFREESV(PL_compcv);
4634 /* ahem, death to those who redefine active sort subs */
4635 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4636 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4638 if (ckWARN(WARN_REDEFINE)
4640 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4642 line_t oldline = CopLINE(PL_curcop);
4643 CopLINE_set(PL_curcop, PL_copline);
4644 Perl_warner(aTHX_ WARN_REDEFINE,
4645 CvCONST(cv) ? "Constant subroutine %s redefined"
4646 : "Subroutine %s redefined", name);
4647 CopLINE_set(PL_curcop, oldline);
4655 SvREFCNT_inc(const_sv);
4657 assert(!CvROOT(cv) && !CvCONST(cv));
4658 sv_setpv((SV*)cv, ""); /* prototype is "" */
4659 CvXSUBANY(cv).any_ptr = const_sv;
4660 CvXSUB(cv) = const_sv_xsub;
4665 cv = newCONSTSUB(NULL, name, const_sv);
4668 SvREFCNT_dec(PL_compcv);
4670 PL_sub_generation++;
4677 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4678 * before we clobber PL_compcv.
4682 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4683 stash = GvSTASH(CvGV(cv));
4684 else if (CvSTASH(cv))
4685 stash = CvSTASH(cv);
4687 stash = PL_curstash;
4690 /* possibly about to re-define existing subr -- ignore old cv */
4691 rcv = (SV*)PL_compcv;
4692 if (name && GvSTASH(gv))
4693 stash = GvSTASH(gv);
4695 stash = PL_curstash;
4697 apply_attrs(stash, rcv, attrs);
4699 if (cv) { /* must reuse cv if autoloaded */
4701 /* got here with just attrs -- work done, so bug out */
4702 SAVEFREESV(PL_compcv);
4706 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4707 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4708 CvOUTSIDE(PL_compcv) = 0;
4709 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4710 CvPADLIST(PL_compcv) = 0;
4711 /* inner references to PL_compcv must be fixed up ... */
4713 AV *padlist = CvPADLIST(cv);
4714 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4715 AV *comppad = (AV*)AvARRAY(padlist)[1];
4716 SV **namepad = AvARRAY(comppad_name);
4717 SV **curpad = AvARRAY(comppad);
4718 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4719 SV *namesv = namepad[ix];
4720 if (namesv && namesv != &PL_sv_undef
4721 && *SvPVX(namesv) == '&')
4723 CV *innercv = (CV*)curpad[ix];
4724 if (CvOUTSIDE(innercv) == PL_compcv) {
4725 CvOUTSIDE(innercv) = cv;
4726 if (!CvANON(innercv) || CvCLONED(innercv)) {
4727 (void)SvREFCNT_inc(cv);
4728 SvREFCNT_dec(PL_compcv);
4734 /* ... before we throw it away */
4735 SvREFCNT_dec(PL_compcv);
4742 PL_sub_generation++;
4746 CvFILE_set_from_cop(cv, PL_curcop);
4747 CvSTASH(cv) = PL_curstash;
4750 if (!CvMUTEXP(cv)) {
4751 New(666, CvMUTEXP(cv), 1, perl_mutex);
4752 MUTEX_INIT(CvMUTEXP(cv));
4754 #endif /* USE_THREADS */
4757 sv_setpv((SV*)cv, ps);
4759 if (PL_error_count) {
4763 char *s = strrchr(name, ':');
4765 if (strEQ(s, "BEGIN")) {
4767 "BEGIN not safe after errors--compilation aborted";
4768 if (PL_in_eval & EVAL_KEEPERR)
4769 Perl_croak(aTHX_ not_safe);
4771 /* force display of errors found but not reported */
4772 sv_catpv(ERRSV, not_safe);
4773 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4781 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4782 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4785 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4786 mod(scalarseq(block), OP_LEAVESUBLV));
4789 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4791 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4792 OpREFCNT_set(CvROOT(cv), 1);
4793 CvSTART(cv) = LINKLIST(CvROOT(cv));
4794 CvROOT(cv)->op_next = 0;
4797 /* now that optimizer has done its work, adjust pad values */
4799 SV **namep = AvARRAY(PL_comppad_name);
4800 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4803 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4806 * The only things that a clonable function needs in its
4807 * pad are references to outer lexicals and anonymous subs.
4808 * The rest are created anew during cloning.
4810 if (!((namesv = namep[ix]) != Nullsv &&
4811 namesv != &PL_sv_undef &&
4813 *SvPVX(namesv) == '&')))
4815 SvREFCNT_dec(PL_curpad[ix]);
4816 PL_curpad[ix] = Nullsv;
4819 assert(!CvCONST(cv));
4820 if (ps && !*ps && op_const_sv(block, cv))
4824 AV *av = newAV(); /* Will be @_ */
4826 av_store(PL_comppad, 0, (SV*)av);
4827 AvFLAGS(av) = AVf_REIFY;
4829 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4830 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4832 if (!SvPADMY(PL_curpad[ix]))
4833 SvPADTMP_on(PL_curpad[ix]);
4837 /* If a potential closure prototype, don't keep a refcount on
4838 * outer CV, unless the latter happens to be a passing eval"".
4839 * This is okay as the lifetime of the prototype is tied to the
4840 * lifetime of the outer CV. Avoids memory leak due to reference
4842 if (!name && CvOUTSIDE(cv)
4843 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4844 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4846 SvREFCNT_dec(CvOUTSIDE(cv));
4849 if (name || aname) {
4851 char *tname = (name ? name : aname);
4853 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4854 SV *sv = NEWSV(0,0);
4855 SV *tmpstr = sv_newmortal();
4856 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4860 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4862 (long)PL_subline, (long)CopLINE(PL_curcop));
4863 gv_efullname3(tmpstr, gv, Nullch);
4864 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4865 hv = GvHVn(db_postponed);
4866 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4867 && (pcv = GvCV(db_postponed)))
4873 call_sv((SV*)pcv, G_DISCARD);
4877 if ((s = strrchr(tname,':')))
4882 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4885 if (strEQ(s, "BEGIN")) {
4886 I32 oldscope = PL_scopestack_ix;
4888 SAVECOPFILE(&PL_compiling);
4889 SAVECOPLINE(&PL_compiling);
4891 sv_setsv(PL_rs, PL_nrs);
4894 PL_beginav = newAV();
4895 DEBUG_x( dump_sub(gv) );
4896 av_push(PL_beginav, (SV*)cv);
4897 GvCV(gv) = 0; /* cv has been hijacked */
4898 call_list(oldscope, PL_beginav);
4900 PL_curcop = &PL_compiling;
4901 PL_compiling.op_private = PL_hints;
4904 else if (strEQ(s, "END") && !PL_error_count) {
4907 DEBUG_x( dump_sub(gv) );
4908 av_unshift(PL_endav, 1);
4909 av_store(PL_endav, 0, (SV*)cv);
4910 GvCV(gv) = 0; /* cv has been hijacked */
4912 else if (strEQ(s, "CHECK") && !PL_error_count) {
4914 PL_checkav = newAV();
4915 DEBUG_x( dump_sub(gv) );
4916 if (PL_main_start && ckWARN(WARN_VOID))
4917 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4918 av_unshift(PL_checkav, 1);
4919 av_store(PL_checkav, 0, (SV*)cv);
4920 GvCV(gv) = 0; /* cv has been hijacked */
4922 else if (strEQ(s, "INIT") && !PL_error_count) {
4924 PL_initav = newAV();
4925 DEBUG_x( dump_sub(gv) );
4926 if (PL_main_start && ckWARN(WARN_VOID))
4927 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4928 av_push(PL_initav, (SV*)cv);
4929 GvCV(gv) = 0; /* cv has been hijacked */
4934 PL_copline = NOLINE;
4939 /* XXX unsafe for threads if eval_owner isn't held */
4941 =for apidoc newCONSTSUB
4943 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4944 eligible for inlining at compile-time.
4950 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4956 SAVECOPLINE(PL_curcop);
4957 CopLINE_set(PL_curcop, PL_copline);
4960 PL_hints &= ~HINT_BLOCK_SCOPE;
4963 SAVESPTR(PL_curstash);
4964 SAVECOPSTASH(PL_curcop);
4965 PL_curstash = stash;
4967 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4969 CopSTASH(PL_curcop) = stash;
4973 cv = newXS(name, const_sv_xsub, __FILE__);
4974 CvXSUBANY(cv).any_ptr = sv;
4976 sv_setpv((SV*)cv, ""); /* prototype is "" */
4984 =for apidoc U||newXS
4986 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4992 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4994 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4997 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4999 /* just a cached method */
5003 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5004 /* already defined (or promised) */
5005 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5006 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5007 line_t oldline = CopLINE(PL_curcop);
5008 if (PL_copline != NOLINE)
5009 CopLINE_set(PL_curcop, PL_copline);
5010 Perl_warner(aTHX_ WARN_REDEFINE,
5011 CvCONST(cv) ? "Constant subroutine %s redefined"
5012 : "Subroutine %s redefined"
5014 CopLINE_set(PL_curcop, oldline);
5021 if (cv) /* must reuse cv if autoloaded */
5024 cv = (CV*)NEWSV(1105,0);
5025 sv_upgrade((SV *)cv, SVt_PVCV);
5029 PL_sub_generation++;
5034 New(666, CvMUTEXP(cv), 1, perl_mutex);
5035 MUTEX_INIT(CvMUTEXP(cv));
5037 #endif /* USE_THREADS */
5038 (void)gv_fetchfile(filename);
5039 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5040 an external constant string */
5041 CvXSUB(cv) = subaddr;
5044 char *s = strrchr(name,':');
5050 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5053 if (strEQ(s, "BEGIN")) {
5055 PL_beginav = newAV();
5056 av_push(PL_beginav, (SV*)cv);
5057 GvCV(gv) = 0; /* cv has been hijacked */
5059 else if (strEQ(s, "END")) {
5062 av_unshift(PL_endav, 1);
5063 av_store(PL_endav, 0, (SV*)cv);
5064 GvCV(gv) = 0; /* cv has been hijacked */
5066 else if (strEQ(s, "CHECK")) {
5068 PL_checkav = newAV();
5069 if (PL_main_start && ckWARN(WARN_VOID))
5070 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5071 av_unshift(PL_checkav, 1);
5072 av_store(PL_checkav, 0, (SV*)cv);
5073 GvCV(gv) = 0; /* cv has been hijacked */
5075 else if (strEQ(s, "INIT")) {
5077 PL_initav = newAV();
5078 if (PL_main_start && ckWARN(WARN_VOID))
5079 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5080 av_push(PL_initav, (SV*)cv);
5081 GvCV(gv) = 0; /* cv has been hijacked */
5092 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5101 name = SvPVx(cSVOPo->op_sv, n_a);
5104 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5105 #ifdef GV_UNIQUE_CHECK
5107 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5111 if ((cv = GvFORM(gv))) {
5112 if (ckWARN(WARN_REDEFINE)) {
5113 line_t oldline = CopLINE(PL_curcop);
5115 CopLINE_set(PL_curcop, PL_copline);
5116 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5117 CopLINE_set(PL_curcop, oldline);
5124 CvFILE_set_from_cop(cv, PL_curcop);
5126 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5127 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5128 SvPADTMP_on(PL_curpad[ix]);
5131 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5132 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5133 OpREFCNT_set(CvROOT(cv), 1);
5134 CvSTART(cv) = LINKLIST(CvROOT(cv));
5135 CvROOT(cv)->op_next = 0;
5138 PL_copline = NOLINE;
5143 Perl_newANONLIST(pTHX_ OP *o)
5145 return newUNOP(OP_REFGEN, 0,
5146 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5150 Perl_newANONHASH(pTHX_ OP *o)
5152 return newUNOP(OP_REFGEN, 0,
5153 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5157 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5159 return newANONATTRSUB(floor, proto, Nullop, block);
5163 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5165 return newUNOP(OP_REFGEN, 0,
5166 newSVOP(OP_ANONCODE, 0,
5167 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5171 Perl_oopsAV(pTHX_ OP *o)
5173 switch (o->op_type) {
5175 o->op_type = OP_PADAV;
5176 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5177 return ref(o, OP_RV2AV);
5180 o->op_type = OP_RV2AV;
5181 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5186 if (ckWARN_d(WARN_INTERNAL))
5187 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5194 Perl_oopsHV(pTHX_ OP *o)
5196 switch (o->op_type) {
5199 o->op_type = OP_PADHV;
5200 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5201 return ref(o, OP_RV2HV);
5205 o->op_type = OP_RV2HV;
5206 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5211 if (ckWARN_d(WARN_INTERNAL))
5212 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5219 Perl_newAVREF(pTHX_ OP *o)
5221 if (o->op_type == OP_PADANY) {
5222 o->op_type = OP_PADAV;
5223 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5226 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5227 && ckWARN(WARN_DEPRECATED)) {
5228 Perl_warner(aTHX_ WARN_DEPRECATED,
5229 "Using an array as a reference is deprecated");
5231 return newUNOP(OP_RV2AV, 0, scalar(o));
5235 Perl_newGVREF(pTHX_ I32 type, OP *o)
5237 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5238 return newUNOP(OP_NULL, 0, o);
5239 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5243 Perl_newHVREF(pTHX_ OP *o)
5245 if (o->op_type == OP_PADANY) {
5246 o->op_type = OP_PADHV;
5247 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5250 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5251 && ckWARN(WARN_DEPRECATED)) {
5252 Perl_warner(aTHX_ WARN_DEPRECATED,
5253 "Using a hash as a reference is deprecated");
5255 return newUNOP(OP_RV2HV, 0, scalar(o));
5259 Perl_oopsCV(pTHX_ OP *o)
5261 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5267 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5269 return newUNOP(OP_RV2CV, flags, scalar(o));
5273 Perl_newSVREF(pTHX_ OP *o)
5275 if (o->op_type == OP_PADANY) {
5276 o->op_type = OP_PADSV;
5277 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5280 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5281 o->op_flags |= OPpDONE_SVREF;
5284 return newUNOP(OP_RV2SV, 0, scalar(o));
5287 /* Check routines. */
5290 Perl_ck_anoncode(pTHX_ OP *o)
5295 name = NEWSV(1106,0);
5296 sv_upgrade(name, SVt_PVNV);
5297 sv_setpvn(name, "&", 1);
5300 ix = pad_alloc(o->op_type, SVs_PADMY);
5301 av_store(PL_comppad_name, ix, name);
5302 av_store(PL_comppad, ix, cSVOPo->op_sv);
5303 SvPADMY_on(cSVOPo->op_sv);
5304 cSVOPo->op_sv = Nullsv;
5305 cSVOPo->op_targ = ix;
5310 Perl_ck_bitop(pTHX_ OP *o)
5312 o->op_private = PL_hints;
5317 Perl_ck_concat(pTHX_ OP *o)
5319 if (cUNOPo->op_first->op_type == OP_CONCAT)
5320 o->op_flags |= OPf_STACKED;
5325 Perl_ck_spair(pTHX_ OP *o)
5327 if (o->op_flags & OPf_KIDS) {
5330 OPCODE type = o->op_type;
5331 o = modkids(ck_fun(o), type);
5332 kid = cUNOPo->op_first;
5333 newop = kUNOP->op_first->op_sibling;
5335 (newop->op_sibling ||
5336 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5337 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5338 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5342 op_free(kUNOP->op_first);
5343 kUNOP->op_first = newop;
5345 o->op_ppaddr = PL_ppaddr[++o->op_type];
5350 Perl_ck_delete(pTHX_ OP *o)
5354 if (o->op_flags & OPf_KIDS) {
5355 OP *kid = cUNOPo->op_first;
5356 switch (kid->op_type) {
5358 o->op_flags |= OPf_SPECIAL;
5361 o->op_private |= OPpSLICE;
5364 o->op_flags |= OPf_SPECIAL;
5369 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5370 PL_op_desc[o->op_type]);
5378 Perl_ck_eof(pTHX_ OP *o)
5380 I32 type = o->op_type;
5382 if (o->op_flags & OPf_KIDS) {
5383 if (cLISTOPo->op_first->op_type == OP_STUB) {
5385 o = newUNOP(type, OPf_SPECIAL,
5386 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5394 Perl_ck_eval(pTHX_ OP *o)
5396 PL_hints |= HINT_BLOCK_SCOPE;
5397 if (o->op_flags & OPf_KIDS) {
5398 SVOP *kid = (SVOP*)cUNOPo->op_first;
5401 o->op_flags &= ~OPf_KIDS;
5404 else if (kid->op_type == OP_LINESEQ) {
5407 kid->op_next = o->op_next;
5408 cUNOPo->op_first = 0;
5411 NewOp(1101, enter, 1, LOGOP);
5412 enter->op_type = OP_ENTERTRY;
5413 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5414 enter->op_private = 0;
5416 /* establish postfix order */
5417 enter->op_next = (OP*)enter;
5419 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5420 o->op_type = OP_LEAVETRY;
5421 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5422 enter->op_other = o;
5430 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5432 o->op_targ = (PADOFFSET)PL_hints;
5437 Perl_ck_exit(pTHX_ OP *o)
5440 HV *table = GvHV(PL_hintgv);
5442 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5443 if (svp && *svp && SvTRUE(*svp))
5444 o->op_private |= OPpEXIT_VMSISH;
5451 Perl_ck_exec(pTHX_ OP *o)
5454 if (o->op_flags & OPf_STACKED) {
5456 kid = cUNOPo->op_first->op_sibling;
5457 if (kid->op_type == OP_RV2GV)
5466 Perl_ck_exists(pTHX_ OP *o)
5469 if (o->op_flags & OPf_KIDS) {
5470 OP *kid = cUNOPo->op_first;
5471 if (kid->op_type == OP_ENTERSUB) {
5472 (void) ref(kid, o->op_type);
5473 if (kid->op_type != OP_RV2CV && !PL_error_count)
5474 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5475 PL_op_desc[o->op_type]);
5476 o->op_private |= OPpEXISTS_SUB;
5478 else if (kid->op_type == OP_AELEM)
5479 o->op_flags |= OPf_SPECIAL;
5480 else if (kid->op_type != OP_HELEM)
5481 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5482 PL_op_desc[o->op_type]);
5490 Perl_ck_gvconst(pTHX_ register OP *o)
5492 o = fold_constants(o);
5493 if (o->op_type == OP_CONST)
5500 Perl_ck_rvconst(pTHX_ register OP *o)
5502 SVOP *kid = (SVOP*)cUNOPo->op_first;
5504 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5505 if (kid->op_type == OP_CONST) {
5509 SV *kidsv = kid->op_sv;
5512 /* Is it a constant from cv_const_sv()? */
5513 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5514 SV *rsv = SvRV(kidsv);
5515 int svtype = SvTYPE(rsv);
5516 char *badtype = Nullch;
5518 switch (o->op_type) {
5520 if (svtype > SVt_PVMG)
5521 badtype = "a SCALAR";
5524 if (svtype != SVt_PVAV)
5525 badtype = "an ARRAY";
5528 if (svtype != SVt_PVHV) {
5529 if (svtype == SVt_PVAV) { /* pseudohash? */
5530 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5531 if (ksv && SvROK(*ksv)
5532 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5541 if (svtype != SVt_PVCV)
5546 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5549 name = SvPV(kidsv, n_a);
5550 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5551 char *badthing = Nullch;
5552 switch (o->op_type) {
5554 badthing = "a SCALAR";
5557 badthing = "an ARRAY";
5560 badthing = "a HASH";
5565 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5569 * This is a little tricky. We only want to add the symbol if we
5570 * didn't add it in the lexer. Otherwise we get duplicate strict
5571 * warnings. But if we didn't add it in the lexer, we must at
5572 * least pretend like we wanted to add it even if it existed before,
5573 * or we get possible typo warnings. OPpCONST_ENTERED says
5574 * whether the lexer already added THIS instance of this symbol.
5576 iscv = (o->op_type == OP_RV2CV) * 2;
5578 gv = gv_fetchpv(name,
5579 iscv | !(kid->op_private & OPpCONST_ENTERED),
5582 : o->op_type == OP_RV2SV
5584 : o->op_type == OP_RV2AV
5586 : o->op_type == OP_RV2HV
5589 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5591 kid->op_type = OP_GV;
5592 SvREFCNT_dec(kid->op_sv);
5594 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5595 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5596 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5598 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5600 kid->op_sv = SvREFCNT_inc(gv);
5602 kid->op_private = 0;
5603 kid->op_ppaddr = PL_ppaddr[OP_GV];
5610 Perl_ck_ftst(pTHX_ OP *o)
5612 I32 type = o->op_type;
5614 if (o->op_flags & OPf_REF) {
5617 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5618 SVOP *kid = (SVOP*)cUNOPo->op_first;
5620 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5622 OP *newop = newGVOP(type, OPf_REF,
5623 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5630 if (type == OP_FTTTY)
5631 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5634 o = newUNOP(type, 0, newDEFSVOP());
5640 Perl_ck_fun(pTHX_ OP *o)
5646 int type = o->op_type;
5647 register I32 oa = PL_opargs[type] >> OASHIFT;
5649 if (o->op_flags & OPf_STACKED) {
5650 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5653 return no_fh_allowed(o);
5656 if (o->op_flags & OPf_KIDS) {
5658 tokid = &cLISTOPo->op_first;
5659 kid = cLISTOPo->op_first;
5660 if (kid->op_type == OP_PUSHMARK ||
5661 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5663 tokid = &kid->op_sibling;
5664 kid = kid->op_sibling;
5666 if (!kid && PL_opargs[type] & OA_DEFGV)
5667 *tokid = kid = newDEFSVOP();
5671 sibl = kid->op_sibling;
5674 /* list seen where single (scalar) arg expected? */
5675 if (numargs == 1 && !(oa >> 4)
5676 && kid->op_type == OP_LIST && type != OP_SCALAR)
5678 return too_many_arguments(o,PL_op_desc[type]);
5691 if ((type == OP_PUSH || type == OP_UNSHIFT)
5692 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5693 Perl_warner(aTHX_ WARN_SYNTAX,
5694 "Useless use of %s with no values",
5697 if (kid->op_type == OP_CONST &&
5698 (kid->op_private & OPpCONST_BARE))
5700 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5701 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5702 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5703 if (ckWARN(WARN_DEPRECATED))
5704 Perl_warner(aTHX_ WARN_DEPRECATED,
5705 "Array @%s missing the @ in argument %"IVdf" of %s()",
5706 name, (IV)numargs, PL_op_desc[type]);
5709 kid->op_sibling = sibl;
5712 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5713 bad_type(numargs, "array", PL_op_desc[type], kid);
5717 if (kid->op_type == OP_CONST &&
5718 (kid->op_private & OPpCONST_BARE))
5720 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5721 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5722 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5723 if (ckWARN(WARN_DEPRECATED))
5724 Perl_warner(aTHX_ WARN_DEPRECATED,
5725 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5726 name, (IV)numargs, PL_op_desc[type]);
5729 kid->op_sibling = sibl;
5732 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5733 bad_type(numargs, "hash", PL_op_desc[type], kid);
5738 OP *newop = newUNOP(OP_NULL, 0, kid);
5739 kid->op_sibling = 0;
5741 newop->op_next = newop;
5743 kid->op_sibling = sibl;
5748 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5749 if (kid->op_type == OP_CONST &&
5750 (kid->op_private & OPpCONST_BARE))
5752 OP *newop = newGVOP(OP_GV, 0,
5753 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5758 else if (kid->op_type == OP_READLINE) {
5759 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5760 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5763 I32 flags = OPf_SPECIAL;
5767 /* is this op a FH constructor? */
5768 if (is_handle_constructor(o,numargs)) {
5769 char *name = Nullch;
5773 /* Set a flag to tell rv2gv to vivify
5774 * need to "prove" flag does not mean something
5775 * else already - NI-S 1999/05/07
5778 if (kid->op_type == OP_PADSV) {
5779 SV **namep = av_fetch(PL_comppad_name,
5781 if (namep && *namep)
5782 name = SvPV(*namep, len);
5784 else if (kid->op_type == OP_RV2SV
5785 && kUNOP->op_first->op_type == OP_GV)
5787 GV *gv = cGVOPx_gv(kUNOP->op_first);
5789 len = GvNAMELEN(gv);
5791 else if (kid->op_type == OP_AELEM
5792 || kid->op_type == OP_HELEM)
5794 name = "__ANONIO__";
5800 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5801 namesv = PL_curpad[targ];
5802 (void)SvUPGRADE(namesv, SVt_PV);
5804 sv_setpvn(namesv, "$", 1);
5805 sv_catpvn(namesv, name, len);
5808 kid->op_sibling = 0;
5809 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5810 kid->op_targ = targ;
5811 kid->op_private |= priv;
5813 kid->op_sibling = sibl;
5819 mod(scalar(kid), type);
5823 tokid = &kid->op_sibling;
5824 kid = kid->op_sibling;
5826 o->op_private |= numargs;
5828 return too_many_arguments(o,PL_op_desc[o->op_type]);
5831 else if (PL_opargs[type] & OA_DEFGV) {
5833 return newUNOP(type, 0, newDEFSVOP());
5837 while (oa & OA_OPTIONAL)
5839 if (oa && oa != OA_LIST)
5840 return too_few_arguments(o,PL_op_desc[o->op_type]);
5846 Perl_ck_glob(pTHX_ OP *o)
5851 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5852 append_elem(OP_GLOB, o, newDEFSVOP());
5854 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5855 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5857 #if !defined(PERL_EXTERNAL_GLOB)
5858 /* XXX this can be tightened up and made more failsafe. */
5862 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5864 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5865 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5866 GvCV(gv) = GvCV(glob_gv);
5867 SvREFCNT_inc((SV*)GvCV(gv));
5868 GvIMPORTED_CV_on(gv);
5871 #endif /* PERL_EXTERNAL_GLOB */
5873 if (gv && GvIMPORTED_CV(gv)) {
5874 append_elem(OP_GLOB, o,
5875 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5876 o->op_type = OP_LIST;
5877 o->op_ppaddr = PL_ppaddr[OP_LIST];
5878 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5879 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5880 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5881 append_elem(OP_LIST, o,
5882 scalar(newUNOP(OP_RV2CV, 0,
5883 newGVOP(OP_GV, 0, gv)))));
5884 o = newUNOP(OP_NULL, 0, ck_subr(o));
5885 o->op_targ = OP_GLOB; /* hint at what it used to be */
5888 gv = newGVgen("main");
5890 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5896 Perl_ck_grep(pTHX_ OP *o)
5900 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5902 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5903 NewOp(1101, gwop, 1, LOGOP);
5905 if (o->op_flags & OPf_STACKED) {
5908 kid = cLISTOPo->op_first->op_sibling;
5909 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5912 kid->op_next = (OP*)gwop;
5913 o->op_flags &= ~OPf_STACKED;
5915 kid = cLISTOPo->op_first->op_sibling;
5916 if (type == OP_MAPWHILE)
5923 kid = cLISTOPo->op_first->op_sibling;
5924 if (kid->op_type != OP_NULL)
5925 Perl_croak(aTHX_ "panic: ck_grep");
5926 kid = kUNOP->op_first;
5928 gwop->op_type = type;
5929 gwop->op_ppaddr = PL_ppaddr[type];
5930 gwop->op_first = listkids(o);
5931 gwop->op_flags |= OPf_KIDS;
5932 gwop->op_private = 1;
5933 gwop->op_other = LINKLIST(kid);
5934 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5935 kid->op_next = (OP*)gwop;
5937 kid = cLISTOPo->op_first->op_sibling;
5938 if (!kid || !kid->op_sibling)
5939 return too_few_arguments(o,PL_op_desc[o->op_type]);
5940 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5941 mod(kid, OP_GREPSTART);
5947 Perl_ck_index(pTHX_ OP *o)
5949 if (o->op_flags & OPf_KIDS) {
5950 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5952 kid = kid->op_sibling; /* get past "big" */
5953 if (kid && kid->op_type == OP_CONST)
5954 fbm_compile(((SVOP*)kid)->op_sv, 0);
5960 Perl_ck_lengthconst(pTHX_ OP *o)
5962 /* XXX length optimization goes here */
5967 Perl_ck_lfun(pTHX_ OP *o)
5969 OPCODE type = o->op_type;
5970 return modkids(ck_fun(o), type);
5974 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5976 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5977 switch (cUNOPo->op_first->op_type) {
5979 /* This is needed for
5980 if (defined %stash::)
5981 to work. Do not break Tk.
5983 break; /* Globals via GV can be undef */
5985 case OP_AASSIGN: /* Is this a good idea? */
5986 Perl_warner(aTHX_ WARN_DEPRECATED,
5987 "defined(@array) is deprecated");
5988 Perl_warner(aTHX_ WARN_DEPRECATED,
5989 "\t(Maybe you should just omit the defined()?)\n");
5992 /* This is needed for
5993 if (defined %stash::)
5994 to work. Do not break Tk.
5996 break; /* Globals via GV can be undef */
5998 Perl_warner(aTHX_ WARN_DEPRECATED,
5999 "defined(%%hash) is deprecated");
6000 Perl_warner(aTHX_ WARN_DEPRECATED,
6001 "\t(Maybe you should just omit the defined()?)\n");
6012 Perl_ck_rfun(pTHX_ OP *o)
6014 OPCODE type = o->op_type;
6015 return refkids(ck_fun(o), type);
6019 Perl_ck_listiob(pTHX_ OP *o)
6023 kid = cLISTOPo->op_first;
6026 kid = cLISTOPo->op_first;
6028 if (kid->op_type == OP_PUSHMARK)
6029 kid = kid->op_sibling;
6030 if (kid && o->op_flags & OPf_STACKED)
6031 kid = kid->op_sibling;
6032 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6033 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6034 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6035 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6036 cLISTOPo->op_first->op_sibling = kid;
6037 cLISTOPo->op_last = kid;
6038 kid = kid->op_sibling;
6043 append_elem(o->op_type, o, newDEFSVOP());
6049 Perl_ck_sassign(pTHX_ OP *o)
6051 OP *kid = cLISTOPo->op_first;
6052 /* has a disposable target? */
6053 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6054 && !(kid->op_flags & OPf_STACKED)
6055 /* Cannot steal the second time! */
6056 && !(kid->op_private & OPpTARGET_MY))
6058 OP *kkid = kid->op_sibling;
6060 /* Can just relocate the target. */
6061 if (kkid && kkid->op_type == OP_PADSV
6062 && !(kkid->op_private & OPpLVAL_INTRO))
6064 kid->op_targ = kkid->op_targ;
6066 /* Now we do not need PADSV and SASSIGN. */
6067 kid->op_sibling = o->op_sibling; /* NULL */
6068 cLISTOPo->op_first = NULL;
6071 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6079 Perl_ck_match(pTHX_ OP *o)
6081 o->op_private |= OPpRUNTIME;
6086 Perl_ck_method(pTHX_ OP *o)
6088 OP *kid = cUNOPo->op_first;
6089 if (kid->op_type == OP_CONST) {
6090 SV* sv = kSVOP->op_sv;
6091 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6093 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6094 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6097 kSVOP->op_sv = Nullsv;
6099 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6108 Perl_ck_null(pTHX_ OP *o)
6114 Perl_ck_open(pTHX_ OP *o)
6116 HV *table = GvHV(PL_hintgv);
6120 svp = hv_fetch(table, "open_IN", 7, FALSE);
6122 mode = mode_from_discipline(*svp);
6123 if (mode & O_BINARY)
6124 o->op_private |= OPpOPEN_IN_RAW;
6125 else if (mode & O_TEXT)
6126 o->op_private |= OPpOPEN_IN_CRLF;
6129 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6131 mode = mode_from_discipline(*svp);
6132 if (mode & O_BINARY)
6133 o->op_private |= OPpOPEN_OUT_RAW;
6134 else if (mode & O_TEXT)
6135 o->op_private |= OPpOPEN_OUT_CRLF;
6138 if (o->op_type == OP_BACKTICK)
6144 Perl_ck_repeat(pTHX_ OP *o)
6146 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6147 o->op_private |= OPpREPEAT_DOLIST;
6148 cBINOPo->op_first = force_list(cBINOPo->op_first);
6156 Perl_ck_require(pTHX_ OP *o)
6160 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6161 SVOP *kid = (SVOP*)cUNOPo->op_first;
6163 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6165 for (s = SvPVX(kid->op_sv); *s; s++) {
6166 if (*s == ':' && s[1] == ':') {
6168 Move(s+2, s+1, strlen(s+2)+1, char);
6169 --SvCUR(kid->op_sv);
6172 if (SvREADONLY(kid->op_sv)) {
6173 SvREADONLY_off(kid->op_sv);
6174 sv_catpvn(kid->op_sv, ".pm", 3);
6175 SvREADONLY_on(kid->op_sv);
6178 sv_catpvn(kid->op_sv, ".pm", 3);
6182 /* handle override, if any */
6183 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6184 if (!(gv && GvIMPORTED_CV(gv)))
6185 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6187 if (gv && GvIMPORTED_CV(gv)) {
6188 OP *kid = cUNOPo->op_first;
6189 cUNOPo->op_first = 0;
6191 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6192 append_elem(OP_LIST, kid,
6193 scalar(newUNOP(OP_RV2CV, 0,
6202 Perl_ck_return(pTHX_ OP *o)
6205 if (CvLVALUE(PL_compcv)) {
6206 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6207 mod(kid, OP_LEAVESUBLV);
6214 Perl_ck_retarget(pTHX_ OP *o)
6216 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6223 Perl_ck_select(pTHX_ OP *o)
6226 if (o->op_flags & OPf_KIDS) {
6227 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6228 if (kid && kid->op_sibling) {
6229 o->op_type = OP_SSELECT;
6230 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6232 return fold_constants(o);
6236 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6237 if (kid && kid->op_type == OP_RV2GV)
6238 kid->op_private &= ~HINT_STRICT_REFS;
6243 Perl_ck_shift(pTHX_ OP *o)
6245 I32 type = o->op_type;
6247 if (!(o->op_flags & OPf_KIDS)) {
6252 if (!CvUNIQUE(PL_compcv)) {
6253 argop = newOP(OP_PADAV, OPf_REF);
6254 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6257 argop = newUNOP(OP_RV2AV, 0,
6258 scalar(newGVOP(OP_GV, 0,
6259 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6262 argop = newUNOP(OP_RV2AV, 0,
6263 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6264 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6265 #endif /* USE_THREADS */
6266 return newUNOP(type, 0, scalar(argop));
6268 return scalar(modkids(ck_fun(o), type));
6272 Perl_ck_sort(pTHX_ OP *o)
6276 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6278 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6279 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6281 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6283 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6285 if (kid->op_type == OP_SCOPE) {
6289 else if (kid->op_type == OP_LEAVE) {
6290 if (o->op_type == OP_SORT) {
6291 op_null(kid); /* wipe out leave */
6294 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6295 if (k->op_next == kid)
6297 /* don't descend into loops */
6298 else if (k->op_type == OP_ENTERLOOP
6299 || k->op_type == OP_ENTERITER)
6301 k = cLOOPx(k)->op_lastop;
6306 kid->op_next = 0; /* just disconnect the leave */
6307 k = kLISTOP->op_first;
6312 if (o->op_type == OP_SORT) {
6313 /* provide scalar context for comparison function/block */
6319 o->op_flags |= OPf_SPECIAL;
6321 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6324 firstkid = firstkid->op_sibling;
6327 /* provide list context for arguments */
6328 if (o->op_type == OP_SORT)
6335 S_simplify_sort(pTHX_ OP *o)
6337 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6341 if (!(o->op_flags & OPf_STACKED))
6343 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6344 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6345 kid = kUNOP->op_first; /* get past null */
6346 if (kid->op_type != OP_SCOPE)
6348 kid = kLISTOP->op_last; /* get past scope */
6349 switch(kid->op_type) {
6357 k = kid; /* remember this node*/
6358 if (kBINOP->op_first->op_type != OP_RV2SV)
6360 kid = kBINOP->op_first; /* get past cmp */
6361 if (kUNOP->op_first->op_type != OP_GV)
6363 kid = kUNOP->op_first; /* get past rv2sv */
6365 if (GvSTASH(gv) != PL_curstash)
6367 if (strEQ(GvNAME(gv), "a"))
6369 else if (strEQ(GvNAME(gv), "b"))
6373 kid = k; /* back to cmp */
6374 if (kBINOP->op_last->op_type != OP_RV2SV)
6376 kid = kBINOP->op_last; /* down to 2nd arg */
6377 if (kUNOP->op_first->op_type != OP_GV)
6379 kid = kUNOP->op_first; /* get past rv2sv */
6381 if (GvSTASH(gv) != PL_curstash
6383 ? strNE(GvNAME(gv), "a")
6384 : strNE(GvNAME(gv), "b")))
6386 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6388 o->op_private |= OPpSORT_REVERSE;
6389 if (k->op_type == OP_NCMP)
6390 o->op_private |= OPpSORT_NUMERIC;
6391 if (k->op_type == OP_I_NCMP)
6392 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6393 kid = cLISTOPo->op_first->op_sibling;
6394 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6395 op_free(kid); /* then delete it */
6399 Perl_ck_split(pTHX_ OP *o)
6403 if (o->op_flags & OPf_STACKED)
6404 return no_fh_allowed(o);
6406 kid = cLISTOPo->op_first;
6407 if (kid->op_type != OP_NULL)
6408 Perl_croak(aTHX_ "panic: ck_split");
6409 kid = kid->op_sibling;
6410 op_free(cLISTOPo->op_first);
6411 cLISTOPo->op_first = kid;
6413 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6414 cLISTOPo->op_last = kid; /* There was only one element previously */
6417 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6418 OP *sibl = kid->op_sibling;
6419 kid->op_sibling = 0;
6420 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6421 if (cLISTOPo->op_first == cLISTOPo->op_last)
6422 cLISTOPo->op_last = kid;
6423 cLISTOPo->op_first = kid;
6424 kid->op_sibling = sibl;
6427 kid->op_type = OP_PUSHRE;
6428 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6431 if (!kid->op_sibling)
6432 append_elem(OP_SPLIT, o, newDEFSVOP());
6434 kid = kid->op_sibling;
6437 if (!kid->op_sibling)
6438 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6440 kid = kid->op_sibling;
6443 if (kid->op_sibling)
6444 return too_many_arguments(o,PL_op_desc[o->op_type]);
6450 Perl_ck_join(pTHX_ OP *o)
6452 if (ckWARN(WARN_SYNTAX)) {
6453 OP *kid = cLISTOPo->op_first->op_sibling;
6454 if (kid && kid->op_type == OP_MATCH) {
6455 char *pmstr = "STRING";
6456 if (PM_GETRE(kPMOP))
6457 pmstr = PM_GETRE(kPMOP)->precomp;
6458 Perl_warner(aTHX_ WARN_SYNTAX,
6459 "/%s/ should probably be written as \"%s\"",
6467 Perl_ck_subr(pTHX_ OP *o)
6469 OP *prev = ((cUNOPo->op_first->op_sibling)
6470 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6471 OP *o2 = prev->op_sibling;
6480 o->op_private |= OPpENTERSUB_HASTARG;
6481 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6482 if (cvop->op_type == OP_RV2CV) {
6484 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6485 op_null(cvop); /* disable rv2cv */
6486 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6487 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6488 GV *gv = cGVOPx_gv(tmpop);
6491 tmpop->op_private |= OPpEARLY_CV;
6492 else if (SvPOK(cv)) {
6493 namegv = CvANON(cv) ? gv : CvGV(cv);
6494 proto = SvPV((SV*)cv, n_a);
6498 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6499 if (o2->op_type == OP_CONST)
6500 o2->op_private &= ~OPpCONST_STRICT;
6501 else if (o2->op_type == OP_LIST) {
6502 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6503 if (o && o->op_type == OP_CONST)
6504 o->op_private &= ~OPpCONST_STRICT;
6507 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6508 if (PERLDB_SUB && PL_curstash != PL_debstash)
6509 o->op_private |= OPpENTERSUB_DB;
6510 while (o2 != cvop) {
6514 return too_many_arguments(o, gv_ename(namegv));
6532 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6534 arg == 1 ? "block or sub {}" : "sub {}",
6535 gv_ename(namegv), o2);
6538 /* '*' allows any scalar type, including bareword */
6541 if (o2->op_type == OP_RV2GV)
6542 goto wrapref; /* autoconvert GLOB -> GLOBref */
6543 else if (o2->op_type == OP_CONST)
6544 o2->op_private &= ~OPpCONST_STRICT;
6545 else if (o2->op_type == OP_ENTERSUB) {
6546 /* accidental subroutine, revert to bareword */
6547 OP *gvop = ((UNOP*)o2)->op_first;
6548 if (gvop && gvop->op_type == OP_NULL) {
6549 gvop = ((UNOP*)gvop)->op_first;
6551 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6554 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6555 (gvop = ((UNOP*)gvop)->op_first) &&
6556 gvop->op_type == OP_GV)
6558 GV *gv = cGVOPx_gv(gvop);
6559 OP *sibling = o2->op_sibling;
6560 SV *n = newSVpvn("",0);
6562 gv_fullname3(n, gv, "");
6563 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6564 sv_chop(n, SvPVX(n)+6);
6565 o2 = newSVOP(OP_CONST, 0, n);
6566 prev->op_sibling = o2;
6567 o2->op_sibling = sibling;
6579 if (o2->op_type != OP_RV2GV)
6580 bad_type(arg, "symbol", gv_ename(namegv), o2);
6583 if (o2->op_type != OP_ENTERSUB)
6584 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6587 if (o2->op_type != OP_RV2SV
6588 && o2->op_type != OP_PADSV
6589 && o2->op_type != OP_HELEM
6590 && o2->op_type != OP_AELEM
6591 && o2->op_type != OP_THREADSV)
6593 bad_type(arg, "scalar", gv_ename(namegv), o2);
6597 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6598 bad_type(arg, "array", gv_ename(namegv), o2);
6601 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6602 bad_type(arg, "hash", gv_ename(namegv), o2);
6606 OP* sib = kid->op_sibling;
6607 kid->op_sibling = 0;
6608 o2 = newUNOP(OP_REFGEN, 0, kid);
6609 o2->op_sibling = sib;
6610 prev->op_sibling = o2;
6621 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6622 gv_ename(namegv), SvPV((SV*)cv, n_a));
6627 mod(o2, OP_ENTERSUB);
6629 o2 = o2->op_sibling;
6631 if (proto && !optional &&
6632 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6633 return too_few_arguments(o, gv_ename(namegv));
6638 Perl_ck_svconst(pTHX_ OP *o)
6640 SvREADONLY_on(cSVOPo->op_sv);
6645 Perl_ck_trunc(pTHX_ OP *o)
6647 if (o->op_flags & OPf_KIDS) {
6648 SVOP *kid = (SVOP*)cUNOPo->op_first;
6650 if (kid->op_type == OP_NULL)
6651 kid = (SVOP*)kid->op_sibling;
6652 if (kid && kid->op_type == OP_CONST &&
6653 (kid->op_private & OPpCONST_BARE))
6655 o->op_flags |= OPf_SPECIAL;
6656 kid->op_private &= ~OPpCONST_STRICT;
6663 Perl_ck_substr(pTHX_ OP *o)
6666 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6667 OP *kid = cLISTOPo->op_first;
6669 if (kid->op_type == OP_NULL)
6670 kid = kid->op_sibling;
6672 kid->op_flags |= OPf_MOD;
6678 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6681 Perl_peep(pTHX_ register OP *o)
6683 register OP* oldop = 0;
6686 if (!o || o->op_seq)
6690 SAVEVPTR(PL_curcop);
6691 for (; o; o = o->op_next) {
6697 switch (o->op_type) {
6701 PL_curcop = ((COP*)o); /* for warnings */
6702 o->op_seq = PL_op_seqmax++;
6706 if (cSVOPo->op_private & OPpCONST_STRICT)
6707 no_bareword_allowed(o);
6709 /* Relocate sv to the pad for thread safety.
6710 * Despite being a "constant", the SV is written to,
6711 * for reference counts, sv_upgrade() etc. */
6713 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6714 if (SvPADTMP(cSVOPo->op_sv)) {
6715 /* If op_sv is already a PADTMP then it is being used by
6716 * some pad, so make a copy. */
6717 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6718 SvREADONLY_on(PL_curpad[ix]);
6719 SvREFCNT_dec(cSVOPo->op_sv);
6722 SvREFCNT_dec(PL_curpad[ix]);
6723 SvPADTMP_on(cSVOPo->op_sv);
6724 PL_curpad[ix] = cSVOPo->op_sv;
6725 /* XXX I don't know how this isn't readonly already. */
6726 SvREADONLY_on(PL_curpad[ix]);
6728 cSVOPo->op_sv = Nullsv;
6732 o->op_seq = PL_op_seqmax++;
6736 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6737 if (o->op_next->op_private & OPpTARGET_MY) {
6738 if (o->op_flags & OPf_STACKED) /* chained concats */
6739 goto ignore_optimization;
6741 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6742 o->op_targ = o->op_next->op_targ;
6743 o->op_next->op_targ = 0;
6744 o->op_private |= OPpTARGET_MY;
6747 op_null(o->op_next);
6749 ignore_optimization:
6750 o->op_seq = PL_op_seqmax++;
6753 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6754 o->op_seq = PL_op_seqmax++;
6755 break; /* Scalar stub must produce undef. List stub is noop */
6759 if (o->op_targ == OP_NEXTSTATE
6760 || o->op_targ == OP_DBSTATE
6761 || o->op_targ == OP_SETSTATE)
6763 PL_curcop = ((COP*)o);
6770 if (oldop && o->op_next) {
6771 oldop->op_next = o->op_next;
6774 o->op_seq = PL_op_seqmax++;
6778 if (o->op_next->op_type == OP_RV2SV) {
6779 if (!(o->op_next->op_private & OPpDEREF)) {
6780 op_null(o->op_next);
6781 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6783 o->op_next = o->op_next->op_next;
6784 o->op_type = OP_GVSV;
6785 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6788 else if (o->op_next->op_type == OP_RV2AV) {
6789 OP* pop = o->op_next->op_next;
6791 if (pop->op_type == OP_CONST &&
6792 (PL_op = pop->op_next) &&
6793 pop->op_next->op_type == OP_AELEM &&
6794 !(pop->op_next->op_private &
6795 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6796 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6801 op_null(o->op_next);
6802 op_null(pop->op_next);
6804 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6805 o->op_next = pop->op_next->op_next;
6806 o->op_type = OP_AELEMFAST;
6807 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6808 o->op_private = (U8)i;
6813 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6815 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6816 /* XXX could check prototype here instead of just carping */
6817 SV *sv = sv_newmortal();
6818 gv_efullname3(sv, gv, Nullch);
6819 Perl_warner(aTHX_ WARN_PROTOTYPE,
6820 "%s() called too early to check prototype",
6825 o->op_seq = PL_op_seqmax++;
6836 o->op_seq = PL_op_seqmax++;
6837 while (cLOGOP->op_other->op_type == OP_NULL)
6838 cLOGOP->op_other = cLOGOP->op_other->op_next;
6839 peep(cLOGOP->op_other);
6844 o->op_seq = PL_op_seqmax++;
6845 while (cLOOP->op_redoop->op_type == OP_NULL)
6846 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6847 peep(cLOOP->op_redoop);
6848 while (cLOOP->op_nextop->op_type == OP_NULL)
6849 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6850 peep(cLOOP->op_nextop);
6851 while (cLOOP->op_lastop->op_type == OP_NULL)
6852 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6853 peep(cLOOP->op_lastop);
6859 o->op_seq = PL_op_seqmax++;
6860 while (cPMOP->op_pmreplstart &&
6861 cPMOP->op_pmreplstart->op_type == OP_NULL)
6862 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6863 peep(cPMOP->op_pmreplstart);
6867 o->op_seq = PL_op_seqmax++;
6868 if (ckWARN(WARN_SYNTAX) && o->op_next
6869 && o->op_next->op_type == OP_NEXTSTATE) {
6870 if (o->op_next->op_sibling &&
6871 o->op_next->op_sibling->op_type != OP_EXIT &&
6872 o->op_next->op_sibling->op_type != OP_WARN &&
6873 o->op_next->op_sibling->op_type != OP_DIE) {
6874 line_t oldline = CopLINE(PL_curcop);
6876 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6877 Perl_warner(aTHX_ WARN_EXEC,
6878 "Statement unlikely to be reached");
6879 Perl_warner(aTHX_ WARN_EXEC,
6880 "\t(Maybe you meant system() when you said exec()?)\n");
6881 CopLINE_set(PL_curcop, oldline);
6890 SV **svp, **indsvp, *sv;
6895 o->op_seq = PL_op_seqmax++;
6897 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6900 /* Make the CONST have a shared SV */
6901 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6902 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6903 key = SvPV(sv, keylen);
6904 lexname = newSVpvn_share(key,
6905 SvUTF8(sv) ? -(I32)keylen : keylen,
6911 if ((o->op_private & (OPpLVAL_INTRO)))
6914 rop = (UNOP*)((BINOP*)o)->op_first;
6915 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6917 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6918 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6920 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6921 if (!fields || !GvHV(*fields))
6923 key = SvPV(*svp, keylen);
6924 indsvp = hv_fetch(GvHV(*fields), key,
6925 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6927 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6928 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6930 ind = SvIV(*indsvp);
6932 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6933 rop->op_type = OP_RV2AV;
6934 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6935 o->op_type = OP_AELEM;
6936 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6938 if (SvREADONLY(*svp))
6940 SvFLAGS(sv) |= (SvFLAGS(*svp)
6941 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6951 SV **svp, **indsvp, *sv;
6955 SVOP *first_key_op, *key_op;
6957 o->op_seq = PL_op_seqmax++;
6958 if ((o->op_private & (OPpLVAL_INTRO))
6959 /* I bet there's always a pushmark... */
6960 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6961 /* hmmm, no optimization if list contains only one key. */
6963 rop = (UNOP*)((LISTOP*)o)->op_last;
6964 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6966 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6967 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6969 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6970 if (!fields || !GvHV(*fields))
6972 /* Again guessing that the pushmark can be jumped over.... */
6973 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6974 ->op_first->op_sibling;
6975 /* Check that the key list contains only constants. */
6976 for (key_op = first_key_op; key_op;
6977 key_op = (SVOP*)key_op->op_sibling)
6978 if (key_op->op_type != OP_CONST)
6982 rop->op_type = OP_RV2AV;
6983 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6984 o->op_type = OP_ASLICE;
6985 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6986 for (key_op = first_key_op; key_op;
6987 key_op = (SVOP*)key_op->op_sibling) {
6988 svp = cSVOPx_svp(key_op);
6989 key = SvPV(*svp, keylen);
6990 indsvp = hv_fetch(GvHV(*fields), key,
6991 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6993 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6994 "in variable %s of type %s",
6995 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6997 ind = SvIV(*indsvp);
6999 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7001 if (SvREADONLY(*svp))
7003 SvFLAGS(sv) |= (SvFLAGS(*svp)
7004 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7012 o->op_seq = PL_op_seqmax++;
7022 /* Efficient sub that returns a constant scalar value. */
7024 const_sv_xsub(pTHXo_ CV* cv)
7029 Perl_croak(aTHX_ "usage: %s::%s()",
7030 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7034 ST(0) = (SV*)XSANY.any_ptr;