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;
847 Safefree(PmopSTASHPV(cPMOPo));
849 /* NOTE: PMOP.op_pmstash is not refcounted */
852 cPMOPo->op_pmreplroot = Nullop;
853 ReREFCNT_dec(PM_GETRE(cPMOPo));
854 PM_SETRE(cPMOPo, (REGEXP*)NULL);
858 if (o->op_targ > 0) {
859 pad_free(o->op_targ);
865 S_cop_free(pTHX_ COP* cop)
867 Safefree(cop->cop_label);
869 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
870 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
872 /* NOTE: COP.cop_stash is not refcounted */
873 SvREFCNT_dec(CopFILEGV(cop));
875 if (! specialWARN(cop->cop_warnings))
876 SvREFCNT_dec(cop->cop_warnings);
877 if (! specialCopIO(cop->cop_io))
878 SvREFCNT_dec(cop->cop_io);
882 Perl_op_null(pTHX_ OP *o)
884 if (o->op_type == OP_NULL)
887 o->op_targ = o->op_type;
888 o->op_type = OP_NULL;
889 o->op_ppaddr = PL_ppaddr[OP_NULL];
892 /* Contextualizers */
894 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
897 Perl_linklist(pTHX_ OP *o)
904 /* establish postfix order */
905 if (cUNOPo->op_first) {
906 o->op_next = LINKLIST(cUNOPo->op_first);
907 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
909 kid->op_next = LINKLIST(kid->op_sibling);
921 Perl_scalarkids(pTHX_ OP *o)
924 if (o && o->op_flags & OPf_KIDS) {
925 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
932 S_scalarboolean(pTHX_ OP *o)
934 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
935 if (ckWARN(WARN_SYNTAX)) {
936 line_t oldline = CopLINE(PL_curcop);
938 if (PL_copline != NOLINE)
939 CopLINE_set(PL_curcop, PL_copline);
940 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
941 CopLINE_set(PL_curcop, oldline);
948 Perl_scalar(pTHX_ OP *o)
952 /* assumes no premature commitment */
953 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
954 || o->op_type == OP_RETURN)
959 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
961 switch (o->op_type) {
963 scalar(cBINOPo->op_first);
968 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
972 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
973 if (!kPMOP->op_pmreplroot)
974 deprecate("implicit split to @_");
982 if (o->op_flags & OPf_KIDS) {
983 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
989 kid = cLISTOPo->op_first;
991 while ((kid = kid->op_sibling)) {
997 WITH_THR(PL_curcop = &PL_compiling);
1002 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1003 if (kid->op_sibling)
1008 WITH_THR(PL_curcop = &PL_compiling);
1015 Perl_scalarvoid(pTHX_ OP *o)
1022 if (o->op_type == OP_NEXTSTATE
1023 || o->op_type == OP_SETSTATE
1024 || o->op_type == OP_DBSTATE
1025 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1026 || o->op_targ == OP_SETSTATE
1027 || o->op_targ == OP_DBSTATE)))
1028 PL_curcop = (COP*)o; /* for warning below */
1030 /* assumes no premature commitment */
1031 want = o->op_flags & OPf_WANT;
1032 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1033 || o->op_type == OP_RETURN)
1038 if ((o->op_private & OPpTARGET_MY)
1039 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1041 return scalar(o); /* As if inside SASSIGN */
1044 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1046 switch (o->op_type) {
1048 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1052 if (o->op_flags & OPf_STACKED)
1056 if (o->op_private == 4)
1098 case OP_GETSOCKNAME:
1099 case OP_GETPEERNAME:
1104 case OP_GETPRIORITY:
1127 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1128 useless = PL_op_desc[o->op_type];
1135 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1136 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1137 useless = "a variable";
1142 if (cSVOPo->op_private & OPpCONST_STRICT)
1143 no_bareword_allowed(o);
1145 if (ckWARN(WARN_VOID)) {
1146 useless = "a constant";
1147 /* the constants 0 and 1 are permitted as they are
1148 conventionally used as dummies in constructs like
1149 1 while some_condition_with_side_effects; */
1150 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1152 else if (SvPOK(sv)) {
1153 /* perl4's way of mixing documentation and code
1154 (before the invention of POD) was based on a
1155 trick to mix nroff and perl code. The trick was
1156 built upon these three nroff macros being used in
1157 void context. The pink camel has the details in
1158 the script wrapman near page 319. */
1159 if (strnEQ(SvPVX(sv), "di", 2) ||
1160 strnEQ(SvPVX(sv), "ds", 2) ||
1161 strnEQ(SvPVX(sv), "ig", 2))
1166 op_null(o); /* don't execute or even remember it */
1170 o->op_type = OP_PREINC; /* pre-increment is faster */
1171 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1175 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1176 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1182 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1187 if (o->op_flags & OPf_STACKED)
1194 if (!(o->op_flags & OPf_KIDS))
1203 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1210 /* all requires must return a boolean value */
1211 o->op_flags &= ~OPf_WANT;
1216 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1217 if (!kPMOP->op_pmreplroot)
1218 deprecate("implicit split to @_");
1222 if (useless && ckWARN(WARN_VOID))
1223 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1228 Perl_listkids(pTHX_ OP *o)
1231 if (o && o->op_flags & OPf_KIDS) {
1232 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1239 Perl_list(pTHX_ OP *o)
1243 /* assumes no premature commitment */
1244 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1245 || o->op_type == OP_RETURN)
1250 if ((o->op_private & OPpTARGET_MY)
1251 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1253 return o; /* As if inside SASSIGN */
1256 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1258 switch (o->op_type) {
1261 list(cBINOPo->op_first);
1266 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1274 if (!(o->op_flags & OPf_KIDS))
1276 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1277 list(cBINOPo->op_first);
1278 return gen_constant_list(o);
1285 kid = cLISTOPo->op_first;
1287 while ((kid = kid->op_sibling)) {
1288 if (kid->op_sibling)
1293 WITH_THR(PL_curcop = &PL_compiling);
1297 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1298 if (kid->op_sibling)
1303 WITH_THR(PL_curcop = &PL_compiling);
1306 /* all requires must return a boolean value */
1307 o->op_flags &= ~OPf_WANT;
1314 Perl_scalarseq(pTHX_ OP *o)
1319 if (o->op_type == OP_LINESEQ ||
1320 o->op_type == OP_SCOPE ||
1321 o->op_type == OP_LEAVE ||
1322 o->op_type == OP_LEAVETRY)
1324 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1325 if (kid->op_sibling) {
1329 PL_curcop = &PL_compiling;
1331 o->op_flags &= ~OPf_PARENS;
1332 if (PL_hints & HINT_BLOCK_SCOPE)
1333 o->op_flags |= OPf_PARENS;
1336 o = newOP(OP_STUB, 0);
1341 S_modkids(pTHX_ OP *o, I32 type)
1344 if (o && o->op_flags & OPf_KIDS) {
1345 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1352 Perl_mod(pTHX_ OP *o, I32 type)
1357 if (!o || PL_error_count)
1360 if ((o->op_private & OPpTARGET_MY)
1361 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1366 switch (o->op_type) {
1371 if (!(o->op_private & (OPpCONST_ARYBASE)))
1373 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1374 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1378 SAVEI32(PL_compiling.cop_arybase);
1379 PL_compiling.cop_arybase = 0;
1381 else if (type == OP_REFGEN)
1384 Perl_croak(aTHX_ "That use of $[ is unsupported");
1387 if (o->op_flags & OPf_PARENS)
1391 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1392 !(o->op_flags & OPf_STACKED)) {
1393 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1394 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1395 assert(cUNOPo->op_first->op_type == OP_NULL);
1396 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1399 else { /* lvalue subroutine call */
1400 o->op_private |= OPpLVAL_INTRO;
1401 PL_modcount = RETURN_UNLIMITED_NUMBER;
1402 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1403 /* Backward compatibility mode: */
1404 o->op_private |= OPpENTERSUB_INARGS;
1407 else { /* Compile-time error message: */
1408 OP *kid = cUNOPo->op_first;
1412 if (kid->op_type == OP_PUSHMARK)
1414 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1416 "panic: unexpected lvalue entersub "
1417 "args: type/targ %ld:%ld",
1418 (long)kid->op_type,kid->op_targ);
1419 kid = kLISTOP->op_first;
1421 while (kid->op_sibling)
1422 kid = kid->op_sibling;
1423 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1425 if (kid->op_type == OP_METHOD_NAMED
1426 || kid->op_type == OP_METHOD)
1430 if (kid->op_sibling || kid->op_next != kid) {
1431 yyerror("panic: unexpected optree near method call");
1435 NewOp(1101, newop, 1, UNOP);
1436 newop->op_type = OP_RV2CV;
1437 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1438 newop->op_first = Nullop;
1439 newop->op_next = (OP*)newop;
1440 kid->op_sibling = (OP*)newop;
1441 newop->op_private |= OPpLVAL_INTRO;
1445 if (kid->op_type != OP_RV2CV)
1447 "panic: unexpected lvalue entersub "
1448 "entry via type/targ %ld:%ld",
1449 (long)kid->op_type,kid->op_targ);
1450 kid->op_private |= OPpLVAL_INTRO;
1451 break; /* Postpone until runtime */
1455 kid = kUNOP->op_first;
1456 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1457 kid = kUNOP->op_first;
1458 if (kid->op_type == OP_NULL)
1460 "Unexpected constant lvalue entersub "
1461 "entry via type/targ %ld:%ld",
1462 (long)kid->op_type,kid->op_targ);
1463 if (kid->op_type != OP_GV) {
1464 /* Restore RV2CV to check lvalueness */
1466 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1467 okid->op_next = kid->op_next;
1468 kid->op_next = okid;
1471 okid->op_next = Nullop;
1472 okid->op_type = OP_RV2CV;
1474 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1475 okid->op_private |= OPpLVAL_INTRO;
1479 cv = GvCV(kGVOP_gv);
1489 /* grep, foreach, subcalls, refgen */
1490 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1492 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1493 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1495 : (o->op_type == OP_ENTERSUB
1496 ? "non-lvalue subroutine call"
1497 : PL_op_desc[o->op_type])),
1498 type ? PL_op_desc[type] : "local"));
1512 case OP_RIGHT_SHIFT:
1521 if (!(o->op_flags & OPf_STACKED))
1527 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1533 if (!type && cUNOPo->op_first->op_type != OP_GV)
1534 Perl_croak(aTHX_ "Can't localize through a reference");
1535 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1536 PL_modcount = RETURN_UNLIMITED_NUMBER;
1537 return o; /* Treat \(@foo) like ordinary list. */
1541 if (scalar_mod_type(o, type))
1543 ref(cUNOPo->op_first, o->op_type);
1547 if (type == OP_LEAVESUBLV)
1548 o->op_private |= OPpMAYBE_LVSUB;
1554 PL_modcount = RETURN_UNLIMITED_NUMBER;
1557 if (!type && cUNOPo->op_first->op_type != OP_GV)
1558 Perl_croak(aTHX_ "Can't localize through a reference");
1559 ref(cUNOPo->op_first, o->op_type);
1563 PL_hints |= HINT_BLOCK_SCOPE;
1573 PL_modcount = RETURN_UNLIMITED_NUMBER;
1574 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1575 return o; /* Treat \(@foo) like ordinary list. */
1576 if (scalar_mod_type(o, type))
1578 if (type == OP_LEAVESUBLV)
1579 o->op_private |= OPpMAYBE_LVSUB;
1584 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1585 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1590 PL_modcount++; /* XXX ??? */
1592 #endif /* USE_THREADS */
1598 if (type != OP_SASSIGN)
1602 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1607 if (type == OP_LEAVESUBLV)
1608 o->op_private |= OPpMAYBE_LVSUB;
1610 pad_free(o->op_targ);
1611 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1612 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1613 if (o->op_flags & OPf_KIDS)
1614 mod(cBINOPo->op_first->op_sibling, type);
1619 ref(cBINOPo->op_first, o->op_type);
1620 if (type == OP_ENTERSUB &&
1621 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1622 o->op_private |= OPpLVAL_DEFER;
1623 if (type == OP_LEAVESUBLV)
1624 o->op_private |= OPpMAYBE_LVSUB;
1632 if (o->op_flags & OPf_KIDS)
1633 mod(cLISTOPo->op_last, type);
1637 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1639 else if (!(o->op_flags & OPf_KIDS))
1641 if (o->op_targ != OP_LIST) {
1642 mod(cBINOPo->op_first, type);
1647 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1652 if (type != OP_LEAVESUBLV)
1654 break; /* mod()ing was handled by ck_return() */
1656 if (type != OP_LEAVESUBLV)
1657 o->op_flags |= OPf_MOD;
1659 if (type == OP_AASSIGN || type == OP_SASSIGN)
1660 o->op_flags |= OPf_SPECIAL|OPf_REF;
1662 o->op_private |= OPpLVAL_INTRO;
1663 o->op_flags &= ~OPf_SPECIAL;
1664 PL_hints |= HINT_BLOCK_SCOPE;
1666 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1667 && type != OP_LEAVESUBLV)
1668 o->op_flags |= OPf_REF;
1673 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1677 if (o->op_type == OP_RV2GV)
1701 case OP_RIGHT_SHIFT:
1720 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1722 switch (o->op_type) {
1730 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1743 Perl_refkids(pTHX_ OP *o, I32 type)
1746 if (o && o->op_flags & OPf_KIDS) {
1747 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1754 Perl_ref(pTHX_ OP *o, I32 type)
1758 if (!o || PL_error_count)
1761 switch (o->op_type) {
1763 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1764 !(o->op_flags & OPf_STACKED)) {
1765 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1766 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1767 assert(cUNOPo->op_first->op_type == OP_NULL);
1768 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1769 o->op_flags |= OPf_SPECIAL;
1774 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1778 if (type == OP_DEFINED)
1779 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1780 ref(cUNOPo->op_first, o->op_type);
1783 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1784 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1785 : type == OP_RV2HV ? OPpDEREF_HV
1787 o->op_flags |= OPf_MOD;
1792 o->op_flags |= OPf_MOD; /* XXX ??? */
1797 o->op_flags |= OPf_REF;
1800 if (type == OP_DEFINED)
1801 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1802 ref(cUNOPo->op_first, o->op_type);
1807 o->op_flags |= OPf_REF;
1812 if (!(o->op_flags & OPf_KIDS))
1814 ref(cBINOPo->op_first, type);
1818 ref(cBINOPo->op_first, o->op_type);
1819 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1820 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1821 : type == OP_RV2HV ? OPpDEREF_HV
1823 o->op_flags |= OPf_MOD;
1831 if (!(o->op_flags & OPf_KIDS))
1833 ref(cLISTOPo->op_last, type);
1843 S_dup_attrlist(pTHX_ OP *o)
1847 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1848 * where the first kid is OP_PUSHMARK and the remaining ones
1849 * are OP_CONST. We need to push the OP_CONST values.
1851 if (o->op_type == OP_CONST)
1852 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1854 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1855 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1856 if (o->op_type == OP_CONST)
1857 rop = append_elem(OP_LIST, rop,
1858 newSVOP(OP_CONST, o->op_flags,
1859 SvREFCNT_inc(cSVOPo->op_sv)));
1866 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1870 /* fake up C<use attributes $pkg,$rv,@attrs> */
1871 ENTER; /* need to protect against side-effects of 'use' */
1874 stashsv = newSVpv(HvNAME(stash), 0);
1876 stashsv = &PL_sv_no;
1878 #define ATTRSMODULE "attributes"
1880 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1881 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1883 prepend_elem(OP_LIST,
1884 newSVOP(OP_CONST, 0, stashsv),
1885 prepend_elem(OP_LIST,
1886 newSVOP(OP_CONST, 0,
1888 dup_attrlist(attrs))));
1893 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1894 char *attrstr, STRLEN len)
1899 len = strlen(attrstr);
1903 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1905 char *sstr = attrstr;
1906 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1907 attrs = append_elem(OP_LIST, attrs,
1908 newSVOP(OP_CONST, 0,
1909 newSVpvn(sstr, attrstr-sstr)));
1913 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1914 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1915 Nullsv, prepend_elem(OP_LIST,
1916 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1917 prepend_elem(OP_LIST,
1918 newSVOP(OP_CONST, 0,
1924 S_my_kid(pTHX_ OP *o, OP *attrs)
1929 if (!o || PL_error_count)
1933 if (type == OP_LIST) {
1934 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1936 } else if (type == OP_UNDEF) {
1938 } else if (type == OP_RV2SV || /* "our" declaration */
1940 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1942 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1944 PL_in_my_stash = Nullhv;
1945 apply_attrs(GvSTASH(gv),
1946 (type == OP_RV2SV ? GvSV(gv) :
1947 type == OP_RV2AV ? (SV*)GvAV(gv) :
1948 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1951 o->op_private |= OPpOUR_INTRO;
1953 } else if (type != OP_PADSV &&
1956 type != OP_PUSHMARK)
1958 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1959 PL_op_desc[o->op_type],
1960 PL_in_my == KEY_our ? "our" : "my"));
1963 else if (attrs && type != OP_PUSHMARK) {
1969 PL_in_my_stash = Nullhv;
1971 /* check for C<my Dog $spot> when deciding package */
1972 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1973 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1974 stash = SvSTASH(*namesvp);
1976 stash = PL_curstash;
1977 padsv = PAD_SV(o->op_targ);
1978 apply_attrs(stash, padsv, attrs);
1980 o->op_flags |= OPf_MOD;
1981 o->op_private |= OPpLVAL_INTRO;
1986 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1988 if (o->op_flags & OPf_PARENS)
1992 o = my_kid(o, attrs);
1994 PL_in_my_stash = Nullhv;
1999 Perl_my(pTHX_ OP *o)
2001 return my_kid(o, Nullop);
2005 Perl_sawparens(pTHX_ OP *o)
2008 o->op_flags |= OPf_PARENS;
2013 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2017 if (ckWARN(WARN_MISC) &&
2018 (left->op_type == OP_RV2AV ||
2019 left->op_type == OP_RV2HV ||
2020 left->op_type == OP_PADAV ||
2021 left->op_type == OP_PADHV)) {
2022 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2023 right->op_type == OP_TRANS)
2024 ? right->op_type : OP_MATCH];
2025 const char *sample = ((left->op_type == OP_RV2AV ||
2026 left->op_type == OP_PADAV)
2027 ? "@array" : "%hash");
2028 Perl_warner(aTHX_ WARN_MISC,
2029 "Applying %s to %s will act on scalar(%s)",
2030 desc, sample, sample);
2033 if (!(right->op_flags & OPf_STACKED) &&
2034 (right->op_type == OP_MATCH ||
2035 right->op_type == OP_SUBST ||
2036 right->op_type == OP_TRANS)) {
2037 right->op_flags |= OPf_STACKED;
2038 if ((right->op_type != OP_MATCH &&
2039 ! (right->op_type == OP_TRANS &&
2040 right->op_private & OPpTRANS_IDENTICAL)) ||
2041 /* if SV has magic, then match on original SV, not on its copy.
2042 see note in pp_helem() */
2043 (right->op_type == OP_MATCH &&
2044 (left->op_type == OP_AELEM ||
2045 left->op_type == OP_HELEM ||
2046 left->op_type == OP_AELEMFAST)))
2047 left = mod(left, right->op_type);
2048 if (right->op_type == OP_TRANS)
2049 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2051 o = prepend_elem(right->op_type, scalar(left), right);
2053 return newUNOP(OP_NOT, 0, scalar(o));
2057 return bind_match(type, left,
2058 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2062 Perl_invert(pTHX_ OP *o)
2066 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2067 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2071 Perl_scope(pTHX_ OP *o)
2074 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2075 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2076 o->op_type = OP_LEAVE;
2077 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2080 if (o->op_type == OP_LINESEQ) {
2082 o->op_type = OP_SCOPE;
2083 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2084 kid = ((LISTOP*)o)->op_first;
2085 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2089 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2096 Perl_save_hints(pTHX)
2099 SAVESPTR(GvHV(PL_hintgv));
2100 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2101 SAVEFREESV(GvHV(PL_hintgv));
2105 Perl_block_start(pTHX_ int full)
2107 int retval = PL_savestack_ix;
2109 SAVEI32(PL_comppad_name_floor);
2110 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2112 PL_comppad_name_fill = PL_comppad_name_floor;
2113 if (PL_comppad_name_floor < 0)
2114 PL_comppad_name_floor = 0;
2115 SAVEI32(PL_min_intro_pending);
2116 SAVEI32(PL_max_intro_pending);
2117 PL_min_intro_pending = 0;
2118 SAVEI32(PL_comppad_name_fill);
2119 SAVEI32(PL_padix_floor);
2120 PL_padix_floor = PL_padix;
2121 PL_pad_reset_pending = FALSE;
2123 PL_hints &= ~HINT_BLOCK_SCOPE;
2124 SAVESPTR(PL_compiling.cop_warnings);
2125 if (! specialWARN(PL_compiling.cop_warnings)) {
2126 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2127 SAVEFREESV(PL_compiling.cop_warnings) ;
2129 SAVESPTR(PL_compiling.cop_io);
2130 if (! specialCopIO(PL_compiling.cop_io)) {
2131 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2132 SAVEFREESV(PL_compiling.cop_io) ;
2138 Perl_block_end(pTHX_ I32 floor, OP *seq)
2140 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2141 OP* retval = scalarseq(seq);
2143 PL_pad_reset_pending = FALSE;
2144 PL_compiling.op_private = PL_hints;
2146 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2147 pad_leavemy(PL_comppad_name_fill);
2156 OP *o = newOP(OP_THREADSV, 0);
2157 o->op_targ = find_threadsv("_");
2160 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2161 #endif /* USE_THREADS */
2165 Perl_newPROG(pTHX_ OP *o)
2170 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2171 ((PL_in_eval & EVAL_KEEPERR)
2172 ? OPf_SPECIAL : 0), o);
2173 PL_eval_start = linklist(PL_eval_root);
2174 PL_eval_root->op_private |= OPpREFCOUNTED;
2175 OpREFCNT_set(PL_eval_root, 1);
2176 PL_eval_root->op_next = 0;
2177 peep(PL_eval_start);
2182 PL_main_root = scope(sawparens(scalarvoid(o)));
2183 PL_curcop = &PL_compiling;
2184 PL_main_start = LINKLIST(PL_main_root);
2185 PL_main_root->op_private |= OPpREFCOUNTED;
2186 OpREFCNT_set(PL_main_root, 1);
2187 PL_main_root->op_next = 0;
2188 peep(PL_main_start);
2191 /* Register with debugger */
2193 CV *cv = get_cv("DB::postponed", FALSE);
2197 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2199 call_sv((SV*)cv, G_DISCARD);
2206 Perl_localize(pTHX_ OP *o, I32 lex)
2208 if (o->op_flags & OPf_PARENS)
2211 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2213 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2214 if (*s == ';' || *s == '=')
2215 Perl_warner(aTHX_ WARN_PARENTHESIS,
2216 "Parentheses missing around \"%s\" list",
2217 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2223 o = mod(o, OP_NULL); /* a bit kludgey */
2225 PL_in_my_stash = Nullhv;
2230 Perl_jmaybe(pTHX_ OP *o)
2232 if (o->op_type == OP_LIST) {
2235 o2 = newOP(OP_THREADSV, 0);
2236 o2->op_targ = find_threadsv(";");
2238 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2239 #endif /* USE_THREADS */
2240 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2246 Perl_fold_constants(pTHX_ register OP *o)
2249 I32 type = o->op_type;
2252 if (PL_opargs[type] & OA_RETSCALAR)
2254 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2255 o->op_targ = pad_alloc(type, SVs_PADTMP);
2257 /* integerize op, unless it happens to be C<-foo>.
2258 * XXX should pp_i_negate() do magic string negation instead? */
2259 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2260 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2261 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2263 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2266 if (!(PL_opargs[type] & OA_FOLDCONST))
2271 /* XXX might want a ck_negate() for this */
2272 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2284 /* XXX what about the numeric ops? */
2285 if (PL_hints & HINT_LOCALE)
2290 goto nope; /* Don't try to run w/ errors */
2292 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2293 if ((curop->op_type != OP_CONST ||
2294 (curop->op_private & OPpCONST_BARE)) &&
2295 curop->op_type != OP_LIST &&
2296 curop->op_type != OP_SCALAR &&
2297 curop->op_type != OP_NULL &&
2298 curop->op_type != OP_PUSHMARK)
2304 curop = LINKLIST(o);
2308 sv = *(PL_stack_sp--);
2309 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2310 pad_swipe(o->op_targ);
2311 else if (SvTEMP(sv)) { /* grab mortal temp? */
2312 (void)SvREFCNT_inc(sv);
2316 if (type == OP_RV2GV)
2317 return newGVOP(OP_GV, 0, (GV*)sv);
2319 /* try to smush double to int, but don't smush -2.0 to -2 */
2320 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2323 #ifdef PERL_PRESERVE_IVUV
2324 /* Only bother to attempt to fold to IV if
2325 most operators will benefit */
2329 return newSVOP(OP_CONST, 0, sv);
2333 if (!(PL_opargs[type] & OA_OTHERINT))
2336 if (!(PL_hints & HINT_INTEGER)) {
2337 if (type == OP_MODULO
2338 || type == OP_DIVIDE
2339 || !(o->op_flags & OPf_KIDS))
2344 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2345 if (curop->op_type == OP_CONST) {
2346 if (SvIOK(((SVOP*)curop)->op_sv))
2350 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2354 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2361 Perl_gen_constant_list(pTHX_ register OP *o)
2364 I32 oldtmps_floor = PL_tmps_floor;
2368 return o; /* Don't attempt to run with errors */
2370 PL_op = curop = LINKLIST(o);
2377 PL_tmps_floor = oldtmps_floor;
2379 o->op_type = OP_RV2AV;
2380 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2381 curop = ((UNOP*)o)->op_first;
2382 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2389 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2391 if (!o || o->op_type != OP_LIST)
2392 o = newLISTOP(OP_LIST, 0, o, Nullop);
2394 o->op_flags &= ~OPf_WANT;
2396 if (!(PL_opargs[type] & OA_MARK))
2397 op_null(cLISTOPo->op_first);
2400 o->op_ppaddr = PL_ppaddr[type];
2401 o->op_flags |= flags;
2403 o = CHECKOP(type, o);
2404 if (o->op_type != type)
2407 return fold_constants(o);
2410 /* List constructors */
2413 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2421 if (first->op_type != type
2422 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2424 return newLISTOP(type, 0, first, last);
2427 if (first->op_flags & OPf_KIDS)
2428 ((LISTOP*)first)->op_last->op_sibling = last;
2430 first->op_flags |= OPf_KIDS;
2431 ((LISTOP*)first)->op_first = last;
2433 ((LISTOP*)first)->op_last = last;
2438 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2446 if (first->op_type != type)
2447 return prepend_elem(type, (OP*)first, (OP*)last);
2449 if (last->op_type != type)
2450 return append_elem(type, (OP*)first, (OP*)last);
2452 first->op_last->op_sibling = last->op_first;
2453 first->op_last = last->op_last;
2454 first->op_flags |= (last->op_flags & OPf_KIDS);
2456 #ifdef PL_OP_SLAB_ALLOC
2464 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2472 if (last->op_type == type) {
2473 if (type == OP_LIST) { /* already a PUSHMARK there */
2474 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2475 ((LISTOP*)last)->op_first->op_sibling = first;
2476 if (!(first->op_flags & OPf_PARENS))
2477 last->op_flags &= ~OPf_PARENS;
2480 if (!(last->op_flags & OPf_KIDS)) {
2481 ((LISTOP*)last)->op_last = first;
2482 last->op_flags |= OPf_KIDS;
2484 first->op_sibling = ((LISTOP*)last)->op_first;
2485 ((LISTOP*)last)->op_first = first;
2487 last->op_flags |= OPf_KIDS;
2491 return newLISTOP(type, 0, first, last);
2497 Perl_newNULLLIST(pTHX)
2499 return newOP(OP_STUB, 0);
2503 Perl_force_list(pTHX_ OP *o)
2505 if (!o || o->op_type != OP_LIST)
2506 o = newLISTOP(OP_LIST, 0, o, Nullop);
2512 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2516 NewOp(1101, listop, 1, LISTOP);
2518 listop->op_type = type;
2519 listop->op_ppaddr = PL_ppaddr[type];
2522 listop->op_flags = flags;
2526 else if (!first && last)
2529 first->op_sibling = last;
2530 listop->op_first = first;
2531 listop->op_last = last;
2532 if (type == OP_LIST) {
2534 pushop = newOP(OP_PUSHMARK, 0);
2535 pushop->op_sibling = first;
2536 listop->op_first = pushop;
2537 listop->op_flags |= OPf_KIDS;
2539 listop->op_last = pushop;
2546 Perl_newOP(pTHX_ I32 type, I32 flags)
2549 NewOp(1101, o, 1, OP);
2551 o->op_ppaddr = PL_ppaddr[type];
2552 o->op_flags = flags;
2555 o->op_private = 0 + (flags >> 8);
2556 if (PL_opargs[type] & OA_RETSCALAR)
2558 if (PL_opargs[type] & OA_TARGET)
2559 o->op_targ = pad_alloc(type, SVs_PADTMP);
2560 return CHECKOP(type, o);
2564 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2569 first = newOP(OP_STUB, 0);
2570 if (PL_opargs[type] & OA_MARK)
2571 first = force_list(first);
2573 NewOp(1101, unop, 1, UNOP);
2574 unop->op_type = type;
2575 unop->op_ppaddr = PL_ppaddr[type];
2576 unop->op_first = first;
2577 unop->op_flags = flags | OPf_KIDS;
2578 unop->op_private = 1 | (flags >> 8);
2579 unop = (UNOP*) CHECKOP(type, unop);
2583 return fold_constants((OP *) unop);
2587 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2590 NewOp(1101, binop, 1, BINOP);
2593 first = newOP(OP_NULL, 0);
2595 binop->op_type = type;
2596 binop->op_ppaddr = PL_ppaddr[type];
2597 binop->op_first = first;
2598 binop->op_flags = flags | OPf_KIDS;
2601 binop->op_private = 1 | (flags >> 8);
2604 binop->op_private = 2 | (flags >> 8);
2605 first->op_sibling = last;
2608 binop = (BINOP*)CHECKOP(type, binop);
2609 if (binop->op_next || binop->op_type != type)
2612 binop->op_last = binop->op_first->op_sibling;
2614 return fold_constants((OP *)binop);
2618 uvcompare(const void *a, const void *b)
2620 if (*((UV *)a) < (*(UV *)b))
2622 if (*((UV *)a) > (*(UV *)b))
2624 if (*((UV *)a+1) < (*(UV *)b+1))
2626 if (*((UV *)a+1) > (*(UV *)b+1))
2632 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2634 SV *tstr = ((SVOP*)expr)->op_sv;
2635 SV *rstr = ((SVOP*)repl)->op_sv;
2638 U8 *t = (U8*)SvPV(tstr, tlen);
2639 U8 *r = (U8*)SvPV(rstr, rlen);
2646 register short *tbl;
2648 PL_hints |= HINT_BLOCK_SCOPE;
2649 complement = o->op_private & OPpTRANS_COMPLEMENT;
2650 del = o->op_private & OPpTRANS_DELETE;
2651 squash = o->op_private & OPpTRANS_SQUASH;
2654 o->op_private |= OPpTRANS_FROM_UTF;
2657 o->op_private |= OPpTRANS_TO_UTF;
2659 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2660 SV* listsv = newSVpvn("# comment\n",10);
2662 U8* tend = t + tlen;
2663 U8* rend = r + rlen;
2677 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2678 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2684 tsave = t = bytes_to_utf8(t, &len);
2687 if (!to_utf && rlen) {
2689 rsave = r = bytes_to_utf8(r, &len);
2693 /* There are several snags with this code on EBCDIC:
2694 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2695 2. scan_const() in toke.c has encoded chars in native encoding which makes
2696 ranges at least in EBCDIC 0..255 range the bottom odd.
2700 U8 tmpbuf[UTF8_MAXLEN+1];
2703 New(1109, cp, 2*tlen, UV);
2705 transv = newSVpvn("",0);
2707 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2709 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2711 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2715 cp[2*i+1] = cp[2*i];
2719 qsort(cp, i, 2*sizeof(UV), uvcompare);
2720 for (j = 0; j < i; j++) {
2722 diff = val - nextmin;
2724 t = uvuni_to_utf8(tmpbuf,nextmin);
2725 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2727 U8 range_mark = UTF_TO_NATIVE(0xff);
2728 t = uvuni_to_utf8(tmpbuf, val - 1);
2729 sv_catpvn(transv, (char *)&range_mark, 1);
2730 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2737 t = uvuni_to_utf8(tmpbuf,nextmin);
2738 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2740 U8 range_mark = UTF_TO_NATIVE(0xff);
2741 sv_catpvn(transv, (char *)&range_mark, 1);
2743 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2744 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2745 t = (U8*)SvPVX(transv);
2746 tlen = SvCUR(transv);
2750 else if (!rlen && !del) {
2751 r = t; rlen = tlen; rend = tend;
2754 if ((!rlen && !del) || t == r ||
2755 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2757 o->op_private |= OPpTRANS_IDENTICAL;
2761 while (t < tend || tfirst <= tlast) {
2762 /* see if we need more "t" chars */
2763 if (tfirst > tlast) {
2764 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2766 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2768 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2775 /* now see if we need more "r" chars */
2776 if (rfirst > rlast) {
2778 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2780 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2782 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2791 rfirst = rlast = 0xffffffff;
2795 /* now see which range will peter our first, if either. */
2796 tdiff = tlast - tfirst;
2797 rdiff = rlast - rfirst;
2804 if (rfirst == 0xffffffff) {
2805 diff = tdiff; /* oops, pretend rdiff is infinite */
2807 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2808 (long)tfirst, (long)tlast);
2810 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2814 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2815 (long)tfirst, (long)(tfirst + diff),
2818 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2819 (long)tfirst, (long)rfirst);
2821 if (rfirst + diff > max)
2822 max = rfirst + diff;
2824 grows = (tfirst < rfirst &&
2825 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2837 else if (max > 0xff)
2842 Safefree(cPVOPo->op_pv);
2843 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2844 SvREFCNT_dec(listsv);
2846 SvREFCNT_dec(transv);
2848 if (!del && havefinal && rlen)
2849 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2850 newSVuv((UV)final), 0);
2853 o->op_private |= OPpTRANS_GROWS;
2865 tbl = (short*)cPVOPo->op_pv;
2867 Zero(tbl, 256, short);
2868 for (i = 0; i < tlen; i++)
2870 for (i = 0, j = 0; i < 256; i++) {
2881 if (i < 128 && r[j] >= 128)
2891 o->op_private |= OPpTRANS_IDENTICAL;
2896 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2897 tbl[0x100] = rlen - j;
2898 for (i=0; i < rlen - j; i++)
2899 tbl[0x101+i] = r[j+i];
2903 if (!rlen && !del) {
2906 o->op_private |= OPpTRANS_IDENTICAL;
2908 for (i = 0; i < 256; i++)
2910 for (i = 0, j = 0; i < tlen; i++,j++) {
2913 if (tbl[t[i]] == -1)
2919 if (tbl[t[i]] == -1) {
2920 if (t[i] < 128 && r[j] >= 128)
2927 o->op_private |= OPpTRANS_GROWS;
2935 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2939 NewOp(1101, pmop, 1, PMOP);
2940 pmop->op_type = type;
2941 pmop->op_ppaddr = PL_ppaddr[type];
2942 pmop->op_flags = flags;
2943 pmop->op_private = 0 | (flags >> 8);
2945 if (PL_hints & HINT_RE_TAINT)
2946 pmop->op_pmpermflags |= PMf_RETAINT;
2947 if (PL_hints & HINT_LOCALE)
2948 pmop->op_pmpermflags |= PMf_LOCALE;
2949 pmop->op_pmflags = pmop->op_pmpermflags;
2953 SV* repointer = newSViv(0);
2954 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2955 pmop->op_pmoffset = av_len(PL_regex_padav);
2956 PL_regex_pad = AvARRAY(PL_regex_padav);
2960 /* link into pm list */
2961 if (type != OP_TRANS && PL_curstash) {
2962 pmop->op_pmnext = HvPMROOT(PL_curstash);
2963 HvPMROOT(PL_curstash) = pmop;
2964 PmopSTASH_set(pmop,PL_curstash);
2971 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2975 I32 repl_has_vars = 0;
2977 if (o->op_type == OP_TRANS)
2978 return pmtrans(o, expr, repl);
2980 PL_hints |= HINT_BLOCK_SCOPE;
2983 if (expr->op_type == OP_CONST) {
2985 SV *pat = ((SVOP*)expr)->op_sv;
2986 char *p = SvPV(pat, plen);
2987 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2988 sv_setpvn(pat, "\\s+", 3);
2989 p = SvPV(pat, plen);
2990 pm->op_pmflags |= PMf_SKIPWHITE;
2992 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2993 pm->op_pmdynflags |= PMdf_UTF8;
2994 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2995 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2996 pm->op_pmflags |= PMf_WHITE;
3000 if (PL_hints & HINT_UTF8)
3001 pm->op_pmdynflags |= PMdf_UTF8;
3002 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3003 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3005 : OP_REGCMAYBE),0,expr);
3007 NewOp(1101, rcop, 1, LOGOP);
3008 rcop->op_type = OP_REGCOMP;
3009 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3010 rcop->op_first = scalar(expr);
3011 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3012 ? (OPf_SPECIAL | OPf_KIDS)
3014 rcop->op_private = 1;
3017 /* establish postfix order */
3018 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3020 rcop->op_next = expr;
3021 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3024 rcop->op_next = LINKLIST(expr);
3025 expr->op_next = (OP*)rcop;
3028 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3033 if (pm->op_pmflags & PMf_EVAL) {
3035 if (CopLINE(PL_curcop) < PL_multi_end)
3036 CopLINE_set(PL_curcop, PL_multi_end);
3039 else if (repl->op_type == OP_THREADSV
3040 && strchr("&`'123456789+",
3041 PL_threadsv_names[repl->op_targ]))
3045 #endif /* USE_THREADS */
3046 else if (repl->op_type == OP_CONST)
3050 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3051 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3053 if (curop->op_type == OP_THREADSV) {
3055 if (strchr("&`'123456789+", curop->op_private))
3059 if (curop->op_type == OP_GV) {
3060 GV *gv = cGVOPx_gv(curop);
3062 if (strchr("&`'123456789+", *GvENAME(gv)))
3065 #endif /* USE_THREADS */
3066 else if (curop->op_type == OP_RV2CV)
3068 else if (curop->op_type == OP_RV2SV ||
3069 curop->op_type == OP_RV2AV ||
3070 curop->op_type == OP_RV2HV ||
3071 curop->op_type == OP_RV2GV) {
3072 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3075 else if (curop->op_type == OP_PADSV ||
3076 curop->op_type == OP_PADAV ||
3077 curop->op_type == OP_PADHV ||
3078 curop->op_type == OP_PADANY) {
3081 else if (curop->op_type == OP_PUSHRE)
3082 ; /* Okay here, dangerous in newASSIGNOP */
3092 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3093 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3094 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3095 prepend_elem(o->op_type, scalar(repl), o);
3098 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3099 pm->op_pmflags |= PMf_MAYBE_CONST;
3100 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3102 NewOp(1101, rcop, 1, LOGOP);
3103 rcop->op_type = OP_SUBSTCONT;
3104 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3105 rcop->op_first = scalar(repl);
3106 rcop->op_flags |= OPf_KIDS;
3107 rcop->op_private = 1;
3110 /* establish postfix order */
3111 rcop->op_next = LINKLIST(repl);
3112 repl->op_next = (OP*)rcop;
3114 pm->op_pmreplroot = scalar((OP*)rcop);
3115 pm->op_pmreplstart = LINKLIST(rcop);
3124 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3127 NewOp(1101, svop, 1, SVOP);
3128 svop->op_type = type;
3129 svop->op_ppaddr = PL_ppaddr[type];
3131 svop->op_next = (OP*)svop;
3132 svop->op_flags = flags;
3133 if (PL_opargs[type] & OA_RETSCALAR)
3135 if (PL_opargs[type] & OA_TARGET)
3136 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3137 return CHECKOP(type, svop);
3141 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3144 NewOp(1101, padop, 1, PADOP);
3145 padop->op_type = type;
3146 padop->op_ppaddr = PL_ppaddr[type];
3147 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3148 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3149 PL_curpad[padop->op_padix] = sv;
3151 padop->op_next = (OP*)padop;
3152 padop->op_flags = flags;
3153 if (PL_opargs[type] & OA_RETSCALAR)
3155 if (PL_opargs[type] & OA_TARGET)
3156 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3157 return CHECKOP(type, padop);
3161 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3165 return newPADOP(type, flags, SvREFCNT_inc(gv));
3167 return newSVOP(type, flags, SvREFCNT_inc(gv));
3172 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3175 NewOp(1101, pvop, 1, PVOP);
3176 pvop->op_type = type;
3177 pvop->op_ppaddr = PL_ppaddr[type];
3179 pvop->op_next = (OP*)pvop;
3180 pvop->op_flags = flags;
3181 if (PL_opargs[type] & OA_RETSCALAR)
3183 if (PL_opargs[type] & OA_TARGET)
3184 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3185 return CHECKOP(type, pvop);
3189 Perl_package(pTHX_ OP *o)
3193 save_hptr(&PL_curstash);
3194 save_item(PL_curstname);
3199 name = SvPV(sv, len);
3200 PL_curstash = gv_stashpvn(name,len,TRUE);
3201 sv_setpvn(PL_curstname, name, len);
3205 deprecate("\"package\" with no arguments");
3206 sv_setpv(PL_curstname,"<none>");
3207 PL_curstash = Nullhv;
3209 PL_hints |= HINT_BLOCK_SCOPE;
3210 PL_copline = NOLINE;
3215 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3221 if (id->op_type != OP_CONST)
3222 Perl_croak(aTHX_ "Module name must be constant");
3226 if (version != Nullop) {
3227 SV *vesv = ((SVOP*)version)->op_sv;
3229 if (arg == Nullop && !SvNIOKp(vesv)) {
3236 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3237 Perl_croak(aTHX_ "Version number must be constant number");
3239 /* Make copy of id so we don't free it twice */
3240 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3242 /* Fake up a method call to VERSION */
3243 meth = newSVpvn("VERSION",7);
3244 sv_upgrade(meth, SVt_PVIV);
3245 (void)SvIOK_on(meth);
3246 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3247 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3248 append_elem(OP_LIST,
3249 prepend_elem(OP_LIST, pack, list(version)),
3250 newSVOP(OP_METHOD_NAMED, 0, meth)));
3254 /* Fake up an import/unimport */
3255 if (arg && arg->op_type == OP_STUB)
3256 imop = arg; /* no import on explicit () */
3257 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3258 imop = Nullop; /* use 5.0; */
3263 /* Make copy of id so we don't free it twice */
3264 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3266 /* Fake up a method call to import/unimport */
3267 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3268 sv_upgrade(meth, SVt_PVIV);
3269 (void)SvIOK_on(meth);
3270 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3271 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3272 append_elem(OP_LIST,
3273 prepend_elem(OP_LIST, pack, list(arg)),
3274 newSVOP(OP_METHOD_NAMED, 0, meth)));
3277 /* Fake up the BEGIN {}, which does its thing immediately. */
3279 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3282 append_elem(OP_LINESEQ,
3283 append_elem(OP_LINESEQ,
3284 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3285 newSTATEOP(0, Nullch, veop)),
3286 newSTATEOP(0, Nullch, imop) ));
3288 PL_hints |= HINT_BLOCK_SCOPE;
3289 PL_copline = NOLINE;
3294 =for apidoc load_module
3296 Loads the module whose name is pointed to by the string part of name.
3297 Note that the actual module name, not its filename, should be given.
3298 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3299 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3300 (or 0 for no flags). ver, if specified, provides version semantics
3301 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3302 arguments can be used to specify arguments to the module's import()
3303 method, similar to C<use Foo::Bar VERSION LIST>.
3308 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3311 va_start(args, ver);
3312 vload_module(flags, name, ver, &args);
3316 #ifdef PERL_IMPLICIT_CONTEXT
3318 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3322 va_start(args, ver);
3323 vload_module(flags, name, ver, &args);
3329 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3331 OP *modname, *veop, *imop;
3333 modname = newSVOP(OP_CONST, 0, name);
3334 modname->op_private |= OPpCONST_BARE;
3336 veop = newSVOP(OP_CONST, 0, ver);
3340 if (flags & PERL_LOADMOD_NOIMPORT) {
3341 imop = sawparens(newNULLLIST());
3343 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3344 imop = va_arg(*args, OP*);
3349 sv = va_arg(*args, SV*);
3351 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3352 sv = va_arg(*args, SV*);
3356 line_t ocopline = PL_copline;
3357 int oexpect = PL_expect;
3359 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3360 veop, modname, imop);
3361 PL_expect = oexpect;
3362 PL_copline = ocopline;
3367 Perl_dofile(pTHX_ OP *term)
3372 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3373 if (!(gv && GvIMPORTED_CV(gv)))
3374 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3376 if (gv && GvIMPORTED_CV(gv)) {
3377 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3378 append_elem(OP_LIST, term,
3379 scalar(newUNOP(OP_RV2CV, 0,
3384 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3390 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3392 return newBINOP(OP_LSLICE, flags,
3393 list(force_list(subscript)),
3394 list(force_list(listval)) );
3398 S_list_assignment(pTHX_ register OP *o)
3403 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3404 o = cUNOPo->op_first;
3406 if (o->op_type == OP_COND_EXPR) {
3407 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3408 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3413 yyerror("Assignment to both a list and a scalar");
3417 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3418 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3419 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3422 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3425 if (o->op_type == OP_RV2SV)
3432 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3437 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3438 return newLOGOP(optype, 0,
3439 mod(scalar(left), optype),
3440 newUNOP(OP_SASSIGN, 0, scalar(right)));
3443 return newBINOP(optype, OPf_STACKED,
3444 mod(scalar(left), optype), scalar(right));
3448 if (list_assignment(left)) {
3452 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3453 left = mod(left, OP_AASSIGN);
3461 curop = list(force_list(left));
3462 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3463 o->op_private = 0 | (flags >> 8);
3464 for (curop = ((LISTOP*)curop)->op_first;
3465 curop; curop = curop->op_sibling)
3467 if (curop->op_type == OP_RV2HV &&
3468 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3469 o->op_private |= OPpASSIGN_HASH;
3473 if (!(left->op_private & OPpLVAL_INTRO)) {
3476 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3477 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3478 if (curop->op_type == OP_GV) {
3479 GV *gv = cGVOPx_gv(curop);
3480 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3482 SvCUR(gv) = PL_generation;
3484 else if (curop->op_type == OP_PADSV ||
3485 curop->op_type == OP_PADAV ||
3486 curop->op_type == OP_PADHV ||
3487 curop->op_type == OP_PADANY) {
3488 SV **svp = AvARRAY(PL_comppad_name);
3489 SV *sv = svp[curop->op_targ];
3490 if (SvCUR(sv) == PL_generation)
3492 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3494 else if (curop->op_type == OP_RV2CV)
3496 else if (curop->op_type == OP_RV2SV ||
3497 curop->op_type == OP_RV2AV ||
3498 curop->op_type == OP_RV2HV ||
3499 curop->op_type == OP_RV2GV) {
3500 if (lastop->op_type != OP_GV) /* funny deref? */
3503 else if (curop->op_type == OP_PUSHRE) {
3504 if (((PMOP*)curop)->op_pmreplroot) {
3506 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3508 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3510 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3512 SvCUR(gv) = PL_generation;
3521 o->op_private |= OPpASSIGN_COMMON;
3523 if (right && right->op_type == OP_SPLIT) {
3525 if ((tmpop = ((LISTOP*)right)->op_first) &&
3526 tmpop->op_type == OP_PUSHRE)
3528 PMOP *pm = (PMOP*)tmpop;
3529 if (left->op_type == OP_RV2AV &&
3530 !(left->op_private & OPpLVAL_INTRO) &&
3531 !(o->op_private & OPpASSIGN_COMMON) )
3533 tmpop = ((UNOP*)left)->op_first;
3534 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3536 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3537 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3539 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3540 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3542 pm->op_pmflags |= PMf_ONCE;
3543 tmpop = cUNOPo->op_first; /* to list (nulled) */
3544 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3545 tmpop->op_sibling = Nullop; /* don't free split */
3546 right->op_next = tmpop->op_next; /* fix starting loc */
3547 op_free(o); /* blow off assign */
3548 right->op_flags &= ~OPf_WANT;
3549 /* "I don't know and I don't care." */
3554 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3555 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3557 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3559 sv_setiv(sv, PL_modcount+1);
3567 right = newOP(OP_UNDEF, 0);
3568 if (right->op_type == OP_READLINE) {
3569 right->op_flags |= OPf_STACKED;
3570 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3573 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3574 o = newBINOP(OP_SASSIGN, flags,
3575 scalar(right), mod(scalar(left), OP_SASSIGN) );
3587 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3589 U32 seq = intro_my();
3592 NewOp(1101, cop, 1, COP);
3593 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3594 cop->op_type = OP_DBSTATE;
3595 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3598 cop->op_type = OP_NEXTSTATE;
3599 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3601 cop->op_flags = flags;
3602 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3604 cop->op_private |= NATIVE_HINTS;
3606 PL_compiling.op_private = cop->op_private;
3607 cop->op_next = (OP*)cop;
3610 cop->cop_label = label;
3611 PL_hints |= HINT_BLOCK_SCOPE;
3614 cop->cop_arybase = PL_curcop->cop_arybase;
3615 if (specialWARN(PL_curcop->cop_warnings))
3616 cop->cop_warnings = PL_curcop->cop_warnings ;
3618 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3619 if (specialCopIO(PL_curcop->cop_io))
3620 cop->cop_io = PL_curcop->cop_io;
3622 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3625 if (PL_copline == NOLINE)
3626 CopLINE_set(cop, CopLINE(PL_curcop));
3628 CopLINE_set(cop, PL_copline);
3629 PL_copline = NOLINE;
3632 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3634 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3636 CopSTASH_set(cop, PL_curstash);
3638 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3639 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3640 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3641 (void)SvIOK_on(*svp);
3642 SvIVX(*svp) = PTR2IV(cop);
3646 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3649 /* "Introduce" my variables to visible status. */
3657 if (! PL_min_intro_pending)
3658 return PL_cop_seqmax;
3660 svp = AvARRAY(PL_comppad_name);
3661 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3662 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3663 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3664 SvNVX(sv) = (NV)PL_cop_seqmax;
3667 PL_min_intro_pending = 0;
3668 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3669 return PL_cop_seqmax++;
3673 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3675 return new_logop(type, flags, &first, &other);
3679 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3683 OP *first = *firstp;
3684 OP *other = *otherp;
3686 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3687 return newBINOP(type, flags, scalar(first), scalar(other));
3689 scalarboolean(first);
3690 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3691 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3692 if (type == OP_AND || type == OP_OR) {
3698 first = *firstp = cUNOPo->op_first;
3700 first->op_next = o->op_next;
3701 cUNOPo->op_first = Nullop;
3705 if (first->op_type == OP_CONST) {
3706 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3707 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3708 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3719 else if (first->op_type == OP_WANTARRAY) {
3725 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3726 OP *k1 = ((UNOP*)first)->op_first;
3727 OP *k2 = k1->op_sibling;
3729 switch (first->op_type)
3732 if (k2 && k2->op_type == OP_READLINE
3733 && (k2->op_flags & OPf_STACKED)
3734 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3736 warnop = k2->op_type;
3741 if (k1->op_type == OP_READDIR
3742 || k1->op_type == OP_GLOB
3743 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3744 || k1->op_type == OP_EACH)
3746 warnop = ((k1->op_type == OP_NULL)
3747 ? k1->op_targ : k1->op_type);
3752 line_t oldline = CopLINE(PL_curcop);
3753 CopLINE_set(PL_curcop, PL_copline);
3754 Perl_warner(aTHX_ WARN_MISC,
3755 "Value of %s%s can be \"0\"; test with defined()",
3757 ((warnop == OP_READLINE || warnop == OP_GLOB)
3758 ? " construct" : "() operator"));
3759 CopLINE_set(PL_curcop, oldline);
3766 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3767 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3769 NewOp(1101, logop, 1, LOGOP);
3771 logop->op_type = type;
3772 logop->op_ppaddr = PL_ppaddr[type];
3773 logop->op_first = first;
3774 logop->op_flags = flags | OPf_KIDS;
3775 logop->op_other = LINKLIST(other);
3776 logop->op_private = 1 | (flags >> 8);
3778 /* establish postfix order */
3779 logop->op_next = LINKLIST(first);
3780 first->op_next = (OP*)logop;
3781 first->op_sibling = other;
3783 o = newUNOP(OP_NULL, 0, (OP*)logop);
3790 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3797 return newLOGOP(OP_AND, 0, first, trueop);
3799 return newLOGOP(OP_OR, 0, first, falseop);
3801 scalarboolean(first);
3802 if (first->op_type == OP_CONST) {
3803 if (SvTRUE(((SVOP*)first)->op_sv)) {
3814 else if (first->op_type == OP_WANTARRAY) {
3818 NewOp(1101, logop, 1, LOGOP);
3819 logop->op_type = OP_COND_EXPR;
3820 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3821 logop->op_first = first;
3822 logop->op_flags = flags | OPf_KIDS;
3823 logop->op_private = 1 | (flags >> 8);
3824 logop->op_other = LINKLIST(trueop);
3825 logop->op_next = LINKLIST(falseop);
3828 /* establish postfix order */
3829 start = LINKLIST(first);
3830 first->op_next = (OP*)logop;
3832 first->op_sibling = trueop;
3833 trueop->op_sibling = falseop;
3834 o = newUNOP(OP_NULL, 0, (OP*)logop);
3836 trueop->op_next = falseop->op_next = o;
3843 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3851 NewOp(1101, range, 1, LOGOP);
3853 range->op_type = OP_RANGE;
3854 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3855 range->op_first = left;
3856 range->op_flags = OPf_KIDS;
3857 leftstart = LINKLIST(left);
3858 range->op_other = LINKLIST(right);
3859 range->op_private = 1 | (flags >> 8);
3861 left->op_sibling = right;
3863 range->op_next = (OP*)range;
3864 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3865 flop = newUNOP(OP_FLOP, 0, flip);
3866 o = newUNOP(OP_NULL, 0, flop);
3868 range->op_next = leftstart;
3870 left->op_next = flip;
3871 right->op_next = flop;
3873 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3874 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3875 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3876 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3878 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3879 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3882 if (!flip->op_private || !flop->op_private)
3883 linklist(o); /* blow off optimizer unless constant */
3889 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3893 int once = block && block->op_flags & OPf_SPECIAL &&
3894 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3897 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3898 return block; /* do {} while 0 does once */
3899 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3900 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3901 expr = newUNOP(OP_DEFINED, 0,
3902 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3903 } else if (expr->op_flags & OPf_KIDS) {
3904 OP *k1 = ((UNOP*)expr)->op_first;
3905 OP *k2 = (k1) ? k1->op_sibling : NULL;
3906 switch (expr->op_type) {
3908 if (k2 && k2->op_type == OP_READLINE
3909 && (k2->op_flags & OPf_STACKED)
3910 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3911 expr = newUNOP(OP_DEFINED, 0, expr);
3915 if (k1->op_type == OP_READDIR
3916 || k1->op_type == OP_GLOB
3917 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3918 || k1->op_type == OP_EACH)
3919 expr = newUNOP(OP_DEFINED, 0, expr);
3925 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3926 o = new_logop(OP_AND, 0, &expr, &listop);
3929 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3931 if (once && o != listop)
3932 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3935 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3937 o->op_flags |= flags;
3939 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3944 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3952 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3953 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3954 expr = newUNOP(OP_DEFINED, 0,
3955 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3956 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3957 OP *k1 = ((UNOP*)expr)->op_first;
3958 OP *k2 = (k1) ? k1->op_sibling : NULL;
3959 switch (expr->op_type) {
3961 if (k2 && k2->op_type == OP_READLINE
3962 && (k2->op_flags & OPf_STACKED)
3963 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3964 expr = newUNOP(OP_DEFINED, 0, expr);
3968 if (k1->op_type == OP_READDIR
3969 || k1->op_type == OP_GLOB
3970 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3971 || k1->op_type == OP_EACH)
3972 expr = newUNOP(OP_DEFINED, 0, expr);
3978 block = newOP(OP_NULL, 0);
3980 block = scope(block);
3984 next = LINKLIST(cont);
3987 OP *unstack = newOP(OP_UNSTACK, 0);
3990 cont = append_elem(OP_LINESEQ, cont, unstack);
3991 if ((line_t)whileline != NOLINE) {
3992 PL_copline = whileline;
3993 cont = append_elem(OP_LINESEQ, cont,
3994 newSTATEOP(0, Nullch, Nullop));
3998 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3999 redo = LINKLIST(listop);
4002 PL_copline = whileline;
4004 o = new_logop(OP_AND, 0, &expr, &listop);
4005 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4006 op_free(expr); /* oops, it's a while (0) */
4008 return Nullop; /* listop already freed by new_logop */
4011 ((LISTOP*)listop)->op_last->op_next =
4012 (o == listop ? redo : LINKLIST(o));
4018 NewOp(1101,loop,1,LOOP);
4019 loop->op_type = OP_ENTERLOOP;
4020 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4021 loop->op_private = 0;
4022 loop->op_next = (OP*)loop;
4025 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4027 loop->op_redoop = redo;
4028 loop->op_lastop = o;
4029 o->op_private |= loopflags;
4032 loop->op_nextop = next;
4034 loop->op_nextop = o;
4036 o->op_flags |= flags;
4037 o->op_private |= (flags >> 8);
4042 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4050 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4051 sv->op_type = OP_RV2GV;
4052 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4054 else if (sv->op_type == OP_PADSV) { /* private variable */
4055 padoff = sv->op_targ;
4060 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4061 padoff = sv->op_targ;
4063 iterflags |= OPf_SPECIAL;
4068 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4072 padoff = find_threadsv("_");
4073 iterflags |= OPf_SPECIAL;
4075 sv = newGVOP(OP_GV, 0, PL_defgv);
4078 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4079 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4080 iterflags |= OPf_STACKED;
4082 else if (expr->op_type == OP_NULL &&
4083 (expr->op_flags & OPf_KIDS) &&
4084 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4086 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4087 * set the STACKED flag to indicate that these values are to be
4088 * treated as min/max values by 'pp_iterinit'.
4090 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4091 LOGOP* range = (LOGOP*) flip->op_first;
4092 OP* left = range->op_first;
4093 OP* right = left->op_sibling;
4096 range->op_flags &= ~OPf_KIDS;
4097 range->op_first = Nullop;
4099 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4100 listop->op_first->op_next = range->op_next;
4101 left->op_next = range->op_other;
4102 right->op_next = (OP*)listop;
4103 listop->op_next = listop->op_first;
4106 expr = (OP*)(listop);
4108 iterflags |= OPf_STACKED;
4111 expr = mod(force_list(expr), OP_GREPSTART);
4115 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4116 append_elem(OP_LIST, expr, scalar(sv))));
4117 assert(!loop->op_next);
4118 #ifdef PL_OP_SLAB_ALLOC
4121 NewOp(1234,tmp,1,LOOP);
4122 Copy(loop,tmp,1,LOOP);
4126 Renew(loop, 1, LOOP);
4128 loop->op_targ = padoff;
4129 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4130 PL_copline = forline;
4131 return newSTATEOP(0, label, wop);
4135 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4140 if (type != OP_GOTO || label->op_type == OP_CONST) {
4141 /* "last()" means "last" */
4142 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4143 o = newOP(type, OPf_SPECIAL);
4145 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4146 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4152 if (label->op_type == OP_ENTERSUB)
4153 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4154 o = newUNOP(type, OPf_STACKED, label);
4156 PL_hints |= HINT_BLOCK_SCOPE;
4161 Perl_cv_undef(pTHX_ CV *cv)
4165 MUTEX_DESTROY(CvMUTEXP(cv));
4166 Safefree(CvMUTEXP(cv));
4169 #endif /* USE_THREADS */
4172 if (CvFILE(cv) && !CvXSUB(cv)) {
4173 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4174 Safefree(CvFILE(cv));
4179 if (!CvXSUB(cv) && CvROOT(cv)) {
4181 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4182 Perl_croak(aTHX_ "Can't undef active subroutine");
4185 Perl_croak(aTHX_ "Can't undef active subroutine");
4186 #endif /* USE_THREADS */
4189 SAVEVPTR(PL_curpad);
4192 op_free(CvROOT(cv));
4193 CvROOT(cv) = Nullop;
4196 SvPOK_off((SV*)cv); /* forget prototype */
4198 /* Since closure prototypes have the same lifetime as the containing
4199 * CV, they don't hold a refcount on the outside CV. This avoids
4200 * the refcount loop between the outer CV (which keeps a refcount to
4201 * the closure prototype in the pad entry for pp_anoncode()) and the
4202 * closure prototype, and the ensuing memory leak. This does not
4203 * apply to closures generated within eval"", since eval"" CVs are
4204 * ephemeral. --GSAR */
4205 if (!CvANON(cv) || CvCLONED(cv)
4206 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4207 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4209 SvREFCNT_dec(CvOUTSIDE(cv));
4211 CvOUTSIDE(cv) = Nullcv;
4213 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4216 if (CvPADLIST(cv)) {
4217 /* may be during global destruction */
4218 if (SvREFCNT(CvPADLIST(cv))) {
4219 I32 i = AvFILLp(CvPADLIST(cv));
4221 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4222 SV* sv = svp ? *svp : Nullsv;
4225 if (sv == (SV*)PL_comppad_name)
4226 PL_comppad_name = Nullav;
4227 else if (sv == (SV*)PL_comppad) {
4228 PL_comppad = Nullav;
4229 PL_curpad = Null(SV**);
4233 SvREFCNT_dec((SV*)CvPADLIST(cv));
4235 CvPADLIST(cv) = Nullav;
4243 #ifdef DEBUG_CLOSURES
4245 S_cv_dump(pTHX_ CV *cv)
4248 CV *outside = CvOUTSIDE(cv);
4249 AV* padlist = CvPADLIST(cv);
4256 PerlIO_printf(Perl_debug_log,
4257 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4259 (CvANON(cv) ? "ANON"
4260 : (cv == PL_main_cv) ? "MAIN"
4261 : CvUNIQUE(cv) ? "UNIQUE"
4262 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4265 : CvANON(outside) ? "ANON"
4266 : (outside == PL_main_cv) ? "MAIN"
4267 : CvUNIQUE(outside) ? "UNIQUE"
4268 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4273 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4274 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4275 pname = AvARRAY(pad_name);
4276 ppad = AvARRAY(pad);
4278 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4279 if (SvPOK(pname[ix]))
4280 PerlIO_printf(Perl_debug_log,
4281 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4282 (int)ix, PTR2UV(ppad[ix]),
4283 SvFAKE(pname[ix]) ? "FAKE " : "",
4285 (IV)I_32(SvNVX(pname[ix])),
4288 #endif /* DEBUGGING */
4290 #endif /* DEBUG_CLOSURES */
4293 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4297 AV* protopadlist = CvPADLIST(proto);
4298 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4299 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4300 SV** pname = AvARRAY(protopad_name);
4301 SV** ppad = AvARRAY(protopad);
4302 I32 fname = AvFILLp(protopad_name);
4303 I32 fpad = AvFILLp(protopad);
4307 assert(!CvUNIQUE(proto));
4311 SAVESPTR(PL_comppad_name);
4312 SAVESPTR(PL_compcv);
4314 cv = PL_compcv = (CV*)NEWSV(1104,0);
4315 sv_upgrade((SV *)cv, SvTYPE(proto));
4316 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4320 New(666, CvMUTEXP(cv), 1, perl_mutex);
4321 MUTEX_INIT(CvMUTEXP(cv));
4323 #endif /* USE_THREADS */
4325 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4326 : savepv(CvFILE(proto));
4328 CvFILE(cv) = CvFILE(proto);
4330 CvGV(cv) = CvGV(proto);
4331 CvSTASH(cv) = CvSTASH(proto);
4332 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4333 CvSTART(cv) = CvSTART(proto);
4335 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4338 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4340 PL_comppad_name = newAV();
4341 for (ix = fname; ix >= 0; ix--)
4342 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4344 PL_comppad = newAV();
4346 comppadlist = newAV();
4347 AvREAL_off(comppadlist);
4348 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4349 av_store(comppadlist, 1, (SV*)PL_comppad);
4350 CvPADLIST(cv) = comppadlist;
4351 av_fill(PL_comppad, AvFILLp(protopad));
4352 PL_curpad = AvARRAY(PL_comppad);
4354 av = newAV(); /* will be @_ */
4356 av_store(PL_comppad, 0, (SV*)av);
4357 AvFLAGS(av) = AVf_REIFY;
4359 for (ix = fpad; ix > 0; ix--) {
4360 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4361 if (namesv && namesv != &PL_sv_undef) {
4362 char *name = SvPVX(namesv); /* XXX */
4363 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4364 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4365 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4367 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4369 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4371 else { /* our own lexical */
4374 /* anon code -- we'll come back for it */
4375 sv = SvREFCNT_inc(ppad[ix]);
4377 else if (*name == '@')
4379 else if (*name == '%')
4388 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4389 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4392 SV* sv = NEWSV(0,0);
4398 /* Now that vars are all in place, clone nested closures. */
4400 for (ix = fpad; ix > 0; ix--) {
4401 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4403 && namesv != &PL_sv_undef
4404 && !(SvFLAGS(namesv) & SVf_FAKE)
4405 && *SvPVX(namesv) == '&'
4406 && CvCLONE(ppad[ix]))
4408 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4409 SvREFCNT_dec(ppad[ix]);
4412 PL_curpad[ix] = (SV*)kid;
4416 #ifdef DEBUG_CLOSURES
4417 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4419 PerlIO_printf(Perl_debug_log, " from:\n");
4421 PerlIO_printf(Perl_debug_log, " to:\n");
4428 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4430 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4432 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4439 Perl_cv_clone(pTHX_ CV *proto)
4442 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4443 cv = cv_clone2(proto, CvOUTSIDE(proto));
4444 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4449 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4451 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4452 SV* msg = sv_newmortal();
4456 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4457 sv_setpv(msg, "Prototype mismatch:");
4459 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4461 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4462 sv_catpv(msg, " vs ");
4464 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4466 sv_catpv(msg, "none");
4467 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4471 static void const_sv_xsub(pTHXo_ CV* cv);
4474 =for apidoc cv_const_sv
4476 If C<cv> is a constant sub eligible for inlining. returns the constant
4477 value returned by the sub. Otherwise, returns NULL.
4479 Constant subs can be created with C<newCONSTSUB> or as described in
4480 L<perlsub/"Constant Functions">.
4485 Perl_cv_const_sv(pTHX_ CV *cv)
4487 if (!cv || !CvCONST(cv))
4489 return (SV*)CvXSUBANY(cv).any_ptr;
4493 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4500 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4501 o = cLISTOPo->op_first->op_sibling;
4503 for (; o; o = o->op_next) {
4504 OPCODE type = o->op_type;
4506 if (sv && o->op_next == o)
4508 if (o->op_next != o) {
4509 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4511 if (type == OP_DBSTATE)
4514 if (type == OP_LEAVESUB || type == OP_RETURN)
4518 if (type == OP_CONST && cSVOPo->op_sv)
4520 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4521 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4522 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4526 /* We get here only from cv_clone2() while creating a closure.
4527 Copy the const value here instead of in cv_clone2 so that
4528 SvREADONLY_on doesn't lead to problems when leaving
4533 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4545 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4555 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4559 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4561 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4565 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4571 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4576 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4577 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4578 SV *sv = sv_newmortal();
4579 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4580 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4585 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4586 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4596 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4597 maximum a prototype before. */
4598 if (SvTYPE(gv) > SVt_NULL) {
4599 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4600 && ckWARN_d(WARN_PROTOTYPE))
4602 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4604 cv_ckproto((CV*)gv, NULL, ps);
4607 sv_setpv((SV*)gv, ps);
4609 sv_setiv((SV*)gv, -1);
4610 SvREFCNT_dec(PL_compcv);
4611 cv = PL_compcv = NULL;
4612 PL_sub_generation++;
4616 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4618 #ifdef GV_UNIQUE_CHECK
4619 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4620 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4624 if (!block || !ps || *ps || attrs)
4627 const_sv = op_const_sv(block, Nullcv);
4630 bool exists = CvROOT(cv) || CvXSUB(cv);
4632 #ifdef GV_UNIQUE_CHECK
4633 if (exists && GvUNIQUE(gv)) {
4634 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4638 /* if the subroutine doesn't exist and wasn't pre-declared
4639 * with a prototype, assume it will be AUTOLOADed,
4640 * skipping the prototype check
4642 if (exists || SvPOK(cv))
4643 cv_ckproto(cv, gv, ps);
4644 /* already defined (or promised)? */
4645 if (exists || GvASSUMECV(gv)) {
4646 if (!block && !attrs) {
4647 /* just a "sub foo;" when &foo is already defined */
4648 SAVEFREESV(PL_compcv);
4651 /* ahem, death to those who redefine active sort subs */
4652 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4653 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4655 if (ckWARN(WARN_REDEFINE)
4657 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4659 line_t oldline = CopLINE(PL_curcop);
4660 CopLINE_set(PL_curcop, PL_copline);
4661 Perl_warner(aTHX_ WARN_REDEFINE,
4662 CvCONST(cv) ? "Constant subroutine %s redefined"
4663 : "Subroutine %s redefined", name);
4664 CopLINE_set(PL_curcop, oldline);
4672 SvREFCNT_inc(const_sv);
4674 assert(!CvROOT(cv) && !CvCONST(cv));
4675 sv_setpv((SV*)cv, ""); /* prototype is "" */
4676 CvXSUBANY(cv).any_ptr = const_sv;
4677 CvXSUB(cv) = const_sv_xsub;
4682 cv = newCONSTSUB(NULL, name, const_sv);
4685 SvREFCNT_dec(PL_compcv);
4687 PL_sub_generation++;
4694 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4695 * before we clobber PL_compcv.
4699 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4700 stash = GvSTASH(CvGV(cv));
4701 else if (CvSTASH(cv))
4702 stash = CvSTASH(cv);
4704 stash = PL_curstash;
4707 /* possibly about to re-define existing subr -- ignore old cv */
4708 rcv = (SV*)PL_compcv;
4709 if (name && GvSTASH(gv))
4710 stash = GvSTASH(gv);
4712 stash = PL_curstash;
4714 apply_attrs(stash, rcv, attrs);
4716 if (cv) { /* must reuse cv if autoloaded */
4718 /* got here with just attrs -- work done, so bug out */
4719 SAVEFREESV(PL_compcv);
4723 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4724 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4725 CvOUTSIDE(PL_compcv) = 0;
4726 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4727 CvPADLIST(PL_compcv) = 0;
4728 /* inner references to PL_compcv must be fixed up ... */
4730 AV *padlist = CvPADLIST(cv);
4731 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4732 AV *comppad = (AV*)AvARRAY(padlist)[1];
4733 SV **namepad = AvARRAY(comppad_name);
4734 SV **curpad = AvARRAY(comppad);
4735 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4736 SV *namesv = namepad[ix];
4737 if (namesv && namesv != &PL_sv_undef
4738 && *SvPVX(namesv) == '&')
4740 CV *innercv = (CV*)curpad[ix];
4741 if (CvOUTSIDE(innercv) == PL_compcv) {
4742 CvOUTSIDE(innercv) = cv;
4743 if (!CvANON(innercv) || CvCLONED(innercv)) {
4744 (void)SvREFCNT_inc(cv);
4745 SvREFCNT_dec(PL_compcv);
4751 /* ... before we throw it away */
4752 SvREFCNT_dec(PL_compcv);
4753 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4754 ++PL_sub_generation;
4761 PL_sub_generation++;
4765 CvFILE_set_from_cop(cv, PL_curcop);
4766 CvSTASH(cv) = PL_curstash;
4769 if (!CvMUTEXP(cv)) {
4770 New(666, CvMUTEXP(cv), 1, perl_mutex);
4771 MUTEX_INIT(CvMUTEXP(cv));
4773 #endif /* USE_THREADS */
4776 sv_setpv((SV*)cv, ps);
4778 if (PL_error_count) {
4782 char *s = strrchr(name, ':');
4784 if (strEQ(s, "BEGIN")) {
4786 "BEGIN not safe after errors--compilation aborted";
4787 if (PL_in_eval & EVAL_KEEPERR)
4788 Perl_croak(aTHX_ not_safe);
4790 /* force display of errors found but not reported */
4791 sv_catpv(ERRSV, not_safe);
4792 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4800 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4801 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4804 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4805 mod(scalarseq(block), OP_LEAVESUBLV));
4808 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4810 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4811 OpREFCNT_set(CvROOT(cv), 1);
4812 CvSTART(cv) = LINKLIST(CvROOT(cv));
4813 CvROOT(cv)->op_next = 0;
4816 /* now that optimizer has done its work, adjust pad values */
4818 SV **namep = AvARRAY(PL_comppad_name);
4819 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4822 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4825 * The only things that a clonable function needs in its
4826 * pad are references to outer lexicals and anonymous subs.
4827 * The rest are created anew during cloning.
4829 if (!((namesv = namep[ix]) != Nullsv &&
4830 namesv != &PL_sv_undef &&
4832 *SvPVX(namesv) == '&')))
4834 SvREFCNT_dec(PL_curpad[ix]);
4835 PL_curpad[ix] = Nullsv;
4838 assert(!CvCONST(cv));
4839 if (ps && !*ps && op_const_sv(block, cv))
4843 AV *av = newAV(); /* Will be @_ */
4845 av_store(PL_comppad, 0, (SV*)av);
4846 AvFLAGS(av) = AVf_REIFY;
4848 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4849 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4851 if (!SvPADMY(PL_curpad[ix]))
4852 SvPADTMP_on(PL_curpad[ix]);
4856 /* If a potential closure prototype, don't keep a refcount on
4857 * outer CV, unless the latter happens to be a passing eval"".
4858 * This is okay as the lifetime of the prototype is tied to the
4859 * lifetime of the outer CV. Avoids memory leak due to reference
4861 if (!name && CvOUTSIDE(cv)
4862 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4863 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4865 SvREFCNT_dec(CvOUTSIDE(cv));
4868 if (name || aname) {
4870 char *tname = (name ? name : aname);
4872 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4873 SV *sv = NEWSV(0,0);
4874 SV *tmpstr = sv_newmortal();
4875 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4879 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4881 (long)PL_subline, (long)CopLINE(PL_curcop));
4882 gv_efullname3(tmpstr, gv, Nullch);
4883 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4884 hv = GvHVn(db_postponed);
4885 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4886 && (pcv = GvCV(db_postponed)))
4892 call_sv((SV*)pcv, G_DISCARD);
4896 if ((s = strrchr(tname,':')))
4901 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4904 if (strEQ(s, "BEGIN")) {
4905 I32 oldscope = PL_scopestack_ix;
4907 SAVECOPFILE(&PL_compiling);
4908 SAVECOPLINE(&PL_compiling);
4910 sv_setsv(PL_rs, PL_nrs);
4913 PL_beginav = newAV();
4914 DEBUG_x( dump_sub(gv) );
4915 av_push(PL_beginav, (SV*)cv);
4916 GvCV(gv) = 0; /* cv has been hijacked */
4917 call_list(oldscope, PL_beginav);
4919 PL_curcop = &PL_compiling;
4920 PL_compiling.op_private = PL_hints;
4923 else if (strEQ(s, "END") && !PL_error_count) {
4926 DEBUG_x( dump_sub(gv) );
4927 av_unshift(PL_endav, 1);
4928 av_store(PL_endav, 0, (SV*)cv);
4929 GvCV(gv) = 0; /* cv has been hijacked */
4931 else if (strEQ(s, "CHECK") && !PL_error_count) {
4933 PL_checkav = newAV();
4934 DEBUG_x( dump_sub(gv) );
4935 if (PL_main_start && ckWARN(WARN_VOID))
4936 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4937 av_unshift(PL_checkav, 1);
4938 av_store(PL_checkav, 0, (SV*)cv);
4939 GvCV(gv) = 0; /* cv has been hijacked */
4941 else if (strEQ(s, "INIT") && !PL_error_count) {
4943 PL_initav = newAV();
4944 DEBUG_x( dump_sub(gv) );
4945 if (PL_main_start && ckWARN(WARN_VOID))
4946 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4947 av_push(PL_initav, (SV*)cv);
4948 GvCV(gv) = 0; /* cv has been hijacked */
4953 PL_copline = NOLINE;
4958 /* XXX unsafe for threads if eval_owner isn't held */
4960 =for apidoc newCONSTSUB
4962 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4963 eligible for inlining at compile-time.
4969 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4975 SAVECOPLINE(PL_curcop);
4976 CopLINE_set(PL_curcop, PL_copline);
4979 PL_hints &= ~HINT_BLOCK_SCOPE;
4982 SAVESPTR(PL_curstash);
4983 SAVECOPSTASH(PL_curcop);
4984 PL_curstash = stash;
4986 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4988 CopSTASH(PL_curcop) = stash;
4992 cv = newXS(name, const_sv_xsub, __FILE__);
4993 CvXSUBANY(cv).any_ptr = sv;
4995 sv_setpv((SV*)cv, ""); /* prototype is "" */
5003 =for apidoc U||newXS
5005 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5011 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5013 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5016 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5018 /* just a cached method */
5022 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5023 /* already defined (or promised) */
5024 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5025 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5026 line_t oldline = CopLINE(PL_curcop);
5027 if (PL_copline != NOLINE)
5028 CopLINE_set(PL_curcop, PL_copline);
5029 Perl_warner(aTHX_ WARN_REDEFINE,
5030 CvCONST(cv) ? "Constant subroutine %s redefined"
5031 : "Subroutine %s redefined"
5033 CopLINE_set(PL_curcop, oldline);
5040 if (cv) /* must reuse cv if autoloaded */
5043 cv = (CV*)NEWSV(1105,0);
5044 sv_upgrade((SV *)cv, SVt_PVCV);
5048 PL_sub_generation++;
5053 New(666, CvMUTEXP(cv), 1, perl_mutex);
5054 MUTEX_INIT(CvMUTEXP(cv));
5056 #endif /* USE_THREADS */
5057 (void)gv_fetchfile(filename);
5058 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5059 an external constant string */
5060 CvXSUB(cv) = subaddr;
5063 char *s = strrchr(name,':');
5069 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5072 if (strEQ(s, "BEGIN")) {
5074 PL_beginav = newAV();
5075 av_push(PL_beginav, (SV*)cv);
5076 GvCV(gv) = 0; /* cv has been hijacked */
5078 else if (strEQ(s, "END")) {
5081 av_unshift(PL_endav, 1);
5082 av_store(PL_endav, 0, (SV*)cv);
5083 GvCV(gv) = 0; /* cv has been hijacked */
5085 else if (strEQ(s, "CHECK")) {
5087 PL_checkav = newAV();
5088 if (PL_main_start && ckWARN(WARN_VOID))
5089 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5090 av_unshift(PL_checkav, 1);
5091 av_store(PL_checkav, 0, (SV*)cv);
5092 GvCV(gv) = 0; /* cv has been hijacked */
5094 else if (strEQ(s, "INIT")) {
5096 PL_initav = newAV();
5097 if (PL_main_start && ckWARN(WARN_VOID))
5098 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5099 av_push(PL_initav, (SV*)cv);
5100 GvCV(gv) = 0; /* cv has been hijacked */
5111 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5120 name = SvPVx(cSVOPo->op_sv, n_a);
5123 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5124 #ifdef GV_UNIQUE_CHECK
5126 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5130 if ((cv = GvFORM(gv))) {
5131 if (ckWARN(WARN_REDEFINE)) {
5132 line_t oldline = CopLINE(PL_curcop);
5134 CopLINE_set(PL_curcop, PL_copline);
5135 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5136 CopLINE_set(PL_curcop, oldline);
5143 CvFILE_set_from_cop(cv, PL_curcop);
5145 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5146 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5147 SvPADTMP_on(PL_curpad[ix]);
5150 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5151 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5152 OpREFCNT_set(CvROOT(cv), 1);
5153 CvSTART(cv) = LINKLIST(CvROOT(cv));
5154 CvROOT(cv)->op_next = 0;
5157 PL_copline = NOLINE;
5162 Perl_newANONLIST(pTHX_ OP *o)
5164 return newUNOP(OP_REFGEN, 0,
5165 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5169 Perl_newANONHASH(pTHX_ OP *o)
5171 return newUNOP(OP_REFGEN, 0,
5172 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5176 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5178 return newANONATTRSUB(floor, proto, Nullop, block);
5182 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5184 return newUNOP(OP_REFGEN, 0,
5185 newSVOP(OP_ANONCODE, 0,
5186 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5190 Perl_oopsAV(pTHX_ OP *o)
5192 switch (o->op_type) {
5194 o->op_type = OP_PADAV;
5195 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5196 return ref(o, OP_RV2AV);
5199 o->op_type = OP_RV2AV;
5200 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5205 if (ckWARN_d(WARN_INTERNAL))
5206 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5213 Perl_oopsHV(pTHX_ OP *o)
5215 switch (o->op_type) {
5218 o->op_type = OP_PADHV;
5219 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5220 return ref(o, OP_RV2HV);
5224 o->op_type = OP_RV2HV;
5225 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5230 if (ckWARN_d(WARN_INTERNAL))
5231 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5238 Perl_newAVREF(pTHX_ OP *o)
5240 if (o->op_type == OP_PADANY) {
5241 o->op_type = OP_PADAV;
5242 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5245 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5246 && ckWARN(WARN_DEPRECATED)) {
5247 Perl_warner(aTHX_ WARN_DEPRECATED,
5248 "Using an array as a reference is deprecated");
5250 return newUNOP(OP_RV2AV, 0, scalar(o));
5254 Perl_newGVREF(pTHX_ I32 type, OP *o)
5256 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5257 return newUNOP(OP_NULL, 0, o);
5258 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5262 Perl_newHVREF(pTHX_ OP *o)
5264 if (o->op_type == OP_PADANY) {
5265 o->op_type = OP_PADHV;
5266 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5269 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5270 && ckWARN(WARN_DEPRECATED)) {
5271 Perl_warner(aTHX_ WARN_DEPRECATED,
5272 "Using a hash as a reference is deprecated");
5274 return newUNOP(OP_RV2HV, 0, scalar(o));
5278 Perl_oopsCV(pTHX_ OP *o)
5280 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5286 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5288 return newUNOP(OP_RV2CV, flags, scalar(o));
5292 Perl_newSVREF(pTHX_ OP *o)
5294 if (o->op_type == OP_PADANY) {
5295 o->op_type = OP_PADSV;
5296 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5299 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5300 o->op_flags |= OPpDONE_SVREF;
5303 return newUNOP(OP_RV2SV, 0, scalar(o));
5306 /* Check routines. */
5309 Perl_ck_anoncode(pTHX_ OP *o)
5314 name = NEWSV(1106,0);
5315 sv_upgrade(name, SVt_PVNV);
5316 sv_setpvn(name, "&", 1);
5319 ix = pad_alloc(o->op_type, SVs_PADMY);
5320 av_store(PL_comppad_name, ix, name);
5321 av_store(PL_comppad, ix, cSVOPo->op_sv);
5322 SvPADMY_on(cSVOPo->op_sv);
5323 cSVOPo->op_sv = Nullsv;
5324 cSVOPo->op_targ = ix;
5329 Perl_ck_bitop(pTHX_ OP *o)
5331 o->op_private = PL_hints;
5336 Perl_ck_concat(pTHX_ OP *o)
5338 if (cUNOPo->op_first->op_type == OP_CONCAT)
5339 o->op_flags |= OPf_STACKED;
5344 Perl_ck_spair(pTHX_ OP *o)
5346 if (o->op_flags & OPf_KIDS) {
5349 OPCODE type = o->op_type;
5350 o = modkids(ck_fun(o), type);
5351 kid = cUNOPo->op_first;
5352 newop = kUNOP->op_first->op_sibling;
5354 (newop->op_sibling ||
5355 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5356 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5357 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5361 op_free(kUNOP->op_first);
5362 kUNOP->op_first = newop;
5364 o->op_ppaddr = PL_ppaddr[++o->op_type];
5369 Perl_ck_delete(pTHX_ OP *o)
5373 if (o->op_flags & OPf_KIDS) {
5374 OP *kid = cUNOPo->op_first;
5375 switch (kid->op_type) {
5377 o->op_flags |= OPf_SPECIAL;
5380 o->op_private |= OPpSLICE;
5383 o->op_flags |= OPf_SPECIAL;
5388 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5389 PL_op_desc[o->op_type]);
5397 Perl_ck_eof(pTHX_ OP *o)
5399 I32 type = o->op_type;
5401 if (o->op_flags & OPf_KIDS) {
5402 if (cLISTOPo->op_first->op_type == OP_STUB) {
5404 o = newUNOP(type, OPf_SPECIAL,
5405 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5413 Perl_ck_eval(pTHX_ OP *o)
5415 PL_hints |= HINT_BLOCK_SCOPE;
5416 if (o->op_flags & OPf_KIDS) {
5417 SVOP *kid = (SVOP*)cUNOPo->op_first;
5420 o->op_flags &= ~OPf_KIDS;
5423 else if (kid->op_type == OP_LINESEQ) {
5426 kid->op_next = o->op_next;
5427 cUNOPo->op_first = 0;
5430 NewOp(1101, enter, 1, LOGOP);
5431 enter->op_type = OP_ENTERTRY;
5432 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5433 enter->op_private = 0;
5435 /* establish postfix order */
5436 enter->op_next = (OP*)enter;
5438 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5439 o->op_type = OP_LEAVETRY;
5440 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5441 enter->op_other = o;
5449 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5451 o->op_targ = (PADOFFSET)PL_hints;
5456 Perl_ck_exit(pTHX_ OP *o)
5459 HV *table = GvHV(PL_hintgv);
5461 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5462 if (svp && *svp && SvTRUE(*svp))
5463 o->op_private |= OPpEXIT_VMSISH;
5470 Perl_ck_exec(pTHX_ OP *o)
5473 if (o->op_flags & OPf_STACKED) {
5475 kid = cUNOPo->op_first->op_sibling;
5476 if (kid->op_type == OP_RV2GV)
5485 Perl_ck_exists(pTHX_ OP *o)
5488 if (o->op_flags & OPf_KIDS) {
5489 OP *kid = cUNOPo->op_first;
5490 if (kid->op_type == OP_ENTERSUB) {
5491 (void) ref(kid, o->op_type);
5492 if (kid->op_type != OP_RV2CV && !PL_error_count)
5493 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5494 PL_op_desc[o->op_type]);
5495 o->op_private |= OPpEXISTS_SUB;
5497 else if (kid->op_type == OP_AELEM)
5498 o->op_flags |= OPf_SPECIAL;
5499 else if (kid->op_type != OP_HELEM)
5500 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5501 PL_op_desc[o->op_type]);
5509 Perl_ck_gvconst(pTHX_ register OP *o)
5511 o = fold_constants(o);
5512 if (o->op_type == OP_CONST)
5519 Perl_ck_rvconst(pTHX_ register OP *o)
5521 SVOP *kid = (SVOP*)cUNOPo->op_first;
5523 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5524 if (kid->op_type == OP_CONST) {
5528 SV *kidsv = kid->op_sv;
5531 /* Is it a constant from cv_const_sv()? */
5532 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5533 SV *rsv = SvRV(kidsv);
5534 int svtype = SvTYPE(rsv);
5535 char *badtype = Nullch;
5537 switch (o->op_type) {
5539 if (svtype > SVt_PVMG)
5540 badtype = "a SCALAR";
5543 if (svtype != SVt_PVAV)
5544 badtype = "an ARRAY";
5547 if (svtype != SVt_PVHV) {
5548 if (svtype == SVt_PVAV) { /* pseudohash? */
5549 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5550 if (ksv && SvROK(*ksv)
5551 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5560 if (svtype != SVt_PVCV)
5565 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5568 name = SvPV(kidsv, n_a);
5569 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5570 char *badthing = Nullch;
5571 switch (o->op_type) {
5573 badthing = "a SCALAR";
5576 badthing = "an ARRAY";
5579 badthing = "a HASH";
5584 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5588 * This is a little tricky. We only want to add the symbol if we
5589 * didn't add it in the lexer. Otherwise we get duplicate strict
5590 * warnings. But if we didn't add it in the lexer, we must at
5591 * least pretend like we wanted to add it even if it existed before,
5592 * or we get possible typo warnings. OPpCONST_ENTERED says
5593 * whether the lexer already added THIS instance of this symbol.
5595 iscv = (o->op_type == OP_RV2CV) * 2;
5597 gv = gv_fetchpv(name,
5598 iscv | !(kid->op_private & OPpCONST_ENTERED),
5601 : o->op_type == OP_RV2SV
5603 : o->op_type == OP_RV2AV
5605 : o->op_type == OP_RV2HV
5608 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5610 kid->op_type = OP_GV;
5611 SvREFCNT_dec(kid->op_sv);
5613 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5614 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5615 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5617 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5619 kid->op_sv = SvREFCNT_inc(gv);
5621 kid->op_private = 0;
5622 kid->op_ppaddr = PL_ppaddr[OP_GV];
5629 Perl_ck_ftst(pTHX_ OP *o)
5631 I32 type = o->op_type;
5633 if (o->op_flags & OPf_REF) {
5636 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5637 SVOP *kid = (SVOP*)cUNOPo->op_first;
5639 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5641 OP *newop = newGVOP(type, OPf_REF,
5642 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5649 if (type == OP_FTTTY)
5650 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5653 o = newUNOP(type, 0, newDEFSVOP());
5659 Perl_ck_fun(pTHX_ OP *o)
5665 int type = o->op_type;
5666 register I32 oa = PL_opargs[type] >> OASHIFT;
5668 if (o->op_flags & OPf_STACKED) {
5669 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5672 return no_fh_allowed(o);
5675 if (o->op_flags & OPf_KIDS) {
5677 tokid = &cLISTOPo->op_first;
5678 kid = cLISTOPo->op_first;
5679 if (kid->op_type == OP_PUSHMARK ||
5680 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5682 tokid = &kid->op_sibling;
5683 kid = kid->op_sibling;
5685 if (!kid && PL_opargs[type] & OA_DEFGV)
5686 *tokid = kid = newDEFSVOP();
5690 sibl = kid->op_sibling;
5693 /* list seen where single (scalar) arg expected? */
5694 if (numargs == 1 && !(oa >> 4)
5695 && kid->op_type == OP_LIST && type != OP_SCALAR)
5697 return too_many_arguments(o,PL_op_desc[type]);
5710 if ((type == OP_PUSH || type == OP_UNSHIFT)
5711 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5712 Perl_warner(aTHX_ WARN_SYNTAX,
5713 "Useless use of %s with no values",
5716 if (kid->op_type == OP_CONST &&
5717 (kid->op_private & OPpCONST_BARE))
5719 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5720 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5721 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5722 if (ckWARN(WARN_DEPRECATED))
5723 Perl_warner(aTHX_ WARN_DEPRECATED,
5724 "Array @%s missing the @ in argument %"IVdf" of %s()",
5725 name, (IV)numargs, PL_op_desc[type]);
5728 kid->op_sibling = sibl;
5731 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5732 bad_type(numargs, "array", PL_op_desc[type], kid);
5736 if (kid->op_type == OP_CONST &&
5737 (kid->op_private & OPpCONST_BARE))
5739 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5740 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5741 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5742 if (ckWARN(WARN_DEPRECATED))
5743 Perl_warner(aTHX_ WARN_DEPRECATED,
5744 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5745 name, (IV)numargs, PL_op_desc[type]);
5748 kid->op_sibling = sibl;
5751 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5752 bad_type(numargs, "hash", PL_op_desc[type], kid);
5757 OP *newop = newUNOP(OP_NULL, 0, kid);
5758 kid->op_sibling = 0;
5760 newop->op_next = newop;
5762 kid->op_sibling = sibl;
5767 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5768 if (kid->op_type == OP_CONST &&
5769 (kid->op_private & OPpCONST_BARE))
5771 OP *newop = newGVOP(OP_GV, 0,
5772 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5777 else if (kid->op_type == OP_READLINE) {
5778 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5779 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5782 I32 flags = OPf_SPECIAL;
5786 /* is this op a FH constructor? */
5787 if (is_handle_constructor(o,numargs)) {
5788 char *name = Nullch;
5792 /* Set a flag to tell rv2gv to vivify
5793 * need to "prove" flag does not mean something
5794 * else already - NI-S 1999/05/07
5797 if (kid->op_type == OP_PADSV) {
5798 SV **namep = av_fetch(PL_comppad_name,
5800 if (namep && *namep)
5801 name = SvPV(*namep, len);
5803 else if (kid->op_type == OP_RV2SV
5804 && kUNOP->op_first->op_type == OP_GV)
5806 GV *gv = cGVOPx_gv(kUNOP->op_first);
5808 len = GvNAMELEN(gv);
5810 else if (kid->op_type == OP_AELEM
5811 || kid->op_type == OP_HELEM)
5813 name = "__ANONIO__";
5819 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5820 namesv = PL_curpad[targ];
5821 (void)SvUPGRADE(namesv, SVt_PV);
5823 sv_setpvn(namesv, "$", 1);
5824 sv_catpvn(namesv, name, len);
5827 kid->op_sibling = 0;
5828 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5829 kid->op_targ = targ;
5830 kid->op_private |= priv;
5832 kid->op_sibling = sibl;
5838 mod(scalar(kid), type);
5842 tokid = &kid->op_sibling;
5843 kid = kid->op_sibling;
5845 o->op_private |= numargs;
5847 return too_many_arguments(o,PL_op_desc[o->op_type]);
5850 else if (PL_opargs[type] & OA_DEFGV) {
5852 return newUNOP(type, 0, newDEFSVOP());
5856 while (oa & OA_OPTIONAL)
5858 if (oa && oa != OA_LIST)
5859 return too_few_arguments(o,PL_op_desc[o->op_type]);
5865 Perl_ck_glob(pTHX_ OP *o)
5870 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5871 append_elem(OP_GLOB, o, newDEFSVOP());
5873 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5874 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5876 #if !defined(PERL_EXTERNAL_GLOB)
5877 /* XXX this can be tightened up and made more failsafe. */
5881 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5883 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5884 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5885 GvCV(gv) = GvCV(glob_gv);
5886 SvREFCNT_inc((SV*)GvCV(gv));
5887 GvIMPORTED_CV_on(gv);
5890 #endif /* PERL_EXTERNAL_GLOB */
5892 if (gv && GvIMPORTED_CV(gv)) {
5893 append_elem(OP_GLOB, o,
5894 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5895 o->op_type = OP_LIST;
5896 o->op_ppaddr = PL_ppaddr[OP_LIST];
5897 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5898 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5899 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5900 append_elem(OP_LIST, o,
5901 scalar(newUNOP(OP_RV2CV, 0,
5902 newGVOP(OP_GV, 0, gv)))));
5903 o = newUNOP(OP_NULL, 0, ck_subr(o));
5904 o->op_targ = OP_GLOB; /* hint at what it used to be */
5907 gv = newGVgen("main");
5909 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5915 Perl_ck_grep(pTHX_ OP *o)
5919 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5921 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5922 NewOp(1101, gwop, 1, LOGOP);
5924 if (o->op_flags & OPf_STACKED) {
5927 kid = cLISTOPo->op_first->op_sibling;
5928 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5931 kid->op_next = (OP*)gwop;
5932 o->op_flags &= ~OPf_STACKED;
5934 kid = cLISTOPo->op_first->op_sibling;
5935 if (type == OP_MAPWHILE)
5942 kid = cLISTOPo->op_first->op_sibling;
5943 if (kid->op_type != OP_NULL)
5944 Perl_croak(aTHX_ "panic: ck_grep");
5945 kid = kUNOP->op_first;
5947 gwop->op_type = type;
5948 gwop->op_ppaddr = PL_ppaddr[type];
5949 gwop->op_first = listkids(o);
5950 gwop->op_flags |= OPf_KIDS;
5951 gwop->op_private = 1;
5952 gwop->op_other = LINKLIST(kid);
5953 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5954 kid->op_next = (OP*)gwop;
5956 kid = cLISTOPo->op_first->op_sibling;
5957 if (!kid || !kid->op_sibling)
5958 return too_few_arguments(o,PL_op_desc[o->op_type]);
5959 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5960 mod(kid, OP_GREPSTART);
5966 Perl_ck_index(pTHX_ OP *o)
5968 if (o->op_flags & OPf_KIDS) {
5969 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5971 kid = kid->op_sibling; /* get past "big" */
5972 if (kid && kid->op_type == OP_CONST)
5973 fbm_compile(((SVOP*)kid)->op_sv, 0);
5979 Perl_ck_lengthconst(pTHX_ OP *o)
5981 /* XXX length optimization goes here */
5986 Perl_ck_lfun(pTHX_ OP *o)
5988 OPCODE type = o->op_type;
5989 return modkids(ck_fun(o), type);
5993 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5995 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5996 switch (cUNOPo->op_first->op_type) {
5998 /* This is needed for
5999 if (defined %stash::)
6000 to work. Do not break Tk.
6002 break; /* Globals via GV can be undef */
6004 case OP_AASSIGN: /* Is this a good idea? */
6005 Perl_warner(aTHX_ WARN_DEPRECATED,
6006 "defined(@array) is deprecated");
6007 Perl_warner(aTHX_ WARN_DEPRECATED,
6008 "\t(Maybe you should just omit the defined()?)\n");
6011 /* This is needed for
6012 if (defined %stash::)
6013 to work. Do not break Tk.
6015 break; /* Globals via GV can be undef */
6017 Perl_warner(aTHX_ WARN_DEPRECATED,
6018 "defined(%%hash) is deprecated");
6019 Perl_warner(aTHX_ WARN_DEPRECATED,
6020 "\t(Maybe you should just omit the defined()?)\n");
6031 Perl_ck_rfun(pTHX_ OP *o)
6033 OPCODE type = o->op_type;
6034 return refkids(ck_fun(o), type);
6038 Perl_ck_listiob(pTHX_ OP *o)
6042 kid = cLISTOPo->op_first;
6045 kid = cLISTOPo->op_first;
6047 if (kid->op_type == OP_PUSHMARK)
6048 kid = kid->op_sibling;
6049 if (kid && o->op_flags & OPf_STACKED)
6050 kid = kid->op_sibling;
6051 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6052 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6053 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6054 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6055 cLISTOPo->op_first->op_sibling = kid;
6056 cLISTOPo->op_last = kid;
6057 kid = kid->op_sibling;
6062 append_elem(o->op_type, o, newDEFSVOP());
6068 Perl_ck_sassign(pTHX_ OP *o)
6070 OP *kid = cLISTOPo->op_first;
6071 /* has a disposable target? */
6072 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6073 && !(kid->op_flags & OPf_STACKED)
6074 /* Cannot steal the second time! */
6075 && !(kid->op_private & OPpTARGET_MY))
6077 OP *kkid = kid->op_sibling;
6079 /* Can just relocate the target. */
6080 if (kkid && kkid->op_type == OP_PADSV
6081 && !(kkid->op_private & OPpLVAL_INTRO))
6083 kid->op_targ = kkid->op_targ;
6085 /* Now we do not need PADSV and SASSIGN. */
6086 kid->op_sibling = o->op_sibling; /* NULL */
6087 cLISTOPo->op_first = NULL;
6090 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6098 Perl_ck_match(pTHX_ OP *o)
6100 o->op_private |= OPpRUNTIME;
6105 Perl_ck_method(pTHX_ OP *o)
6107 OP *kid = cUNOPo->op_first;
6108 if (kid->op_type == OP_CONST) {
6109 SV* sv = kSVOP->op_sv;
6110 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6112 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6113 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6116 kSVOP->op_sv = Nullsv;
6118 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6127 Perl_ck_null(pTHX_ OP *o)
6133 Perl_ck_open(pTHX_ OP *o)
6135 HV *table = GvHV(PL_hintgv);
6139 svp = hv_fetch(table, "open_IN", 7, FALSE);
6141 mode = mode_from_discipline(*svp);
6142 if (mode & O_BINARY)
6143 o->op_private |= OPpOPEN_IN_RAW;
6144 else if (mode & O_TEXT)
6145 o->op_private |= OPpOPEN_IN_CRLF;
6148 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6150 mode = mode_from_discipline(*svp);
6151 if (mode & O_BINARY)
6152 o->op_private |= OPpOPEN_OUT_RAW;
6153 else if (mode & O_TEXT)
6154 o->op_private |= OPpOPEN_OUT_CRLF;
6157 if (o->op_type == OP_BACKTICK)
6163 Perl_ck_repeat(pTHX_ OP *o)
6165 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6166 o->op_private |= OPpREPEAT_DOLIST;
6167 cBINOPo->op_first = force_list(cBINOPo->op_first);
6175 Perl_ck_require(pTHX_ OP *o)
6179 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6180 SVOP *kid = (SVOP*)cUNOPo->op_first;
6182 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6184 for (s = SvPVX(kid->op_sv); *s; s++) {
6185 if (*s == ':' && s[1] == ':') {
6187 Move(s+2, s+1, strlen(s+2)+1, char);
6188 --SvCUR(kid->op_sv);
6191 if (SvREADONLY(kid->op_sv)) {
6192 SvREADONLY_off(kid->op_sv);
6193 sv_catpvn(kid->op_sv, ".pm", 3);
6194 SvREADONLY_on(kid->op_sv);
6197 sv_catpvn(kid->op_sv, ".pm", 3);
6201 /* handle override, if any */
6202 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6203 if (!(gv && GvIMPORTED_CV(gv)))
6204 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6206 if (gv && GvIMPORTED_CV(gv)) {
6207 OP *kid = cUNOPo->op_first;
6208 cUNOPo->op_first = 0;
6210 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6211 append_elem(OP_LIST, kid,
6212 scalar(newUNOP(OP_RV2CV, 0,
6221 Perl_ck_return(pTHX_ OP *o)
6224 if (CvLVALUE(PL_compcv)) {
6225 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6226 mod(kid, OP_LEAVESUBLV);
6233 Perl_ck_retarget(pTHX_ OP *o)
6235 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6242 Perl_ck_select(pTHX_ OP *o)
6245 if (o->op_flags & OPf_KIDS) {
6246 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6247 if (kid && kid->op_sibling) {
6248 o->op_type = OP_SSELECT;
6249 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6251 return fold_constants(o);
6255 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6256 if (kid && kid->op_type == OP_RV2GV)
6257 kid->op_private &= ~HINT_STRICT_REFS;
6262 Perl_ck_shift(pTHX_ OP *o)
6264 I32 type = o->op_type;
6266 if (!(o->op_flags & OPf_KIDS)) {
6271 if (!CvUNIQUE(PL_compcv)) {
6272 argop = newOP(OP_PADAV, OPf_REF);
6273 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6276 argop = newUNOP(OP_RV2AV, 0,
6277 scalar(newGVOP(OP_GV, 0,
6278 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6281 argop = newUNOP(OP_RV2AV, 0,
6282 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6283 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6284 #endif /* USE_THREADS */
6285 return newUNOP(type, 0, scalar(argop));
6287 return scalar(modkids(ck_fun(o), type));
6291 Perl_ck_sort(pTHX_ OP *o)
6295 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6297 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6298 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6300 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6302 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6304 if (kid->op_type == OP_SCOPE) {
6308 else if (kid->op_type == OP_LEAVE) {
6309 if (o->op_type == OP_SORT) {
6310 op_null(kid); /* wipe out leave */
6313 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6314 if (k->op_next == kid)
6316 /* don't descend into loops */
6317 else if (k->op_type == OP_ENTERLOOP
6318 || k->op_type == OP_ENTERITER)
6320 k = cLOOPx(k)->op_lastop;
6325 kid->op_next = 0; /* just disconnect the leave */
6326 k = kLISTOP->op_first;
6331 if (o->op_type == OP_SORT) {
6332 /* provide scalar context for comparison function/block */
6338 o->op_flags |= OPf_SPECIAL;
6340 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6343 firstkid = firstkid->op_sibling;
6346 /* provide list context for arguments */
6347 if (o->op_type == OP_SORT)
6354 S_simplify_sort(pTHX_ OP *o)
6356 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6360 if (!(o->op_flags & OPf_STACKED))
6362 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6363 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6364 kid = kUNOP->op_first; /* get past null */
6365 if (kid->op_type != OP_SCOPE)
6367 kid = kLISTOP->op_last; /* get past scope */
6368 switch(kid->op_type) {
6376 k = kid; /* remember this node*/
6377 if (kBINOP->op_first->op_type != OP_RV2SV)
6379 kid = kBINOP->op_first; /* get past cmp */
6380 if (kUNOP->op_first->op_type != OP_GV)
6382 kid = kUNOP->op_first; /* get past rv2sv */
6384 if (GvSTASH(gv) != PL_curstash)
6386 if (strEQ(GvNAME(gv), "a"))
6388 else if (strEQ(GvNAME(gv), "b"))
6392 kid = k; /* back to cmp */
6393 if (kBINOP->op_last->op_type != OP_RV2SV)
6395 kid = kBINOP->op_last; /* down to 2nd arg */
6396 if (kUNOP->op_first->op_type != OP_GV)
6398 kid = kUNOP->op_first; /* get past rv2sv */
6400 if (GvSTASH(gv) != PL_curstash
6402 ? strNE(GvNAME(gv), "a")
6403 : strNE(GvNAME(gv), "b")))
6405 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6407 o->op_private |= OPpSORT_REVERSE;
6408 if (k->op_type == OP_NCMP)
6409 o->op_private |= OPpSORT_NUMERIC;
6410 if (k->op_type == OP_I_NCMP)
6411 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6412 kid = cLISTOPo->op_first->op_sibling;
6413 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6414 op_free(kid); /* then delete it */
6418 Perl_ck_split(pTHX_ OP *o)
6422 if (o->op_flags & OPf_STACKED)
6423 return no_fh_allowed(o);
6425 kid = cLISTOPo->op_first;
6426 if (kid->op_type != OP_NULL)
6427 Perl_croak(aTHX_ "panic: ck_split");
6428 kid = kid->op_sibling;
6429 op_free(cLISTOPo->op_first);
6430 cLISTOPo->op_first = kid;
6432 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6433 cLISTOPo->op_last = kid; /* There was only one element previously */
6436 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6437 OP *sibl = kid->op_sibling;
6438 kid->op_sibling = 0;
6439 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6440 if (cLISTOPo->op_first == cLISTOPo->op_last)
6441 cLISTOPo->op_last = kid;
6442 cLISTOPo->op_first = kid;
6443 kid->op_sibling = sibl;
6446 kid->op_type = OP_PUSHRE;
6447 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6450 if (!kid->op_sibling)
6451 append_elem(OP_SPLIT, o, newDEFSVOP());
6453 kid = kid->op_sibling;
6456 if (!kid->op_sibling)
6457 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6459 kid = kid->op_sibling;
6462 if (kid->op_sibling)
6463 return too_many_arguments(o,PL_op_desc[o->op_type]);
6469 Perl_ck_join(pTHX_ OP *o)
6471 if (ckWARN(WARN_SYNTAX)) {
6472 OP *kid = cLISTOPo->op_first->op_sibling;
6473 if (kid && kid->op_type == OP_MATCH) {
6474 char *pmstr = "STRING";
6475 if (PM_GETRE(kPMOP))
6476 pmstr = PM_GETRE(kPMOP)->precomp;
6477 Perl_warner(aTHX_ WARN_SYNTAX,
6478 "/%s/ should probably be written as \"%s\"",
6486 Perl_ck_subr(pTHX_ OP *o)
6488 OP *prev = ((cUNOPo->op_first->op_sibling)
6489 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6490 OP *o2 = prev->op_sibling;
6499 o->op_private |= OPpENTERSUB_HASTARG;
6500 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6501 if (cvop->op_type == OP_RV2CV) {
6503 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6504 op_null(cvop); /* disable rv2cv */
6505 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6506 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6507 GV *gv = cGVOPx_gv(tmpop);
6510 tmpop->op_private |= OPpEARLY_CV;
6511 else if (SvPOK(cv)) {
6512 namegv = CvANON(cv) ? gv : CvGV(cv);
6513 proto = SvPV((SV*)cv, n_a);
6517 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6518 if (o2->op_type == OP_CONST)
6519 o2->op_private &= ~OPpCONST_STRICT;
6520 else if (o2->op_type == OP_LIST) {
6521 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6522 if (o && o->op_type == OP_CONST)
6523 o->op_private &= ~OPpCONST_STRICT;
6526 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6527 if (PERLDB_SUB && PL_curstash != PL_debstash)
6528 o->op_private |= OPpENTERSUB_DB;
6529 while (o2 != cvop) {
6533 return too_many_arguments(o, gv_ename(namegv));
6551 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6553 arg == 1 ? "block or sub {}" : "sub {}",
6554 gv_ename(namegv), o2);
6557 /* '*' allows any scalar type, including bareword */
6560 if (o2->op_type == OP_RV2GV)
6561 goto wrapref; /* autoconvert GLOB -> GLOBref */
6562 else if (o2->op_type == OP_CONST)
6563 o2->op_private &= ~OPpCONST_STRICT;
6564 else if (o2->op_type == OP_ENTERSUB) {
6565 /* accidental subroutine, revert to bareword */
6566 OP *gvop = ((UNOP*)o2)->op_first;
6567 if (gvop && gvop->op_type == OP_NULL) {
6568 gvop = ((UNOP*)gvop)->op_first;
6570 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6573 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6574 (gvop = ((UNOP*)gvop)->op_first) &&
6575 gvop->op_type == OP_GV)
6577 GV *gv = cGVOPx_gv(gvop);
6578 OP *sibling = o2->op_sibling;
6579 SV *n = newSVpvn("",0);
6581 gv_fullname3(n, gv, "");
6582 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6583 sv_chop(n, SvPVX(n)+6);
6584 o2 = newSVOP(OP_CONST, 0, n);
6585 prev->op_sibling = o2;
6586 o2->op_sibling = sibling;
6598 if (o2->op_type != OP_RV2GV)
6599 bad_type(arg, "symbol", gv_ename(namegv), o2);
6602 if (o2->op_type != OP_ENTERSUB)
6603 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6606 if (o2->op_type != OP_RV2SV
6607 && o2->op_type != OP_PADSV
6608 && o2->op_type != OP_HELEM
6609 && o2->op_type != OP_AELEM
6610 && o2->op_type != OP_THREADSV)
6612 bad_type(arg, "scalar", gv_ename(namegv), o2);
6616 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6617 bad_type(arg, "array", gv_ename(namegv), o2);
6620 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6621 bad_type(arg, "hash", gv_ename(namegv), o2);
6625 OP* sib = kid->op_sibling;
6626 kid->op_sibling = 0;
6627 o2 = newUNOP(OP_REFGEN, 0, kid);
6628 o2->op_sibling = sib;
6629 prev->op_sibling = o2;
6640 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6641 gv_ename(namegv), SvPV((SV*)cv, n_a));
6646 mod(o2, OP_ENTERSUB);
6648 o2 = o2->op_sibling;
6650 if (proto && !optional &&
6651 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6652 return too_few_arguments(o, gv_ename(namegv));
6657 Perl_ck_svconst(pTHX_ OP *o)
6659 SvREADONLY_on(cSVOPo->op_sv);
6664 Perl_ck_trunc(pTHX_ OP *o)
6666 if (o->op_flags & OPf_KIDS) {
6667 SVOP *kid = (SVOP*)cUNOPo->op_first;
6669 if (kid->op_type == OP_NULL)
6670 kid = (SVOP*)kid->op_sibling;
6671 if (kid && kid->op_type == OP_CONST &&
6672 (kid->op_private & OPpCONST_BARE))
6674 o->op_flags |= OPf_SPECIAL;
6675 kid->op_private &= ~OPpCONST_STRICT;
6682 Perl_ck_substr(pTHX_ OP *o)
6685 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6686 OP *kid = cLISTOPo->op_first;
6688 if (kid->op_type == OP_NULL)
6689 kid = kid->op_sibling;
6691 kid->op_flags |= OPf_MOD;
6697 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6700 Perl_peep(pTHX_ register OP *o)
6702 register OP* oldop = 0;
6705 if (!o || o->op_seq)
6709 SAVEVPTR(PL_curcop);
6710 for (; o; o = o->op_next) {
6716 switch (o->op_type) {
6720 PL_curcop = ((COP*)o); /* for warnings */
6721 o->op_seq = PL_op_seqmax++;
6725 if (cSVOPo->op_private & OPpCONST_STRICT)
6726 no_bareword_allowed(o);
6728 /* Relocate sv to the pad for thread safety.
6729 * Despite being a "constant", the SV is written to,
6730 * for reference counts, sv_upgrade() etc. */
6732 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6733 if (SvPADTMP(cSVOPo->op_sv)) {
6734 /* If op_sv is already a PADTMP then it is being used by
6735 * some pad, so make a copy. */
6736 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6737 SvREADONLY_on(PL_curpad[ix]);
6738 SvREFCNT_dec(cSVOPo->op_sv);
6741 SvREFCNT_dec(PL_curpad[ix]);
6742 SvPADTMP_on(cSVOPo->op_sv);
6743 PL_curpad[ix] = cSVOPo->op_sv;
6744 /* XXX I don't know how this isn't readonly already. */
6745 SvREADONLY_on(PL_curpad[ix]);
6747 cSVOPo->op_sv = Nullsv;
6751 o->op_seq = PL_op_seqmax++;
6755 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6756 if (o->op_next->op_private & OPpTARGET_MY) {
6757 if (o->op_flags & OPf_STACKED) /* chained concats */
6758 goto ignore_optimization;
6760 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6761 o->op_targ = o->op_next->op_targ;
6762 o->op_next->op_targ = 0;
6763 o->op_private |= OPpTARGET_MY;
6766 op_null(o->op_next);
6768 ignore_optimization:
6769 o->op_seq = PL_op_seqmax++;
6772 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6773 o->op_seq = PL_op_seqmax++;
6774 break; /* Scalar stub must produce undef. List stub is noop */
6778 if (o->op_targ == OP_NEXTSTATE
6779 || o->op_targ == OP_DBSTATE
6780 || o->op_targ == OP_SETSTATE)
6782 PL_curcop = ((COP*)o);
6784 /* XXX: We avoid setting op_seq here to prevent later calls
6785 to peep() from mistakenly concluding that optimisation
6786 has already occurred. This doesn't fix the real problem,
6787 though (See 20010220.007). AMS 20010719 */
6788 if (oldop && o->op_next) {
6789 oldop->op_next = o->op_next;
6797 if (oldop && o->op_next) {
6798 oldop->op_next = o->op_next;
6801 o->op_seq = PL_op_seqmax++;
6805 if (o->op_next->op_type == OP_RV2SV) {
6806 if (!(o->op_next->op_private & OPpDEREF)) {
6807 op_null(o->op_next);
6808 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6810 o->op_next = o->op_next->op_next;
6811 o->op_type = OP_GVSV;
6812 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6815 else if (o->op_next->op_type == OP_RV2AV) {
6816 OP* pop = o->op_next->op_next;
6818 if (pop->op_type == OP_CONST &&
6819 (PL_op = pop->op_next) &&
6820 pop->op_next->op_type == OP_AELEM &&
6821 !(pop->op_next->op_private &
6822 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6823 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6828 op_null(o->op_next);
6829 op_null(pop->op_next);
6831 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6832 o->op_next = pop->op_next->op_next;
6833 o->op_type = OP_AELEMFAST;
6834 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6835 o->op_private = (U8)i;
6840 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6842 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6843 /* XXX could check prototype here instead of just carping */
6844 SV *sv = sv_newmortal();
6845 gv_efullname3(sv, gv, Nullch);
6846 Perl_warner(aTHX_ WARN_PROTOTYPE,
6847 "%s() called too early to check prototype",
6852 o->op_seq = PL_op_seqmax++;
6863 o->op_seq = PL_op_seqmax++;
6864 while (cLOGOP->op_other->op_type == OP_NULL)
6865 cLOGOP->op_other = cLOGOP->op_other->op_next;
6866 peep(cLOGOP->op_other);
6871 o->op_seq = PL_op_seqmax++;
6872 while (cLOOP->op_redoop->op_type == OP_NULL)
6873 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6874 peep(cLOOP->op_redoop);
6875 while (cLOOP->op_nextop->op_type == OP_NULL)
6876 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6877 peep(cLOOP->op_nextop);
6878 while (cLOOP->op_lastop->op_type == OP_NULL)
6879 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6880 peep(cLOOP->op_lastop);
6886 o->op_seq = PL_op_seqmax++;
6887 while (cPMOP->op_pmreplstart &&
6888 cPMOP->op_pmreplstart->op_type == OP_NULL)
6889 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6890 peep(cPMOP->op_pmreplstart);
6894 o->op_seq = PL_op_seqmax++;
6895 if (ckWARN(WARN_SYNTAX) && o->op_next
6896 && o->op_next->op_type == OP_NEXTSTATE) {
6897 if (o->op_next->op_sibling &&
6898 o->op_next->op_sibling->op_type != OP_EXIT &&
6899 o->op_next->op_sibling->op_type != OP_WARN &&
6900 o->op_next->op_sibling->op_type != OP_DIE) {
6901 line_t oldline = CopLINE(PL_curcop);
6903 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6904 Perl_warner(aTHX_ WARN_EXEC,
6905 "Statement unlikely to be reached");
6906 Perl_warner(aTHX_ WARN_EXEC,
6907 "\t(Maybe you meant system() when you said exec()?)\n");
6908 CopLINE_set(PL_curcop, oldline);
6917 SV **svp, **indsvp, *sv;
6922 o->op_seq = PL_op_seqmax++;
6924 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6927 /* Make the CONST have a shared SV */
6928 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6929 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6930 key = SvPV(sv, keylen);
6931 lexname = newSVpvn_share(key,
6932 SvUTF8(sv) ? -(I32)keylen : keylen,
6938 if ((o->op_private & (OPpLVAL_INTRO)))
6941 rop = (UNOP*)((BINOP*)o)->op_first;
6942 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6944 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6945 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6947 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6948 if (!fields || !GvHV(*fields))
6950 key = SvPV(*svp, keylen);
6951 indsvp = hv_fetch(GvHV(*fields), key,
6952 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6954 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6955 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6957 ind = SvIV(*indsvp);
6959 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6960 rop->op_type = OP_RV2AV;
6961 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6962 o->op_type = OP_AELEM;
6963 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6965 if (SvREADONLY(*svp))
6967 SvFLAGS(sv) |= (SvFLAGS(*svp)
6968 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6978 SV **svp, **indsvp, *sv;
6982 SVOP *first_key_op, *key_op;
6984 o->op_seq = PL_op_seqmax++;
6985 if ((o->op_private & (OPpLVAL_INTRO))
6986 /* I bet there's always a pushmark... */
6987 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6988 /* hmmm, no optimization if list contains only one key. */
6990 rop = (UNOP*)((LISTOP*)o)->op_last;
6991 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6993 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6994 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6996 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6997 if (!fields || !GvHV(*fields))
6999 /* Again guessing that the pushmark can be jumped over.... */
7000 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7001 ->op_first->op_sibling;
7002 /* Check that the key list contains only constants. */
7003 for (key_op = first_key_op; key_op;
7004 key_op = (SVOP*)key_op->op_sibling)
7005 if (key_op->op_type != OP_CONST)
7009 rop->op_type = OP_RV2AV;
7010 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7011 o->op_type = OP_ASLICE;
7012 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7013 for (key_op = first_key_op; key_op;
7014 key_op = (SVOP*)key_op->op_sibling) {
7015 svp = cSVOPx_svp(key_op);
7016 key = SvPV(*svp, keylen);
7017 indsvp = hv_fetch(GvHV(*fields), key,
7018 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7020 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7021 "in variable %s of type %s",
7022 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7024 ind = SvIV(*indsvp);
7026 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7028 if (SvREADONLY(*svp))
7030 SvFLAGS(sv) |= (SvFLAGS(*svp)
7031 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7039 o->op_seq = PL_op_seqmax++;
7049 /* Efficient sub that returns a constant scalar value. */
7051 const_sv_xsub(pTHXo_ CV* cv)
7056 Perl_croak(aTHX_ "usage: %s::%s()",
7057 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7061 ST(0) = (SV*)XSANY.any_ptr;