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)
2214 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2216 char *s = PL_bufptr;
2218 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2221 if (*s == ';' || *s == '=')
2222 Perl_warner(aTHX_ WARN_PARENTHESIS,
2223 "Parentheses missing around \"%s\" list",
2224 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2230 o = mod(o, OP_NULL); /* a bit kludgey */
2232 PL_in_my_stash = Nullhv;
2237 Perl_jmaybe(pTHX_ OP *o)
2239 if (o->op_type == OP_LIST) {
2242 o2 = newOP(OP_THREADSV, 0);
2243 o2->op_targ = find_threadsv(";");
2245 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2246 #endif /* USE_THREADS */
2247 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2253 Perl_fold_constants(pTHX_ register OP *o)
2256 I32 type = o->op_type;
2259 if (PL_opargs[type] & OA_RETSCALAR)
2261 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2262 o->op_targ = pad_alloc(type, SVs_PADTMP);
2264 /* integerize op, unless it happens to be C<-foo>.
2265 * XXX should pp_i_negate() do magic string negation instead? */
2266 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2267 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2268 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2270 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2273 if (!(PL_opargs[type] & OA_FOLDCONST))
2278 /* XXX might want a ck_negate() for this */
2279 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2291 /* XXX what about the numeric ops? */
2292 if (PL_hints & HINT_LOCALE)
2297 goto nope; /* Don't try to run w/ errors */
2299 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2300 if ((curop->op_type != OP_CONST ||
2301 (curop->op_private & OPpCONST_BARE)) &&
2302 curop->op_type != OP_LIST &&
2303 curop->op_type != OP_SCALAR &&
2304 curop->op_type != OP_NULL &&
2305 curop->op_type != OP_PUSHMARK)
2311 curop = LINKLIST(o);
2315 sv = *(PL_stack_sp--);
2316 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2317 pad_swipe(o->op_targ);
2318 else if (SvTEMP(sv)) { /* grab mortal temp? */
2319 (void)SvREFCNT_inc(sv);
2323 if (type == OP_RV2GV)
2324 return newGVOP(OP_GV, 0, (GV*)sv);
2326 /* try to smush double to int, but don't smush -2.0 to -2 */
2327 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2330 #ifdef PERL_PRESERVE_IVUV
2331 /* Only bother to attempt to fold to IV if
2332 most operators will benefit */
2336 return newSVOP(OP_CONST, 0, sv);
2340 if (!(PL_opargs[type] & OA_OTHERINT))
2343 if (!(PL_hints & HINT_INTEGER)) {
2344 if (type == OP_MODULO
2345 || type == OP_DIVIDE
2346 || !(o->op_flags & OPf_KIDS))
2351 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2352 if (curop->op_type == OP_CONST) {
2353 if (SvIOK(((SVOP*)curop)->op_sv))
2357 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2361 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2368 Perl_gen_constant_list(pTHX_ register OP *o)
2371 I32 oldtmps_floor = PL_tmps_floor;
2375 return o; /* Don't attempt to run with errors */
2377 PL_op = curop = LINKLIST(o);
2384 PL_tmps_floor = oldtmps_floor;
2386 o->op_type = OP_RV2AV;
2387 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2388 curop = ((UNOP*)o)->op_first;
2389 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2396 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2398 if (!o || o->op_type != OP_LIST)
2399 o = newLISTOP(OP_LIST, 0, o, Nullop);
2401 o->op_flags &= ~OPf_WANT;
2403 if (!(PL_opargs[type] & OA_MARK))
2404 op_null(cLISTOPo->op_first);
2407 o->op_ppaddr = PL_ppaddr[type];
2408 o->op_flags |= flags;
2410 o = CHECKOP(type, o);
2411 if (o->op_type != type)
2414 return fold_constants(o);
2417 /* List constructors */
2420 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2428 if (first->op_type != type
2429 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2431 return newLISTOP(type, 0, first, last);
2434 if (first->op_flags & OPf_KIDS)
2435 ((LISTOP*)first)->op_last->op_sibling = last;
2437 first->op_flags |= OPf_KIDS;
2438 ((LISTOP*)first)->op_first = last;
2440 ((LISTOP*)first)->op_last = last;
2445 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2453 if (first->op_type != type)
2454 return prepend_elem(type, (OP*)first, (OP*)last);
2456 if (last->op_type != type)
2457 return append_elem(type, (OP*)first, (OP*)last);
2459 first->op_last->op_sibling = last->op_first;
2460 first->op_last = last->op_last;
2461 first->op_flags |= (last->op_flags & OPf_KIDS);
2463 #ifdef PL_OP_SLAB_ALLOC
2471 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2479 if (last->op_type == type) {
2480 if (type == OP_LIST) { /* already a PUSHMARK there */
2481 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2482 ((LISTOP*)last)->op_first->op_sibling = first;
2483 if (!(first->op_flags & OPf_PARENS))
2484 last->op_flags &= ~OPf_PARENS;
2487 if (!(last->op_flags & OPf_KIDS)) {
2488 ((LISTOP*)last)->op_last = first;
2489 last->op_flags |= OPf_KIDS;
2491 first->op_sibling = ((LISTOP*)last)->op_first;
2492 ((LISTOP*)last)->op_first = first;
2494 last->op_flags |= OPf_KIDS;
2498 return newLISTOP(type, 0, first, last);
2504 Perl_newNULLLIST(pTHX)
2506 return newOP(OP_STUB, 0);
2510 Perl_force_list(pTHX_ OP *o)
2512 if (!o || o->op_type != OP_LIST)
2513 o = newLISTOP(OP_LIST, 0, o, Nullop);
2519 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2523 NewOp(1101, listop, 1, LISTOP);
2525 listop->op_type = type;
2526 listop->op_ppaddr = PL_ppaddr[type];
2529 listop->op_flags = flags;
2533 else if (!first && last)
2536 first->op_sibling = last;
2537 listop->op_first = first;
2538 listop->op_last = last;
2539 if (type == OP_LIST) {
2541 pushop = newOP(OP_PUSHMARK, 0);
2542 pushop->op_sibling = first;
2543 listop->op_first = pushop;
2544 listop->op_flags |= OPf_KIDS;
2546 listop->op_last = pushop;
2553 Perl_newOP(pTHX_ I32 type, I32 flags)
2556 NewOp(1101, o, 1, OP);
2558 o->op_ppaddr = PL_ppaddr[type];
2559 o->op_flags = flags;
2562 o->op_private = 0 + (flags >> 8);
2563 if (PL_opargs[type] & OA_RETSCALAR)
2565 if (PL_opargs[type] & OA_TARGET)
2566 o->op_targ = pad_alloc(type, SVs_PADTMP);
2567 return CHECKOP(type, o);
2571 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2576 first = newOP(OP_STUB, 0);
2577 if (PL_opargs[type] & OA_MARK)
2578 first = force_list(first);
2580 NewOp(1101, unop, 1, UNOP);
2581 unop->op_type = type;
2582 unop->op_ppaddr = PL_ppaddr[type];
2583 unop->op_first = first;
2584 unop->op_flags = flags | OPf_KIDS;
2585 unop->op_private = 1 | (flags >> 8);
2586 unop = (UNOP*) CHECKOP(type, unop);
2590 return fold_constants((OP *) unop);
2594 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2597 NewOp(1101, binop, 1, BINOP);
2600 first = newOP(OP_NULL, 0);
2602 binop->op_type = type;
2603 binop->op_ppaddr = PL_ppaddr[type];
2604 binop->op_first = first;
2605 binop->op_flags = flags | OPf_KIDS;
2608 binop->op_private = 1 | (flags >> 8);
2611 binop->op_private = 2 | (flags >> 8);
2612 first->op_sibling = last;
2615 binop = (BINOP*)CHECKOP(type, binop);
2616 if (binop->op_next || binop->op_type != type)
2619 binop->op_last = binop->op_first->op_sibling;
2621 return fold_constants((OP *)binop);
2625 uvcompare(const void *a, const void *b)
2627 if (*((UV *)a) < (*(UV *)b))
2629 if (*((UV *)a) > (*(UV *)b))
2631 if (*((UV *)a+1) < (*(UV *)b+1))
2633 if (*((UV *)a+1) > (*(UV *)b+1))
2639 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2641 SV *tstr = ((SVOP*)expr)->op_sv;
2642 SV *rstr = ((SVOP*)repl)->op_sv;
2645 U8 *t = (U8*)SvPV(tstr, tlen);
2646 U8 *r = (U8*)SvPV(rstr, rlen);
2653 register short *tbl;
2655 PL_hints |= HINT_BLOCK_SCOPE;
2656 complement = o->op_private & OPpTRANS_COMPLEMENT;
2657 del = o->op_private & OPpTRANS_DELETE;
2658 squash = o->op_private & OPpTRANS_SQUASH;
2661 o->op_private |= OPpTRANS_FROM_UTF;
2664 o->op_private |= OPpTRANS_TO_UTF;
2666 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2667 SV* listsv = newSVpvn("# comment\n",10);
2669 U8* tend = t + tlen;
2670 U8* rend = r + rlen;
2684 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2685 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2691 tsave = t = bytes_to_utf8(t, &len);
2694 if (!to_utf && rlen) {
2696 rsave = r = bytes_to_utf8(r, &len);
2700 /* There are several snags with this code on EBCDIC:
2701 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2702 2. scan_const() in toke.c has encoded chars in native encoding which makes
2703 ranges at least in EBCDIC 0..255 range the bottom odd.
2707 U8 tmpbuf[UTF8_MAXLEN+1];
2710 New(1109, cp, 2*tlen, UV);
2712 transv = newSVpvn("",0);
2714 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2716 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2718 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2722 cp[2*i+1] = cp[2*i];
2726 qsort(cp, i, 2*sizeof(UV), uvcompare);
2727 for (j = 0; j < i; j++) {
2729 diff = val - nextmin;
2731 t = uvuni_to_utf8(tmpbuf,nextmin);
2732 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2734 U8 range_mark = UTF_TO_NATIVE(0xff);
2735 t = uvuni_to_utf8(tmpbuf, val - 1);
2736 sv_catpvn(transv, (char *)&range_mark, 1);
2737 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2744 t = uvuni_to_utf8(tmpbuf,nextmin);
2745 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2747 U8 range_mark = UTF_TO_NATIVE(0xff);
2748 sv_catpvn(transv, (char *)&range_mark, 1);
2750 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2751 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2752 t = (U8*)SvPVX(transv);
2753 tlen = SvCUR(transv);
2757 else if (!rlen && !del) {
2758 r = t; rlen = tlen; rend = tend;
2761 if ((!rlen && !del) || t == r ||
2762 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2764 o->op_private |= OPpTRANS_IDENTICAL;
2768 while (t < tend || tfirst <= tlast) {
2769 /* see if we need more "t" chars */
2770 if (tfirst > tlast) {
2771 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2773 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2775 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2782 /* now see if we need more "r" chars */
2783 if (rfirst > rlast) {
2785 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2787 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2789 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2798 rfirst = rlast = 0xffffffff;
2802 /* now see which range will peter our first, if either. */
2803 tdiff = tlast - tfirst;
2804 rdiff = rlast - rfirst;
2811 if (rfirst == 0xffffffff) {
2812 diff = tdiff; /* oops, pretend rdiff is infinite */
2814 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2815 (long)tfirst, (long)tlast);
2817 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2821 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2822 (long)tfirst, (long)(tfirst + diff),
2825 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2826 (long)tfirst, (long)rfirst);
2828 if (rfirst + diff > max)
2829 max = rfirst + diff;
2831 grows = (tfirst < rfirst &&
2832 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2844 else if (max > 0xff)
2849 Safefree(cPVOPo->op_pv);
2850 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2851 SvREFCNT_dec(listsv);
2853 SvREFCNT_dec(transv);
2855 if (!del && havefinal && rlen)
2856 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2857 newSVuv((UV)final), 0);
2860 o->op_private |= OPpTRANS_GROWS;
2872 tbl = (short*)cPVOPo->op_pv;
2874 Zero(tbl, 256, short);
2875 for (i = 0; i < tlen; i++)
2877 for (i = 0, j = 0; i < 256; i++) {
2888 if (i < 128 && r[j] >= 128)
2898 o->op_private |= OPpTRANS_IDENTICAL;
2903 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2904 tbl[0x100] = rlen - j;
2905 for (i=0; i < rlen - j; i++)
2906 tbl[0x101+i] = r[j+i];
2910 if (!rlen && !del) {
2913 o->op_private |= OPpTRANS_IDENTICAL;
2915 for (i = 0; i < 256; i++)
2917 for (i = 0, j = 0; i < tlen; i++,j++) {
2920 if (tbl[t[i]] == -1)
2926 if (tbl[t[i]] == -1) {
2927 if (t[i] < 128 && r[j] >= 128)
2934 o->op_private |= OPpTRANS_GROWS;
2942 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2946 NewOp(1101, pmop, 1, PMOP);
2947 pmop->op_type = type;
2948 pmop->op_ppaddr = PL_ppaddr[type];
2949 pmop->op_flags = flags;
2950 pmop->op_private = 0 | (flags >> 8);
2952 if (PL_hints & HINT_RE_TAINT)
2953 pmop->op_pmpermflags |= PMf_RETAINT;
2954 if (PL_hints & HINT_LOCALE)
2955 pmop->op_pmpermflags |= PMf_LOCALE;
2956 pmop->op_pmflags = pmop->op_pmpermflags;
2960 SV* repointer = newSViv(0);
2961 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2962 pmop->op_pmoffset = av_len(PL_regex_padav);
2963 PL_regex_pad = AvARRAY(PL_regex_padav);
2967 /* link into pm list */
2968 if (type != OP_TRANS && PL_curstash) {
2969 pmop->op_pmnext = HvPMROOT(PL_curstash);
2970 HvPMROOT(PL_curstash) = pmop;
2971 PmopSTASH_set(pmop,PL_curstash);
2978 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2982 I32 repl_has_vars = 0;
2984 if (o->op_type == OP_TRANS)
2985 return pmtrans(o, expr, repl);
2987 PL_hints |= HINT_BLOCK_SCOPE;
2990 if (expr->op_type == OP_CONST) {
2992 SV *pat = ((SVOP*)expr)->op_sv;
2993 char *p = SvPV(pat, plen);
2994 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2995 sv_setpvn(pat, "\\s+", 3);
2996 p = SvPV(pat, plen);
2997 pm->op_pmflags |= PMf_SKIPWHITE;
2999 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
3000 pm->op_pmdynflags |= PMdf_UTF8;
3001 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3002 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3003 pm->op_pmflags |= PMf_WHITE;
3007 if (PL_hints & HINT_UTF8)
3008 pm->op_pmdynflags |= PMdf_UTF8;
3009 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3010 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3012 : OP_REGCMAYBE),0,expr);
3014 NewOp(1101, rcop, 1, LOGOP);
3015 rcop->op_type = OP_REGCOMP;
3016 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3017 rcop->op_first = scalar(expr);
3018 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3019 ? (OPf_SPECIAL | OPf_KIDS)
3021 rcop->op_private = 1;
3024 /* establish postfix order */
3025 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3027 rcop->op_next = expr;
3028 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3031 rcop->op_next = LINKLIST(expr);
3032 expr->op_next = (OP*)rcop;
3035 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3040 if (pm->op_pmflags & PMf_EVAL) {
3042 if (CopLINE(PL_curcop) < PL_multi_end)
3043 CopLINE_set(PL_curcop, PL_multi_end);
3046 else if (repl->op_type == OP_THREADSV
3047 && strchr("&`'123456789+",
3048 PL_threadsv_names[repl->op_targ]))
3052 #endif /* USE_THREADS */
3053 else if (repl->op_type == OP_CONST)
3057 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3058 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3060 if (curop->op_type == OP_THREADSV) {
3062 if (strchr("&`'123456789+", curop->op_private))
3066 if (curop->op_type == OP_GV) {
3067 GV *gv = cGVOPx_gv(curop);
3069 if (strchr("&`'123456789+", *GvENAME(gv)))
3072 #endif /* USE_THREADS */
3073 else if (curop->op_type == OP_RV2CV)
3075 else if (curop->op_type == OP_RV2SV ||
3076 curop->op_type == OP_RV2AV ||
3077 curop->op_type == OP_RV2HV ||
3078 curop->op_type == OP_RV2GV) {
3079 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3082 else if (curop->op_type == OP_PADSV ||
3083 curop->op_type == OP_PADAV ||
3084 curop->op_type == OP_PADHV ||
3085 curop->op_type == OP_PADANY) {
3088 else if (curop->op_type == OP_PUSHRE)
3089 ; /* Okay here, dangerous in newASSIGNOP */
3099 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3100 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3101 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3102 prepend_elem(o->op_type, scalar(repl), o);
3105 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3106 pm->op_pmflags |= PMf_MAYBE_CONST;
3107 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3109 NewOp(1101, rcop, 1, LOGOP);
3110 rcop->op_type = OP_SUBSTCONT;
3111 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3112 rcop->op_first = scalar(repl);
3113 rcop->op_flags |= OPf_KIDS;
3114 rcop->op_private = 1;
3117 /* establish postfix order */
3118 rcop->op_next = LINKLIST(repl);
3119 repl->op_next = (OP*)rcop;
3121 pm->op_pmreplroot = scalar((OP*)rcop);
3122 pm->op_pmreplstart = LINKLIST(rcop);
3131 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3134 NewOp(1101, svop, 1, SVOP);
3135 svop->op_type = type;
3136 svop->op_ppaddr = PL_ppaddr[type];
3138 svop->op_next = (OP*)svop;
3139 svop->op_flags = flags;
3140 if (PL_opargs[type] & OA_RETSCALAR)
3142 if (PL_opargs[type] & OA_TARGET)
3143 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3144 return CHECKOP(type, svop);
3148 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3151 NewOp(1101, padop, 1, PADOP);
3152 padop->op_type = type;
3153 padop->op_ppaddr = PL_ppaddr[type];
3154 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3155 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3156 PL_curpad[padop->op_padix] = sv;
3158 padop->op_next = (OP*)padop;
3159 padop->op_flags = flags;
3160 if (PL_opargs[type] & OA_RETSCALAR)
3162 if (PL_opargs[type] & OA_TARGET)
3163 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3164 return CHECKOP(type, padop);
3168 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3172 return newPADOP(type, flags, SvREFCNT_inc(gv));
3174 return newSVOP(type, flags, SvREFCNT_inc(gv));
3179 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3182 NewOp(1101, pvop, 1, PVOP);
3183 pvop->op_type = type;
3184 pvop->op_ppaddr = PL_ppaddr[type];
3186 pvop->op_next = (OP*)pvop;
3187 pvop->op_flags = flags;
3188 if (PL_opargs[type] & OA_RETSCALAR)
3190 if (PL_opargs[type] & OA_TARGET)
3191 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3192 return CHECKOP(type, pvop);
3196 Perl_package(pTHX_ OP *o)
3200 save_hptr(&PL_curstash);
3201 save_item(PL_curstname);
3206 name = SvPV(sv, len);
3207 PL_curstash = gv_stashpvn(name,len,TRUE);
3208 sv_setpvn(PL_curstname, name, len);
3212 deprecate("\"package\" with no arguments");
3213 sv_setpv(PL_curstname,"<none>");
3214 PL_curstash = Nullhv;
3216 PL_hints |= HINT_BLOCK_SCOPE;
3217 PL_copline = NOLINE;
3222 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3227 char *packname = Nullch;
3231 if (id->op_type != OP_CONST)
3232 Perl_croak(aTHX_ "Module name must be constant");
3236 if (version != Nullop) {
3237 SV *vesv = ((SVOP*)version)->op_sv;
3239 if (arg == Nullop && !SvNIOKp(vesv)) {
3246 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3247 Perl_croak(aTHX_ "Version number must be constant number");
3249 /* Make copy of id so we don't free it twice */
3250 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3252 /* Fake up a method call to VERSION */
3253 meth = newSVpvn("VERSION",7);
3254 sv_upgrade(meth, SVt_PVIV);
3255 (void)SvIOK_on(meth);
3256 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3257 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3258 append_elem(OP_LIST,
3259 prepend_elem(OP_LIST, pack, list(version)),
3260 newSVOP(OP_METHOD_NAMED, 0, meth)));
3264 /* Fake up an import/unimport */
3265 if (arg && arg->op_type == OP_STUB)
3266 imop = arg; /* no import on explicit () */
3267 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3268 imop = Nullop; /* use 5.0; */
3273 /* Make copy of id so we don't free it twice */
3274 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3276 /* Fake up a method call to import/unimport */
3277 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3278 sv_upgrade(meth, SVt_PVIV);
3279 (void)SvIOK_on(meth);
3280 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3281 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3282 append_elem(OP_LIST,
3283 prepend_elem(OP_LIST, pack, list(arg)),
3284 newSVOP(OP_METHOD_NAMED, 0, meth)));
3287 if (ckWARN(WARN_MISC) &&
3288 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3289 SvPOK(packsv = ((SVOP*)id)->op_sv))
3291 /* BEGIN will free the ops, so we need to make a copy */
3292 packlen = SvCUR(packsv);
3293 packname = savepvn(SvPVX(packsv), packlen);
3296 /* Fake up the BEGIN {}, which does its thing immediately. */
3298 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3301 append_elem(OP_LINESEQ,
3302 append_elem(OP_LINESEQ,
3303 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3304 newSTATEOP(0, Nullch, veop)),
3305 newSTATEOP(0, Nullch, imop) ));
3308 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3309 Perl_warner(aTHX_ WARN_MISC,
3310 "Package `%s' not found "
3311 "(did you use the incorrect case?)", packname);
3316 PL_hints |= HINT_BLOCK_SCOPE;
3317 PL_copline = NOLINE;
3322 =for apidoc load_module
3324 Loads the module whose name is pointed to by the string part of name.
3325 Note that the actual module name, not its filename, should be given.
3326 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3327 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3328 (or 0 for no flags). ver, if specified, provides version semantics
3329 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3330 arguments can be used to specify arguments to the module's import()
3331 method, similar to C<use Foo::Bar VERSION LIST>.
3336 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3339 va_start(args, ver);
3340 vload_module(flags, name, ver, &args);
3344 #ifdef PERL_IMPLICIT_CONTEXT
3346 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3350 va_start(args, ver);
3351 vload_module(flags, name, ver, &args);
3357 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3359 OP *modname, *veop, *imop;
3361 modname = newSVOP(OP_CONST, 0, name);
3362 modname->op_private |= OPpCONST_BARE;
3364 veop = newSVOP(OP_CONST, 0, ver);
3368 if (flags & PERL_LOADMOD_NOIMPORT) {
3369 imop = sawparens(newNULLLIST());
3371 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3372 imop = va_arg(*args, OP*);
3377 sv = va_arg(*args, SV*);
3379 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3380 sv = va_arg(*args, SV*);
3384 line_t ocopline = PL_copline;
3385 int oexpect = PL_expect;
3387 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3388 veop, modname, imop);
3389 PL_expect = oexpect;
3390 PL_copline = ocopline;
3395 Perl_dofile(pTHX_ OP *term)
3400 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3401 if (!(gv && GvIMPORTED_CV(gv)))
3402 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3404 if (gv && GvIMPORTED_CV(gv)) {
3405 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3406 append_elem(OP_LIST, term,
3407 scalar(newUNOP(OP_RV2CV, 0,
3412 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3418 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3420 return newBINOP(OP_LSLICE, flags,
3421 list(force_list(subscript)),
3422 list(force_list(listval)) );
3426 S_list_assignment(pTHX_ register OP *o)
3431 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3432 o = cUNOPo->op_first;
3434 if (o->op_type == OP_COND_EXPR) {
3435 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3436 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3441 yyerror("Assignment to both a list and a scalar");
3445 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3446 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3447 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3450 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3453 if (o->op_type == OP_RV2SV)
3460 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3465 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3466 return newLOGOP(optype, 0,
3467 mod(scalar(left), optype),
3468 newUNOP(OP_SASSIGN, 0, scalar(right)));
3471 return newBINOP(optype, OPf_STACKED,
3472 mod(scalar(left), optype), scalar(right));
3476 if (list_assignment(left)) {
3480 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3481 left = mod(left, OP_AASSIGN);
3489 curop = list(force_list(left));
3490 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3491 o->op_private = 0 | (flags >> 8);
3492 for (curop = ((LISTOP*)curop)->op_first;
3493 curop; curop = curop->op_sibling)
3495 if (curop->op_type == OP_RV2HV &&
3496 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3497 o->op_private |= OPpASSIGN_HASH;
3501 if (!(left->op_private & OPpLVAL_INTRO)) {
3504 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3505 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3506 if (curop->op_type == OP_GV) {
3507 GV *gv = cGVOPx_gv(curop);
3508 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3510 SvCUR(gv) = PL_generation;
3512 else if (curop->op_type == OP_PADSV ||
3513 curop->op_type == OP_PADAV ||
3514 curop->op_type == OP_PADHV ||
3515 curop->op_type == OP_PADANY) {
3516 SV **svp = AvARRAY(PL_comppad_name);
3517 SV *sv = svp[curop->op_targ];
3518 if (SvCUR(sv) == PL_generation)
3520 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3522 else if (curop->op_type == OP_RV2CV)
3524 else if (curop->op_type == OP_RV2SV ||
3525 curop->op_type == OP_RV2AV ||
3526 curop->op_type == OP_RV2HV ||
3527 curop->op_type == OP_RV2GV) {
3528 if (lastop->op_type != OP_GV) /* funny deref? */
3531 else if (curop->op_type == OP_PUSHRE) {
3532 if (((PMOP*)curop)->op_pmreplroot) {
3534 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3536 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3538 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3540 SvCUR(gv) = PL_generation;
3549 o->op_private |= OPpASSIGN_COMMON;
3551 if (right && right->op_type == OP_SPLIT) {
3553 if ((tmpop = ((LISTOP*)right)->op_first) &&
3554 tmpop->op_type == OP_PUSHRE)
3556 PMOP *pm = (PMOP*)tmpop;
3557 if (left->op_type == OP_RV2AV &&
3558 !(left->op_private & OPpLVAL_INTRO) &&
3559 !(o->op_private & OPpASSIGN_COMMON) )
3561 tmpop = ((UNOP*)left)->op_first;
3562 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3564 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3565 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3567 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3568 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3570 pm->op_pmflags |= PMf_ONCE;
3571 tmpop = cUNOPo->op_first; /* to list (nulled) */
3572 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3573 tmpop->op_sibling = Nullop; /* don't free split */
3574 right->op_next = tmpop->op_next; /* fix starting loc */
3575 op_free(o); /* blow off assign */
3576 right->op_flags &= ~OPf_WANT;
3577 /* "I don't know and I don't care." */
3582 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3583 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3585 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3587 sv_setiv(sv, PL_modcount+1);
3595 right = newOP(OP_UNDEF, 0);
3596 if (right->op_type == OP_READLINE) {
3597 right->op_flags |= OPf_STACKED;
3598 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3601 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3602 o = newBINOP(OP_SASSIGN, flags,
3603 scalar(right), mod(scalar(left), OP_SASSIGN) );
3615 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3617 U32 seq = intro_my();
3620 NewOp(1101, cop, 1, COP);
3621 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3622 cop->op_type = OP_DBSTATE;
3623 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3626 cop->op_type = OP_NEXTSTATE;
3627 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3629 cop->op_flags = flags;
3630 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3632 cop->op_private |= NATIVE_HINTS;
3634 PL_compiling.op_private = cop->op_private;
3635 cop->op_next = (OP*)cop;
3638 cop->cop_label = label;
3639 PL_hints |= HINT_BLOCK_SCOPE;
3642 cop->cop_arybase = PL_curcop->cop_arybase;
3643 if (specialWARN(PL_curcop->cop_warnings))
3644 cop->cop_warnings = PL_curcop->cop_warnings ;
3646 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3647 if (specialCopIO(PL_curcop->cop_io))
3648 cop->cop_io = PL_curcop->cop_io;
3650 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3653 if (PL_copline == NOLINE)
3654 CopLINE_set(cop, CopLINE(PL_curcop));
3656 CopLINE_set(cop, PL_copline);
3657 PL_copline = NOLINE;
3660 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3662 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3664 CopSTASH_set(cop, PL_curstash);
3666 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3667 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3668 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3669 (void)SvIOK_on(*svp);
3670 SvIVX(*svp) = PTR2IV(cop);
3674 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3677 /* "Introduce" my variables to visible status. */
3685 if (! PL_min_intro_pending)
3686 return PL_cop_seqmax;
3688 svp = AvARRAY(PL_comppad_name);
3689 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3690 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3691 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3692 SvNVX(sv) = (NV)PL_cop_seqmax;
3695 PL_min_intro_pending = 0;
3696 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3697 return PL_cop_seqmax++;
3701 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3703 return new_logop(type, flags, &first, &other);
3707 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3711 OP *first = *firstp;
3712 OP *other = *otherp;
3714 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3715 return newBINOP(type, flags, scalar(first), scalar(other));
3717 scalarboolean(first);
3718 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3719 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3720 if (type == OP_AND || type == OP_OR) {
3726 first = *firstp = cUNOPo->op_first;
3728 first->op_next = o->op_next;
3729 cUNOPo->op_first = Nullop;
3733 if (first->op_type == OP_CONST) {
3734 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3735 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3736 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3747 else if (first->op_type == OP_WANTARRAY) {
3753 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3754 OP *k1 = ((UNOP*)first)->op_first;
3755 OP *k2 = k1->op_sibling;
3757 switch (first->op_type)
3760 if (k2 && k2->op_type == OP_READLINE
3761 && (k2->op_flags & OPf_STACKED)
3762 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3764 warnop = k2->op_type;
3769 if (k1->op_type == OP_READDIR
3770 || k1->op_type == OP_GLOB
3771 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3772 || k1->op_type == OP_EACH)
3774 warnop = ((k1->op_type == OP_NULL)
3775 ? k1->op_targ : k1->op_type);
3780 line_t oldline = CopLINE(PL_curcop);
3781 CopLINE_set(PL_curcop, PL_copline);
3782 Perl_warner(aTHX_ WARN_MISC,
3783 "Value of %s%s can be \"0\"; test with defined()",
3785 ((warnop == OP_READLINE || warnop == OP_GLOB)
3786 ? " construct" : "() operator"));
3787 CopLINE_set(PL_curcop, oldline);
3794 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3795 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3797 NewOp(1101, logop, 1, LOGOP);
3799 logop->op_type = type;
3800 logop->op_ppaddr = PL_ppaddr[type];
3801 logop->op_first = first;
3802 logop->op_flags = flags | OPf_KIDS;
3803 logop->op_other = LINKLIST(other);
3804 logop->op_private = 1 | (flags >> 8);
3806 /* establish postfix order */
3807 logop->op_next = LINKLIST(first);
3808 first->op_next = (OP*)logop;
3809 first->op_sibling = other;
3811 o = newUNOP(OP_NULL, 0, (OP*)logop);
3818 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3825 return newLOGOP(OP_AND, 0, first, trueop);
3827 return newLOGOP(OP_OR, 0, first, falseop);
3829 scalarboolean(first);
3830 if (first->op_type == OP_CONST) {
3831 if (SvTRUE(((SVOP*)first)->op_sv)) {
3842 else if (first->op_type == OP_WANTARRAY) {
3846 NewOp(1101, logop, 1, LOGOP);
3847 logop->op_type = OP_COND_EXPR;
3848 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3849 logop->op_first = first;
3850 logop->op_flags = flags | OPf_KIDS;
3851 logop->op_private = 1 | (flags >> 8);
3852 logop->op_other = LINKLIST(trueop);
3853 logop->op_next = LINKLIST(falseop);
3856 /* establish postfix order */
3857 start = LINKLIST(first);
3858 first->op_next = (OP*)logop;
3860 first->op_sibling = trueop;
3861 trueop->op_sibling = falseop;
3862 o = newUNOP(OP_NULL, 0, (OP*)logop);
3864 trueop->op_next = falseop->op_next = o;
3871 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3879 NewOp(1101, range, 1, LOGOP);
3881 range->op_type = OP_RANGE;
3882 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3883 range->op_first = left;
3884 range->op_flags = OPf_KIDS;
3885 leftstart = LINKLIST(left);
3886 range->op_other = LINKLIST(right);
3887 range->op_private = 1 | (flags >> 8);
3889 left->op_sibling = right;
3891 range->op_next = (OP*)range;
3892 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3893 flop = newUNOP(OP_FLOP, 0, flip);
3894 o = newUNOP(OP_NULL, 0, flop);
3896 range->op_next = leftstart;
3898 left->op_next = flip;
3899 right->op_next = flop;
3901 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3902 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3903 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3904 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3906 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3907 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3910 if (!flip->op_private || !flop->op_private)
3911 linklist(o); /* blow off optimizer unless constant */
3917 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3921 int once = block && block->op_flags & OPf_SPECIAL &&
3922 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3925 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3926 return block; /* do {} while 0 does once */
3927 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3928 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3929 expr = newUNOP(OP_DEFINED, 0,
3930 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3931 } else if (expr->op_flags & OPf_KIDS) {
3932 OP *k1 = ((UNOP*)expr)->op_first;
3933 OP *k2 = (k1) ? k1->op_sibling : NULL;
3934 switch (expr->op_type) {
3936 if (k2 && k2->op_type == OP_READLINE
3937 && (k2->op_flags & OPf_STACKED)
3938 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3939 expr = newUNOP(OP_DEFINED, 0, expr);
3943 if (k1->op_type == OP_READDIR
3944 || k1->op_type == OP_GLOB
3945 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3946 || k1->op_type == OP_EACH)
3947 expr = newUNOP(OP_DEFINED, 0, expr);
3953 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3954 o = new_logop(OP_AND, 0, &expr, &listop);
3957 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3959 if (once && o != listop)
3960 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3963 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3965 o->op_flags |= flags;
3967 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3972 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3980 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3981 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3982 expr = newUNOP(OP_DEFINED, 0,
3983 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3984 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3985 OP *k1 = ((UNOP*)expr)->op_first;
3986 OP *k2 = (k1) ? k1->op_sibling : NULL;
3987 switch (expr->op_type) {
3989 if (k2 && k2->op_type == OP_READLINE
3990 && (k2->op_flags & OPf_STACKED)
3991 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3992 expr = newUNOP(OP_DEFINED, 0, expr);
3996 if (k1->op_type == OP_READDIR
3997 || k1->op_type == OP_GLOB
3998 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3999 || k1->op_type == OP_EACH)
4000 expr = newUNOP(OP_DEFINED, 0, expr);
4006 block = newOP(OP_NULL, 0);
4008 block = scope(block);
4012 next = LINKLIST(cont);
4015 OP *unstack = newOP(OP_UNSTACK, 0);
4018 cont = append_elem(OP_LINESEQ, cont, unstack);
4019 if ((line_t)whileline != NOLINE) {
4020 PL_copline = whileline;
4021 cont = append_elem(OP_LINESEQ, cont,
4022 newSTATEOP(0, Nullch, Nullop));
4026 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4027 redo = LINKLIST(listop);
4030 PL_copline = whileline;
4032 o = new_logop(OP_AND, 0, &expr, &listop);
4033 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4034 op_free(expr); /* oops, it's a while (0) */
4036 return Nullop; /* listop already freed by new_logop */
4039 ((LISTOP*)listop)->op_last->op_next =
4040 (o == listop ? redo : LINKLIST(o));
4046 NewOp(1101,loop,1,LOOP);
4047 loop->op_type = OP_ENTERLOOP;
4048 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4049 loop->op_private = 0;
4050 loop->op_next = (OP*)loop;
4053 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4055 loop->op_redoop = redo;
4056 loop->op_lastop = o;
4057 o->op_private |= loopflags;
4060 loop->op_nextop = next;
4062 loop->op_nextop = o;
4064 o->op_flags |= flags;
4065 o->op_private |= (flags >> 8);
4070 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4078 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4079 sv->op_type = OP_RV2GV;
4080 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4082 else if (sv->op_type == OP_PADSV) { /* private variable */
4083 padoff = sv->op_targ;
4088 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4089 padoff = sv->op_targ;
4091 iterflags |= OPf_SPECIAL;
4096 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4100 padoff = find_threadsv("_");
4101 iterflags |= OPf_SPECIAL;
4103 sv = newGVOP(OP_GV, 0, PL_defgv);
4106 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4107 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4108 iterflags |= OPf_STACKED;
4110 else if (expr->op_type == OP_NULL &&
4111 (expr->op_flags & OPf_KIDS) &&
4112 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4114 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4115 * set the STACKED flag to indicate that these values are to be
4116 * treated as min/max values by 'pp_iterinit'.
4118 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4119 LOGOP* range = (LOGOP*) flip->op_first;
4120 OP* left = range->op_first;
4121 OP* right = left->op_sibling;
4124 range->op_flags &= ~OPf_KIDS;
4125 range->op_first = Nullop;
4127 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4128 listop->op_first->op_next = range->op_next;
4129 left->op_next = range->op_other;
4130 right->op_next = (OP*)listop;
4131 listop->op_next = listop->op_first;
4134 expr = (OP*)(listop);
4136 iterflags |= OPf_STACKED;
4139 expr = mod(force_list(expr), OP_GREPSTART);
4143 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4144 append_elem(OP_LIST, expr, scalar(sv))));
4145 assert(!loop->op_next);
4146 #ifdef PL_OP_SLAB_ALLOC
4149 NewOp(1234,tmp,1,LOOP);
4150 Copy(loop,tmp,1,LOOP);
4154 Renew(loop, 1, LOOP);
4156 loop->op_targ = padoff;
4157 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4158 PL_copline = forline;
4159 return newSTATEOP(0, label, wop);
4163 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4168 if (type != OP_GOTO || label->op_type == OP_CONST) {
4169 /* "last()" means "last" */
4170 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4171 o = newOP(type, OPf_SPECIAL);
4173 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4174 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4180 if (label->op_type == OP_ENTERSUB)
4181 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4182 o = newUNOP(type, OPf_STACKED, label);
4184 PL_hints |= HINT_BLOCK_SCOPE;
4189 Perl_cv_undef(pTHX_ CV *cv)
4193 MUTEX_DESTROY(CvMUTEXP(cv));
4194 Safefree(CvMUTEXP(cv));
4197 #endif /* USE_THREADS */
4200 if (CvFILE(cv) && !CvXSUB(cv)) {
4201 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4202 Safefree(CvFILE(cv));
4207 if (!CvXSUB(cv) && CvROOT(cv)) {
4209 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4210 Perl_croak(aTHX_ "Can't undef active subroutine");
4213 Perl_croak(aTHX_ "Can't undef active subroutine");
4214 #endif /* USE_THREADS */
4217 SAVEVPTR(PL_curpad);
4220 op_free(CvROOT(cv));
4221 CvROOT(cv) = Nullop;
4224 SvPOK_off((SV*)cv); /* forget prototype */
4226 /* Since closure prototypes have the same lifetime as the containing
4227 * CV, they don't hold a refcount on the outside CV. This avoids
4228 * the refcount loop between the outer CV (which keeps a refcount to
4229 * the closure prototype in the pad entry for pp_anoncode()) and the
4230 * closure prototype, and the ensuing memory leak. This does not
4231 * apply to closures generated within eval"", since eval"" CVs are
4232 * ephemeral. --GSAR */
4233 if (!CvANON(cv) || CvCLONED(cv)
4234 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4235 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4237 SvREFCNT_dec(CvOUTSIDE(cv));
4239 CvOUTSIDE(cv) = Nullcv;
4241 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4244 if (CvPADLIST(cv)) {
4245 /* may be during global destruction */
4246 if (SvREFCNT(CvPADLIST(cv))) {
4247 I32 i = AvFILLp(CvPADLIST(cv));
4249 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4250 SV* sv = svp ? *svp : Nullsv;
4253 if (sv == (SV*)PL_comppad_name)
4254 PL_comppad_name = Nullav;
4255 else if (sv == (SV*)PL_comppad) {
4256 PL_comppad = Nullav;
4257 PL_curpad = Null(SV**);
4261 SvREFCNT_dec((SV*)CvPADLIST(cv));
4263 CvPADLIST(cv) = Nullav;
4271 #ifdef DEBUG_CLOSURES
4273 S_cv_dump(pTHX_ CV *cv)
4276 CV *outside = CvOUTSIDE(cv);
4277 AV* padlist = CvPADLIST(cv);
4284 PerlIO_printf(Perl_debug_log,
4285 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4287 (CvANON(cv) ? "ANON"
4288 : (cv == PL_main_cv) ? "MAIN"
4289 : CvUNIQUE(cv) ? "UNIQUE"
4290 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4293 : CvANON(outside) ? "ANON"
4294 : (outside == PL_main_cv) ? "MAIN"
4295 : CvUNIQUE(outside) ? "UNIQUE"
4296 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4301 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4302 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4303 pname = AvARRAY(pad_name);
4304 ppad = AvARRAY(pad);
4306 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4307 if (SvPOK(pname[ix]))
4308 PerlIO_printf(Perl_debug_log,
4309 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4310 (int)ix, PTR2UV(ppad[ix]),
4311 SvFAKE(pname[ix]) ? "FAKE " : "",
4313 (IV)I_32(SvNVX(pname[ix])),
4316 #endif /* DEBUGGING */
4318 #endif /* DEBUG_CLOSURES */
4321 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4325 AV* protopadlist = CvPADLIST(proto);
4326 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4327 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4328 SV** pname = AvARRAY(protopad_name);
4329 SV** ppad = AvARRAY(protopad);
4330 I32 fname = AvFILLp(protopad_name);
4331 I32 fpad = AvFILLp(protopad);
4335 assert(!CvUNIQUE(proto));
4339 SAVESPTR(PL_comppad_name);
4340 SAVESPTR(PL_compcv);
4342 cv = PL_compcv = (CV*)NEWSV(1104,0);
4343 sv_upgrade((SV *)cv, SvTYPE(proto));
4344 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4348 New(666, CvMUTEXP(cv), 1, perl_mutex);
4349 MUTEX_INIT(CvMUTEXP(cv));
4351 #endif /* USE_THREADS */
4353 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4354 : savepv(CvFILE(proto));
4356 CvFILE(cv) = CvFILE(proto);
4358 CvGV(cv) = CvGV(proto);
4359 CvSTASH(cv) = CvSTASH(proto);
4360 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4361 CvSTART(cv) = CvSTART(proto);
4363 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4366 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4368 PL_comppad_name = newAV();
4369 for (ix = fname; ix >= 0; ix--)
4370 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4372 PL_comppad = newAV();
4374 comppadlist = newAV();
4375 AvREAL_off(comppadlist);
4376 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4377 av_store(comppadlist, 1, (SV*)PL_comppad);
4378 CvPADLIST(cv) = comppadlist;
4379 av_fill(PL_comppad, AvFILLp(protopad));
4380 PL_curpad = AvARRAY(PL_comppad);
4382 av = newAV(); /* will be @_ */
4384 av_store(PL_comppad, 0, (SV*)av);
4385 AvFLAGS(av) = AVf_REIFY;
4387 for (ix = fpad; ix > 0; ix--) {
4388 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4389 if (namesv && namesv != &PL_sv_undef) {
4390 char *name = SvPVX(namesv); /* XXX */
4391 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4392 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4393 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4395 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4397 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4399 else { /* our own lexical */
4402 /* anon code -- we'll come back for it */
4403 sv = SvREFCNT_inc(ppad[ix]);
4405 else if (*name == '@')
4407 else if (*name == '%')
4416 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4417 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4420 SV* sv = NEWSV(0,0);
4426 /* Now that vars are all in place, clone nested closures. */
4428 for (ix = fpad; ix > 0; ix--) {
4429 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4431 && namesv != &PL_sv_undef
4432 && !(SvFLAGS(namesv) & SVf_FAKE)
4433 && *SvPVX(namesv) == '&'
4434 && CvCLONE(ppad[ix]))
4436 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4437 SvREFCNT_dec(ppad[ix]);
4440 PL_curpad[ix] = (SV*)kid;
4444 #ifdef DEBUG_CLOSURES
4445 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4447 PerlIO_printf(Perl_debug_log, " from:\n");
4449 PerlIO_printf(Perl_debug_log, " to:\n");
4456 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4458 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4460 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4467 Perl_cv_clone(pTHX_ CV *proto)
4470 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4471 cv = cv_clone2(proto, CvOUTSIDE(proto));
4472 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4477 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4479 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4480 SV* msg = sv_newmortal();
4484 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4485 sv_setpv(msg, "Prototype mismatch:");
4487 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4489 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4490 sv_catpv(msg, " vs ");
4492 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4494 sv_catpv(msg, "none");
4495 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4499 static void const_sv_xsub(pTHXo_ CV* cv);
4502 =for apidoc cv_const_sv
4504 If C<cv> is a constant sub eligible for inlining. returns the constant
4505 value returned by the sub. Otherwise, returns NULL.
4507 Constant subs can be created with C<newCONSTSUB> or as described in
4508 L<perlsub/"Constant Functions">.
4513 Perl_cv_const_sv(pTHX_ CV *cv)
4515 if (!cv || !CvCONST(cv))
4517 return (SV*)CvXSUBANY(cv).any_ptr;
4521 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4528 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4529 o = cLISTOPo->op_first->op_sibling;
4531 for (; o; o = o->op_next) {
4532 OPCODE type = o->op_type;
4534 if (sv && o->op_next == o)
4536 if (o->op_next != o) {
4537 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4539 if (type == OP_DBSTATE)
4542 if (type == OP_LEAVESUB || type == OP_RETURN)
4546 if (type == OP_CONST && cSVOPo->op_sv)
4548 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4549 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4550 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4554 /* We get here only from cv_clone2() while creating a closure.
4555 Copy the const value here instead of in cv_clone2 so that
4556 SvREADONLY_on doesn't lead to problems when leaving
4561 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4573 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4583 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4587 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4589 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4593 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4599 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4604 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4605 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4606 SV *sv = sv_newmortal();
4607 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4608 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4613 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4614 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4624 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4625 maximum a prototype before. */
4626 if (SvTYPE(gv) > SVt_NULL) {
4627 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4628 && ckWARN_d(WARN_PROTOTYPE))
4630 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4632 cv_ckproto((CV*)gv, NULL, ps);
4635 sv_setpv((SV*)gv, ps);
4637 sv_setiv((SV*)gv, -1);
4638 SvREFCNT_dec(PL_compcv);
4639 cv = PL_compcv = NULL;
4640 PL_sub_generation++;
4644 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4646 #ifdef GV_UNIQUE_CHECK
4647 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4648 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4652 if (!block || !ps || *ps || attrs)
4655 const_sv = op_const_sv(block, Nullcv);
4658 bool exists = CvROOT(cv) || CvXSUB(cv);
4660 #ifdef GV_UNIQUE_CHECK
4661 if (exists && GvUNIQUE(gv)) {
4662 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4666 /* if the subroutine doesn't exist and wasn't pre-declared
4667 * with a prototype, assume it will be AUTOLOADed,
4668 * skipping the prototype check
4670 if (exists || SvPOK(cv))
4671 cv_ckproto(cv, gv, ps);
4672 /* already defined (or promised)? */
4673 if (exists || GvASSUMECV(gv)) {
4674 if (!block && !attrs) {
4675 /* just a "sub foo;" when &foo is already defined */
4676 SAVEFREESV(PL_compcv);
4679 /* ahem, death to those who redefine active sort subs */
4680 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4681 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4683 if (ckWARN(WARN_REDEFINE)
4685 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4687 line_t oldline = CopLINE(PL_curcop);
4688 CopLINE_set(PL_curcop, PL_copline);
4689 Perl_warner(aTHX_ WARN_REDEFINE,
4690 CvCONST(cv) ? "Constant subroutine %s redefined"
4691 : "Subroutine %s redefined", name);
4692 CopLINE_set(PL_curcop, oldline);
4700 SvREFCNT_inc(const_sv);
4702 assert(!CvROOT(cv) && !CvCONST(cv));
4703 sv_setpv((SV*)cv, ""); /* prototype is "" */
4704 CvXSUBANY(cv).any_ptr = const_sv;
4705 CvXSUB(cv) = const_sv_xsub;
4710 cv = newCONSTSUB(NULL, name, const_sv);
4713 SvREFCNT_dec(PL_compcv);
4715 PL_sub_generation++;
4722 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4723 * before we clobber PL_compcv.
4727 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4728 stash = GvSTASH(CvGV(cv));
4729 else if (CvSTASH(cv))
4730 stash = CvSTASH(cv);
4732 stash = PL_curstash;
4735 /* possibly about to re-define existing subr -- ignore old cv */
4736 rcv = (SV*)PL_compcv;
4737 if (name && GvSTASH(gv))
4738 stash = GvSTASH(gv);
4740 stash = PL_curstash;
4742 apply_attrs(stash, rcv, attrs);
4744 if (cv) { /* must reuse cv if autoloaded */
4746 /* got here with just attrs -- work done, so bug out */
4747 SAVEFREESV(PL_compcv);
4751 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4752 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4753 CvOUTSIDE(PL_compcv) = 0;
4754 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4755 CvPADLIST(PL_compcv) = 0;
4756 /* inner references to PL_compcv must be fixed up ... */
4758 AV *padlist = CvPADLIST(cv);
4759 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4760 AV *comppad = (AV*)AvARRAY(padlist)[1];
4761 SV **namepad = AvARRAY(comppad_name);
4762 SV **curpad = AvARRAY(comppad);
4763 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4764 SV *namesv = namepad[ix];
4765 if (namesv && namesv != &PL_sv_undef
4766 && *SvPVX(namesv) == '&')
4768 CV *innercv = (CV*)curpad[ix];
4769 if (CvOUTSIDE(innercv) == PL_compcv) {
4770 CvOUTSIDE(innercv) = cv;
4771 if (!CvANON(innercv) || CvCLONED(innercv)) {
4772 (void)SvREFCNT_inc(cv);
4773 SvREFCNT_dec(PL_compcv);
4779 /* ... before we throw it away */
4780 SvREFCNT_dec(PL_compcv);
4781 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4782 ++PL_sub_generation;
4789 PL_sub_generation++;
4793 CvFILE_set_from_cop(cv, PL_curcop);
4794 CvSTASH(cv) = PL_curstash;
4797 if (!CvMUTEXP(cv)) {
4798 New(666, CvMUTEXP(cv), 1, perl_mutex);
4799 MUTEX_INIT(CvMUTEXP(cv));
4801 #endif /* USE_THREADS */
4804 sv_setpv((SV*)cv, ps);
4806 if (PL_error_count) {
4810 char *s = strrchr(name, ':');
4812 if (strEQ(s, "BEGIN")) {
4814 "BEGIN not safe after errors--compilation aborted";
4815 if (PL_in_eval & EVAL_KEEPERR)
4816 Perl_croak(aTHX_ not_safe);
4818 /* force display of errors found but not reported */
4819 sv_catpv(ERRSV, not_safe);
4820 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4828 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4829 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4832 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4833 mod(scalarseq(block), OP_LEAVESUBLV));
4836 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4838 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4839 OpREFCNT_set(CvROOT(cv), 1);
4840 CvSTART(cv) = LINKLIST(CvROOT(cv));
4841 CvROOT(cv)->op_next = 0;
4842 CALL_PEEP(CvSTART(cv));
4844 /* now that optimizer has done its work, adjust pad values */
4846 SV **namep = AvARRAY(PL_comppad_name);
4847 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4850 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4853 * The only things that a clonable function needs in its
4854 * pad are references to outer lexicals and anonymous subs.
4855 * The rest are created anew during cloning.
4857 if (!((namesv = namep[ix]) != Nullsv &&
4858 namesv != &PL_sv_undef &&
4860 *SvPVX(namesv) == '&')))
4862 SvREFCNT_dec(PL_curpad[ix]);
4863 PL_curpad[ix] = Nullsv;
4866 assert(!CvCONST(cv));
4867 if (ps && !*ps && op_const_sv(block, cv))
4871 AV *av = newAV(); /* Will be @_ */
4873 av_store(PL_comppad, 0, (SV*)av);
4874 AvFLAGS(av) = AVf_REIFY;
4876 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4877 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4879 if (!SvPADMY(PL_curpad[ix]))
4880 SvPADTMP_on(PL_curpad[ix]);
4884 /* If a potential closure prototype, don't keep a refcount on
4885 * outer CV, unless the latter happens to be a passing eval"".
4886 * This is okay as the lifetime of the prototype is tied to the
4887 * lifetime of the outer CV. Avoids memory leak due to reference
4889 if (!name && CvOUTSIDE(cv)
4890 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4891 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4893 SvREFCNT_dec(CvOUTSIDE(cv));
4896 if (name || aname) {
4898 char *tname = (name ? name : aname);
4900 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4901 SV *sv = NEWSV(0,0);
4902 SV *tmpstr = sv_newmortal();
4903 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4907 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4909 (long)PL_subline, (long)CopLINE(PL_curcop));
4910 gv_efullname3(tmpstr, gv, Nullch);
4911 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4912 hv = GvHVn(db_postponed);
4913 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4914 && (pcv = GvCV(db_postponed)))
4920 call_sv((SV*)pcv, G_DISCARD);
4924 if ((s = strrchr(tname,':')))
4929 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4932 if (strEQ(s, "BEGIN")) {
4933 I32 oldscope = PL_scopestack_ix;
4935 SAVECOPFILE(&PL_compiling);
4936 SAVECOPLINE(&PL_compiling);
4938 sv_setsv(PL_rs, PL_nrs);
4941 PL_beginav = newAV();
4942 DEBUG_x( dump_sub(gv) );
4943 av_push(PL_beginav, (SV*)cv);
4944 GvCV(gv) = 0; /* cv has been hijacked */
4945 call_list(oldscope, PL_beginav);
4947 PL_curcop = &PL_compiling;
4948 PL_compiling.op_private = PL_hints;
4951 else if (strEQ(s, "END") && !PL_error_count) {
4954 DEBUG_x( dump_sub(gv) );
4955 av_unshift(PL_endav, 1);
4956 av_store(PL_endav, 0, (SV*)cv);
4957 GvCV(gv) = 0; /* cv has been hijacked */
4959 else if (strEQ(s, "CHECK") && !PL_error_count) {
4961 PL_checkav = newAV();
4962 DEBUG_x( dump_sub(gv) );
4963 if (PL_main_start && ckWARN(WARN_VOID))
4964 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4965 av_unshift(PL_checkav, 1);
4966 av_store(PL_checkav, 0, (SV*)cv);
4967 GvCV(gv) = 0; /* cv has been hijacked */
4969 else if (strEQ(s, "INIT") && !PL_error_count) {
4971 PL_initav = newAV();
4972 DEBUG_x( dump_sub(gv) );
4973 if (PL_main_start && ckWARN(WARN_VOID))
4974 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4975 av_push(PL_initav, (SV*)cv);
4976 GvCV(gv) = 0; /* cv has been hijacked */
4981 PL_copline = NOLINE;
4986 /* XXX unsafe for threads if eval_owner isn't held */
4988 =for apidoc newCONSTSUB
4990 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4991 eligible for inlining at compile-time.
4997 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5003 SAVECOPLINE(PL_curcop);
5004 CopLINE_set(PL_curcop, PL_copline);
5007 PL_hints &= ~HINT_BLOCK_SCOPE;
5010 SAVESPTR(PL_curstash);
5011 SAVECOPSTASH(PL_curcop);
5012 PL_curstash = stash;
5014 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5016 CopSTASH(PL_curcop) = stash;
5020 cv = newXS(name, const_sv_xsub, __FILE__);
5021 CvXSUBANY(cv).any_ptr = sv;
5023 sv_setpv((SV*)cv, ""); /* prototype is "" */
5031 =for apidoc U||newXS
5033 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5039 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5041 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5044 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5046 /* just a cached method */
5050 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5051 /* already defined (or promised) */
5052 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5053 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5054 line_t oldline = CopLINE(PL_curcop);
5055 if (PL_copline != NOLINE)
5056 CopLINE_set(PL_curcop, PL_copline);
5057 Perl_warner(aTHX_ WARN_REDEFINE,
5058 CvCONST(cv) ? "Constant subroutine %s redefined"
5059 : "Subroutine %s redefined"
5061 CopLINE_set(PL_curcop, oldline);
5068 if (cv) /* must reuse cv if autoloaded */
5071 cv = (CV*)NEWSV(1105,0);
5072 sv_upgrade((SV *)cv, SVt_PVCV);
5076 PL_sub_generation++;
5081 New(666, CvMUTEXP(cv), 1, perl_mutex);
5082 MUTEX_INIT(CvMUTEXP(cv));
5084 #endif /* USE_THREADS */
5085 (void)gv_fetchfile(filename);
5086 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5087 an external constant string */
5088 CvXSUB(cv) = subaddr;
5091 char *s = strrchr(name,':');
5097 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5100 if (strEQ(s, "BEGIN")) {
5102 PL_beginav = newAV();
5103 av_push(PL_beginav, (SV*)cv);
5104 GvCV(gv) = 0; /* cv has been hijacked */
5106 else if (strEQ(s, "END")) {
5109 av_unshift(PL_endav, 1);
5110 av_store(PL_endav, 0, (SV*)cv);
5111 GvCV(gv) = 0; /* cv has been hijacked */
5113 else if (strEQ(s, "CHECK")) {
5115 PL_checkav = newAV();
5116 if (PL_main_start && ckWARN(WARN_VOID))
5117 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5118 av_unshift(PL_checkav, 1);
5119 av_store(PL_checkav, 0, (SV*)cv);
5120 GvCV(gv) = 0; /* cv has been hijacked */
5122 else if (strEQ(s, "INIT")) {
5124 PL_initav = newAV();
5125 if (PL_main_start && ckWARN(WARN_VOID))
5126 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5127 av_push(PL_initav, (SV*)cv);
5128 GvCV(gv) = 0; /* cv has been hijacked */
5139 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5148 name = SvPVx(cSVOPo->op_sv, n_a);
5151 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5152 #ifdef GV_UNIQUE_CHECK
5154 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5158 if ((cv = GvFORM(gv))) {
5159 if (ckWARN(WARN_REDEFINE)) {
5160 line_t oldline = CopLINE(PL_curcop);
5162 CopLINE_set(PL_curcop, PL_copline);
5163 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5164 CopLINE_set(PL_curcop, oldline);
5171 CvFILE_set_from_cop(cv, PL_curcop);
5173 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5174 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5175 SvPADTMP_on(PL_curpad[ix]);
5178 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5179 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5180 OpREFCNT_set(CvROOT(cv), 1);
5181 CvSTART(cv) = LINKLIST(CvROOT(cv));
5182 CvROOT(cv)->op_next = 0;
5183 CALL_PEEP(CvSTART(cv));
5185 PL_copline = NOLINE;
5190 Perl_newANONLIST(pTHX_ OP *o)
5192 return newUNOP(OP_REFGEN, 0,
5193 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5197 Perl_newANONHASH(pTHX_ OP *o)
5199 return newUNOP(OP_REFGEN, 0,
5200 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5204 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5206 return newANONATTRSUB(floor, proto, Nullop, block);
5210 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5212 return newUNOP(OP_REFGEN, 0,
5213 newSVOP(OP_ANONCODE, 0,
5214 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5218 Perl_oopsAV(pTHX_ OP *o)
5220 switch (o->op_type) {
5222 o->op_type = OP_PADAV;
5223 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5224 return ref(o, OP_RV2AV);
5227 o->op_type = OP_RV2AV;
5228 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5233 if (ckWARN_d(WARN_INTERNAL))
5234 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5241 Perl_oopsHV(pTHX_ OP *o)
5243 switch (o->op_type) {
5246 o->op_type = OP_PADHV;
5247 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5248 return ref(o, OP_RV2HV);
5252 o->op_type = OP_RV2HV;
5253 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5258 if (ckWARN_d(WARN_INTERNAL))
5259 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5266 Perl_newAVREF(pTHX_ OP *o)
5268 if (o->op_type == OP_PADANY) {
5269 o->op_type = OP_PADAV;
5270 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5273 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5274 && ckWARN(WARN_DEPRECATED)) {
5275 Perl_warner(aTHX_ WARN_DEPRECATED,
5276 "Using an array as a reference is deprecated");
5278 return newUNOP(OP_RV2AV, 0, scalar(o));
5282 Perl_newGVREF(pTHX_ I32 type, OP *o)
5284 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5285 return newUNOP(OP_NULL, 0, o);
5286 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5290 Perl_newHVREF(pTHX_ OP *o)
5292 if (o->op_type == OP_PADANY) {
5293 o->op_type = OP_PADHV;
5294 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5297 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5298 && ckWARN(WARN_DEPRECATED)) {
5299 Perl_warner(aTHX_ WARN_DEPRECATED,
5300 "Using a hash as a reference is deprecated");
5302 return newUNOP(OP_RV2HV, 0, scalar(o));
5306 Perl_oopsCV(pTHX_ OP *o)
5308 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5314 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5316 return newUNOP(OP_RV2CV, flags, scalar(o));
5320 Perl_newSVREF(pTHX_ OP *o)
5322 if (o->op_type == OP_PADANY) {
5323 o->op_type = OP_PADSV;
5324 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5327 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5328 o->op_flags |= OPpDONE_SVREF;
5331 return newUNOP(OP_RV2SV, 0, scalar(o));
5334 /* Check routines. */
5337 Perl_ck_anoncode(pTHX_ OP *o)
5342 name = NEWSV(1106,0);
5343 sv_upgrade(name, SVt_PVNV);
5344 sv_setpvn(name, "&", 1);
5347 ix = pad_alloc(o->op_type, SVs_PADMY);
5348 av_store(PL_comppad_name, ix, name);
5349 av_store(PL_comppad, ix, cSVOPo->op_sv);
5350 SvPADMY_on(cSVOPo->op_sv);
5351 cSVOPo->op_sv = Nullsv;
5352 cSVOPo->op_targ = ix;
5357 Perl_ck_bitop(pTHX_ OP *o)
5359 o->op_private = PL_hints;
5364 Perl_ck_concat(pTHX_ OP *o)
5366 if (cUNOPo->op_first->op_type == OP_CONCAT)
5367 o->op_flags |= OPf_STACKED;
5372 Perl_ck_spair(pTHX_ OP *o)
5374 if (o->op_flags & OPf_KIDS) {
5377 OPCODE type = o->op_type;
5378 o = modkids(ck_fun(o), type);
5379 kid = cUNOPo->op_first;
5380 newop = kUNOP->op_first->op_sibling;
5382 (newop->op_sibling ||
5383 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5384 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5385 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5389 op_free(kUNOP->op_first);
5390 kUNOP->op_first = newop;
5392 o->op_ppaddr = PL_ppaddr[++o->op_type];
5397 Perl_ck_delete(pTHX_ OP *o)
5401 if (o->op_flags & OPf_KIDS) {
5402 OP *kid = cUNOPo->op_first;
5403 switch (kid->op_type) {
5405 o->op_flags |= OPf_SPECIAL;
5408 o->op_private |= OPpSLICE;
5411 o->op_flags |= OPf_SPECIAL;
5416 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5417 PL_op_desc[o->op_type]);
5425 Perl_ck_eof(pTHX_ OP *o)
5427 I32 type = o->op_type;
5429 if (o->op_flags & OPf_KIDS) {
5430 if (cLISTOPo->op_first->op_type == OP_STUB) {
5432 o = newUNOP(type, OPf_SPECIAL,
5433 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5441 Perl_ck_eval(pTHX_ OP *o)
5443 PL_hints |= HINT_BLOCK_SCOPE;
5444 if (o->op_flags & OPf_KIDS) {
5445 SVOP *kid = (SVOP*)cUNOPo->op_first;
5448 o->op_flags &= ~OPf_KIDS;
5451 else if (kid->op_type == OP_LINESEQ) {
5454 kid->op_next = o->op_next;
5455 cUNOPo->op_first = 0;
5458 NewOp(1101, enter, 1, LOGOP);
5459 enter->op_type = OP_ENTERTRY;
5460 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5461 enter->op_private = 0;
5463 /* establish postfix order */
5464 enter->op_next = (OP*)enter;
5466 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5467 o->op_type = OP_LEAVETRY;
5468 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5469 enter->op_other = o;
5477 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5479 o->op_targ = (PADOFFSET)PL_hints;
5484 Perl_ck_exit(pTHX_ OP *o)
5487 HV *table = GvHV(PL_hintgv);
5489 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5490 if (svp && *svp && SvTRUE(*svp))
5491 o->op_private |= OPpEXIT_VMSISH;
5498 Perl_ck_exec(pTHX_ OP *o)
5501 if (o->op_flags & OPf_STACKED) {
5503 kid = cUNOPo->op_first->op_sibling;
5504 if (kid->op_type == OP_RV2GV)
5513 Perl_ck_exists(pTHX_ OP *o)
5516 if (o->op_flags & OPf_KIDS) {
5517 OP *kid = cUNOPo->op_first;
5518 if (kid->op_type == OP_ENTERSUB) {
5519 (void) ref(kid, o->op_type);
5520 if (kid->op_type != OP_RV2CV && !PL_error_count)
5521 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5522 PL_op_desc[o->op_type]);
5523 o->op_private |= OPpEXISTS_SUB;
5525 else if (kid->op_type == OP_AELEM)
5526 o->op_flags |= OPf_SPECIAL;
5527 else if (kid->op_type != OP_HELEM)
5528 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5529 PL_op_desc[o->op_type]);
5537 Perl_ck_gvconst(pTHX_ register OP *o)
5539 o = fold_constants(o);
5540 if (o->op_type == OP_CONST)
5547 Perl_ck_rvconst(pTHX_ register OP *o)
5549 SVOP *kid = (SVOP*)cUNOPo->op_first;
5551 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5552 if (kid->op_type == OP_CONST) {
5556 SV *kidsv = kid->op_sv;
5559 /* Is it a constant from cv_const_sv()? */
5560 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5561 SV *rsv = SvRV(kidsv);
5562 int svtype = SvTYPE(rsv);
5563 char *badtype = Nullch;
5565 switch (o->op_type) {
5567 if (svtype > SVt_PVMG)
5568 badtype = "a SCALAR";
5571 if (svtype != SVt_PVAV)
5572 badtype = "an ARRAY";
5575 if (svtype != SVt_PVHV) {
5576 if (svtype == SVt_PVAV) { /* pseudohash? */
5577 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5578 if (ksv && SvROK(*ksv)
5579 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5588 if (svtype != SVt_PVCV)
5593 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5596 name = SvPV(kidsv, n_a);
5597 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5598 char *badthing = Nullch;
5599 switch (o->op_type) {
5601 badthing = "a SCALAR";
5604 badthing = "an ARRAY";
5607 badthing = "a HASH";
5612 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5616 * This is a little tricky. We only want to add the symbol if we
5617 * didn't add it in the lexer. Otherwise we get duplicate strict
5618 * warnings. But if we didn't add it in the lexer, we must at
5619 * least pretend like we wanted to add it even if it existed before,
5620 * or we get possible typo warnings. OPpCONST_ENTERED says
5621 * whether the lexer already added THIS instance of this symbol.
5623 iscv = (o->op_type == OP_RV2CV) * 2;
5625 gv = gv_fetchpv(name,
5626 iscv | !(kid->op_private & OPpCONST_ENTERED),
5629 : o->op_type == OP_RV2SV
5631 : o->op_type == OP_RV2AV
5633 : o->op_type == OP_RV2HV
5636 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5638 kid->op_type = OP_GV;
5639 SvREFCNT_dec(kid->op_sv);
5641 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5642 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5643 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5645 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5647 kid->op_sv = SvREFCNT_inc(gv);
5649 kid->op_private = 0;
5650 kid->op_ppaddr = PL_ppaddr[OP_GV];
5657 Perl_ck_ftst(pTHX_ OP *o)
5659 I32 type = o->op_type;
5661 if (o->op_flags & OPf_REF) {
5664 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5665 SVOP *kid = (SVOP*)cUNOPo->op_first;
5667 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5669 OP *newop = newGVOP(type, OPf_REF,
5670 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5677 if (type == OP_FTTTY)
5678 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5681 o = newUNOP(type, 0, newDEFSVOP());
5687 Perl_ck_fun(pTHX_ OP *o)
5693 int type = o->op_type;
5694 register I32 oa = PL_opargs[type] >> OASHIFT;
5696 if (o->op_flags & OPf_STACKED) {
5697 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5700 return no_fh_allowed(o);
5703 if (o->op_flags & OPf_KIDS) {
5705 tokid = &cLISTOPo->op_first;
5706 kid = cLISTOPo->op_first;
5707 if (kid->op_type == OP_PUSHMARK ||
5708 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5710 tokid = &kid->op_sibling;
5711 kid = kid->op_sibling;
5713 if (!kid && PL_opargs[type] & OA_DEFGV)
5714 *tokid = kid = newDEFSVOP();
5718 sibl = kid->op_sibling;
5721 /* list seen where single (scalar) arg expected? */
5722 if (numargs == 1 && !(oa >> 4)
5723 && kid->op_type == OP_LIST && type != OP_SCALAR)
5725 return too_many_arguments(o,PL_op_desc[type]);
5738 if ((type == OP_PUSH || type == OP_UNSHIFT)
5739 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5740 Perl_warner(aTHX_ WARN_SYNTAX,
5741 "Useless use of %s with no values",
5744 if (kid->op_type == OP_CONST &&
5745 (kid->op_private & OPpCONST_BARE))
5747 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5748 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5749 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5750 if (ckWARN(WARN_DEPRECATED))
5751 Perl_warner(aTHX_ WARN_DEPRECATED,
5752 "Array @%s missing the @ in argument %"IVdf" of %s()",
5753 name, (IV)numargs, PL_op_desc[type]);
5756 kid->op_sibling = sibl;
5759 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5760 bad_type(numargs, "array", PL_op_desc[type], kid);
5764 if (kid->op_type == OP_CONST &&
5765 (kid->op_private & OPpCONST_BARE))
5767 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5768 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5769 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5770 if (ckWARN(WARN_DEPRECATED))
5771 Perl_warner(aTHX_ WARN_DEPRECATED,
5772 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5773 name, (IV)numargs, PL_op_desc[type]);
5776 kid->op_sibling = sibl;
5779 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5780 bad_type(numargs, "hash", PL_op_desc[type], kid);
5785 OP *newop = newUNOP(OP_NULL, 0, kid);
5786 kid->op_sibling = 0;
5788 newop->op_next = newop;
5790 kid->op_sibling = sibl;
5795 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5796 if (kid->op_type == OP_CONST &&
5797 (kid->op_private & OPpCONST_BARE))
5799 OP *newop = newGVOP(OP_GV, 0,
5800 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5805 else if (kid->op_type == OP_READLINE) {
5806 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5807 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5810 I32 flags = OPf_SPECIAL;
5814 /* is this op a FH constructor? */
5815 if (is_handle_constructor(o,numargs)) {
5816 char *name = Nullch;
5820 /* Set a flag to tell rv2gv to vivify
5821 * need to "prove" flag does not mean something
5822 * else already - NI-S 1999/05/07
5825 if (kid->op_type == OP_PADSV) {
5826 SV **namep = av_fetch(PL_comppad_name,
5828 if (namep && *namep)
5829 name = SvPV(*namep, len);
5831 else if (kid->op_type == OP_RV2SV
5832 && kUNOP->op_first->op_type == OP_GV)
5834 GV *gv = cGVOPx_gv(kUNOP->op_first);
5836 len = GvNAMELEN(gv);
5838 else if (kid->op_type == OP_AELEM
5839 || kid->op_type == OP_HELEM)
5841 name = "__ANONIO__";
5847 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5848 namesv = PL_curpad[targ];
5849 (void)SvUPGRADE(namesv, SVt_PV);
5851 sv_setpvn(namesv, "$", 1);
5852 sv_catpvn(namesv, name, len);
5855 kid->op_sibling = 0;
5856 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5857 kid->op_targ = targ;
5858 kid->op_private |= priv;
5860 kid->op_sibling = sibl;
5866 mod(scalar(kid), type);
5870 tokid = &kid->op_sibling;
5871 kid = kid->op_sibling;
5873 o->op_private |= numargs;
5875 return too_many_arguments(o,PL_op_desc[o->op_type]);
5878 else if (PL_opargs[type] & OA_DEFGV) {
5880 return newUNOP(type, 0, newDEFSVOP());
5884 while (oa & OA_OPTIONAL)
5886 if (oa && oa != OA_LIST)
5887 return too_few_arguments(o,PL_op_desc[o->op_type]);
5893 Perl_ck_glob(pTHX_ OP *o)
5898 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5899 append_elem(OP_GLOB, o, newDEFSVOP());
5901 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5902 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5904 #if !defined(PERL_EXTERNAL_GLOB)
5905 /* XXX this can be tightened up and made more failsafe. */
5909 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5911 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5912 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5913 GvCV(gv) = GvCV(glob_gv);
5914 SvREFCNT_inc((SV*)GvCV(gv));
5915 GvIMPORTED_CV_on(gv);
5918 #endif /* PERL_EXTERNAL_GLOB */
5920 if (gv && GvIMPORTED_CV(gv)) {
5921 append_elem(OP_GLOB, o,
5922 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5923 o->op_type = OP_LIST;
5924 o->op_ppaddr = PL_ppaddr[OP_LIST];
5925 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5926 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5927 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5928 append_elem(OP_LIST, o,
5929 scalar(newUNOP(OP_RV2CV, 0,
5930 newGVOP(OP_GV, 0, gv)))));
5931 o = newUNOP(OP_NULL, 0, ck_subr(o));
5932 o->op_targ = OP_GLOB; /* hint at what it used to be */
5935 gv = newGVgen("main");
5937 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5943 Perl_ck_grep(pTHX_ OP *o)
5947 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5949 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5950 NewOp(1101, gwop, 1, LOGOP);
5952 if (o->op_flags & OPf_STACKED) {
5955 kid = cLISTOPo->op_first->op_sibling;
5956 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5959 kid->op_next = (OP*)gwop;
5960 o->op_flags &= ~OPf_STACKED;
5962 kid = cLISTOPo->op_first->op_sibling;
5963 if (type == OP_MAPWHILE)
5970 kid = cLISTOPo->op_first->op_sibling;
5971 if (kid->op_type != OP_NULL)
5972 Perl_croak(aTHX_ "panic: ck_grep");
5973 kid = kUNOP->op_first;
5975 gwop->op_type = type;
5976 gwop->op_ppaddr = PL_ppaddr[type];
5977 gwop->op_first = listkids(o);
5978 gwop->op_flags |= OPf_KIDS;
5979 gwop->op_private = 1;
5980 gwop->op_other = LINKLIST(kid);
5981 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5982 kid->op_next = (OP*)gwop;
5984 kid = cLISTOPo->op_first->op_sibling;
5985 if (!kid || !kid->op_sibling)
5986 return too_few_arguments(o,PL_op_desc[o->op_type]);
5987 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5988 mod(kid, OP_GREPSTART);
5994 Perl_ck_index(pTHX_ OP *o)
5996 if (o->op_flags & OPf_KIDS) {
5997 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5999 kid = kid->op_sibling; /* get past "big" */
6000 if (kid && kid->op_type == OP_CONST)
6001 fbm_compile(((SVOP*)kid)->op_sv, 0);
6007 Perl_ck_lengthconst(pTHX_ OP *o)
6009 /* XXX length optimization goes here */
6014 Perl_ck_lfun(pTHX_ OP *o)
6016 OPCODE type = o->op_type;
6017 return modkids(ck_fun(o), type);
6021 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6023 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6024 switch (cUNOPo->op_first->op_type) {
6026 /* This is needed for
6027 if (defined %stash::)
6028 to work. Do not break Tk.
6030 break; /* Globals via GV can be undef */
6032 case OP_AASSIGN: /* Is this a good idea? */
6033 Perl_warner(aTHX_ WARN_DEPRECATED,
6034 "defined(@array) is deprecated");
6035 Perl_warner(aTHX_ WARN_DEPRECATED,
6036 "\t(Maybe you should just omit the defined()?)\n");
6039 /* This is needed for
6040 if (defined %stash::)
6041 to work. Do not break Tk.
6043 break; /* Globals via GV can be undef */
6045 Perl_warner(aTHX_ WARN_DEPRECATED,
6046 "defined(%%hash) is deprecated");
6047 Perl_warner(aTHX_ WARN_DEPRECATED,
6048 "\t(Maybe you should just omit the defined()?)\n");
6059 Perl_ck_rfun(pTHX_ OP *o)
6061 OPCODE type = o->op_type;
6062 return refkids(ck_fun(o), type);
6066 Perl_ck_listiob(pTHX_ OP *o)
6070 kid = cLISTOPo->op_first;
6073 kid = cLISTOPo->op_first;
6075 if (kid->op_type == OP_PUSHMARK)
6076 kid = kid->op_sibling;
6077 if (kid && o->op_flags & OPf_STACKED)
6078 kid = kid->op_sibling;
6079 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6080 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6081 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6082 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6083 cLISTOPo->op_first->op_sibling = kid;
6084 cLISTOPo->op_last = kid;
6085 kid = kid->op_sibling;
6090 append_elem(o->op_type, o, newDEFSVOP());
6096 Perl_ck_sassign(pTHX_ OP *o)
6098 OP *kid = cLISTOPo->op_first;
6099 /* has a disposable target? */
6100 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6101 && !(kid->op_flags & OPf_STACKED)
6102 /* Cannot steal the second time! */
6103 && !(kid->op_private & OPpTARGET_MY))
6105 OP *kkid = kid->op_sibling;
6107 /* Can just relocate the target. */
6108 if (kkid && kkid->op_type == OP_PADSV
6109 && !(kkid->op_private & OPpLVAL_INTRO))
6111 kid->op_targ = kkid->op_targ;
6113 /* Now we do not need PADSV and SASSIGN. */
6114 kid->op_sibling = o->op_sibling; /* NULL */
6115 cLISTOPo->op_first = NULL;
6118 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6126 Perl_ck_match(pTHX_ OP *o)
6128 o->op_private |= OPpRUNTIME;
6133 Perl_ck_method(pTHX_ OP *o)
6135 OP *kid = cUNOPo->op_first;
6136 if (kid->op_type == OP_CONST) {
6137 SV* sv = kSVOP->op_sv;
6138 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6140 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6141 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6144 kSVOP->op_sv = Nullsv;
6146 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6155 Perl_ck_null(pTHX_ OP *o)
6161 Perl_ck_open(pTHX_ OP *o)
6163 HV *table = GvHV(PL_hintgv);
6167 svp = hv_fetch(table, "open_IN", 7, FALSE);
6169 mode = mode_from_discipline(*svp);
6170 if (mode & O_BINARY)
6171 o->op_private |= OPpOPEN_IN_RAW;
6172 else if (mode & O_TEXT)
6173 o->op_private |= OPpOPEN_IN_CRLF;
6176 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6178 mode = mode_from_discipline(*svp);
6179 if (mode & O_BINARY)
6180 o->op_private |= OPpOPEN_OUT_RAW;
6181 else if (mode & O_TEXT)
6182 o->op_private |= OPpOPEN_OUT_CRLF;
6185 if (o->op_type == OP_BACKTICK)
6191 Perl_ck_repeat(pTHX_ OP *o)
6193 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6194 o->op_private |= OPpREPEAT_DOLIST;
6195 cBINOPo->op_first = force_list(cBINOPo->op_first);
6203 Perl_ck_require(pTHX_ OP *o)
6207 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6208 SVOP *kid = (SVOP*)cUNOPo->op_first;
6210 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6212 for (s = SvPVX(kid->op_sv); *s; s++) {
6213 if (*s == ':' && s[1] == ':') {
6215 Move(s+2, s+1, strlen(s+2)+1, char);
6216 --SvCUR(kid->op_sv);
6219 if (SvREADONLY(kid->op_sv)) {
6220 SvREADONLY_off(kid->op_sv);
6221 sv_catpvn(kid->op_sv, ".pm", 3);
6222 SvREADONLY_on(kid->op_sv);
6225 sv_catpvn(kid->op_sv, ".pm", 3);
6229 /* handle override, if any */
6230 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6231 if (!(gv && GvIMPORTED_CV(gv)))
6232 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6234 if (gv && GvIMPORTED_CV(gv)) {
6235 OP *kid = cUNOPo->op_first;
6236 cUNOPo->op_first = 0;
6238 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6239 append_elem(OP_LIST, kid,
6240 scalar(newUNOP(OP_RV2CV, 0,
6249 Perl_ck_return(pTHX_ OP *o)
6252 if (CvLVALUE(PL_compcv)) {
6253 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6254 mod(kid, OP_LEAVESUBLV);
6261 Perl_ck_retarget(pTHX_ OP *o)
6263 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6270 Perl_ck_select(pTHX_ OP *o)
6273 if (o->op_flags & OPf_KIDS) {
6274 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6275 if (kid && kid->op_sibling) {
6276 o->op_type = OP_SSELECT;
6277 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6279 return fold_constants(o);
6283 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6284 if (kid && kid->op_type == OP_RV2GV)
6285 kid->op_private &= ~HINT_STRICT_REFS;
6290 Perl_ck_shift(pTHX_ OP *o)
6292 I32 type = o->op_type;
6294 if (!(o->op_flags & OPf_KIDS)) {
6299 if (!CvUNIQUE(PL_compcv)) {
6300 argop = newOP(OP_PADAV, OPf_REF);
6301 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6304 argop = newUNOP(OP_RV2AV, 0,
6305 scalar(newGVOP(OP_GV, 0,
6306 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6309 argop = newUNOP(OP_RV2AV, 0,
6310 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6311 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6312 #endif /* USE_THREADS */
6313 return newUNOP(type, 0, scalar(argop));
6315 return scalar(modkids(ck_fun(o), type));
6319 Perl_ck_sort(pTHX_ OP *o)
6323 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6325 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6326 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6328 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6330 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6332 if (kid->op_type == OP_SCOPE) {
6336 else if (kid->op_type == OP_LEAVE) {
6337 if (o->op_type == OP_SORT) {
6338 op_null(kid); /* wipe out leave */
6341 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6342 if (k->op_next == kid)
6344 /* don't descend into loops */
6345 else if (k->op_type == OP_ENTERLOOP
6346 || k->op_type == OP_ENTERITER)
6348 k = cLOOPx(k)->op_lastop;
6353 kid->op_next = 0; /* just disconnect the leave */
6354 k = kLISTOP->op_first;
6359 if (o->op_type == OP_SORT) {
6360 /* provide scalar context for comparison function/block */
6366 o->op_flags |= OPf_SPECIAL;
6368 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6371 firstkid = firstkid->op_sibling;
6374 /* provide list context for arguments */
6375 if (o->op_type == OP_SORT)
6382 S_simplify_sort(pTHX_ OP *o)
6384 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6388 if (!(o->op_flags & OPf_STACKED))
6390 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6391 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6392 kid = kUNOP->op_first; /* get past null */
6393 if (kid->op_type != OP_SCOPE)
6395 kid = kLISTOP->op_last; /* get past scope */
6396 switch(kid->op_type) {
6404 k = kid; /* remember this node*/
6405 if (kBINOP->op_first->op_type != OP_RV2SV)
6407 kid = kBINOP->op_first; /* get past cmp */
6408 if (kUNOP->op_first->op_type != OP_GV)
6410 kid = kUNOP->op_first; /* get past rv2sv */
6412 if (GvSTASH(gv) != PL_curstash)
6414 if (strEQ(GvNAME(gv), "a"))
6416 else if (strEQ(GvNAME(gv), "b"))
6420 kid = k; /* back to cmp */
6421 if (kBINOP->op_last->op_type != OP_RV2SV)
6423 kid = kBINOP->op_last; /* down to 2nd arg */
6424 if (kUNOP->op_first->op_type != OP_GV)
6426 kid = kUNOP->op_first; /* get past rv2sv */
6428 if (GvSTASH(gv) != PL_curstash
6430 ? strNE(GvNAME(gv), "a")
6431 : strNE(GvNAME(gv), "b")))
6433 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6435 o->op_private |= OPpSORT_REVERSE;
6436 if (k->op_type == OP_NCMP)
6437 o->op_private |= OPpSORT_NUMERIC;
6438 if (k->op_type == OP_I_NCMP)
6439 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6440 kid = cLISTOPo->op_first->op_sibling;
6441 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6442 op_free(kid); /* then delete it */
6446 Perl_ck_split(pTHX_ OP *o)
6450 if (o->op_flags & OPf_STACKED)
6451 return no_fh_allowed(o);
6453 kid = cLISTOPo->op_first;
6454 if (kid->op_type != OP_NULL)
6455 Perl_croak(aTHX_ "panic: ck_split");
6456 kid = kid->op_sibling;
6457 op_free(cLISTOPo->op_first);
6458 cLISTOPo->op_first = kid;
6460 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6461 cLISTOPo->op_last = kid; /* There was only one element previously */
6464 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6465 OP *sibl = kid->op_sibling;
6466 kid->op_sibling = 0;
6467 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6468 if (cLISTOPo->op_first == cLISTOPo->op_last)
6469 cLISTOPo->op_last = kid;
6470 cLISTOPo->op_first = kid;
6471 kid->op_sibling = sibl;
6474 kid->op_type = OP_PUSHRE;
6475 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6478 if (!kid->op_sibling)
6479 append_elem(OP_SPLIT, o, newDEFSVOP());
6481 kid = kid->op_sibling;
6484 if (!kid->op_sibling)
6485 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6487 kid = kid->op_sibling;
6490 if (kid->op_sibling)
6491 return too_many_arguments(o,PL_op_desc[o->op_type]);
6497 Perl_ck_join(pTHX_ OP *o)
6499 if (ckWARN(WARN_SYNTAX)) {
6500 OP *kid = cLISTOPo->op_first->op_sibling;
6501 if (kid && kid->op_type == OP_MATCH) {
6502 char *pmstr = "STRING";
6503 if (PM_GETRE(kPMOP))
6504 pmstr = PM_GETRE(kPMOP)->precomp;
6505 Perl_warner(aTHX_ WARN_SYNTAX,
6506 "/%s/ should probably be written as \"%s\"",
6514 Perl_ck_subr(pTHX_ OP *o)
6516 OP *prev = ((cUNOPo->op_first->op_sibling)
6517 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6518 OP *o2 = prev->op_sibling;
6527 o->op_private |= OPpENTERSUB_HASTARG;
6528 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6529 if (cvop->op_type == OP_RV2CV) {
6531 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6532 op_null(cvop); /* disable rv2cv */
6533 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6534 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6535 GV *gv = cGVOPx_gv(tmpop);
6538 tmpop->op_private |= OPpEARLY_CV;
6539 else if (SvPOK(cv)) {
6540 namegv = CvANON(cv) ? gv : CvGV(cv);
6541 proto = SvPV((SV*)cv, n_a);
6545 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6546 if (o2->op_type == OP_CONST)
6547 o2->op_private &= ~OPpCONST_STRICT;
6548 else if (o2->op_type == OP_LIST) {
6549 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6550 if (o && o->op_type == OP_CONST)
6551 o->op_private &= ~OPpCONST_STRICT;
6554 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6555 if (PERLDB_SUB && PL_curstash != PL_debstash)
6556 o->op_private |= OPpENTERSUB_DB;
6557 while (o2 != cvop) {
6561 return too_many_arguments(o, gv_ename(namegv));
6579 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6581 arg == 1 ? "block or sub {}" : "sub {}",
6582 gv_ename(namegv), o2);
6585 /* '*' allows any scalar type, including bareword */
6588 if (o2->op_type == OP_RV2GV)
6589 goto wrapref; /* autoconvert GLOB -> GLOBref */
6590 else if (o2->op_type == OP_CONST)
6591 o2->op_private &= ~OPpCONST_STRICT;
6592 else if (o2->op_type == OP_ENTERSUB) {
6593 /* accidental subroutine, revert to bareword */
6594 OP *gvop = ((UNOP*)o2)->op_first;
6595 if (gvop && gvop->op_type == OP_NULL) {
6596 gvop = ((UNOP*)gvop)->op_first;
6598 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6601 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6602 (gvop = ((UNOP*)gvop)->op_first) &&
6603 gvop->op_type == OP_GV)
6605 GV *gv = cGVOPx_gv(gvop);
6606 OP *sibling = o2->op_sibling;
6607 SV *n = newSVpvn("",0);
6609 gv_fullname3(n, gv, "");
6610 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6611 sv_chop(n, SvPVX(n)+6);
6612 o2 = newSVOP(OP_CONST, 0, n);
6613 prev->op_sibling = o2;
6614 o2->op_sibling = sibling;
6626 if (o2->op_type != OP_RV2GV)
6627 bad_type(arg, "symbol", gv_ename(namegv), o2);
6630 if (o2->op_type != OP_ENTERSUB)
6631 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6634 if (o2->op_type != OP_RV2SV
6635 && o2->op_type != OP_PADSV
6636 && o2->op_type != OP_HELEM
6637 && o2->op_type != OP_AELEM
6638 && o2->op_type != OP_THREADSV)
6640 bad_type(arg, "scalar", gv_ename(namegv), o2);
6644 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6645 bad_type(arg, "array", gv_ename(namegv), o2);
6648 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6649 bad_type(arg, "hash", gv_ename(namegv), o2);
6653 OP* sib = kid->op_sibling;
6654 kid->op_sibling = 0;
6655 o2 = newUNOP(OP_REFGEN, 0, kid);
6656 o2->op_sibling = sib;
6657 prev->op_sibling = o2;
6668 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6669 gv_ename(namegv), SvPV((SV*)cv, n_a));
6674 mod(o2, OP_ENTERSUB);
6676 o2 = o2->op_sibling;
6678 if (proto && !optional &&
6679 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6680 return too_few_arguments(o, gv_ename(namegv));
6685 Perl_ck_svconst(pTHX_ OP *o)
6687 SvREADONLY_on(cSVOPo->op_sv);
6692 Perl_ck_trunc(pTHX_ OP *o)
6694 if (o->op_flags & OPf_KIDS) {
6695 SVOP *kid = (SVOP*)cUNOPo->op_first;
6697 if (kid->op_type == OP_NULL)
6698 kid = (SVOP*)kid->op_sibling;
6699 if (kid && kid->op_type == OP_CONST &&
6700 (kid->op_private & OPpCONST_BARE))
6702 o->op_flags |= OPf_SPECIAL;
6703 kid->op_private &= ~OPpCONST_STRICT;
6710 Perl_ck_substr(pTHX_ OP *o)
6713 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6714 OP *kid = cLISTOPo->op_first;
6716 if (kid->op_type == OP_NULL)
6717 kid = kid->op_sibling;
6719 kid->op_flags |= OPf_MOD;
6725 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6728 Perl_peep(pTHX_ register OP *o)
6730 register OP* oldop = 0;
6733 if (!o || o->op_seq)
6737 SAVEVPTR(PL_curcop);
6738 for (; o; o = o->op_next) {
6744 switch (o->op_type) {
6748 PL_curcop = ((COP*)o); /* for warnings */
6749 o->op_seq = PL_op_seqmax++;
6753 if (cSVOPo->op_private & OPpCONST_STRICT)
6754 no_bareword_allowed(o);
6756 /* Relocate sv to the pad for thread safety.
6757 * Despite being a "constant", the SV is written to,
6758 * for reference counts, sv_upgrade() etc. */
6760 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6761 if (SvPADTMP(cSVOPo->op_sv)) {
6762 /* If op_sv is already a PADTMP then it is being used by
6763 * some pad, so make a copy. */
6764 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6765 SvREADONLY_on(PL_curpad[ix]);
6766 SvREFCNT_dec(cSVOPo->op_sv);
6769 SvREFCNT_dec(PL_curpad[ix]);
6770 SvPADTMP_on(cSVOPo->op_sv);
6771 PL_curpad[ix] = cSVOPo->op_sv;
6772 /* XXX I don't know how this isn't readonly already. */
6773 SvREADONLY_on(PL_curpad[ix]);
6775 cSVOPo->op_sv = Nullsv;
6779 o->op_seq = PL_op_seqmax++;
6783 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6784 if (o->op_next->op_private & OPpTARGET_MY) {
6785 if (o->op_flags & OPf_STACKED) /* chained concats */
6786 goto ignore_optimization;
6788 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6789 o->op_targ = o->op_next->op_targ;
6790 o->op_next->op_targ = 0;
6791 o->op_private |= OPpTARGET_MY;
6794 op_null(o->op_next);
6796 ignore_optimization:
6797 o->op_seq = PL_op_seqmax++;
6800 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6801 o->op_seq = PL_op_seqmax++;
6802 break; /* Scalar stub must produce undef. List stub is noop */
6806 if (o->op_targ == OP_NEXTSTATE
6807 || o->op_targ == OP_DBSTATE
6808 || o->op_targ == OP_SETSTATE)
6810 PL_curcop = ((COP*)o);
6812 /* XXX: We avoid setting op_seq here to prevent later calls
6813 to peep() from mistakenly concluding that optimisation
6814 has already occurred. This doesn't fix the real problem,
6815 though (See 20010220.007). AMS 20010719 */
6816 if (oldop && o->op_next) {
6817 oldop->op_next = o->op_next;
6825 if (oldop && o->op_next) {
6826 oldop->op_next = o->op_next;
6829 o->op_seq = PL_op_seqmax++;
6833 if (o->op_next->op_type == OP_RV2SV) {
6834 if (!(o->op_next->op_private & OPpDEREF)) {
6835 op_null(o->op_next);
6836 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6838 o->op_next = o->op_next->op_next;
6839 o->op_type = OP_GVSV;
6840 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6843 else if (o->op_next->op_type == OP_RV2AV) {
6844 OP* pop = o->op_next->op_next;
6846 if (pop->op_type == OP_CONST &&
6847 (PL_op = pop->op_next) &&
6848 pop->op_next->op_type == OP_AELEM &&
6849 !(pop->op_next->op_private &
6850 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6851 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6856 op_null(o->op_next);
6857 op_null(pop->op_next);
6859 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6860 o->op_next = pop->op_next->op_next;
6861 o->op_type = OP_AELEMFAST;
6862 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6863 o->op_private = (U8)i;
6868 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6870 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6871 /* XXX could check prototype here instead of just carping */
6872 SV *sv = sv_newmortal();
6873 gv_efullname3(sv, gv, Nullch);
6874 Perl_warner(aTHX_ WARN_PROTOTYPE,
6875 "%s() called too early to check prototype",
6880 o->op_seq = PL_op_seqmax++;
6891 o->op_seq = PL_op_seqmax++;
6892 while (cLOGOP->op_other->op_type == OP_NULL)
6893 cLOGOP->op_other = cLOGOP->op_other->op_next;
6894 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6899 o->op_seq = PL_op_seqmax++;
6900 while (cLOOP->op_redoop->op_type == OP_NULL)
6901 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6902 peep(cLOOP->op_redoop);
6903 while (cLOOP->op_nextop->op_type == OP_NULL)
6904 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6905 peep(cLOOP->op_nextop);
6906 while (cLOOP->op_lastop->op_type == OP_NULL)
6907 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6908 peep(cLOOP->op_lastop);
6914 o->op_seq = PL_op_seqmax++;
6915 while (cPMOP->op_pmreplstart &&
6916 cPMOP->op_pmreplstart->op_type == OP_NULL)
6917 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6918 peep(cPMOP->op_pmreplstart);
6922 o->op_seq = PL_op_seqmax++;
6923 if (ckWARN(WARN_SYNTAX) && o->op_next
6924 && o->op_next->op_type == OP_NEXTSTATE) {
6925 if (o->op_next->op_sibling &&
6926 o->op_next->op_sibling->op_type != OP_EXIT &&
6927 o->op_next->op_sibling->op_type != OP_WARN &&
6928 o->op_next->op_sibling->op_type != OP_DIE) {
6929 line_t oldline = CopLINE(PL_curcop);
6931 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6932 Perl_warner(aTHX_ WARN_EXEC,
6933 "Statement unlikely to be reached");
6934 Perl_warner(aTHX_ WARN_EXEC,
6935 "\t(Maybe you meant system() when you said exec()?)\n");
6936 CopLINE_set(PL_curcop, oldline);
6945 SV **svp, **indsvp, *sv;
6950 o->op_seq = PL_op_seqmax++;
6952 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6955 /* Make the CONST have a shared SV */
6956 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6957 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6958 key = SvPV(sv, keylen);
6959 lexname = newSVpvn_share(key,
6960 SvUTF8(sv) ? -(I32)keylen : keylen,
6966 if ((o->op_private & (OPpLVAL_INTRO)))
6969 rop = (UNOP*)((BINOP*)o)->op_first;
6970 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6972 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6973 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6975 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6976 if (!fields || !GvHV(*fields))
6978 key = SvPV(*svp, keylen);
6979 indsvp = hv_fetch(GvHV(*fields), key,
6980 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6982 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6983 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6985 ind = SvIV(*indsvp);
6987 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6988 rop->op_type = OP_RV2AV;
6989 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6990 o->op_type = OP_AELEM;
6991 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6993 if (SvREADONLY(*svp))
6995 SvFLAGS(sv) |= (SvFLAGS(*svp)
6996 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7006 SV **svp, **indsvp, *sv;
7010 SVOP *first_key_op, *key_op;
7012 o->op_seq = PL_op_seqmax++;
7013 if ((o->op_private & (OPpLVAL_INTRO))
7014 /* I bet there's always a pushmark... */
7015 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7016 /* hmmm, no optimization if list contains only one key. */
7018 rop = (UNOP*)((LISTOP*)o)->op_last;
7019 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7021 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7022 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7024 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7025 if (!fields || !GvHV(*fields))
7027 /* Again guessing that the pushmark can be jumped over.... */
7028 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7029 ->op_first->op_sibling;
7030 /* Check that the key list contains only constants. */
7031 for (key_op = first_key_op; key_op;
7032 key_op = (SVOP*)key_op->op_sibling)
7033 if (key_op->op_type != OP_CONST)
7037 rop->op_type = OP_RV2AV;
7038 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7039 o->op_type = OP_ASLICE;
7040 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7041 for (key_op = first_key_op; key_op;
7042 key_op = (SVOP*)key_op->op_sibling) {
7043 svp = cSVOPx_svp(key_op);
7044 key = SvPV(*svp, keylen);
7045 indsvp = hv_fetch(GvHV(*fields), key,
7046 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7048 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7049 "in variable %s of type %s",
7050 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7052 ind = SvIV(*indsvp);
7054 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7056 if (SvREADONLY(*svp))
7058 SvFLAGS(sv) |= (SvFLAGS(*svp)
7059 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7067 o->op_seq = PL_op_seqmax++;
7077 /* Efficient sub that returns a constant scalar value. */
7079 const_sv_xsub(pTHXo_ CV* cv)
7084 Perl_croak(aTHX_ "usage: %s::%s()",
7085 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7089 ST(0) = (SV*)XSANY.any_ptr;