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,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);
4759 PL_sub_generation++;
4763 CvFILE_set_from_cop(cv, PL_curcop);
4764 CvSTASH(cv) = PL_curstash;
4767 if (!CvMUTEXP(cv)) {
4768 New(666, CvMUTEXP(cv), 1, perl_mutex);
4769 MUTEX_INIT(CvMUTEXP(cv));
4771 #endif /* USE_THREADS */
4774 sv_setpv((SV*)cv, ps);
4776 if (PL_error_count) {
4780 char *s = strrchr(name, ':');
4782 if (strEQ(s, "BEGIN")) {
4784 "BEGIN not safe after errors--compilation aborted";
4785 if (PL_in_eval & EVAL_KEEPERR)
4786 Perl_croak(aTHX_ not_safe);
4788 /* force display of errors found but not reported */
4789 sv_catpv(ERRSV, not_safe);
4790 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4798 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4799 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4802 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4803 mod(scalarseq(block), OP_LEAVESUBLV));
4806 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4808 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4809 OpREFCNT_set(CvROOT(cv), 1);
4810 CvSTART(cv) = LINKLIST(CvROOT(cv));
4811 CvROOT(cv)->op_next = 0;
4814 /* now that optimizer has done its work, adjust pad values */
4816 SV **namep = AvARRAY(PL_comppad_name);
4817 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4820 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4823 * The only things that a clonable function needs in its
4824 * pad are references to outer lexicals and anonymous subs.
4825 * The rest are created anew during cloning.
4827 if (!((namesv = namep[ix]) != Nullsv &&
4828 namesv != &PL_sv_undef &&
4830 *SvPVX(namesv) == '&')))
4832 SvREFCNT_dec(PL_curpad[ix]);
4833 PL_curpad[ix] = Nullsv;
4836 assert(!CvCONST(cv));
4837 if (ps && !*ps && op_const_sv(block, cv))
4841 AV *av = newAV(); /* Will be @_ */
4843 av_store(PL_comppad, 0, (SV*)av);
4844 AvFLAGS(av) = AVf_REIFY;
4846 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4847 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4849 if (!SvPADMY(PL_curpad[ix]))
4850 SvPADTMP_on(PL_curpad[ix]);
4854 /* If a potential closure prototype, don't keep a refcount on
4855 * outer CV, unless the latter happens to be a passing eval"".
4856 * This is okay as the lifetime of the prototype is tied to the
4857 * lifetime of the outer CV. Avoids memory leak due to reference
4859 if (!name && CvOUTSIDE(cv)
4860 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4861 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4863 SvREFCNT_dec(CvOUTSIDE(cv));
4866 if (name || aname) {
4868 char *tname = (name ? name : aname);
4870 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4871 SV *sv = NEWSV(0,0);
4872 SV *tmpstr = sv_newmortal();
4873 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4877 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4879 (long)PL_subline, (long)CopLINE(PL_curcop));
4880 gv_efullname3(tmpstr, gv, Nullch);
4881 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4882 hv = GvHVn(db_postponed);
4883 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4884 && (pcv = GvCV(db_postponed)))
4890 call_sv((SV*)pcv, G_DISCARD);
4894 if ((s = strrchr(tname,':')))
4899 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4902 if (strEQ(s, "BEGIN")) {
4903 I32 oldscope = PL_scopestack_ix;
4905 SAVECOPFILE(&PL_compiling);
4906 SAVECOPLINE(&PL_compiling);
4908 sv_setsv(PL_rs, PL_nrs);
4911 PL_beginav = newAV();
4912 DEBUG_x( dump_sub(gv) );
4913 av_push(PL_beginav, (SV*)cv);
4914 GvCV(gv) = 0; /* cv has been hijacked */
4915 call_list(oldscope, PL_beginav);
4917 PL_curcop = &PL_compiling;
4918 PL_compiling.op_private = PL_hints;
4921 else if (strEQ(s, "END") && !PL_error_count) {
4924 DEBUG_x( dump_sub(gv) );
4925 av_unshift(PL_endav, 1);
4926 av_store(PL_endav, 0, (SV*)cv);
4927 GvCV(gv) = 0; /* cv has been hijacked */
4929 else if (strEQ(s, "CHECK") && !PL_error_count) {
4931 PL_checkav = newAV();
4932 DEBUG_x( dump_sub(gv) );
4933 if (PL_main_start && ckWARN(WARN_VOID))
4934 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4935 av_unshift(PL_checkav, 1);
4936 av_store(PL_checkav, 0, (SV*)cv);
4937 GvCV(gv) = 0; /* cv has been hijacked */
4939 else if (strEQ(s, "INIT") && !PL_error_count) {
4941 PL_initav = newAV();
4942 DEBUG_x( dump_sub(gv) );
4943 if (PL_main_start && ckWARN(WARN_VOID))
4944 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4945 av_push(PL_initav, (SV*)cv);
4946 GvCV(gv) = 0; /* cv has been hijacked */
4951 PL_copline = NOLINE;
4956 /* XXX unsafe for threads if eval_owner isn't held */
4958 =for apidoc newCONSTSUB
4960 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4961 eligible for inlining at compile-time.
4967 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4973 SAVECOPLINE(PL_curcop);
4974 CopLINE_set(PL_curcop, PL_copline);
4977 PL_hints &= ~HINT_BLOCK_SCOPE;
4980 SAVESPTR(PL_curstash);
4981 SAVECOPSTASH(PL_curcop);
4982 PL_curstash = stash;
4984 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4986 CopSTASH(PL_curcop) = stash;
4990 cv = newXS(name, const_sv_xsub, __FILE__);
4991 CvXSUBANY(cv).any_ptr = sv;
4993 sv_setpv((SV*)cv, ""); /* prototype is "" */
5001 =for apidoc U||newXS
5003 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5009 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5011 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5014 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5016 /* just a cached method */
5020 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5021 /* already defined (or promised) */
5022 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5023 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5024 line_t oldline = CopLINE(PL_curcop);
5025 if (PL_copline != NOLINE)
5026 CopLINE_set(PL_curcop, PL_copline);
5027 Perl_warner(aTHX_ WARN_REDEFINE,
5028 CvCONST(cv) ? "Constant subroutine %s redefined"
5029 : "Subroutine %s redefined"
5031 CopLINE_set(PL_curcop, oldline);
5038 if (cv) /* must reuse cv if autoloaded */
5041 cv = (CV*)NEWSV(1105,0);
5042 sv_upgrade((SV *)cv, SVt_PVCV);
5046 PL_sub_generation++;
5051 New(666, CvMUTEXP(cv), 1, perl_mutex);
5052 MUTEX_INIT(CvMUTEXP(cv));
5054 #endif /* USE_THREADS */
5055 (void)gv_fetchfile(filename);
5056 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5057 an external constant string */
5058 CvXSUB(cv) = subaddr;
5061 char *s = strrchr(name,':');
5067 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5070 if (strEQ(s, "BEGIN")) {
5072 PL_beginav = newAV();
5073 av_push(PL_beginav, (SV*)cv);
5074 GvCV(gv) = 0; /* cv has been hijacked */
5076 else if (strEQ(s, "END")) {
5079 av_unshift(PL_endav, 1);
5080 av_store(PL_endav, 0, (SV*)cv);
5081 GvCV(gv) = 0; /* cv has been hijacked */
5083 else if (strEQ(s, "CHECK")) {
5085 PL_checkav = newAV();
5086 if (PL_main_start && ckWARN(WARN_VOID))
5087 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5088 av_unshift(PL_checkav, 1);
5089 av_store(PL_checkav, 0, (SV*)cv);
5090 GvCV(gv) = 0; /* cv has been hijacked */
5092 else if (strEQ(s, "INIT")) {
5094 PL_initav = newAV();
5095 if (PL_main_start && ckWARN(WARN_VOID))
5096 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5097 av_push(PL_initav, (SV*)cv);
5098 GvCV(gv) = 0; /* cv has been hijacked */
5109 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5118 name = SvPVx(cSVOPo->op_sv, n_a);
5121 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5122 #ifdef GV_UNIQUE_CHECK
5124 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5128 if ((cv = GvFORM(gv))) {
5129 if (ckWARN(WARN_REDEFINE)) {
5130 line_t oldline = CopLINE(PL_curcop);
5132 CopLINE_set(PL_curcop, PL_copline);
5133 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5134 CopLINE_set(PL_curcop, oldline);
5141 CvFILE_set_from_cop(cv, PL_curcop);
5143 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5144 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5145 SvPADTMP_on(PL_curpad[ix]);
5148 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5149 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5150 OpREFCNT_set(CvROOT(cv), 1);
5151 CvSTART(cv) = LINKLIST(CvROOT(cv));
5152 CvROOT(cv)->op_next = 0;
5155 PL_copline = NOLINE;
5160 Perl_newANONLIST(pTHX_ OP *o)
5162 return newUNOP(OP_REFGEN, 0,
5163 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5167 Perl_newANONHASH(pTHX_ OP *o)
5169 return newUNOP(OP_REFGEN, 0,
5170 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5174 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5176 return newANONATTRSUB(floor, proto, Nullop, block);
5180 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5182 return newUNOP(OP_REFGEN, 0,
5183 newSVOP(OP_ANONCODE, 0,
5184 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5188 Perl_oopsAV(pTHX_ OP *o)
5190 switch (o->op_type) {
5192 o->op_type = OP_PADAV;
5193 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5194 return ref(o, OP_RV2AV);
5197 o->op_type = OP_RV2AV;
5198 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5203 if (ckWARN_d(WARN_INTERNAL))
5204 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5211 Perl_oopsHV(pTHX_ OP *o)
5213 switch (o->op_type) {
5216 o->op_type = OP_PADHV;
5217 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5218 return ref(o, OP_RV2HV);
5222 o->op_type = OP_RV2HV;
5223 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5228 if (ckWARN_d(WARN_INTERNAL))
5229 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5236 Perl_newAVREF(pTHX_ OP *o)
5238 if (o->op_type == OP_PADANY) {
5239 o->op_type = OP_PADAV;
5240 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5243 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5244 && ckWARN(WARN_DEPRECATED)) {
5245 Perl_warner(aTHX_ WARN_DEPRECATED,
5246 "Using an array as a reference is deprecated");
5248 return newUNOP(OP_RV2AV, 0, scalar(o));
5252 Perl_newGVREF(pTHX_ I32 type, OP *o)
5254 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5255 return newUNOP(OP_NULL, 0, o);
5256 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5260 Perl_newHVREF(pTHX_ OP *o)
5262 if (o->op_type == OP_PADANY) {
5263 o->op_type = OP_PADHV;
5264 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5267 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5268 && ckWARN(WARN_DEPRECATED)) {
5269 Perl_warner(aTHX_ WARN_DEPRECATED,
5270 "Using a hash as a reference is deprecated");
5272 return newUNOP(OP_RV2HV, 0, scalar(o));
5276 Perl_oopsCV(pTHX_ OP *o)
5278 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5284 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5286 return newUNOP(OP_RV2CV, flags, scalar(o));
5290 Perl_newSVREF(pTHX_ OP *o)
5292 if (o->op_type == OP_PADANY) {
5293 o->op_type = OP_PADSV;
5294 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5297 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5298 o->op_flags |= OPpDONE_SVREF;
5301 return newUNOP(OP_RV2SV, 0, scalar(o));
5304 /* Check routines. */
5307 Perl_ck_anoncode(pTHX_ OP *o)
5312 name = NEWSV(1106,0);
5313 sv_upgrade(name, SVt_PVNV);
5314 sv_setpvn(name, "&", 1);
5317 ix = pad_alloc(o->op_type, SVs_PADMY);
5318 av_store(PL_comppad_name, ix, name);
5319 av_store(PL_comppad, ix, cSVOPo->op_sv);
5320 SvPADMY_on(cSVOPo->op_sv);
5321 cSVOPo->op_sv = Nullsv;
5322 cSVOPo->op_targ = ix;
5327 Perl_ck_bitop(pTHX_ OP *o)
5329 o->op_private = PL_hints;
5334 Perl_ck_concat(pTHX_ OP *o)
5336 if (cUNOPo->op_first->op_type == OP_CONCAT)
5337 o->op_flags |= OPf_STACKED;
5342 Perl_ck_spair(pTHX_ OP *o)
5344 if (o->op_flags & OPf_KIDS) {
5347 OPCODE type = o->op_type;
5348 o = modkids(ck_fun(o), type);
5349 kid = cUNOPo->op_first;
5350 newop = kUNOP->op_first->op_sibling;
5352 (newop->op_sibling ||
5353 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5354 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5355 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5359 op_free(kUNOP->op_first);
5360 kUNOP->op_first = newop;
5362 o->op_ppaddr = PL_ppaddr[++o->op_type];
5367 Perl_ck_delete(pTHX_ OP *o)
5371 if (o->op_flags & OPf_KIDS) {
5372 OP *kid = cUNOPo->op_first;
5373 switch (kid->op_type) {
5375 o->op_flags |= OPf_SPECIAL;
5378 o->op_private |= OPpSLICE;
5381 o->op_flags |= OPf_SPECIAL;
5386 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5387 PL_op_desc[o->op_type]);
5395 Perl_ck_eof(pTHX_ OP *o)
5397 I32 type = o->op_type;
5399 if (o->op_flags & OPf_KIDS) {
5400 if (cLISTOPo->op_first->op_type == OP_STUB) {
5402 o = newUNOP(type, OPf_SPECIAL,
5403 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5411 Perl_ck_eval(pTHX_ OP *o)
5413 PL_hints |= HINT_BLOCK_SCOPE;
5414 if (o->op_flags & OPf_KIDS) {
5415 SVOP *kid = (SVOP*)cUNOPo->op_first;
5418 o->op_flags &= ~OPf_KIDS;
5421 else if (kid->op_type == OP_LINESEQ) {
5424 kid->op_next = o->op_next;
5425 cUNOPo->op_first = 0;
5428 NewOp(1101, enter, 1, LOGOP);
5429 enter->op_type = OP_ENTERTRY;
5430 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5431 enter->op_private = 0;
5433 /* establish postfix order */
5434 enter->op_next = (OP*)enter;
5436 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5437 o->op_type = OP_LEAVETRY;
5438 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5439 enter->op_other = o;
5447 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5449 o->op_targ = (PADOFFSET)PL_hints;
5454 Perl_ck_exit(pTHX_ OP *o)
5457 HV *table = GvHV(PL_hintgv);
5459 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5460 if (svp && *svp && SvTRUE(*svp))
5461 o->op_private |= OPpEXIT_VMSISH;
5468 Perl_ck_exec(pTHX_ OP *o)
5471 if (o->op_flags & OPf_STACKED) {
5473 kid = cUNOPo->op_first->op_sibling;
5474 if (kid->op_type == OP_RV2GV)
5483 Perl_ck_exists(pTHX_ OP *o)
5486 if (o->op_flags & OPf_KIDS) {
5487 OP *kid = cUNOPo->op_first;
5488 if (kid->op_type == OP_ENTERSUB) {
5489 (void) ref(kid, o->op_type);
5490 if (kid->op_type != OP_RV2CV && !PL_error_count)
5491 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5492 PL_op_desc[o->op_type]);
5493 o->op_private |= OPpEXISTS_SUB;
5495 else if (kid->op_type == OP_AELEM)
5496 o->op_flags |= OPf_SPECIAL;
5497 else if (kid->op_type != OP_HELEM)
5498 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5499 PL_op_desc[o->op_type]);
5507 Perl_ck_gvconst(pTHX_ register OP *o)
5509 o = fold_constants(o);
5510 if (o->op_type == OP_CONST)
5517 Perl_ck_rvconst(pTHX_ register OP *o)
5519 SVOP *kid = (SVOP*)cUNOPo->op_first;
5521 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5522 if (kid->op_type == OP_CONST) {
5526 SV *kidsv = kid->op_sv;
5529 /* Is it a constant from cv_const_sv()? */
5530 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5531 SV *rsv = SvRV(kidsv);
5532 int svtype = SvTYPE(rsv);
5533 char *badtype = Nullch;
5535 switch (o->op_type) {
5537 if (svtype > SVt_PVMG)
5538 badtype = "a SCALAR";
5541 if (svtype != SVt_PVAV)
5542 badtype = "an ARRAY";
5545 if (svtype != SVt_PVHV) {
5546 if (svtype == SVt_PVAV) { /* pseudohash? */
5547 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5548 if (ksv && SvROK(*ksv)
5549 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5558 if (svtype != SVt_PVCV)
5563 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5566 name = SvPV(kidsv, n_a);
5567 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5568 char *badthing = Nullch;
5569 switch (o->op_type) {
5571 badthing = "a SCALAR";
5574 badthing = "an ARRAY";
5577 badthing = "a HASH";
5582 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5586 * This is a little tricky. We only want to add the symbol if we
5587 * didn't add it in the lexer. Otherwise we get duplicate strict
5588 * warnings. But if we didn't add it in the lexer, we must at
5589 * least pretend like we wanted to add it even if it existed before,
5590 * or we get possible typo warnings. OPpCONST_ENTERED says
5591 * whether the lexer already added THIS instance of this symbol.
5593 iscv = (o->op_type == OP_RV2CV) * 2;
5595 gv = gv_fetchpv(name,
5596 iscv | !(kid->op_private & OPpCONST_ENTERED),
5599 : o->op_type == OP_RV2SV
5601 : o->op_type == OP_RV2AV
5603 : o->op_type == OP_RV2HV
5606 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5608 kid->op_type = OP_GV;
5609 SvREFCNT_dec(kid->op_sv);
5611 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5612 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5613 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5615 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5617 kid->op_sv = SvREFCNT_inc(gv);
5619 kid->op_private = 0;
5620 kid->op_ppaddr = PL_ppaddr[OP_GV];
5627 Perl_ck_ftst(pTHX_ OP *o)
5629 I32 type = o->op_type;
5631 if (o->op_flags & OPf_REF) {
5634 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5635 SVOP *kid = (SVOP*)cUNOPo->op_first;
5637 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5639 OP *newop = newGVOP(type, OPf_REF,
5640 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5647 if (type == OP_FTTTY)
5648 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5651 o = newUNOP(type, 0, newDEFSVOP());
5657 Perl_ck_fun(pTHX_ OP *o)
5663 int type = o->op_type;
5664 register I32 oa = PL_opargs[type] >> OASHIFT;
5666 if (o->op_flags & OPf_STACKED) {
5667 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5670 return no_fh_allowed(o);
5673 if (o->op_flags & OPf_KIDS) {
5675 tokid = &cLISTOPo->op_first;
5676 kid = cLISTOPo->op_first;
5677 if (kid->op_type == OP_PUSHMARK ||
5678 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5680 tokid = &kid->op_sibling;
5681 kid = kid->op_sibling;
5683 if (!kid && PL_opargs[type] & OA_DEFGV)
5684 *tokid = kid = newDEFSVOP();
5688 sibl = kid->op_sibling;
5691 /* list seen where single (scalar) arg expected? */
5692 if (numargs == 1 && !(oa >> 4)
5693 && kid->op_type == OP_LIST && type != OP_SCALAR)
5695 return too_many_arguments(o,PL_op_desc[type]);
5708 if ((type == OP_PUSH || type == OP_UNSHIFT)
5709 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5710 Perl_warner(aTHX_ WARN_SYNTAX,
5711 "Useless use of %s with no values",
5714 if (kid->op_type == OP_CONST &&
5715 (kid->op_private & OPpCONST_BARE))
5717 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5718 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5719 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5720 if (ckWARN(WARN_DEPRECATED))
5721 Perl_warner(aTHX_ WARN_DEPRECATED,
5722 "Array @%s missing the @ in argument %"IVdf" of %s()",
5723 name, (IV)numargs, PL_op_desc[type]);
5726 kid->op_sibling = sibl;
5729 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5730 bad_type(numargs, "array", PL_op_desc[type], kid);
5734 if (kid->op_type == OP_CONST &&
5735 (kid->op_private & OPpCONST_BARE))
5737 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5738 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5739 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5740 if (ckWARN(WARN_DEPRECATED))
5741 Perl_warner(aTHX_ WARN_DEPRECATED,
5742 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5743 name, (IV)numargs, PL_op_desc[type]);
5746 kid->op_sibling = sibl;
5749 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5750 bad_type(numargs, "hash", PL_op_desc[type], kid);
5755 OP *newop = newUNOP(OP_NULL, 0, kid);
5756 kid->op_sibling = 0;
5758 newop->op_next = newop;
5760 kid->op_sibling = sibl;
5765 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5766 if (kid->op_type == OP_CONST &&
5767 (kid->op_private & OPpCONST_BARE))
5769 OP *newop = newGVOP(OP_GV, 0,
5770 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5775 else if (kid->op_type == OP_READLINE) {
5776 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5777 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5780 I32 flags = OPf_SPECIAL;
5784 /* is this op a FH constructor? */
5785 if (is_handle_constructor(o,numargs)) {
5786 char *name = Nullch;
5790 /* Set a flag to tell rv2gv to vivify
5791 * need to "prove" flag does not mean something
5792 * else already - NI-S 1999/05/07
5795 if (kid->op_type == OP_PADSV) {
5796 SV **namep = av_fetch(PL_comppad_name,
5798 if (namep && *namep)
5799 name = SvPV(*namep, len);
5801 else if (kid->op_type == OP_RV2SV
5802 && kUNOP->op_first->op_type == OP_GV)
5804 GV *gv = cGVOPx_gv(kUNOP->op_first);
5806 len = GvNAMELEN(gv);
5808 else if (kid->op_type == OP_AELEM
5809 || kid->op_type == OP_HELEM)
5811 name = "__ANONIO__";
5817 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5818 namesv = PL_curpad[targ];
5819 (void)SvUPGRADE(namesv, SVt_PV);
5821 sv_setpvn(namesv, "$", 1);
5822 sv_catpvn(namesv, name, len);
5825 kid->op_sibling = 0;
5826 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5827 kid->op_targ = targ;
5828 kid->op_private |= priv;
5830 kid->op_sibling = sibl;
5836 mod(scalar(kid), type);
5840 tokid = &kid->op_sibling;
5841 kid = kid->op_sibling;
5843 o->op_private |= numargs;
5845 return too_many_arguments(o,PL_op_desc[o->op_type]);
5848 else if (PL_opargs[type] & OA_DEFGV) {
5850 return newUNOP(type, 0, newDEFSVOP());
5854 while (oa & OA_OPTIONAL)
5856 if (oa && oa != OA_LIST)
5857 return too_few_arguments(o,PL_op_desc[o->op_type]);
5863 Perl_ck_glob(pTHX_ OP *o)
5868 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5869 append_elem(OP_GLOB, o, newDEFSVOP());
5871 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5872 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5874 #if !defined(PERL_EXTERNAL_GLOB)
5875 /* XXX this can be tightened up and made more failsafe. */
5879 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5881 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5882 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5883 GvCV(gv) = GvCV(glob_gv);
5884 SvREFCNT_inc((SV*)GvCV(gv));
5885 GvIMPORTED_CV_on(gv);
5888 #endif /* PERL_EXTERNAL_GLOB */
5890 if (gv && GvIMPORTED_CV(gv)) {
5891 append_elem(OP_GLOB, o,
5892 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5893 o->op_type = OP_LIST;
5894 o->op_ppaddr = PL_ppaddr[OP_LIST];
5895 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5896 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5897 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5898 append_elem(OP_LIST, o,
5899 scalar(newUNOP(OP_RV2CV, 0,
5900 newGVOP(OP_GV, 0, gv)))));
5901 o = newUNOP(OP_NULL, 0, ck_subr(o));
5902 o->op_targ = OP_GLOB; /* hint at what it used to be */
5905 gv = newGVgen("main");
5907 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5913 Perl_ck_grep(pTHX_ OP *o)
5917 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5919 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5920 NewOp(1101, gwop, 1, LOGOP);
5922 if (o->op_flags & OPf_STACKED) {
5925 kid = cLISTOPo->op_first->op_sibling;
5926 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5929 kid->op_next = (OP*)gwop;
5930 o->op_flags &= ~OPf_STACKED;
5932 kid = cLISTOPo->op_first->op_sibling;
5933 if (type == OP_MAPWHILE)
5940 kid = cLISTOPo->op_first->op_sibling;
5941 if (kid->op_type != OP_NULL)
5942 Perl_croak(aTHX_ "panic: ck_grep");
5943 kid = kUNOP->op_first;
5945 gwop->op_type = type;
5946 gwop->op_ppaddr = PL_ppaddr[type];
5947 gwop->op_first = listkids(o);
5948 gwop->op_flags |= OPf_KIDS;
5949 gwop->op_private = 1;
5950 gwop->op_other = LINKLIST(kid);
5951 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5952 kid->op_next = (OP*)gwop;
5954 kid = cLISTOPo->op_first->op_sibling;
5955 if (!kid || !kid->op_sibling)
5956 return too_few_arguments(o,PL_op_desc[o->op_type]);
5957 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5958 mod(kid, OP_GREPSTART);
5964 Perl_ck_index(pTHX_ OP *o)
5966 if (o->op_flags & OPf_KIDS) {
5967 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5969 kid = kid->op_sibling; /* get past "big" */
5970 if (kid && kid->op_type == OP_CONST)
5971 fbm_compile(((SVOP*)kid)->op_sv, 0);
5977 Perl_ck_lengthconst(pTHX_ OP *o)
5979 /* XXX length optimization goes here */
5984 Perl_ck_lfun(pTHX_ OP *o)
5986 OPCODE type = o->op_type;
5987 return modkids(ck_fun(o), type);
5991 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5993 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5994 switch (cUNOPo->op_first->op_type) {
5996 /* This is needed for
5997 if (defined %stash::)
5998 to work. Do not break Tk.
6000 break; /* Globals via GV can be undef */
6002 case OP_AASSIGN: /* Is this a good idea? */
6003 Perl_warner(aTHX_ WARN_DEPRECATED,
6004 "defined(@array) is deprecated");
6005 Perl_warner(aTHX_ WARN_DEPRECATED,
6006 "\t(Maybe you should just omit the defined()?)\n");
6009 /* This is needed for
6010 if (defined %stash::)
6011 to work. Do not break Tk.
6013 break; /* Globals via GV can be undef */
6015 Perl_warner(aTHX_ WARN_DEPRECATED,
6016 "defined(%%hash) is deprecated");
6017 Perl_warner(aTHX_ WARN_DEPRECATED,
6018 "\t(Maybe you should just omit the defined()?)\n");
6029 Perl_ck_rfun(pTHX_ OP *o)
6031 OPCODE type = o->op_type;
6032 return refkids(ck_fun(o), type);
6036 Perl_ck_listiob(pTHX_ OP *o)
6040 kid = cLISTOPo->op_first;
6043 kid = cLISTOPo->op_first;
6045 if (kid->op_type == OP_PUSHMARK)
6046 kid = kid->op_sibling;
6047 if (kid && o->op_flags & OPf_STACKED)
6048 kid = kid->op_sibling;
6049 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6050 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6051 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6052 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6053 cLISTOPo->op_first->op_sibling = kid;
6054 cLISTOPo->op_last = kid;
6055 kid = kid->op_sibling;
6060 append_elem(o->op_type, o, newDEFSVOP());
6066 Perl_ck_sassign(pTHX_ OP *o)
6068 OP *kid = cLISTOPo->op_first;
6069 /* has a disposable target? */
6070 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6071 && !(kid->op_flags & OPf_STACKED)
6072 /* Cannot steal the second time! */
6073 && !(kid->op_private & OPpTARGET_MY))
6075 OP *kkid = kid->op_sibling;
6077 /* Can just relocate the target. */
6078 if (kkid && kkid->op_type == OP_PADSV
6079 && !(kkid->op_private & OPpLVAL_INTRO))
6081 kid->op_targ = kkid->op_targ;
6083 /* Now we do not need PADSV and SASSIGN. */
6084 kid->op_sibling = o->op_sibling; /* NULL */
6085 cLISTOPo->op_first = NULL;
6088 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6096 Perl_ck_match(pTHX_ OP *o)
6098 o->op_private |= OPpRUNTIME;
6103 Perl_ck_method(pTHX_ OP *o)
6105 OP *kid = cUNOPo->op_first;
6106 if (kid->op_type == OP_CONST) {
6107 SV* sv = kSVOP->op_sv;
6108 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6110 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6111 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6114 kSVOP->op_sv = Nullsv;
6116 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6125 Perl_ck_null(pTHX_ OP *o)
6131 Perl_ck_open(pTHX_ OP *o)
6133 HV *table = GvHV(PL_hintgv);
6137 svp = hv_fetch(table, "open_IN", 7, FALSE);
6139 mode = mode_from_discipline(*svp);
6140 if (mode & O_BINARY)
6141 o->op_private |= OPpOPEN_IN_RAW;
6142 else if (mode & O_TEXT)
6143 o->op_private |= OPpOPEN_IN_CRLF;
6146 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6148 mode = mode_from_discipline(*svp);
6149 if (mode & O_BINARY)
6150 o->op_private |= OPpOPEN_OUT_RAW;
6151 else if (mode & O_TEXT)
6152 o->op_private |= OPpOPEN_OUT_CRLF;
6155 if (o->op_type == OP_BACKTICK)
6161 Perl_ck_repeat(pTHX_ OP *o)
6163 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6164 o->op_private |= OPpREPEAT_DOLIST;
6165 cBINOPo->op_first = force_list(cBINOPo->op_first);
6173 Perl_ck_require(pTHX_ OP *o)
6177 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6178 SVOP *kid = (SVOP*)cUNOPo->op_first;
6180 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6182 for (s = SvPVX(kid->op_sv); *s; s++) {
6183 if (*s == ':' && s[1] == ':') {
6185 Move(s+2, s+1, strlen(s+2)+1, char);
6186 --SvCUR(kid->op_sv);
6189 if (SvREADONLY(kid->op_sv)) {
6190 SvREADONLY_off(kid->op_sv);
6191 sv_catpvn(kid->op_sv, ".pm", 3);
6192 SvREADONLY_on(kid->op_sv);
6195 sv_catpvn(kid->op_sv, ".pm", 3);
6199 /* handle override, if any */
6200 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6201 if (!(gv && GvIMPORTED_CV(gv)))
6202 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6204 if (gv && GvIMPORTED_CV(gv)) {
6205 OP *kid = cUNOPo->op_first;
6206 cUNOPo->op_first = 0;
6208 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6209 append_elem(OP_LIST, kid,
6210 scalar(newUNOP(OP_RV2CV, 0,
6219 Perl_ck_return(pTHX_ OP *o)
6222 if (CvLVALUE(PL_compcv)) {
6223 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6224 mod(kid, OP_LEAVESUBLV);
6231 Perl_ck_retarget(pTHX_ OP *o)
6233 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6240 Perl_ck_select(pTHX_ OP *o)
6243 if (o->op_flags & OPf_KIDS) {
6244 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6245 if (kid && kid->op_sibling) {
6246 o->op_type = OP_SSELECT;
6247 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6249 return fold_constants(o);
6253 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6254 if (kid && kid->op_type == OP_RV2GV)
6255 kid->op_private &= ~HINT_STRICT_REFS;
6260 Perl_ck_shift(pTHX_ OP *o)
6262 I32 type = o->op_type;
6264 if (!(o->op_flags & OPf_KIDS)) {
6269 if (!CvUNIQUE(PL_compcv)) {
6270 argop = newOP(OP_PADAV, OPf_REF);
6271 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6274 argop = newUNOP(OP_RV2AV, 0,
6275 scalar(newGVOP(OP_GV, 0,
6276 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6279 argop = newUNOP(OP_RV2AV, 0,
6280 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6281 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6282 #endif /* USE_THREADS */
6283 return newUNOP(type, 0, scalar(argop));
6285 return scalar(modkids(ck_fun(o), type));
6289 Perl_ck_sort(pTHX_ OP *o)
6293 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6295 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6296 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6298 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6300 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6302 if (kid->op_type == OP_SCOPE) {
6306 else if (kid->op_type == OP_LEAVE) {
6307 if (o->op_type == OP_SORT) {
6308 op_null(kid); /* wipe out leave */
6311 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6312 if (k->op_next == kid)
6314 /* don't descend into loops */
6315 else if (k->op_type == OP_ENTERLOOP
6316 || k->op_type == OP_ENTERITER)
6318 k = cLOOPx(k)->op_lastop;
6323 kid->op_next = 0; /* just disconnect the leave */
6324 k = kLISTOP->op_first;
6329 if (o->op_type == OP_SORT) {
6330 /* provide scalar context for comparison function/block */
6336 o->op_flags |= OPf_SPECIAL;
6338 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6341 firstkid = firstkid->op_sibling;
6344 /* provide list context for arguments */
6345 if (o->op_type == OP_SORT)
6352 S_simplify_sort(pTHX_ OP *o)
6354 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6358 if (!(o->op_flags & OPf_STACKED))
6360 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6361 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6362 kid = kUNOP->op_first; /* get past null */
6363 if (kid->op_type != OP_SCOPE)
6365 kid = kLISTOP->op_last; /* get past scope */
6366 switch(kid->op_type) {
6374 k = kid; /* remember this node*/
6375 if (kBINOP->op_first->op_type != OP_RV2SV)
6377 kid = kBINOP->op_first; /* get past cmp */
6378 if (kUNOP->op_first->op_type != OP_GV)
6380 kid = kUNOP->op_first; /* get past rv2sv */
6382 if (GvSTASH(gv) != PL_curstash)
6384 if (strEQ(GvNAME(gv), "a"))
6386 else if (strEQ(GvNAME(gv), "b"))
6390 kid = k; /* back to cmp */
6391 if (kBINOP->op_last->op_type != OP_RV2SV)
6393 kid = kBINOP->op_last; /* down to 2nd arg */
6394 if (kUNOP->op_first->op_type != OP_GV)
6396 kid = kUNOP->op_first; /* get past rv2sv */
6398 if (GvSTASH(gv) != PL_curstash
6400 ? strNE(GvNAME(gv), "a")
6401 : strNE(GvNAME(gv), "b")))
6403 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6405 o->op_private |= OPpSORT_REVERSE;
6406 if (k->op_type == OP_NCMP)
6407 o->op_private |= OPpSORT_NUMERIC;
6408 if (k->op_type == OP_I_NCMP)
6409 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6410 kid = cLISTOPo->op_first->op_sibling;
6411 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6412 op_free(kid); /* then delete it */
6416 Perl_ck_split(pTHX_ OP *o)
6420 if (o->op_flags & OPf_STACKED)
6421 return no_fh_allowed(o);
6423 kid = cLISTOPo->op_first;
6424 if (kid->op_type != OP_NULL)
6425 Perl_croak(aTHX_ "panic: ck_split");
6426 kid = kid->op_sibling;
6427 op_free(cLISTOPo->op_first);
6428 cLISTOPo->op_first = kid;
6430 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6431 cLISTOPo->op_last = kid; /* There was only one element previously */
6434 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6435 OP *sibl = kid->op_sibling;
6436 kid->op_sibling = 0;
6437 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6438 if (cLISTOPo->op_first == cLISTOPo->op_last)
6439 cLISTOPo->op_last = kid;
6440 cLISTOPo->op_first = kid;
6441 kid->op_sibling = sibl;
6444 kid->op_type = OP_PUSHRE;
6445 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6448 if (!kid->op_sibling)
6449 append_elem(OP_SPLIT, o, newDEFSVOP());
6451 kid = kid->op_sibling;
6454 if (!kid->op_sibling)
6455 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6457 kid = kid->op_sibling;
6460 if (kid->op_sibling)
6461 return too_many_arguments(o,PL_op_desc[o->op_type]);
6467 Perl_ck_join(pTHX_ OP *o)
6469 if (ckWARN(WARN_SYNTAX)) {
6470 OP *kid = cLISTOPo->op_first->op_sibling;
6471 if (kid && kid->op_type == OP_MATCH) {
6472 char *pmstr = "STRING";
6473 if (PM_GETRE(kPMOP))
6474 pmstr = PM_GETRE(kPMOP)->precomp;
6475 Perl_warner(aTHX_ WARN_SYNTAX,
6476 "/%s/ should probably be written as \"%s\"",
6484 Perl_ck_subr(pTHX_ OP *o)
6486 OP *prev = ((cUNOPo->op_first->op_sibling)
6487 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6488 OP *o2 = prev->op_sibling;
6497 o->op_private |= OPpENTERSUB_HASTARG;
6498 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6499 if (cvop->op_type == OP_RV2CV) {
6501 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6502 op_null(cvop); /* disable rv2cv */
6503 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6504 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6505 GV *gv = cGVOPx_gv(tmpop);
6508 tmpop->op_private |= OPpEARLY_CV;
6509 else if (SvPOK(cv)) {
6510 namegv = CvANON(cv) ? gv : CvGV(cv);
6511 proto = SvPV((SV*)cv, n_a);
6515 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6516 if (o2->op_type == OP_CONST)
6517 o2->op_private &= ~OPpCONST_STRICT;
6518 else if (o2->op_type == OP_LIST) {
6519 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6520 if (o && o->op_type == OP_CONST)
6521 o->op_private &= ~OPpCONST_STRICT;
6524 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6525 if (PERLDB_SUB && PL_curstash != PL_debstash)
6526 o->op_private |= OPpENTERSUB_DB;
6527 while (o2 != cvop) {
6531 return too_many_arguments(o, gv_ename(namegv));
6549 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6551 arg == 1 ? "block or sub {}" : "sub {}",
6552 gv_ename(namegv), o2);
6555 /* '*' allows any scalar type, including bareword */
6558 if (o2->op_type == OP_RV2GV)
6559 goto wrapref; /* autoconvert GLOB -> GLOBref */
6560 else if (o2->op_type == OP_CONST)
6561 o2->op_private &= ~OPpCONST_STRICT;
6562 else if (o2->op_type == OP_ENTERSUB) {
6563 /* accidental subroutine, revert to bareword */
6564 OP *gvop = ((UNOP*)o2)->op_first;
6565 if (gvop && gvop->op_type == OP_NULL) {
6566 gvop = ((UNOP*)gvop)->op_first;
6568 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6571 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6572 (gvop = ((UNOP*)gvop)->op_first) &&
6573 gvop->op_type == OP_GV)
6575 GV *gv = cGVOPx_gv(gvop);
6576 OP *sibling = o2->op_sibling;
6577 SV *n = newSVpvn("",0);
6579 gv_fullname3(n, gv, "");
6580 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6581 sv_chop(n, SvPVX(n)+6);
6582 o2 = newSVOP(OP_CONST, 0, n);
6583 prev->op_sibling = o2;
6584 o2->op_sibling = sibling;
6596 if (o2->op_type != OP_RV2GV)
6597 bad_type(arg, "symbol", gv_ename(namegv), o2);
6600 if (o2->op_type != OP_ENTERSUB)
6601 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6604 if (o2->op_type != OP_RV2SV
6605 && o2->op_type != OP_PADSV
6606 && o2->op_type != OP_HELEM
6607 && o2->op_type != OP_AELEM
6608 && o2->op_type != OP_THREADSV)
6610 bad_type(arg, "scalar", gv_ename(namegv), o2);
6614 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6615 bad_type(arg, "array", gv_ename(namegv), o2);
6618 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6619 bad_type(arg, "hash", gv_ename(namegv), o2);
6623 OP* sib = kid->op_sibling;
6624 kid->op_sibling = 0;
6625 o2 = newUNOP(OP_REFGEN, 0, kid);
6626 o2->op_sibling = sib;
6627 prev->op_sibling = o2;
6638 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6639 gv_ename(namegv), SvPV((SV*)cv, n_a));
6644 mod(o2, OP_ENTERSUB);
6646 o2 = o2->op_sibling;
6648 if (proto && !optional &&
6649 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6650 return too_few_arguments(o, gv_ename(namegv));
6655 Perl_ck_svconst(pTHX_ OP *o)
6657 SvREADONLY_on(cSVOPo->op_sv);
6662 Perl_ck_trunc(pTHX_ OP *o)
6664 if (o->op_flags & OPf_KIDS) {
6665 SVOP *kid = (SVOP*)cUNOPo->op_first;
6667 if (kid->op_type == OP_NULL)
6668 kid = (SVOP*)kid->op_sibling;
6669 if (kid && kid->op_type == OP_CONST &&
6670 (kid->op_private & OPpCONST_BARE))
6672 o->op_flags |= OPf_SPECIAL;
6673 kid->op_private &= ~OPpCONST_STRICT;
6680 Perl_ck_substr(pTHX_ OP *o)
6683 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6684 OP *kid = cLISTOPo->op_first;
6686 if (kid->op_type == OP_NULL)
6687 kid = kid->op_sibling;
6689 kid->op_flags |= OPf_MOD;
6695 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6698 Perl_peep(pTHX_ register OP *o)
6700 register OP* oldop = 0;
6703 if (!o || o->op_seq)
6707 SAVEVPTR(PL_curcop);
6708 for (; o; o = o->op_next) {
6714 switch (o->op_type) {
6718 PL_curcop = ((COP*)o); /* for warnings */
6719 o->op_seq = PL_op_seqmax++;
6723 if (cSVOPo->op_private & OPpCONST_STRICT)
6724 no_bareword_allowed(o);
6726 /* Relocate sv to the pad for thread safety.
6727 * Despite being a "constant", the SV is written to,
6728 * for reference counts, sv_upgrade() etc. */
6730 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6731 if (SvPADTMP(cSVOPo->op_sv)) {
6732 /* If op_sv is already a PADTMP then it is being used by
6733 * some pad, so make a copy. */
6734 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6735 SvREADONLY_on(PL_curpad[ix]);
6736 SvREFCNT_dec(cSVOPo->op_sv);
6739 SvREFCNT_dec(PL_curpad[ix]);
6740 SvPADTMP_on(cSVOPo->op_sv);
6741 PL_curpad[ix] = cSVOPo->op_sv;
6742 /* XXX I don't know how this isn't readonly already. */
6743 SvREADONLY_on(PL_curpad[ix]);
6745 cSVOPo->op_sv = Nullsv;
6749 o->op_seq = PL_op_seqmax++;
6753 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6754 if (o->op_next->op_private & OPpTARGET_MY) {
6755 if (o->op_flags & OPf_STACKED) /* chained concats */
6756 goto ignore_optimization;
6758 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6759 o->op_targ = o->op_next->op_targ;
6760 o->op_next->op_targ = 0;
6761 o->op_private |= OPpTARGET_MY;
6764 op_null(o->op_next);
6766 ignore_optimization:
6767 o->op_seq = PL_op_seqmax++;
6770 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6771 o->op_seq = PL_op_seqmax++;
6772 break; /* Scalar stub must produce undef. List stub is noop */
6776 if (o->op_targ == OP_NEXTSTATE
6777 || o->op_targ == OP_DBSTATE
6778 || o->op_targ == OP_SETSTATE)
6780 PL_curcop = ((COP*)o);
6787 if (oldop && o->op_next) {
6788 oldop->op_next = o->op_next;
6791 o->op_seq = PL_op_seqmax++;
6795 if (o->op_next->op_type == OP_RV2SV) {
6796 if (!(o->op_next->op_private & OPpDEREF)) {
6797 op_null(o->op_next);
6798 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6800 o->op_next = o->op_next->op_next;
6801 o->op_type = OP_GVSV;
6802 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6805 else if (o->op_next->op_type == OP_RV2AV) {
6806 OP* pop = o->op_next->op_next;
6808 if (pop->op_type == OP_CONST &&
6809 (PL_op = pop->op_next) &&
6810 pop->op_next->op_type == OP_AELEM &&
6811 !(pop->op_next->op_private &
6812 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6813 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6818 op_null(o->op_next);
6819 op_null(pop->op_next);
6821 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6822 o->op_next = pop->op_next->op_next;
6823 o->op_type = OP_AELEMFAST;
6824 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6825 o->op_private = (U8)i;
6830 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6832 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6833 /* XXX could check prototype here instead of just carping */
6834 SV *sv = sv_newmortal();
6835 gv_efullname3(sv, gv, Nullch);
6836 Perl_warner(aTHX_ WARN_PROTOTYPE,
6837 "%s() called too early to check prototype",
6842 o->op_seq = PL_op_seqmax++;
6853 o->op_seq = PL_op_seqmax++;
6854 while (cLOGOP->op_other->op_type == OP_NULL)
6855 cLOGOP->op_other = cLOGOP->op_other->op_next;
6856 peep(cLOGOP->op_other);
6861 o->op_seq = PL_op_seqmax++;
6862 while (cLOOP->op_redoop->op_type == OP_NULL)
6863 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6864 peep(cLOOP->op_redoop);
6865 while (cLOOP->op_nextop->op_type == OP_NULL)
6866 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6867 peep(cLOOP->op_nextop);
6868 while (cLOOP->op_lastop->op_type == OP_NULL)
6869 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6870 peep(cLOOP->op_lastop);
6876 o->op_seq = PL_op_seqmax++;
6877 while (cPMOP->op_pmreplstart &&
6878 cPMOP->op_pmreplstart->op_type == OP_NULL)
6879 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6880 peep(cPMOP->op_pmreplstart);
6884 o->op_seq = PL_op_seqmax++;
6885 if (ckWARN(WARN_SYNTAX) && o->op_next
6886 && o->op_next->op_type == OP_NEXTSTATE) {
6887 if (o->op_next->op_sibling &&
6888 o->op_next->op_sibling->op_type != OP_EXIT &&
6889 o->op_next->op_sibling->op_type != OP_WARN &&
6890 o->op_next->op_sibling->op_type != OP_DIE) {
6891 line_t oldline = CopLINE(PL_curcop);
6893 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6894 Perl_warner(aTHX_ WARN_EXEC,
6895 "Statement unlikely to be reached");
6896 Perl_warner(aTHX_ WARN_EXEC,
6897 "\t(Maybe you meant system() when you said exec()?)\n");
6898 CopLINE_set(PL_curcop, oldline);
6907 SV **svp, **indsvp, *sv;
6912 o->op_seq = PL_op_seqmax++;
6914 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6917 /* Make the CONST have a shared SV */
6918 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6919 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6920 key = SvPV(sv, keylen);
6921 lexname = newSVpvn_share(key,
6922 SvUTF8(sv) ? -(I32)keylen : keylen,
6928 if ((o->op_private & (OPpLVAL_INTRO)))
6931 rop = (UNOP*)((BINOP*)o)->op_first;
6932 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6934 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6935 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6937 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6938 if (!fields || !GvHV(*fields))
6940 key = SvPV(*svp, keylen);
6941 indsvp = hv_fetch(GvHV(*fields), key,
6942 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6944 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6945 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6947 ind = SvIV(*indsvp);
6949 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6950 rop->op_type = OP_RV2AV;
6951 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6952 o->op_type = OP_AELEM;
6953 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6955 if (SvREADONLY(*svp))
6957 SvFLAGS(sv) |= (SvFLAGS(*svp)
6958 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6968 SV **svp, **indsvp, *sv;
6972 SVOP *first_key_op, *key_op;
6974 o->op_seq = PL_op_seqmax++;
6975 if ((o->op_private & (OPpLVAL_INTRO))
6976 /* I bet there's always a pushmark... */
6977 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6978 /* hmmm, no optimization if list contains only one key. */
6980 rop = (UNOP*)((LISTOP*)o)->op_last;
6981 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6983 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6984 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6986 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6987 if (!fields || !GvHV(*fields))
6989 /* Again guessing that the pushmark can be jumped over.... */
6990 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6991 ->op_first->op_sibling;
6992 /* Check that the key list contains only constants. */
6993 for (key_op = first_key_op; key_op;
6994 key_op = (SVOP*)key_op->op_sibling)
6995 if (key_op->op_type != OP_CONST)
6999 rop->op_type = OP_RV2AV;
7000 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7001 o->op_type = OP_ASLICE;
7002 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7003 for (key_op = first_key_op; key_op;
7004 key_op = (SVOP*)key_op->op_sibling) {
7005 svp = cSVOPx_svp(key_op);
7006 key = SvPV(*svp, keylen);
7007 indsvp = hv_fetch(GvHV(*fields), key,
7008 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7010 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7011 "in variable %s of type %s",
7012 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7014 ind = SvIV(*indsvp);
7016 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7018 if (SvREADONLY(*svp))
7020 SvFLAGS(sv) |= (SvFLAGS(*svp)
7021 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7029 o->op_seq = PL_op_seqmax++;
7039 /* Efficient sub that returns a constant scalar value. */
7041 const_sv_xsub(pTHXo_ CV* cv)
7046 Perl_croak(aTHX_ "usage: %s::%s()",
7047 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7051 ST(0) = (SV*)XSANY.any_ptr;