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 sv_setpv(PL_curstname,"<none>");
3201 PL_curstash = Nullhv;
3203 PL_hints |= HINT_BLOCK_SCOPE;
3204 PL_copline = NOLINE;
3209 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3215 if (id->op_type != OP_CONST)
3216 Perl_croak(aTHX_ "Module name must be constant");
3220 if (version != Nullop) {
3221 SV *vesv = ((SVOP*)version)->op_sv;
3223 if (arg == Nullop && !SvNIOKp(vesv)) {
3230 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3231 Perl_croak(aTHX_ "Version number must be constant number");
3233 /* Make copy of id so we don't free it twice */
3234 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3236 /* Fake up a method call to VERSION */
3237 meth = newSVpvn("VERSION",7);
3238 sv_upgrade(meth, SVt_PVIV);
3239 (void)SvIOK_on(meth);
3240 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3241 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3242 append_elem(OP_LIST,
3243 prepend_elem(OP_LIST, pack, list(version)),
3244 newSVOP(OP_METHOD_NAMED, 0, meth)));
3248 /* Fake up an import/unimport */
3249 if (arg && arg->op_type == OP_STUB)
3250 imop = arg; /* no import on explicit () */
3251 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3252 imop = Nullop; /* use 5.0; */
3257 /* Make copy of id so we don't free it twice */
3258 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3260 /* Fake up a method call to import/unimport */
3261 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3262 sv_upgrade(meth, SVt_PVIV);
3263 (void)SvIOK_on(meth);
3264 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3265 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3266 append_elem(OP_LIST,
3267 prepend_elem(OP_LIST, pack, list(arg)),
3268 newSVOP(OP_METHOD_NAMED, 0, meth)));
3271 /* Fake up the BEGIN {}, which does its thing immediately. */
3273 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3276 append_elem(OP_LINESEQ,
3277 append_elem(OP_LINESEQ,
3278 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3279 newSTATEOP(0, Nullch, veop)),
3280 newSTATEOP(0, Nullch, imop) ));
3282 PL_hints |= HINT_BLOCK_SCOPE;
3283 PL_copline = NOLINE;
3288 =for apidoc load_module
3290 Loads the module whose name is pointed to by the string part of name.
3291 Note that the actual module name, not its filename, should be given.
3292 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3293 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3294 (or 0 for no flags). ver, if specified, provides version semantics
3295 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3296 arguments can be used to specify arguments to the module's import()
3297 method, similar to C<use Foo::Bar VERSION LIST>.
3302 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3305 va_start(args, ver);
3306 vload_module(flags, name, ver, &args);
3310 #ifdef PERL_IMPLICIT_CONTEXT
3312 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3316 va_start(args, ver);
3317 vload_module(flags, name, ver, &args);
3323 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3325 OP *modname, *veop, *imop;
3327 modname = newSVOP(OP_CONST, 0, name);
3328 modname->op_private |= OPpCONST_BARE;
3330 veop = newSVOP(OP_CONST, 0, ver);
3334 if (flags & PERL_LOADMOD_NOIMPORT) {
3335 imop = sawparens(newNULLLIST());
3337 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3338 imop = va_arg(*args, OP*);
3343 sv = va_arg(*args, SV*);
3345 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3346 sv = va_arg(*args, SV*);
3350 line_t ocopline = PL_copline;
3351 int oexpect = PL_expect;
3353 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3354 veop, modname, imop);
3355 PL_expect = oexpect;
3356 PL_copline = ocopline;
3361 Perl_dofile(pTHX_ OP *term)
3366 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3367 if (!(gv && GvIMPORTED_CV(gv)))
3368 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3370 if (gv && GvIMPORTED_CV(gv)) {
3371 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3372 append_elem(OP_LIST, term,
3373 scalar(newUNOP(OP_RV2CV, 0,
3378 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3384 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3386 return newBINOP(OP_LSLICE, flags,
3387 list(force_list(subscript)),
3388 list(force_list(listval)) );
3392 S_list_assignment(pTHX_ register OP *o)
3397 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3398 o = cUNOPo->op_first;
3400 if (o->op_type == OP_COND_EXPR) {
3401 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3402 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3407 yyerror("Assignment to both a list and a scalar");
3411 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3412 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3413 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3416 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3419 if (o->op_type == OP_RV2SV)
3426 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3431 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3432 return newLOGOP(optype, 0,
3433 mod(scalar(left), optype),
3434 newUNOP(OP_SASSIGN, 0, scalar(right)));
3437 return newBINOP(optype, OPf_STACKED,
3438 mod(scalar(left), optype), scalar(right));
3442 if (list_assignment(left)) {
3446 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3447 left = mod(left, OP_AASSIGN);
3455 curop = list(force_list(left));
3456 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3457 o->op_private = 0 | (flags >> 8);
3458 for (curop = ((LISTOP*)curop)->op_first;
3459 curop; curop = curop->op_sibling)
3461 if (curop->op_type == OP_RV2HV &&
3462 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3463 o->op_private |= OPpASSIGN_HASH;
3467 if (!(left->op_private & OPpLVAL_INTRO)) {
3470 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3471 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3472 if (curop->op_type == OP_GV) {
3473 GV *gv = cGVOPx_gv(curop);
3474 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3476 SvCUR(gv) = PL_generation;
3478 else if (curop->op_type == OP_PADSV ||
3479 curop->op_type == OP_PADAV ||
3480 curop->op_type == OP_PADHV ||
3481 curop->op_type == OP_PADANY) {
3482 SV **svp = AvARRAY(PL_comppad_name);
3483 SV *sv = svp[curop->op_targ];
3484 if (SvCUR(sv) == PL_generation)
3486 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3488 else if (curop->op_type == OP_RV2CV)
3490 else if (curop->op_type == OP_RV2SV ||
3491 curop->op_type == OP_RV2AV ||
3492 curop->op_type == OP_RV2HV ||
3493 curop->op_type == OP_RV2GV) {
3494 if (lastop->op_type != OP_GV) /* funny deref? */
3497 else if (curop->op_type == OP_PUSHRE) {
3498 if (((PMOP*)curop)->op_pmreplroot) {
3500 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3502 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3504 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3506 SvCUR(gv) = PL_generation;
3515 o->op_private |= OPpASSIGN_COMMON;
3517 if (right && right->op_type == OP_SPLIT) {
3519 if ((tmpop = ((LISTOP*)right)->op_first) &&
3520 tmpop->op_type == OP_PUSHRE)
3522 PMOP *pm = (PMOP*)tmpop;
3523 if (left->op_type == OP_RV2AV &&
3524 !(left->op_private & OPpLVAL_INTRO) &&
3525 !(o->op_private & OPpASSIGN_COMMON) )
3527 tmpop = ((UNOP*)left)->op_first;
3528 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3530 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3531 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3533 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3534 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3536 pm->op_pmflags |= PMf_ONCE;
3537 tmpop = cUNOPo->op_first; /* to list (nulled) */
3538 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3539 tmpop->op_sibling = Nullop; /* don't free split */
3540 right->op_next = tmpop->op_next; /* fix starting loc */
3541 op_free(o); /* blow off assign */
3542 right->op_flags &= ~OPf_WANT;
3543 /* "I don't know and I don't care." */
3548 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3549 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3551 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3553 sv_setiv(sv, PL_modcount+1);
3561 right = newOP(OP_UNDEF, 0);
3562 if (right->op_type == OP_READLINE) {
3563 right->op_flags |= OPf_STACKED;
3564 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3567 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3568 o = newBINOP(OP_SASSIGN, flags,
3569 scalar(right), mod(scalar(left), OP_SASSIGN) );
3581 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3583 U32 seq = intro_my();
3586 NewOp(1101, cop, 1, COP);
3587 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3588 cop->op_type = OP_DBSTATE;
3589 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3592 cop->op_type = OP_NEXTSTATE;
3593 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3595 cop->op_flags = flags;
3596 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3598 cop->op_private |= NATIVE_HINTS;
3600 PL_compiling.op_private = cop->op_private;
3601 cop->op_next = (OP*)cop;
3604 cop->cop_label = label;
3605 PL_hints |= HINT_BLOCK_SCOPE;
3608 cop->cop_arybase = PL_curcop->cop_arybase;
3609 if (specialWARN(PL_curcop->cop_warnings))
3610 cop->cop_warnings = PL_curcop->cop_warnings ;
3612 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3613 if (specialCopIO(PL_curcop->cop_io))
3614 cop->cop_io = PL_curcop->cop_io;
3616 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3619 if (PL_copline == NOLINE)
3620 CopLINE_set(cop, CopLINE(PL_curcop));
3622 CopLINE_set(cop, PL_copline);
3623 PL_copline = NOLINE;
3626 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3628 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3630 CopSTASH_set(cop, PL_curstash);
3632 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3633 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3634 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3635 (void)SvIOK_on(*svp);
3636 SvIVX(*svp) = PTR2IV(cop);
3640 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3643 /* "Introduce" my variables to visible status. */
3651 if (! PL_min_intro_pending)
3652 return PL_cop_seqmax;
3654 svp = AvARRAY(PL_comppad_name);
3655 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3656 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3657 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3658 SvNVX(sv) = (NV)PL_cop_seqmax;
3661 PL_min_intro_pending = 0;
3662 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3663 return PL_cop_seqmax++;
3667 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3669 return new_logop(type, flags, &first, &other);
3673 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3677 OP *first = *firstp;
3678 OP *other = *otherp;
3680 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3681 return newBINOP(type, flags, scalar(first), scalar(other));
3683 scalarboolean(first);
3684 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3685 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3686 if (type == OP_AND || type == OP_OR) {
3692 first = *firstp = cUNOPo->op_first;
3694 first->op_next = o->op_next;
3695 cUNOPo->op_first = Nullop;
3699 if (first->op_type == OP_CONST) {
3700 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3701 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3702 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3713 else if (first->op_type == OP_WANTARRAY) {
3719 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3720 OP *k1 = ((UNOP*)first)->op_first;
3721 OP *k2 = k1->op_sibling;
3723 switch (first->op_type)
3726 if (k2 && k2->op_type == OP_READLINE
3727 && (k2->op_flags & OPf_STACKED)
3728 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3730 warnop = k2->op_type;
3735 if (k1->op_type == OP_READDIR
3736 || k1->op_type == OP_GLOB
3737 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3738 || k1->op_type == OP_EACH)
3740 warnop = ((k1->op_type == OP_NULL)
3741 ? k1->op_targ : k1->op_type);
3746 line_t oldline = CopLINE(PL_curcop);
3747 CopLINE_set(PL_curcop, PL_copline);
3748 Perl_warner(aTHX_ WARN_MISC,
3749 "Value of %s%s can be \"0\"; test with defined()",
3751 ((warnop == OP_READLINE || warnop == OP_GLOB)
3752 ? " construct" : "() operator"));
3753 CopLINE_set(PL_curcop, oldline);
3760 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3761 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3763 NewOp(1101, logop, 1, LOGOP);
3765 logop->op_type = type;
3766 logop->op_ppaddr = PL_ppaddr[type];
3767 logop->op_first = first;
3768 logop->op_flags = flags | OPf_KIDS;
3769 logop->op_other = LINKLIST(other);
3770 logop->op_private = 1 | (flags >> 8);
3772 /* establish postfix order */
3773 logop->op_next = LINKLIST(first);
3774 first->op_next = (OP*)logop;
3775 first->op_sibling = other;
3777 o = newUNOP(OP_NULL, 0, (OP*)logop);
3784 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3791 return newLOGOP(OP_AND, 0, first, trueop);
3793 return newLOGOP(OP_OR, 0, first, falseop);
3795 scalarboolean(first);
3796 if (first->op_type == OP_CONST) {
3797 if (SvTRUE(((SVOP*)first)->op_sv)) {
3808 else if (first->op_type == OP_WANTARRAY) {
3812 NewOp(1101, logop, 1, LOGOP);
3813 logop->op_type = OP_COND_EXPR;
3814 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3815 logop->op_first = first;
3816 logop->op_flags = flags | OPf_KIDS;
3817 logop->op_private = 1 | (flags >> 8);
3818 logop->op_other = LINKLIST(trueop);
3819 logop->op_next = LINKLIST(falseop);
3822 /* establish postfix order */
3823 start = LINKLIST(first);
3824 first->op_next = (OP*)logop;
3826 first->op_sibling = trueop;
3827 trueop->op_sibling = falseop;
3828 o = newUNOP(OP_NULL, 0, (OP*)logop);
3830 trueop->op_next = falseop->op_next = o;
3837 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3845 NewOp(1101, range, 1, LOGOP);
3847 range->op_type = OP_RANGE;
3848 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3849 range->op_first = left;
3850 range->op_flags = OPf_KIDS;
3851 leftstart = LINKLIST(left);
3852 range->op_other = LINKLIST(right);
3853 range->op_private = 1 | (flags >> 8);
3855 left->op_sibling = right;
3857 range->op_next = (OP*)range;
3858 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3859 flop = newUNOP(OP_FLOP, 0, flip);
3860 o = newUNOP(OP_NULL, 0, flop);
3862 range->op_next = leftstart;
3864 left->op_next = flip;
3865 right->op_next = flop;
3867 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3868 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3869 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3870 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3872 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3873 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3876 if (!flip->op_private || !flop->op_private)
3877 linklist(o); /* blow off optimizer unless constant */
3883 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3887 int once = block && block->op_flags & OPf_SPECIAL &&
3888 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3891 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3892 return block; /* do {} while 0 does once */
3893 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3894 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3895 expr = newUNOP(OP_DEFINED, 0,
3896 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3897 } else if (expr->op_flags & OPf_KIDS) {
3898 OP *k1 = ((UNOP*)expr)->op_first;
3899 OP *k2 = (k1) ? k1->op_sibling : NULL;
3900 switch (expr->op_type) {
3902 if (k2 && k2->op_type == OP_READLINE
3903 && (k2->op_flags & OPf_STACKED)
3904 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3905 expr = newUNOP(OP_DEFINED, 0, expr);
3909 if (k1->op_type == OP_READDIR
3910 || k1->op_type == OP_GLOB
3911 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3912 || k1->op_type == OP_EACH)
3913 expr = newUNOP(OP_DEFINED, 0, expr);
3919 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3920 o = new_logop(OP_AND, 0, &expr, &listop);
3923 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3925 if (once && o != listop)
3926 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3929 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3931 o->op_flags |= flags;
3933 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3938 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3946 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3947 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3948 expr = newUNOP(OP_DEFINED, 0,
3949 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3950 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3951 OP *k1 = ((UNOP*)expr)->op_first;
3952 OP *k2 = (k1) ? k1->op_sibling : NULL;
3953 switch (expr->op_type) {
3955 if (k2 && k2->op_type == OP_READLINE
3956 && (k2->op_flags & OPf_STACKED)
3957 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3958 expr = newUNOP(OP_DEFINED, 0, expr);
3962 if (k1->op_type == OP_READDIR
3963 || k1->op_type == OP_GLOB
3964 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3965 || k1->op_type == OP_EACH)
3966 expr = newUNOP(OP_DEFINED, 0, expr);
3972 block = newOP(OP_NULL, 0);
3974 block = scope(block);
3978 next = LINKLIST(cont);
3981 OP *unstack = newOP(OP_UNSTACK, 0);
3984 cont = append_elem(OP_LINESEQ, cont, unstack);
3985 if ((line_t)whileline != NOLINE) {
3986 PL_copline = whileline;
3987 cont = append_elem(OP_LINESEQ, cont,
3988 newSTATEOP(0, Nullch, Nullop));
3992 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3993 redo = LINKLIST(listop);
3996 PL_copline = whileline;
3998 o = new_logop(OP_AND, 0, &expr, &listop);
3999 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4000 op_free(expr); /* oops, it's a while (0) */
4002 return Nullop; /* listop already freed by new_logop */
4005 ((LISTOP*)listop)->op_last->op_next =
4006 (o == listop ? redo : LINKLIST(o));
4012 NewOp(1101,loop,1,LOOP);
4013 loop->op_type = OP_ENTERLOOP;
4014 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4015 loop->op_private = 0;
4016 loop->op_next = (OP*)loop;
4019 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4021 loop->op_redoop = redo;
4022 loop->op_lastop = o;
4023 o->op_private |= loopflags;
4026 loop->op_nextop = next;
4028 loop->op_nextop = o;
4030 o->op_flags |= flags;
4031 o->op_private |= (flags >> 8);
4036 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4044 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4045 sv->op_type = OP_RV2GV;
4046 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4048 else if (sv->op_type == OP_PADSV) { /* private variable */
4049 padoff = sv->op_targ;
4054 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4055 padoff = sv->op_targ;
4057 iterflags |= OPf_SPECIAL;
4062 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4066 padoff = find_threadsv("_");
4067 iterflags |= OPf_SPECIAL;
4069 sv = newGVOP(OP_GV, 0, PL_defgv);
4072 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4073 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4074 iterflags |= OPf_STACKED;
4076 else if (expr->op_type == OP_NULL &&
4077 (expr->op_flags & OPf_KIDS) &&
4078 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4080 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4081 * set the STACKED flag to indicate that these values are to be
4082 * treated as min/max values by 'pp_iterinit'.
4084 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4085 LOGOP* range = (LOGOP*) flip->op_first;
4086 OP* left = range->op_first;
4087 OP* right = left->op_sibling;
4090 range->op_flags &= ~OPf_KIDS;
4091 range->op_first = Nullop;
4093 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4094 listop->op_first->op_next = range->op_next;
4095 left->op_next = range->op_other;
4096 right->op_next = (OP*)listop;
4097 listop->op_next = listop->op_first;
4100 expr = (OP*)(listop);
4102 iterflags |= OPf_STACKED;
4105 expr = mod(force_list(expr), OP_GREPSTART);
4109 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4110 append_elem(OP_LIST, expr, scalar(sv))));
4111 assert(!loop->op_next);
4112 #ifdef PL_OP_SLAB_ALLOC
4115 NewOp(1234,tmp,1,LOOP);
4116 Copy(loop,tmp,1,LOOP);
4120 Renew(loop, 1, LOOP);
4122 loop->op_targ = padoff;
4123 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4124 PL_copline = forline;
4125 return newSTATEOP(0, label, wop);
4129 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4134 if (type != OP_GOTO || label->op_type == OP_CONST) {
4135 /* "last()" means "last" */
4136 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4137 o = newOP(type, OPf_SPECIAL);
4139 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4140 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4146 if (label->op_type == OP_ENTERSUB)
4147 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4148 o = newUNOP(type, OPf_STACKED, label);
4150 PL_hints |= HINT_BLOCK_SCOPE;
4155 Perl_cv_undef(pTHX_ CV *cv)
4159 MUTEX_DESTROY(CvMUTEXP(cv));
4160 Safefree(CvMUTEXP(cv));
4163 #endif /* USE_THREADS */
4166 if (CvFILE(cv) && !CvXSUB(cv)) {
4167 Safefree(CvFILE(cv));
4172 if (!CvXSUB(cv) && CvROOT(cv)) {
4174 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4175 Perl_croak(aTHX_ "Can't undef active subroutine");
4178 Perl_croak(aTHX_ "Can't undef active subroutine");
4179 #endif /* USE_THREADS */
4182 SAVEVPTR(PL_curpad);
4185 op_free(CvROOT(cv));
4186 CvROOT(cv) = Nullop;
4189 SvPOK_off((SV*)cv); /* forget prototype */
4191 /* Since closure prototypes have the same lifetime as the containing
4192 * CV, they don't hold a refcount on the outside CV. This avoids
4193 * the refcount loop between the outer CV (which keeps a refcount to
4194 * the closure prototype in the pad entry for pp_anoncode()) and the
4195 * closure prototype, and the ensuing memory leak. This does not
4196 * apply to closures generated within eval"", since eval"" CVs are
4197 * ephemeral. --GSAR */
4198 if (!CvANON(cv) || CvCLONED(cv)
4199 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4200 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4202 SvREFCNT_dec(CvOUTSIDE(cv));
4204 CvOUTSIDE(cv) = Nullcv;
4206 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4209 if (CvPADLIST(cv)) {
4210 /* may be during global destruction */
4211 if (SvREFCNT(CvPADLIST(cv))) {
4212 I32 i = AvFILLp(CvPADLIST(cv));
4214 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4215 SV* sv = svp ? *svp : Nullsv;
4218 if (sv == (SV*)PL_comppad_name)
4219 PL_comppad_name = Nullav;
4220 else if (sv == (SV*)PL_comppad) {
4221 PL_comppad = Nullav;
4222 PL_curpad = Null(SV**);
4226 SvREFCNT_dec((SV*)CvPADLIST(cv));
4228 CvPADLIST(cv) = Nullav;
4236 #ifdef DEBUG_CLOSURES
4238 S_cv_dump(pTHX_ CV *cv)
4241 CV *outside = CvOUTSIDE(cv);
4242 AV* padlist = CvPADLIST(cv);
4249 PerlIO_printf(Perl_debug_log,
4250 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4252 (CvANON(cv) ? "ANON"
4253 : (cv == PL_main_cv) ? "MAIN"
4254 : CvUNIQUE(cv) ? "UNIQUE"
4255 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4258 : CvANON(outside) ? "ANON"
4259 : (outside == PL_main_cv) ? "MAIN"
4260 : CvUNIQUE(outside) ? "UNIQUE"
4261 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4266 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4267 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4268 pname = AvARRAY(pad_name);
4269 ppad = AvARRAY(pad);
4271 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4272 if (SvPOK(pname[ix]))
4273 PerlIO_printf(Perl_debug_log,
4274 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4275 (int)ix, PTR2UV(ppad[ix]),
4276 SvFAKE(pname[ix]) ? "FAKE " : "",
4278 (IV)I_32(SvNVX(pname[ix])),
4281 #endif /* DEBUGGING */
4283 #endif /* DEBUG_CLOSURES */
4286 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4290 AV* protopadlist = CvPADLIST(proto);
4291 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4292 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4293 SV** pname = AvARRAY(protopad_name);
4294 SV** ppad = AvARRAY(protopad);
4295 I32 fname = AvFILLp(protopad_name);
4296 I32 fpad = AvFILLp(protopad);
4300 assert(!CvUNIQUE(proto));
4304 SAVESPTR(PL_comppad_name);
4305 SAVESPTR(PL_compcv);
4307 cv = PL_compcv = (CV*)NEWSV(1104,0);
4308 sv_upgrade((SV *)cv, SvTYPE(proto));
4309 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4313 New(666, CvMUTEXP(cv), 1, perl_mutex);
4314 MUTEX_INIT(CvMUTEXP(cv));
4316 #endif /* USE_THREADS */
4318 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4319 : savepv(CvFILE(proto));
4321 CvFILE(cv) = CvFILE(proto);
4323 CvGV(cv) = CvGV(proto);
4324 CvSTASH(cv) = CvSTASH(proto);
4325 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4326 CvSTART(cv) = CvSTART(proto);
4328 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4331 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4333 PL_comppad_name = newAV();
4334 for (ix = fname; ix >= 0; ix--)
4335 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4337 PL_comppad = newAV();
4339 comppadlist = newAV();
4340 AvREAL_off(comppadlist);
4341 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4342 av_store(comppadlist, 1, (SV*)PL_comppad);
4343 CvPADLIST(cv) = comppadlist;
4344 av_fill(PL_comppad, AvFILLp(protopad));
4345 PL_curpad = AvARRAY(PL_comppad);
4347 av = newAV(); /* will be @_ */
4349 av_store(PL_comppad, 0, (SV*)av);
4350 AvFLAGS(av) = AVf_REIFY;
4352 for (ix = fpad; ix > 0; ix--) {
4353 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4354 if (namesv && namesv != &PL_sv_undef) {
4355 char *name = SvPVX(namesv); /* XXX */
4356 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4357 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4358 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4360 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4362 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4364 else { /* our own lexical */
4367 /* anon code -- we'll come back for it */
4368 sv = SvREFCNT_inc(ppad[ix]);
4370 else if (*name == '@')
4372 else if (*name == '%')
4381 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4382 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4385 SV* sv = NEWSV(0,0);
4391 /* Now that vars are all in place, clone nested closures. */
4393 for (ix = fpad; ix > 0; ix--) {
4394 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4396 && namesv != &PL_sv_undef
4397 && !(SvFLAGS(namesv) & SVf_FAKE)
4398 && *SvPVX(namesv) == '&'
4399 && CvCLONE(ppad[ix]))
4401 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4402 SvREFCNT_dec(ppad[ix]);
4405 PL_curpad[ix] = (SV*)kid;
4409 #ifdef DEBUG_CLOSURES
4410 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4412 PerlIO_printf(Perl_debug_log, " from:\n");
4414 PerlIO_printf(Perl_debug_log, " to:\n");
4421 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4423 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4425 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4432 Perl_cv_clone(pTHX_ CV *proto)
4435 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4436 cv = cv_clone2(proto, CvOUTSIDE(proto));
4437 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4442 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4444 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4445 SV* msg = sv_newmortal();
4449 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4450 sv_setpv(msg, "Prototype mismatch:");
4452 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4454 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4455 sv_catpv(msg, " vs ");
4457 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4459 sv_catpv(msg, "none");
4460 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4464 static void const_sv_xsub(pTHXo_ CV* cv);
4467 =for apidoc cv_const_sv
4469 If C<cv> is a constant sub eligible for inlining. returns the constant
4470 value returned by the sub. Otherwise, returns NULL.
4472 Constant subs can be created with C<newCONSTSUB> or as described in
4473 L<perlsub/"Constant Functions">.
4478 Perl_cv_const_sv(pTHX_ CV *cv)
4480 if (!cv || !CvCONST(cv))
4482 return (SV*)CvXSUBANY(cv).any_ptr;
4486 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4493 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4494 o = cLISTOPo->op_first->op_sibling;
4496 for (; o; o = o->op_next) {
4497 OPCODE type = o->op_type;
4499 if (sv && o->op_next == o)
4501 if (o->op_next != o) {
4502 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4504 if (type == OP_DBSTATE)
4507 if (type == OP_LEAVESUB || type == OP_RETURN)
4511 if (type == OP_CONST && cSVOPo->op_sv)
4513 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4514 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4515 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4519 /* We get here only from cv_clone2() while creating a closure.
4520 Copy the const value here instead of in cv_clone2 so that
4521 SvREADONLY_on doesn't lead to problems when leaving
4526 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4538 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4548 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4552 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4554 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4558 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4564 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4569 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4570 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4571 SV *sv = sv_newmortal();
4572 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4573 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4578 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4579 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4589 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4590 maximum a prototype before. */
4591 if (SvTYPE(gv) > SVt_NULL) {
4592 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4593 && ckWARN_d(WARN_PROTOTYPE))
4595 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4597 cv_ckproto((CV*)gv, NULL, ps);
4600 sv_setpv((SV*)gv, ps);
4602 sv_setiv((SV*)gv, -1);
4603 SvREFCNT_dec(PL_compcv);
4604 cv = PL_compcv = NULL;
4605 PL_sub_generation++;
4609 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4611 #ifdef GV_UNIQUE_CHECK
4612 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4613 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4617 if (!block || !ps || *ps || attrs)
4620 const_sv = op_const_sv(block, Nullcv);
4623 bool exists = CvROOT(cv) || CvXSUB(cv);
4625 #ifdef GV_UNIQUE_CHECK
4626 if (exists && GvUNIQUE(gv)) {
4627 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4631 /* if the subroutine doesn't exist and wasn't pre-declared
4632 * with a prototype, assume it will be AUTOLOADed,
4633 * skipping the prototype check
4635 if (exists || SvPOK(cv))
4636 cv_ckproto(cv, gv, ps);
4637 /* already defined (or promised)? */
4638 if (exists || GvASSUMECV(gv)) {
4639 if (!block && !attrs) {
4640 /* just a "sub foo;" when &foo is already defined */
4641 SAVEFREESV(PL_compcv);
4644 /* ahem, death to those who redefine active sort subs */
4645 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4646 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4648 if (ckWARN(WARN_REDEFINE)
4650 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4652 line_t oldline = CopLINE(PL_curcop);
4653 CopLINE_set(PL_curcop, PL_copline);
4654 Perl_warner(aTHX_ WARN_REDEFINE,
4655 CvCONST(cv) ? "Constant subroutine %s redefined"
4656 : "Subroutine %s redefined", name);
4657 CopLINE_set(PL_curcop, oldline);
4665 SvREFCNT_inc(const_sv);
4667 assert(!CvROOT(cv) && !CvCONST(cv));
4668 sv_setpv((SV*)cv, ""); /* prototype is "" */
4669 CvXSUBANY(cv).any_ptr = const_sv;
4670 CvXSUB(cv) = const_sv_xsub;
4675 cv = newCONSTSUB(NULL, name, const_sv);
4678 SvREFCNT_dec(PL_compcv);
4680 PL_sub_generation++;
4687 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4688 * before we clobber PL_compcv.
4692 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4693 stash = GvSTASH(CvGV(cv));
4694 else if (CvSTASH(cv))
4695 stash = CvSTASH(cv);
4697 stash = PL_curstash;
4700 /* possibly about to re-define existing subr -- ignore old cv */
4701 rcv = (SV*)PL_compcv;
4702 if (name && GvSTASH(gv))
4703 stash = GvSTASH(gv);
4705 stash = PL_curstash;
4707 apply_attrs(stash, rcv, attrs);
4709 if (cv) { /* must reuse cv if autoloaded */
4711 /* got here with just attrs -- work done, so bug out */
4712 SAVEFREESV(PL_compcv);
4716 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4717 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4718 CvOUTSIDE(PL_compcv) = 0;
4719 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4720 CvPADLIST(PL_compcv) = 0;
4721 /* inner references to PL_compcv must be fixed up ... */
4723 AV *padlist = CvPADLIST(cv);
4724 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4725 AV *comppad = (AV*)AvARRAY(padlist)[1];
4726 SV **namepad = AvARRAY(comppad_name);
4727 SV **curpad = AvARRAY(comppad);
4728 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4729 SV *namesv = namepad[ix];
4730 if (namesv && namesv != &PL_sv_undef
4731 && *SvPVX(namesv) == '&')
4733 CV *innercv = (CV*)curpad[ix];
4734 if (CvOUTSIDE(innercv) == PL_compcv) {
4735 CvOUTSIDE(innercv) = cv;
4736 if (!CvANON(innercv) || CvCLONED(innercv)) {
4737 (void)SvREFCNT_inc(cv);
4738 SvREFCNT_dec(PL_compcv);
4744 /* ... before we throw it away */
4745 SvREFCNT_dec(PL_compcv);
4752 PL_sub_generation++;
4756 CvFILE_set_from_cop(cv, PL_curcop);
4757 CvSTASH(cv) = PL_curstash;
4760 if (!CvMUTEXP(cv)) {
4761 New(666, CvMUTEXP(cv), 1, perl_mutex);
4762 MUTEX_INIT(CvMUTEXP(cv));
4764 #endif /* USE_THREADS */
4767 sv_setpv((SV*)cv, ps);
4769 if (PL_error_count) {
4773 char *s = strrchr(name, ':');
4775 if (strEQ(s, "BEGIN")) {
4777 "BEGIN not safe after errors--compilation aborted";
4778 if (PL_in_eval & EVAL_KEEPERR)
4779 Perl_croak(aTHX_ not_safe);
4781 /* force display of errors found but not reported */
4782 sv_catpv(ERRSV, not_safe);
4783 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4791 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4792 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4795 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4796 mod(scalarseq(block), OP_LEAVESUBLV));
4799 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4801 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4802 OpREFCNT_set(CvROOT(cv), 1);
4803 CvSTART(cv) = LINKLIST(CvROOT(cv));
4804 CvROOT(cv)->op_next = 0;
4807 /* now that optimizer has done its work, adjust pad values */
4809 SV **namep = AvARRAY(PL_comppad_name);
4810 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4813 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4816 * The only things that a clonable function needs in its
4817 * pad are references to outer lexicals and anonymous subs.
4818 * The rest are created anew during cloning.
4820 if (!((namesv = namep[ix]) != Nullsv &&
4821 namesv != &PL_sv_undef &&
4823 *SvPVX(namesv) == '&')))
4825 SvREFCNT_dec(PL_curpad[ix]);
4826 PL_curpad[ix] = Nullsv;
4829 assert(!CvCONST(cv));
4830 if (ps && !*ps && op_const_sv(block, cv))
4834 AV *av = newAV(); /* Will be @_ */
4836 av_store(PL_comppad, 0, (SV*)av);
4837 AvFLAGS(av) = AVf_REIFY;
4839 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4840 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4842 if (!SvPADMY(PL_curpad[ix]))
4843 SvPADTMP_on(PL_curpad[ix]);
4847 /* If a potential closure prototype, don't keep a refcount on
4848 * outer CV, unless the latter happens to be a passing eval"".
4849 * This is okay as the lifetime of the prototype is tied to the
4850 * lifetime of the outer CV. Avoids memory leak due to reference
4852 if (!name && CvOUTSIDE(cv)
4853 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4854 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4856 SvREFCNT_dec(CvOUTSIDE(cv));
4859 if (name || aname) {
4861 char *tname = (name ? name : aname);
4863 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4864 SV *sv = NEWSV(0,0);
4865 SV *tmpstr = sv_newmortal();
4866 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4870 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4872 (long)PL_subline, (long)CopLINE(PL_curcop));
4873 gv_efullname3(tmpstr, gv, Nullch);
4874 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4875 hv = GvHVn(db_postponed);
4876 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4877 && (pcv = GvCV(db_postponed)))
4883 call_sv((SV*)pcv, G_DISCARD);
4887 if ((s = strrchr(tname,':')))
4892 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4895 if (strEQ(s, "BEGIN")) {
4896 I32 oldscope = PL_scopestack_ix;
4898 SAVECOPFILE(&PL_compiling);
4899 SAVECOPLINE(&PL_compiling);
4901 sv_setsv(PL_rs, PL_nrs);
4904 PL_beginav = newAV();
4905 DEBUG_x( dump_sub(gv) );
4906 av_push(PL_beginav, (SV*)cv);
4907 GvCV(gv) = 0; /* cv has been hijacked */
4908 call_list(oldscope, PL_beginav);
4910 PL_curcop = &PL_compiling;
4911 PL_compiling.op_private = PL_hints;
4914 else if (strEQ(s, "END") && !PL_error_count) {
4917 DEBUG_x( dump_sub(gv) );
4918 av_unshift(PL_endav, 1);
4919 av_store(PL_endav, 0, (SV*)cv);
4920 GvCV(gv) = 0; /* cv has been hijacked */
4922 else if (strEQ(s, "CHECK") && !PL_error_count) {
4924 PL_checkav = newAV();
4925 DEBUG_x( dump_sub(gv) );
4926 if (PL_main_start && ckWARN(WARN_VOID))
4927 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4928 av_unshift(PL_checkav, 1);
4929 av_store(PL_checkav, 0, (SV*)cv);
4930 GvCV(gv) = 0; /* cv has been hijacked */
4932 else if (strEQ(s, "INIT") && !PL_error_count) {
4934 PL_initav = newAV();
4935 DEBUG_x( dump_sub(gv) );
4936 if (PL_main_start && ckWARN(WARN_VOID))
4937 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4938 av_push(PL_initav, (SV*)cv);
4939 GvCV(gv) = 0; /* cv has been hijacked */
4944 PL_copline = NOLINE;
4949 /* XXX unsafe for threads if eval_owner isn't held */
4951 =for apidoc newCONSTSUB
4953 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4954 eligible for inlining at compile-time.
4960 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4966 SAVECOPLINE(PL_curcop);
4967 CopLINE_set(PL_curcop, PL_copline);
4970 PL_hints &= ~HINT_BLOCK_SCOPE;
4973 SAVESPTR(PL_curstash);
4974 SAVECOPSTASH(PL_curcop);
4975 PL_curstash = stash;
4977 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4979 CopSTASH(PL_curcop) = stash;
4983 cv = newXS(name, const_sv_xsub, __FILE__);
4984 CvXSUBANY(cv).any_ptr = sv;
4986 sv_setpv((SV*)cv, ""); /* prototype is "" */
4994 =for apidoc U||newXS
4996 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5002 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5004 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5007 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5009 /* just a cached method */
5013 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5014 /* already defined (or promised) */
5015 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5016 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5017 line_t oldline = CopLINE(PL_curcop);
5018 if (PL_copline != NOLINE)
5019 CopLINE_set(PL_curcop, PL_copline);
5020 Perl_warner(aTHX_ WARN_REDEFINE,
5021 CvCONST(cv) ? "Constant subroutine %s redefined"
5022 : "Subroutine %s redefined"
5024 CopLINE_set(PL_curcop, oldline);
5031 if (cv) /* must reuse cv if autoloaded */
5034 cv = (CV*)NEWSV(1105,0);
5035 sv_upgrade((SV *)cv, SVt_PVCV);
5039 PL_sub_generation++;
5044 New(666, CvMUTEXP(cv), 1, perl_mutex);
5045 MUTEX_INIT(CvMUTEXP(cv));
5047 #endif /* USE_THREADS */
5048 (void)gv_fetchfile(filename);
5049 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5050 an external constant string */
5051 CvXSUB(cv) = subaddr;
5054 char *s = strrchr(name,':');
5060 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5063 if (strEQ(s, "BEGIN")) {
5065 PL_beginav = newAV();
5066 av_push(PL_beginav, (SV*)cv);
5067 GvCV(gv) = 0; /* cv has been hijacked */
5069 else if (strEQ(s, "END")) {
5072 av_unshift(PL_endav, 1);
5073 av_store(PL_endav, 0, (SV*)cv);
5074 GvCV(gv) = 0; /* cv has been hijacked */
5076 else if (strEQ(s, "CHECK")) {
5078 PL_checkav = newAV();
5079 if (PL_main_start && ckWARN(WARN_VOID))
5080 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5081 av_unshift(PL_checkav, 1);
5082 av_store(PL_checkav, 0, (SV*)cv);
5083 GvCV(gv) = 0; /* cv has been hijacked */
5085 else if (strEQ(s, "INIT")) {
5087 PL_initav = newAV();
5088 if (PL_main_start && ckWARN(WARN_VOID))
5089 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5090 av_push(PL_initav, (SV*)cv);
5091 GvCV(gv) = 0; /* cv has been hijacked */
5102 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5111 name = SvPVx(cSVOPo->op_sv, n_a);
5114 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5115 #ifdef GV_UNIQUE_CHECK
5117 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5121 if ((cv = GvFORM(gv))) {
5122 if (ckWARN(WARN_REDEFINE)) {
5123 line_t oldline = CopLINE(PL_curcop);
5125 CopLINE_set(PL_curcop, PL_copline);
5126 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5127 CopLINE_set(PL_curcop, oldline);
5134 CvFILE_set_from_cop(cv, PL_curcop);
5136 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5137 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5138 SvPADTMP_on(PL_curpad[ix]);
5141 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5142 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5143 OpREFCNT_set(CvROOT(cv), 1);
5144 CvSTART(cv) = LINKLIST(CvROOT(cv));
5145 CvROOT(cv)->op_next = 0;
5148 PL_copline = NOLINE;
5153 Perl_newANONLIST(pTHX_ OP *o)
5155 return newUNOP(OP_REFGEN, 0,
5156 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5160 Perl_newANONHASH(pTHX_ OP *o)
5162 return newUNOP(OP_REFGEN, 0,
5163 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5167 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5169 return newANONATTRSUB(floor, proto, Nullop, block);
5173 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5175 return newUNOP(OP_REFGEN, 0,
5176 newSVOP(OP_ANONCODE, 0,
5177 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5181 Perl_oopsAV(pTHX_ OP *o)
5183 switch (o->op_type) {
5185 o->op_type = OP_PADAV;
5186 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5187 return ref(o, OP_RV2AV);
5190 o->op_type = OP_RV2AV;
5191 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5196 if (ckWARN_d(WARN_INTERNAL))
5197 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5204 Perl_oopsHV(pTHX_ OP *o)
5206 switch (o->op_type) {
5209 o->op_type = OP_PADHV;
5210 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5211 return ref(o, OP_RV2HV);
5215 o->op_type = OP_RV2HV;
5216 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5221 if (ckWARN_d(WARN_INTERNAL))
5222 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5229 Perl_newAVREF(pTHX_ OP *o)
5231 if (o->op_type == OP_PADANY) {
5232 o->op_type = OP_PADAV;
5233 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5236 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5237 && ckWARN(WARN_DEPRECATED)) {
5238 Perl_warner(aTHX_ WARN_DEPRECATED,
5239 "Using an array as a reference is deprecated");
5241 return newUNOP(OP_RV2AV, 0, scalar(o));
5245 Perl_newGVREF(pTHX_ I32 type, OP *o)
5247 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5248 return newUNOP(OP_NULL, 0, o);
5249 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5253 Perl_newHVREF(pTHX_ OP *o)
5255 if (o->op_type == OP_PADANY) {
5256 o->op_type = OP_PADHV;
5257 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5260 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5261 && ckWARN(WARN_DEPRECATED)) {
5262 Perl_warner(aTHX_ WARN_DEPRECATED,
5263 "Using a hash as a reference is deprecated");
5265 return newUNOP(OP_RV2HV, 0, scalar(o));
5269 Perl_oopsCV(pTHX_ OP *o)
5271 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5277 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5279 return newUNOP(OP_RV2CV, flags, scalar(o));
5283 Perl_newSVREF(pTHX_ OP *o)
5285 if (o->op_type == OP_PADANY) {
5286 o->op_type = OP_PADSV;
5287 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5290 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5291 o->op_flags |= OPpDONE_SVREF;
5294 return newUNOP(OP_RV2SV, 0, scalar(o));
5297 /* Check routines. */
5300 Perl_ck_anoncode(pTHX_ OP *o)
5305 name = NEWSV(1106,0);
5306 sv_upgrade(name, SVt_PVNV);
5307 sv_setpvn(name, "&", 1);
5310 ix = pad_alloc(o->op_type, SVs_PADMY);
5311 av_store(PL_comppad_name, ix, name);
5312 av_store(PL_comppad, ix, cSVOPo->op_sv);
5313 SvPADMY_on(cSVOPo->op_sv);
5314 cSVOPo->op_sv = Nullsv;
5315 cSVOPo->op_targ = ix;
5320 Perl_ck_bitop(pTHX_ OP *o)
5322 o->op_private = PL_hints;
5327 Perl_ck_concat(pTHX_ OP *o)
5329 if (cUNOPo->op_first->op_type == OP_CONCAT)
5330 o->op_flags |= OPf_STACKED;
5335 Perl_ck_spair(pTHX_ OP *o)
5337 if (o->op_flags & OPf_KIDS) {
5340 OPCODE type = o->op_type;
5341 o = modkids(ck_fun(o), type);
5342 kid = cUNOPo->op_first;
5343 newop = kUNOP->op_first->op_sibling;
5345 (newop->op_sibling ||
5346 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5347 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5348 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5352 op_free(kUNOP->op_first);
5353 kUNOP->op_first = newop;
5355 o->op_ppaddr = PL_ppaddr[++o->op_type];
5360 Perl_ck_delete(pTHX_ OP *o)
5364 if (o->op_flags & OPf_KIDS) {
5365 OP *kid = cUNOPo->op_first;
5366 switch (kid->op_type) {
5368 o->op_flags |= OPf_SPECIAL;
5371 o->op_private |= OPpSLICE;
5374 o->op_flags |= OPf_SPECIAL;
5379 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5380 PL_op_desc[o->op_type]);
5388 Perl_ck_eof(pTHX_ OP *o)
5390 I32 type = o->op_type;
5392 if (o->op_flags & OPf_KIDS) {
5393 if (cLISTOPo->op_first->op_type == OP_STUB) {
5395 o = newUNOP(type, OPf_SPECIAL,
5396 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5404 Perl_ck_eval(pTHX_ OP *o)
5406 PL_hints |= HINT_BLOCK_SCOPE;
5407 if (o->op_flags & OPf_KIDS) {
5408 SVOP *kid = (SVOP*)cUNOPo->op_first;
5411 o->op_flags &= ~OPf_KIDS;
5414 else if (kid->op_type == OP_LINESEQ) {
5417 kid->op_next = o->op_next;
5418 cUNOPo->op_first = 0;
5421 NewOp(1101, enter, 1, LOGOP);
5422 enter->op_type = OP_ENTERTRY;
5423 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5424 enter->op_private = 0;
5426 /* establish postfix order */
5427 enter->op_next = (OP*)enter;
5429 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5430 o->op_type = OP_LEAVETRY;
5431 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5432 enter->op_other = o;
5440 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5442 o->op_targ = (PADOFFSET)PL_hints;
5447 Perl_ck_exit(pTHX_ OP *o)
5450 HV *table = GvHV(PL_hintgv);
5452 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5453 if (svp && *svp && SvTRUE(*svp))
5454 o->op_private |= OPpEXIT_VMSISH;
5461 Perl_ck_exec(pTHX_ OP *o)
5464 if (o->op_flags & OPf_STACKED) {
5466 kid = cUNOPo->op_first->op_sibling;
5467 if (kid->op_type == OP_RV2GV)
5476 Perl_ck_exists(pTHX_ OP *o)
5479 if (o->op_flags & OPf_KIDS) {
5480 OP *kid = cUNOPo->op_first;
5481 if (kid->op_type == OP_ENTERSUB) {
5482 (void) ref(kid, o->op_type);
5483 if (kid->op_type != OP_RV2CV && !PL_error_count)
5484 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5485 PL_op_desc[o->op_type]);
5486 o->op_private |= OPpEXISTS_SUB;
5488 else if (kid->op_type == OP_AELEM)
5489 o->op_flags |= OPf_SPECIAL;
5490 else if (kid->op_type != OP_HELEM)
5491 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5492 PL_op_desc[o->op_type]);
5500 Perl_ck_gvconst(pTHX_ register OP *o)
5502 o = fold_constants(o);
5503 if (o->op_type == OP_CONST)
5510 Perl_ck_rvconst(pTHX_ register OP *o)
5512 SVOP *kid = (SVOP*)cUNOPo->op_first;
5514 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5515 if (kid->op_type == OP_CONST) {
5519 SV *kidsv = kid->op_sv;
5522 /* Is it a constant from cv_const_sv()? */
5523 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5524 SV *rsv = SvRV(kidsv);
5525 int svtype = SvTYPE(rsv);
5526 char *badtype = Nullch;
5528 switch (o->op_type) {
5530 if (svtype > SVt_PVMG)
5531 badtype = "a SCALAR";
5534 if (svtype != SVt_PVAV)
5535 badtype = "an ARRAY";
5538 if (svtype != SVt_PVHV) {
5539 if (svtype == SVt_PVAV) { /* pseudohash? */
5540 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5541 if (ksv && SvROK(*ksv)
5542 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5551 if (svtype != SVt_PVCV)
5556 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5559 name = SvPV(kidsv, n_a);
5560 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5561 char *badthing = Nullch;
5562 switch (o->op_type) {
5564 badthing = "a SCALAR";
5567 badthing = "an ARRAY";
5570 badthing = "a HASH";
5575 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5579 * This is a little tricky. We only want to add the symbol if we
5580 * didn't add it in the lexer. Otherwise we get duplicate strict
5581 * warnings. But if we didn't add it in the lexer, we must at
5582 * least pretend like we wanted to add it even if it existed before,
5583 * or we get possible typo warnings. OPpCONST_ENTERED says
5584 * whether the lexer already added THIS instance of this symbol.
5586 iscv = (o->op_type == OP_RV2CV) * 2;
5588 gv = gv_fetchpv(name,
5589 iscv | !(kid->op_private & OPpCONST_ENTERED),
5592 : o->op_type == OP_RV2SV
5594 : o->op_type == OP_RV2AV
5596 : o->op_type == OP_RV2HV
5599 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5601 kid->op_type = OP_GV;
5602 SvREFCNT_dec(kid->op_sv);
5604 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5605 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5606 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5608 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5610 kid->op_sv = SvREFCNT_inc(gv);
5612 kid->op_private = 0;
5613 kid->op_ppaddr = PL_ppaddr[OP_GV];
5620 Perl_ck_ftst(pTHX_ OP *o)
5622 I32 type = o->op_type;
5624 if (o->op_flags & OPf_REF) {
5627 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5628 SVOP *kid = (SVOP*)cUNOPo->op_first;
5630 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5632 OP *newop = newGVOP(type, OPf_REF,
5633 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5640 if (type == OP_FTTTY)
5641 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5644 o = newUNOP(type, 0, newDEFSVOP());
5650 Perl_ck_fun(pTHX_ OP *o)
5656 int type = o->op_type;
5657 register I32 oa = PL_opargs[type] >> OASHIFT;
5659 if (o->op_flags & OPf_STACKED) {
5660 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5663 return no_fh_allowed(o);
5666 if (o->op_flags & OPf_KIDS) {
5668 tokid = &cLISTOPo->op_first;
5669 kid = cLISTOPo->op_first;
5670 if (kid->op_type == OP_PUSHMARK ||
5671 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5673 tokid = &kid->op_sibling;
5674 kid = kid->op_sibling;
5676 if (!kid && PL_opargs[type] & OA_DEFGV)
5677 *tokid = kid = newDEFSVOP();
5681 sibl = kid->op_sibling;
5684 /* list seen where single (scalar) arg expected? */
5685 if (numargs == 1 && !(oa >> 4)
5686 && kid->op_type == OP_LIST && type != OP_SCALAR)
5688 return too_many_arguments(o,PL_op_desc[type]);
5701 if ((type == OP_PUSH || type == OP_UNSHIFT)
5702 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5703 Perl_warner(aTHX_ WARN_SYNTAX,
5704 "Useless use of %s with no values",
5707 if (kid->op_type == OP_CONST &&
5708 (kid->op_private & OPpCONST_BARE))
5710 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5711 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5712 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5713 if (ckWARN(WARN_DEPRECATED))
5714 Perl_warner(aTHX_ WARN_DEPRECATED,
5715 "Array @%s missing the @ in argument %"IVdf" of %s()",
5716 name, (IV)numargs, PL_op_desc[type]);
5719 kid->op_sibling = sibl;
5722 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5723 bad_type(numargs, "array", PL_op_desc[type], kid);
5727 if (kid->op_type == OP_CONST &&
5728 (kid->op_private & OPpCONST_BARE))
5730 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5731 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5732 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5733 if (ckWARN(WARN_DEPRECATED))
5734 Perl_warner(aTHX_ WARN_DEPRECATED,
5735 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5736 name, (IV)numargs, PL_op_desc[type]);
5739 kid->op_sibling = sibl;
5742 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5743 bad_type(numargs, "hash", PL_op_desc[type], kid);
5748 OP *newop = newUNOP(OP_NULL, 0, kid);
5749 kid->op_sibling = 0;
5751 newop->op_next = newop;
5753 kid->op_sibling = sibl;
5758 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5759 if (kid->op_type == OP_CONST &&
5760 (kid->op_private & OPpCONST_BARE))
5762 OP *newop = newGVOP(OP_GV, 0,
5763 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5768 else if (kid->op_type == OP_READLINE) {
5769 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5770 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5773 I32 flags = OPf_SPECIAL;
5777 /* is this op a FH constructor? */
5778 if (is_handle_constructor(o,numargs)) {
5779 char *name = Nullch;
5783 /* Set a flag to tell rv2gv to vivify
5784 * need to "prove" flag does not mean something
5785 * else already - NI-S 1999/05/07
5788 if (kid->op_type == OP_PADSV) {
5789 SV **namep = av_fetch(PL_comppad_name,
5791 if (namep && *namep)
5792 name = SvPV(*namep, len);
5794 else if (kid->op_type == OP_RV2SV
5795 && kUNOP->op_first->op_type == OP_GV)
5797 GV *gv = cGVOPx_gv(kUNOP->op_first);
5799 len = GvNAMELEN(gv);
5801 else if (kid->op_type == OP_AELEM
5802 || kid->op_type == OP_HELEM)
5804 name = "__ANONIO__";
5810 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5811 namesv = PL_curpad[targ];
5812 (void)SvUPGRADE(namesv, SVt_PV);
5814 sv_setpvn(namesv, "$", 1);
5815 sv_catpvn(namesv, name, len);
5818 kid->op_sibling = 0;
5819 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5820 kid->op_targ = targ;
5821 kid->op_private |= priv;
5823 kid->op_sibling = sibl;
5829 mod(scalar(kid), type);
5833 tokid = &kid->op_sibling;
5834 kid = kid->op_sibling;
5836 o->op_private |= numargs;
5838 return too_many_arguments(o,PL_op_desc[o->op_type]);
5841 else if (PL_opargs[type] & OA_DEFGV) {
5843 return newUNOP(type, 0, newDEFSVOP());
5847 while (oa & OA_OPTIONAL)
5849 if (oa && oa != OA_LIST)
5850 return too_few_arguments(o,PL_op_desc[o->op_type]);
5856 Perl_ck_glob(pTHX_ OP *o)
5861 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5862 append_elem(OP_GLOB, o, newDEFSVOP());
5864 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5865 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5867 #if !defined(PERL_EXTERNAL_GLOB)
5868 /* XXX this can be tightened up and made more failsafe. */
5872 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5874 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5875 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5876 GvCV(gv) = GvCV(glob_gv);
5877 SvREFCNT_inc((SV*)GvCV(gv));
5878 GvIMPORTED_CV_on(gv);
5881 #endif /* PERL_EXTERNAL_GLOB */
5883 if (gv && GvIMPORTED_CV(gv)) {
5884 append_elem(OP_GLOB, o,
5885 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5886 o->op_type = OP_LIST;
5887 o->op_ppaddr = PL_ppaddr[OP_LIST];
5888 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5889 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5890 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5891 append_elem(OP_LIST, o,
5892 scalar(newUNOP(OP_RV2CV, 0,
5893 newGVOP(OP_GV, 0, gv)))));
5894 o = newUNOP(OP_NULL, 0, ck_subr(o));
5895 o->op_targ = OP_GLOB; /* hint at what it used to be */
5898 gv = newGVgen("main");
5900 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5906 Perl_ck_grep(pTHX_ OP *o)
5910 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5912 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5913 NewOp(1101, gwop, 1, LOGOP);
5915 if (o->op_flags & OPf_STACKED) {
5918 kid = cLISTOPo->op_first->op_sibling;
5919 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5922 kid->op_next = (OP*)gwop;
5923 o->op_flags &= ~OPf_STACKED;
5925 kid = cLISTOPo->op_first->op_sibling;
5926 if (type == OP_MAPWHILE)
5933 kid = cLISTOPo->op_first->op_sibling;
5934 if (kid->op_type != OP_NULL)
5935 Perl_croak(aTHX_ "panic: ck_grep");
5936 kid = kUNOP->op_first;
5938 gwop->op_type = type;
5939 gwop->op_ppaddr = PL_ppaddr[type];
5940 gwop->op_first = listkids(o);
5941 gwop->op_flags |= OPf_KIDS;
5942 gwop->op_private = 1;
5943 gwop->op_other = LINKLIST(kid);
5944 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5945 kid->op_next = (OP*)gwop;
5947 kid = cLISTOPo->op_first->op_sibling;
5948 if (!kid || !kid->op_sibling)
5949 return too_few_arguments(o,PL_op_desc[o->op_type]);
5950 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5951 mod(kid, OP_GREPSTART);
5957 Perl_ck_index(pTHX_ OP *o)
5959 if (o->op_flags & OPf_KIDS) {
5960 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5962 kid = kid->op_sibling; /* get past "big" */
5963 if (kid && kid->op_type == OP_CONST)
5964 fbm_compile(((SVOP*)kid)->op_sv, 0);
5970 Perl_ck_lengthconst(pTHX_ OP *o)
5972 /* XXX length optimization goes here */
5977 Perl_ck_lfun(pTHX_ OP *o)
5979 OPCODE type = o->op_type;
5980 return modkids(ck_fun(o), type);
5984 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5986 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5987 switch (cUNOPo->op_first->op_type) {
5989 /* This is needed for
5990 if (defined %stash::)
5991 to work. Do not break Tk.
5993 break; /* Globals via GV can be undef */
5995 case OP_AASSIGN: /* Is this a good idea? */
5996 Perl_warner(aTHX_ WARN_DEPRECATED,
5997 "defined(@array) is deprecated");
5998 Perl_warner(aTHX_ WARN_DEPRECATED,
5999 "\t(Maybe you should just omit the defined()?)\n");
6002 /* This is needed for
6003 if (defined %stash::)
6004 to work. Do not break Tk.
6006 break; /* Globals via GV can be undef */
6008 Perl_warner(aTHX_ WARN_DEPRECATED,
6009 "defined(%%hash) is deprecated");
6010 Perl_warner(aTHX_ WARN_DEPRECATED,
6011 "\t(Maybe you should just omit the defined()?)\n");
6022 Perl_ck_rfun(pTHX_ OP *o)
6024 OPCODE type = o->op_type;
6025 return refkids(ck_fun(o), type);
6029 Perl_ck_listiob(pTHX_ OP *o)
6033 kid = cLISTOPo->op_first;
6036 kid = cLISTOPo->op_first;
6038 if (kid->op_type == OP_PUSHMARK)
6039 kid = kid->op_sibling;
6040 if (kid && o->op_flags & OPf_STACKED)
6041 kid = kid->op_sibling;
6042 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6043 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6044 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6045 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6046 cLISTOPo->op_first->op_sibling = kid;
6047 cLISTOPo->op_last = kid;
6048 kid = kid->op_sibling;
6053 append_elem(o->op_type, o, newDEFSVOP());
6059 Perl_ck_sassign(pTHX_ OP *o)
6061 OP *kid = cLISTOPo->op_first;
6062 /* has a disposable target? */
6063 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6064 && !(kid->op_flags & OPf_STACKED)
6065 /* Cannot steal the second time! */
6066 && !(kid->op_private & OPpTARGET_MY))
6068 OP *kkid = kid->op_sibling;
6070 /* Can just relocate the target. */
6071 if (kkid && kkid->op_type == OP_PADSV
6072 && !(kkid->op_private & OPpLVAL_INTRO))
6074 kid->op_targ = kkid->op_targ;
6076 /* Now we do not need PADSV and SASSIGN. */
6077 kid->op_sibling = o->op_sibling; /* NULL */
6078 cLISTOPo->op_first = NULL;
6081 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6089 Perl_ck_match(pTHX_ OP *o)
6091 o->op_private |= OPpRUNTIME;
6096 Perl_ck_method(pTHX_ OP *o)
6098 OP *kid = cUNOPo->op_first;
6099 if (kid->op_type == OP_CONST) {
6100 SV* sv = kSVOP->op_sv;
6101 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6103 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6104 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6107 kSVOP->op_sv = Nullsv;
6109 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6118 Perl_ck_null(pTHX_ OP *o)
6124 Perl_ck_octmode(pTHX_ OP *o)
6128 if ((ckWARN(WARN_OCTMODE)
6129 /* Add WARN_MKDIR instead of getting rid of WARN_{CHMOD,UMASK}.
6130 Backwards compatibility and consistency are terrible things.
6132 || (o->op_type == OP_CHMOD && ckWARN(WARN_CHMOD))
6133 || (o->op_type == OP_UMASK && ckWARN(WARN_UMASK))
6134 || (o->op_type == OP_MKDIR && ckWARN(WARN_MKDIR)))
6135 && o->op_flags & OPf_KIDS)
6137 if (o->op_type == OP_MKDIR)
6138 p = cLISTOPo->op_last; /* mkdir $foo, 0777 */
6139 else if (o->op_type == OP_CHMOD)
6140 p = cLISTOPo->op_first->op_sibling; /* chmod 0777, $foo */
6142 p = cUNOPo->op_first; /* umask 0222 */
6144 if (p->op_type == OP_CONST && !(p->op_private & OPpCONST_OCTAL)) {
6145 int mode = SvIV(cSVOPx_sv(p));
6147 Perl_warner(aTHX_ WARN_OCTMODE,
6148 "Non-octal literal mode (%d) specified", mode);
6149 Perl_warner(aTHX_ WARN_OCTMODE,
6150 "\t(Did you mean 0%d instead?)\n", mode);
6157 Perl_ck_open(pTHX_ OP *o)
6159 HV *table = GvHV(PL_hintgv);
6163 svp = hv_fetch(table, "open_IN", 7, FALSE);
6165 mode = mode_from_discipline(*svp);
6166 if (mode & O_BINARY)
6167 o->op_private |= OPpOPEN_IN_RAW;
6168 else if (mode & O_TEXT)
6169 o->op_private |= OPpOPEN_IN_CRLF;
6172 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6174 mode = mode_from_discipline(*svp);
6175 if (mode & O_BINARY)
6176 o->op_private |= OPpOPEN_OUT_RAW;
6177 else if (mode & O_TEXT)
6178 o->op_private |= OPpOPEN_OUT_CRLF;
6181 if (o->op_type == OP_BACKTICK)
6187 Perl_ck_repeat(pTHX_ OP *o)
6189 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6190 o->op_private |= OPpREPEAT_DOLIST;
6191 cBINOPo->op_first = force_list(cBINOPo->op_first);
6199 Perl_ck_require(pTHX_ OP *o)
6203 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6204 SVOP *kid = (SVOP*)cUNOPo->op_first;
6206 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6208 for (s = SvPVX(kid->op_sv); *s; s++) {
6209 if (*s == ':' && s[1] == ':') {
6211 Move(s+2, s+1, strlen(s+2)+1, char);
6212 --SvCUR(kid->op_sv);
6215 if (SvREADONLY(kid->op_sv)) {
6216 SvREADONLY_off(kid->op_sv);
6217 sv_catpvn(kid->op_sv, ".pm", 3);
6218 SvREADONLY_on(kid->op_sv);
6221 sv_catpvn(kid->op_sv, ".pm", 3);
6225 /* handle override, if any */
6226 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6227 if (!(gv && GvIMPORTED_CV(gv)))
6228 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6230 if (gv && GvIMPORTED_CV(gv)) {
6231 OP *kid = cUNOPo->op_first;
6232 cUNOPo->op_first = 0;
6234 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6235 append_elem(OP_LIST, kid,
6236 scalar(newUNOP(OP_RV2CV, 0,
6245 Perl_ck_return(pTHX_ OP *o)
6248 if (CvLVALUE(PL_compcv)) {
6249 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6250 mod(kid, OP_LEAVESUBLV);
6257 Perl_ck_retarget(pTHX_ OP *o)
6259 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6266 Perl_ck_select(pTHX_ OP *o)
6269 if (o->op_flags & OPf_KIDS) {
6270 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6271 if (kid && kid->op_sibling) {
6272 o->op_type = OP_SSELECT;
6273 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6275 return fold_constants(o);
6279 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6280 if (kid && kid->op_type == OP_RV2GV)
6281 kid->op_private &= ~HINT_STRICT_REFS;
6286 Perl_ck_shift(pTHX_ OP *o)
6288 I32 type = o->op_type;
6290 if (!(o->op_flags & OPf_KIDS)) {
6295 if (!CvUNIQUE(PL_compcv)) {
6296 argop = newOP(OP_PADAV, OPf_REF);
6297 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6300 argop = newUNOP(OP_RV2AV, 0,
6301 scalar(newGVOP(OP_GV, 0,
6302 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6305 argop = newUNOP(OP_RV2AV, 0,
6306 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6307 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6308 #endif /* USE_THREADS */
6309 return newUNOP(type, 0, scalar(argop));
6311 return scalar(modkids(ck_fun(o), type));
6315 Perl_ck_sort(pTHX_ OP *o)
6319 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6321 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6322 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6324 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6326 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6328 if (kid->op_type == OP_SCOPE) {
6332 else if (kid->op_type == OP_LEAVE) {
6333 if (o->op_type == OP_SORT) {
6334 op_null(kid); /* wipe out leave */
6337 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6338 if (k->op_next == kid)
6340 /* don't descend into loops */
6341 else if (k->op_type == OP_ENTERLOOP
6342 || k->op_type == OP_ENTERITER)
6344 k = cLOOPx(k)->op_lastop;
6349 kid->op_next = 0; /* just disconnect the leave */
6350 k = kLISTOP->op_first;
6355 if (o->op_type == OP_SORT) {
6356 /* provide scalar context for comparison function/block */
6362 o->op_flags |= OPf_SPECIAL;
6364 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6367 firstkid = firstkid->op_sibling;
6370 /* provide list context for arguments */
6371 if (o->op_type == OP_SORT)
6378 S_simplify_sort(pTHX_ OP *o)
6380 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6384 if (!(o->op_flags & OPf_STACKED))
6386 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6387 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6388 kid = kUNOP->op_first; /* get past null */
6389 if (kid->op_type != OP_SCOPE)
6391 kid = kLISTOP->op_last; /* get past scope */
6392 switch(kid->op_type) {
6400 k = kid; /* remember this node*/
6401 if (kBINOP->op_first->op_type != OP_RV2SV)
6403 kid = kBINOP->op_first; /* get past cmp */
6404 if (kUNOP->op_first->op_type != OP_GV)
6406 kid = kUNOP->op_first; /* get past rv2sv */
6408 if (GvSTASH(gv) != PL_curstash)
6410 if (strEQ(GvNAME(gv), "a"))
6412 else if (strEQ(GvNAME(gv), "b"))
6416 kid = k; /* back to cmp */
6417 if (kBINOP->op_last->op_type != OP_RV2SV)
6419 kid = kBINOP->op_last; /* down to 2nd arg */
6420 if (kUNOP->op_first->op_type != OP_GV)
6422 kid = kUNOP->op_first; /* get past rv2sv */
6424 if (GvSTASH(gv) != PL_curstash
6426 ? strNE(GvNAME(gv), "a")
6427 : strNE(GvNAME(gv), "b")))
6429 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6431 o->op_private |= OPpSORT_REVERSE;
6432 if (k->op_type == OP_NCMP)
6433 o->op_private |= OPpSORT_NUMERIC;
6434 if (k->op_type == OP_I_NCMP)
6435 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6436 kid = cLISTOPo->op_first->op_sibling;
6437 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6438 op_free(kid); /* then delete it */
6442 Perl_ck_split(pTHX_ OP *o)
6446 if (o->op_flags & OPf_STACKED)
6447 return no_fh_allowed(o);
6449 kid = cLISTOPo->op_first;
6450 if (kid->op_type != OP_NULL)
6451 Perl_croak(aTHX_ "panic: ck_split");
6452 kid = kid->op_sibling;
6453 op_free(cLISTOPo->op_first);
6454 cLISTOPo->op_first = kid;
6456 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6457 cLISTOPo->op_last = kid; /* There was only one element previously */
6460 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6461 OP *sibl = kid->op_sibling;
6462 kid->op_sibling = 0;
6463 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6464 if (cLISTOPo->op_first == cLISTOPo->op_last)
6465 cLISTOPo->op_last = kid;
6466 cLISTOPo->op_first = kid;
6467 kid->op_sibling = sibl;
6470 kid->op_type = OP_PUSHRE;
6471 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6474 if (!kid->op_sibling)
6475 append_elem(OP_SPLIT, o, newDEFSVOP());
6477 kid = kid->op_sibling;
6480 if (!kid->op_sibling)
6481 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6483 kid = kid->op_sibling;
6486 if (kid->op_sibling)
6487 return too_many_arguments(o,PL_op_desc[o->op_type]);
6493 Perl_ck_join(pTHX_ OP *o)
6495 if (ckWARN(WARN_SYNTAX)) {
6496 OP *kid = cLISTOPo->op_first->op_sibling;
6497 if (kid && kid->op_type == OP_MATCH) {
6498 char *pmstr = "STRING";
6499 if (PM_GETRE(kPMOP))
6500 pmstr = PM_GETRE(kPMOP)->precomp;
6501 Perl_warner(aTHX_ WARN_SYNTAX,
6502 "/%s/ should probably be written as \"%s\"",
6510 Perl_ck_subr(pTHX_ OP *o)
6512 OP *prev = ((cUNOPo->op_first->op_sibling)
6513 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6514 OP *o2 = prev->op_sibling;
6523 o->op_private |= OPpENTERSUB_HASTARG;
6524 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6525 if (cvop->op_type == OP_RV2CV) {
6527 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6528 op_null(cvop); /* disable rv2cv */
6529 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6530 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6531 GV *gv = cGVOPx_gv(tmpop);
6534 tmpop->op_private |= OPpEARLY_CV;
6535 else if (SvPOK(cv)) {
6536 namegv = CvANON(cv) ? gv : CvGV(cv);
6537 proto = SvPV((SV*)cv, n_a);
6541 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6542 if (o2->op_type == OP_CONST)
6543 o2->op_private &= ~OPpCONST_STRICT;
6544 else if (o2->op_type == OP_LIST) {
6545 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6546 if (o && o->op_type == OP_CONST)
6547 o->op_private &= ~OPpCONST_STRICT;
6550 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6551 if (PERLDB_SUB && PL_curstash != PL_debstash)
6552 o->op_private |= OPpENTERSUB_DB;
6553 while (o2 != cvop) {
6557 return too_many_arguments(o, gv_ename(namegv));
6575 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6577 arg == 1 ? "block or sub {}" : "sub {}",
6578 gv_ename(namegv), o2);
6581 /* '*' allows any scalar type, including bareword */
6584 if (o2->op_type == OP_RV2GV)
6585 goto wrapref; /* autoconvert GLOB -> GLOBref */
6586 else if (o2->op_type == OP_CONST)
6587 o2->op_private &= ~OPpCONST_STRICT;
6588 else if (o2->op_type == OP_ENTERSUB) {
6589 /* accidental subroutine, revert to bareword */
6590 OP *gvop = ((UNOP*)o2)->op_first;
6591 if (gvop && gvop->op_type == OP_NULL) {
6592 gvop = ((UNOP*)gvop)->op_first;
6594 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6597 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6598 (gvop = ((UNOP*)gvop)->op_first) &&
6599 gvop->op_type == OP_GV)
6601 GV *gv = cGVOPx_gv(gvop);
6602 OP *sibling = o2->op_sibling;
6603 SV *n = newSVpvn("",0);
6605 gv_fullname3(n, gv, "");
6606 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6607 sv_chop(n, SvPVX(n)+6);
6608 o2 = newSVOP(OP_CONST, 0, n);
6609 prev->op_sibling = o2;
6610 o2->op_sibling = sibling;
6622 if (o2->op_type != OP_RV2GV)
6623 bad_type(arg, "symbol", gv_ename(namegv), o2);
6626 if (o2->op_type != OP_ENTERSUB)
6627 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6630 if (o2->op_type != OP_RV2SV
6631 && o2->op_type != OP_PADSV
6632 && o2->op_type != OP_HELEM
6633 && o2->op_type != OP_AELEM
6634 && o2->op_type != OP_THREADSV)
6636 bad_type(arg, "scalar", gv_ename(namegv), o2);
6640 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6641 bad_type(arg, "array", gv_ename(namegv), o2);
6644 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6645 bad_type(arg, "hash", gv_ename(namegv), o2);
6649 OP* sib = kid->op_sibling;
6650 kid->op_sibling = 0;
6651 o2 = newUNOP(OP_REFGEN, 0, kid);
6652 o2->op_sibling = sib;
6653 prev->op_sibling = o2;
6664 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6665 gv_ename(namegv), SvPV((SV*)cv, n_a));
6670 mod(o2, OP_ENTERSUB);
6672 o2 = o2->op_sibling;
6674 if (proto && !optional &&
6675 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6676 return too_few_arguments(o, gv_ename(namegv));
6681 Perl_ck_svconst(pTHX_ OP *o)
6683 SvREADONLY_on(cSVOPo->op_sv);
6688 Perl_ck_trunc(pTHX_ OP *o)
6690 if (o->op_flags & OPf_KIDS) {
6691 SVOP *kid = (SVOP*)cUNOPo->op_first;
6693 if (kid->op_type == OP_NULL)
6694 kid = (SVOP*)kid->op_sibling;
6695 if (kid && kid->op_type == OP_CONST &&
6696 (kid->op_private & OPpCONST_BARE))
6698 o->op_flags |= OPf_SPECIAL;
6699 kid->op_private &= ~OPpCONST_STRICT;
6706 Perl_ck_substr(pTHX_ OP *o)
6709 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6710 OP *kid = cLISTOPo->op_first;
6712 if (kid->op_type == OP_NULL)
6713 kid = kid->op_sibling;
6715 kid->op_flags |= OPf_MOD;
6721 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6724 Perl_peep(pTHX_ register OP *o)
6726 register OP* oldop = 0;
6729 if (!o || o->op_seq)
6733 SAVEVPTR(PL_curcop);
6734 for (; o; o = o->op_next) {
6740 switch (o->op_type) {
6744 PL_curcop = ((COP*)o); /* for warnings */
6745 o->op_seq = PL_op_seqmax++;
6749 if (cSVOPo->op_private & OPpCONST_STRICT)
6750 no_bareword_allowed(o);
6752 /* Relocate sv to the pad for thread safety.
6753 * Despite being a "constant", the SV is written to,
6754 * for reference counts, sv_upgrade() etc. */
6756 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6757 if (SvPADTMP(cSVOPo->op_sv)) {
6758 /* If op_sv is already a PADTMP then it is being used by
6759 * some pad, so make a copy. */
6760 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6761 SvREADONLY_on(PL_curpad[ix]);
6762 SvREFCNT_dec(cSVOPo->op_sv);
6765 SvREFCNT_dec(PL_curpad[ix]);
6766 SvPADTMP_on(cSVOPo->op_sv);
6767 PL_curpad[ix] = cSVOPo->op_sv;
6768 /* XXX I don't know how this isn't readonly already. */
6769 SvREADONLY_on(PL_curpad[ix]);
6771 cSVOPo->op_sv = Nullsv;
6775 o->op_seq = PL_op_seqmax++;
6779 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6780 if (o->op_next->op_private & OPpTARGET_MY) {
6781 if (o->op_flags & OPf_STACKED) /* chained concats */
6782 goto ignore_optimization;
6784 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6785 o->op_targ = o->op_next->op_targ;
6786 o->op_next->op_targ = 0;
6787 o->op_private |= OPpTARGET_MY;
6790 op_null(o->op_next);
6792 ignore_optimization:
6793 o->op_seq = PL_op_seqmax++;
6796 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6797 o->op_seq = PL_op_seqmax++;
6798 break; /* Scalar stub must produce undef. List stub is noop */
6802 if (o->op_targ == OP_NEXTSTATE
6803 || o->op_targ == OP_DBSTATE
6804 || o->op_targ == OP_SETSTATE)
6806 PL_curcop = ((COP*)o);
6813 if (oldop && o->op_next) {
6814 oldop->op_next = o->op_next;
6817 o->op_seq = PL_op_seqmax++;
6821 if (o->op_next->op_type == OP_RV2SV) {
6822 if (!(o->op_next->op_private & OPpDEREF)) {
6823 op_null(o->op_next);
6824 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6826 o->op_next = o->op_next->op_next;
6827 o->op_type = OP_GVSV;
6828 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6831 else if (o->op_next->op_type == OP_RV2AV) {
6832 OP* pop = o->op_next->op_next;
6834 if (pop->op_type == OP_CONST &&
6835 (PL_op = pop->op_next) &&
6836 pop->op_next->op_type == OP_AELEM &&
6837 !(pop->op_next->op_private &
6838 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6839 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6844 op_null(o->op_next);
6845 op_null(pop->op_next);
6847 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6848 o->op_next = pop->op_next->op_next;
6849 o->op_type = OP_AELEMFAST;
6850 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6851 o->op_private = (U8)i;
6856 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6858 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6859 /* XXX could check prototype here instead of just carping */
6860 SV *sv = sv_newmortal();
6861 gv_efullname3(sv, gv, Nullch);
6862 Perl_warner(aTHX_ WARN_PROTOTYPE,
6863 "%s() called too early to check prototype",
6868 o->op_seq = PL_op_seqmax++;
6879 o->op_seq = PL_op_seqmax++;
6880 while (cLOGOP->op_other->op_type == OP_NULL)
6881 cLOGOP->op_other = cLOGOP->op_other->op_next;
6882 peep(cLOGOP->op_other);
6887 o->op_seq = PL_op_seqmax++;
6888 while (cLOOP->op_redoop->op_type == OP_NULL)
6889 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6890 peep(cLOOP->op_redoop);
6891 while (cLOOP->op_nextop->op_type == OP_NULL)
6892 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6893 peep(cLOOP->op_nextop);
6894 while (cLOOP->op_lastop->op_type == OP_NULL)
6895 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6896 peep(cLOOP->op_lastop);
6902 o->op_seq = PL_op_seqmax++;
6903 while (cPMOP->op_pmreplstart &&
6904 cPMOP->op_pmreplstart->op_type == OP_NULL)
6905 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6906 peep(cPMOP->op_pmreplstart);
6910 o->op_seq = PL_op_seqmax++;
6911 if (ckWARN(WARN_SYNTAX) && o->op_next
6912 && o->op_next->op_type == OP_NEXTSTATE) {
6913 if (o->op_next->op_sibling &&
6914 o->op_next->op_sibling->op_type != OP_EXIT &&
6915 o->op_next->op_sibling->op_type != OP_WARN &&
6916 o->op_next->op_sibling->op_type != OP_DIE) {
6917 line_t oldline = CopLINE(PL_curcop);
6919 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6920 Perl_warner(aTHX_ WARN_EXEC,
6921 "Statement unlikely to be reached");
6922 Perl_warner(aTHX_ WARN_EXEC,
6923 "\t(Maybe you meant system() when you said exec()?)\n");
6924 CopLINE_set(PL_curcop, oldline);
6933 SV **svp, **indsvp, *sv;
6938 o->op_seq = PL_op_seqmax++;
6940 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6943 /* Make the CONST have a shared SV */
6944 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6945 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6946 key = SvPV(sv, keylen);
6947 lexname = newSVpvn_share(key,
6948 SvUTF8(sv) ? -(I32)keylen : keylen,
6954 if ((o->op_private & (OPpLVAL_INTRO)))
6957 rop = (UNOP*)((BINOP*)o)->op_first;
6958 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6960 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6961 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6963 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6964 if (!fields || !GvHV(*fields))
6966 key = SvPV(*svp, keylen);
6967 indsvp = hv_fetch(GvHV(*fields), key,
6968 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6970 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6971 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6973 ind = SvIV(*indsvp);
6975 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6976 rop->op_type = OP_RV2AV;
6977 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6978 o->op_type = OP_AELEM;
6979 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6981 if (SvREADONLY(*svp))
6983 SvFLAGS(sv) |= (SvFLAGS(*svp)
6984 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6994 SV **svp, **indsvp, *sv;
6998 SVOP *first_key_op, *key_op;
7000 o->op_seq = PL_op_seqmax++;
7001 if ((o->op_private & (OPpLVAL_INTRO))
7002 /* I bet there's always a pushmark... */
7003 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7004 /* hmmm, no optimization if list contains only one key. */
7006 rop = (UNOP*)((LISTOP*)o)->op_last;
7007 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7009 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7010 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7012 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7013 if (!fields || !GvHV(*fields))
7015 /* Again guessing that the pushmark can be jumped over.... */
7016 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7017 ->op_first->op_sibling;
7018 /* Check that the key list contains only constants. */
7019 for (key_op = first_key_op; key_op;
7020 key_op = (SVOP*)key_op->op_sibling)
7021 if (key_op->op_type != OP_CONST)
7025 rop->op_type = OP_RV2AV;
7026 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7027 o->op_type = OP_ASLICE;
7028 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7029 for (key_op = first_key_op; key_op;
7030 key_op = (SVOP*)key_op->op_sibling) {
7031 svp = cSVOPx_svp(key_op);
7032 key = SvPV(*svp, keylen);
7033 indsvp = hv_fetch(GvHV(*fields), key,
7034 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7036 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7037 "in variable %s of type %s",
7038 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7040 ind = SvIV(*indsvp);
7042 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7044 if (SvREADONLY(*svp))
7046 SvFLAGS(sv) |= (SvFLAGS(*svp)
7047 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7055 o->op_seq = PL_op_seqmax++;
7065 /* Efficient sub that returns a constant scalar value. */
7067 const_sv_xsub(pTHXo_ CV* cv)
7072 Perl_croak(aTHX_ "usage: %s::%s()",
7073 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7077 ST(0) = (SV*)XSANY.any_ptr;