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 o = newSVOP(OP_CONST, 0, sv);
2330 /* We don't want folded constants to trigger OCTMODE warnings,
2331 so we cheat a bit and mark them OCTAL. AMS 20010709 */
2332 o->op_private |= OPpCONST_OCTAL;
2337 if (!(PL_opargs[type] & OA_OTHERINT))
2340 if (!(PL_hints & HINT_INTEGER)) {
2341 if (type == OP_MODULO
2342 || type == OP_DIVIDE
2343 || !(o->op_flags & OPf_KIDS))
2348 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2349 if (curop->op_type == OP_CONST) {
2350 if (SvIOK(((SVOP*)curop)->op_sv))
2354 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2358 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2365 Perl_gen_constant_list(pTHX_ register OP *o)
2368 I32 oldtmps_floor = PL_tmps_floor;
2372 return o; /* Don't attempt to run with errors */
2374 PL_op = curop = LINKLIST(o);
2381 PL_tmps_floor = oldtmps_floor;
2383 o->op_type = OP_RV2AV;
2384 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2385 curop = ((UNOP*)o)->op_first;
2386 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2393 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2395 if (!o || o->op_type != OP_LIST)
2396 o = newLISTOP(OP_LIST, 0, o, Nullop);
2398 o->op_flags &= ~OPf_WANT;
2400 if (!(PL_opargs[type] & OA_MARK))
2401 op_null(cLISTOPo->op_first);
2404 o->op_ppaddr = PL_ppaddr[type];
2405 o->op_flags |= flags;
2407 o = CHECKOP(type, o);
2408 if (o->op_type != type)
2411 return fold_constants(o);
2414 /* List constructors */
2417 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2425 if (first->op_type != type
2426 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2428 return newLISTOP(type, 0, first, last);
2431 if (first->op_flags & OPf_KIDS)
2432 ((LISTOP*)first)->op_last->op_sibling = last;
2434 first->op_flags |= OPf_KIDS;
2435 ((LISTOP*)first)->op_first = last;
2437 ((LISTOP*)first)->op_last = last;
2442 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2450 if (first->op_type != type)
2451 return prepend_elem(type, (OP*)first, (OP*)last);
2453 if (last->op_type != type)
2454 return append_elem(type, (OP*)first, (OP*)last);
2456 first->op_last->op_sibling = last->op_first;
2457 first->op_last = last->op_last;
2458 first->op_flags |= (last->op_flags & OPf_KIDS);
2460 #ifdef PL_OP_SLAB_ALLOC
2468 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2476 if (last->op_type == type) {
2477 if (type == OP_LIST) { /* already a PUSHMARK there */
2478 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2479 ((LISTOP*)last)->op_first->op_sibling = first;
2480 if (!(first->op_flags & OPf_PARENS))
2481 last->op_flags &= ~OPf_PARENS;
2484 if (!(last->op_flags & OPf_KIDS)) {
2485 ((LISTOP*)last)->op_last = first;
2486 last->op_flags |= OPf_KIDS;
2488 first->op_sibling = ((LISTOP*)last)->op_first;
2489 ((LISTOP*)last)->op_first = first;
2491 last->op_flags |= OPf_KIDS;
2495 return newLISTOP(type, 0, first, last);
2501 Perl_newNULLLIST(pTHX)
2503 return newOP(OP_STUB, 0);
2507 Perl_force_list(pTHX_ OP *o)
2509 if (!o || o->op_type != OP_LIST)
2510 o = newLISTOP(OP_LIST, 0, o, Nullop);
2516 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2520 NewOp(1101, listop, 1, LISTOP);
2522 listop->op_type = type;
2523 listop->op_ppaddr = PL_ppaddr[type];
2526 listop->op_flags = flags;
2530 else if (!first && last)
2533 first->op_sibling = last;
2534 listop->op_first = first;
2535 listop->op_last = last;
2536 if (type == OP_LIST) {
2538 pushop = newOP(OP_PUSHMARK, 0);
2539 pushop->op_sibling = first;
2540 listop->op_first = pushop;
2541 listop->op_flags |= OPf_KIDS;
2543 listop->op_last = pushop;
2550 Perl_newOP(pTHX_ I32 type, I32 flags)
2553 NewOp(1101, o, 1, OP);
2555 o->op_ppaddr = PL_ppaddr[type];
2556 o->op_flags = flags;
2559 o->op_private = 0 + (flags >> 8);
2560 if (PL_opargs[type] & OA_RETSCALAR)
2562 if (PL_opargs[type] & OA_TARGET)
2563 o->op_targ = pad_alloc(type, SVs_PADTMP);
2564 return CHECKOP(type, o);
2568 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2573 first = newOP(OP_STUB, 0);
2574 if (PL_opargs[type] & OA_MARK)
2575 first = force_list(first);
2577 NewOp(1101, unop, 1, UNOP);
2578 unop->op_type = type;
2579 unop->op_ppaddr = PL_ppaddr[type];
2580 unop->op_first = first;
2581 unop->op_flags = flags | OPf_KIDS;
2582 unop->op_private = 1 | (flags >> 8);
2583 unop = (UNOP*) CHECKOP(type, unop);
2587 return fold_constants((OP *) unop);
2591 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2594 NewOp(1101, binop, 1, BINOP);
2597 first = newOP(OP_NULL, 0);
2599 binop->op_type = type;
2600 binop->op_ppaddr = PL_ppaddr[type];
2601 binop->op_first = first;
2602 binop->op_flags = flags | OPf_KIDS;
2605 binop->op_private = 1 | (flags >> 8);
2608 binop->op_private = 2 | (flags >> 8);
2609 first->op_sibling = last;
2612 binop = (BINOP*)CHECKOP(type, binop);
2613 if (binop->op_next || binop->op_type != type)
2616 binop->op_last = binop->op_first->op_sibling;
2618 return fold_constants((OP *)binop);
2622 uvcompare(const void *a, const void *b)
2624 if (*((UV *)a) < (*(UV *)b))
2626 if (*((UV *)a) > (*(UV *)b))
2628 if (*((UV *)a+1) < (*(UV *)b+1))
2630 if (*((UV *)a+1) > (*(UV *)b+1))
2636 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2638 SV *tstr = ((SVOP*)expr)->op_sv;
2639 SV *rstr = ((SVOP*)repl)->op_sv;
2642 U8 *t = (U8*)SvPV(tstr, tlen);
2643 U8 *r = (U8*)SvPV(rstr, rlen);
2650 register short *tbl;
2652 PL_hints |= HINT_BLOCK_SCOPE;
2653 complement = o->op_private & OPpTRANS_COMPLEMENT;
2654 del = o->op_private & OPpTRANS_DELETE;
2655 squash = o->op_private & OPpTRANS_SQUASH;
2658 o->op_private |= OPpTRANS_FROM_UTF;
2661 o->op_private |= OPpTRANS_TO_UTF;
2663 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2664 SV* listsv = newSVpvn("# comment\n",10);
2666 U8* tend = t + tlen;
2667 U8* rend = r + rlen;
2681 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2682 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2688 tsave = t = bytes_to_utf8(t, &len);
2691 if (!to_utf && rlen) {
2693 rsave = r = bytes_to_utf8(r, &len);
2697 /* There are several snags with this code on EBCDIC:
2698 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2699 2. scan_const() in toke.c has encoded chars in native encoding which makes
2700 ranges at least in EBCDIC 0..255 range the bottom odd.
2704 U8 tmpbuf[UTF8_MAXLEN+1];
2707 New(1109, cp, 2*tlen, UV);
2709 transv = newSVpvn("",0);
2711 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2713 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2715 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2719 cp[2*i+1] = cp[2*i];
2723 qsort(cp, i, 2*sizeof(UV), uvcompare);
2724 for (j = 0; j < i; j++) {
2726 diff = val - nextmin;
2728 t = uvuni_to_utf8(tmpbuf,nextmin);
2729 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2731 U8 range_mark = UTF_TO_NATIVE(0xff);
2732 t = uvuni_to_utf8(tmpbuf, val - 1);
2733 sv_catpvn(transv, (char *)&range_mark, 1);
2734 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2741 t = uvuni_to_utf8(tmpbuf,nextmin);
2742 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2744 U8 range_mark = UTF_TO_NATIVE(0xff);
2745 sv_catpvn(transv, (char *)&range_mark, 1);
2747 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2748 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2749 t = (U8*)SvPVX(transv);
2750 tlen = SvCUR(transv);
2754 else if (!rlen && !del) {
2755 r = t; rlen = tlen; rend = tend;
2758 if ((!rlen && !del) || t == r ||
2759 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2761 o->op_private |= OPpTRANS_IDENTICAL;
2765 while (t < tend || tfirst <= tlast) {
2766 /* see if we need more "t" chars */
2767 if (tfirst > tlast) {
2768 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2770 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2772 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2779 /* now see if we need more "r" chars */
2780 if (rfirst > rlast) {
2782 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2784 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2786 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2795 rfirst = rlast = 0xffffffff;
2799 /* now see which range will peter our first, if either. */
2800 tdiff = tlast - tfirst;
2801 rdiff = rlast - rfirst;
2808 if (rfirst == 0xffffffff) {
2809 diff = tdiff; /* oops, pretend rdiff is infinite */
2811 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2812 (long)tfirst, (long)tlast);
2814 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2818 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2819 (long)tfirst, (long)(tfirst + diff),
2822 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2823 (long)tfirst, (long)rfirst);
2825 if (rfirst + diff > max)
2826 max = rfirst + diff;
2828 grows = (tfirst < rfirst &&
2829 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2841 else if (max > 0xff)
2846 Safefree(cPVOPo->op_pv);
2847 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2848 SvREFCNT_dec(listsv);
2850 SvREFCNT_dec(transv);
2852 if (!del && havefinal && rlen)
2853 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2854 newSVuv((UV)final), 0);
2857 o->op_private |= OPpTRANS_GROWS;
2869 tbl = (short*)cPVOPo->op_pv;
2871 Zero(tbl, 256, short);
2872 for (i = 0; i < tlen; i++)
2874 for (i = 0, j = 0; i < 256; i++) {
2885 if (i < 128 && r[j] >= 128)
2895 o->op_private |= OPpTRANS_IDENTICAL;
2900 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2901 tbl[0x100] = rlen - j;
2902 for (i=0; i < rlen - j; i++)
2903 tbl[0x101+i] = r[j+i];
2907 if (!rlen && !del) {
2910 o->op_private |= OPpTRANS_IDENTICAL;
2912 for (i = 0; i < 256; i++)
2914 for (i = 0, j = 0; i < tlen; i++,j++) {
2917 if (tbl[t[i]] == -1)
2923 if (tbl[t[i]] == -1) {
2924 if (t[i] < 128 && r[j] >= 128)
2931 o->op_private |= OPpTRANS_GROWS;
2939 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2943 NewOp(1101, pmop, 1, PMOP);
2944 pmop->op_type = type;
2945 pmop->op_ppaddr = PL_ppaddr[type];
2946 pmop->op_flags = flags;
2947 pmop->op_private = 0 | (flags >> 8);
2949 if (PL_hints & HINT_RE_TAINT)
2950 pmop->op_pmpermflags |= PMf_RETAINT;
2951 if (PL_hints & HINT_LOCALE)
2952 pmop->op_pmpermflags |= PMf_LOCALE;
2953 pmop->op_pmflags = pmop->op_pmpermflags;
2955 /* link into pm list */
2956 if (type != OP_TRANS && PL_curstash) {
2957 pmop->op_pmnext = HvPMROOT(PL_curstash);
2958 HvPMROOT(PL_curstash) = pmop;
2959 PmopSTASH_set(pmop,PL_curstash);
2966 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2970 I32 repl_has_vars = 0;
2972 if (o->op_type == OP_TRANS)
2973 return pmtrans(o, expr, repl);
2975 PL_hints |= HINT_BLOCK_SCOPE;
2978 if (expr->op_type == OP_CONST) {
2980 SV *pat = ((SVOP*)expr)->op_sv;
2981 char *p = SvPV(pat, plen);
2982 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2983 sv_setpvn(pat, "\\s+", 3);
2984 p = SvPV(pat, plen);
2985 pm->op_pmflags |= PMf_SKIPWHITE;
2987 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2988 pm->op_pmdynflags |= PMdf_UTF8;
2989 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2990 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2991 pm->op_pmflags |= PMf_WHITE;
2995 if (PL_hints & HINT_UTF8)
2996 pm->op_pmdynflags |= PMdf_UTF8;
2997 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2998 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3000 : OP_REGCMAYBE),0,expr);
3002 NewOp(1101, rcop, 1, LOGOP);
3003 rcop->op_type = OP_REGCOMP;
3004 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3005 rcop->op_first = scalar(expr);
3006 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3007 ? (OPf_SPECIAL | OPf_KIDS)
3009 rcop->op_private = 1;
3012 /* establish postfix order */
3013 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3015 rcop->op_next = expr;
3016 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3019 rcop->op_next = LINKLIST(expr);
3020 expr->op_next = (OP*)rcop;
3023 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3028 if (pm->op_pmflags & PMf_EVAL) {
3030 if (CopLINE(PL_curcop) < PL_multi_end)
3031 CopLINE_set(PL_curcop, PL_multi_end);
3034 else if (repl->op_type == OP_THREADSV
3035 && strchr("&`'123456789+",
3036 PL_threadsv_names[repl->op_targ]))
3040 #endif /* USE_THREADS */
3041 else if (repl->op_type == OP_CONST)
3045 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3046 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3048 if (curop->op_type == OP_THREADSV) {
3050 if (strchr("&`'123456789+", curop->op_private))
3054 if (curop->op_type == OP_GV) {
3055 GV *gv = cGVOPx_gv(curop);
3057 if (strchr("&`'123456789+", *GvENAME(gv)))
3060 #endif /* USE_THREADS */
3061 else if (curop->op_type == OP_RV2CV)
3063 else if (curop->op_type == OP_RV2SV ||
3064 curop->op_type == OP_RV2AV ||
3065 curop->op_type == OP_RV2HV ||
3066 curop->op_type == OP_RV2GV) {
3067 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3070 else if (curop->op_type == OP_PADSV ||
3071 curop->op_type == OP_PADAV ||
3072 curop->op_type == OP_PADHV ||
3073 curop->op_type == OP_PADANY) {
3076 else if (curop->op_type == OP_PUSHRE)
3077 ; /* Okay here, dangerous in newASSIGNOP */
3087 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3088 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3089 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3090 prepend_elem(o->op_type, scalar(repl), o);
3093 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3094 pm->op_pmflags |= PMf_MAYBE_CONST;
3095 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3097 NewOp(1101, rcop, 1, LOGOP);
3098 rcop->op_type = OP_SUBSTCONT;
3099 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3100 rcop->op_first = scalar(repl);
3101 rcop->op_flags |= OPf_KIDS;
3102 rcop->op_private = 1;
3105 /* establish postfix order */
3106 rcop->op_next = LINKLIST(repl);
3107 repl->op_next = (OP*)rcop;
3109 pm->op_pmreplroot = scalar((OP*)rcop);
3110 pm->op_pmreplstart = LINKLIST(rcop);
3119 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3122 NewOp(1101, svop, 1, SVOP);
3123 svop->op_type = type;
3124 svop->op_ppaddr = PL_ppaddr[type];
3126 svop->op_next = (OP*)svop;
3127 svop->op_flags = flags;
3128 if (PL_opargs[type] & OA_RETSCALAR)
3130 if (PL_opargs[type] & OA_TARGET)
3131 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3132 return CHECKOP(type, svop);
3136 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3139 NewOp(1101, padop, 1, PADOP);
3140 padop->op_type = type;
3141 padop->op_ppaddr = PL_ppaddr[type];
3142 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3143 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3144 PL_curpad[padop->op_padix] = sv;
3146 padop->op_next = (OP*)padop;
3147 padop->op_flags = flags;
3148 if (PL_opargs[type] & OA_RETSCALAR)
3150 if (PL_opargs[type] & OA_TARGET)
3151 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3152 return CHECKOP(type, padop);
3156 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3160 return newPADOP(type, flags, SvREFCNT_inc(gv));
3162 return newSVOP(type, flags, SvREFCNT_inc(gv));
3167 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3170 NewOp(1101, pvop, 1, PVOP);
3171 pvop->op_type = type;
3172 pvop->op_ppaddr = PL_ppaddr[type];
3174 pvop->op_next = (OP*)pvop;
3175 pvop->op_flags = flags;
3176 if (PL_opargs[type] & OA_RETSCALAR)
3178 if (PL_opargs[type] & OA_TARGET)
3179 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3180 return CHECKOP(type, pvop);
3184 Perl_package(pTHX_ OP *o)
3188 save_hptr(&PL_curstash);
3189 save_item(PL_curstname);
3194 name = SvPV(sv, len);
3195 PL_curstash = gv_stashpvn(name,len,TRUE);
3196 sv_setpvn(PL_curstname, name, len);
3200 deprecate("\"package\" with no arguments");
3201 sv_setpv(PL_curstname,"<none>");
3202 PL_curstash = Nullhv;
3204 PL_hints |= HINT_BLOCK_SCOPE;
3205 PL_copline = NOLINE;
3210 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3216 if (id->op_type != OP_CONST)
3217 Perl_croak(aTHX_ "Module name must be constant");
3221 if (version != Nullop) {
3222 SV *vesv = ((SVOP*)version)->op_sv;
3224 if (arg == Nullop && !SvNIOKp(vesv)) {
3231 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3232 Perl_croak(aTHX_ "Version number must be constant number");
3234 /* Make copy of id so we don't free it twice */
3235 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3237 /* Fake up a method call to VERSION */
3238 meth = newSVpvn("VERSION",7);
3239 sv_upgrade(meth, SVt_PVIV);
3240 (void)SvIOK_on(meth);
3241 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3242 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3243 append_elem(OP_LIST,
3244 prepend_elem(OP_LIST, pack, list(version)),
3245 newSVOP(OP_METHOD_NAMED, 0, meth)));
3249 /* Fake up an import/unimport */
3250 if (arg && arg->op_type == OP_STUB)
3251 imop = arg; /* no import on explicit () */
3252 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3253 imop = Nullop; /* use 5.0; */
3258 /* Make copy of id so we don't free it twice */
3259 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3261 /* Fake up a method call to import/unimport */
3262 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3263 sv_upgrade(meth, SVt_PVIV);
3264 (void)SvIOK_on(meth);
3265 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3266 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3267 append_elem(OP_LIST,
3268 prepend_elem(OP_LIST, pack, list(arg)),
3269 newSVOP(OP_METHOD_NAMED, 0, meth)));
3272 /* Fake up the BEGIN {}, which does its thing immediately. */
3274 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3277 append_elem(OP_LINESEQ,
3278 append_elem(OP_LINESEQ,
3279 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3280 newSTATEOP(0, Nullch, veop)),
3281 newSTATEOP(0, Nullch, imop) ));
3283 PL_hints |= HINT_BLOCK_SCOPE;
3284 PL_copline = NOLINE;
3289 =for apidoc load_module
3291 Loads the module whose name is pointed to by the string part of name.
3292 Note that the actual module name, not its filename, should be given.
3293 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3294 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3295 (or 0 for no flags). ver, if specified, provides version semantics
3296 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3297 arguments can be used to specify arguments to the module's import()
3298 method, similar to C<use Foo::Bar VERSION LIST>.
3303 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3306 va_start(args, ver);
3307 vload_module(flags, name, ver, &args);
3311 #ifdef PERL_IMPLICIT_CONTEXT
3313 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3317 va_start(args, ver);
3318 vload_module(flags, name, ver, &args);
3324 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3326 OP *modname, *veop, *imop;
3328 modname = newSVOP(OP_CONST, 0, name);
3329 modname->op_private |= OPpCONST_BARE;
3331 veop = newSVOP(OP_CONST, 0, ver);
3335 if (flags & PERL_LOADMOD_NOIMPORT) {
3336 imop = sawparens(newNULLLIST());
3338 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3339 imop = va_arg(*args, OP*);
3344 sv = va_arg(*args, SV*);
3346 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3347 sv = va_arg(*args, SV*);
3351 line_t ocopline = PL_copline;
3352 int oexpect = PL_expect;
3354 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3355 veop, modname, imop);
3356 PL_expect = oexpect;
3357 PL_copline = ocopline;
3362 Perl_dofile(pTHX_ OP *term)
3367 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3368 if (!(gv && GvIMPORTED_CV(gv)))
3369 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3371 if (gv && GvIMPORTED_CV(gv)) {
3372 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3373 append_elem(OP_LIST, term,
3374 scalar(newUNOP(OP_RV2CV, 0,
3379 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3385 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3387 return newBINOP(OP_LSLICE, flags,
3388 list(force_list(subscript)),
3389 list(force_list(listval)) );
3393 S_list_assignment(pTHX_ register OP *o)
3398 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3399 o = cUNOPo->op_first;
3401 if (o->op_type == OP_COND_EXPR) {
3402 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3403 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3408 yyerror("Assignment to both a list and a scalar");
3412 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3413 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3414 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3417 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3420 if (o->op_type == OP_RV2SV)
3427 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3432 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3433 return newLOGOP(optype, 0,
3434 mod(scalar(left), optype),
3435 newUNOP(OP_SASSIGN, 0, scalar(right)));
3438 return newBINOP(optype, OPf_STACKED,
3439 mod(scalar(left), optype), scalar(right));
3443 if (list_assignment(left)) {
3447 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3448 left = mod(left, OP_AASSIGN);
3456 curop = list(force_list(left));
3457 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3458 o->op_private = 0 | (flags >> 8);
3459 for (curop = ((LISTOP*)curop)->op_first;
3460 curop; curop = curop->op_sibling)
3462 if (curop->op_type == OP_RV2HV &&
3463 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3464 o->op_private |= OPpASSIGN_HASH;
3468 if (!(left->op_private & OPpLVAL_INTRO)) {
3471 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3472 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3473 if (curop->op_type == OP_GV) {
3474 GV *gv = cGVOPx_gv(curop);
3475 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3477 SvCUR(gv) = PL_generation;
3479 else if (curop->op_type == OP_PADSV ||
3480 curop->op_type == OP_PADAV ||
3481 curop->op_type == OP_PADHV ||
3482 curop->op_type == OP_PADANY) {
3483 SV **svp = AvARRAY(PL_comppad_name);
3484 SV *sv = svp[curop->op_targ];
3485 if (SvCUR(sv) == PL_generation)
3487 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3489 else if (curop->op_type == OP_RV2CV)
3491 else if (curop->op_type == OP_RV2SV ||
3492 curop->op_type == OP_RV2AV ||
3493 curop->op_type == OP_RV2HV ||
3494 curop->op_type == OP_RV2GV) {
3495 if (lastop->op_type != OP_GV) /* funny deref? */
3498 else if (curop->op_type == OP_PUSHRE) {
3499 if (((PMOP*)curop)->op_pmreplroot) {
3501 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3503 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3505 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3507 SvCUR(gv) = PL_generation;
3516 o->op_private |= OPpASSIGN_COMMON;
3518 if (right && right->op_type == OP_SPLIT) {
3520 if ((tmpop = ((LISTOP*)right)->op_first) &&
3521 tmpop->op_type == OP_PUSHRE)
3523 PMOP *pm = (PMOP*)tmpop;
3524 if (left->op_type == OP_RV2AV &&
3525 !(left->op_private & OPpLVAL_INTRO) &&
3526 !(o->op_private & OPpASSIGN_COMMON) )
3528 tmpop = ((UNOP*)left)->op_first;
3529 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3531 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3532 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3534 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3535 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3537 pm->op_pmflags |= PMf_ONCE;
3538 tmpop = cUNOPo->op_first; /* to list (nulled) */
3539 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3540 tmpop->op_sibling = Nullop; /* don't free split */
3541 right->op_next = tmpop->op_next; /* fix starting loc */
3542 op_free(o); /* blow off assign */
3543 right->op_flags &= ~OPf_WANT;
3544 /* "I don't know and I don't care." */
3549 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3550 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3552 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3554 sv_setiv(sv, PL_modcount+1);
3562 right = newOP(OP_UNDEF, 0);
3563 if (right->op_type == OP_READLINE) {
3564 right->op_flags |= OPf_STACKED;
3565 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3568 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3569 o = newBINOP(OP_SASSIGN, flags,
3570 scalar(right), mod(scalar(left), OP_SASSIGN) );
3582 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3584 U32 seq = intro_my();
3587 NewOp(1101, cop, 1, COP);
3588 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3589 cop->op_type = OP_DBSTATE;
3590 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3593 cop->op_type = OP_NEXTSTATE;
3594 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3596 cop->op_flags = flags;
3597 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3599 cop->op_private |= NATIVE_HINTS;
3601 PL_compiling.op_private = cop->op_private;
3602 cop->op_next = (OP*)cop;
3605 cop->cop_label = label;
3606 PL_hints |= HINT_BLOCK_SCOPE;
3609 cop->cop_arybase = PL_curcop->cop_arybase;
3610 if (specialWARN(PL_curcop->cop_warnings))
3611 cop->cop_warnings = PL_curcop->cop_warnings ;
3613 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3614 if (specialCopIO(PL_curcop->cop_io))
3615 cop->cop_io = PL_curcop->cop_io;
3617 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3620 if (PL_copline == NOLINE)
3621 CopLINE_set(cop, CopLINE(PL_curcop));
3623 CopLINE_set(cop, PL_copline);
3624 PL_copline = NOLINE;
3627 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3629 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3631 CopSTASH_set(cop, PL_curstash);
3633 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3634 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3635 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3636 (void)SvIOK_on(*svp);
3637 SvIVX(*svp) = PTR2IV(cop);
3641 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3644 /* "Introduce" my variables to visible status. */
3652 if (! PL_min_intro_pending)
3653 return PL_cop_seqmax;
3655 svp = AvARRAY(PL_comppad_name);
3656 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3657 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3658 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3659 SvNVX(sv) = (NV)PL_cop_seqmax;
3662 PL_min_intro_pending = 0;
3663 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3664 return PL_cop_seqmax++;
3668 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3670 return new_logop(type, flags, &first, &other);
3674 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3678 OP *first = *firstp;
3679 OP *other = *otherp;
3681 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3682 return newBINOP(type, flags, scalar(first), scalar(other));
3684 scalarboolean(first);
3685 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3686 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3687 if (type == OP_AND || type == OP_OR) {
3693 first = *firstp = cUNOPo->op_first;
3695 first->op_next = o->op_next;
3696 cUNOPo->op_first = Nullop;
3700 if (first->op_type == OP_CONST) {
3701 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3702 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3703 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3714 else if (first->op_type == OP_WANTARRAY) {
3720 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3721 OP *k1 = ((UNOP*)first)->op_first;
3722 OP *k2 = k1->op_sibling;
3724 switch (first->op_type)
3727 if (k2 && k2->op_type == OP_READLINE
3728 && (k2->op_flags & OPf_STACKED)
3729 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3731 warnop = k2->op_type;
3736 if (k1->op_type == OP_READDIR
3737 || k1->op_type == OP_GLOB
3738 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3739 || k1->op_type == OP_EACH)
3741 warnop = ((k1->op_type == OP_NULL)
3742 ? k1->op_targ : k1->op_type);
3747 line_t oldline = CopLINE(PL_curcop);
3748 CopLINE_set(PL_curcop, PL_copline);
3749 Perl_warner(aTHX_ WARN_MISC,
3750 "Value of %s%s can be \"0\"; test with defined()",
3752 ((warnop == OP_READLINE || warnop == OP_GLOB)
3753 ? " construct" : "() operator"));
3754 CopLINE_set(PL_curcop, oldline);
3761 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3762 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3764 NewOp(1101, logop, 1, LOGOP);
3766 logop->op_type = type;
3767 logop->op_ppaddr = PL_ppaddr[type];
3768 logop->op_first = first;
3769 logop->op_flags = flags | OPf_KIDS;
3770 logop->op_other = LINKLIST(other);
3771 logop->op_private = 1 | (flags >> 8);
3773 /* establish postfix order */
3774 logop->op_next = LINKLIST(first);
3775 first->op_next = (OP*)logop;
3776 first->op_sibling = other;
3778 o = newUNOP(OP_NULL, 0, (OP*)logop);
3785 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3792 return newLOGOP(OP_AND, 0, first, trueop);
3794 return newLOGOP(OP_OR, 0, first, falseop);
3796 scalarboolean(first);
3797 if (first->op_type == OP_CONST) {
3798 if (SvTRUE(((SVOP*)first)->op_sv)) {
3809 else if (first->op_type == OP_WANTARRAY) {
3813 NewOp(1101, logop, 1, LOGOP);
3814 logop->op_type = OP_COND_EXPR;
3815 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3816 logop->op_first = first;
3817 logop->op_flags = flags | OPf_KIDS;
3818 logop->op_private = 1 | (flags >> 8);
3819 logop->op_other = LINKLIST(trueop);
3820 logop->op_next = LINKLIST(falseop);
3823 /* establish postfix order */
3824 start = LINKLIST(first);
3825 first->op_next = (OP*)logop;
3827 first->op_sibling = trueop;
3828 trueop->op_sibling = falseop;
3829 o = newUNOP(OP_NULL, 0, (OP*)logop);
3831 trueop->op_next = falseop->op_next = o;
3838 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3846 NewOp(1101, range, 1, LOGOP);
3848 range->op_type = OP_RANGE;
3849 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3850 range->op_first = left;
3851 range->op_flags = OPf_KIDS;
3852 leftstart = LINKLIST(left);
3853 range->op_other = LINKLIST(right);
3854 range->op_private = 1 | (flags >> 8);
3856 left->op_sibling = right;
3858 range->op_next = (OP*)range;
3859 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3860 flop = newUNOP(OP_FLOP, 0, flip);
3861 o = newUNOP(OP_NULL, 0, flop);
3863 range->op_next = leftstart;
3865 left->op_next = flip;
3866 right->op_next = flop;
3868 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3869 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3870 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3871 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3873 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3874 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3877 if (!flip->op_private || !flop->op_private)
3878 linklist(o); /* blow off optimizer unless constant */
3884 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3888 int once = block && block->op_flags & OPf_SPECIAL &&
3889 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3892 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3893 return block; /* do {} while 0 does once */
3894 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3895 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3896 expr = newUNOP(OP_DEFINED, 0,
3897 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3898 } else if (expr->op_flags & OPf_KIDS) {
3899 OP *k1 = ((UNOP*)expr)->op_first;
3900 OP *k2 = (k1) ? k1->op_sibling : NULL;
3901 switch (expr->op_type) {
3903 if (k2 && k2->op_type == OP_READLINE
3904 && (k2->op_flags & OPf_STACKED)
3905 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3906 expr = newUNOP(OP_DEFINED, 0, expr);
3910 if (k1->op_type == OP_READDIR
3911 || k1->op_type == OP_GLOB
3912 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3913 || k1->op_type == OP_EACH)
3914 expr = newUNOP(OP_DEFINED, 0, expr);
3920 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3921 o = new_logop(OP_AND, 0, &expr, &listop);
3924 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3926 if (once && o != listop)
3927 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3930 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3932 o->op_flags |= flags;
3934 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3939 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3947 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3948 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3949 expr = newUNOP(OP_DEFINED, 0,
3950 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3951 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3952 OP *k1 = ((UNOP*)expr)->op_first;
3953 OP *k2 = (k1) ? k1->op_sibling : NULL;
3954 switch (expr->op_type) {
3956 if (k2 && k2->op_type == OP_READLINE
3957 && (k2->op_flags & OPf_STACKED)
3958 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3959 expr = newUNOP(OP_DEFINED, 0, expr);
3963 if (k1->op_type == OP_READDIR
3964 || k1->op_type == OP_GLOB
3965 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3966 || k1->op_type == OP_EACH)
3967 expr = newUNOP(OP_DEFINED, 0, expr);
3973 block = newOP(OP_NULL, 0);
3975 block = scope(block);
3979 next = LINKLIST(cont);
3982 OP *unstack = newOP(OP_UNSTACK, 0);
3985 cont = append_elem(OP_LINESEQ, cont, unstack);
3986 if ((line_t)whileline != NOLINE) {
3987 PL_copline = whileline;
3988 cont = append_elem(OP_LINESEQ, cont,
3989 newSTATEOP(0, Nullch, Nullop));
3993 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3994 redo = LINKLIST(listop);
3997 PL_copline = whileline;
3999 o = new_logop(OP_AND, 0, &expr, &listop);
4000 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4001 op_free(expr); /* oops, it's a while (0) */
4003 return Nullop; /* listop already freed by new_logop */
4006 ((LISTOP*)listop)->op_last->op_next =
4007 (o == listop ? redo : LINKLIST(o));
4013 NewOp(1101,loop,1,LOOP);
4014 loop->op_type = OP_ENTERLOOP;
4015 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4016 loop->op_private = 0;
4017 loop->op_next = (OP*)loop;
4020 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4022 loop->op_redoop = redo;
4023 loop->op_lastop = o;
4024 o->op_private |= loopflags;
4027 loop->op_nextop = next;
4029 loop->op_nextop = o;
4031 o->op_flags |= flags;
4032 o->op_private |= (flags >> 8);
4037 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4045 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4046 sv->op_type = OP_RV2GV;
4047 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4049 else if (sv->op_type == OP_PADSV) { /* private variable */
4050 padoff = sv->op_targ;
4055 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4056 padoff = sv->op_targ;
4058 iterflags |= OPf_SPECIAL;
4063 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4067 padoff = find_threadsv("_");
4068 iterflags |= OPf_SPECIAL;
4070 sv = newGVOP(OP_GV, 0, PL_defgv);
4073 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4074 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4075 iterflags |= OPf_STACKED;
4077 else if (expr->op_type == OP_NULL &&
4078 (expr->op_flags & OPf_KIDS) &&
4079 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4081 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4082 * set the STACKED flag to indicate that these values are to be
4083 * treated as min/max values by 'pp_iterinit'.
4085 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4086 LOGOP* range = (LOGOP*) flip->op_first;
4087 OP* left = range->op_first;
4088 OP* right = left->op_sibling;
4091 range->op_flags &= ~OPf_KIDS;
4092 range->op_first = Nullop;
4094 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4095 listop->op_first->op_next = range->op_next;
4096 left->op_next = range->op_other;
4097 right->op_next = (OP*)listop;
4098 listop->op_next = listop->op_first;
4101 expr = (OP*)(listop);
4103 iterflags |= OPf_STACKED;
4106 expr = mod(force_list(expr), OP_GREPSTART);
4110 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4111 append_elem(OP_LIST, expr, scalar(sv))));
4112 assert(!loop->op_next);
4113 #ifdef PL_OP_SLAB_ALLOC
4116 NewOp(1234,tmp,1,LOOP);
4117 Copy(loop,tmp,1,LOOP);
4121 Renew(loop, 1, LOOP);
4123 loop->op_targ = padoff;
4124 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4125 PL_copline = forline;
4126 return newSTATEOP(0, label, wop);
4130 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4135 if (type != OP_GOTO || label->op_type == OP_CONST) {
4136 /* "last()" means "last" */
4137 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4138 o = newOP(type, OPf_SPECIAL);
4140 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4141 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4147 if (label->op_type == OP_ENTERSUB)
4148 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4149 o = newUNOP(type, OPf_STACKED, label);
4151 PL_hints |= HINT_BLOCK_SCOPE;
4156 Perl_cv_undef(pTHX_ CV *cv)
4160 MUTEX_DESTROY(CvMUTEXP(cv));
4161 Safefree(CvMUTEXP(cv));
4164 #endif /* USE_THREADS */
4167 if (CvFILE(cv) && !CvXSUB(cv)) {
4168 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4169 Safefree(CvFILE(cv));
4174 if (!CvXSUB(cv) && CvROOT(cv)) {
4176 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4177 Perl_croak(aTHX_ "Can't undef active subroutine");
4180 Perl_croak(aTHX_ "Can't undef active subroutine");
4181 #endif /* USE_THREADS */
4184 SAVEVPTR(PL_curpad);
4187 op_free(CvROOT(cv));
4188 CvROOT(cv) = Nullop;
4191 SvPOK_off((SV*)cv); /* forget prototype */
4193 /* Since closure prototypes have the same lifetime as the containing
4194 * CV, they don't hold a refcount on the outside CV. This avoids
4195 * the refcount loop between the outer CV (which keeps a refcount to
4196 * the closure prototype in the pad entry for pp_anoncode()) and the
4197 * closure prototype, and the ensuing memory leak. This does not
4198 * apply to closures generated within eval"", since eval"" CVs are
4199 * ephemeral. --GSAR */
4200 if (!CvANON(cv) || CvCLONED(cv)
4201 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4202 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4204 SvREFCNT_dec(CvOUTSIDE(cv));
4206 CvOUTSIDE(cv) = Nullcv;
4208 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4211 if (CvPADLIST(cv)) {
4212 /* may be during global destruction */
4213 if (SvREFCNT(CvPADLIST(cv))) {
4214 I32 i = AvFILLp(CvPADLIST(cv));
4216 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4217 SV* sv = svp ? *svp : Nullsv;
4220 if (sv == (SV*)PL_comppad_name)
4221 PL_comppad_name = Nullav;
4222 else if (sv == (SV*)PL_comppad) {
4223 PL_comppad = Nullav;
4224 PL_curpad = Null(SV**);
4228 SvREFCNT_dec((SV*)CvPADLIST(cv));
4230 CvPADLIST(cv) = Nullav;
4238 #ifdef DEBUG_CLOSURES
4240 S_cv_dump(pTHX_ CV *cv)
4243 CV *outside = CvOUTSIDE(cv);
4244 AV* padlist = CvPADLIST(cv);
4251 PerlIO_printf(Perl_debug_log,
4252 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4254 (CvANON(cv) ? "ANON"
4255 : (cv == PL_main_cv) ? "MAIN"
4256 : CvUNIQUE(cv) ? "UNIQUE"
4257 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4260 : CvANON(outside) ? "ANON"
4261 : (outside == PL_main_cv) ? "MAIN"
4262 : CvUNIQUE(outside) ? "UNIQUE"
4263 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4268 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4269 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4270 pname = AvARRAY(pad_name);
4271 ppad = AvARRAY(pad);
4273 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4274 if (SvPOK(pname[ix]))
4275 PerlIO_printf(Perl_debug_log,
4276 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4277 (int)ix, PTR2UV(ppad[ix]),
4278 SvFAKE(pname[ix]) ? "FAKE " : "",
4280 (IV)I_32(SvNVX(pname[ix])),
4283 #endif /* DEBUGGING */
4285 #endif /* DEBUG_CLOSURES */
4288 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4292 AV* protopadlist = CvPADLIST(proto);
4293 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4294 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4295 SV** pname = AvARRAY(protopad_name);
4296 SV** ppad = AvARRAY(protopad);
4297 I32 fname = AvFILLp(protopad_name);
4298 I32 fpad = AvFILLp(protopad);
4302 assert(!CvUNIQUE(proto));
4306 SAVESPTR(PL_comppad_name);
4307 SAVESPTR(PL_compcv);
4309 cv = PL_compcv = (CV*)NEWSV(1104,0);
4310 sv_upgrade((SV *)cv, SvTYPE(proto));
4311 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4315 New(666, CvMUTEXP(cv), 1, perl_mutex);
4316 MUTEX_INIT(CvMUTEXP(cv));
4318 #endif /* USE_THREADS */
4320 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4321 : savepv(CvFILE(proto));
4323 CvFILE(cv) = CvFILE(proto);
4325 CvGV(cv) = CvGV(proto);
4326 CvSTASH(cv) = CvSTASH(proto);
4327 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4328 CvSTART(cv) = CvSTART(proto);
4330 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4333 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4335 PL_comppad_name = newAV();
4336 for (ix = fname; ix >= 0; ix--)
4337 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4339 PL_comppad = newAV();
4341 comppadlist = newAV();
4342 AvREAL_off(comppadlist);
4343 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4344 av_store(comppadlist, 1, (SV*)PL_comppad);
4345 CvPADLIST(cv) = comppadlist;
4346 av_fill(PL_comppad, AvFILLp(protopad));
4347 PL_curpad = AvARRAY(PL_comppad);
4349 av = newAV(); /* will be @_ */
4351 av_store(PL_comppad, 0, (SV*)av);
4352 AvFLAGS(av) = AVf_REIFY;
4354 for (ix = fpad; ix > 0; ix--) {
4355 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4356 if (namesv && namesv != &PL_sv_undef) {
4357 char *name = SvPVX(namesv); /* XXX */
4358 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4359 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4360 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4362 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4364 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4366 else { /* our own lexical */
4369 /* anon code -- we'll come back for it */
4370 sv = SvREFCNT_inc(ppad[ix]);
4372 else if (*name == '@')
4374 else if (*name == '%')
4383 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4384 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4387 SV* sv = NEWSV(0,0);
4393 /* Now that vars are all in place, clone nested closures. */
4395 for (ix = fpad; ix > 0; ix--) {
4396 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4398 && namesv != &PL_sv_undef
4399 && !(SvFLAGS(namesv) & SVf_FAKE)
4400 && *SvPVX(namesv) == '&'
4401 && CvCLONE(ppad[ix]))
4403 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4404 SvREFCNT_dec(ppad[ix]);
4407 PL_curpad[ix] = (SV*)kid;
4411 #ifdef DEBUG_CLOSURES
4412 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4414 PerlIO_printf(Perl_debug_log, " from:\n");
4416 PerlIO_printf(Perl_debug_log, " to:\n");
4423 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4425 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4427 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4434 Perl_cv_clone(pTHX_ CV *proto)
4437 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4438 cv = cv_clone2(proto, CvOUTSIDE(proto));
4439 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4444 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4446 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4447 SV* msg = sv_newmortal();
4451 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4452 sv_setpv(msg, "Prototype mismatch:");
4454 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4456 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4457 sv_catpv(msg, " vs ");
4459 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4461 sv_catpv(msg, "none");
4462 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4466 static void const_sv_xsub(pTHXo_ CV* cv);
4469 =for apidoc cv_const_sv
4471 If C<cv> is a constant sub eligible for inlining. returns the constant
4472 value returned by the sub. Otherwise, returns NULL.
4474 Constant subs can be created with C<newCONSTSUB> or as described in
4475 L<perlsub/"Constant Functions">.
4480 Perl_cv_const_sv(pTHX_ CV *cv)
4482 if (!cv || !CvCONST(cv))
4484 return (SV*)CvXSUBANY(cv).any_ptr;
4488 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4495 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4496 o = cLISTOPo->op_first->op_sibling;
4498 for (; o; o = o->op_next) {
4499 OPCODE type = o->op_type;
4501 if (sv && o->op_next == o)
4503 if (o->op_next != o) {
4504 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4506 if (type == OP_DBSTATE)
4509 if (type == OP_LEAVESUB || type == OP_RETURN)
4513 if (type == OP_CONST && cSVOPo->op_sv)
4515 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4516 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4517 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4521 /* We get here only from cv_clone2() while creating a closure.
4522 Copy the const value here instead of in cv_clone2 so that
4523 SvREADONLY_on doesn't lead to problems when leaving
4528 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4540 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4550 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4554 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4556 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4560 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4566 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4571 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4572 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4573 SV *sv = sv_newmortal();
4574 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4575 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4580 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4581 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4591 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4592 maximum a prototype before. */
4593 if (SvTYPE(gv) > SVt_NULL) {
4594 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4595 && ckWARN_d(WARN_PROTOTYPE))
4597 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4599 cv_ckproto((CV*)gv, NULL, ps);
4602 sv_setpv((SV*)gv, ps);
4604 sv_setiv((SV*)gv, -1);
4605 SvREFCNT_dec(PL_compcv);
4606 cv = PL_compcv = NULL;
4607 PL_sub_generation++;
4611 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4613 #ifdef GV_UNIQUE_CHECK
4614 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4615 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4619 if (!block || !ps || *ps || attrs)
4622 const_sv = op_const_sv(block, Nullcv);
4625 bool exists = CvROOT(cv) || CvXSUB(cv);
4627 #ifdef GV_UNIQUE_CHECK
4628 if (exists && GvUNIQUE(gv)) {
4629 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4633 /* if the subroutine doesn't exist and wasn't pre-declared
4634 * with a prototype, assume it will be AUTOLOADed,
4635 * skipping the prototype check
4637 if (exists || SvPOK(cv))
4638 cv_ckproto(cv, gv, ps);
4639 /* already defined (or promised)? */
4640 if (exists || GvASSUMECV(gv)) {
4641 if (!block && !attrs) {
4642 /* just a "sub foo;" when &foo is already defined */
4643 SAVEFREESV(PL_compcv);
4646 /* ahem, death to those who redefine active sort subs */
4647 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4648 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4650 if (ckWARN(WARN_REDEFINE)
4652 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4654 line_t oldline = CopLINE(PL_curcop);
4655 CopLINE_set(PL_curcop, PL_copline);
4656 Perl_warner(aTHX_ WARN_REDEFINE,
4657 CvCONST(cv) ? "Constant subroutine %s redefined"
4658 : "Subroutine %s redefined", name);
4659 CopLINE_set(PL_curcop, oldline);
4667 SvREFCNT_inc(const_sv);
4669 assert(!CvROOT(cv) && !CvCONST(cv));
4670 sv_setpv((SV*)cv, ""); /* prototype is "" */
4671 CvXSUBANY(cv).any_ptr = const_sv;
4672 CvXSUB(cv) = const_sv_xsub;
4677 cv = newCONSTSUB(NULL, name, const_sv);
4680 SvREFCNT_dec(PL_compcv);
4682 PL_sub_generation++;
4689 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4690 * before we clobber PL_compcv.
4694 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4695 stash = GvSTASH(CvGV(cv));
4696 else if (CvSTASH(cv))
4697 stash = CvSTASH(cv);
4699 stash = PL_curstash;
4702 /* possibly about to re-define existing subr -- ignore old cv */
4703 rcv = (SV*)PL_compcv;
4704 if (name && GvSTASH(gv))
4705 stash = GvSTASH(gv);
4707 stash = PL_curstash;
4709 apply_attrs(stash, rcv, attrs);
4711 if (cv) { /* must reuse cv if autoloaded */
4713 /* got here with just attrs -- work done, so bug out */
4714 SAVEFREESV(PL_compcv);
4718 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4719 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4720 CvOUTSIDE(PL_compcv) = 0;
4721 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4722 CvPADLIST(PL_compcv) = 0;
4723 /* inner references to PL_compcv must be fixed up ... */
4725 AV *padlist = CvPADLIST(cv);
4726 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4727 AV *comppad = (AV*)AvARRAY(padlist)[1];
4728 SV **namepad = AvARRAY(comppad_name);
4729 SV **curpad = AvARRAY(comppad);
4730 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4731 SV *namesv = namepad[ix];
4732 if (namesv && namesv != &PL_sv_undef
4733 && *SvPVX(namesv) == '&')
4735 CV *innercv = (CV*)curpad[ix];
4736 if (CvOUTSIDE(innercv) == PL_compcv) {
4737 CvOUTSIDE(innercv) = cv;
4738 if (!CvANON(innercv) || CvCLONED(innercv)) {
4739 (void)SvREFCNT_inc(cv);
4740 SvREFCNT_dec(PL_compcv);
4746 /* ... before we throw it away */
4747 SvREFCNT_dec(PL_compcv);
4754 PL_sub_generation++;
4758 CvFILE_set_from_cop(cv, PL_curcop);
4759 CvSTASH(cv) = PL_curstash;
4762 if (!CvMUTEXP(cv)) {
4763 New(666, CvMUTEXP(cv), 1, perl_mutex);
4764 MUTEX_INIT(CvMUTEXP(cv));
4766 #endif /* USE_THREADS */
4769 sv_setpv((SV*)cv, ps);
4771 if (PL_error_count) {
4775 char *s = strrchr(name, ':');
4777 if (strEQ(s, "BEGIN")) {
4779 "BEGIN not safe after errors--compilation aborted";
4780 if (PL_in_eval & EVAL_KEEPERR)
4781 Perl_croak(aTHX_ not_safe);
4783 /* force display of errors found but not reported */
4784 sv_catpv(ERRSV, not_safe);
4785 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4793 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4794 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4797 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4798 mod(scalarseq(block), OP_LEAVESUBLV));
4801 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4803 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4804 OpREFCNT_set(CvROOT(cv), 1);
4805 CvSTART(cv) = LINKLIST(CvROOT(cv));
4806 CvROOT(cv)->op_next = 0;
4809 /* now that optimizer has done its work, adjust pad values */
4811 SV **namep = AvARRAY(PL_comppad_name);
4812 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4815 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4818 * The only things that a clonable function needs in its
4819 * pad are references to outer lexicals and anonymous subs.
4820 * The rest are created anew during cloning.
4822 if (!((namesv = namep[ix]) != Nullsv &&
4823 namesv != &PL_sv_undef &&
4825 *SvPVX(namesv) == '&')))
4827 SvREFCNT_dec(PL_curpad[ix]);
4828 PL_curpad[ix] = Nullsv;
4831 assert(!CvCONST(cv));
4832 if (ps && !*ps && op_const_sv(block, cv))
4836 AV *av = newAV(); /* Will be @_ */
4838 av_store(PL_comppad, 0, (SV*)av);
4839 AvFLAGS(av) = AVf_REIFY;
4841 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4842 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4844 if (!SvPADMY(PL_curpad[ix]))
4845 SvPADTMP_on(PL_curpad[ix]);
4849 /* If a potential closure prototype, don't keep a refcount on
4850 * outer CV, unless the latter happens to be a passing eval"".
4851 * This is okay as the lifetime of the prototype is tied to the
4852 * lifetime of the outer CV. Avoids memory leak due to reference
4854 if (!name && CvOUTSIDE(cv)
4855 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4856 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4858 SvREFCNT_dec(CvOUTSIDE(cv));
4861 if (name || aname) {
4863 char *tname = (name ? name : aname);
4865 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4866 SV *sv = NEWSV(0,0);
4867 SV *tmpstr = sv_newmortal();
4868 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4872 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4874 (long)PL_subline, (long)CopLINE(PL_curcop));
4875 gv_efullname3(tmpstr, gv, Nullch);
4876 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4877 hv = GvHVn(db_postponed);
4878 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4879 && (pcv = GvCV(db_postponed)))
4885 call_sv((SV*)pcv, G_DISCARD);
4889 if ((s = strrchr(tname,':')))
4894 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4897 if (strEQ(s, "BEGIN")) {
4898 I32 oldscope = PL_scopestack_ix;
4900 SAVECOPFILE(&PL_compiling);
4901 SAVECOPLINE(&PL_compiling);
4903 sv_setsv(PL_rs, PL_nrs);
4906 PL_beginav = newAV();
4907 DEBUG_x( dump_sub(gv) );
4908 av_push(PL_beginav, (SV*)cv);
4909 GvCV(gv) = 0; /* cv has been hijacked */
4910 call_list(oldscope, PL_beginav);
4912 PL_curcop = &PL_compiling;
4913 PL_compiling.op_private = PL_hints;
4916 else if (strEQ(s, "END") && !PL_error_count) {
4919 DEBUG_x( dump_sub(gv) );
4920 av_unshift(PL_endav, 1);
4921 av_store(PL_endav, 0, (SV*)cv);
4922 GvCV(gv) = 0; /* cv has been hijacked */
4924 else if (strEQ(s, "CHECK") && !PL_error_count) {
4926 PL_checkav = newAV();
4927 DEBUG_x( dump_sub(gv) );
4928 if (PL_main_start && ckWARN(WARN_VOID))
4929 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4930 av_unshift(PL_checkav, 1);
4931 av_store(PL_checkav, 0, (SV*)cv);
4932 GvCV(gv) = 0; /* cv has been hijacked */
4934 else if (strEQ(s, "INIT") && !PL_error_count) {
4936 PL_initav = newAV();
4937 DEBUG_x( dump_sub(gv) );
4938 if (PL_main_start && ckWARN(WARN_VOID))
4939 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4940 av_push(PL_initav, (SV*)cv);
4941 GvCV(gv) = 0; /* cv has been hijacked */
4946 PL_copline = NOLINE;
4951 /* XXX unsafe for threads if eval_owner isn't held */
4953 =for apidoc newCONSTSUB
4955 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4956 eligible for inlining at compile-time.
4962 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4968 SAVECOPLINE(PL_curcop);
4969 CopLINE_set(PL_curcop, PL_copline);
4972 PL_hints &= ~HINT_BLOCK_SCOPE;
4975 SAVESPTR(PL_curstash);
4976 SAVECOPSTASH(PL_curcop);
4977 PL_curstash = stash;
4979 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4981 CopSTASH(PL_curcop) = stash;
4985 cv = newXS(name, const_sv_xsub, __FILE__);
4986 CvXSUBANY(cv).any_ptr = sv;
4988 sv_setpv((SV*)cv, ""); /* prototype is "" */
4996 =for apidoc U||newXS
4998 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5004 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5006 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5009 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5011 /* just a cached method */
5015 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5016 /* already defined (or promised) */
5017 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5018 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5019 line_t oldline = CopLINE(PL_curcop);
5020 if (PL_copline != NOLINE)
5021 CopLINE_set(PL_curcop, PL_copline);
5022 Perl_warner(aTHX_ WARN_REDEFINE,
5023 CvCONST(cv) ? "Constant subroutine %s redefined"
5024 : "Subroutine %s redefined"
5026 CopLINE_set(PL_curcop, oldline);
5033 if (cv) /* must reuse cv if autoloaded */
5036 cv = (CV*)NEWSV(1105,0);
5037 sv_upgrade((SV *)cv, SVt_PVCV);
5041 PL_sub_generation++;
5046 New(666, CvMUTEXP(cv), 1, perl_mutex);
5047 MUTEX_INIT(CvMUTEXP(cv));
5049 #endif /* USE_THREADS */
5050 (void)gv_fetchfile(filename);
5051 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5052 an external constant string */
5053 CvXSUB(cv) = subaddr;
5056 char *s = strrchr(name,':');
5062 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5065 if (strEQ(s, "BEGIN")) {
5067 PL_beginav = newAV();
5068 av_push(PL_beginav, (SV*)cv);
5069 GvCV(gv) = 0; /* cv has been hijacked */
5071 else if (strEQ(s, "END")) {
5074 av_unshift(PL_endav, 1);
5075 av_store(PL_endav, 0, (SV*)cv);
5076 GvCV(gv) = 0; /* cv has been hijacked */
5078 else if (strEQ(s, "CHECK")) {
5080 PL_checkav = newAV();
5081 if (PL_main_start && ckWARN(WARN_VOID))
5082 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5083 av_unshift(PL_checkav, 1);
5084 av_store(PL_checkav, 0, (SV*)cv);
5085 GvCV(gv) = 0; /* cv has been hijacked */
5087 else if (strEQ(s, "INIT")) {
5089 PL_initav = newAV();
5090 if (PL_main_start && ckWARN(WARN_VOID))
5091 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5092 av_push(PL_initav, (SV*)cv);
5093 GvCV(gv) = 0; /* cv has been hijacked */
5104 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5113 name = SvPVx(cSVOPo->op_sv, n_a);
5116 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5117 #ifdef GV_UNIQUE_CHECK
5119 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5123 if ((cv = GvFORM(gv))) {
5124 if (ckWARN(WARN_REDEFINE)) {
5125 line_t oldline = CopLINE(PL_curcop);
5127 CopLINE_set(PL_curcop, PL_copline);
5128 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5129 CopLINE_set(PL_curcop, oldline);
5136 CvFILE_set_from_cop(cv, PL_curcop);
5138 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5139 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5140 SvPADTMP_on(PL_curpad[ix]);
5143 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5144 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5145 OpREFCNT_set(CvROOT(cv), 1);
5146 CvSTART(cv) = LINKLIST(CvROOT(cv));
5147 CvROOT(cv)->op_next = 0;
5150 PL_copline = NOLINE;
5155 Perl_newANONLIST(pTHX_ OP *o)
5157 return newUNOP(OP_REFGEN, 0,
5158 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5162 Perl_newANONHASH(pTHX_ OP *o)
5164 return newUNOP(OP_REFGEN, 0,
5165 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5169 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5171 return newANONATTRSUB(floor, proto, Nullop, block);
5175 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5177 return newUNOP(OP_REFGEN, 0,
5178 newSVOP(OP_ANONCODE, 0,
5179 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5183 Perl_oopsAV(pTHX_ OP *o)
5185 switch (o->op_type) {
5187 o->op_type = OP_PADAV;
5188 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5189 return ref(o, OP_RV2AV);
5192 o->op_type = OP_RV2AV;
5193 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5198 if (ckWARN_d(WARN_INTERNAL))
5199 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5206 Perl_oopsHV(pTHX_ OP *o)
5208 switch (o->op_type) {
5211 o->op_type = OP_PADHV;
5212 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5213 return ref(o, OP_RV2HV);
5217 o->op_type = OP_RV2HV;
5218 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5223 if (ckWARN_d(WARN_INTERNAL))
5224 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5231 Perl_newAVREF(pTHX_ OP *o)
5233 if (o->op_type == OP_PADANY) {
5234 o->op_type = OP_PADAV;
5235 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5238 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5239 && ckWARN(WARN_DEPRECATED)) {
5240 Perl_warner(aTHX_ WARN_DEPRECATED,
5241 "Using an array as a reference is deprecated");
5243 return newUNOP(OP_RV2AV, 0, scalar(o));
5247 Perl_newGVREF(pTHX_ I32 type, OP *o)
5249 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5250 return newUNOP(OP_NULL, 0, o);
5251 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5255 Perl_newHVREF(pTHX_ OP *o)
5257 if (o->op_type == OP_PADANY) {
5258 o->op_type = OP_PADHV;
5259 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5262 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5263 && ckWARN(WARN_DEPRECATED)) {
5264 Perl_warner(aTHX_ WARN_DEPRECATED,
5265 "Using a hash as a reference is deprecated");
5267 return newUNOP(OP_RV2HV, 0, scalar(o));
5271 Perl_oopsCV(pTHX_ OP *o)
5273 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5279 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5281 return newUNOP(OP_RV2CV, flags, scalar(o));
5285 Perl_newSVREF(pTHX_ OP *o)
5287 if (o->op_type == OP_PADANY) {
5288 o->op_type = OP_PADSV;
5289 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5292 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5293 o->op_flags |= OPpDONE_SVREF;
5296 return newUNOP(OP_RV2SV, 0, scalar(o));
5299 /* Check routines. */
5302 Perl_ck_anoncode(pTHX_ OP *o)
5307 name = NEWSV(1106,0);
5308 sv_upgrade(name, SVt_PVNV);
5309 sv_setpvn(name, "&", 1);
5312 ix = pad_alloc(o->op_type, SVs_PADMY);
5313 av_store(PL_comppad_name, ix, name);
5314 av_store(PL_comppad, ix, cSVOPo->op_sv);
5315 SvPADMY_on(cSVOPo->op_sv);
5316 cSVOPo->op_sv = Nullsv;
5317 cSVOPo->op_targ = ix;
5322 Perl_ck_bitop(pTHX_ OP *o)
5324 o->op_private = PL_hints;
5329 Perl_ck_concat(pTHX_ OP *o)
5331 if (cUNOPo->op_first->op_type == OP_CONCAT)
5332 o->op_flags |= OPf_STACKED;
5337 Perl_ck_spair(pTHX_ OP *o)
5339 if (o->op_flags & OPf_KIDS) {
5342 OPCODE type = o->op_type;
5343 o = modkids(ck_fun(o), type);
5344 kid = cUNOPo->op_first;
5345 newop = kUNOP->op_first->op_sibling;
5347 (newop->op_sibling ||
5348 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5349 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5350 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5354 op_free(kUNOP->op_first);
5355 kUNOP->op_first = newop;
5357 o->op_ppaddr = PL_ppaddr[++o->op_type];
5362 Perl_ck_delete(pTHX_ OP *o)
5366 if (o->op_flags & OPf_KIDS) {
5367 OP *kid = cUNOPo->op_first;
5368 switch (kid->op_type) {
5370 o->op_flags |= OPf_SPECIAL;
5373 o->op_private |= OPpSLICE;
5376 o->op_flags |= OPf_SPECIAL;
5381 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5382 PL_op_desc[o->op_type]);
5390 Perl_ck_eof(pTHX_ OP *o)
5392 I32 type = o->op_type;
5394 if (o->op_flags & OPf_KIDS) {
5395 if (cLISTOPo->op_first->op_type == OP_STUB) {
5397 o = newUNOP(type, OPf_SPECIAL,
5398 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5406 Perl_ck_eval(pTHX_ OP *o)
5408 PL_hints |= HINT_BLOCK_SCOPE;
5409 if (o->op_flags & OPf_KIDS) {
5410 SVOP *kid = (SVOP*)cUNOPo->op_first;
5413 o->op_flags &= ~OPf_KIDS;
5416 else if (kid->op_type == OP_LINESEQ) {
5419 kid->op_next = o->op_next;
5420 cUNOPo->op_first = 0;
5423 NewOp(1101, enter, 1, LOGOP);
5424 enter->op_type = OP_ENTERTRY;
5425 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5426 enter->op_private = 0;
5428 /* establish postfix order */
5429 enter->op_next = (OP*)enter;
5431 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5432 o->op_type = OP_LEAVETRY;
5433 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5434 enter->op_other = o;
5442 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5444 o->op_targ = (PADOFFSET)PL_hints;
5449 Perl_ck_exit(pTHX_ OP *o)
5452 HV *table = GvHV(PL_hintgv);
5454 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5455 if (svp && *svp && SvTRUE(*svp))
5456 o->op_private |= OPpEXIT_VMSISH;
5463 Perl_ck_exec(pTHX_ OP *o)
5466 if (o->op_flags & OPf_STACKED) {
5468 kid = cUNOPo->op_first->op_sibling;
5469 if (kid->op_type == OP_RV2GV)
5478 Perl_ck_exists(pTHX_ OP *o)
5481 if (o->op_flags & OPf_KIDS) {
5482 OP *kid = cUNOPo->op_first;
5483 if (kid->op_type == OP_ENTERSUB) {
5484 (void) ref(kid, o->op_type);
5485 if (kid->op_type != OP_RV2CV && !PL_error_count)
5486 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5487 PL_op_desc[o->op_type]);
5488 o->op_private |= OPpEXISTS_SUB;
5490 else if (kid->op_type == OP_AELEM)
5491 o->op_flags |= OPf_SPECIAL;
5492 else if (kid->op_type != OP_HELEM)
5493 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5494 PL_op_desc[o->op_type]);
5502 Perl_ck_gvconst(pTHX_ register OP *o)
5504 o = fold_constants(o);
5505 if (o->op_type == OP_CONST)
5512 Perl_ck_rvconst(pTHX_ register OP *o)
5514 SVOP *kid = (SVOP*)cUNOPo->op_first;
5516 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5517 if (kid->op_type == OP_CONST) {
5521 SV *kidsv = kid->op_sv;
5524 /* Is it a constant from cv_const_sv()? */
5525 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5526 SV *rsv = SvRV(kidsv);
5527 int svtype = SvTYPE(rsv);
5528 char *badtype = Nullch;
5530 switch (o->op_type) {
5532 if (svtype > SVt_PVMG)
5533 badtype = "a SCALAR";
5536 if (svtype != SVt_PVAV)
5537 badtype = "an ARRAY";
5540 if (svtype != SVt_PVHV) {
5541 if (svtype == SVt_PVAV) { /* pseudohash? */
5542 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5543 if (ksv && SvROK(*ksv)
5544 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5553 if (svtype != SVt_PVCV)
5558 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5561 name = SvPV(kidsv, n_a);
5562 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5563 char *badthing = Nullch;
5564 switch (o->op_type) {
5566 badthing = "a SCALAR";
5569 badthing = "an ARRAY";
5572 badthing = "a HASH";
5577 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5581 * This is a little tricky. We only want to add the symbol if we
5582 * didn't add it in the lexer. Otherwise we get duplicate strict
5583 * warnings. But if we didn't add it in the lexer, we must at
5584 * least pretend like we wanted to add it even if it existed before,
5585 * or we get possible typo warnings. OPpCONST_ENTERED says
5586 * whether the lexer already added THIS instance of this symbol.
5588 iscv = (o->op_type == OP_RV2CV) * 2;
5590 gv = gv_fetchpv(name,
5591 iscv | !(kid->op_private & OPpCONST_ENTERED),
5594 : o->op_type == OP_RV2SV
5596 : o->op_type == OP_RV2AV
5598 : o->op_type == OP_RV2HV
5601 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5603 kid->op_type = OP_GV;
5604 SvREFCNT_dec(kid->op_sv);
5606 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5607 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5608 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5610 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5612 kid->op_sv = SvREFCNT_inc(gv);
5614 kid->op_private = 0;
5615 kid->op_ppaddr = PL_ppaddr[OP_GV];
5622 Perl_ck_ftst(pTHX_ OP *o)
5624 I32 type = o->op_type;
5626 if (o->op_flags & OPf_REF) {
5629 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5630 SVOP *kid = (SVOP*)cUNOPo->op_first;
5632 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5634 OP *newop = newGVOP(type, OPf_REF,
5635 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5642 if (type == OP_FTTTY)
5643 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5646 o = newUNOP(type, 0, newDEFSVOP());
5652 Perl_ck_fun(pTHX_ OP *o)
5658 int type = o->op_type;
5659 register I32 oa = PL_opargs[type] >> OASHIFT;
5661 if (o->op_flags & OPf_STACKED) {
5662 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5665 return no_fh_allowed(o);
5668 if (o->op_flags & OPf_KIDS) {
5670 tokid = &cLISTOPo->op_first;
5671 kid = cLISTOPo->op_first;
5672 if (kid->op_type == OP_PUSHMARK ||
5673 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5675 tokid = &kid->op_sibling;
5676 kid = kid->op_sibling;
5678 if (!kid && PL_opargs[type] & OA_DEFGV)
5679 *tokid = kid = newDEFSVOP();
5683 sibl = kid->op_sibling;
5686 /* list seen where single (scalar) arg expected? */
5687 if (numargs == 1 && !(oa >> 4)
5688 && kid->op_type == OP_LIST && type != OP_SCALAR)
5690 return too_many_arguments(o,PL_op_desc[type]);
5703 if ((type == OP_PUSH || type == OP_UNSHIFT)
5704 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5705 Perl_warner(aTHX_ WARN_SYNTAX,
5706 "Useless use of %s with no values",
5709 if (kid->op_type == OP_CONST &&
5710 (kid->op_private & OPpCONST_BARE))
5712 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5713 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5714 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5715 if (ckWARN(WARN_DEPRECATED))
5716 Perl_warner(aTHX_ WARN_DEPRECATED,
5717 "Array @%s missing the @ in argument %"IVdf" of %s()",
5718 name, (IV)numargs, PL_op_desc[type]);
5721 kid->op_sibling = sibl;
5724 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5725 bad_type(numargs, "array", PL_op_desc[type], kid);
5729 if (kid->op_type == OP_CONST &&
5730 (kid->op_private & OPpCONST_BARE))
5732 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5733 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5734 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5735 if (ckWARN(WARN_DEPRECATED))
5736 Perl_warner(aTHX_ WARN_DEPRECATED,
5737 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5738 name, (IV)numargs, PL_op_desc[type]);
5741 kid->op_sibling = sibl;
5744 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5745 bad_type(numargs, "hash", PL_op_desc[type], kid);
5750 OP *newop = newUNOP(OP_NULL, 0, kid);
5751 kid->op_sibling = 0;
5753 newop->op_next = newop;
5755 kid->op_sibling = sibl;
5760 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5761 if (kid->op_type == OP_CONST &&
5762 (kid->op_private & OPpCONST_BARE))
5764 OP *newop = newGVOP(OP_GV, 0,
5765 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5770 else if (kid->op_type == OP_READLINE) {
5771 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5772 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5775 I32 flags = OPf_SPECIAL;
5779 /* is this op a FH constructor? */
5780 if (is_handle_constructor(o,numargs)) {
5781 char *name = Nullch;
5785 /* Set a flag to tell rv2gv to vivify
5786 * need to "prove" flag does not mean something
5787 * else already - NI-S 1999/05/07
5790 if (kid->op_type == OP_PADSV) {
5791 SV **namep = av_fetch(PL_comppad_name,
5793 if (namep && *namep)
5794 name = SvPV(*namep, len);
5796 else if (kid->op_type == OP_RV2SV
5797 && kUNOP->op_first->op_type == OP_GV)
5799 GV *gv = cGVOPx_gv(kUNOP->op_first);
5801 len = GvNAMELEN(gv);
5803 else if (kid->op_type == OP_AELEM
5804 || kid->op_type == OP_HELEM)
5806 name = "__ANONIO__";
5812 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5813 namesv = PL_curpad[targ];
5814 (void)SvUPGRADE(namesv, SVt_PV);
5816 sv_setpvn(namesv, "$", 1);
5817 sv_catpvn(namesv, name, len);
5820 kid->op_sibling = 0;
5821 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5822 kid->op_targ = targ;
5823 kid->op_private |= priv;
5825 kid->op_sibling = sibl;
5831 mod(scalar(kid), type);
5835 tokid = &kid->op_sibling;
5836 kid = kid->op_sibling;
5838 o->op_private |= numargs;
5840 return too_many_arguments(o,PL_op_desc[o->op_type]);
5843 else if (PL_opargs[type] & OA_DEFGV) {
5845 return newUNOP(type, 0, newDEFSVOP());
5849 while (oa & OA_OPTIONAL)
5851 if (oa && oa != OA_LIST)
5852 return too_few_arguments(o,PL_op_desc[o->op_type]);
5858 Perl_ck_glob(pTHX_ OP *o)
5863 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5864 append_elem(OP_GLOB, o, newDEFSVOP());
5866 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5867 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5869 #if !defined(PERL_EXTERNAL_GLOB)
5870 /* XXX this can be tightened up and made more failsafe. */
5874 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5876 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5877 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5878 GvCV(gv) = GvCV(glob_gv);
5879 SvREFCNT_inc((SV*)GvCV(gv));
5880 GvIMPORTED_CV_on(gv);
5883 #endif /* PERL_EXTERNAL_GLOB */
5885 if (gv && GvIMPORTED_CV(gv)) {
5886 append_elem(OP_GLOB, o,
5887 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5888 o->op_type = OP_LIST;
5889 o->op_ppaddr = PL_ppaddr[OP_LIST];
5890 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5891 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5892 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5893 append_elem(OP_LIST, o,
5894 scalar(newUNOP(OP_RV2CV, 0,
5895 newGVOP(OP_GV, 0, gv)))));
5896 o = newUNOP(OP_NULL, 0, ck_subr(o));
5897 o->op_targ = OP_GLOB; /* hint at what it used to be */
5900 gv = newGVgen("main");
5902 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5908 Perl_ck_grep(pTHX_ OP *o)
5912 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5914 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5915 NewOp(1101, gwop, 1, LOGOP);
5917 if (o->op_flags & OPf_STACKED) {
5920 kid = cLISTOPo->op_first->op_sibling;
5921 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5924 kid->op_next = (OP*)gwop;
5925 o->op_flags &= ~OPf_STACKED;
5927 kid = cLISTOPo->op_first->op_sibling;
5928 if (type == OP_MAPWHILE)
5935 kid = cLISTOPo->op_first->op_sibling;
5936 if (kid->op_type != OP_NULL)
5937 Perl_croak(aTHX_ "panic: ck_grep");
5938 kid = kUNOP->op_first;
5940 gwop->op_type = type;
5941 gwop->op_ppaddr = PL_ppaddr[type];
5942 gwop->op_first = listkids(o);
5943 gwop->op_flags |= OPf_KIDS;
5944 gwop->op_private = 1;
5945 gwop->op_other = LINKLIST(kid);
5946 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5947 kid->op_next = (OP*)gwop;
5949 kid = cLISTOPo->op_first->op_sibling;
5950 if (!kid || !kid->op_sibling)
5951 return too_few_arguments(o,PL_op_desc[o->op_type]);
5952 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5953 mod(kid, OP_GREPSTART);
5959 Perl_ck_index(pTHX_ OP *o)
5961 if (o->op_flags & OPf_KIDS) {
5962 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5964 kid = kid->op_sibling; /* get past "big" */
5965 if (kid && kid->op_type == OP_CONST)
5966 fbm_compile(((SVOP*)kid)->op_sv, 0);
5972 Perl_ck_lengthconst(pTHX_ OP *o)
5974 /* XXX length optimization goes here */
5979 Perl_ck_lfun(pTHX_ OP *o)
5981 OPCODE type = o->op_type;
5982 return modkids(ck_fun(o), type);
5986 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5988 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5989 switch (cUNOPo->op_first->op_type) {
5991 /* This is needed for
5992 if (defined %stash::)
5993 to work. Do not break Tk.
5995 break; /* Globals via GV can be undef */
5997 case OP_AASSIGN: /* Is this a good idea? */
5998 Perl_warner(aTHX_ WARN_DEPRECATED,
5999 "defined(@array) is deprecated");
6000 Perl_warner(aTHX_ WARN_DEPRECATED,
6001 "\t(Maybe you should just omit the defined()?)\n");
6004 /* This is needed for
6005 if (defined %stash::)
6006 to work. Do not break Tk.
6008 break; /* Globals via GV can be undef */
6010 Perl_warner(aTHX_ WARN_DEPRECATED,
6011 "defined(%%hash) is deprecated");
6012 Perl_warner(aTHX_ WARN_DEPRECATED,
6013 "\t(Maybe you should just omit the defined()?)\n");
6024 Perl_ck_rfun(pTHX_ OP *o)
6026 OPCODE type = o->op_type;
6027 return refkids(ck_fun(o), type);
6031 Perl_ck_listiob(pTHX_ OP *o)
6035 kid = cLISTOPo->op_first;
6038 kid = cLISTOPo->op_first;
6040 if (kid->op_type == OP_PUSHMARK)
6041 kid = kid->op_sibling;
6042 if (kid && o->op_flags & OPf_STACKED)
6043 kid = kid->op_sibling;
6044 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6045 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6046 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6047 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6048 cLISTOPo->op_first->op_sibling = kid;
6049 cLISTOPo->op_last = kid;
6050 kid = kid->op_sibling;
6055 append_elem(o->op_type, o, newDEFSVOP());
6061 Perl_ck_sassign(pTHX_ OP *o)
6063 OP *kid = cLISTOPo->op_first;
6064 /* has a disposable target? */
6065 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6066 && !(kid->op_flags & OPf_STACKED)
6067 /* Cannot steal the second time! */
6068 && !(kid->op_private & OPpTARGET_MY))
6070 OP *kkid = kid->op_sibling;
6072 /* Can just relocate the target. */
6073 if (kkid && kkid->op_type == OP_PADSV
6074 && !(kkid->op_private & OPpLVAL_INTRO))
6076 kid->op_targ = kkid->op_targ;
6078 /* Now we do not need PADSV and SASSIGN. */
6079 kid->op_sibling = o->op_sibling; /* NULL */
6080 cLISTOPo->op_first = NULL;
6083 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6091 Perl_ck_match(pTHX_ OP *o)
6093 o->op_private |= OPpRUNTIME;
6098 Perl_ck_method(pTHX_ OP *o)
6100 OP *kid = cUNOPo->op_first;
6101 if (kid->op_type == OP_CONST) {
6102 SV* sv = kSVOP->op_sv;
6103 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6105 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6106 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6109 kSVOP->op_sv = Nullsv;
6111 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6120 Perl_ck_null(pTHX_ OP *o)
6126 Perl_ck_octmode(pTHX_ OP *o)
6130 if ((ckWARN(WARN_OCTMODE)
6131 /* Add WARN_MKDIR instead of getting rid of WARN_{CHMOD,UMASK}.
6132 Backwards compatibility and consistency are terrible things.
6134 || (o->op_type == OP_CHMOD && ckWARN(WARN_CHMOD))
6135 || (o->op_type == OP_UMASK && ckWARN(WARN_UMASK))
6136 || (o->op_type == OP_MKDIR && ckWARN(WARN_MKDIR)))
6137 && o->op_flags & OPf_KIDS)
6139 if (o->op_type == OP_MKDIR)
6140 p = cLISTOPo->op_last; /* mkdir $foo, 0777 */
6141 else if (o->op_type == OP_CHMOD)
6142 p = cLISTOPo->op_first->op_sibling; /* chmod 0777, $foo */
6144 p = cUNOPo->op_first; /* umask 0222 */
6146 if (p->op_type == OP_CONST && !(p->op_private & OPpCONST_OCTAL)) {
6147 int mode = SvIV(cSVOPx_sv(p));
6149 Perl_warner(aTHX_ WARN_OCTMODE,
6150 "Non-octal literal mode (%d) specified", mode);
6151 Perl_warner(aTHX_ WARN_OCTMODE,
6152 "\t(Did you mean 0%d instead?)\n", mode);
6159 Perl_ck_open(pTHX_ OP *o)
6161 HV *table = GvHV(PL_hintgv);
6165 svp = hv_fetch(table, "open_IN", 7, FALSE);
6167 mode = mode_from_discipline(*svp);
6168 if (mode & O_BINARY)
6169 o->op_private |= OPpOPEN_IN_RAW;
6170 else if (mode & O_TEXT)
6171 o->op_private |= OPpOPEN_IN_CRLF;
6174 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6176 mode = mode_from_discipline(*svp);
6177 if (mode & O_BINARY)
6178 o->op_private |= OPpOPEN_OUT_RAW;
6179 else if (mode & O_TEXT)
6180 o->op_private |= OPpOPEN_OUT_CRLF;
6183 if (o->op_type == OP_BACKTICK)
6189 Perl_ck_repeat(pTHX_ OP *o)
6191 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6192 o->op_private |= OPpREPEAT_DOLIST;
6193 cBINOPo->op_first = force_list(cBINOPo->op_first);
6201 Perl_ck_require(pTHX_ OP *o)
6205 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6206 SVOP *kid = (SVOP*)cUNOPo->op_first;
6208 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6210 for (s = SvPVX(kid->op_sv); *s; s++) {
6211 if (*s == ':' && s[1] == ':') {
6213 Move(s+2, s+1, strlen(s+2)+1, char);
6214 --SvCUR(kid->op_sv);
6217 if (SvREADONLY(kid->op_sv)) {
6218 SvREADONLY_off(kid->op_sv);
6219 sv_catpvn(kid->op_sv, ".pm", 3);
6220 SvREADONLY_on(kid->op_sv);
6223 sv_catpvn(kid->op_sv, ".pm", 3);
6227 /* handle override, if any */
6228 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6229 if (!(gv && GvIMPORTED_CV(gv)))
6230 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6232 if (gv && GvIMPORTED_CV(gv)) {
6233 OP *kid = cUNOPo->op_first;
6234 cUNOPo->op_first = 0;
6236 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6237 append_elem(OP_LIST, kid,
6238 scalar(newUNOP(OP_RV2CV, 0,
6247 Perl_ck_return(pTHX_ OP *o)
6250 if (CvLVALUE(PL_compcv)) {
6251 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6252 mod(kid, OP_LEAVESUBLV);
6259 Perl_ck_retarget(pTHX_ OP *o)
6261 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6268 Perl_ck_select(pTHX_ OP *o)
6271 if (o->op_flags & OPf_KIDS) {
6272 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6273 if (kid && kid->op_sibling) {
6274 o->op_type = OP_SSELECT;
6275 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6277 return fold_constants(o);
6281 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6282 if (kid && kid->op_type == OP_RV2GV)
6283 kid->op_private &= ~HINT_STRICT_REFS;
6288 Perl_ck_shift(pTHX_ OP *o)
6290 I32 type = o->op_type;
6292 if (!(o->op_flags & OPf_KIDS)) {
6297 if (!CvUNIQUE(PL_compcv)) {
6298 argop = newOP(OP_PADAV, OPf_REF);
6299 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6302 argop = newUNOP(OP_RV2AV, 0,
6303 scalar(newGVOP(OP_GV, 0,
6304 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6307 argop = newUNOP(OP_RV2AV, 0,
6308 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6309 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6310 #endif /* USE_THREADS */
6311 return newUNOP(type, 0, scalar(argop));
6313 return scalar(modkids(ck_fun(o), type));
6317 Perl_ck_sort(pTHX_ OP *o)
6321 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6323 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6324 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6326 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6328 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6330 if (kid->op_type == OP_SCOPE) {
6334 else if (kid->op_type == OP_LEAVE) {
6335 if (o->op_type == OP_SORT) {
6336 op_null(kid); /* wipe out leave */
6339 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6340 if (k->op_next == kid)
6342 /* don't descend into loops */
6343 else if (k->op_type == OP_ENTERLOOP
6344 || k->op_type == OP_ENTERITER)
6346 k = cLOOPx(k)->op_lastop;
6351 kid->op_next = 0; /* just disconnect the leave */
6352 k = kLISTOP->op_first;
6357 if (o->op_type == OP_SORT) {
6358 /* provide scalar context for comparison function/block */
6364 o->op_flags |= OPf_SPECIAL;
6366 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6369 firstkid = firstkid->op_sibling;
6372 /* provide list context for arguments */
6373 if (o->op_type == OP_SORT)
6380 S_simplify_sort(pTHX_ OP *o)
6382 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6386 if (!(o->op_flags & OPf_STACKED))
6388 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6389 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6390 kid = kUNOP->op_first; /* get past null */
6391 if (kid->op_type != OP_SCOPE)
6393 kid = kLISTOP->op_last; /* get past scope */
6394 switch(kid->op_type) {
6402 k = kid; /* remember this node*/
6403 if (kBINOP->op_first->op_type != OP_RV2SV)
6405 kid = kBINOP->op_first; /* get past cmp */
6406 if (kUNOP->op_first->op_type != OP_GV)
6408 kid = kUNOP->op_first; /* get past rv2sv */
6410 if (GvSTASH(gv) != PL_curstash)
6412 if (strEQ(GvNAME(gv), "a"))
6414 else if (strEQ(GvNAME(gv), "b"))
6418 kid = k; /* back to cmp */
6419 if (kBINOP->op_last->op_type != OP_RV2SV)
6421 kid = kBINOP->op_last; /* down to 2nd arg */
6422 if (kUNOP->op_first->op_type != OP_GV)
6424 kid = kUNOP->op_first; /* get past rv2sv */
6426 if (GvSTASH(gv) != PL_curstash
6428 ? strNE(GvNAME(gv), "a")
6429 : strNE(GvNAME(gv), "b")))
6431 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6433 o->op_private |= OPpSORT_REVERSE;
6434 if (k->op_type == OP_NCMP)
6435 o->op_private |= OPpSORT_NUMERIC;
6436 if (k->op_type == OP_I_NCMP)
6437 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6438 kid = cLISTOPo->op_first->op_sibling;
6439 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6440 op_free(kid); /* then delete it */
6444 Perl_ck_split(pTHX_ OP *o)
6448 if (o->op_flags & OPf_STACKED)
6449 return no_fh_allowed(o);
6451 kid = cLISTOPo->op_first;
6452 if (kid->op_type != OP_NULL)
6453 Perl_croak(aTHX_ "panic: ck_split");
6454 kid = kid->op_sibling;
6455 op_free(cLISTOPo->op_first);
6456 cLISTOPo->op_first = kid;
6458 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6459 cLISTOPo->op_last = kid; /* There was only one element previously */
6462 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6463 OP *sibl = kid->op_sibling;
6464 kid->op_sibling = 0;
6465 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6466 if (cLISTOPo->op_first == cLISTOPo->op_last)
6467 cLISTOPo->op_last = kid;
6468 cLISTOPo->op_first = kid;
6469 kid->op_sibling = sibl;
6472 kid->op_type = OP_PUSHRE;
6473 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6476 if (!kid->op_sibling)
6477 append_elem(OP_SPLIT, o, newDEFSVOP());
6479 kid = kid->op_sibling;
6482 if (!kid->op_sibling)
6483 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6485 kid = kid->op_sibling;
6488 if (kid->op_sibling)
6489 return too_many_arguments(o,PL_op_desc[o->op_type]);
6495 Perl_ck_join(pTHX_ OP *o)
6497 if (ckWARN(WARN_SYNTAX)) {
6498 OP *kid = cLISTOPo->op_first->op_sibling;
6499 if (kid && kid->op_type == OP_MATCH) {
6500 char *pmstr = "STRING";
6501 if (PM_GETRE(kPMOP))
6502 pmstr = PM_GETRE(kPMOP)->precomp;
6503 Perl_warner(aTHX_ WARN_SYNTAX,
6504 "/%s/ should probably be written as \"%s\"",
6512 Perl_ck_subr(pTHX_ OP *o)
6514 OP *prev = ((cUNOPo->op_first->op_sibling)
6515 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6516 OP *o2 = prev->op_sibling;
6525 o->op_private |= OPpENTERSUB_HASTARG;
6526 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6527 if (cvop->op_type == OP_RV2CV) {
6529 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6530 op_null(cvop); /* disable rv2cv */
6531 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6532 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6533 GV *gv = cGVOPx_gv(tmpop);
6536 tmpop->op_private |= OPpEARLY_CV;
6537 else if (SvPOK(cv)) {
6538 namegv = CvANON(cv) ? gv : CvGV(cv);
6539 proto = SvPV((SV*)cv, n_a);
6543 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6544 if (o2->op_type == OP_CONST)
6545 o2->op_private &= ~OPpCONST_STRICT;
6546 else if (o2->op_type == OP_LIST) {
6547 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6548 if (o && o->op_type == OP_CONST)
6549 o->op_private &= ~OPpCONST_STRICT;
6552 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6553 if (PERLDB_SUB && PL_curstash != PL_debstash)
6554 o->op_private |= OPpENTERSUB_DB;
6555 while (o2 != cvop) {
6559 return too_many_arguments(o, gv_ename(namegv));
6577 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6579 arg == 1 ? "block or sub {}" : "sub {}",
6580 gv_ename(namegv), o2);
6583 /* '*' allows any scalar type, including bareword */
6586 if (o2->op_type == OP_RV2GV)
6587 goto wrapref; /* autoconvert GLOB -> GLOBref */
6588 else if (o2->op_type == OP_CONST)
6589 o2->op_private &= ~OPpCONST_STRICT;
6590 else if (o2->op_type == OP_ENTERSUB) {
6591 /* accidental subroutine, revert to bareword */
6592 OP *gvop = ((UNOP*)o2)->op_first;
6593 if (gvop && gvop->op_type == OP_NULL) {
6594 gvop = ((UNOP*)gvop)->op_first;
6596 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6599 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6600 (gvop = ((UNOP*)gvop)->op_first) &&
6601 gvop->op_type == OP_GV)
6603 GV *gv = cGVOPx_gv(gvop);
6604 OP *sibling = o2->op_sibling;
6605 SV *n = newSVpvn("",0);
6607 gv_fullname3(n, gv, "");
6608 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6609 sv_chop(n, SvPVX(n)+6);
6610 o2 = newSVOP(OP_CONST, 0, n);
6611 prev->op_sibling = o2;
6612 o2->op_sibling = sibling;
6624 if (o2->op_type != OP_RV2GV)
6625 bad_type(arg, "symbol", gv_ename(namegv), o2);
6628 if (o2->op_type != OP_ENTERSUB)
6629 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6632 if (o2->op_type != OP_RV2SV
6633 && o2->op_type != OP_PADSV
6634 && o2->op_type != OP_HELEM
6635 && o2->op_type != OP_AELEM
6636 && o2->op_type != OP_THREADSV)
6638 bad_type(arg, "scalar", gv_ename(namegv), o2);
6642 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6643 bad_type(arg, "array", gv_ename(namegv), o2);
6646 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6647 bad_type(arg, "hash", gv_ename(namegv), o2);
6651 OP* sib = kid->op_sibling;
6652 kid->op_sibling = 0;
6653 o2 = newUNOP(OP_REFGEN, 0, kid);
6654 o2->op_sibling = sib;
6655 prev->op_sibling = o2;
6666 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6667 gv_ename(namegv), SvPV((SV*)cv, n_a));
6672 mod(o2, OP_ENTERSUB);
6674 o2 = o2->op_sibling;
6676 if (proto && !optional &&
6677 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6678 return too_few_arguments(o, gv_ename(namegv));
6683 Perl_ck_svconst(pTHX_ OP *o)
6685 SvREADONLY_on(cSVOPo->op_sv);
6690 Perl_ck_trunc(pTHX_ OP *o)
6692 if (o->op_flags & OPf_KIDS) {
6693 SVOP *kid = (SVOP*)cUNOPo->op_first;
6695 if (kid->op_type == OP_NULL)
6696 kid = (SVOP*)kid->op_sibling;
6697 if (kid && kid->op_type == OP_CONST &&
6698 (kid->op_private & OPpCONST_BARE))
6700 o->op_flags |= OPf_SPECIAL;
6701 kid->op_private &= ~OPpCONST_STRICT;
6708 Perl_ck_substr(pTHX_ OP *o)
6711 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6712 OP *kid = cLISTOPo->op_first;
6714 if (kid->op_type == OP_NULL)
6715 kid = kid->op_sibling;
6717 kid->op_flags |= OPf_MOD;
6723 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6726 Perl_peep(pTHX_ register OP *o)
6728 register OP* oldop = 0;
6731 if (!o || o->op_seq)
6735 SAVEVPTR(PL_curcop);
6736 for (; o; o = o->op_next) {
6742 switch (o->op_type) {
6746 PL_curcop = ((COP*)o); /* for warnings */
6747 o->op_seq = PL_op_seqmax++;
6751 if (cSVOPo->op_private & OPpCONST_STRICT)
6752 no_bareword_allowed(o);
6754 /* Relocate sv to the pad for thread safety.
6755 * Despite being a "constant", the SV is written to,
6756 * for reference counts, sv_upgrade() etc. */
6758 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6759 if (SvPADTMP(cSVOPo->op_sv)) {
6760 /* If op_sv is already a PADTMP then it is being used by
6761 * some pad, so make a copy. */
6762 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6763 SvREADONLY_on(PL_curpad[ix]);
6764 SvREFCNT_dec(cSVOPo->op_sv);
6767 SvREFCNT_dec(PL_curpad[ix]);
6768 SvPADTMP_on(cSVOPo->op_sv);
6769 PL_curpad[ix] = cSVOPo->op_sv;
6770 /* XXX I don't know how this isn't readonly already. */
6771 SvREADONLY_on(PL_curpad[ix]);
6773 cSVOPo->op_sv = Nullsv;
6777 o->op_seq = PL_op_seqmax++;
6781 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6782 if (o->op_next->op_private & OPpTARGET_MY) {
6783 if (o->op_flags & OPf_STACKED) /* chained concats */
6784 goto ignore_optimization;
6786 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6787 o->op_targ = o->op_next->op_targ;
6788 o->op_next->op_targ = 0;
6789 o->op_private |= OPpTARGET_MY;
6792 op_null(o->op_next);
6794 ignore_optimization:
6795 o->op_seq = PL_op_seqmax++;
6798 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6799 o->op_seq = PL_op_seqmax++;
6800 break; /* Scalar stub must produce undef. List stub is noop */
6804 if (o->op_targ == OP_NEXTSTATE
6805 || o->op_targ == OP_DBSTATE
6806 || o->op_targ == OP_SETSTATE)
6808 PL_curcop = ((COP*)o);
6815 if (oldop && o->op_next) {
6816 oldop->op_next = o->op_next;
6819 o->op_seq = PL_op_seqmax++;
6823 if (o->op_next->op_type == OP_RV2SV) {
6824 if (!(o->op_next->op_private & OPpDEREF)) {
6825 op_null(o->op_next);
6826 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6828 o->op_next = o->op_next->op_next;
6829 o->op_type = OP_GVSV;
6830 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6833 else if (o->op_next->op_type == OP_RV2AV) {
6834 OP* pop = o->op_next->op_next;
6836 if (pop->op_type == OP_CONST &&
6837 (PL_op = pop->op_next) &&
6838 pop->op_next->op_type == OP_AELEM &&
6839 !(pop->op_next->op_private &
6840 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6841 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6846 op_null(o->op_next);
6847 op_null(pop->op_next);
6849 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6850 o->op_next = pop->op_next->op_next;
6851 o->op_type = OP_AELEMFAST;
6852 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6853 o->op_private = (U8)i;
6858 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6860 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6861 /* XXX could check prototype here instead of just carping */
6862 SV *sv = sv_newmortal();
6863 gv_efullname3(sv, gv, Nullch);
6864 Perl_warner(aTHX_ WARN_PROTOTYPE,
6865 "%s() called too early to check prototype",
6870 o->op_seq = PL_op_seqmax++;
6881 o->op_seq = PL_op_seqmax++;
6882 while (cLOGOP->op_other->op_type == OP_NULL)
6883 cLOGOP->op_other = cLOGOP->op_other->op_next;
6884 peep(cLOGOP->op_other);
6889 o->op_seq = PL_op_seqmax++;
6890 while (cLOOP->op_redoop->op_type == OP_NULL)
6891 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6892 peep(cLOOP->op_redoop);
6893 while (cLOOP->op_nextop->op_type == OP_NULL)
6894 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6895 peep(cLOOP->op_nextop);
6896 while (cLOOP->op_lastop->op_type == OP_NULL)
6897 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6898 peep(cLOOP->op_lastop);
6904 o->op_seq = PL_op_seqmax++;
6905 while (cPMOP->op_pmreplstart &&
6906 cPMOP->op_pmreplstart->op_type == OP_NULL)
6907 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6908 peep(cPMOP->op_pmreplstart);
6912 o->op_seq = PL_op_seqmax++;
6913 if (ckWARN(WARN_SYNTAX) && o->op_next
6914 && o->op_next->op_type == OP_NEXTSTATE) {
6915 if (o->op_next->op_sibling &&
6916 o->op_next->op_sibling->op_type != OP_EXIT &&
6917 o->op_next->op_sibling->op_type != OP_WARN &&
6918 o->op_next->op_sibling->op_type != OP_DIE) {
6919 line_t oldline = CopLINE(PL_curcop);
6921 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6922 Perl_warner(aTHX_ WARN_EXEC,
6923 "Statement unlikely to be reached");
6924 Perl_warner(aTHX_ WARN_EXEC,
6925 "\t(Maybe you meant system() when you said exec()?)\n");
6926 CopLINE_set(PL_curcop, oldline);
6935 SV **svp, **indsvp, *sv;
6940 o->op_seq = PL_op_seqmax++;
6942 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6945 /* Make the CONST have a shared SV */
6946 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6947 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6948 key = SvPV(sv, keylen);
6949 lexname = newSVpvn_share(key,
6950 SvUTF8(sv) ? -(I32)keylen : keylen,
6956 if ((o->op_private & (OPpLVAL_INTRO)))
6959 rop = (UNOP*)((BINOP*)o)->op_first;
6960 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6962 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6963 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6965 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6966 if (!fields || !GvHV(*fields))
6968 key = SvPV(*svp, keylen);
6969 indsvp = hv_fetch(GvHV(*fields), key,
6970 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6972 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6973 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6975 ind = SvIV(*indsvp);
6977 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6978 rop->op_type = OP_RV2AV;
6979 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6980 o->op_type = OP_AELEM;
6981 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6983 if (SvREADONLY(*svp))
6985 SvFLAGS(sv) |= (SvFLAGS(*svp)
6986 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6996 SV **svp, **indsvp, *sv;
7000 SVOP *first_key_op, *key_op;
7002 o->op_seq = PL_op_seqmax++;
7003 if ((o->op_private & (OPpLVAL_INTRO))
7004 /* I bet there's always a pushmark... */
7005 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7006 /* hmmm, no optimization if list contains only one key. */
7008 rop = (UNOP*)((LISTOP*)o)->op_last;
7009 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7011 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7012 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7014 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7015 if (!fields || !GvHV(*fields))
7017 /* Again guessing that the pushmark can be jumped over.... */
7018 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7019 ->op_first->op_sibling;
7020 /* Check that the key list contains only constants. */
7021 for (key_op = first_key_op; key_op;
7022 key_op = (SVOP*)key_op->op_sibling)
7023 if (key_op->op_type != OP_CONST)
7027 rop->op_type = OP_RV2AV;
7028 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7029 o->op_type = OP_ASLICE;
7030 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7031 for (key_op = first_key_op; key_op;
7032 key_op = (SVOP*)key_op->op_sibling) {
7033 svp = cSVOPx_svp(key_op);
7034 key = SvPV(*svp, keylen);
7035 indsvp = hv_fetch(GvHV(*fields), key,
7036 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7038 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7039 "in variable %s of type %s",
7040 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7042 ind = SvIV(*indsvp);
7044 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7046 if (SvREADONLY(*svp))
7048 SvFLAGS(sv) |= (SvFLAGS(*svp)
7049 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7057 o->op_seq = PL_op_seqmax++;
7067 /* Efficient sub that returns a constant scalar value. */
7069 const_sv_xsub(pTHXo_ CV* cv)
7074 Perl_croak(aTHX_ "usage: %s::%s()",
7075 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7079 ST(0) = (SV*)XSANY.any_ptr;