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 CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
25 /* #define PL_OP_SLAB_ALLOC */
27 #ifdef PL_OP_SLAB_ALLOC
28 #define SLAB_SIZE 8192
29 static char *PL_OpPtr = NULL;
30 static int PL_OpSpace = 0;
31 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
32 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
34 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
40 Newz(m,PL_OpPtr,SLAB_SIZE,char);
41 PL_OpSpace = SLAB_SIZE - sz;
42 return PL_OpPtr += PL_OpSpace;
46 #define NewOp(m, var, c, type) Newz(m, var, c, type)
49 * In the following definition, the ", Nullop" is just to make the compiler
50 * think the expression is of the right type: croak actually does a Siglongjmp.
52 #define CHECKOP(type,o) \
53 ((PL_op_mask && PL_op_mask[type]) \
54 ? ( op_free((OP*)o), \
55 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
57 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
59 #define PAD_MAX 999999999
60 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
63 S_gv_ename(pTHX_ GV *gv)
66 SV* tmpsv = sv_newmortal();
67 gv_efullname3(tmpsv, gv, Nullch);
68 return SvPV(tmpsv,n_a);
72 S_no_fh_allowed(pTHX_ OP *o)
74 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
75 PL_op_desc[o->op_type]));
80 S_too_few_arguments(pTHX_ OP *o, char *name)
82 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
87 S_too_many_arguments(pTHX_ OP *o, char *name)
89 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
94 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
96 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
97 (int)n, name, t, PL_op_desc[kid->op_type]));
101 S_no_bareword_allowed(pTHX_ OP *o)
103 qerror(Perl_mess(aTHX_
104 "Bareword \"%s\" not allowed while \"strict subs\" in use",
105 SvPV_nolen(cSVOPo_sv)));
108 /* "register" allocation */
111 Perl_pad_allocmy(pTHX_ char *name)
116 if (!(PL_in_my == KEY_our ||
118 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
119 (name[1] == '_' && (int)strlen(name) > 2)))
121 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
122 /* 1999-02-27 mjd@plover.com */
124 p = strchr(name, '\0');
125 /* The next block assumes the buffer is at least 205 chars
126 long. At present, it's always at least 256 chars. */
128 strcpy(name+200, "...");
134 /* Move everything else down one character */
135 for (; p-name > 2; p--)
137 name[2] = toCTRL(name[1]);
140 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
142 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
143 SV **svp = AvARRAY(PL_comppad_name);
144 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
145 PADOFFSET top = AvFILLp(PL_comppad_name);
146 for (off = top; off > PL_comppad_name_floor; off--) {
148 && sv != &PL_sv_undef
149 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
150 && (PL_in_my != KEY_our
151 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
152 && strEQ(name, SvPVX(sv)))
154 Perl_warner(aTHX_ WARN_MISC,
155 "\"%s\" variable %s masks earlier declaration in same %s",
156 (PL_in_my == KEY_our ? "our" : "my"),
158 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
163 if (PL_in_my == KEY_our) {
166 && sv != &PL_sv_undef
167 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
168 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
169 && strEQ(name, SvPVX(sv)))
171 Perl_warner(aTHX_ WARN_MISC,
172 "\"our\" variable %s redeclared", name);
173 Perl_warner(aTHX_ WARN_MISC,
174 "\t(Did you mean \"local\" instead of \"our\"?)\n");
177 } while ( off-- > 0 );
180 off = pad_alloc(OP_PADSV, SVs_PADMY);
182 sv_upgrade(sv, SVt_PVNV);
184 if (PL_in_my_stash) {
186 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
187 name, PL_in_my == KEY_our ? "our" : "my"));
188 SvFLAGS(sv) |= SVpad_TYPED;
189 (void)SvUPGRADE(sv, SVt_PVMG);
190 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
192 if (PL_in_my == KEY_our) {
193 (void)SvUPGRADE(sv, SVt_PVGV);
194 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
195 SvFLAGS(sv) |= SVpad_OUR;
197 av_store(PL_comppad_name, off, sv);
198 SvNVX(sv) = (NV)PAD_MAX;
199 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
200 if (!PL_min_intro_pending)
201 PL_min_intro_pending = off;
202 PL_max_intro_pending = off;
204 av_store(PL_comppad, off, (SV*)newAV());
205 else if (*name == '%')
206 av_store(PL_comppad, off, (SV*)newHV());
207 SvPADMY_on(PL_curpad[off]);
212 S_pad_addlex(pTHX_ SV *proto_namesv)
214 SV *namesv = NEWSV(1103,0);
215 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
216 sv_upgrade(namesv, SVt_PVNV);
217 sv_setpv(namesv, SvPVX(proto_namesv));
218 av_store(PL_comppad_name, newoff, namesv);
219 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
220 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
221 SvFAKE_on(namesv); /* A ref, not a real var */
222 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
223 SvFLAGS(namesv) |= SVpad_OUR;
224 (void)SvUPGRADE(namesv, SVt_PVGV);
225 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
227 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
228 SvFLAGS(namesv) |= SVpad_TYPED;
229 (void)SvUPGRADE(namesv, SVt_PVMG);
230 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
235 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
238 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
239 I32 cx_ix, I32 saweval, U32 flags)
245 register PERL_CONTEXT *cx;
247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
252 if (!svp || *svp == &PL_sv_undef)
255 svp = AvARRAY(curname);
256 for (off = AvFILLp(curname); off > 0; off--) {
257 if ((sv = svp[off]) &&
258 sv != &PL_sv_undef &&
260 seq > I_32(SvNVX(sv)) &&
261 strEQ(SvPVX(sv), name))
272 return 0; /* don't clone from inactive stack frame */
276 oldpad = (AV*)AvARRAY(curlist)[depth];
277 oldsv = *av_fetch(oldpad, off, TRUE);
278 if (!newoff) { /* Not a mere clone operation. */
279 newoff = pad_addlex(sv);
280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
281 /* "It's closures all the way down." */
282 CvCLONE_on(PL_compcv);
284 if (CvANON(PL_compcv))
285 oldsv = Nullsv; /* no need to keep ref */
290 bcv && bcv != cv && !CvCLONE(bcv);
291 bcv = CvOUTSIDE(bcv))
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
314 Perl_warner(aTHX_ WARN_CLOSURE,
315 "Variable \"%s\" may be unavailable",
323 else if (!CvUNIQUE(PL_compcv)) {
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
327 Perl_warner(aTHX_ WARN_CLOSURE,
328 "Variable \"%s\" will not stay shared", name);
332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
338 if (flags & FINDLEX_NOSEARCH)
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
346 for (i = cx_ix; i >= 0; i--) {
348 switch (CxTYPE(cx)) {
350 if (i == 0 && saweval) {
351 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
355 switch (cx->blk_eval.old_op_type) {
357 if (CxREALEVAL(cx)) {
360 seq = cxstack[i].blk_oldcop->cop_seq;
361 startcv = cxstack[i].blk_eval.cv;
362 if (startcv && CvOUTSIDE(startcv)) {
363 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
365 if (off) /* continue looking if not found here */
372 /* require/do must have their own scope */
381 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
382 saweval = i; /* so we know where we were called from */
383 seq = cxstack[i].blk_oldcop->cop_seq;
386 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
394 Perl_pad_findmy(pTHX_ char *name)
399 SV **svp = AvARRAY(PL_comppad_name);
400 U32 seq = PL_cop_seqmax;
406 * Special case to get lexical (and hence per-thread) @_.
407 * XXX I need to find out how to tell at parse-time whether use
408 * of @_ should refer to a lexical (from a sub) or defgv (global
409 * scope and maybe weird sub-ish things like formats). See
410 * startsub in perly.y. It's possible that @_ could be lexical
411 * (at least from subs) even in non-threaded perl.
413 if (strEQ(name, "@_"))
414 return 0; /* success. (NOT_IN_PAD indicates failure) */
415 #endif /* USE_THREADS */
417 /* The one we're looking for is probably just before comppad_name_fill. */
418 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
419 if ((sv = svp[off]) &&
420 sv != &PL_sv_undef &&
423 seq > I_32(SvNVX(sv)))) &&
424 strEQ(SvPVX(sv), name))
426 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
427 return (PADOFFSET)off;
428 pendoff = off; /* this pending def. will override import */
432 outside = CvOUTSIDE(PL_compcv);
434 /* Check if if we're compiling an eval'', and adjust seq to be the
435 * eval's seq number. This depends on eval'' having a non-null
436 * CvOUTSIDE() while it is being compiled. The eval'' itself is
437 * identified by CvEVAL being true and CvGV being null. */
438 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
439 cx = &cxstack[cxstack_ix];
441 seq = cx->blk_oldcop->cop_seq;
444 /* See if it's in a nested scope */
445 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
447 /* If there is a pending local definition, this new alias must die */
449 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
450 return off; /* pad_findlex returns 0 for failure...*/
452 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
456 Perl_pad_leavemy(pTHX_ I32 fill)
459 SV **svp = AvARRAY(PL_comppad_name);
461 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
462 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
463 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
464 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
467 /* "Deintroduce" my variables that are leaving with this scope. */
468 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
469 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
470 SvIVX(sv) = PL_cop_seqmax;
475 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
480 if (AvARRAY(PL_comppad) != PL_curpad)
481 Perl_croak(aTHX_ "panic: pad_alloc");
482 if (PL_pad_reset_pending)
484 if (tmptype & SVs_PADMY) {
486 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
487 } while (SvPADBUSY(sv)); /* need a fresh one */
488 retval = AvFILLp(PL_comppad);
491 SV **names = AvARRAY(PL_comppad_name);
492 SSize_t names_fill = AvFILLp(PL_comppad_name);
495 * "foreach" index vars temporarily become aliases to non-"my"
496 * values. Thus we must skip, not just pad values that are
497 * marked as current pad values, but also those with names.
499 if (++PL_padix <= names_fill &&
500 (sv = names[PL_padix]) && sv != &PL_sv_undef)
502 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
503 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
504 !IS_PADGV(sv) && !IS_PADCONST(sv))
509 SvFLAGS(sv) |= tmptype;
510 PL_curpad = AvARRAY(PL_comppad);
512 DEBUG_X(PerlIO_printf(Perl_debug_log,
513 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
514 PTR2UV(thr), PTR2UV(PL_curpad),
515 (long) retval, PL_op_name[optype]));
517 DEBUG_X(PerlIO_printf(Perl_debug_log,
518 "Pad 0x%"UVxf" alloc %ld for %s\n",
520 (long) retval, PL_op_name[optype]));
521 #endif /* USE_THREADS */
522 return (PADOFFSET)retval;
526 Perl_pad_sv(pTHX_ PADOFFSET po)
529 DEBUG_X(PerlIO_printf(Perl_debug_log,
530 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
531 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
534 Perl_croak(aTHX_ "panic: pad_sv po");
535 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
536 PTR2UV(PL_curpad), (IV)po));
537 #endif /* USE_THREADS */
538 return PL_curpad[po]; /* eventually we'll turn this into a macro */
542 Perl_pad_free(pTHX_ PADOFFSET po)
546 if (AvARRAY(PL_comppad) != PL_curpad)
547 Perl_croak(aTHX_ "panic: pad_free curpad");
549 Perl_croak(aTHX_ "panic: pad_free po");
551 DEBUG_X(PerlIO_printf(Perl_debug_log,
552 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
553 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
555 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
556 PTR2UV(PL_curpad), (IV)po));
557 #endif /* USE_THREADS */
558 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
559 SvPADTMP_off(PL_curpad[po]);
561 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
564 if ((I32)po < PL_padix)
569 Perl_pad_swipe(pTHX_ PADOFFSET po)
571 if (AvARRAY(PL_comppad) != PL_curpad)
572 Perl_croak(aTHX_ "panic: pad_swipe curpad");
574 Perl_croak(aTHX_ "panic: pad_swipe po");
576 DEBUG_X(PerlIO_printf(Perl_debug_log,
577 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
580 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
581 PTR2UV(PL_curpad), (IV)po));
582 #endif /* USE_THREADS */
583 SvPADTMP_off(PL_curpad[po]);
584 PL_curpad[po] = NEWSV(1107,0);
585 SvPADTMP_on(PL_curpad[po]);
586 if ((I32)po < PL_padix)
590 /* XXX pad_reset() is currently disabled because it results in serious bugs.
591 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
592 * on the stack by OPs that use them, there are several ways to get an alias
593 * to a shared TARG. Such an alias will change randomly and unpredictably.
594 * We avoid doing this until we can think of a Better Way.
599 #ifdef USE_BROKEN_PAD_RESET
602 if (AvARRAY(PL_comppad) != PL_curpad)
603 Perl_croak(aTHX_ "panic: pad_reset curpad");
605 DEBUG_X(PerlIO_printf(Perl_debug_log,
606 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
607 PTR2UV(thr), PTR2UV(PL_curpad)));
609 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
611 #endif /* USE_THREADS */
612 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
613 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
614 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
615 SvPADTMP_off(PL_curpad[po]);
617 PL_padix = PL_padix_floor;
620 PL_pad_reset_pending = FALSE;
624 /* find_threadsv is not reentrant */
626 Perl_find_threadsv(pTHX_ const char *name)
631 /* We currently only handle names of a single character */
632 p = strchr(PL_threadsv_names, *name);
635 key = p - PL_threadsv_names;
636 MUTEX_LOCK(&thr->mutex);
637 svp = av_fetch(thr->threadsv, key, FALSE);
639 MUTEX_UNLOCK(&thr->mutex);
641 SV *sv = NEWSV(0, 0);
642 av_store(thr->threadsv, key, sv);
643 thr->threadsvp = AvARRAY(thr->threadsv);
644 MUTEX_UNLOCK(&thr->mutex);
646 * Some magic variables used to be automagically initialised
647 * in gv_fetchpv. Those which are now per-thread magicals get
648 * initialised here instead.
654 sv_setpv(sv, "\034");
655 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
660 PL_sawampersand = TRUE;
674 /* XXX %! tied to Errno.pm needs to be added here.
675 * See gv_fetchpv(). */
679 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
681 DEBUG_S(PerlIO_printf(Perl_error_log,
682 "find_threadsv: new SV %p for $%s%c\n",
683 sv, (*name < 32) ? "^" : "",
684 (*name < 32) ? toCTRL(*name) : *name));
688 #endif /* USE_THREADS */
693 Perl_op_free(pTHX_ OP *o)
695 register OP *kid, *nextkid;
698 if (!o || o->op_seq == (U16)-1)
701 if (o->op_private & OPpREFCOUNTED) {
702 switch (o->op_type) {
710 if (OpREFCNT_dec(o)) {
721 if (o->op_flags & OPf_KIDS) {
722 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
723 nextkid = kid->op_sibling; /* Get before next freeing kid */
731 /* COP* is not cleared by op_clear() so that we may track line
732 * numbers etc even after null() */
733 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
738 #ifdef PL_OP_SLAB_ALLOC
739 if ((char *) o == PL_OpPtr)
748 Perl_op_clear(pTHX_ OP *o)
750 switch (o->op_type) {
751 case OP_NULL: /* Was holding old type, if any. */
752 case OP_ENTEREVAL: /* Was holding hints. */
754 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
760 if (!(o->op_flags & OPf_SPECIAL))
763 #endif /* USE_THREADS */
765 if (!(o->op_flags & OPf_REF)
766 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
773 if (cPADOPo->op_padix > 0) {
776 pad_swipe(cPADOPo->op_padix);
777 /* No GvIN_PAD_off(gv) here, because other references may still
778 * exist on the pad */
781 cPADOPo->op_padix = 0;
784 SvREFCNT_dec(cSVOPo->op_sv);
785 cSVOPo->op_sv = Nullsv;
788 case OP_METHOD_NAMED:
790 SvREFCNT_dec(cSVOPo->op_sv);
791 cSVOPo->op_sv = Nullsv;
797 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
801 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
802 SvREFCNT_dec(cSVOPo->op_sv);
803 cSVOPo->op_sv = Nullsv;
806 Safefree(cPVOPo->op_pv);
807 cPVOPo->op_pv = Nullch;
811 op_free(cPMOPo->op_pmreplroot);
815 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
817 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
818 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
819 /* No GvIN_PAD_off(gv) here, because other references may still
820 * exist on the pad */
825 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
832 HV *pmstash = PmopSTASH(cPMOPo);
833 if (pmstash && SvREFCNT(pmstash)) {
834 PMOP *pmop = HvPMROOT(pmstash);
835 PMOP *lastpmop = NULL;
837 if (cPMOPo == pmop) {
839 lastpmop->op_pmnext = pmop->op_pmnext;
841 HvPMROOT(pmstash) = pmop->op_pmnext;
845 pmop = pmop->op_pmnext;
849 Safefree(PmopSTASHPV(cPMOPo));
851 /* NOTE: PMOP.op_pmstash is not refcounted */
854 cPMOPo->op_pmreplroot = Nullop;
855 ReREFCNT_dec(PM_GETRE(cPMOPo));
856 PM_SETRE(cPMOPo, (REGEXP*)NULL);
860 if (o->op_targ > 0) {
861 pad_free(o->op_targ);
867 S_cop_free(pTHX_ COP* cop)
869 Safefree(cop->cop_label);
871 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
872 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
874 /* NOTE: COP.cop_stash is not refcounted */
875 SvREFCNT_dec(CopFILEGV(cop));
877 if (! specialWARN(cop->cop_warnings))
878 SvREFCNT_dec(cop->cop_warnings);
879 if (! specialCopIO(cop->cop_io))
880 SvREFCNT_dec(cop->cop_io);
884 Perl_op_null(pTHX_ OP *o)
886 if (o->op_type == OP_NULL)
889 o->op_targ = o->op_type;
890 o->op_type = OP_NULL;
891 o->op_ppaddr = PL_ppaddr[OP_NULL];
894 /* Contextualizers */
896 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
899 Perl_linklist(pTHX_ OP *o)
906 /* establish postfix order */
907 if (cUNOPo->op_first) {
908 o->op_next = LINKLIST(cUNOPo->op_first);
909 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
911 kid->op_next = LINKLIST(kid->op_sibling);
923 Perl_scalarkids(pTHX_ OP *o)
926 if (o && o->op_flags & OPf_KIDS) {
927 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
934 S_scalarboolean(pTHX_ OP *o)
936 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
937 if (ckWARN(WARN_SYNTAX)) {
938 line_t oldline = CopLINE(PL_curcop);
940 if (PL_copline != NOLINE)
941 CopLINE_set(PL_curcop, PL_copline);
942 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
943 CopLINE_set(PL_curcop, oldline);
950 Perl_scalar(pTHX_ OP *o)
954 /* assumes no premature commitment */
955 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
956 || o->op_type == OP_RETURN)
961 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
963 switch (o->op_type) {
965 scalar(cBINOPo->op_first);
970 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
974 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
975 if (!kPMOP->op_pmreplroot)
976 deprecate("implicit split to @_");
984 if (o->op_flags & OPf_KIDS) {
985 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
991 kid = cLISTOPo->op_first;
993 while ((kid = kid->op_sibling)) {
999 WITH_THR(PL_curcop = &PL_compiling);
1004 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1005 if (kid->op_sibling)
1010 WITH_THR(PL_curcop = &PL_compiling);
1017 Perl_scalarvoid(pTHX_ OP *o)
1024 if (o->op_type == OP_NEXTSTATE
1025 || o->op_type == OP_SETSTATE
1026 || o->op_type == OP_DBSTATE
1027 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1028 || o->op_targ == OP_SETSTATE
1029 || o->op_targ == OP_DBSTATE)))
1030 PL_curcop = (COP*)o; /* for warning below */
1032 /* assumes no premature commitment */
1033 want = o->op_flags & OPf_WANT;
1034 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1035 || o->op_type == OP_RETURN)
1040 if ((o->op_private & OPpTARGET_MY)
1041 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1043 return scalar(o); /* As if inside SASSIGN */
1046 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1048 switch (o->op_type) {
1050 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1054 if (o->op_flags & OPf_STACKED)
1058 if (o->op_private == 4)
1100 case OP_GETSOCKNAME:
1101 case OP_GETPEERNAME:
1106 case OP_GETPRIORITY:
1129 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1130 useless = PL_op_desc[o->op_type];
1137 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1138 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1139 useless = "a variable";
1144 if (cSVOPo->op_private & OPpCONST_STRICT)
1145 no_bareword_allowed(o);
1147 if (ckWARN(WARN_VOID)) {
1148 useless = "a constant";
1149 /* the constants 0 and 1 are permitted as they are
1150 conventionally used as dummies in constructs like
1151 1 while some_condition_with_side_effects; */
1152 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1154 else if (SvPOK(sv)) {
1155 /* perl4's way of mixing documentation and code
1156 (before the invention of POD) was based on a
1157 trick to mix nroff and perl code. The trick was
1158 built upon these three nroff macros being used in
1159 void context. The pink camel has the details in
1160 the script wrapman near page 319. */
1161 if (strnEQ(SvPVX(sv), "di", 2) ||
1162 strnEQ(SvPVX(sv), "ds", 2) ||
1163 strnEQ(SvPVX(sv), "ig", 2))
1168 op_null(o); /* don't execute or even remember it */
1172 o->op_type = OP_PREINC; /* pre-increment is faster */
1173 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1177 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1178 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1184 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1189 if (o->op_flags & OPf_STACKED)
1196 if (!(o->op_flags & OPf_KIDS))
1205 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1212 /* all requires must return a boolean value */
1213 o->op_flags &= ~OPf_WANT;
1218 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1219 if (!kPMOP->op_pmreplroot)
1220 deprecate("implicit split to @_");
1224 if (useless && ckWARN(WARN_VOID))
1225 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1230 Perl_listkids(pTHX_ OP *o)
1233 if (o && o->op_flags & OPf_KIDS) {
1234 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1241 Perl_list(pTHX_ OP *o)
1245 /* assumes no premature commitment */
1246 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1247 || o->op_type == OP_RETURN)
1252 if ((o->op_private & OPpTARGET_MY)
1253 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1255 return o; /* As if inside SASSIGN */
1258 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1260 switch (o->op_type) {
1263 list(cBINOPo->op_first);
1268 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1276 if (!(o->op_flags & OPf_KIDS))
1278 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1279 list(cBINOPo->op_first);
1280 return gen_constant_list(o);
1287 kid = cLISTOPo->op_first;
1289 while ((kid = kid->op_sibling)) {
1290 if (kid->op_sibling)
1295 WITH_THR(PL_curcop = &PL_compiling);
1299 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1300 if (kid->op_sibling)
1305 WITH_THR(PL_curcop = &PL_compiling);
1308 /* all requires must return a boolean value */
1309 o->op_flags &= ~OPf_WANT;
1316 Perl_scalarseq(pTHX_ OP *o)
1321 if (o->op_type == OP_LINESEQ ||
1322 o->op_type == OP_SCOPE ||
1323 o->op_type == OP_LEAVE ||
1324 o->op_type == OP_LEAVETRY)
1326 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1327 if (kid->op_sibling) {
1331 PL_curcop = &PL_compiling;
1333 o->op_flags &= ~OPf_PARENS;
1334 if (PL_hints & HINT_BLOCK_SCOPE)
1335 o->op_flags |= OPf_PARENS;
1338 o = newOP(OP_STUB, 0);
1343 S_modkids(pTHX_ OP *o, I32 type)
1346 if (o && o->op_flags & OPf_KIDS) {
1347 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1354 Perl_mod(pTHX_ OP *o, I32 type)
1359 if (!o || PL_error_count)
1362 if ((o->op_private & OPpTARGET_MY)
1363 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1368 switch (o->op_type) {
1373 if (!(o->op_private & (OPpCONST_ARYBASE)))
1375 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1376 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1380 SAVEI32(PL_compiling.cop_arybase);
1381 PL_compiling.cop_arybase = 0;
1383 else if (type == OP_REFGEN)
1386 Perl_croak(aTHX_ "That use of $[ is unsupported");
1389 if (o->op_flags & OPf_PARENS)
1393 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1394 !(o->op_flags & OPf_STACKED)) {
1395 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1396 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1397 assert(cUNOPo->op_first->op_type == OP_NULL);
1398 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1401 else { /* lvalue subroutine call */
1402 o->op_private |= OPpLVAL_INTRO;
1403 PL_modcount = RETURN_UNLIMITED_NUMBER;
1404 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1405 /* Backward compatibility mode: */
1406 o->op_private |= OPpENTERSUB_INARGS;
1409 else { /* Compile-time error message: */
1410 OP *kid = cUNOPo->op_first;
1414 if (kid->op_type == OP_PUSHMARK)
1416 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1418 "panic: unexpected lvalue entersub "
1419 "args: type/targ %ld:%ld",
1420 (long)kid->op_type,kid->op_targ);
1421 kid = kLISTOP->op_first;
1423 while (kid->op_sibling)
1424 kid = kid->op_sibling;
1425 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1427 if (kid->op_type == OP_METHOD_NAMED
1428 || kid->op_type == OP_METHOD)
1432 if (kid->op_sibling || kid->op_next != kid) {
1433 yyerror("panic: unexpected optree near method call");
1437 NewOp(1101, newop, 1, UNOP);
1438 newop->op_type = OP_RV2CV;
1439 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1440 newop->op_first = Nullop;
1441 newop->op_next = (OP*)newop;
1442 kid->op_sibling = (OP*)newop;
1443 newop->op_private |= OPpLVAL_INTRO;
1447 if (kid->op_type != OP_RV2CV)
1449 "panic: unexpected lvalue entersub "
1450 "entry via type/targ %ld:%ld",
1451 (long)kid->op_type,kid->op_targ);
1452 kid->op_private |= OPpLVAL_INTRO;
1453 break; /* Postpone until runtime */
1457 kid = kUNOP->op_first;
1458 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1459 kid = kUNOP->op_first;
1460 if (kid->op_type == OP_NULL)
1462 "Unexpected constant lvalue entersub "
1463 "entry via type/targ %ld:%ld",
1464 (long)kid->op_type,kid->op_targ);
1465 if (kid->op_type != OP_GV) {
1466 /* Restore RV2CV to check lvalueness */
1468 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1469 okid->op_next = kid->op_next;
1470 kid->op_next = okid;
1473 okid->op_next = Nullop;
1474 okid->op_type = OP_RV2CV;
1476 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1477 okid->op_private |= OPpLVAL_INTRO;
1481 cv = GvCV(kGVOP_gv);
1491 /* grep, foreach, subcalls, refgen */
1492 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1494 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1495 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1497 : (o->op_type == OP_ENTERSUB
1498 ? "non-lvalue subroutine call"
1499 : PL_op_desc[o->op_type])),
1500 type ? PL_op_desc[type] : "local"));
1514 case OP_RIGHT_SHIFT:
1523 if (!(o->op_flags & OPf_STACKED))
1529 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1535 if (!type && cUNOPo->op_first->op_type != OP_GV)
1536 Perl_croak(aTHX_ "Can't localize through a reference");
1537 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1538 PL_modcount = RETURN_UNLIMITED_NUMBER;
1539 return o; /* Treat \(@foo) like ordinary list. */
1543 if (scalar_mod_type(o, type))
1545 ref(cUNOPo->op_first, o->op_type);
1549 if (type == OP_LEAVESUBLV)
1550 o->op_private |= OPpMAYBE_LVSUB;
1556 PL_modcount = RETURN_UNLIMITED_NUMBER;
1559 if (!type && cUNOPo->op_first->op_type != OP_GV)
1560 Perl_croak(aTHX_ "Can't localize through a reference");
1561 ref(cUNOPo->op_first, o->op_type);
1565 PL_hints |= HINT_BLOCK_SCOPE;
1575 PL_modcount = RETURN_UNLIMITED_NUMBER;
1576 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1577 return o; /* Treat \(@foo) like ordinary list. */
1578 if (scalar_mod_type(o, type))
1580 if (type == OP_LEAVESUBLV)
1581 o->op_private |= OPpMAYBE_LVSUB;
1586 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1587 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1592 PL_modcount++; /* XXX ??? */
1594 #endif /* USE_THREADS */
1600 if (type != OP_SASSIGN)
1604 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1609 if (type == OP_LEAVESUBLV)
1610 o->op_private |= OPpMAYBE_LVSUB;
1612 pad_free(o->op_targ);
1613 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1614 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1615 if (o->op_flags & OPf_KIDS)
1616 mod(cBINOPo->op_first->op_sibling, type);
1621 ref(cBINOPo->op_first, o->op_type);
1622 if (type == OP_ENTERSUB &&
1623 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1624 o->op_private |= OPpLVAL_DEFER;
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1634 if (o->op_flags & OPf_KIDS)
1635 mod(cLISTOPo->op_last, type);
1639 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1641 else if (!(o->op_flags & OPf_KIDS))
1643 if (o->op_targ != OP_LIST) {
1644 mod(cBINOPo->op_first, type);
1649 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1654 if (type != OP_LEAVESUBLV)
1656 break; /* mod()ing was handled by ck_return() */
1658 if (type != OP_LEAVESUBLV)
1659 o->op_flags |= OPf_MOD;
1661 if (type == OP_AASSIGN || type == OP_SASSIGN)
1662 o->op_flags |= OPf_SPECIAL|OPf_REF;
1664 o->op_private |= OPpLVAL_INTRO;
1665 o->op_flags &= ~OPf_SPECIAL;
1666 PL_hints |= HINT_BLOCK_SCOPE;
1668 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1669 && type != OP_LEAVESUBLV)
1670 o->op_flags |= OPf_REF;
1675 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1679 if (o->op_type == OP_RV2GV)
1703 case OP_RIGHT_SHIFT:
1722 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1724 switch (o->op_type) {
1732 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1745 Perl_refkids(pTHX_ OP *o, I32 type)
1748 if (o && o->op_flags & OPf_KIDS) {
1749 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1756 Perl_ref(pTHX_ OP *o, I32 type)
1760 if (!o || PL_error_count)
1763 switch (o->op_type) {
1765 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1766 !(o->op_flags & OPf_STACKED)) {
1767 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1768 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1769 assert(cUNOPo->op_first->op_type == OP_NULL);
1770 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1771 o->op_flags |= OPf_SPECIAL;
1776 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1780 if (type == OP_DEFINED)
1781 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1782 ref(cUNOPo->op_first, o->op_type);
1785 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1786 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1787 : type == OP_RV2HV ? OPpDEREF_HV
1789 o->op_flags |= OPf_MOD;
1794 o->op_flags |= OPf_MOD; /* XXX ??? */
1799 o->op_flags |= OPf_REF;
1802 if (type == OP_DEFINED)
1803 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1804 ref(cUNOPo->op_first, o->op_type);
1809 o->op_flags |= OPf_REF;
1814 if (!(o->op_flags & OPf_KIDS))
1816 ref(cBINOPo->op_first, type);
1820 ref(cBINOPo->op_first, o->op_type);
1821 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1822 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1823 : type == OP_RV2HV ? OPpDEREF_HV
1825 o->op_flags |= OPf_MOD;
1833 if (!(o->op_flags & OPf_KIDS))
1835 ref(cLISTOPo->op_last, type);
1845 S_dup_attrlist(pTHX_ OP *o)
1849 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1850 * where the first kid is OP_PUSHMARK and the remaining ones
1851 * are OP_CONST. We need to push the OP_CONST values.
1853 if (o->op_type == OP_CONST)
1854 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1856 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1857 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1858 if (o->op_type == OP_CONST)
1859 rop = append_elem(OP_LIST, rop,
1860 newSVOP(OP_CONST, o->op_flags,
1861 SvREFCNT_inc(cSVOPo->op_sv)));
1868 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1872 /* fake up C<use attributes $pkg,$rv,@attrs> */
1873 ENTER; /* need to protect against side-effects of 'use' */
1876 stashsv = newSVpv(HvNAME(stash), 0);
1878 stashsv = &PL_sv_no;
1880 #define ATTRSMODULE "attributes"
1882 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1883 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1885 prepend_elem(OP_LIST,
1886 newSVOP(OP_CONST, 0, stashsv),
1887 prepend_elem(OP_LIST,
1888 newSVOP(OP_CONST, 0,
1890 dup_attrlist(attrs))));
1895 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1896 char *attrstr, STRLEN len)
1901 len = strlen(attrstr);
1905 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1907 char *sstr = attrstr;
1908 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1909 attrs = append_elem(OP_LIST, attrs,
1910 newSVOP(OP_CONST, 0,
1911 newSVpvn(sstr, attrstr-sstr)));
1915 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1916 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1917 Nullsv, prepend_elem(OP_LIST,
1918 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1919 prepend_elem(OP_LIST,
1920 newSVOP(OP_CONST, 0,
1926 S_my_kid(pTHX_ OP *o, OP *attrs)
1931 if (!o || PL_error_count)
1935 if (type == OP_LIST) {
1936 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1938 } else if (type == OP_UNDEF) {
1940 } else if (type == OP_RV2SV || /* "our" declaration */
1942 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1944 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1946 PL_in_my_stash = Nullhv;
1947 apply_attrs(GvSTASH(gv),
1948 (type == OP_RV2SV ? GvSV(gv) :
1949 type == OP_RV2AV ? (SV*)GvAV(gv) :
1950 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1953 o->op_private |= OPpOUR_INTRO;
1955 } else if (type != OP_PADSV &&
1958 type != OP_PUSHMARK)
1960 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1961 PL_op_desc[o->op_type],
1962 PL_in_my == KEY_our ? "our" : "my"));
1965 else if (attrs && type != OP_PUSHMARK) {
1971 PL_in_my_stash = Nullhv;
1973 /* check for C<my Dog $spot> when deciding package */
1974 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1975 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1976 stash = SvSTASH(*namesvp);
1978 stash = PL_curstash;
1979 padsv = PAD_SV(o->op_targ);
1980 apply_attrs(stash, padsv, attrs);
1982 o->op_flags |= OPf_MOD;
1983 o->op_private |= OPpLVAL_INTRO;
1988 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1990 if (o->op_flags & OPf_PARENS)
1994 o = my_kid(o, attrs);
1996 PL_in_my_stash = Nullhv;
2001 Perl_my(pTHX_ OP *o)
2003 return my_kid(o, Nullop);
2007 Perl_sawparens(pTHX_ OP *o)
2010 o->op_flags |= OPf_PARENS;
2015 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2019 if (ckWARN(WARN_MISC) &&
2020 (left->op_type == OP_RV2AV ||
2021 left->op_type == OP_RV2HV ||
2022 left->op_type == OP_PADAV ||
2023 left->op_type == OP_PADHV)) {
2024 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2025 right->op_type == OP_TRANS)
2026 ? right->op_type : OP_MATCH];
2027 const char *sample = ((left->op_type == OP_RV2AV ||
2028 left->op_type == OP_PADAV)
2029 ? "@array" : "%hash");
2030 Perl_warner(aTHX_ WARN_MISC,
2031 "Applying %s to %s will act on scalar(%s)",
2032 desc, sample, sample);
2035 if (!(right->op_flags & OPf_STACKED) &&
2036 (right->op_type == OP_MATCH ||
2037 right->op_type == OP_SUBST ||
2038 right->op_type == OP_TRANS)) {
2039 right->op_flags |= OPf_STACKED;
2040 if ((right->op_type != OP_MATCH &&
2041 ! (right->op_type == OP_TRANS &&
2042 right->op_private & OPpTRANS_IDENTICAL)) ||
2043 /* if SV has magic, then match on original SV, not on its copy.
2044 see note in pp_helem() */
2045 (right->op_type == OP_MATCH &&
2046 (left->op_type == OP_AELEM ||
2047 left->op_type == OP_HELEM ||
2048 left->op_type == OP_AELEMFAST)))
2049 left = mod(left, right->op_type);
2050 if (right->op_type == OP_TRANS)
2051 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2053 o = prepend_elem(right->op_type, scalar(left), right);
2055 return newUNOP(OP_NOT, 0, scalar(o));
2059 return bind_match(type, left,
2060 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2064 Perl_invert(pTHX_ OP *o)
2068 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2069 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2073 Perl_scope(pTHX_ OP *o)
2076 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2077 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2078 o->op_type = OP_LEAVE;
2079 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2082 if (o->op_type == OP_LINESEQ) {
2084 o->op_type = OP_SCOPE;
2085 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2086 kid = ((LISTOP*)o)->op_first;
2087 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2091 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2098 Perl_save_hints(pTHX)
2101 SAVESPTR(GvHV(PL_hintgv));
2102 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2103 SAVEFREESV(GvHV(PL_hintgv));
2107 Perl_block_start(pTHX_ int full)
2109 int retval = PL_savestack_ix;
2111 SAVEI32(PL_comppad_name_floor);
2112 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2114 PL_comppad_name_fill = PL_comppad_name_floor;
2115 if (PL_comppad_name_floor < 0)
2116 PL_comppad_name_floor = 0;
2117 SAVEI32(PL_min_intro_pending);
2118 SAVEI32(PL_max_intro_pending);
2119 PL_min_intro_pending = 0;
2120 SAVEI32(PL_comppad_name_fill);
2121 SAVEI32(PL_padix_floor);
2122 PL_padix_floor = PL_padix;
2123 PL_pad_reset_pending = FALSE;
2125 PL_hints &= ~HINT_BLOCK_SCOPE;
2126 SAVESPTR(PL_compiling.cop_warnings);
2127 if (! specialWARN(PL_compiling.cop_warnings)) {
2128 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2129 SAVEFREESV(PL_compiling.cop_warnings) ;
2131 SAVESPTR(PL_compiling.cop_io);
2132 if (! specialCopIO(PL_compiling.cop_io)) {
2133 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2134 SAVEFREESV(PL_compiling.cop_io) ;
2140 Perl_block_end(pTHX_ I32 floor, OP *seq)
2142 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2143 OP* retval = scalarseq(seq);
2145 PL_pad_reset_pending = FALSE;
2146 PL_compiling.op_private = PL_hints;
2148 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2149 pad_leavemy(PL_comppad_name_fill);
2158 OP *o = newOP(OP_THREADSV, 0);
2159 o->op_targ = find_threadsv("_");
2162 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2163 #endif /* USE_THREADS */
2167 Perl_newPROG(pTHX_ OP *o)
2172 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2173 ((PL_in_eval & EVAL_KEEPERR)
2174 ? OPf_SPECIAL : 0), o);
2175 PL_eval_start = linklist(PL_eval_root);
2176 PL_eval_root->op_private |= OPpREFCOUNTED;
2177 OpREFCNT_set(PL_eval_root, 1);
2178 PL_eval_root->op_next = 0;
2179 CALL_PEEP(PL_eval_start);
2184 PL_main_root = scope(sawparens(scalarvoid(o)));
2185 PL_curcop = &PL_compiling;
2186 PL_main_start = LINKLIST(PL_main_root);
2187 PL_main_root->op_private |= OPpREFCOUNTED;
2188 OpREFCNT_set(PL_main_root, 1);
2189 PL_main_root->op_next = 0;
2190 CALL_PEEP(PL_main_start);
2193 /* Register with debugger */
2195 CV *cv = get_cv("DB::postponed", FALSE);
2199 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2201 call_sv((SV*)cv, G_DISCARD);
2208 Perl_localize(pTHX_ OP *o, I32 lex)
2210 if (o->op_flags & OPf_PARENS)
2213 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2215 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2216 if (*s == ';' || *s == '=')
2217 Perl_warner(aTHX_ WARN_PARENTHESIS,
2218 "Parentheses missing around \"%s\" list",
2219 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2225 o = mod(o, OP_NULL); /* a bit kludgey */
2227 PL_in_my_stash = Nullhv;
2232 Perl_jmaybe(pTHX_ OP *o)
2234 if (o->op_type == OP_LIST) {
2237 o2 = newOP(OP_THREADSV, 0);
2238 o2->op_targ = find_threadsv(";");
2240 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2241 #endif /* USE_THREADS */
2242 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2248 Perl_fold_constants(pTHX_ register OP *o)
2251 I32 type = o->op_type;
2254 if (PL_opargs[type] & OA_RETSCALAR)
2256 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2257 o->op_targ = pad_alloc(type, SVs_PADTMP);
2259 /* integerize op, unless it happens to be C<-foo>.
2260 * XXX should pp_i_negate() do magic string negation instead? */
2261 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2262 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2263 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2265 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2268 if (!(PL_opargs[type] & OA_FOLDCONST))
2273 /* XXX might want a ck_negate() for this */
2274 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2286 /* XXX what about the numeric ops? */
2287 if (PL_hints & HINT_LOCALE)
2292 goto nope; /* Don't try to run w/ errors */
2294 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2295 if ((curop->op_type != OP_CONST ||
2296 (curop->op_private & OPpCONST_BARE)) &&
2297 curop->op_type != OP_LIST &&
2298 curop->op_type != OP_SCALAR &&
2299 curop->op_type != OP_NULL &&
2300 curop->op_type != OP_PUSHMARK)
2306 curop = LINKLIST(o);
2310 sv = *(PL_stack_sp--);
2311 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2312 pad_swipe(o->op_targ);
2313 else if (SvTEMP(sv)) { /* grab mortal temp? */
2314 (void)SvREFCNT_inc(sv);
2318 if (type == OP_RV2GV)
2319 return newGVOP(OP_GV, 0, (GV*)sv);
2321 /* try to smush double to int, but don't smush -2.0 to -2 */
2322 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2325 #ifdef PERL_PRESERVE_IVUV
2326 /* Only bother to attempt to fold to IV if
2327 most operators will benefit */
2331 return newSVOP(OP_CONST, 0, sv);
2335 if (!(PL_opargs[type] & OA_OTHERINT))
2338 if (!(PL_hints & HINT_INTEGER)) {
2339 if (type == OP_MODULO
2340 || type == OP_DIVIDE
2341 || !(o->op_flags & OPf_KIDS))
2346 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2347 if (curop->op_type == OP_CONST) {
2348 if (SvIOK(((SVOP*)curop)->op_sv))
2352 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2356 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2363 Perl_gen_constant_list(pTHX_ register OP *o)
2366 I32 oldtmps_floor = PL_tmps_floor;
2370 return o; /* Don't attempt to run with errors */
2372 PL_op = curop = LINKLIST(o);
2379 PL_tmps_floor = oldtmps_floor;
2381 o->op_type = OP_RV2AV;
2382 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2383 curop = ((UNOP*)o)->op_first;
2384 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2391 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2393 if (!o || o->op_type != OP_LIST)
2394 o = newLISTOP(OP_LIST, 0, o, Nullop);
2396 o->op_flags &= ~OPf_WANT;
2398 if (!(PL_opargs[type] & OA_MARK))
2399 op_null(cLISTOPo->op_first);
2402 o->op_ppaddr = PL_ppaddr[type];
2403 o->op_flags |= flags;
2405 o = CHECKOP(type, o);
2406 if (o->op_type != type)
2409 return fold_constants(o);
2412 /* List constructors */
2415 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2423 if (first->op_type != type
2424 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2426 return newLISTOP(type, 0, first, last);
2429 if (first->op_flags & OPf_KIDS)
2430 ((LISTOP*)first)->op_last->op_sibling = last;
2432 first->op_flags |= OPf_KIDS;
2433 ((LISTOP*)first)->op_first = last;
2435 ((LISTOP*)first)->op_last = last;
2440 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2448 if (first->op_type != type)
2449 return prepend_elem(type, (OP*)first, (OP*)last);
2451 if (last->op_type != type)
2452 return append_elem(type, (OP*)first, (OP*)last);
2454 first->op_last->op_sibling = last->op_first;
2455 first->op_last = last->op_last;
2456 first->op_flags |= (last->op_flags & OPf_KIDS);
2458 #ifdef PL_OP_SLAB_ALLOC
2466 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2474 if (last->op_type == type) {
2475 if (type == OP_LIST) { /* already a PUSHMARK there */
2476 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2477 ((LISTOP*)last)->op_first->op_sibling = first;
2478 if (!(first->op_flags & OPf_PARENS))
2479 last->op_flags &= ~OPf_PARENS;
2482 if (!(last->op_flags & OPf_KIDS)) {
2483 ((LISTOP*)last)->op_last = first;
2484 last->op_flags |= OPf_KIDS;
2486 first->op_sibling = ((LISTOP*)last)->op_first;
2487 ((LISTOP*)last)->op_first = first;
2489 last->op_flags |= OPf_KIDS;
2493 return newLISTOP(type, 0, first, last);
2499 Perl_newNULLLIST(pTHX)
2501 return newOP(OP_STUB, 0);
2505 Perl_force_list(pTHX_ OP *o)
2507 if (!o || o->op_type != OP_LIST)
2508 o = newLISTOP(OP_LIST, 0, o, Nullop);
2514 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2518 NewOp(1101, listop, 1, LISTOP);
2520 listop->op_type = type;
2521 listop->op_ppaddr = PL_ppaddr[type];
2524 listop->op_flags = flags;
2528 else if (!first && last)
2531 first->op_sibling = last;
2532 listop->op_first = first;
2533 listop->op_last = last;
2534 if (type == OP_LIST) {
2536 pushop = newOP(OP_PUSHMARK, 0);
2537 pushop->op_sibling = first;
2538 listop->op_first = pushop;
2539 listop->op_flags |= OPf_KIDS;
2541 listop->op_last = pushop;
2548 Perl_newOP(pTHX_ I32 type, I32 flags)
2551 NewOp(1101, o, 1, OP);
2553 o->op_ppaddr = PL_ppaddr[type];
2554 o->op_flags = flags;
2557 o->op_private = 0 + (flags >> 8);
2558 if (PL_opargs[type] & OA_RETSCALAR)
2560 if (PL_opargs[type] & OA_TARGET)
2561 o->op_targ = pad_alloc(type, SVs_PADTMP);
2562 return CHECKOP(type, o);
2566 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2571 first = newOP(OP_STUB, 0);
2572 if (PL_opargs[type] & OA_MARK)
2573 first = force_list(first);
2575 NewOp(1101, unop, 1, UNOP);
2576 unop->op_type = type;
2577 unop->op_ppaddr = PL_ppaddr[type];
2578 unop->op_first = first;
2579 unop->op_flags = flags | OPf_KIDS;
2580 unop->op_private = 1 | (flags >> 8);
2581 unop = (UNOP*) CHECKOP(type, unop);
2585 return fold_constants((OP *) unop);
2589 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2592 NewOp(1101, binop, 1, BINOP);
2595 first = newOP(OP_NULL, 0);
2597 binop->op_type = type;
2598 binop->op_ppaddr = PL_ppaddr[type];
2599 binop->op_first = first;
2600 binop->op_flags = flags | OPf_KIDS;
2603 binop->op_private = 1 | (flags >> 8);
2606 binop->op_private = 2 | (flags >> 8);
2607 first->op_sibling = last;
2610 binop = (BINOP*)CHECKOP(type, binop);
2611 if (binop->op_next || binop->op_type != type)
2614 binop->op_last = binop->op_first->op_sibling;
2616 return fold_constants((OP *)binop);
2620 uvcompare(const void *a, const void *b)
2622 if (*((UV *)a) < (*(UV *)b))
2624 if (*((UV *)a) > (*(UV *)b))
2626 if (*((UV *)a+1) < (*(UV *)b+1))
2628 if (*((UV *)a+1) > (*(UV *)b+1))
2634 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2636 SV *tstr = ((SVOP*)expr)->op_sv;
2637 SV *rstr = ((SVOP*)repl)->op_sv;
2640 U8 *t = (U8*)SvPV(tstr, tlen);
2641 U8 *r = (U8*)SvPV(rstr, rlen);
2648 register short *tbl;
2650 PL_hints |= HINT_BLOCK_SCOPE;
2651 complement = o->op_private & OPpTRANS_COMPLEMENT;
2652 del = o->op_private & OPpTRANS_DELETE;
2653 squash = o->op_private & OPpTRANS_SQUASH;
2656 o->op_private |= OPpTRANS_FROM_UTF;
2659 o->op_private |= OPpTRANS_TO_UTF;
2661 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2662 SV* listsv = newSVpvn("# comment\n",10);
2664 U8* tend = t + tlen;
2665 U8* rend = r + rlen;
2679 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2680 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2686 tsave = t = bytes_to_utf8(t, &len);
2689 if (!to_utf && rlen) {
2691 rsave = r = bytes_to_utf8(r, &len);
2695 /* There are several snags with this code on EBCDIC:
2696 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2697 2. scan_const() in toke.c has encoded chars in native encoding which makes
2698 ranges at least in EBCDIC 0..255 range the bottom odd.
2702 U8 tmpbuf[UTF8_MAXLEN+1];
2705 New(1109, cp, 2*tlen, UV);
2707 transv = newSVpvn("",0);
2709 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2711 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2713 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2717 cp[2*i+1] = cp[2*i];
2721 qsort(cp, i, 2*sizeof(UV), uvcompare);
2722 for (j = 0; j < i; j++) {
2724 diff = val - nextmin;
2726 t = uvuni_to_utf8(tmpbuf,nextmin);
2727 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2729 U8 range_mark = UTF_TO_NATIVE(0xff);
2730 t = uvuni_to_utf8(tmpbuf, val - 1);
2731 sv_catpvn(transv, (char *)&range_mark, 1);
2732 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2739 t = uvuni_to_utf8(tmpbuf,nextmin);
2740 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2742 U8 range_mark = UTF_TO_NATIVE(0xff);
2743 sv_catpvn(transv, (char *)&range_mark, 1);
2745 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2746 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2747 t = (U8*)SvPVX(transv);
2748 tlen = SvCUR(transv);
2752 else if (!rlen && !del) {
2753 r = t; rlen = tlen; rend = tend;
2756 if ((!rlen && !del) || t == r ||
2757 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2759 o->op_private |= OPpTRANS_IDENTICAL;
2763 while (t < tend || tfirst <= tlast) {
2764 /* see if we need more "t" chars */
2765 if (tfirst > tlast) {
2766 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2768 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2770 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2777 /* now see if we need more "r" chars */
2778 if (rfirst > rlast) {
2780 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2782 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2784 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2793 rfirst = rlast = 0xffffffff;
2797 /* now see which range will peter our first, if either. */
2798 tdiff = tlast - tfirst;
2799 rdiff = rlast - rfirst;
2806 if (rfirst == 0xffffffff) {
2807 diff = tdiff; /* oops, pretend rdiff is infinite */
2809 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2810 (long)tfirst, (long)tlast);
2812 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2816 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2817 (long)tfirst, (long)(tfirst + diff),
2820 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2821 (long)tfirst, (long)rfirst);
2823 if (rfirst + diff > max)
2824 max = rfirst + diff;
2826 grows = (tfirst < rfirst &&
2827 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2839 else if (max > 0xff)
2844 Safefree(cPVOPo->op_pv);
2845 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2846 SvREFCNT_dec(listsv);
2848 SvREFCNT_dec(transv);
2850 if (!del && havefinal && rlen)
2851 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2852 newSVuv((UV)final), 0);
2855 o->op_private |= OPpTRANS_GROWS;
2867 tbl = (short*)cPVOPo->op_pv;
2869 Zero(tbl, 256, short);
2870 for (i = 0; i < tlen; i++)
2872 for (i = 0, j = 0; i < 256; i++) {
2883 if (i < 128 && r[j] >= 128)
2893 o->op_private |= OPpTRANS_IDENTICAL;
2898 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2899 tbl[0x100] = rlen - j;
2900 for (i=0; i < rlen - j; i++)
2901 tbl[0x101+i] = r[j+i];
2905 if (!rlen && !del) {
2908 o->op_private |= OPpTRANS_IDENTICAL;
2910 for (i = 0; i < 256; i++)
2912 for (i = 0, j = 0; i < tlen; i++,j++) {
2915 if (tbl[t[i]] == -1)
2921 if (tbl[t[i]] == -1) {
2922 if (t[i] < 128 && r[j] >= 128)
2929 o->op_private |= OPpTRANS_GROWS;
2937 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2941 NewOp(1101, pmop, 1, PMOP);
2942 pmop->op_type = type;
2943 pmop->op_ppaddr = PL_ppaddr[type];
2944 pmop->op_flags = flags;
2945 pmop->op_private = 0 | (flags >> 8);
2947 if (PL_hints & HINT_RE_TAINT)
2948 pmop->op_pmpermflags |= PMf_RETAINT;
2949 if (PL_hints & HINT_LOCALE)
2950 pmop->op_pmpermflags |= PMf_LOCALE;
2951 pmop->op_pmflags = pmop->op_pmpermflags;
2955 SV* repointer = newSViv(0);
2956 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2957 pmop->op_pmoffset = av_len(PL_regex_padav);
2958 PL_regex_pad = AvARRAY(PL_regex_padav);
2962 /* link into pm list */
2963 if (type != OP_TRANS && PL_curstash) {
2964 pmop->op_pmnext = HvPMROOT(PL_curstash);
2965 HvPMROOT(PL_curstash) = pmop;
2966 PmopSTASH_set(pmop,PL_curstash);
2973 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2977 I32 repl_has_vars = 0;
2979 if (o->op_type == OP_TRANS)
2980 return pmtrans(o, expr, repl);
2982 PL_hints |= HINT_BLOCK_SCOPE;
2985 if (expr->op_type == OP_CONST) {
2987 SV *pat = ((SVOP*)expr)->op_sv;
2988 char *p = SvPV(pat, plen);
2989 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2990 sv_setpvn(pat, "\\s+", 3);
2991 p = SvPV(pat, plen);
2992 pm->op_pmflags |= PMf_SKIPWHITE;
2994 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2995 pm->op_pmdynflags |= PMdf_UTF8;
2996 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2997 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2998 pm->op_pmflags |= PMf_WHITE;
3002 if (PL_hints & HINT_UTF8)
3003 pm->op_pmdynflags |= PMdf_UTF8;
3004 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3005 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3007 : OP_REGCMAYBE),0,expr);
3009 NewOp(1101, rcop, 1, LOGOP);
3010 rcop->op_type = OP_REGCOMP;
3011 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3012 rcop->op_first = scalar(expr);
3013 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3014 ? (OPf_SPECIAL | OPf_KIDS)
3016 rcop->op_private = 1;
3019 /* establish postfix order */
3020 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3022 rcop->op_next = expr;
3023 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3026 rcop->op_next = LINKLIST(expr);
3027 expr->op_next = (OP*)rcop;
3030 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3035 if (pm->op_pmflags & PMf_EVAL) {
3037 if (CopLINE(PL_curcop) < PL_multi_end)
3038 CopLINE_set(PL_curcop, PL_multi_end);
3041 else if (repl->op_type == OP_THREADSV
3042 && strchr("&`'123456789+",
3043 PL_threadsv_names[repl->op_targ]))
3047 #endif /* USE_THREADS */
3048 else if (repl->op_type == OP_CONST)
3052 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3053 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3055 if (curop->op_type == OP_THREADSV) {
3057 if (strchr("&`'123456789+", curop->op_private))
3061 if (curop->op_type == OP_GV) {
3062 GV *gv = cGVOPx_gv(curop);
3064 if (strchr("&`'123456789+", *GvENAME(gv)))
3067 #endif /* USE_THREADS */
3068 else if (curop->op_type == OP_RV2CV)
3070 else if (curop->op_type == OP_RV2SV ||
3071 curop->op_type == OP_RV2AV ||
3072 curop->op_type == OP_RV2HV ||
3073 curop->op_type == OP_RV2GV) {
3074 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3077 else if (curop->op_type == OP_PADSV ||
3078 curop->op_type == OP_PADAV ||
3079 curop->op_type == OP_PADHV ||
3080 curop->op_type == OP_PADANY) {
3083 else if (curop->op_type == OP_PUSHRE)
3084 ; /* Okay here, dangerous in newASSIGNOP */
3094 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3095 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3096 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3097 prepend_elem(o->op_type, scalar(repl), o);
3100 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3101 pm->op_pmflags |= PMf_MAYBE_CONST;
3102 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3104 NewOp(1101, rcop, 1, LOGOP);
3105 rcop->op_type = OP_SUBSTCONT;
3106 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3107 rcop->op_first = scalar(repl);
3108 rcop->op_flags |= OPf_KIDS;
3109 rcop->op_private = 1;
3112 /* establish postfix order */
3113 rcop->op_next = LINKLIST(repl);
3114 repl->op_next = (OP*)rcop;
3116 pm->op_pmreplroot = scalar((OP*)rcop);
3117 pm->op_pmreplstart = LINKLIST(rcop);
3126 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3129 NewOp(1101, svop, 1, SVOP);
3130 svop->op_type = type;
3131 svop->op_ppaddr = PL_ppaddr[type];
3133 svop->op_next = (OP*)svop;
3134 svop->op_flags = flags;
3135 if (PL_opargs[type] & OA_RETSCALAR)
3137 if (PL_opargs[type] & OA_TARGET)
3138 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3139 return CHECKOP(type, svop);
3143 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3146 NewOp(1101, padop, 1, PADOP);
3147 padop->op_type = type;
3148 padop->op_ppaddr = PL_ppaddr[type];
3149 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3150 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3151 PL_curpad[padop->op_padix] = sv;
3153 padop->op_next = (OP*)padop;
3154 padop->op_flags = flags;
3155 if (PL_opargs[type] & OA_RETSCALAR)
3157 if (PL_opargs[type] & OA_TARGET)
3158 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3159 return CHECKOP(type, padop);
3163 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3167 return newPADOP(type, flags, SvREFCNT_inc(gv));
3169 return newSVOP(type, flags, SvREFCNT_inc(gv));
3174 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3177 NewOp(1101, pvop, 1, PVOP);
3178 pvop->op_type = type;
3179 pvop->op_ppaddr = PL_ppaddr[type];
3181 pvop->op_next = (OP*)pvop;
3182 pvop->op_flags = flags;
3183 if (PL_opargs[type] & OA_RETSCALAR)
3185 if (PL_opargs[type] & OA_TARGET)
3186 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3187 return CHECKOP(type, pvop);
3191 Perl_package(pTHX_ OP *o)
3195 save_hptr(&PL_curstash);
3196 save_item(PL_curstname);
3201 name = SvPV(sv, len);
3202 PL_curstash = gv_stashpvn(name,len,TRUE);
3203 sv_setpvn(PL_curstname, name, len);
3207 deprecate("\"package\" with no arguments");
3208 sv_setpv(PL_curstname,"<none>");
3209 PL_curstash = Nullhv;
3211 PL_hints |= HINT_BLOCK_SCOPE;
3212 PL_copline = NOLINE;
3217 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3222 char *packname = Nullch;
3226 if (id->op_type != OP_CONST)
3227 Perl_croak(aTHX_ "Module name must be constant");
3231 if (version != Nullop) {
3232 SV *vesv = ((SVOP*)version)->op_sv;
3234 if (arg == Nullop && !SvNIOKp(vesv)) {
3241 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3242 Perl_croak(aTHX_ "Version number must be constant number");
3244 /* Make copy of id so we don't free it twice */
3245 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3247 /* Fake up a method call to VERSION */
3248 meth = newSVpvn("VERSION",7);
3249 sv_upgrade(meth, SVt_PVIV);
3250 (void)SvIOK_on(meth);
3251 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3252 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3253 append_elem(OP_LIST,
3254 prepend_elem(OP_LIST, pack, list(version)),
3255 newSVOP(OP_METHOD_NAMED, 0, meth)));
3259 /* Fake up an import/unimport */
3260 if (arg && arg->op_type == OP_STUB)
3261 imop = arg; /* no import on explicit () */
3262 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3263 imop = Nullop; /* use 5.0; */
3268 /* Make copy of id so we don't free it twice */
3269 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3271 /* Fake up a method call to import/unimport */
3272 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3273 sv_upgrade(meth, SVt_PVIV);
3274 (void)SvIOK_on(meth);
3275 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3276 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3277 append_elem(OP_LIST,
3278 prepend_elem(OP_LIST, pack, list(arg)),
3279 newSVOP(OP_METHOD_NAMED, 0, meth)));
3282 if (ckWARN(WARN_MISC) &&
3283 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3284 SvPOK(packsv = ((SVOP*)id)->op_sv))
3286 /* BEGIN will free the ops, so we need to make a copy */
3287 packlen = SvCUR(packsv);
3288 packname = savepvn(SvPVX(packsv), packlen);
3291 /* Fake up the BEGIN {}, which does its thing immediately. */
3293 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3296 append_elem(OP_LINESEQ,
3297 append_elem(OP_LINESEQ,
3298 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3299 newSTATEOP(0, Nullch, veop)),
3300 newSTATEOP(0, Nullch, imop) ));
3303 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3304 Perl_warner(aTHX_ WARN_MISC,
3305 "Package `%s' not found "
3306 "(did you use the incorrect case?)", packname);
3311 PL_hints |= HINT_BLOCK_SCOPE;
3312 PL_copline = NOLINE;
3317 =for apidoc load_module
3319 Loads the module whose name is pointed to by the string part of name.
3320 Note that the actual module name, not its filename, should be given.
3321 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3322 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3323 (or 0 for no flags). ver, if specified, provides version semantics
3324 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3325 arguments can be used to specify arguments to the module's import()
3326 method, similar to C<use Foo::Bar VERSION LIST>.
3331 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3334 va_start(args, ver);
3335 vload_module(flags, name, ver, &args);
3339 #ifdef PERL_IMPLICIT_CONTEXT
3341 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3345 va_start(args, ver);
3346 vload_module(flags, name, ver, &args);
3352 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3354 OP *modname, *veop, *imop;
3356 modname = newSVOP(OP_CONST, 0, name);
3357 modname->op_private |= OPpCONST_BARE;
3359 veop = newSVOP(OP_CONST, 0, ver);
3363 if (flags & PERL_LOADMOD_NOIMPORT) {
3364 imop = sawparens(newNULLLIST());
3366 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3367 imop = va_arg(*args, OP*);
3372 sv = va_arg(*args, SV*);
3374 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3375 sv = va_arg(*args, SV*);
3379 line_t ocopline = PL_copline;
3380 int oexpect = PL_expect;
3382 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3383 veop, modname, imop);
3384 PL_expect = oexpect;
3385 PL_copline = ocopline;
3390 Perl_dofile(pTHX_ OP *term)
3395 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3396 if (!(gv && GvIMPORTED_CV(gv)))
3397 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3399 if (gv && GvIMPORTED_CV(gv)) {
3400 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3401 append_elem(OP_LIST, term,
3402 scalar(newUNOP(OP_RV2CV, 0,
3407 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3413 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3415 return newBINOP(OP_LSLICE, flags,
3416 list(force_list(subscript)),
3417 list(force_list(listval)) );
3421 S_list_assignment(pTHX_ register OP *o)
3426 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3427 o = cUNOPo->op_first;
3429 if (o->op_type == OP_COND_EXPR) {
3430 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3431 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3436 yyerror("Assignment to both a list and a scalar");
3440 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3441 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3442 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3445 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3448 if (o->op_type == OP_RV2SV)
3455 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3460 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3461 return newLOGOP(optype, 0,
3462 mod(scalar(left), optype),
3463 newUNOP(OP_SASSIGN, 0, scalar(right)));
3466 return newBINOP(optype, OPf_STACKED,
3467 mod(scalar(left), optype), scalar(right));
3471 if (list_assignment(left)) {
3475 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3476 left = mod(left, OP_AASSIGN);
3484 curop = list(force_list(left));
3485 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3486 o->op_private = 0 | (flags >> 8);
3487 for (curop = ((LISTOP*)curop)->op_first;
3488 curop; curop = curop->op_sibling)
3490 if (curop->op_type == OP_RV2HV &&
3491 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3492 o->op_private |= OPpASSIGN_HASH;
3496 if (!(left->op_private & OPpLVAL_INTRO)) {
3499 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3500 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3501 if (curop->op_type == OP_GV) {
3502 GV *gv = cGVOPx_gv(curop);
3503 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3505 SvCUR(gv) = PL_generation;
3507 else if (curop->op_type == OP_PADSV ||
3508 curop->op_type == OP_PADAV ||
3509 curop->op_type == OP_PADHV ||
3510 curop->op_type == OP_PADANY) {
3511 SV **svp = AvARRAY(PL_comppad_name);
3512 SV *sv = svp[curop->op_targ];
3513 if (SvCUR(sv) == PL_generation)
3515 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3517 else if (curop->op_type == OP_RV2CV)
3519 else if (curop->op_type == OP_RV2SV ||
3520 curop->op_type == OP_RV2AV ||
3521 curop->op_type == OP_RV2HV ||
3522 curop->op_type == OP_RV2GV) {
3523 if (lastop->op_type != OP_GV) /* funny deref? */
3526 else if (curop->op_type == OP_PUSHRE) {
3527 if (((PMOP*)curop)->op_pmreplroot) {
3529 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3531 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3533 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3535 SvCUR(gv) = PL_generation;
3544 o->op_private |= OPpASSIGN_COMMON;
3546 if (right && right->op_type == OP_SPLIT) {
3548 if ((tmpop = ((LISTOP*)right)->op_first) &&
3549 tmpop->op_type == OP_PUSHRE)
3551 PMOP *pm = (PMOP*)tmpop;
3552 if (left->op_type == OP_RV2AV &&
3553 !(left->op_private & OPpLVAL_INTRO) &&
3554 !(o->op_private & OPpASSIGN_COMMON) )
3556 tmpop = ((UNOP*)left)->op_first;
3557 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3559 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3560 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3562 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3563 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3565 pm->op_pmflags |= PMf_ONCE;
3566 tmpop = cUNOPo->op_first; /* to list (nulled) */
3567 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3568 tmpop->op_sibling = Nullop; /* don't free split */
3569 right->op_next = tmpop->op_next; /* fix starting loc */
3570 op_free(o); /* blow off assign */
3571 right->op_flags &= ~OPf_WANT;
3572 /* "I don't know and I don't care." */
3577 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3578 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3580 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3582 sv_setiv(sv, PL_modcount+1);
3590 right = newOP(OP_UNDEF, 0);
3591 if (right->op_type == OP_READLINE) {
3592 right->op_flags |= OPf_STACKED;
3593 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3596 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3597 o = newBINOP(OP_SASSIGN, flags,
3598 scalar(right), mod(scalar(left), OP_SASSIGN) );
3610 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3612 U32 seq = intro_my();
3615 NewOp(1101, cop, 1, COP);
3616 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3617 cop->op_type = OP_DBSTATE;
3618 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3621 cop->op_type = OP_NEXTSTATE;
3622 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3624 cop->op_flags = flags;
3625 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3627 cop->op_private |= NATIVE_HINTS;
3629 PL_compiling.op_private = cop->op_private;
3630 cop->op_next = (OP*)cop;
3633 cop->cop_label = label;
3634 PL_hints |= HINT_BLOCK_SCOPE;
3637 cop->cop_arybase = PL_curcop->cop_arybase;
3638 if (specialWARN(PL_curcop->cop_warnings))
3639 cop->cop_warnings = PL_curcop->cop_warnings ;
3641 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3642 if (specialCopIO(PL_curcop->cop_io))
3643 cop->cop_io = PL_curcop->cop_io;
3645 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3648 if (PL_copline == NOLINE)
3649 CopLINE_set(cop, CopLINE(PL_curcop));
3651 CopLINE_set(cop, PL_copline);
3652 PL_copline = NOLINE;
3655 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3657 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3659 CopSTASH_set(cop, PL_curstash);
3661 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3662 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3663 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3664 (void)SvIOK_on(*svp);
3665 SvIVX(*svp) = PTR2IV(cop);
3669 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3672 /* "Introduce" my variables to visible status. */
3680 if (! PL_min_intro_pending)
3681 return PL_cop_seqmax;
3683 svp = AvARRAY(PL_comppad_name);
3684 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3685 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3686 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3687 SvNVX(sv) = (NV)PL_cop_seqmax;
3690 PL_min_intro_pending = 0;
3691 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3692 return PL_cop_seqmax++;
3696 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3698 return new_logop(type, flags, &first, &other);
3702 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3706 OP *first = *firstp;
3707 OP *other = *otherp;
3709 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3710 return newBINOP(type, flags, scalar(first), scalar(other));
3712 scalarboolean(first);
3713 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3714 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3715 if (type == OP_AND || type == OP_OR) {
3721 first = *firstp = cUNOPo->op_first;
3723 first->op_next = o->op_next;
3724 cUNOPo->op_first = Nullop;
3728 if (first->op_type == OP_CONST) {
3729 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3730 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3731 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3742 else if (first->op_type == OP_WANTARRAY) {
3748 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3749 OP *k1 = ((UNOP*)first)->op_first;
3750 OP *k2 = k1->op_sibling;
3752 switch (first->op_type)
3755 if (k2 && k2->op_type == OP_READLINE
3756 && (k2->op_flags & OPf_STACKED)
3757 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3759 warnop = k2->op_type;
3764 if (k1->op_type == OP_READDIR
3765 || k1->op_type == OP_GLOB
3766 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3767 || k1->op_type == OP_EACH)
3769 warnop = ((k1->op_type == OP_NULL)
3770 ? k1->op_targ : k1->op_type);
3775 line_t oldline = CopLINE(PL_curcop);
3776 CopLINE_set(PL_curcop, PL_copline);
3777 Perl_warner(aTHX_ WARN_MISC,
3778 "Value of %s%s can be \"0\"; test with defined()",
3780 ((warnop == OP_READLINE || warnop == OP_GLOB)
3781 ? " construct" : "() operator"));
3782 CopLINE_set(PL_curcop, oldline);
3789 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3790 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3792 NewOp(1101, logop, 1, LOGOP);
3794 logop->op_type = type;
3795 logop->op_ppaddr = PL_ppaddr[type];
3796 logop->op_first = first;
3797 logop->op_flags = flags | OPf_KIDS;
3798 logop->op_other = LINKLIST(other);
3799 logop->op_private = 1 | (flags >> 8);
3801 /* establish postfix order */
3802 logop->op_next = LINKLIST(first);
3803 first->op_next = (OP*)logop;
3804 first->op_sibling = other;
3806 o = newUNOP(OP_NULL, 0, (OP*)logop);
3813 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3820 return newLOGOP(OP_AND, 0, first, trueop);
3822 return newLOGOP(OP_OR, 0, first, falseop);
3824 scalarboolean(first);
3825 if (first->op_type == OP_CONST) {
3826 if (SvTRUE(((SVOP*)first)->op_sv)) {
3837 else if (first->op_type == OP_WANTARRAY) {
3841 NewOp(1101, logop, 1, LOGOP);
3842 logop->op_type = OP_COND_EXPR;
3843 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3844 logop->op_first = first;
3845 logop->op_flags = flags | OPf_KIDS;
3846 logop->op_private = 1 | (flags >> 8);
3847 logop->op_other = LINKLIST(trueop);
3848 logop->op_next = LINKLIST(falseop);
3851 /* establish postfix order */
3852 start = LINKLIST(first);
3853 first->op_next = (OP*)logop;
3855 first->op_sibling = trueop;
3856 trueop->op_sibling = falseop;
3857 o = newUNOP(OP_NULL, 0, (OP*)logop);
3859 trueop->op_next = falseop->op_next = o;
3866 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3874 NewOp(1101, range, 1, LOGOP);
3876 range->op_type = OP_RANGE;
3877 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3878 range->op_first = left;
3879 range->op_flags = OPf_KIDS;
3880 leftstart = LINKLIST(left);
3881 range->op_other = LINKLIST(right);
3882 range->op_private = 1 | (flags >> 8);
3884 left->op_sibling = right;
3886 range->op_next = (OP*)range;
3887 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3888 flop = newUNOP(OP_FLOP, 0, flip);
3889 o = newUNOP(OP_NULL, 0, flop);
3891 range->op_next = leftstart;
3893 left->op_next = flip;
3894 right->op_next = flop;
3896 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3897 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3898 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3899 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3901 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3902 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3905 if (!flip->op_private || !flop->op_private)
3906 linklist(o); /* blow off optimizer unless constant */
3912 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3916 int once = block && block->op_flags & OPf_SPECIAL &&
3917 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3920 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3921 return block; /* do {} while 0 does once */
3922 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3923 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3924 expr = newUNOP(OP_DEFINED, 0,
3925 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3926 } else if (expr->op_flags & OPf_KIDS) {
3927 OP *k1 = ((UNOP*)expr)->op_first;
3928 OP *k2 = (k1) ? k1->op_sibling : NULL;
3929 switch (expr->op_type) {
3931 if (k2 && k2->op_type == OP_READLINE
3932 && (k2->op_flags & OPf_STACKED)
3933 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3934 expr = newUNOP(OP_DEFINED, 0, expr);
3938 if (k1->op_type == OP_READDIR
3939 || k1->op_type == OP_GLOB
3940 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3941 || k1->op_type == OP_EACH)
3942 expr = newUNOP(OP_DEFINED, 0, expr);
3948 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3949 o = new_logop(OP_AND, 0, &expr, &listop);
3952 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3954 if (once && o != listop)
3955 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3958 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3960 o->op_flags |= flags;
3962 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3967 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3975 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3976 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3977 expr = newUNOP(OP_DEFINED, 0,
3978 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3979 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3980 OP *k1 = ((UNOP*)expr)->op_first;
3981 OP *k2 = (k1) ? k1->op_sibling : NULL;
3982 switch (expr->op_type) {
3984 if (k2 && k2->op_type == OP_READLINE
3985 && (k2->op_flags & OPf_STACKED)
3986 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3987 expr = newUNOP(OP_DEFINED, 0, expr);
3991 if (k1->op_type == OP_READDIR
3992 || k1->op_type == OP_GLOB
3993 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3994 || k1->op_type == OP_EACH)
3995 expr = newUNOP(OP_DEFINED, 0, expr);
4001 block = newOP(OP_NULL, 0);
4003 block = scope(block);
4007 next = LINKLIST(cont);
4010 OP *unstack = newOP(OP_UNSTACK, 0);
4013 cont = append_elem(OP_LINESEQ, cont, unstack);
4014 if ((line_t)whileline != NOLINE) {
4015 PL_copline = whileline;
4016 cont = append_elem(OP_LINESEQ, cont,
4017 newSTATEOP(0, Nullch, Nullop));
4021 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4022 redo = LINKLIST(listop);
4025 PL_copline = whileline;
4027 o = new_logop(OP_AND, 0, &expr, &listop);
4028 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4029 op_free(expr); /* oops, it's a while (0) */
4031 return Nullop; /* listop already freed by new_logop */
4034 ((LISTOP*)listop)->op_last->op_next =
4035 (o == listop ? redo : LINKLIST(o));
4041 NewOp(1101,loop,1,LOOP);
4042 loop->op_type = OP_ENTERLOOP;
4043 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4044 loop->op_private = 0;
4045 loop->op_next = (OP*)loop;
4048 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4050 loop->op_redoop = redo;
4051 loop->op_lastop = o;
4052 o->op_private |= loopflags;
4055 loop->op_nextop = next;
4057 loop->op_nextop = o;
4059 o->op_flags |= flags;
4060 o->op_private |= (flags >> 8);
4065 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4073 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4074 sv->op_type = OP_RV2GV;
4075 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4077 else if (sv->op_type == OP_PADSV) { /* private variable */
4078 padoff = sv->op_targ;
4083 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4084 padoff = sv->op_targ;
4086 iterflags |= OPf_SPECIAL;
4091 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4095 padoff = find_threadsv("_");
4096 iterflags |= OPf_SPECIAL;
4098 sv = newGVOP(OP_GV, 0, PL_defgv);
4101 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4102 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4103 iterflags |= OPf_STACKED;
4105 else if (expr->op_type == OP_NULL &&
4106 (expr->op_flags & OPf_KIDS) &&
4107 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4109 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4110 * set the STACKED flag to indicate that these values are to be
4111 * treated as min/max values by 'pp_iterinit'.
4113 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4114 LOGOP* range = (LOGOP*) flip->op_first;
4115 OP* left = range->op_first;
4116 OP* right = left->op_sibling;
4119 range->op_flags &= ~OPf_KIDS;
4120 range->op_first = Nullop;
4122 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4123 listop->op_first->op_next = range->op_next;
4124 left->op_next = range->op_other;
4125 right->op_next = (OP*)listop;
4126 listop->op_next = listop->op_first;
4129 expr = (OP*)(listop);
4131 iterflags |= OPf_STACKED;
4134 expr = mod(force_list(expr), OP_GREPSTART);
4138 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4139 append_elem(OP_LIST, expr, scalar(sv))));
4140 assert(!loop->op_next);
4141 #ifdef PL_OP_SLAB_ALLOC
4144 NewOp(1234,tmp,1,LOOP);
4145 Copy(loop,tmp,1,LOOP);
4149 Renew(loop, 1, LOOP);
4151 loop->op_targ = padoff;
4152 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4153 PL_copline = forline;
4154 return newSTATEOP(0, label, wop);
4158 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4163 if (type != OP_GOTO || label->op_type == OP_CONST) {
4164 /* "last()" means "last" */
4165 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4166 o = newOP(type, OPf_SPECIAL);
4168 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4169 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4175 if (label->op_type == OP_ENTERSUB)
4176 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4177 o = newUNOP(type, OPf_STACKED, label);
4179 PL_hints |= HINT_BLOCK_SCOPE;
4184 Perl_cv_undef(pTHX_ CV *cv)
4188 MUTEX_DESTROY(CvMUTEXP(cv));
4189 Safefree(CvMUTEXP(cv));
4192 #endif /* USE_THREADS */
4195 if (CvFILE(cv) && !CvXSUB(cv)) {
4196 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4197 Safefree(CvFILE(cv));
4202 if (!CvXSUB(cv) && CvROOT(cv)) {
4204 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4205 Perl_croak(aTHX_ "Can't undef active subroutine");
4208 Perl_croak(aTHX_ "Can't undef active subroutine");
4209 #endif /* USE_THREADS */
4212 SAVEVPTR(PL_curpad);
4215 op_free(CvROOT(cv));
4216 CvROOT(cv) = Nullop;
4219 SvPOK_off((SV*)cv); /* forget prototype */
4221 /* Since closure prototypes have the same lifetime as the containing
4222 * CV, they don't hold a refcount on the outside CV. This avoids
4223 * the refcount loop between the outer CV (which keeps a refcount to
4224 * the closure prototype in the pad entry for pp_anoncode()) and the
4225 * closure prototype, and the ensuing memory leak. This does not
4226 * apply to closures generated within eval"", since eval"" CVs are
4227 * ephemeral. --GSAR */
4228 if (!CvANON(cv) || CvCLONED(cv)
4229 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4230 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4232 SvREFCNT_dec(CvOUTSIDE(cv));
4234 CvOUTSIDE(cv) = Nullcv;
4236 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4239 if (CvPADLIST(cv)) {
4240 /* may be during global destruction */
4241 if (SvREFCNT(CvPADLIST(cv))) {
4242 I32 i = AvFILLp(CvPADLIST(cv));
4244 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4245 SV* sv = svp ? *svp : Nullsv;
4248 if (sv == (SV*)PL_comppad_name)
4249 PL_comppad_name = Nullav;
4250 else if (sv == (SV*)PL_comppad) {
4251 PL_comppad = Nullav;
4252 PL_curpad = Null(SV**);
4256 SvREFCNT_dec((SV*)CvPADLIST(cv));
4258 CvPADLIST(cv) = Nullav;
4266 #ifdef DEBUG_CLOSURES
4268 S_cv_dump(pTHX_ CV *cv)
4271 CV *outside = CvOUTSIDE(cv);
4272 AV* padlist = CvPADLIST(cv);
4279 PerlIO_printf(Perl_debug_log,
4280 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4282 (CvANON(cv) ? "ANON"
4283 : (cv == PL_main_cv) ? "MAIN"
4284 : CvUNIQUE(cv) ? "UNIQUE"
4285 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4288 : CvANON(outside) ? "ANON"
4289 : (outside == PL_main_cv) ? "MAIN"
4290 : CvUNIQUE(outside) ? "UNIQUE"
4291 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4296 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4297 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4298 pname = AvARRAY(pad_name);
4299 ppad = AvARRAY(pad);
4301 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4302 if (SvPOK(pname[ix]))
4303 PerlIO_printf(Perl_debug_log,
4304 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4305 (int)ix, PTR2UV(ppad[ix]),
4306 SvFAKE(pname[ix]) ? "FAKE " : "",
4308 (IV)I_32(SvNVX(pname[ix])),
4311 #endif /* DEBUGGING */
4313 #endif /* DEBUG_CLOSURES */
4316 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4320 AV* protopadlist = CvPADLIST(proto);
4321 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4322 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4323 SV** pname = AvARRAY(protopad_name);
4324 SV** ppad = AvARRAY(protopad);
4325 I32 fname = AvFILLp(protopad_name);
4326 I32 fpad = AvFILLp(protopad);
4330 assert(!CvUNIQUE(proto));
4334 SAVESPTR(PL_comppad_name);
4335 SAVESPTR(PL_compcv);
4337 cv = PL_compcv = (CV*)NEWSV(1104,0);
4338 sv_upgrade((SV *)cv, SvTYPE(proto));
4339 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4343 New(666, CvMUTEXP(cv), 1, perl_mutex);
4344 MUTEX_INIT(CvMUTEXP(cv));
4346 #endif /* USE_THREADS */
4348 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4349 : savepv(CvFILE(proto));
4351 CvFILE(cv) = CvFILE(proto);
4353 CvGV(cv) = CvGV(proto);
4354 CvSTASH(cv) = CvSTASH(proto);
4355 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4356 CvSTART(cv) = CvSTART(proto);
4358 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4361 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4363 PL_comppad_name = newAV();
4364 for (ix = fname; ix >= 0; ix--)
4365 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4367 PL_comppad = newAV();
4369 comppadlist = newAV();
4370 AvREAL_off(comppadlist);
4371 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4372 av_store(comppadlist, 1, (SV*)PL_comppad);
4373 CvPADLIST(cv) = comppadlist;
4374 av_fill(PL_comppad, AvFILLp(protopad));
4375 PL_curpad = AvARRAY(PL_comppad);
4377 av = newAV(); /* will be @_ */
4379 av_store(PL_comppad, 0, (SV*)av);
4380 AvFLAGS(av) = AVf_REIFY;
4382 for (ix = fpad; ix > 0; ix--) {
4383 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4384 if (namesv && namesv != &PL_sv_undef) {
4385 char *name = SvPVX(namesv); /* XXX */
4386 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4387 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4388 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4390 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4392 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4394 else { /* our own lexical */
4397 /* anon code -- we'll come back for it */
4398 sv = SvREFCNT_inc(ppad[ix]);
4400 else if (*name == '@')
4402 else if (*name == '%')
4411 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4412 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4415 SV* sv = NEWSV(0,0);
4421 /* Now that vars are all in place, clone nested closures. */
4423 for (ix = fpad; ix > 0; ix--) {
4424 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4426 && namesv != &PL_sv_undef
4427 && !(SvFLAGS(namesv) & SVf_FAKE)
4428 && *SvPVX(namesv) == '&'
4429 && CvCLONE(ppad[ix]))
4431 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4432 SvREFCNT_dec(ppad[ix]);
4435 PL_curpad[ix] = (SV*)kid;
4439 #ifdef DEBUG_CLOSURES
4440 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4442 PerlIO_printf(Perl_debug_log, " from:\n");
4444 PerlIO_printf(Perl_debug_log, " to:\n");
4451 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4453 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4455 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4462 Perl_cv_clone(pTHX_ CV *proto)
4465 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4466 cv = cv_clone2(proto, CvOUTSIDE(proto));
4467 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4472 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4474 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4475 SV* msg = sv_newmortal();
4479 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4480 sv_setpv(msg, "Prototype mismatch:");
4482 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4484 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4485 sv_catpv(msg, " vs ");
4487 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4489 sv_catpv(msg, "none");
4490 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4494 static void const_sv_xsub(pTHXo_ CV* cv);
4497 =for apidoc cv_const_sv
4499 If C<cv> is a constant sub eligible for inlining. returns the constant
4500 value returned by the sub. Otherwise, returns NULL.
4502 Constant subs can be created with C<newCONSTSUB> or as described in
4503 L<perlsub/"Constant Functions">.
4508 Perl_cv_const_sv(pTHX_ CV *cv)
4510 if (!cv || !CvCONST(cv))
4512 return (SV*)CvXSUBANY(cv).any_ptr;
4516 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4523 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4524 o = cLISTOPo->op_first->op_sibling;
4526 for (; o; o = o->op_next) {
4527 OPCODE type = o->op_type;
4529 if (sv && o->op_next == o)
4531 if (o->op_next != o) {
4532 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4534 if (type == OP_DBSTATE)
4537 if (type == OP_LEAVESUB || type == OP_RETURN)
4541 if (type == OP_CONST && cSVOPo->op_sv)
4543 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4544 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4545 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4549 /* We get here only from cv_clone2() while creating a closure.
4550 Copy the const value here instead of in cv_clone2 so that
4551 SvREADONLY_on doesn't lead to problems when leaving
4556 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4568 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4578 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4582 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4584 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4588 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4594 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4599 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4600 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4601 SV *sv = sv_newmortal();
4602 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4603 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4608 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4609 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4619 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4620 maximum a prototype before. */
4621 if (SvTYPE(gv) > SVt_NULL) {
4622 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4623 && ckWARN_d(WARN_PROTOTYPE))
4625 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4627 cv_ckproto((CV*)gv, NULL, ps);
4630 sv_setpv((SV*)gv, ps);
4632 sv_setiv((SV*)gv, -1);
4633 SvREFCNT_dec(PL_compcv);
4634 cv = PL_compcv = NULL;
4635 PL_sub_generation++;
4639 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4641 #ifdef GV_UNIQUE_CHECK
4642 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4643 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4647 if (!block || !ps || *ps || attrs)
4650 const_sv = op_const_sv(block, Nullcv);
4653 bool exists = CvROOT(cv) || CvXSUB(cv);
4655 #ifdef GV_UNIQUE_CHECK
4656 if (exists && GvUNIQUE(gv)) {
4657 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4661 /* if the subroutine doesn't exist and wasn't pre-declared
4662 * with a prototype, assume it will be AUTOLOADed,
4663 * skipping the prototype check
4665 if (exists || SvPOK(cv))
4666 cv_ckproto(cv, gv, ps);
4667 /* already defined (or promised)? */
4668 if (exists || GvASSUMECV(gv)) {
4669 if (!block && !attrs) {
4670 /* just a "sub foo;" when &foo is already defined */
4671 SAVEFREESV(PL_compcv);
4674 /* ahem, death to those who redefine active sort subs */
4675 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4676 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4678 if (ckWARN(WARN_REDEFINE)
4680 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4682 line_t oldline = CopLINE(PL_curcop);
4683 CopLINE_set(PL_curcop, PL_copline);
4684 Perl_warner(aTHX_ WARN_REDEFINE,
4685 CvCONST(cv) ? "Constant subroutine %s redefined"
4686 : "Subroutine %s redefined", name);
4687 CopLINE_set(PL_curcop, oldline);
4695 SvREFCNT_inc(const_sv);
4697 assert(!CvROOT(cv) && !CvCONST(cv));
4698 sv_setpv((SV*)cv, ""); /* prototype is "" */
4699 CvXSUBANY(cv).any_ptr = const_sv;
4700 CvXSUB(cv) = const_sv_xsub;
4705 cv = newCONSTSUB(NULL, name, const_sv);
4708 SvREFCNT_dec(PL_compcv);
4710 PL_sub_generation++;
4717 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4718 * before we clobber PL_compcv.
4722 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4723 stash = GvSTASH(CvGV(cv));
4724 else if (CvSTASH(cv))
4725 stash = CvSTASH(cv);
4727 stash = PL_curstash;
4730 /* possibly about to re-define existing subr -- ignore old cv */
4731 rcv = (SV*)PL_compcv;
4732 if (name && GvSTASH(gv))
4733 stash = GvSTASH(gv);
4735 stash = PL_curstash;
4737 apply_attrs(stash, rcv, attrs);
4739 if (cv) { /* must reuse cv if autoloaded */
4741 /* got here with just attrs -- work done, so bug out */
4742 SAVEFREESV(PL_compcv);
4746 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4747 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4748 CvOUTSIDE(PL_compcv) = 0;
4749 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4750 CvPADLIST(PL_compcv) = 0;
4751 /* inner references to PL_compcv must be fixed up ... */
4753 AV *padlist = CvPADLIST(cv);
4754 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4755 AV *comppad = (AV*)AvARRAY(padlist)[1];
4756 SV **namepad = AvARRAY(comppad_name);
4757 SV **curpad = AvARRAY(comppad);
4758 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4759 SV *namesv = namepad[ix];
4760 if (namesv && namesv != &PL_sv_undef
4761 && *SvPVX(namesv) == '&')
4763 CV *innercv = (CV*)curpad[ix];
4764 if (CvOUTSIDE(innercv) == PL_compcv) {
4765 CvOUTSIDE(innercv) = cv;
4766 if (!CvANON(innercv) || CvCLONED(innercv)) {
4767 (void)SvREFCNT_inc(cv);
4768 SvREFCNT_dec(PL_compcv);
4774 /* ... before we throw it away */
4775 SvREFCNT_dec(PL_compcv);
4776 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4777 ++PL_sub_generation;
4784 PL_sub_generation++;
4788 CvFILE_set_from_cop(cv, PL_curcop);
4789 CvSTASH(cv) = PL_curstash;
4792 if (!CvMUTEXP(cv)) {
4793 New(666, CvMUTEXP(cv), 1, perl_mutex);
4794 MUTEX_INIT(CvMUTEXP(cv));
4796 #endif /* USE_THREADS */
4799 sv_setpv((SV*)cv, ps);
4801 if (PL_error_count) {
4805 char *s = strrchr(name, ':');
4807 if (strEQ(s, "BEGIN")) {
4809 "BEGIN not safe after errors--compilation aborted";
4810 if (PL_in_eval & EVAL_KEEPERR)
4811 Perl_croak(aTHX_ not_safe);
4813 /* force display of errors found but not reported */
4814 sv_catpv(ERRSV, not_safe);
4815 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4823 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4824 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4827 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4828 mod(scalarseq(block), OP_LEAVESUBLV));
4831 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4833 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4834 OpREFCNT_set(CvROOT(cv), 1);
4835 CvSTART(cv) = LINKLIST(CvROOT(cv));
4836 CvROOT(cv)->op_next = 0;
4837 CALL_PEEP(CvSTART(cv));
4839 /* now that optimizer has done its work, adjust pad values */
4841 SV **namep = AvARRAY(PL_comppad_name);
4842 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4845 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4848 * The only things that a clonable function needs in its
4849 * pad are references to outer lexicals and anonymous subs.
4850 * The rest are created anew during cloning.
4852 if (!((namesv = namep[ix]) != Nullsv &&
4853 namesv != &PL_sv_undef &&
4855 *SvPVX(namesv) == '&')))
4857 SvREFCNT_dec(PL_curpad[ix]);
4858 PL_curpad[ix] = Nullsv;
4861 assert(!CvCONST(cv));
4862 if (ps && !*ps && op_const_sv(block, cv))
4866 AV *av = newAV(); /* Will be @_ */
4868 av_store(PL_comppad, 0, (SV*)av);
4869 AvFLAGS(av) = AVf_REIFY;
4871 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4872 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4874 if (!SvPADMY(PL_curpad[ix]))
4875 SvPADTMP_on(PL_curpad[ix]);
4879 /* If a potential closure prototype, don't keep a refcount on
4880 * outer CV, unless the latter happens to be a passing eval"".
4881 * This is okay as the lifetime of the prototype is tied to the
4882 * lifetime of the outer CV. Avoids memory leak due to reference
4884 if (!name && CvOUTSIDE(cv)
4885 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4886 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4888 SvREFCNT_dec(CvOUTSIDE(cv));
4891 if (name || aname) {
4893 char *tname = (name ? name : aname);
4895 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4896 SV *sv = NEWSV(0,0);
4897 SV *tmpstr = sv_newmortal();
4898 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4902 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4904 (long)PL_subline, (long)CopLINE(PL_curcop));
4905 gv_efullname3(tmpstr, gv, Nullch);
4906 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4907 hv = GvHVn(db_postponed);
4908 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4909 && (pcv = GvCV(db_postponed)))
4915 call_sv((SV*)pcv, G_DISCARD);
4919 if ((s = strrchr(tname,':')))
4924 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4927 if (strEQ(s, "BEGIN")) {
4928 I32 oldscope = PL_scopestack_ix;
4930 SAVECOPFILE(&PL_compiling);
4931 SAVECOPLINE(&PL_compiling);
4933 sv_setsv(PL_rs, PL_nrs);
4936 PL_beginav = newAV();
4937 DEBUG_x( dump_sub(gv) );
4938 av_push(PL_beginav, (SV*)cv);
4939 GvCV(gv) = 0; /* cv has been hijacked */
4940 call_list(oldscope, PL_beginav);
4942 PL_curcop = &PL_compiling;
4943 PL_compiling.op_private = PL_hints;
4946 else if (strEQ(s, "END") && !PL_error_count) {
4949 DEBUG_x( dump_sub(gv) );
4950 av_unshift(PL_endav, 1);
4951 av_store(PL_endav, 0, (SV*)cv);
4952 GvCV(gv) = 0; /* cv has been hijacked */
4954 else if (strEQ(s, "CHECK") && !PL_error_count) {
4956 PL_checkav = newAV();
4957 DEBUG_x( dump_sub(gv) );
4958 if (PL_main_start && ckWARN(WARN_VOID))
4959 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4960 av_unshift(PL_checkav, 1);
4961 av_store(PL_checkav, 0, (SV*)cv);
4962 GvCV(gv) = 0; /* cv has been hijacked */
4964 else if (strEQ(s, "INIT") && !PL_error_count) {
4966 PL_initav = newAV();
4967 DEBUG_x( dump_sub(gv) );
4968 if (PL_main_start && ckWARN(WARN_VOID))
4969 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4970 av_push(PL_initav, (SV*)cv);
4971 GvCV(gv) = 0; /* cv has been hijacked */
4976 PL_copline = NOLINE;
4981 /* XXX unsafe for threads if eval_owner isn't held */
4983 =for apidoc newCONSTSUB
4985 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4986 eligible for inlining at compile-time.
4992 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4998 SAVECOPLINE(PL_curcop);
4999 CopLINE_set(PL_curcop, PL_copline);
5002 PL_hints &= ~HINT_BLOCK_SCOPE;
5005 SAVESPTR(PL_curstash);
5006 SAVECOPSTASH(PL_curcop);
5007 PL_curstash = stash;
5009 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5011 CopSTASH(PL_curcop) = stash;
5015 cv = newXS(name, const_sv_xsub, __FILE__);
5016 CvXSUBANY(cv).any_ptr = sv;
5018 sv_setpv((SV*)cv, ""); /* prototype is "" */
5026 =for apidoc U||newXS
5028 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5034 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5036 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5039 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5041 /* just a cached method */
5045 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5046 /* already defined (or promised) */
5047 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5048 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5049 line_t oldline = CopLINE(PL_curcop);
5050 if (PL_copline != NOLINE)
5051 CopLINE_set(PL_curcop, PL_copline);
5052 Perl_warner(aTHX_ WARN_REDEFINE,
5053 CvCONST(cv) ? "Constant subroutine %s redefined"
5054 : "Subroutine %s redefined"
5056 CopLINE_set(PL_curcop, oldline);
5063 if (cv) /* must reuse cv if autoloaded */
5066 cv = (CV*)NEWSV(1105,0);
5067 sv_upgrade((SV *)cv, SVt_PVCV);
5071 PL_sub_generation++;
5076 New(666, CvMUTEXP(cv), 1, perl_mutex);
5077 MUTEX_INIT(CvMUTEXP(cv));
5079 #endif /* USE_THREADS */
5080 (void)gv_fetchfile(filename);
5081 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5082 an external constant string */
5083 CvXSUB(cv) = subaddr;
5086 char *s = strrchr(name,':');
5092 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5095 if (strEQ(s, "BEGIN")) {
5097 PL_beginav = newAV();
5098 av_push(PL_beginav, (SV*)cv);
5099 GvCV(gv) = 0; /* cv has been hijacked */
5101 else if (strEQ(s, "END")) {
5104 av_unshift(PL_endav, 1);
5105 av_store(PL_endav, 0, (SV*)cv);
5106 GvCV(gv) = 0; /* cv has been hijacked */
5108 else if (strEQ(s, "CHECK")) {
5110 PL_checkav = newAV();
5111 if (PL_main_start && ckWARN(WARN_VOID))
5112 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5113 av_unshift(PL_checkav, 1);
5114 av_store(PL_checkav, 0, (SV*)cv);
5115 GvCV(gv) = 0; /* cv has been hijacked */
5117 else if (strEQ(s, "INIT")) {
5119 PL_initav = newAV();
5120 if (PL_main_start && ckWARN(WARN_VOID))
5121 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5122 av_push(PL_initav, (SV*)cv);
5123 GvCV(gv) = 0; /* cv has been hijacked */
5134 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5143 name = SvPVx(cSVOPo->op_sv, n_a);
5146 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5147 #ifdef GV_UNIQUE_CHECK
5149 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5153 if ((cv = GvFORM(gv))) {
5154 if (ckWARN(WARN_REDEFINE)) {
5155 line_t oldline = CopLINE(PL_curcop);
5157 CopLINE_set(PL_curcop, PL_copline);
5158 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5159 CopLINE_set(PL_curcop, oldline);
5166 CvFILE_set_from_cop(cv, PL_curcop);
5168 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5169 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5170 SvPADTMP_on(PL_curpad[ix]);
5173 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5174 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5175 OpREFCNT_set(CvROOT(cv), 1);
5176 CvSTART(cv) = LINKLIST(CvROOT(cv));
5177 CvROOT(cv)->op_next = 0;
5178 CALL_PEEP(CvSTART(cv));
5180 PL_copline = NOLINE;
5185 Perl_newANONLIST(pTHX_ OP *o)
5187 return newUNOP(OP_REFGEN, 0,
5188 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5192 Perl_newANONHASH(pTHX_ OP *o)
5194 return newUNOP(OP_REFGEN, 0,
5195 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5199 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5201 return newANONATTRSUB(floor, proto, Nullop, block);
5205 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5207 return newUNOP(OP_REFGEN, 0,
5208 newSVOP(OP_ANONCODE, 0,
5209 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5213 Perl_oopsAV(pTHX_ OP *o)
5215 switch (o->op_type) {
5217 o->op_type = OP_PADAV;
5218 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5219 return ref(o, OP_RV2AV);
5222 o->op_type = OP_RV2AV;
5223 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5228 if (ckWARN_d(WARN_INTERNAL))
5229 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5236 Perl_oopsHV(pTHX_ OP *o)
5238 switch (o->op_type) {
5241 o->op_type = OP_PADHV;
5242 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5243 return ref(o, OP_RV2HV);
5247 o->op_type = OP_RV2HV;
5248 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5253 if (ckWARN_d(WARN_INTERNAL))
5254 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5261 Perl_newAVREF(pTHX_ OP *o)
5263 if (o->op_type == OP_PADANY) {
5264 o->op_type = OP_PADAV;
5265 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5268 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5269 && ckWARN(WARN_DEPRECATED)) {
5270 Perl_warner(aTHX_ WARN_DEPRECATED,
5271 "Using an array as a reference is deprecated");
5273 return newUNOP(OP_RV2AV, 0, scalar(o));
5277 Perl_newGVREF(pTHX_ I32 type, OP *o)
5279 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5280 return newUNOP(OP_NULL, 0, o);
5281 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5285 Perl_newHVREF(pTHX_ OP *o)
5287 if (o->op_type == OP_PADANY) {
5288 o->op_type = OP_PADHV;
5289 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5292 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5293 && ckWARN(WARN_DEPRECATED)) {
5294 Perl_warner(aTHX_ WARN_DEPRECATED,
5295 "Using a hash as a reference is deprecated");
5297 return newUNOP(OP_RV2HV, 0, scalar(o));
5301 Perl_oopsCV(pTHX_ OP *o)
5303 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5309 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5311 return newUNOP(OP_RV2CV, flags, scalar(o));
5315 Perl_newSVREF(pTHX_ OP *o)
5317 if (o->op_type == OP_PADANY) {
5318 o->op_type = OP_PADSV;
5319 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5322 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5323 o->op_flags |= OPpDONE_SVREF;
5326 return newUNOP(OP_RV2SV, 0, scalar(o));
5329 /* Check routines. */
5332 Perl_ck_anoncode(pTHX_ OP *o)
5337 name = NEWSV(1106,0);
5338 sv_upgrade(name, SVt_PVNV);
5339 sv_setpvn(name, "&", 1);
5342 ix = pad_alloc(o->op_type, SVs_PADMY);
5343 av_store(PL_comppad_name, ix, name);
5344 av_store(PL_comppad, ix, cSVOPo->op_sv);
5345 SvPADMY_on(cSVOPo->op_sv);
5346 cSVOPo->op_sv = Nullsv;
5347 cSVOPo->op_targ = ix;
5352 Perl_ck_bitop(pTHX_ OP *o)
5354 o->op_private = PL_hints;
5359 Perl_ck_concat(pTHX_ OP *o)
5361 if (cUNOPo->op_first->op_type == OP_CONCAT)
5362 o->op_flags |= OPf_STACKED;
5367 Perl_ck_spair(pTHX_ OP *o)
5369 if (o->op_flags & OPf_KIDS) {
5372 OPCODE type = o->op_type;
5373 o = modkids(ck_fun(o), type);
5374 kid = cUNOPo->op_first;
5375 newop = kUNOP->op_first->op_sibling;
5377 (newop->op_sibling ||
5378 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5379 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5380 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5384 op_free(kUNOP->op_first);
5385 kUNOP->op_first = newop;
5387 o->op_ppaddr = PL_ppaddr[++o->op_type];
5392 Perl_ck_delete(pTHX_ OP *o)
5396 if (o->op_flags & OPf_KIDS) {
5397 OP *kid = cUNOPo->op_first;
5398 switch (kid->op_type) {
5400 o->op_flags |= OPf_SPECIAL;
5403 o->op_private |= OPpSLICE;
5406 o->op_flags |= OPf_SPECIAL;
5411 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5412 PL_op_desc[o->op_type]);
5420 Perl_ck_eof(pTHX_ OP *o)
5422 I32 type = o->op_type;
5424 if (o->op_flags & OPf_KIDS) {
5425 if (cLISTOPo->op_first->op_type == OP_STUB) {
5427 o = newUNOP(type, OPf_SPECIAL,
5428 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5436 Perl_ck_eval(pTHX_ OP *o)
5438 PL_hints |= HINT_BLOCK_SCOPE;
5439 if (o->op_flags & OPf_KIDS) {
5440 SVOP *kid = (SVOP*)cUNOPo->op_first;
5443 o->op_flags &= ~OPf_KIDS;
5446 else if (kid->op_type == OP_LINESEQ) {
5449 kid->op_next = o->op_next;
5450 cUNOPo->op_first = 0;
5453 NewOp(1101, enter, 1, LOGOP);
5454 enter->op_type = OP_ENTERTRY;
5455 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5456 enter->op_private = 0;
5458 /* establish postfix order */
5459 enter->op_next = (OP*)enter;
5461 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5462 o->op_type = OP_LEAVETRY;
5463 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5464 enter->op_other = o;
5472 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5474 o->op_targ = (PADOFFSET)PL_hints;
5479 Perl_ck_exit(pTHX_ OP *o)
5482 HV *table = GvHV(PL_hintgv);
5484 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5485 if (svp && *svp && SvTRUE(*svp))
5486 o->op_private |= OPpEXIT_VMSISH;
5493 Perl_ck_exec(pTHX_ OP *o)
5496 if (o->op_flags & OPf_STACKED) {
5498 kid = cUNOPo->op_first->op_sibling;
5499 if (kid->op_type == OP_RV2GV)
5508 Perl_ck_exists(pTHX_ OP *o)
5511 if (o->op_flags & OPf_KIDS) {
5512 OP *kid = cUNOPo->op_first;
5513 if (kid->op_type == OP_ENTERSUB) {
5514 (void) ref(kid, o->op_type);
5515 if (kid->op_type != OP_RV2CV && !PL_error_count)
5516 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5517 PL_op_desc[o->op_type]);
5518 o->op_private |= OPpEXISTS_SUB;
5520 else if (kid->op_type == OP_AELEM)
5521 o->op_flags |= OPf_SPECIAL;
5522 else if (kid->op_type != OP_HELEM)
5523 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5524 PL_op_desc[o->op_type]);
5532 Perl_ck_gvconst(pTHX_ register OP *o)
5534 o = fold_constants(o);
5535 if (o->op_type == OP_CONST)
5542 Perl_ck_rvconst(pTHX_ register OP *o)
5544 SVOP *kid = (SVOP*)cUNOPo->op_first;
5546 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5547 if (kid->op_type == OP_CONST) {
5551 SV *kidsv = kid->op_sv;
5554 /* Is it a constant from cv_const_sv()? */
5555 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5556 SV *rsv = SvRV(kidsv);
5557 int svtype = SvTYPE(rsv);
5558 char *badtype = Nullch;
5560 switch (o->op_type) {
5562 if (svtype > SVt_PVMG)
5563 badtype = "a SCALAR";
5566 if (svtype != SVt_PVAV)
5567 badtype = "an ARRAY";
5570 if (svtype != SVt_PVHV) {
5571 if (svtype == SVt_PVAV) { /* pseudohash? */
5572 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5573 if (ksv && SvROK(*ksv)
5574 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5583 if (svtype != SVt_PVCV)
5588 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5591 name = SvPV(kidsv, n_a);
5592 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5593 char *badthing = Nullch;
5594 switch (o->op_type) {
5596 badthing = "a SCALAR";
5599 badthing = "an ARRAY";
5602 badthing = "a HASH";
5607 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5611 * This is a little tricky. We only want to add the symbol if we
5612 * didn't add it in the lexer. Otherwise we get duplicate strict
5613 * warnings. But if we didn't add it in the lexer, we must at
5614 * least pretend like we wanted to add it even if it existed before,
5615 * or we get possible typo warnings. OPpCONST_ENTERED says
5616 * whether the lexer already added THIS instance of this symbol.
5618 iscv = (o->op_type == OP_RV2CV) * 2;
5620 gv = gv_fetchpv(name,
5621 iscv | !(kid->op_private & OPpCONST_ENTERED),
5624 : o->op_type == OP_RV2SV
5626 : o->op_type == OP_RV2AV
5628 : o->op_type == OP_RV2HV
5631 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5633 kid->op_type = OP_GV;
5634 SvREFCNT_dec(kid->op_sv);
5636 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5637 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5638 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5640 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5642 kid->op_sv = SvREFCNT_inc(gv);
5644 kid->op_private = 0;
5645 kid->op_ppaddr = PL_ppaddr[OP_GV];
5652 Perl_ck_ftst(pTHX_ OP *o)
5654 I32 type = o->op_type;
5656 if (o->op_flags & OPf_REF) {
5659 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5660 SVOP *kid = (SVOP*)cUNOPo->op_first;
5662 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5664 OP *newop = newGVOP(type, OPf_REF,
5665 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5672 if (type == OP_FTTTY)
5673 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5676 o = newUNOP(type, 0, newDEFSVOP());
5682 Perl_ck_fun(pTHX_ OP *o)
5688 int type = o->op_type;
5689 register I32 oa = PL_opargs[type] >> OASHIFT;
5691 if (o->op_flags & OPf_STACKED) {
5692 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5695 return no_fh_allowed(o);
5698 if (o->op_flags & OPf_KIDS) {
5700 tokid = &cLISTOPo->op_first;
5701 kid = cLISTOPo->op_first;
5702 if (kid->op_type == OP_PUSHMARK ||
5703 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5705 tokid = &kid->op_sibling;
5706 kid = kid->op_sibling;
5708 if (!kid && PL_opargs[type] & OA_DEFGV)
5709 *tokid = kid = newDEFSVOP();
5713 sibl = kid->op_sibling;
5716 /* list seen where single (scalar) arg expected? */
5717 if (numargs == 1 && !(oa >> 4)
5718 && kid->op_type == OP_LIST && type != OP_SCALAR)
5720 return too_many_arguments(o,PL_op_desc[type]);
5733 if ((type == OP_PUSH || type == OP_UNSHIFT)
5734 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5735 Perl_warner(aTHX_ WARN_SYNTAX,
5736 "Useless use of %s with no values",
5739 if (kid->op_type == OP_CONST &&
5740 (kid->op_private & OPpCONST_BARE))
5742 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5743 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5744 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5745 if (ckWARN(WARN_DEPRECATED))
5746 Perl_warner(aTHX_ WARN_DEPRECATED,
5747 "Array @%s missing the @ in argument %"IVdf" of %s()",
5748 name, (IV)numargs, PL_op_desc[type]);
5751 kid->op_sibling = sibl;
5754 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5755 bad_type(numargs, "array", PL_op_desc[type], kid);
5759 if (kid->op_type == OP_CONST &&
5760 (kid->op_private & OPpCONST_BARE))
5762 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5763 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5764 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5765 if (ckWARN(WARN_DEPRECATED))
5766 Perl_warner(aTHX_ WARN_DEPRECATED,
5767 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5768 name, (IV)numargs, PL_op_desc[type]);
5771 kid->op_sibling = sibl;
5774 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5775 bad_type(numargs, "hash", PL_op_desc[type], kid);
5780 OP *newop = newUNOP(OP_NULL, 0, kid);
5781 kid->op_sibling = 0;
5783 newop->op_next = newop;
5785 kid->op_sibling = sibl;
5790 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5791 if (kid->op_type == OP_CONST &&
5792 (kid->op_private & OPpCONST_BARE))
5794 OP *newop = newGVOP(OP_GV, 0,
5795 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5800 else if (kid->op_type == OP_READLINE) {
5801 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5802 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5805 I32 flags = OPf_SPECIAL;
5809 /* is this op a FH constructor? */
5810 if (is_handle_constructor(o,numargs)) {
5811 char *name = Nullch;
5815 /* Set a flag to tell rv2gv to vivify
5816 * need to "prove" flag does not mean something
5817 * else already - NI-S 1999/05/07
5820 if (kid->op_type == OP_PADSV) {
5821 SV **namep = av_fetch(PL_comppad_name,
5823 if (namep && *namep)
5824 name = SvPV(*namep, len);
5826 else if (kid->op_type == OP_RV2SV
5827 && kUNOP->op_first->op_type == OP_GV)
5829 GV *gv = cGVOPx_gv(kUNOP->op_first);
5831 len = GvNAMELEN(gv);
5833 else if (kid->op_type == OP_AELEM
5834 || kid->op_type == OP_HELEM)
5836 name = "__ANONIO__";
5842 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5843 namesv = PL_curpad[targ];
5844 (void)SvUPGRADE(namesv, SVt_PV);
5846 sv_setpvn(namesv, "$", 1);
5847 sv_catpvn(namesv, name, len);
5850 kid->op_sibling = 0;
5851 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5852 kid->op_targ = targ;
5853 kid->op_private |= priv;
5855 kid->op_sibling = sibl;
5861 mod(scalar(kid), type);
5865 tokid = &kid->op_sibling;
5866 kid = kid->op_sibling;
5868 o->op_private |= numargs;
5870 return too_many_arguments(o,PL_op_desc[o->op_type]);
5873 else if (PL_opargs[type] & OA_DEFGV) {
5875 return newUNOP(type, 0, newDEFSVOP());
5879 while (oa & OA_OPTIONAL)
5881 if (oa && oa != OA_LIST)
5882 return too_few_arguments(o,PL_op_desc[o->op_type]);
5888 Perl_ck_glob(pTHX_ OP *o)
5893 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5894 append_elem(OP_GLOB, o, newDEFSVOP());
5896 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5897 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5899 #if !defined(PERL_EXTERNAL_GLOB)
5900 /* XXX this can be tightened up and made more failsafe. */
5904 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5906 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5907 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5908 GvCV(gv) = GvCV(glob_gv);
5909 SvREFCNT_inc((SV*)GvCV(gv));
5910 GvIMPORTED_CV_on(gv);
5913 #endif /* PERL_EXTERNAL_GLOB */
5915 if (gv && GvIMPORTED_CV(gv)) {
5916 append_elem(OP_GLOB, o,
5917 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5918 o->op_type = OP_LIST;
5919 o->op_ppaddr = PL_ppaddr[OP_LIST];
5920 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5921 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5922 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5923 append_elem(OP_LIST, o,
5924 scalar(newUNOP(OP_RV2CV, 0,
5925 newGVOP(OP_GV, 0, gv)))));
5926 o = newUNOP(OP_NULL, 0, ck_subr(o));
5927 o->op_targ = OP_GLOB; /* hint at what it used to be */
5930 gv = newGVgen("main");
5932 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5938 Perl_ck_grep(pTHX_ OP *o)
5942 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5944 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5945 NewOp(1101, gwop, 1, LOGOP);
5947 if (o->op_flags & OPf_STACKED) {
5950 kid = cLISTOPo->op_first->op_sibling;
5951 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5954 kid->op_next = (OP*)gwop;
5955 o->op_flags &= ~OPf_STACKED;
5957 kid = cLISTOPo->op_first->op_sibling;
5958 if (type == OP_MAPWHILE)
5965 kid = cLISTOPo->op_first->op_sibling;
5966 if (kid->op_type != OP_NULL)
5967 Perl_croak(aTHX_ "panic: ck_grep");
5968 kid = kUNOP->op_first;
5970 gwop->op_type = type;
5971 gwop->op_ppaddr = PL_ppaddr[type];
5972 gwop->op_first = listkids(o);
5973 gwop->op_flags |= OPf_KIDS;
5974 gwop->op_private = 1;
5975 gwop->op_other = LINKLIST(kid);
5976 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5977 kid->op_next = (OP*)gwop;
5979 kid = cLISTOPo->op_first->op_sibling;
5980 if (!kid || !kid->op_sibling)
5981 return too_few_arguments(o,PL_op_desc[o->op_type]);
5982 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5983 mod(kid, OP_GREPSTART);
5989 Perl_ck_index(pTHX_ OP *o)
5991 if (o->op_flags & OPf_KIDS) {
5992 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5994 kid = kid->op_sibling; /* get past "big" */
5995 if (kid && kid->op_type == OP_CONST)
5996 fbm_compile(((SVOP*)kid)->op_sv, 0);
6002 Perl_ck_lengthconst(pTHX_ OP *o)
6004 /* XXX length optimization goes here */
6009 Perl_ck_lfun(pTHX_ OP *o)
6011 OPCODE type = o->op_type;
6012 return modkids(ck_fun(o), type);
6016 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6018 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6019 switch (cUNOPo->op_first->op_type) {
6021 /* This is needed for
6022 if (defined %stash::)
6023 to work. Do not break Tk.
6025 break; /* Globals via GV can be undef */
6027 case OP_AASSIGN: /* Is this a good idea? */
6028 Perl_warner(aTHX_ WARN_DEPRECATED,
6029 "defined(@array) is deprecated");
6030 Perl_warner(aTHX_ WARN_DEPRECATED,
6031 "\t(Maybe you should just omit the defined()?)\n");
6034 /* This is needed for
6035 if (defined %stash::)
6036 to work. Do not break Tk.
6038 break; /* Globals via GV can be undef */
6040 Perl_warner(aTHX_ WARN_DEPRECATED,
6041 "defined(%%hash) is deprecated");
6042 Perl_warner(aTHX_ WARN_DEPRECATED,
6043 "\t(Maybe you should just omit the defined()?)\n");
6054 Perl_ck_rfun(pTHX_ OP *o)
6056 OPCODE type = o->op_type;
6057 return refkids(ck_fun(o), type);
6061 Perl_ck_listiob(pTHX_ OP *o)
6065 kid = cLISTOPo->op_first;
6068 kid = cLISTOPo->op_first;
6070 if (kid->op_type == OP_PUSHMARK)
6071 kid = kid->op_sibling;
6072 if (kid && o->op_flags & OPf_STACKED)
6073 kid = kid->op_sibling;
6074 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6075 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6076 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6077 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6078 cLISTOPo->op_first->op_sibling = kid;
6079 cLISTOPo->op_last = kid;
6080 kid = kid->op_sibling;
6085 append_elem(o->op_type, o, newDEFSVOP());
6091 Perl_ck_sassign(pTHX_ OP *o)
6093 OP *kid = cLISTOPo->op_first;
6094 /* has a disposable target? */
6095 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6096 && !(kid->op_flags & OPf_STACKED)
6097 /* Cannot steal the second time! */
6098 && !(kid->op_private & OPpTARGET_MY))
6100 OP *kkid = kid->op_sibling;
6102 /* Can just relocate the target. */
6103 if (kkid && kkid->op_type == OP_PADSV
6104 && !(kkid->op_private & OPpLVAL_INTRO))
6106 kid->op_targ = kkid->op_targ;
6108 /* Now we do not need PADSV and SASSIGN. */
6109 kid->op_sibling = o->op_sibling; /* NULL */
6110 cLISTOPo->op_first = NULL;
6113 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6121 Perl_ck_match(pTHX_ OP *o)
6123 o->op_private |= OPpRUNTIME;
6128 Perl_ck_method(pTHX_ OP *o)
6130 OP *kid = cUNOPo->op_first;
6131 if (kid->op_type == OP_CONST) {
6132 SV* sv = kSVOP->op_sv;
6133 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6135 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6136 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6139 kSVOP->op_sv = Nullsv;
6141 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6150 Perl_ck_null(pTHX_ OP *o)
6156 Perl_ck_open(pTHX_ OP *o)
6158 HV *table = GvHV(PL_hintgv);
6162 svp = hv_fetch(table, "open_IN", 7, FALSE);
6164 mode = mode_from_discipline(*svp);
6165 if (mode & O_BINARY)
6166 o->op_private |= OPpOPEN_IN_RAW;
6167 else if (mode & O_TEXT)
6168 o->op_private |= OPpOPEN_IN_CRLF;
6171 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6173 mode = mode_from_discipline(*svp);
6174 if (mode & O_BINARY)
6175 o->op_private |= OPpOPEN_OUT_RAW;
6176 else if (mode & O_TEXT)
6177 o->op_private |= OPpOPEN_OUT_CRLF;
6180 if (o->op_type == OP_BACKTICK)
6186 Perl_ck_repeat(pTHX_ OP *o)
6188 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6189 o->op_private |= OPpREPEAT_DOLIST;
6190 cBINOPo->op_first = force_list(cBINOPo->op_first);
6198 Perl_ck_require(pTHX_ OP *o)
6202 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6203 SVOP *kid = (SVOP*)cUNOPo->op_first;
6205 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6207 for (s = SvPVX(kid->op_sv); *s; s++) {
6208 if (*s == ':' && s[1] == ':') {
6210 Move(s+2, s+1, strlen(s+2)+1, char);
6211 --SvCUR(kid->op_sv);
6214 if (SvREADONLY(kid->op_sv)) {
6215 SvREADONLY_off(kid->op_sv);
6216 sv_catpvn(kid->op_sv, ".pm", 3);
6217 SvREADONLY_on(kid->op_sv);
6220 sv_catpvn(kid->op_sv, ".pm", 3);
6224 /* handle override, if any */
6225 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6226 if (!(gv && GvIMPORTED_CV(gv)))
6227 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6229 if (gv && GvIMPORTED_CV(gv)) {
6230 OP *kid = cUNOPo->op_first;
6231 cUNOPo->op_first = 0;
6233 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6234 append_elem(OP_LIST, kid,
6235 scalar(newUNOP(OP_RV2CV, 0,
6244 Perl_ck_return(pTHX_ OP *o)
6247 if (CvLVALUE(PL_compcv)) {
6248 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6249 mod(kid, OP_LEAVESUBLV);
6256 Perl_ck_retarget(pTHX_ OP *o)
6258 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6265 Perl_ck_select(pTHX_ OP *o)
6268 if (o->op_flags & OPf_KIDS) {
6269 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6270 if (kid && kid->op_sibling) {
6271 o->op_type = OP_SSELECT;
6272 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6274 return fold_constants(o);
6278 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6279 if (kid && kid->op_type == OP_RV2GV)
6280 kid->op_private &= ~HINT_STRICT_REFS;
6285 Perl_ck_shift(pTHX_ OP *o)
6287 I32 type = o->op_type;
6289 if (!(o->op_flags & OPf_KIDS)) {
6294 if (!CvUNIQUE(PL_compcv)) {
6295 argop = newOP(OP_PADAV, OPf_REF);
6296 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6299 argop = newUNOP(OP_RV2AV, 0,
6300 scalar(newGVOP(OP_GV, 0,
6301 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6304 argop = newUNOP(OP_RV2AV, 0,
6305 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6306 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6307 #endif /* USE_THREADS */
6308 return newUNOP(type, 0, scalar(argop));
6310 return scalar(modkids(ck_fun(o), type));
6314 Perl_ck_sort(pTHX_ OP *o)
6318 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6320 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6321 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6323 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6325 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6327 if (kid->op_type == OP_SCOPE) {
6331 else if (kid->op_type == OP_LEAVE) {
6332 if (o->op_type == OP_SORT) {
6333 op_null(kid); /* wipe out leave */
6336 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6337 if (k->op_next == kid)
6339 /* don't descend into loops */
6340 else if (k->op_type == OP_ENTERLOOP
6341 || k->op_type == OP_ENTERITER)
6343 k = cLOOPx(k)->op_lastop;
6348 kid->op_next = 0; /* just disconnect the leave */
6349 k = kLISTOP->op_first;
6354 if (o->op_type == OP_SORT) {
6355 /* provide scalar context for comparison function/block */
6361 o->op_flags |= OPf_SPECIAL;
6363 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6366 firstkid = firstkid->op_sibling;
6369 /* provide list context for arguments */
6370 if (o->op_type == OP_SORT)
6377 S_simplify_sort(pTHX_ OP *o)
6379 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6383 if (!(o->op_flags & OPf_STACKED))
6385 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6386 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6387 kid = kUNOP->op_first; /* get past null */
6388 if (kid->op_type != OP_SCOPE)
6390 kid = kLISTOP->op_last; /* get past scope */
6391 switch(kid->op_type) {
6399 k = kid; /* remember this node*/
6400 if (kBINOP->op_first->op_type != OP_RV2SV)
6402 kid = kBINOP->op_first; /* get past cmp */
6403 if (kUNOP->op_first->op_type != OP_GV)
6405 kid = kUNOP->op_first; /* get past rv2sv */
6407 if (GvSTASH(gv) != PL_curstash)
6409 if (strEQ(GvNAME(gv), "a"))
6411 else if (strEQ(GvNAME(gv), "b"))
6415 kid = k; /* back to cmp */
6416 if (kBINOP->op_last->op_type != OP_RV2SV)
6418 kid = kBINOP->op_last; /* down to 2nd arg */
6419 if (kUNOP->op_first->op_type != OP_GV)
6421 kid = kUNOP->op_first; /* get past rv2sv */
6423 if (GvSTASH(gv) != PL_curstash
6425 ? strNE(GvNAME(gv), "a")
6426 : strNE(GvNAME(gv), "b")))
6428 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6430 o->op_private |= OPpSORT_REVERSE;
6431 if (k->op_type == OP_NCMP)
6432 o->op_private |= OPpSORT_NUMERIC;
6433 if (k->op_type == OP_I_NCMP)
6434 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6435 kid = cLISTOPo->op_first->op_sibling;
6436 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6437 op_free(kid); /* then delete it */
6441 Perl_ck_split(pTHX_ OP *o)
6445 if (o->op_flags & OPf_STACKED)
6446 return no_fh_allowed(o);
6448 kid = cLISTOPo->op_first;
6449 if (kid->op_type != OP_NULL)
6450 Perl_croak(aTHX_ "panic: ck_split");
6451 kid = kid->op_sibling;
6452 op_free(cLISTOPo->op_first);
6453 cLISTOPo->op_first = kid;
6455 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6456 cLISTOPo->op_last = kid; /* There was only one element previously */
6459 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6460 OP *sibl = kid->op_sibling;
6461 kid->op_sibling = 0;
6462 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6463 if (cLISTOPo->op_first == cLISTOPo->op_last)
6464 cLISTOPo->op_last = kid;
6465 cLISTOPo->op_first = kid;
6466 kid->op_sibling = sibl;
6469 kid->op_type = OP_PUSHRE;
6470 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6473 if (!kid->op_sibling)
6474 append_elem(OP_SPLIT, o, newDEFSVOP());
6476 kid = kid->op_sibling;
6479 if (!kid->op_sibling)
6480 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6482 kid = kid->op_sibling;
6485 if (kid->op_sibling)
6486 return too_many_arguments(o,PL_op_desc[o->op_type]);
6492 Perl_ck_join(pTHX_ OP *o)
6494 if (ckWARN(WARN_SYNTAX)) {
6495 OP *kid = cLISTOPo->op_first->op_sibling;
6496 if (kid && kid->op_type == OP_MATCH) {
6497 char *pmstr = "STRING";
6498 if (PM_GETRE(kPMOP))
6499 pmstr = PM_GETRE(kPMOP)->precomp;
6500 Perl_warner(aTHX_ WARN_SYNTAX,
6501 "/%s/ should probably be written as \"%s\"",
6509 Perl_ck_subr(pTHX_ OP *o)
6511 OP *prev = ((cUNOPo->op_first->op_sibling)
6512 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6513 OP *o2 = prev->op_sibling;
6522 o->op_private |= OPpENTERSUB_HASTARG;
6523 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6524 if (cvop->op_type == OP_RV2CV) {
6526 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6527 op_null(cvop); /* disable rv2cv */
6528 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6529 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6530 GV *gv = cGVOPx_gv(tmpop);
6533 tmpop->op_private |= OPpEARLY_CV;
6534 else if (SvPOK(cv)) {
6535 namegv = CvANON(cv) ? gv : CvGV(cv);
6536 proto = SvPV((SV*)cv, n_a);
6540 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6541 if (o2->op_type == OP_CONST)
6542 o2->op_private &= ~OPpCONST_STRICT;
6543 else if (o2->op_type == OP_LIST) {
6544 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6545 if (o && o->op_type == OP_CONST)
6546 o->op_private &= ~OPpCONST_STRICT;
6549 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6550 if (PERLDB_SUB && PL_curstash != PL_debstash)
6551 o->op_private |= OPpENTERSUB_DB;
6552 while (o2 != cvop) {
6556 return too_many_arguments(o, gv_ename(namegv));
6574 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6576 arg == 1 ? "block or sub {}" : "sub {}",
6577 gv_ename(namegv), o2);
6580 /* '*' allows any scalar type, including bareword */
6583 if (o2->op_type == OP_RV2GV)
6584 goto wrapref; /* autoconvert GLOB -> GLOBref */
6585 else if (o2->op_type == OP_CONST)
6586 o2->op_private &= ~OPpCONST_STRICT;
6587 else if (o2->op_type == OP_ENTERSUB) {
6588 /* accidental subroutine, revert to bareword */
6589 OP *gvop = ((UNOP*)o2)->op_first;
6590 if (gvop && gvop->op_type == OP_NULL) {
6591 gvop = ((UNOP*)gvop)->op_first;
6593 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6596 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6597 (gvop = ((UNOP*)gvop)->op_first) &&
6598 gvop->op_type == OP_GV)
6600 GV *gv = cGVOPx_gv(gvop);
6601 OP *sibling = o2->op_sibling;
6602 SV *n = newSVpvn("",0);
6604 gv_fullname3(n, gv, "");
6605 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6606 sv_chop(n, SvPVX(n)+6);
6607 o2 = newSVOP(OP_CONST, 0, n);
6608 prev->op_sibling = o2;
6609 o2->op_sibling = sibling;
6621 if (o2->op_type != OP_RV2GV)
6622 bad_type(arg, "symbol", gv_ename(namegv), o2);
6625 if (o2->op_type != OP_ENTERSUB)
6626 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6629 if (o2->op_type != OP_RV2SV
6630 && o2->op_type != OP_PADSV
6631 && o2->op_type != OP_HELEM
6632 && o2->op_type != OP_AELEM
6633 && o2->op_type != OP_THREADSV)
6635 bad_type(arg, "scalar", gv_ename(namegv), o2);
6639 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6640 bad_type(arg, "array", gv_ename(namegv), o2);
6643 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6644 bad_type(arg, "hash", gv_ename(namegv), o2);
6648 OP* sib = kid->op_sibling;
6649 kid->op_sibling = 0;
6650 o2 = newUNOP(OP_REFGEN, 0, kid);
6651 o2->op_sibling = sib;
6652 prev->op_sibling = o2;
6663 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6664 gv_ename(namegv), SvPV((SV*)cv, n_a));
6669 mod(o2, OP_ENTERSUB);
6671 o2 = o2->op_sibling;
6673 if (proto && !optional &&
6674 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6675 return too_few_arguments(o, gv_ename(namegv));
6680 Perl_ck_svconst(pTHX_ OP *o)
6682 SvREADONLY_on(cSVOPo->op_sv);
6687 Perl_ck_trunc(pTHX_ OP *o)
6689 if (o->op_flags & OPf_KIDS) {
6690 SVOP *kid = (SVOP*)cUNOPo->op_first;
6692 if (kid->op_type == OP_NULL)
6693 kid = (SVOP*)kid->op_sibling;
6694 if (kid && kid->op_type == OP_CONST &&
6695 (kid->op_private & OPpCONST_BARE))
6697 o->op_flags |= OPf_SPECIAL;
6698 kid->op_private &= ~OPpCONST_STRICT;
6705 Perl_ck_substr(pTHX_ OP *o)
6708 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6709 OP *kid = cLISTOPo->op_first;
6711 if (kid->op_type == OP_NULL)
6712 kid = kid->op_sibling;
6714 kid->op_flags |= OPf_MOD;
6720 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6723 Perl_peep(pTHX_ register OP *o)
6725 register OP* oldop = 0;
6728 if (!o || o->op_seq)
6732 SAVEVPTR(PL_curcop);
6733 for (; o; o = o->op_next) {
6739 switch (o->op_type) {
6743 PL_curcop = ((COP*)o); /* for warnings */
6744 o->op_seq = PL_op_seqmax++;
6748 if (cSVOPo->op_private & OPpCONST_STRICT)
6749 no_bareword_allowed(o);
6751 /* Relocate sv to the pad for thread safety.
6752 * Despite being a "constant", the SV is written to,
6753 * for reference counts, sv_upgrade() etc. */
6755 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6756 if (SvPADTMP(cSVOPo->op_sv)) {
6757 /* If op_sv is already a PADTMP then it is being used by
6758 * some pad, so make a copy. */
6759 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6760 SvREADONLY_on(PL_curpad[ix]);
6761 SvREFCNT_dec(cSVOPo->op_sv);
6764 SvREFCNT_dec(PL_curpad[ix]);
6765 SvPADTMP_on(cSVOPo->op_sv);
6766 PL_curpad[ix] = cSVOPo->op_sv;
6767 /* XXX I don't know how this isn't readonly already. */
6768 SvREADONLY_on(PL_curpad[ix]);
6770 cSVOPo->op_sv = Nullsv;
6774 o->op_seq = PL_op_seqmax++;
6778 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6779 if (o->op_next->op_private & OPpTARGET_MY) {
6780 if (o->op_flags & OPf_STACKED) /* chained concats */
6781 goto ignore_optimization;
6783 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6784 o->op_targ = o->op_next->op_targ;
6785 o->op_next->op_targ = 0;
6786 o->op_private |= OPpTARGET_MY;
6789 op_null(o->op_next);
6791 ignore_optimization:
6792 o->op_seq = PL_op_seqmax++;
6795 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6796 o->op_seq = PL_op_seqmax++;
6797 break; /* Scalar stub must produce undef. List stub is noop */
6801 if (o->op_targ == OP_NEXTSTATE
6802 || o->op_targ == OP_DBSTATE
6803 || o->op_targ == OP_SETSTATE)
6805 PL_curcop = ((COP*)o);
6807 /* XXX: We avoid setting op_seq here to prevent later calls
6808 to peep() from mistakenly concluding that optimisation
6809 has already occurred. This doesn't fix the real problem,
6810 though (See 20010220.007). AMS 20010719 */
6811 if (oldop && o->op_next) {
6812 oldop->op_next = o->op_next;
6820 if (oldop && o->op_next) {
6821 oldop->op_next = o->op_next;
6824 o->op_seq = PL_op_seqmax++;
6828 if (o->op_next->op_type == OP_RV2SV) {
6829 if (!(o->op_next->op_private & OPpDEREF)) {
6830 op_null(o->op_next);
6831 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6833 o->op_next = o->op_next->op_next;
6834 o->op_type = OP_GVSV;
6835 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6838 else if (o->op_next->op_type == OP_RV2AV) {
6839 OP* pop = o->op_next->op_next;
6841 if (pop->op_type == OP_CONST &&
6842 (PL_op = pop->op_next) &&
6843 pop->op_next->op_type == OP_AELEM &&
6844 !(pop->op_next->op_private &
6845 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6846 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6851 op_null(o->op_next);
6852 op_null(pop->op_next);
6854 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6855 o->op_next = pop->op_next->op_next;
6856 o->op_type = OP_AELEMFAST;
6857 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6858 o->op_private = (U8)i;
6863 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6865 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6866 /* XXX could check prototype here instead of just carping */
6867 SV *sv = sv_newmortal();
6868 gv_efullname3(sv, gv, Nullch);
6869 Perl_warner(aTHX_ WARN_PROTOTYPE,
6870 "%s() called too early to check prototype",
6875 o->op_seq = PL_op_seqmax++;
6886 o->op_seq = PL_op_seqmax++;
6887 while (cLOGOP->op_other->op_type == OP_NULL)
6888 cLOGOP->op_other = cLOGOP->op_other->op_next;
6889 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6894 o->op_seq = PL_op_seqmax++;
6895 while (cLOOP->op_redoop->op_type == OP_NULL)
6896 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6897 peep(cLOOP->op_redoop);
6898 while (cLOOP->op_nextop->op_type == OP_NULL)
6899 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6900 peep(cLOOP->op_nextop);
6901 while (cLOOP->op_lastop->op_type == OP_NULL)
6902 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6903 peep(cLOOP->op_lastop);
6909 o->op_seq = PL_op_seqmax++;
6910 while (cPMOP->op_pmreplstart &&
6911 cPMOP->op_pmreplstart->op_type == OP_NULL)
6912 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6913 peep(cPMOP->op_pmreplstart);
6917 o->op_seq = PL_op_seqmax++;
6918 if (ckWARN(WARN_SYNTAX) && o->op_next
6919 && o->op_next->op_type == OP_NEXTSTATE) {
6920 if (o->op_next->op_sibling &&
6921 o->op_next->op_sibling->op_type != OP_EXIT &&
6922 o->op_next->op_sibling->op_type != OP_WARN &&
6923 o->op_next->op_sibling->op_type != OP_DIE) {
6924 line_t oldline = CopLINE(PL_curcop);
6926 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6927 Perl_warner(aTHX_ WARN_EXEC,
6928 "Statement unlikely to be reached");
6929 Perl_warner(aTHX_ WARN_EXEC,
6930 "\t(Maybe you meant system() when you said exec()?)\n");
6931 CopLINE_set(PL_curcop, oldline);
6940 SV **svp, **indsvp, *sv;
6945 o->op_seq = PL_op_seqmax++;
6947 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6950 /* Make the CONST have a shared SV */
6951 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6952 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6953 key = SvPV(sv, keylen);
6954 lexname = newSVpvn_share(key,
6955 SvUTF8(sv) ? -(I32)keylen : keylen,
6961 if ((o->op_private & (OPpLVAL_INTRO)))
6964 rop = (UNOP*)((BINOP*)o)->op_first;
6965 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6967 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6968 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6970 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6971 if (!fields || !GvHV(*fields))
6973 key = SvPV(*svp, keylen);
6974 indsvp = hv_fetch(GvHV(*fields), key,
6975 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6977 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6978 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6980 ind = SvIV(*indsvp);
6982 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6983 rop->op_type = OP_RV2AV;
6984 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6985 o->op_type = OP_AELEM;
6986 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6988 if (SvREADONLY(*svp))
6990 SvFLAGS(sv) |= (SvFLAGS(*svp)
6991 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7001 SV **svp, **indsvp, *sv;
7005 SVOP *first_key_op, *key_op;
7007 o->op_seq = PL_op_seqmax++;
7008 if ((o->op_private & (OPpLVAL_INTRO))
7009 /* I bet there's always a pushmark... */
7010 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7011 /* hmmm, no optimization if list contains only one key. */
7013 rop = (UNOP*)((LISTOP*)o)->op_last;
7014 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7016 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7017 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7019 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7020 if (!fields || !GvHV(*fields))
7022 /* Again guessing that the pushmark can be jumped over.... */
7023 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7024 ->op_first->op_sibling;
7025 /* Check that the key list contains only constants. */
7026 for (key_op = first_key_op; key_op;
7027 key_op = (SVOP*)key_op->op_sibling)
7028 if (key_op->op_type != OP_CONST)
7032 rop->op_type = OP_RV2AV;
7033 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7034 o->op_type = OP_ASLICE;
7035 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7036 for (key_op = first_key_op; key_op;
7037 key_op = (SVOP*)key_op->op_sibling) {
7038 svp = cSVOPx_svp(key_op);
7039 key = SvPV(*svp, keylen);
7040 indsvp = hv_fetch(GvHV(*fields), key,
7041 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7043 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7044 "in variable %s of type %s",
7045 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7047 ind = SvIV(*indsvp);
7049 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7051 if (SvREADONLY(*svp))
7053 SvFLAGS(sv) |= (SvFLAGS(*svp)
7054 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7062 o->op_seq = PL_op_seqmax++;
7072 /* Efficient sub that returns a constant scalar value. */
7074 const_sv_xsub(pTHXo_ CV* cv)
7079 Perl_croak(aTHX_ "usage: %s::%s()",
7080 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7084 ST(0) = (SV*)XSANY.any_ptr;