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 /* we use the "SAFE" version of the PM_ macros here
856 * since sv_clean_all might release some PMOPs
857 * after PL_regex_padav has been cleared
858 * and the clearing of PL_regex_padav needs to
859 * happen before sv_clean_all
861 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
862 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
866 if (o->op_targ > 0) {
867 pad_free(o->op_targ);
873 S_cop_free(pTHX_ COP* cop)
875 Safefree(cop->cop_label);
877 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
878 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
880 /* NOTE: COP.cop_stash is not refcounted */
881 SvREFCNT_dec(CopFILEGV(cop));
883 if (! specialWARN(cop->cop_warnings))
884 SvREFCNT_dec(cop->cop_warnings);
885 if (! specialCopIO(cop->cop_io))
886 SvREFCNT_dec(cop->cop_io);
890 Perl_op_null(pTHX_ OP *o)
892 if (o->op_type == OP_NULL)
895 o->op_targ = o->op_type;
896 o->op_type = OP_NULL;
897 o->op_ppaddr = PL_ppaddr[OP_NULL];
900 /* Contextualizers */
902 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
905 Perl_linklist(pTHX_ OP *o)
912 /* establish postfix order */
913 if (cUNOPo->op_first) {
914 o->op_next = LINKLIST(cUNOPo->op_first);
915 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
917 kid->op_next = LINKLIST(kid->op_sibling);
929 Perl_scalarkids(pTHX_ OP *o)
932 if (o && o->op_flags & OPf_KIDS) {
933 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
940 S_scalarboolean(pTHX_ OP *o)
942 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
943 if (ckWARN(WARN_SYNTAX)) {
944 line_t oldline = CopLINE(PL_curcop);
946 if (PL_copline != NOLINE)
947 CopLINE_set(PL_curcop, PL_copline);
948 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
949 CopLINE_set(PL_curcop, oldline);
956 Perl_scalar(pTHX_ OP *o)
960 /* assumes no premature commitment */
961 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
962 || o->op_type == OP_RETURN)
967 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
969 switch (o->op_type) {
971 scalar(cBINOPo->op_first);
976 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
980 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
981 if (!kPMOP->op_pmreplroot)
982 deprecate("implicit split to @_");
990 if (o->op_flags & OPf_KIDS) {
991 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
997 kid = cLISTOPo->op_first;
999 while ((kid = kid->op_sibling)) {
1000 if (kid->op_sibling)
1005 WITH_THR(PL_curcop = &PL_compiling);
1010 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1011 if (kid->op_sibling)
1016 WITH_THR(PL_curcop = &PL_compiling);
1023 Perl_scalarvoid(pTHX_ OP *o)
1030 if (o->op_type == OP_NEXTSTATE
1031 || o->op_type == OP_SETSTATE
1032 || o->op_type == OP_DBSTATE
1033 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1034 || o->op_targ == OP_SETSTATE
1035 || o->op_targ == OP_DBSTATE)))
1036 PL_curcop = (COP*)o; /* for warning below */
1038 /* assumes no premature commitment */
1039 want = o->op_flags & OPf_WANT;
1040 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1041 || o->op_type == OP_RETURN)
1046 if ((o->op_private & OPpTARGET_MY)
1047 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1049 return scalar(o); /* As if inside SASSIGN */
1052 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1054 switch (o->op_type) {
1056 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1060 if (o->op_flags & OPf_STACKED)
1064 if (o->op_private == 4)
1106 case OP_GETSOCKNAME:
1107 case OP_GETPEERNAME:
1112 case OP_GETPRIORITY:
1135 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1136 useless = PL_op_desc[o->op_type];
1143 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1144 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1145 useless = "a variable";
1150 if (cSVOPo->op_private & OPpCONST_STRICT)
1151 no_bareword_allowed(o);
1153 if (ckWARN(WARN_VOID)) {
1154 useless = "a constant";
1155 /* the constants 0 and 1 are permitted as they are
1156 conventionally used as dummies in constructs like
1157 1 while some_condition_with_side_effects; */
1158 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1160 else if (SvPOK(sv)) {
1161 /* perl4's way of mixing documentation and code
1162 (before the invention of POD) was based on a
1163 trick to mix nroff and perl code. The trick was
1164 built upon these three nroff macros being used in
1165 void context. The pink camel has the details in
1166 the script wrapman near page 319. */
1167 if (strnEQ(SvPVX(sv), "di", 2) ||
1168 strnEQ(SvPVX(sv), "ds", 2) ||
1169 strnEQ(SvPVX(sv), "ig", 2))
1174 op_null(o); /* don't execute or even remember it */
1178 o->op_type = OP_PREINC; /* pre-increment is faster */
1179 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1183 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1184 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1190 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1195 if (o->op_flags & OPf_STACKED)
1202 if (!(o->op_flags & OPf_KIDS))
1211 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1218 /* all requires must return a boolean value */
1219 o->op_flags &= ~OPf_WANT;
1224 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1225 if (!kPMOP->op_pmreplroot)
1226 deprecate("implicit split to @_");
1230 if (useless && ckWARN(WARN_VOID))
1231 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1236 Perl_listkids(pTHX_ OP *o)
1239 if (o && o->op_flags & OPf_KIDS) {
1240 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1247 Perl_list(pTHX_ OP *o)
1251 /* assumes no premature commitment */
1252 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1253 || o->op_type == OP_RETURN)
1258 if ((o->op_private & OPpTARGET_MY)
1259 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1261 return o; /* As if inside SASSIGN */
1264 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1266 switch (o->op_type) {
1269 list(cBINOPo->op_first);
1274 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1282 if (!(o->op_flags & OPf_KIDS))
1284 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1285 list(cBINOPo->op_first);
1286 return gen_constant_list(o);
1293 kid = cLISTOPo->op_first;
1295 while ((kid = kid->op_sibling)) {
1296 if (kid->op_sibling)
1301 WITH_THR(PL_curcop = &PL_compiling);
1305 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1306 if (kid->op_sibling)
1311 WITH_THR(PL_curcop = &PL_compiling);
1314 /* all requires must return a boolean value */
1315 o->op_flags &= ~OPf_WANT;
1322 Perl_scalarseq(pTHX_ OP *o)
1327 if (o->op_type == OP_LINESEQ ||
1328 o->op_type == OP_SCOPE ||
1329 o->op_type == OP_LEAVE ||
1330 o->op_type == OP_LEAVETRY)
1332 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1333 if (kid->op_sibling) {
1337 PL_curcop = &PL_compiling;
1339 o->op_flags &= ~OPf_PARENS;
1340 if (PL_hints & HINT_BLOCK_SCOPE)
1341 o->op_flags |= OPf_PARENS;
1344 o = newOP(OP_STUB, 0);
1349 S_modkids(pTHX_ OP *o, I32 type)
1352 if (o && o->op_flags & OPf_KIDS) {
1353 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1360 Perl_mod(pTHX_ OP *o, I32 type)
1365 if (!o || PL_error_count)
1368 if ((o->op_private & OPpTARGET_MY)
1369 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1374 switch (o->op_type) {
1379 if (!(o->op_private & (OPpCONST_ARYBASE)))
1381 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1382 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1386 SAVEI32(PL_compiling.cop_arybase);
1387 PL_compiling.cop_arybase = 0;
1389 else if (type == OP_REFGEN)
1392 Perl_croak(aTHX_ "That use of $[ is unsupported");
1395 if (o->op_flags & OPf_PARENS)
1399 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1400 !(o->op_flags & OPf_STACKED)) {
1401 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1402 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1403 assert(cUNOPo->op_first->op_type == OP_NULL);
1404 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1407 else { /* lvalue subroutine call */
1408 o->op_private |= OPpLVAL_INTRO;
1409 PL_modcount = RETURN_UNLIMITED_NUMBER;
1410 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1411 /* Backward compatibility mode: */
1412 o->op_private |= OPpENTERSUB_INARGS;
1415 else { /* Compile-time error message: */
1416 OP *kid = cUNOPo->op_first;
1420 if (kid->op_type == OP_PUSHMARK)
1422 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1424 "panic: unexpected lvalue entersub "
1425 "args: type/targ %ld:%ld",
1426 (long)kid->op_type,kid->op_targ);
1427 kid = kLISTOP->op_first;
1429 while (kid->op_sibling)
1430 kid = kid->op_sibling;
1431 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1433 if (kid->op_type == OP_METHOD_NAMED
1434 || kid->op_type == OP_METHOD)
1438 if (kid->op_sibling || kid->op_next != kid) {
1439 yyerror("panic: unexpected optree near method call");
1443 NewOp(1101, newop, 1, UNOP);
1444 newop->op_type = OP_RV2CV;
1445 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1446 newop->op_first = Nullop;
1447 newop->op_next = (OP*)newop;
1448 kid->op_sibling = (OP*)newop;
1449 newop->op_private |= OPpLVAL_INTRO;
1453 if (kid->op_type != OP_RV2CV)
1455 "panic: unexpected lvalue entersub "
1456 "entry via type/targ %ld:%ld",
1457 (long)kid->op_type,kid->op_targ);
1458 kid->op_private |= OPpLVAL_INTRO;
1459 break; /* Postpone until runtime */
1463 kid = kUNOP->op_first;
1464 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1465 kid = kUNOP->op_first;
1466 if (kid->op_type == OP_NULL)
1468 "Unexpected constant lvalue entersub "
1469 "entry via type/targ %ld:%ld",
1470 (long)kid->op_type,kid->op_targ);
1471 if (kid->op_type != OP_GV) {
1472 /* Restore RV2CV to check lvalueness */
1474 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1475 okid->op_next = kid->op_next;
1476 kid->op_next = okid;
1479 okid->op_next = Nullop;
1480 okid->op_type = OP_RV2CV;
1482 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1483 okid->op_private |= OPpLVAL_INTRO;
1487 cv = GvCV(kGVOP_gv);
1497 /* grep, foreach, subcalls, refgen */
1498 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1500 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1501 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1503 : (o->op_type == OP_ENTERSUB
1504 ? "non-lvalue subroutine call"
1505 : PL_op_desc[o->op_type])),
1506 type ? PL_op_desc[type] : "local"));
1520 case OP_RIGHT_SHIFT:
1529 if (!(o->op_flags & OPf_STACKED))
1535 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1541 if (!type && cUNOPo->op_first->op_type != OP_GV)
1542 Perl_croak(aTHX_ "Can't localize through a reference");
1543 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1544 PL_modcount = RETURN_UNLIMITED_NUMBER;
1545 return o; /* Treat \(@foo) like ordinary list. */
1549 if (scalar_mod_type(o, type))
1551 ref(cUNOPo->op_first, o->op_type);
1555 if (type == OP_LEAVESUBLV)
1556 o->op_private |= OPpMAYBE_LVSUB;
1562 PL_modcount = RETURN_UNLIMITED_NUMBER;
1565 if (!type && cUNOPo->op_first->op_type != OP_GV)
1566 Perl_croak(aTHX_ "Can't localize through a reference");
1567 ref(cUNOPo->op_first, o->op_type);
1571 PL_hints |= HINT_BLOCK_SCOPE;
1581 PL_modcount = RETURN_UNLIMITED_NUMBER;
1582 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1583 return o; /* Treat \(@foo) like ordinary list. */
1584 if (scalar_mod_type(o, type))
1586 if (type == OP_LEAVESUBLV)
1587 o->op_private |= OPpMAYBE_LVSUB;
1592 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1593 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1598 PL_modcount++; /* XXX ??? */
1600 #endif /* USE_THREADS */
1606 if (type != OP_SASSIGN)
1610 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1615 if (type == OP_LEAVESUBLV)
1616 o->op_private |= OPpMAYBE_LVSUB;
1618 pad_free(o->op_targ);
1619 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1620 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1621 if (o->op_flags & OPf_KIDS)
1622 mod(cBINOPo->op_first->op_sibling, type);
1627 ref(cBINOPo->op_first, o->op_type);
1628 if (type == OP_ENTERSUB &&
1629 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1630 o->op_private |= OPpLVAL_DEFER;
1631 if (type == OP_LEAVESUBLV)
1632 o->op_private |= OPpMAYBE_LVSUB;
1640 if (o->op_flags & OPf_KIDS)
1641 mod(cLISTOPo->op_last, type);
1645 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1647 else if (!(o->op_flags & OPf_KIDS))
1649 if (o->op_targ != OP_LIST) {
1650 mod(cBINOPo->op_first, type);
1655 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1660 if (type != OP_LEAVESUBLV)
1662 break; /* mod()ing was handled by ck_return() */
1664 if (type != OP_LEAVESUBLV)
1665 o->op_flags |= OPf_MOD;
1667 if (type == OP_AASSIGN || type == OP_SASSIGN)
1668 o->op_flags |= OPf_SPECIAL|OPf_REF;
1670 o->op_private |= OPpLVAL_INTRO;
1671 o->op_flags &= ~OPf_SPECIAL;
1672 PL_hints |= HINT_BLOCK_SCOPE;
1674 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1675 && type != OP_LEAVESUBLV)
1676 o->op_flags |= OPf_REF;
1681 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1685 if (o->op_type == OP_RV2GV)
1709 case OP_RIGHT_SHIFT:
1728 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1730 switch (o->op_type) {
1738 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1751 Perl_refkids(pTHX_ OP *o, I32 type)
1754 if (o && o->op_flags & OPf_KIDS) {
1755 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1762 Perl_ref(pTHX_ OP *o, I32 type)
1766 if (!o || PL_error_count)
1769 switch (o->op_type) {
1771 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1772 !(o->op_flags & OPf_STACKED)) {
1773 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1774 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1775 assert(cUNOPo->op_first->op_type == OP_NULL);
1776 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1777 o->op_flags |= OPf_SPECIAL;
1782 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1786 if (type == OP_DEFINED)
1787 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1788 ref(cUNOPo->op_first, o->op_type);
1791 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1792 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1793 : type == OP_RV2HV ? OPpDEREF_HV
1795 o->op_flags |= OPf_MOD;
1800 o->op_flags |= OPf_MOD; /* XXX ??? */
1805 o->op_flags |= OPf_REF;
1808 if (type == OP_DEFINED)
1809 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1810 ref(cUNOPo->op_first, o->op_type);
1815 o->op_flags |= OPf_REF;
1820 if (!(o->op_flags & OPf_KIDS))
1822 ref(cBINOPo->op_first, type);
1826 ref(cBINOPo->op_first, o->op_type);
1827 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1828 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1829 : type == OP_RV2HV ? OPpDEREF_HV
1831 o->op_flags |= OPf_MOD;
1839 if (!(o->op_flags & OPf_KIDS))
1841 ref(cLISTOPo->op_last, type);
1851 S_dup_attrlist(pTHX_ OP *o)
1855 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1856 * where the first kid is OP_PUSHMARK and the remaining ones
1857 * are OP_CONST. We need to push the OP_CONST values.
1859 if (o->op_type == OP_CONST)
1860 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1862 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1863 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1864 if (o->op_type == OP_CONST)
1865 rop = append_elem(OP_LIST, rop,
1866 newSVOP(OP_CONST, o->op_flags,
1867 SvREFCNT_inc(cSVOPo->op_sv)));
1874 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1878 /* fake up C<use attributes $pkg,$rv,@attrs> */
1879 ENTER; /* need to protect against side-effects of 'use' */
1882 stashsv = newSVpv(HvNAME(stash), 0);
1884 stashsv = &PL_sv_no;
1886 #define ATTRSMODULE "attributes"
1888 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1889 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1891 prepend_elem(OP_LIST,
1892 newSVOP(OP_CONST, 0, stashsv),
1893 prepend_elem(OP_LIST,
1894 newSVOP(OP_CONST, 0,
1896 dup_attrlist(attrs))));
1901 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1902 char *attrstr, STRLEN len)
1907 len = strlen(attrstr);
1911 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1913 char *sstr = attrstr;
1914 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1915 attrs = append_elem(OP_LIST, attrs,
1916 newSVOP(OP_CONST, 0,
1917 newSVpvn(sstr, attrstr-sstr)));
1921 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1922 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1923 Nullsv, prepend_elem(OP_LIST,
1924 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1925 prepend_elem(OP_LIST,
1926 newSVOP(OP_CONST, 0,
1932 S_my_kid(pTHX_ OP *o, OP *attrs)
1937 if (!o || PL_error_count)
1941 if (type == OP_LIST) {
1942 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1944 } else if (type == OP_UNDEF) {
1946 } else if (type == OP_RV2SV || /* "our" declaration */
1948 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1950 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1952 PL_in_my_stash = Nullhv;
1953 apply_attrs(GvSTASH(gv),
1954 (type == OP_RV2SV ? GvSV(gv) :
1955 type == OP_RV2AV ? (SV*)GvAV(gv) :
1956 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1959 o->op_private |= OPpOUR_INTRO;
1961 } else if (type != OP_PADSV &&
1964 type != OP_PUSHMARK)
1966 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1967 PL_op_desc[o->op_type],
1968 PL_in_my == KEY_our ? "our" : "my"));
1971 else if (attrs && type != OP_PUSHMARK) {
1977 PL_in_my_stash = Nullhv;
1979 /* check for C<my Dog $spot> when deciding package */
1980 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1981 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1982 stash = SvSTASH(*namesvp);
1984 stash = PL_curstash;
1985 padsv = PAD_SV(o->op_targ);
1986 apply_attrs(stash, padsv, attrs);
1988 o->op_flags |= OPf_MOD;
1989 o->op_private |= OPpLVAL_INTRO;
1994 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1996 if (o->op_flags & OPf_PARENS)
2000 o = my_kid(o, attrs);
2002 PL_in_my_stash = Nullhv;
2007 Perl_my(pTHX_ OP *o)
2009 return my_kid(o, Nullop);
2013 Perl_sawparens(pTHX_ OP *o)
2016 o->op_flags |= OPf_PARENS;
2021 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2025 if (ckWARN(WARN_MISC) &&
2026 (left->op_type == OP_RV2AV ||
2027 left->op_type == OP_RV2HV ||
2028 left->op_type == OP_PADAV ||
2029 left->op_type == OP_PADHV)) {
2030 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2031 right->op_type == OP_TRANS)
2032 ? right->op_type : OP_MATCH];
2033 const char *sample = ((left->op_type == OP_RV2AV ||
2034 left->op_type == OP_PADAV)
2035 ? "@array" : "%hash");
2036 Perl_warner(aTHX_ WARN_MISC,
2037 "Applying %s to %s will act on scalar(%s)",
2038 desc, sample, sample);
2041 if (!(right->op_flags & OPf_STACKED) &&
2042 (right->op_type == OP_MATCH ||
2043 right->op_type == OP_SUBST ||
2044 right->op_type == OP_TRANS)) {
2045 right->op_flags |= OPf_STACKED;
2046 if ((right->op_type != OP_MATCH &&
2047 ! (right->op_type == OP_TRANS &&
2048 right->op_private & OPpTRANS_IDENTICAL)) ||
2049 /* if SV has magic, then match on original SV, not on its copy.
2050 see note in pp_helem() */
2051 (right->op_type == OP_MATCH &&
2052 (left->op_type == OP_AELEM ||
2053 left->op_type == OP_HELEM ||
2054 left->op_type == OP_AELEMFAST)))
2055 left = mod(left, right->op_type);
2056 if (right->op_type == OP_TRANS)
2057 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2059 o = prepend_elem(right->op_type, scalar(left), right);
2061 return newUNOP(OP_NOT, 0, scalar(o));
2065 return bind_match(type, left,
2066 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2070 Perl_invert(pTHX_ OP *o)
2074 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2075 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2079 Perl_scope(pTHX_ OP *o)
2082 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2083 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2084 o->op_type = OP_LEAVE;
2085 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2088 if (o->op_type == OP_LINESEQ) {
2090 o->op_type = OP_SCOPE;
2091 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2092 kid = ((LISTOP*)o)->op_first;
2093 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2097 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2104 Perl_save_hints(pTHX)
2107 SAVESPTR(GvHV(PL_hintgv));
2108 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2109 SAVEFREESV(GvHV(PL_hintgv));
2113 Perl_block_start(pTHX_ int full)
2115 int retval = PL_savestack_ix;
2117 SAVEI32(PL_comppad_name_floor);
2118 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2120 PL_comppad_name_fill = PL_comppad_name_floor;
2121 if (PL_comppad_name_floor < 0)
2122 PL_comppad_name_floor = 0;
2123 SAVEI32(PL_min_intro_pending);
2124 SAVEI32(PL_max_intro_pending);
2125 PL_min_intro_pending = 0;
2126 SAVEI32(PL_comppad_name_fill);
2127 SAVEI32(PL_padix_floor);
2128 PL_padix_floor = PL_padix;
2129 PL_pad_reset_pending = FALSE;
2131 PL_hints &= ~HINT_BLOCK_SCOPE;
2132 SAVESPTR(PL_compiling.cop_warnings);
2133 if (! specialWARN(PL_compiling.cop_warnings)) {
2134 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2135 SAVEFREESV(PL_compiling.cop_warnings) ;
2137 SAVESPTR(PL_compiling.cop_io);
2138 if (! specialCopIO(PL_compiling.cop_io)) {
2139 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2140 SAVEFREESV(PL_compiling.cop_io) ;
2146 Perl_block_end(pTHX_ I32 floor, OP *seq)
2148 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2149 OP* retval = scalarseq(seq);
2151 PL_pad_reset_pending = FALSE;
2152 PL_compiling.op_private = PL_hints;
2154 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2155 pad_leavemy(PL_comppad_name_fill);
2164 OP *o = newOP(OP_THREADSV, 0);
2165 o->op_targ = find_threadsv("_");
2168 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2169 #endif /* USE_THREADS */
2173 Perl_newPROG(pTHX_ OP *o)
2178 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2179 ((PL_in_eval & EVAL_KEEPERR)
2180 ? OPf_SPECIAL : 0), o);
2181 PL_eval_start = linklist(PL_eval_root);
2182 PL_eval_root->op_private |= OPpREFCOUNTED;
2183 OpREFCNT_set(PL_eval_root, 1);
2184 PL_eval_root->op_next = 0;
2185 CALL_PEEP(PL_eval_start);
2190 PL_main_root = scope(sawparens(scalarvoid(o)));
2191 PL_curcop = &PL_compiling;
2192 PL_main_start = LINKLIST(PL_main_root);
2193 PL_main_root->op_private |= OPpREFCOUNTED;
2194 OpREFCNT_set(PL_main_root, 1);
2195 PL_main_root->op_next = 0;
2196 CALL_PEEP(PL_main_start);
2199 /* Register with debugger */
2201 CV *cv = get_cv("DB::postponed", FALSE);
2205 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2207 call_sv((SV*)cv, G_DISCARD);
2214 Perl_localize(pTHX_ OP *o, I32 lex)
2216 if (o->op_flags & OPf_PARENS)
2219 if (ckWARN(WARN_PARENTHESIS)
2220 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2222 char *s = PL_bufptr;
2224 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2227 if (*s == ';' || *s == '=')
2228 Perl_warner(aTHX_ WARN_PARENTHESIS,
2229 "Parentheses missing around \"%s\" list",
2230 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2236 o = mod(o, OP_NULL); /* a bit kludgey */
2238 PL_in_my_stash = Nullhv;
2243 Perl_jmaybe(pTHX_ OP *o)
2245 if (o->op_type == OP_LIST) {
2248 o2 = newOP(OP_THREADSV, 0);
2249 o2->op_targ = find_threadsv(";");
2251 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2252 #endif /* USE_THREADS */
2253 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2259 Perl_fold_constants(pTHX_ register OP *o)
2262 I32 type = o->op_type;
2265 if (PL_opargs[type] & OA_RETSCALAR)
2267 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2268 o->op_targ = pad_alloc(type, SVs_PADTMP);
2270 /* integerize op, unless it happens to be C<-foo>.
2271 * XXX should pp_i_negate() do magic string negation instead? */
2272 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2273 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2274 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2276 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2279 if (!(PL_opargs[type] & OA_FOLDCONST))
2284 /* XXX might want a ck_negate() for this */
2285 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2297 /* XXX what about the numeric ops? */
2298 if (PL_hints & HINT_LOCALE)
2303 goto nope; /* Don't try to run w/ errors */
2305 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2306 if ((curop->op_type != OP_CONST ||
2307 (curop->op_private & OPpCONST_BARE)) &&
2308 curop->op_type != OP_LIST &&
2309 curop->op_type != OP_SCALAR &&
2310 curop->op_type != OP_NULL &&
2311 curop->op_type != OP_PUSHMARK)
2317 curop = LINKLIST(o);
2321 sv = *(PL_stack_sp--);
2322 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2323 pad_swipe(o->op_targ);
2324 else if (SvTEMP(sv)) { /* grab mortal temp? */
2325 (void)SvREFCNT_inc(sv);
2329 if (type == OP_RV2GV)
2330 return newGVOP(OP_GV, 0, (GV*)sv);
2332 /* try to smush double to int, but don't smush -2.0 to -2 */
2333 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2336 #ifdef PERL_PRESERVE_IVUV
2337 /* Only bother to attempt to fold to IV if
2338 most operators will benefit */
2342 return newSVOP(OP_CONST, 0, sv);
2346 if (!(PL_opargs[type] & OA_OTHERINT))
2349 if (!(PL_hints & HINT_INTEGER)) {
2350 if (type == OP_MODULO
2351 || type == OP_DIVIDE
2352 || !(o->op_flags & OPf_KIDS))
2357 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2358 if (curop->op_type == OP_CONST) {
2359 if (SvIOK(((SVOP*)curop)->op_sv))
2363 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2367 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2374 Perl_gen_constant_list(pTHX_ register OP *o)
2377 I32 oldtmps_floor = PL_tmps_floor;
2381 return o; /* Don't attempt to run with errors */
2383 PL_op = curop = LINKLIST(o);
2390 PL_tmps_floor = oldtmps_floor;
2392 o->op_type = OP_RV2AV;
2393 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2394 curop = ((UNOP*)o)->op_first;
2395 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2402 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2404 if (!o || o->op_type != OP_LIST)
2405 o = newLISTOP(OP_LIST, 0, o, Nullop);
2407 o->op_flags &= ~OPf_WANT;
2409 if (!(PL_opargs[type] & OA_MARK))
2410 op_null(cLISTOPo->op_first);
2413 o->op_ppaddr = PL_ppaddr[type];
2414 o->op_flags |= flags;
2416 o = CHECKOP(type, o);
2417 if (o->op_type != type)
2420 return fold_constants(o);
2423 /* List constructors */
2426 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2434 if (first->op_type != type
2435 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2437 return newLISTOP(type, 0, first, last);
2440 if (first->op_flags & OPf_KIDS)
2441 ((LISTOP*)first)->op_last->op_sibling = last;
2443 first->op_flags |= OPf_KIDS;
2444 ((LISTOP*)first)->op_first = last;
2446 ((LISTOP*)first)->op_last = last;
2451 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2459 if (first->op_type != type)
2460 return prepend_elem(type, (OP*)first, (OP*)last);
2462 if (last->op_type != type)
2463 return append_elem(type, (OP*)first, (OP*)last);
2465 first->op_last->op_sibling = last->op_first;
2466 first->op_last = last->op_last;
2467 first->op_flags |= (last->op_flags & OPf_KIDS);
2469 #ifdef PL_OP_SLAB_ALLOC
2477 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2485 if (last->op_type == type) {
2486 if (type == OP_LIST) { /* already a PUSHMARK there */
2487 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2488 ((LISTOP*)last)->op_first->op_sibling = first;
2489 if (!(first->op_flags & OPf_PARENS))
2490 last->op_flags &= ~OPf_PARENS;
2493 if (!(last->op_flags & OPf_KIDS)) {
2494 ((LISTOP*)last)->op_last = first;
2495 last->op_flags |= OPf_KIDS;
2497 first->op_sibling = ((LISTOP*)last)->op_first;
2498 ((LISTOP*)last)->op_first = first;
2500 last->op_flags |= OPf_KIDS;
2504 return newLISTOP(type, 0, first, last);
2510 Perl_newNULLLIST(pTHX)
2512 return newOP(OP_STUB, 0);
2516 Perl_force_list(pTHX_ OP *o)
2518 if (!o || o->op_type != OP_LIST)
2519 o = newLISTOP(OP_LIST, 0, o, Nullop);
2525 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2529 NewOp(1101, listop, 1, LISTOP);
2531 listop->op_type = type;
2532 listop->op_ppaddr = PL_ppaddr[type];
2535 listop->op_flags = flags;
2539 else if (!first && last)
2542 first->op_sibling = last;
2543 listop->op_first = first;
2544 listop->op_last = last;
2545 if (type == OP_LIST) {
2547 pushop = newOP(OP_PUSHMARK, 0);
2548 pushop->op_sibling = first;
2549 listop->op_first = pushop;
2550 listop->op_flags |= OPf_KIDS;
2552 listop->op_last = pushop;
2559 Perl_newOP(pTHX_ I32 type, I32 flags)
2562 NewOp(1101, o, 1, OP);
2564 o->op_ppaddr = PL_ppaddr[type];
2565 o->op_flags = flags;
2568 o->op_private = 0 + (flags >> 8);
2569 if (PL_opargs[type] & OA_RETSCALAR)
2571 if (PL_opargs[type] & OA_TARGET)
2572 o->op_targ = pad_alloc(type, SVs_PADTMP);
2573 return CHECKOP(type, o);
2577 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2582 first = newOP(OP_STUB, 0);
2583 if (PL_opargs[type] & OA_MARK)
2584 first = force_list(first);
2586 NewOp(1101, unop, 1, UNOP);
2587 unop->op_type = type;
2588 unop->op_ppaddr = PL_ppaddr[type];
2589 unop->op_first = first;
2590 unop->op_flags = flags | OPf_KIDS;
2591 unop->op_private = 1 | (flags >> 8);
2592 unop = (UNOP*) CHECKOP(type, unop);
2596 return fold_constants((OP *) unop);
2600 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2603 NewOp(1101, binop, 1, BINOP);
2606 first = newOP(OP_NULL, 0);
2608 binop->op_type = type;
2609 binop->op_ppaddr = PL_ppaddr[type];
2610 binop->op_first = first;
2611 binop->op_flags = flags | OPf_KIDS;
2614 binop->op_private = 1 | (flags >> 8);
2617 binop->op_private = 2 | (flags >> 8);
2618 first->op_sibling = last;
2621 binop = (BINOP*)CHECKOP(type, binop);
2622 if (binop->op_next || binop->op_type != type)
2625 binop->op_last = binop->op_first->op_sibling;
2627 return fold_constants((OP *)binop);
2631 uvcompare(const void *a, const void *b)
2633 if (*((UV *)a) < (*(UV *)b))
2635 if (*((UV *)a) > (*(UV *)b))
2637 if (*((UV *)a+1) < (*(UV *)b+1))
2639 if (*((UV *)a+1) > (*(UV *)b+1))
2645 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2647 SV *tstr = ((SVOP*)expr)->op_sv;
2648 SV *rstr = ((SVOP*)repl)->op_sv;
2651 U8 *t = (U8*)SvPV(tstr, tlen);
2652 U8 *r = (U8*)SvPV(rstr, rlen);
2659 register short *tbl;
2661 PL_hints |= HINT_BLOCK_SCOPE;
2662 complement = o->op_private & OPpTRANS_COMPLEMENT;
2663 del = o->op_private & OPpTRANS_DELETE;
2664 squash = o->op_private & OPpTRANS_SQUASH;
2667 o->op_private |= OPpTRANS_FROM_UTF;
2670 o->op_private |= OPpTRANS_TO_UTF;
2672 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2673 SV* listsv = newSVpvn("# comment\n",10);
2675 U8* tend = t + tlen;
2676 U8* rend = r + rlen;
2690 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2691 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2697 tsave = t = bytes_to_utf8(t, &len);
2700 if (!to_utf && rlen) {
2702 rsave = r = bytes_to_utf8(r, &len);
2706 /* There are several snags with this code on EBCDIC:
2707 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2708 2. scan_const() in toke.c has encoded chars in native encoding which makes
2709 ranges at least in EBCDIC 0..255 range the bottom odd.
2713 U8 tmpbuf[UTF8_MAXLEN+1];
2716 New(1109, cp, 2*tlen, UV);
2718 transv = newSVpvn("",0);
2720 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2722 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2724 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2728 cp[2*i+1] = cp[2*i];
2732 qsort(cp, i, 2*sizeof(UV), uvcompare);
2733 for (j = 0; j < i; j++) {
2735 diff = val - nextmin;
2737 t = uvuni_to_utf8(tmpbuf,nextmin);
2738 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2740 U8 range_mark = UTF_TO_NATIVE(0xff);
2741 t = uvuni_to_utf8(tmpbuf, val - 1);
2742 sv_catpvn(transv, (char *)&range_mark, 1);
2743 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2750 t = uvuni_to_utf8(tmpbuf,nextmin);
2751 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2753 U8 range_mark = UTF_TO_NATIVE(0xff);
2754 sv_catpvn(transv, (char *)&range_mark, 1);
2756 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2757 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2758 t = (U8*)SvPVX(transv);
2759 tlen = SvCUR(transv);
2763 else if (!rlen && !del) {
2764 r = t; rlen = tlen; rend = tend;
2767 if ((!rlen && !del) || t == r ||
2768 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2770 o->op_private |= OPpTRANS_IDENTICAL;
2774 while (t < tend || tfirst <= tlast) {
2775 /* see if we need more "t" chars */
2776 if (tfirst > tlast) {
2777 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2779 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2781 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2788 /* now see if we need more "r" chars */
2789 if (rfirst > rlast) {
2791 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2793 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2795 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2804 rfirst = rlast = 0xffffffff;
2808 /* now see which range will peter our first, if either. */
2809 tdiff = tlast - tfirst;
2810 rdiff = rlast - rfirst;
2817 if (rfirst == 0xffffffff) {
2818 diff = tdiff; /* oops, pretend rdiff is infinite */
2820 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2821 (long)tfirst, (long)tlast);
2823 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2827 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2828 (long)tfirst, (long)(tfirst + diff),
2831 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2832 (long)tfirst, (long)rfirst);
2834 if (rfirst + diff > max)
2835 max = rfirst + diff;
2837 grows = (tfirst < rfirst &&
2838 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2850 else if (max > 0xff)
2855 Safefree(cPVOPo->op_pv);
2856 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2857 SvREFCNT_dec(listsv);
2859 SvREFCNT_dec(transv);
2861 if (!del && havefinal && rlen)
2862 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2863 newSVuv((UV)final), 0);
2866 o->op_private |= OPpTRANS_GROWS;
2878 tbl = (short*)cPVOPo->op_pv;
2880 Zero(tbl, 256, short);
2881 for (i = 0; i < tlen; i++)
2883 for (i = 0, j = 0; i < 256; i++) {
2894 if (i < 128 && r[j] >= 128)
2904 o->op_private |= OPpTRANS_IDENTICAL;
2909 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2910 tbl[0x100] = rlen - j;
2911 for (i=0; i < rlen - j; i++)
2912 tbl[0x101+i] = r[j+i];
2916 if (!rlen && !del) {
2919 o->op_private |= OPpTRANS_IDENTICAL;
2921 for (i = 0; i < 256; i++)
2923 for (i = 0, j = 0; i < tlen; i++,j++) {
2926 if (tbl[t[i]] == -1)
2932 if (tbl[t[i]] == -1) {
2933 if (t[i] < 128 && r[j] >= 128)
2940 o->op_private |= OPpTRANS_GROWS;
2948 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2952 NewOp(1101, pmop, 1, PMOP);
2953 pmop->op_type = type;
2954 pmop->op_ppaddr = PL_ppaddr[type];
2955 pmop->op_flags = flags;
2956 pmop->op_private = 0 | (flags >> 8);
2958 if (PL_hints & HINT_RE_TAINT)
2959 pmop->op_pmpermflags |= PMf_RETAINT;
2960 if (PL_hints & HINT_LOCALE)
2961 pmop->op_pmpermflags |= PMf_LOCALE;
2962 pmop->op_pmflags = pmop->op_pmpermflags;
2966 SV* repointer = newSViv(0);
2967 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2968 pmop->op_pmoffset = av_len(PL_regex_padav);
2969 PL_regex_pad = AvARRAY(PL_regex_padav);
2973 /* link into pm list */
2974 if (type != OP_TRANS && PL_curstash) {
2975 pmop->op_pmnext = HvPMROOT(PL_curstash);
2976 HvPMROOT(PL_curstash) = pmop;
2977 PmopSTASH_set(pmop,PL_curstash);
2984 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2988 I32 repl_has_vars = 0;
2990 if (o->op_type == OP_TRANS)
2991 return pmtrans(o, expr, repl);
2993 PL_hints |= HINT_BLOCK_SCOPE;
2996 if (expr->op_type == OP_CONST) {
2998 SV *pat = ((SVOP*)expr)->op_sv;
2999 char *p = SvPV(pat, plen);
3000 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3001 sv_setpvn(pat, "\\s+", 3);
3002 p = SvPV(pat, plen);
3003 pm->op_pmflags |= PMf_SKIPWHITE;
3005 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
3006 pm->op_pmdynflags |= PMdf_UTF8;
3007 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3008 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3009 pm->op_pmflags |= PMf_WHITE;
3013 if (PL_hints & HINT_UTF8)
3014 pm->op_pmdynflags |= PMdf_UTF8;
3015 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3016 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3018 : OP_REGCMAYBE),0,expr);
3020 NewOp(1101, rcop, 1, LOGOP);
3021 rcop->op_type = OP_REGCOMP;
3022 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3023 rcop->op_first = scalar(expr);
3024 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3025 ? (OPf_SPECIAL | OPf_KIDS)
3027 rcop->op_private = 1;
3030 /* establish postfix order */
3031 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3033 rcop->op_next = expr;
3034 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3037 rcop->op_next = LINKLIST(expr);
3038 expr->op_next = (OP*)rcop;
3041 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3046 if (pm->op_pmflags & PMf_EVAL) {
3048 if (CopLINE(PL_curcop) < PL_multi_end)
3049 CopLINE_set(PL_curcop, PL_multi_end);
3052 else if (repl->op_type == OP_THREADSV
3053 && strchr("&`'123456789+",
3054 PL_threadsv_names[repl->op_targ]))
3058 #endif /* USE_THREADS */
3059 else if (repl->op_type == OP_CONST)
3063 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3064 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3066 if (curop->op_type == OP_THREADSV) {
3068 if (strchr("&`'123456789+", curop->op_private))
3072 if (curop->op_type == OP_GV) {
3073 GV *gv = cGVOPx_gv(curop);
3075 if (strchr("&`'123456789+", *GvENAME(gv)))
3078 #endif /* USE_THREADS */
3079 else if (curop->op_type == OP_RV2CV)
3081 else if (curop->op_type == OP_RV2SV ||
3082 curop->op_type == OP_RV2AV ||
3083 curop->op_type == OP_RV2HV ||
3084 curop->op_type == OP_RV2GV) {
3085 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3088 else if (curop->op_type == OP_PADSV ||
3089 curop->op_type == OP_PADAV ||
3090 curop->op_type == OP_PADHV ||
3091 curop->op_type == OP_PADANY) {
3094 else if (curop->op_type == OP_PUSHRE)
3095 ; /* Okay here, dangerous in newASSIGNOP */
3105 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3106 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3107 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3108 prepend_elem(o->op_type, scalar(repl), o);
3111 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3112 pm->op_pmflags |= PMf_MAYBE_CONST;
3113 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3115 NewOp(1101, rcop, 1, LOGOP);
3116 rcop->op_type = OP_SUBSTCONT;
3117 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3118 rcop->op_first = scalar(repl);
3119 rcop->op_flags |= OPf_KIDS;
3120 rcop->op_private = 1;
3123 /* establish postfix order */
3124 rcop->op_next = LINKLIST(repl);
3125 repl->op_next = (OP*)rcop;
3127 pm->op_pmreplroot = scalar((OP*)rcop);
3128 pm->op_pmreplstart = LINKLIST(rcop);
3137 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3140 NewOp(1101, svop, 1, SVOP);
3141 svop->op_type = type;
3142 svop->op_ppaddr = PL_ppaddr[type];
3144 svop->op_next = (OP*)svop;
3145 svop->op_flags = flags;
3146 if (PL_opargs[type] & OA_RETSCALAR)
3148 if (PL_opargs[type] & OA_TARGET)
3149 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3150 return CHECKOP(type, svop);
3154 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3157 NewOp(1101, padop, 1, PADOP);
3158 padop->op_type = type;
3159 padop->op_ppaddr = PL_ppaddr[type];
3160 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3161 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3162 PL_curpad[padop->op_padix] = sv;
3164 padop->op_next = (OP*)padop;
3165 padop->op_flags = flags;
3166 if (PL_opargs[type] & OA_RETSCALAR)
3168 if (PL_opargs[type] & OA_TARGET)
3169 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3170 return CHECKOP(type, padop);
3174 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3178 return newPADOP(type, flags, SvREFCNT_inc(gv));
3180 return newSVOP(type, flags, SvREFCNT_inc(gv));
3185 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3188 NewOp(1101, pvop, 1, PVOP);
3189 pvop->op_type = type;
3190 pvop->op_ppaddr = PL_ppaddr[type];
3192 pvop->op_next = (OP*)pvop;
3193 pvop->op_flags = flags;
3194 if (PL_opargs[type] & OA_RETSCALAR)
3196 if (PL_opargs[type] & OA_TARGET)
3197 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3198 return CHECKOP(type, pvop);
3202 Perl_package(pTHX_ OP *o)
3206 save_hptr(&PL_curstash);
3207 save_item(PL_curstname);
3212 name = SvPV(sv, len);
3213 PL_curstash = gv_stashpvn(name,len,TRUE);
3214 sv_setpvn(PL_curstname, name, len);
3218 deprecate("\"package\" with no arguments");
3219 sv_setpv(PL_curstname,"<none>");
3220 PL_curstash = Nullhv;
3222 PL_hints |= HINT_BLOCK_SCOPE;
3223 PL_copline = NOLINE;
3228 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3233 char *packname = Nullch;
3237 if (id->op_type != OP_CONST)
3238 Perl_croak(aTHX_ "Module name must be constant");
3242 if (version != Nullop) {
3243 SV *vesv = ((SVOP*)version)->op_sv;
3245 if (arg == Nullop && !SvNIOKp(vesv)) {
3252 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3253 Perl_croak(aTHX_ "Version number must be constant number");
3255 /* Make copy of id so we don't free it twice */
3256 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3258 /* Fake up a method call to VERSION */
3259 meth = newSVpvn("VERSION",7);
3260 sv_upgrade(meth, SVt_PVIV);
3261 (void)SvIOK_on(meth);
3262 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3263 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3264 append_elem(OP_LIST,
3265 prepend_elem(OP_LIST, pack, list(version)),
3266 newSVOP(OP_METHOD_NAMED, 0, meth)));
3270 /* Fake up an import/unimport */
3271 if (arg && arg->op_type == OP_STUB)
3272 imop = arg; /* no import on explicit () */
3273 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3274 imop = Nullop; /* use 5.0; */
3279 /* Make copy of id so we don't free it twice */
3280 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3282 /* Fake up a method call to import/unimport */
3283 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3284 sv_upgrade(meth, SVt_PVIV);
3285 (void)SvIOK_on(meth);
3286 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3287 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3288 append_elem(OP_LIST,
3289 prepend_elem(OP_LIST, pack, list(arg)),
3290 newSVOP(OP_METHOD_NAMED, 0, meth)));
3293 if (ckWARN(WARN_MISC) &&
3294 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3295 SvPOK(packsv = ((SVOP*)id)->op_sv))
3297 /* BEGIN will free the ops, so we need to make a copy */
3298 packlen = SvCUR(packsv);
3299 packname = savepvn(SvPVX(packsv), packlen);
3302 /* Fake up the BEGIN {}, which does its thing immediately. */
3304 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3307 append_elem(OP_LINESEQ,
3308 append_elem(OP_LINESEQ,
3309 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3310 newSTATEOP(0, Nullch, veop)),
3311 newSTATEOP(0, Nullch, imop) ));
3314 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3315 Perl_warner(aTHX_ WARN_MISC,
3316 "Package `%s' not found "
3317 "(did you use the incorrect case?)", packname);
3322 PL_hints |= HINT_BLOCK_SCOPE;
3323 PL_copline = NOLINE;
3328 =for apidoc load_module
3330 Loads the module whose name is pointed to by the string part of name.
3331 Note that the actual module name, not its filename, should be given.
3332 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3333 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3334 (or 0 for no flags). ver, if specified, provides version semantics
3335 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3336 arguments can be used to specify arguments to the module's import()
3337 method, similar to C<use Foo::Bar VERSION LIST>.
3342 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3345 va_start(args, ver);
3346 vload_module(flags, name, ver, &args);
3350 #ifdef PERL_IMPLICIT_CONTEXT
3352 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3356 va_start(args, ver);
3357 vload_module(flags, name, ver, &args);
3363 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3365 OP *modname, *veop, *imop;
3367 modname = newSVOP(OP_CONST, 0, name);
3368 modname->op_private |= OPpCONST_BARE;
3370 veop = newSVOP(OP_CONST, 0, ver);
3374 if (flags & PERL_LOADMOD_NOIMPORT) {
3375 imop = sawparens(newNULLLIST());
3377 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3378 imop = va_arg(*args, OP*);
3383 sv = va_arg(*args, SV*);
3385 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3386 sv = va_arg(*args, SV*);
3390 line_t ocopline = PL_copline;
3391 int oexpect = PL_expect;
3393 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3394 veop, modname, imop);
3395 PL_expect = oexpect;
3396 PL_copline = ocopline;
3401 Perl_dofile(pTHX_ OP *term)
3406 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3407 if (!(gv && GvIMPORTED_CV(gv)))
3408 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3410 if (gv && GvIMPORTED_CV(gv)) {
3411 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3412 append_elem(OP_LIST, term,
3413 scalar(newUNOP(OP_RV2CV, 0,
3418 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3424 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3426 return newBINOP(OP_LSLICE, flags,
3427 list(force_list(subscript)),
3428 list(force_list(listval)) );
3432 S_list_assignment(pTHX_ register OP *o)
3437 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3438 o = cUNOPo->op_first;
3440 if (o->op_type == OP_COND_EXPR) {
3441 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3442 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3447 yyerror("Assignment to both a list and a scalar");
3451 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3452 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3453 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3456 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3459 if (o->op_type == OP_RV2SV)
3466 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3471 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3472 return newLOGOP(optype, 0,
3473 mod(scalar(left), optype),
3474 newUNOP(OP_SASSIGN, 0, scalar(right)));
3477 return newBINOP(optype, OPf_STACKED,
3478 mod(scalar(left), optype), scalar(right));
3482 if (list_assignment(left)) {
3486 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3487 left = mod(left, OP_AASSIGN);
3495 curop = list(force_list(left));
3496 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3497 o->op_private = 0 | (flags >> 8);
3498 for (curop = ((LISTOP*)curop)->op_first;
3499 curop; curop = curop->op_sibling)
3501 if (curop->op_type == OP_RV2HV &&
3502 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3503 o->op_private |= OPpASSIGN_HASH;
3507 if (!(left->op_private & OPpLVAL_INTRO)) {
3510 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3511 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3512 if (curop->op_type == OP_GV) {
3513 GV *gv = cGVOPx_gv(curop);
3514 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3516 SvCUR(gv) = PL_generation;
3518 else if (curop->op_type == OP_PADSV ||
3519 curop->op_type == OP_PADAV ||
3520 curop->op_type == OP_PADHV ||
3521 curop->op_type == OP_PADANY) {
3522 SV **svp = AvARRAY(PL_comppad_name);
3523 SV *sv = svp[curop->op_targ];
3524 if (SvCUR(sv) == PL_generation)
3526 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3528 else if (curop->op_type == OP_RV2CV)
3530 else if (curop->op_type == OP_RV2SV ||
3531 curop->op_type == OP_RV2AV ||
3532 curop->op_type == OP_RV2HV ||
3533 curop->op_type == OP_RV2GV) {
3534 if (lastop->op_type != OP_GV) /* funny deref? */
3537 else if (curop->op_type == OP_PUSHRE) {
3538 if (((PMOP*)curop)->op_pmreplroot) {
3540 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3542 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3544 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3546 SvCUR(gv) = PL_generation;
3555 o->op_private |= OPpASSIGN_COMMON;
3557 if (right && right->op_type == OP_SPLIT) {
3559 if ((tmpop = ((LISTOP*)right)->op_first) &&
3560 tmpop->op_type == OP_PUSHRE)
3562 PMOP *pm = (PMOP*)tmpop;
3563 if (left->op_type == OP_RV2AV &&
3564 !(left->op_private & OPpLVAL_INTRO) &&
3565 !(o->op_private & OPpASSIGN_COMMON) )
3567 tmpop = ((UNOP*)left)->op_first;
3568 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3570 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3571 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3573 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3574 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3576 pm->op_pmflags |= PMf_ONCE;
3577 tmpop = cUNOPo->op_first; /* to list (nulled) */
3578 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3579 tmpop->op_sibling = Nullop; /* don't free split */
3580 right->op_next = tmpop->op_next; /* fix starting loc */
3581 op_free(o); /* blow off assign */
3582 right->op_flags &= ~OPf_WANT;
3583 /* "I don't know and I don't care." */
3588 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3589 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3591 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3593 sv_setiv(sv, PL_modcount+1);
3601 right = newOP(OP_UNDEF, 0);
3602 if (right->op_type == OP_READLINE) {
3603 right->op_flags |= OPf_STACKED;
3604 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3607 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3608 o = newBINOP(OP_SASSIGN, flags,
3609 scalar(right), mod(scalar(left), OP_SASSIGN) );
3621 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3623 U32 seq = intro_my();
3626 NewOp(1101, cop, 1, COP);
3627 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3628 cop->op_type = OP_DBSTATE;
3629 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3632 cop->op_type = OP_NEXTSTATE;
3633 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3635 cop->op_flags = flags;
3636 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3638 cop->op_private |= NATIVE_HINTS;
3640 PL_compiling.op_private = cop->op_private;
3641 cop->op_next = (OP*)cop;
3644 cop->cop_label = label;
3645 PL_hints |= HINT_BLOCK_SCOPE;
3648 cop->cop_arybase = PL_curcop->cop_arybase;
3649 if (specialWARN(PL_curcop->cop_warnings))
3650 cop->cop_warnings = PL_curcop->cop_warnings ;
3652 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3653 if (specialCopIO(PL_curcop->cop_io))
3654 cop->cop_io = PL_curcop->cop_io;
3656 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3659 if (PL_copline == NOLINE)
3660 CopLINE_set(cop, CopLINE(PL_curcop));
3662 CopLINE_set(cop, PL_copline);
3663 PL_copline = NOLINE;
3666 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3668 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3670 CopSTASH_set(cop, PL_curstash);
3672 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3673 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3674 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3675 (void)SvIOK_on(*svp);
3676 SvIVX(*svp) = PTR2IV(cop);
3680 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3683 /* "Introduce" my variables to visible status. */
3691 if (! PL_min_intro_pending)
3692 return PL_cop_seqmax;
3694 svp = AvARRAY(PL_comppad_name);
3695 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3696 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3697 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3698 SvNVX(sv) = (NV)PL_cop_seqmax;
3701 PL_min_intro_pending = 0;
3702 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3703 return PL_cop_seqmax++;
3707 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3709 return new_logop(type, flags, &first, &other);
3713 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3717 OP *first = *firstp;
3718 OP *other = *otherp;
3720 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3721 return newBINOP(type, flags, scalar(first), scalar(other));
3723 scalarboolean(first);
3724 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3725 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3726 if (type == OP_AND || type == OP_OR) {
3732 first = *firstp = cUNOPo->op_first;
3734 first->op_next = o->op_next;
3735 cUNOPo->op_first = Nullop;
3739 if (first->op_type == OP_CONST) {
3740 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3741 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3742 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3753 else if (first->op_type == OP_WANTARRAY) {
3759 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3760 OP *k1 = ((UNOP*)first)->op_first;
3761 OP *k2 = k1->op_sibling;
3763 switch (first->op_type)
3766 if (k2 && k2->op_type == OP_READLINE
3767 && (k2->op_flags & OPf_STACKED)
3768 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3770 warnop = k2->op_type;
3775 if (k1->op_type == OP_READDIR
3776 || k1->op_type == OP_GLOB
3777 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3778 || k1->op_type == OP_EACH)
3780 warnop = ((k1->op_type == OP_NULL)
3781 ? k1->op_targ : k1->op_type);
3786 line_t oldline = CopLINE(PL_curcop);
3787 CopLINE_set(PL_curcop, PL_copline);
3788 Perl_warner(aTHX_ WARN_MISC,
3789 "Value of %s%s can be \"0\"; test with defined()",
3791 ((warnop == OP_READLINE || warnop == OP_GLOB)
3792 ? " construct" : "() operator"));
3793 CopLINE_set(PL_curcop, oldline);
3800 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3801 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3803 NewOp(1101, logop, 1, LOGOP);
3805 logop->op_type = type;
3806 logop->op_ppaddr = PL_ppaddr[type];
3807 logop->op_first = first;
3808 logop->op_flags = flags | OPf_KIDS;
3809 logop->op_other = LINKLIST(other);
3810 logop->op_private = 1 | (flags >> 8);
3812 /* establish postfix order */
3813 logop->op_next = LINKLIST(first);
3814 first->op_next = (OP*)logop;
3815 first->op_sibling = other;
3817 o = newUNOP(OP_NULL, 0, (OP*)logop);
3824 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3831 return newLOGOP(OP_AND, 0, first, trueop);
3833 return newLOGOP(OP_OR, 0, first, falseop);
3835 scalarboolean(first);
3836 if (first->op_type == OP_CONST) {
3837 if (SvTRUE(((SVOP*)first)->op_sv)) {
3848 else if (first->op_type == OP_WANTARRAY) {
3852 NewOp(1101, logop, 1, LOGOP);
3853 logop->op_type = OP_COND_EXPR;
3854 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3855 logop->op_first = first;
3856 logop->op_flags = flags | OPf_KIDS;
3857 logop->op_private = 1 | (flags >> 8);
3858 logop->op_other = LINKLIST(trueop);
3859 logop->op_next = LINKLIST(falseop);
3862 /* establish postfix order */
3863 start = LINKLIST(first);
3864 first->op_next = (OP*)logop;
3866 first->op_sibling = trueop;
3867 trueop->op_sibling = falseop;
3868 o = newUNOP(OP_NULL, 0, (OP*)logop);
3870 trueop->op_next = falseop->op_next = o;
3877 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3885 NewOp(1101, range, 1, LOGOP);
3887 range->op_type = OP_RANGE;
3888 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3889 range->op_first = left;
3890 range->op_flags = OPf_KIDS;
3891 leftstart = LINKLIST(left);
3892 range->op_other = LINKLIST(right);
3893 range->op_private = 1 | (flags >> 8);
3895 left->op_sibling = right;
3897 range->op_next = (OP*)range;
3898 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3899 flop = newUNOP(OP_FLOP, 0, flip);
3900 o = newUNOP(OP_NULL, 0, flop);
3902 range->op_next = leftstart;
3904 left->op_next = flip;
3905 right->op_next = flop;
3907 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3908 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3909 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3910 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3912 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3913 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3916 if (!flip->op_private || !flop->op_private)
3917 linklist(o); /* blow off optimizer unless constant */
3923 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3927 int once = block && block->op_flags & OPf_SPECIAL &&
3928 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3931 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3932 return block; /* do {} while 0 does once */
3933 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3934 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3935 expr = newUNOP(OP_DEFINED, 0,
3936 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3937 } else if (expr->op_flags & OPf_KIDS) {
3938 OP *k1 = ((UNOP*)expr)->op_first;
3939 OP *k2 = (k1) ? k1->op_sibling : NULL;
3940 switch (expr->op_type) {
3942 if (k2 && k2->op_type == OP_READLINE
3943 && (k2->op_flags & OPf_STACKED)
3944 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3945 expr = newUNOP(OP_DEFINED, 0, expr);
3949 if (k1->op_type == OP_READDIR
3950 || k1->op_type == OP_GLOB
3951 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3952 || k1->op_type == OP_EACH)
3953 expr = newUNOP(OP_DEFINED, 0, expr);
3959 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3960 o = new_logop(OP_AND, 0, &expr, &listop);
3963 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3965 if (once && o != listop)
3966 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3969 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3971 o->op_flags |= flags;
3973 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3978 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3986 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3987 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3988 expr = newUNOP(OP_DEFINED, 0,
3989 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3990 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3991 OP *k1 = ((UNOP*)expr)->op_first;
3992 OP *k2 = (k1) ? k1->op_sibling : NULL;
3993 switch (expr->op_type) {
3995 if (k2 && k2->op_type == OP_READLINE
3996 && (k2->op_flags & OPf_STACKED)
3997 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3998 expr = newUNOP(OP_DEFINED, 0, expr);
4002 if (k1->op_type == OP_READDIR
4003 || k1->op_type == OP_GLOB
4004 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4005 || k1->op_type == OP_EACH)
4006 expr = newUNOP(OP_DEFINED, 0, expr);
4012 block = newOP(OP_NULL, 0);
4014 block = scope(block);
4018 next = LINKLIST(cont);
4021 OP *unstack = newOP(OP_UNSTACK, 0);
4024 cont = append_elem(OP_LINESEQ, cont, unstack);
4025 if ((line_t)whileline != NOLINE) {
4026 PL_copline = whileline;
4027 cont = append_elem(OP_LINESEQ, cont,
4028 newSTATEOP(0, Nullch, Nullop));
4032 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4033 redo = LINKLIST(listop);
4036 PL_copline = whileline;
4038 o = new_logop(OP_AND, 0, &expr, &listop);
4039 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4040 op_free(expr); /* oops, it's a while (0) */
4042 return Nullop; /* listop already freed by new_logop */
4045 ((LISTOP*)listop)->op_last->op_next =
4046 (o == listop ? redo : LINKLIST(o));
4052 NewOp(1101,loop,1,LOOP);
4053 loop->op_type = OP_ENTERLOOP;
4054 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4055 loop->op_private = 0;
4056 loop->op_next = (OP*)loop;
4059 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4061 loop->op_redoop = redo;
4062 loop->op_lastop = o;
4063 o->op_private |= loopflags;
4066 loop->op_nextop = next;
4068 loop->op_nextop = o;
4070 o->op_flags |= flags;
4071 o->op_private |= (flags >> 8);
4076 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4084 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4085 sv->op_type = OP_RV2GV;
4086 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4088 else if (sv->op_type == OP_PADSV) { /* private variable */
4089 padoff = sv->op_targ;
4094 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4095 padoff = sv->op_targ;
4097 iterflags |= OPf_SPECIAL;
4102 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4106 padoff = find_threadsv("_");
4107 iterflags |= OPf_SPECIAL;
4109 sv = newGVOP(OP_GV, 0, PL_defgv);
4112 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4113 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4114 iterflags |= OPf_STACKED;
4116 else if (expr->op_type == OP_NULL &&
4117 (expr->op_flags & OPf_KIDS) &&
4118 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4120 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4121 * set the STACKED flag to indicate that these values are to be
4122 * treated as min/max values by 'pp_iterinit'.
4124 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4125 LOGOP* range = (LOGOP*) flip->op_first;
4126 OP* left = range->op_first;
4127 OP* right = left->op_sibling;
4130 range->op_flags &= ~OPf_KIDS;
4131 range->op_first = Nullop;
4133 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4134 listop->op_first->op_next = range->op_next;
4135 left->op_next = range->op_other;
4136 right->op_next = (OP*)listop;
4137 listop->op_next = listop->op_first;
4140 expr = (OP*)(listop);
4142 iterflags |= OPf_STACKED;
4145 expr = mod(force_list(expr), OP_GREPSTART);
4149 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4150 append_elem(OP_LIST, expr, scalar(sv))));
4151 assert(!loop->op_next);
4152 #ifdef PL_OP_SLAB_ALLOC
4155 NewOp(1234,tmp,1,LOOP);
4156 Copy(loop,tmp,1,LOOP);
4160 Renew(loop, 1, LOOP);
4162 loop->op_targ = padoff;
4163 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4164 PL_copline = forline;
4165 return newSTATEOP(0, label, wop);
4169 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4174 if (type != OP_GOTO || label->op_type == OP_CONST) {
4175 /* "last()" means "last" */
4176 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4177 o = newOP(type, OPf_SPECIAL);
4179 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4180 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4186 if (label->op_type == OP_ENTERSUB)
4187 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4188 o = newUNOP(type, OPf_STACKED, label);
4190 PL_hints |= HINT_BLOCK_SCOPE;
4195 Perl_cv_undef(pTHX_ CV *cv)
4199 MUTEX_DESTROY(CvMUTEXP(cv));
4200 Safefree(CvMUTEXP(cv));
4203 #endif /* USE_THREADS */
4206 if (CvFILE(cv) && !CvXSUB(cv)) {
4207 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4208 Safefree(CvFILE(cv));
4213 if (!CvXSUB(cv) && CvROOT(cv)) {
4215 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4216 Perl_croak(aTHX_ "Can't undef active subroutine");
4219 Perl_croak(aTHX_ "Can't undef active subroutine");
4220 #endif /* USE_THREADS */
4223 SAVEVPTR(PL_curpad);
4226 op_free(CvROOT(cv));
4227 CvROOT(cv) = Nullop;
4230 SvPOK_off((SV*)cv); /* forget prototype */
4232 /* Since closure prototypes have the same lifetime as the containing
4233 * CV, they don't hold a refcount on the outside CV. This avoids
4234 * the refcount loop between the outer CV (which keeps a refcount to
4235 * the closure prototype in the pad entry for pp_anoncode()) and the
4236 * closure prototype, and the ensuing memory leak. This does not
4237 * apply to closures generated within eval"", since eval"" CVs are
4238 * ephemeral. --GSAR */
4239 if (!CvANON(cv) || CvCLONED(cv)
4240 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4241 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4243 SvREFCNT_dec(CvOUTSIDE(cv));
4245 CvOUTSIDE(cv) = Nullcv;
4247 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4250 if (CvPADLIST(cv)) {
4251 /* may be during global destruction */
4252 if (SvREFCNT(CvPADLIST(cv))) {
4253 I32 i = AvFILLp(CvPADLIST(cv));
4255 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4256 SV* sv = svp ? *svp : Nullsv;
4259 if (sv == (SV*)PL_comppad_name)
4260 PL_comppad_name = Nullav;
4261 else if (sv == (SV*)PL_comppad) {
4262 PL_comppad = Nullav;
4263 PL_curpad = Null(SV**);
4267 SvREFCNT_dec((SV*)CvPADLIST(cv));
4269 CvPADLIST(cv) = Nullav;
4277 #ifdef DEBUG_CLOSURES
4279 S_cv_dump(pTHX_ CV *cv)
4282 CV *outside = CvOUTSIDE(cv);
4283 AV* padlist = CvPADLIST(cv);
4290 PerlIO_printf(Perl_debug_log,
4291 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4293 (CvANON(cv) ? "ANON"
4294 : (cv == PL_main_cv) ? "MAIN"
4295 : CvUNIQUE(cv) ? "UNIQUE"
4296 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4299 : CvANON(outside) ? "ANON"
4300 : (outside == PL_main_cv) ? "MAIN"
4301 : CvUNIQUE(outside) ? "UNIQUE"
4302 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4307 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4308 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4309 pname = AvARRAY(pad_name);
4310 ppad = AvARRAY(pad);
4312 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4313 if (SvPOK(pname[ix]))
4314 PerlIO_printf(Perl_debug_log,
4315 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4316 (int)ix, PTR2UV(ppad[ix]),
4317 SvFAKE(pname[ix]) ? "FAKE " : "",
4319 (IV)I_32(SvNVX(pname[ix])),
4322 #endif /* DEBUGGING */
4324 #endif /* DEBUG_CLOSURES */
4327 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4331 AV* protopadlist = CvPADLIST(proto);
4332 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4333 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4334 SV** pname = AvARRAY(protopad_name);
4335 SV** ppad = AvARRAY(protopad);
4336 I32 fname = AvFILLp(protopad_name);
4337 I32 fpad = AvFILLp(protopad);
4341 assert(!CvUNIQUE(proto));
4345 SAVESPTR(PL_comppad_name);
4346 SAVESPTR(PL_compcv);
4348 cv = PL_compcv = (CV*)NEWSV(1104,0);
4349 sv_upgrade((SV *)cv, SvTYPE(proto));
4350 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4354 New(666, CvMUTEXP(cv), 1, perl_mutex);
4355 MUTEX_INIT(CvMUTEXP(cv));
4357 #endif /* USE_THREADS */
4359 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4360 : savepv(CvFILE(proto));
4362 CvFILE(cv) = CvFILE(proto);
4364 CvGV(cv) = CvGV(proto);
4365 CvSTASH(cv) = CvSTASH(proto);
4366 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4367 CvSTART(cv) = CvSTART(proto);
4369 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4372 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4374 PL_comppad_name = newAV();
4375 for (ix = fname; ix >= 0; ix--)
4376 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4378 PL_comppad = newAV();
4380 comppadlist = newAV();
4381 AvREAL_off(comppadlist);
4382 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4383 av_store(comppadlist, 1, (SV*)PL_comppad);
4384 CvPADLIST(cv) = comppadlist;
4385 av_fill(PL_comppad, AvFILLp(protopad));
4386 PL_curpad = AvARRAY(PL_comppad);
4388 av = newAV(); /* will be @_ */
4390 av_store(PL_comppad, 0, (SV*)av);
4391 AvFLAGS(av) = AVf_REIFY;
4393 for (ix = fpad; ix > 0; ix--) {
4394 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4395 if (namesv && namesv != &PL_sv_undef) {
4396 char *name = SvPVX(namesv); /* XXX */
4397 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4398 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4399 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4401 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4403 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4405 else { /* our own lexical */
4408 /* anon code -- we'll come back for it */
4409 sv = SvREFCNT_inc(ppad[ix]);
4411 else if (*name == '@')
4413 else if (*name == '%')
4422 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4423 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4426 SV* sv = NEWSV(0,0);
4432 /* Now that vars are all in place, clone nested closures. */
4434 for (ix = fpad; ix > 0; ix--) {
4435 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4437 && namesv != &PL_sv_undef
4438 && !(SvFLAGS(namesv) & SVf_FAKE)
4439 && *SvPVX(namesv) == '&'
4440 && CvCLONE(ppad[ix]))
4442 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4443 SvREFCNT_dec(ppad[ix]);
4446 PL_curpad[ix] = (SV*)kid;
4450 #ifdef DEBUG_CLOSURES
4451 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4453 PerlIO_printf(Perl_debug_log, " from:\n");
4455 PerlIO_printf(Perl_debug_log, " to:\n");
4462 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4464 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4466 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4473 Perl_cv_clone(pTHX_ CV *proto)
4476 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4477 cv = cv_clone2(proto, CvOUTSIDE(proto));
4478 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4483 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4485 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4486 SV* msg = sv_newmortal();
4490 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4491 sv_setpv(msg, "Prototype mismatch:");
4493 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4495 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4496 sv_catpv(msg, " vs ");
4498 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4500 sv_catpv(msg, "none");
4501 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4505 static void const_sv_xsub(pTHXo_ CV* cv);
4508 =for apidoc cv_const_sv
4510 If C<cv> is a constant sub eligible for inlining. returns the constant
4511 value returned by the sub. Otherwise, returns NULL.
4513 Constant subs can be created with C<newCONSTSUB> or as described in
4514 L<perlsub/"Constant Functions">.
4519 Perl_cv_const_sv(pTHX_ CV *cv)
4521 if (!cv || !CvCONST(cv))
4523 return (SV*)CvXSUBANY(cv).any_ptr;
4527 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4534 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4535 o = cLISTOPo->op_first->op_sibling;
4537 for (; o; o = o->op_next) {
4538 OPCODE type = o->op_type;
4540 if (sv && o->op_next == o)
4542 if (o->op_next != o) {
4543 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4545 if (type == OP_DBSTATE)
4548 if (type == OP_LEAVESUB || type == OP_RETURN)
4552 if (type == OP_CONST && cSVOPo->op_sv)
4554 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4555 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4556 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4560 /* We get here only from cv_clone2() while creating a closure.
4561 Copy the const value here instead of in cv_clone2 so that
4562 SvREADONLY_on doesn't lead to problems when leaving
4567 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4579 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4589 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4593 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4595 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4599 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4605 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4610 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4611 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4612 SV *sv = sv_newmortal();
4613 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4614 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4619 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4620 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4630 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4631 maximum a prototype before. */
4632 if (SvTYPE(gv) > SVt_NULL) {
4633 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4634 && ckWARN_d(WARN_PROTOTYPE))
4636 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4638 cv_ckproto((CV*)gv, NULL, ps);
4641 sv_setpv((SV*)gv, ps);
4643 sv_setiv((SV*)gv, -1);
4644 SvREFCNT_dec(PL_compcv);
4645 cv = PL_compcv = NULL;
4646 PL_sub_generation++;
4650 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4652 #ifdef GV_UNIQUE_CHECK
4653 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4654 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4658 if (!block || !ps || *ps || attrs)
4661 const_sv = op_const_sv(block, Nullcv);
4664 bool exists = CvROOT(cv) || CvXSUB(cv);
4666 #ifdef GV_UNIQUE_CHECK
4667 if (exists && GvUNIQUE(gv)) {
4668 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4672 /* if the subroutine doesn't exist and wasn't pre-declared
4673 * with a prototype, assume it will be AUTOLOADed,
4674 * skipping the prototype check
4676 if (exists || SvPOK(cv))
4677 cv_ckproto(cv, gv, ps);
4678 /* already defined (or promised)? */
4679 if (exists || GvASSUMECV(gv)) {
4680 if (!block && !attrs) {
4681 /* just a "sub foo;" when &foo is already defined */
4682 SAVEFREESV(PL_compcv);
4685 /* ahem, death to those who redefine active sort subs */
4686 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4687 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4689 if (ckWARN(WARN_REDEFINE)
4691 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4693 line_t oldline = CopLINE(PL_curcop);
4694 CopLINE_set(PL_curcop, PL_copline);
4695 Perl_warner(aTHX_ WARN_REDEFINE,
4696 CvCONST(cv) ? "Constant subroutine %s redefined"
4697 : "Subroutine %s redefined", name);
4698 CopLINE_set(PL_curcop, oldline);
4706 SvREFCNT_inc(const_sv);
4708 assert(!CvROOT(cv) && !CvCONST(cv));
4709 sv_setpv((SV*)cv, ""); /* prototype is "" */
4710 CvXSUBANY(cv).any_ptr = const_sv;
4711 CvXSUB(cv) = const_sv_xsub;
4716 cv = newCONSTSUB(NULL, name, const_sv);
4719 SvREFCNT_dec(PL_compcv);
4721 PL_sub_generation++;
4728 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4729 * before we clobber PL_compcv.
4733 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4734 stash = GvSTASH(CvGV(cv));
4735 else if (CvSTASH(cv))
4736 stash = CvSTASH(cv);
4738 stash = PL_curstash;
4741 /* possibly about to re-define existing subr -- ignore old cv */
4742 rcv = (SV*)PL_compcv;
4743 if (name && GvSTASH(gv))
4744 stash = GvSTASH(gv);
4746 stash = PL_curstash;
4748 apply_attrs(stash, rcv, attrs);
4750 if (cv) { /* must reuse cv if autoloaded */
4752 /* got here with just attrs -- work done, so bug out */
4753 SAVEFREESV(PL_compcv);
4757 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4758 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4759 CvOUTSIDE(PL_compcv) = 0;
4760 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4761 CvPADLIST(PL_compcv) = 0;
4762 /* inner references to PL_compcv must be fixed up ... */
4764 AV *padlist = CvPADLIST(cv);
4765 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4766 AV *comppad = (AV*)AvARRAY(padlist)[1];
4767 SV **namepad = AvARRAY(comppad_name);
4768 SV **curpad = AvARRAY(comppad);
4769 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4770 SV *namesv = namepad[ix];
4771 if (namesv && namesv != &PL_sv_undef
4772 && *SvPVX(namesv) == '&')
4774 CV *innercv = (CV*)curpad[ix];
4775 if (CvOUTSIDE(innercv) == PL_compcv) {
4776 CvOUTSIDE(innercv) = cv;
4777 if (!CvANON(innercv) || CvCLONED(innercv)) {
4778 (void)SvREFCNT_inc(cv);
4779 SvREFCNT_dec(PL_compcv);
4785 /* ... before we throw it away */
4786 SvREFCNT_dec(PL_compcv);
4787 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4788 ++PL_sub_generation;
4795 PL_sub_generation++;
4799 CvFILE_set_from_cop(cv, PL_curcop);
4800 CvSTASH(cv) = PL_curstash;
4803 if (!CvMUTEXP(cv)) {
4804 New(666, CvMUTEXP(cv), 1, perl_mutex);
4805 MUTEX_INIT(CvMUTEXP(cv));
4807 #endif /* USE_THREADS */
4810 sv_setpv((SV*)cv, ps);
4812 if (PL_error_count) {
4816 char *s = strrchr(name, ':');
4818 if (strEQ(s, "BEGIN")) {
4820 "BEGIN not safe after errors--compilation aborted";
4821 if (PL_in_eval & EVAL_KEEPERR)
4822 Perl_croak(aTHX_ not_safe);
4824 /* force display of errors found but not reported */
4825 sv_catpv(ERRSV, not_safe);
4826 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4834 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4835 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4838 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4839 mod(scalarseq(block), OP_LEAVESUBLV));
4842 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4844 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4845 OpREFCNT_set(CvROOT(cv), 1);
4846 CvSTART(cv) = LINKLIST(CvROOT(cv));
4847 CvROOT(cv)->op_next = 0;
4848 CALL_PEEP(CvSTART(cv));
4850 /* now that optimizer has done its work, adjust pad values */
4852 SV **namep = AvARRAY(PL_comppad_name);
4853 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4856 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4859 * The only things that a clonable function needs in its
4860 * pad are references to outer lexicals and anonymous subs.
4861 * The rest are created anew during cloning.
4863 if (!((namesv = namep[ix]) != Nullsv &&
4864 namesv != &PL_sv_undef &&
4866 *SvPVX(namesv) == '&')))
4868 SvREFCNT_dec(PL_curpad[ix]);
4869 PL_curpad[ix] = Nullsv;
4872 assert(!CvCONST(cv));
4873 if (ps && !*ps && op_const_sv(block, cv))
4877 AV *av = newAV(); /* Will be @_ */
4879 av_store(PL_comppad, 0, (SV*)av);
4880 AvFLAGS(av) = AVf_REIFY;
4882 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4883 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4885 if (!SvPADMY(PL_curpad[ix]))
4886 SvPADTMP_on(PL_curpad[ix]);
4890 /* If a potential closure prototype, don't keep a refcount on
4891 * outer CV, unless the latter happens to be a passing eval"".
4892 * This is okay as the lifetime of the prototype is tied to the
4893 * lifetime of the outer CV. Avoids memory leak due to reference
4895 if (!name && CvOUTSIDE(cv)
4896 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4897 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4899 SvREFCNT_dec(CvOUTSIDE(cv));
4902 if (name || aname) {
4904 char *tname = (name ? name : aname);
4906 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4907 SV *sv = NEWSV(0,0);
4908 SV *tmpstr = sv_newmortal();
4909 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4913 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4915 (long)PL_subline, (long)CopLINE(PL_curcop));
4916 gv_efullname3(tmpstr, gv, Nullch);
4917 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4918 hv = GvHVn(db_postponed);
4919 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4920 && (pcv = GvCV(db_postponed)))
4926 call_sv((SV*)pcv, G_DISCARD);
4930 if ((s = strrchr(tname,':')))
4935 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4938 if (strEQ(s, "BEGIN")) {
4939 I32 oldscope = PL_scopestack_ix;
4941 SAVECOPFILE(&PL_compiling);
4942 SAVECOPLINE(&PL_compiling);
4944 sv_setsv(PL_rs, PL_nrs);
4947 PL_beginav = newAV();
4948 DEBUG_x( dump_sub(gv) );
4949 av_push(PL_beginav, (SV*)cv);
4950 GvCV(gv) = 0; /* cv has been hijacked */
4951 call_list(oldscope, PL_beginav);
4953 PL_curcop = &PL_compiling;
4954 PL_compiling.op_private = PL_hints;
4957 else if (strEQ(s, "END") && !PL_error_count) {
4960 DEBUG_x( dump_sub(gv) );
4961 av_unshift(PL_endav, 1);
4962 av_store(PL_endav, 0, (SV*)cv);
4963 GvCV(gv) = 0; /* cv has been hijacked */
4965 else if (strEQ(s, "CHECK") && !PL_error_count) {
4967 PL_checkav = newAV();
4968 DEBUG_x( dump_sub(gv) );
4969 if (PL_main_start && ckWARN(WARN_VOID))
4970 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4971 av_unshift(PL_checkav, 1);
4972 av_store(PL_checkav, 0, (SV*)cv);
4973 GvCV(gv) = 0; /* cv has been hijacked */
4975 else if (strEQ(s, "INIT") && !PL_error_count) {
4977 PL_initav = newAV();
4978 DEBUG_x( dump_sub(gv) );
4979 if (PL_main_start && ckWARN(WARN_VOID))
4980 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4981 av_push(PL_initav, (SV*)cv);
4982 GvCV(gv) = 0; /* cv has been hijacked */
4987 PL_copline = NOLINE;
4992 /* XXX unsafe for threads if eval_owner isn't held */
4994 =for apidoc newCONSTSUB
4996 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4997 eligible for inlining at compile-time.
5003 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5009 SAVECOPLINE(PL_curcop);
5010 CopLINE_set(PL_curcop, PL_copline);
5013 PL_hints &= ~HINT_BLOCK_SCOPE;
5016 SAVESPTR(PL_curstash);
5017 SAVECOPSTASH(PL_curcop);
5018 PL_curstash = stash;
5020 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5022 CopSTASH(PL_curcop) = stash;
5026 cv = newXS(name, const_sv_xsub, __FILE__);
5027 CvXSUBANY(cv).any_ptr = sv;
5029 sv_setpv((SV*)cv, ""); /* prototype is "" */
5037 =for apidoc U||newXS
5039 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5045 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5047 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5050 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5052 /* just a cached method */
5056 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5057 /* already defined (or promised) */
5058 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5059 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5060 line_t oldline = CopLINE(PL_curcop);
5061 if (PL_copline != NOLINE)
5062 CopLINE_set(PL_curcop, PL_copline);
5063 Perl_warner(aTHX_ WARN_REDEFINE,
5064 CvCONST(cv) ? "Constant subroutine %s redefined"
5065 : "Subroutine %s redefined"
5067 CopLINE_set(PL_curcop, oldline);
5074 if (cv) /* must reuse cv if autoloaded */
5077 cv = (CV*)NEWSV(1105,0);
5078 sv_upgrade((SV *)cv, SVt_PVCV);
5082 PL_sub_generation++;
5087 New(666, CvMUTEXP(cv), 1, perl_mutex);
5088 MUTEX_INIT(CvMUTEXP(cv));
5090 #endif /* USE_THREADS */
5091 (void)gv_fetchfile(filename);
5092 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5093 an external constant string */
5094 CvXSUB(cv) = subaddr;
5097 char *s = strrchr(name,':');
5103 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5106 if (strEQ(s, "BEGIN")) {
5108 PL_beginav = newAV();
5109 av_push(PL_beginav, (SV*)cv);
5110 GvCV(gv) = 0; /* cv has been hijacked */
5112 else if (strEQ(s, "END")) {
5115 av_unshift(PL_endav, 1);
5116 av_store(PL_endav, 0, (SV*)cv);
5117 GvCV(gv) = 0; /* cv has been hijacked */
5119 else if (strEQ(s, "CHECK")) {
5121 PL_checkav = newAV();
5122 if (PL_main_start && ckWARN(WARN_VOID))
5123 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5124 av_unshift(PL_checkav, 1);
5125 av_store(PL_checkav, 0, (SV*)cv);
5126 GvCV(gv) = 0; /* cv has been hijacked */
5128 else if (strEQ(s, "INIT")) {
5130 PL_initav = newAV();
5131 if (PL_main_start && ckWARN(WARN_VOID))
5132 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5133 av_push(PL_initav, (SV*)cv);
5134 GvCV(gv) = 0; /* cv has been hijacked */
5145 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5154 name = SvPVx(cSVOPo->op_sv, n_a);
5157 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5158 #ifdef GV_UNIQUE_CHECK
5160 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5164 if ((cv = GvFORM(gv))) {
5165 if (ckWARN(WARN_REDEFINE)) {
5166 line_t oldline = CopLINE(PL_curcop);
5168 CopLINE_set(PL_curcop, PL_copline);
5169 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5170 CopLINE_set(PL_curcop, oldline);
5177 CvFILE_set_from_cop(cv, PL_curcop);
5179 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5180 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5181 SvPADTMP_on(PL_curpad[ix]);
5184 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5185 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5186 OpREFCNT_set(CvROOT(cv), 1);
5187 CvSTART(cv) = LINKLIST(CvROOT(cv));
5188 CvROOT(cv)->op_next = 0;
5189 CALL_PEEP(CvSTART(cv));
5191 PL_copline = NOLINE;
5196 Perl_newANONLIST(pTHX_ OP *o)
5198 return newUNOP(OP_REFGEN, 0,
5199 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5203 Perl_newANONHASH(pTHX_ OP *o)
5205 return newUNOP(OP_REFGEN, 0,
5206 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5210 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5212 return newANONATTRSUB(floor, proto, Nullop, block);
5216 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5218 return newUNOP(OP_REFGEN, 0,
5219 newSVOP(OP_ANONCODE, 0,
5220 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5224 Perl_oopsAV(pTHX_ OP *o)
5226 switch (o->op_type) {
5228 o->op_type = OP_PADAV;
5229 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5230 return ref(o, OP_RV2AV);
5233 o->op_type = OP_RV2AV;
5234 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5239 if (ckWARN_d(WARN_INTERNAL))
5240 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5247 Perl_oopsHV(pTHX_ OP *o)
5249 switch (o->op_type) {
5252 o->op_type = OP_PADHV;
5253 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5254 return ref(o, OP_RV2HV);
5258 o->op_type = OP_RV2HV;
5259 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5264 if (ckWARN_d(WARN_INTERNAL))
5265 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5272 Perl_newAVREF(pTHX_ OP *o)
5274 if (o->op_type == OP_PADANY) {
5275 o->op_type = OP_PADAV;
5276 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5279 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5280 && ckWARN(WARN_DEPRECATED)) {
5281 Perl_warner(aTHX_ WARN_DEPRECATED,
5282 "Using an array as a reference is deprecated");
5284 return newUNOP(OP_RV2AV, 0, scalar(o));
5288 Perl_newGVREF(pTHX_ I32 type, OP *o)
5290 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5291 return newUNOP(OP_NULL, 0, o);
5292 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5296 Perl_newHVREF(pTHX_ OP *o)
5298 if (o->op_type == OP_PADANY) {
5299 o->op_type = OP_PADHV;
5300 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5303 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5304 && ckWARN(WARN_DEPRECATED)) {
5305 Perl_warner(aTHX_ WARN_DEPRECATED,
5306 "Using a hash as a reference is deprecated");
5308 return newUNOP(OP_RV2HV, 0, scalar(o));
5312 Perl_oopsCV(pTHX_ OP *o)
5314 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5320 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5322 return newUNOP(OP_RV2CV, flags, scalar(o));
5326 Perl_newSVREF(pTHX_ OP *o)
5328 if (o->op_type == OP_PADANY) {
5329 o->op_type = OP_PADSV;
5330 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5333 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5334 o->op_flags |= OPpDONE_SVREF;
5337 return newUNOP(OP_RV2SV, 0, scalar(o));
5340 /* Check routines. */
5343 Perl_ck_anoncode(pTHX_ OP *o)
5348 name = NEWSV(1106,0);
5349 sv_upgrade(name, SVt_PVNV);
5350 sv_setpvn(name, "&", 1);
5353 ix = pad_alloc(o->op_type, SVs_PADMY);
5354 av_store(PL_comppad_name, ix, name);
5355 av_store(PL_comppad, ix, cSVOPo->op_sv);
5356 SvPADMY_on(cSVOPo->op_sv);
5357 cSVOPo->op_sv = Nullsv;
5358 cSVOPo->op_targ = ix;
5363 Perl_ck_bitop(pTHX_ OP *o)
5365 o->op_private = PL_hints;
5370 Perl_ck_concat(pTHX_ OP *o)
5372 if (cUNOPo->op_first->op_type == OP_CONCAT)
5373 o->op_flags |= OPf_STACKED;
5378 Perl_ck_spair(pTHX_ OP *o)
5380 if (o->op_flags & OPf_KIDS) {
5383 OPCODE type = o->op_type;
5384 o = modkids(ck_fun(o), type);
5385 kid = cUNOPo->op_first;
5386 newop = kUNOP->op_first->op_sibling;
5388 (newop->op_sibling ||
5389 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5390 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5391 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5395 op_free(kUNOP->op_first);
5396 kUNOP->op_first = newop;
5398 o->op_ppaddr = PL_ppaddr[++o->op_type];
5403 Perl_ck_delete(pTHX_ OP *o)
5407 if (o->op_flags & OPf_KIDS) {
5408 OP *kid = cUNOPo->op_first;
5409 switch (kid->op_type) {
5411 o->op_flags |= OPf_SPECIAL;
5414 o->op_private |= OPpSLICE;
5417 o->op_flags |= OPf_SPECIAL;
5422 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5423 PL_op_desc[o->op_type]);
5431 Perl_ck_eof(pTHX_ OP *o)
5433 I32 type = o->op_type;
5435 if (o->op_flags & OPf_KIDS) {
5436 if (cLISTOPo->op_first->op_type == OP_STUB) {
5438 o = newUNOP(type, OPf_SPECIAL,
5439 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5447 Perl_ck_eval(pTHX_ OP *o)
5449 PL_hints |= HINT_BLOCK_SCOPE;
5450 if (o->op_flags & OPf_KIDS) {
5451 SVOP *kid = (SVOP*)cUNOPo->op_first;
5454 o->op_flags &= ~OPf_KIDS;
5457 else if (kid->op_type == OP_LINESEQ) {
5460 kid->op_next = o->op_next;
5461 cUNOPo->op_first = 0;
5464 NewOp(1101, enter, 1, LOGOP);
5465 enter->op_type = OP_ENTERTRY;
5466 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5467 enter->op_private = 0;
5469 /* establish postfix order */
5470 enter->op_next = (OP*)enter;
5472 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5473 o->op_type = OP_LEAVETRY;
5474 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5475 enter->op_other = o;
5483 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5485 o->op_targ = (PADOFFSET)PL_hints;
5490 Perl_ck_exit(pTHX_ OP *o)
5493 HV *table = GvHV(PL_hintgv);
5495 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5496 if (svp && *svp && SvTRUE(*svp))
5497 o->op_private |= OPpEXIT_VMSISH;
5504 Perl_ck_exec(pTHX_ OP *o)
5507 if (o->op_flags & OPf_STACKED) {
5509 kid = cUNOPo->op_first->op_sibling;
5510 if (kid->op_type == OP_RV2GV)
5519 Perl_ck_exists(pTHX_ OP *o)
5522 if (o->op_flags & OPf_KIDS) {
5523 OP *kid = cUNOPo->op_first;
5524 if (kid->op_type == OP_ENTERSUB) {
5525 (void) ref(kid, o->op_type);
5526 if (kid->op_type != OP_RV2CV && !PL_error_count)
5527 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5528 PL_op_desc[o->op_type]);
5529 o->op_private |= OPpEXISTS_SUB;
5531 else if (kid->op_type == OP_AELEM)
5532 o->op_flags |= OPf_SPECIAL;
5533 else if (kid->op_type != OP_HELEM)
5534 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5535 PL_op_desc[o->op_type]);
5543 Perl_ck_gvconst(pTHX_ register OP *o)
5545 o = fold_constants(o);
5546 if (o->op_type == OP_CONST)
5553 Perl_ck_rvconst(pTHX_ register OP *o)
5555 SVOP *kid = (SVOP*)cUNOPo->op_first;
5557 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5558 if (kid->op_type == OP_CONST) {
5562 SV *kidsv = kid->op_sv;
5565 /* Is it a constant from cv_const_sv()? */
5566 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5567 SV *rsv = SvRV(kidsv);
5568 int svtype = SvTYPE(rsv);
5569 char *badtype = Nullch;
5571 switch (o->op_type) {
5573 if (svtype > SVt_PVMG)
5574 badtype = "a SCALAR";
5577 if (svtype != SVt_PVAV)
5578 badtype = "an ARRAY";
5581 if (svtype != SVt_PVHV) {
5582 if (svtype == SVt_PVAV) { /* pseudohash? */
5583 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5584 if (ksv && SvROK(*ksv)
5585 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5594 if (svtype != SVt_PVCV)
5599 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5602 name = SvPV(kidsv, n_a);
5603 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5604 char *badthing = Nullch;
5605 switch (o->op_type) {
5607 badthing = "a SCALAR";
5610 badthing = "an ARRAY";
5613 badthing = "a HASH";
5618 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5622 * This is a little tricky. We only want to add the symbol if we
5623 * didn't add it in the lexer. Otherwise we get duplicate strict
5624 * warnings. But if we didn't add it in the lexer, we must at
5625 * least pretend like we wanted to add it even if it existed before,
5626 * or we get possible typo warnings. OPpCONST_ENTERED says
5627 * whether the lexer already added THIS instance of this symbol.
5629 iscv = (o->op_type == OP_RV2CV) * 2;
5631 gv = gv_fetchpv(name,
5632 iscv | !(kid->op_private & OPpCONST_ENTERED),
5635 : o->op_type == OP_RV2SV
5637 : o->op_type == OP_RV2AV
5639 : o->op_type == OP_RV2HV
5642 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5644 kid->op_type = OP_GV;
5645 SvREFCNT_dec(kid->op_sv);
5647 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5648 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5649 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5651 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5653 kid->op_sv = SvREFCNT_inc(gv);
5655 kid->op_private = 0;
5656 kid->op_ppaddr = PL_ppaddr[OP_GV];
5663 Perl_ck_ftst(pTHX_ OP *o)
5665 I32 type = o->op_type;
5667 if (o->op_flags & OPf_REF) {
5670 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5671 SVOP *kid = (SVOP*)cUNOPo->op_first;
5673 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5675 OP *newop = newGVOP(type, OPf_REF,
5676 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5683 if (type == OP_FTTTY)
5684 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5687 o = newUNOP(type, 0, newDEFSVOP());
5693 Perl_ck_fun(pTHX_ OP *o)
5699 int type = o->op_type;
5700 register I32 oa = PL_opargs[type] >> OASHIFT;
5702 if (o->op_flags & OPf_STACKED) {
5703 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5706 return no_fh_allowed(o);
5709 if (o->op_flags & OPf_KIDS) {
5711 tokid = &cLISTOPo->op_first;
5712 kid = cLISTOPo->op_first;
5713 if (kid->op_type == OP_PUSHMARK ||
5714 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5716 tokid = &kid->op_sibling;
5717 kid = kid->op_sibling;
5719 if (!kid && PL_opargs[type] & OA_DEFGV)
5720 *tokid = kid = newDEFSVOP();
5724 sibl = kid->op_sibling;
5727 /* list seen where single (scalar) arg expected? */
5728 if (numargs == 1 && !(oa >> 4)
5729 && kid->op_type == OP_LIST && type != OP_SCALAR)
5731 return too_many_arguments(o,PL_op_desc[type]);
5744 if ((type == OP_PUSH || type == OP_UNSHIFT)
5745 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5746 Perl_warner(aTHX_ WARN_SYNTAX,
5747 "Useless use of %s with no values",
5750 if (kid->op_type == OP_CONST &&
5751 (kid->op_private & OPpCONST_BARE))
5753 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5754 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5755 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5756 if (ckWARN(WARN_DEPRECATED))
5757 Perl_warner(aTHX_ WARN_DEPRECATED,
5758 "Array @%s missing the @ in argument %"IVdf" of %s()",
5759 name, (IV)numargs, PL_op_desc[type]);
5762 kid->op_sibling = sibl;
5765 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5766 bad_type(numargs, "array", PL_op_desc[type], kid);
5770 if (kid->op_type == OP_CONST &&
5771 (kid->op_private & OPpCONST_BARE))
5773 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5774 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5775 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5776 if (ckWARN(WARN_DEPRECATED))
5777 Perl_warner(aTHX_ WARN_DEPRECATED,
5778 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5779 name, (IV)numargs, PL_op_desc[type]);
5782 kid->op_sibling = sibl;
5785 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5786 bad_type(numargs, "hash", PL_op_desc[type], kid);
5791 OP *newop = newUNOP(OP_NULL, 0, kid);
5792 kid->op_sibling = 0;
5794 newop->op_next = newop;
5796 kid->op_sibling = sibl;
5801 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5802 if (kid->op_type == OP_CONST &&
5803 (kid->op_private & OPpCONST_BARE))
5805 OP *newop = newGVOP(OP_GV, 0,
5806 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5811 else if (kid->op_type == OP_READLINE) {
5812 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5813 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5816 I32 flags = OPf_SPECIAL;
5820 /* is this op a FH constructor? */
5821 if (is_handle_constructor(o,numargs)) {
5822 char *name = Nullch;
5826 /* Set a flag to tell rv2gv to vivify
5827 * need to "prove" flag does not mean something
5828 * else already - NI-S 1999/05/07
5831 if (kid->op_type == OP_PADSV) {
5832 SV **namep = av_fetch(PL_comppad_name,
5834 if (namep && *namep)
5835 name = SvPV(*namep, len);
5837 else if (kid->op_type == OP_RV2SV
5838 && kUNOP->op_first->op_type == OP_GV)
5840 GV *gv = cGVOPx_gv(kUNOP->op_first);
5842 len = GvNAMELEN(gv);
5844 else if (kid->op_type == OP_AELEM
5845 || kid->op_type == OP_HELEM)
5847 name = "__ANONIO__";
5853 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5854 namesv = PL_curpad[targ];
5855 (void)SvUPGRADE(namesv, SVt_PV);
5857 sv_setpvn(namesv, "$", 1);
5858 sv_catpvn(namesv, name, len);
5861 kid->op_sibling = 0;
5862 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5863 kid->op_targ = targ;
5864 kid->op_private |= priv;
5866 kid->op_sibling = sibl;
5872 mod(scalar(kid), type);
5876 tokid = &kid->op_sibling;
5877 kid = kid->op_sibling;
5879 o->op_private |= numargs;
5881 return too_many_arguments(o,PL_op_desc[o->op_type]);
5884 else if (PL_opargs[type] & OA_DEFGV) {
5886 return newUNOP(type, 0, newDEFSVOP());
5890 while (oa & OA_OPTIONAL)
5892 if (oa && oa != OA_LIST)
5893 return too_few_arguments(o,PL_op_desc[o->op_type]);
5899 Perl_ck_glob(pTHX_ OP *o)
5904 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5905 append_elem(OP_GLOB, o, newDEFSVOP());
5907 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5908 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5910 #if !defined(PERL_EXTERNAL_GLOB)
5911 /* XXX this can be tightened up and made more failsafe. */
5915 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5917 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5918 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5919 GvCV(gv) = GvCV(glob_gv);
5920 SvREFCNT_inc((SV*)GvCV(gv));
5921 GvIMPORTED_CV_on(gv);
5924 #endif /* PERL_EXTERNAL_GLOB */
5926 if (gv && GvIMPORTED_CV(gv)) {
5927 append_elem(OP_GLOB, o,
5928 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5929 o->op_type = OP_LIST;
5930 o->op_ppaddr = PL_ppaddr[OP_LIST];
5931 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5932 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5933 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5934 append_elem(OP_LIST, o,
5935 scalar(newUNOP(OP_RV2CV, 0,
5936 newGVOP(OP_GV, 0, gv)))));
5937 o = newUNOP(OP_NULL, 0, ck_subr(o));
5938 o->op_targ = OP_GLOB; /* hint at what it used to be */
5941 gv = newGVgen("main");
5943 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5949 Perl_ck_grep(pTHX_ OP *o)
5953 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5955 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5956 NewOp(1101, gwop, 1, LOGOP);
5958 if (o->op_flags & OPf_STACKED) {
5961 kid = cLISTOPo->op_first->op_sibling;
5962 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5965 kid->op_next = (OP*)gwop;
5966 o->op_flags &= ~OPf_STACKED;
5968 kid = cLISTOPo->op_first->op_sibling;
5969 if (type == OP_MAPWHILE)
5976 kid = cLISTOPo->op_first->op_sibling;
5977 if (kid->op_type != OP_NULL)
5978 Perl_croak(aTHX_ "panic: ck_grep");
5979 kid = kUNOP->op_first;
5981 gwop->op_type = type;
5982 gwop->op_ppaddr = PL_ppaddr[type];
5983 gwop->op_first = listkids(o);
5984 gwop->op_flags |= OPf_KIDS;
5985 gwop->op_private = 1;
5986 gwop->op_other = LINKLIST(kid);
5987 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5988 kid->op_next = (OP*)gwop;
5990 kid = cLISTOPo->op_first->op_sibling;
5991 if (!kid || !kid->op_sibling)
5992 return too_few_arguments(o,PL_op_desc[o->op_type]);
5993 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5994 mod(kid, OP_GREPSTART);
6000 Perl_ck_index(pTHX_ OP *o)
6002 if (o->op_flags & OPf_KIDS) {
6003 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6005 kid = kid->op_sibling; /* get past "big" */
6006 if (kid && kid->op_type == OP_CONST)
6007 fbm_compile(((SVOP*)kid)->op_sv, 0);
6013 Perl_ck_lengthconst(pTHX_ OP *o)
6015 /* XXX length optimization goes here */
6020 Perl_ck_lfun(pTHX_ OP *o)
6022 OPCODE type = o->op_type;
6023 return modkids(ck_fun(o), type);
6027 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6029 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6030 switch (cUNOPo->op_first->op_type) {
6032 /* This is needed for
6033 if (defined %stash::)
6034 to work. Do not break Tk.
6036 break; /* Globals via GV can be undef */
6038 case OP_AASSIGN: /* Is this a good idea? */
6039 Perl_warner(aTHX_ WARN_DEPRECATED,
6040 "defined(@array) is deprecated");
6041 Perl_warner(aTHX_ WARN_DEPRECATED,
6042 "\t(Maybe you should just omit the defined()?)\n");
6045 /* This is needed for
6046 if (defined %stash::)
6047 to work. Do not break Tk.
6049 break; /* Globals via GV can be undef */
6051 Perl_warner(aTHX_ WARN_DEPRECATED,
6052 "defined(%%hash) is deprecated");
6053 Perl_warner(aTHX_ WARN_DEPRECATED,
6054 "\t(Maybe you should just omit the defined()?)\n");
6065 Perl_ck_rfun(pTHX_ OP *o)
6067 OPCODE type = o->op_type;
6068 return refkids(ck_fun(o), type);
6072 Perl_ck_listiob(pTHX_ OP *o)
6076 kid = cLISTOPo->op_first;
6079 kid = cLISTOPo->op_first;
6081 if (kid->op_type == OP_PUSHMARK)
6082 kid = kid->op_sibling;
6083 if (kid && o->op_flags & OPf_STACKED)
6084 kid = kid->op_sibling;
6085 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6086 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6087 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6088 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6089 cLISTOPo->op_first->op_sibling = kid;
6090 cLISTOPo->op_last = kid;
6091 kid = kid->op_sibling;
6096 append_elem(o->op_type, o, newDEFSVOP());
6102 Perl_ck_sassign(pTHX_ OP *o)
6104 OP *kid = cLISTOPo->op_first;
6105 /* has a disposable target? */
6106 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6107 && !(kid->op_flags & OPf_STACKED)
6108 /* Cannot steal the second time! */
6109 && !(kid->op_private & OPpTARGET_MY))
6111 OP *kkid = kid->op_sibling;
6113 /* Can just relocate the target. */
6114 if (kkid && kkid->op_type == OP_PADSV
6115 && !(kkid->op_private & OPpLVAL_INTRO))
6117 kid->op_targ = kkid->op_targ;
6119 /* Now we do not need PADSV and SASSIGN. */
6120 kid->op_sibling = o->op_sibling; /* NULL */
6121 cLISTOPo->op_first = NULL;
6124 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6132 Perl_ck_match(pTHX_ OP *o)
6134 o->op_private |= OPpRUNTIME;
6139 Perl_ck_method(pTHX_ OP *o)
6141 OP *kid = cUNOPo->op_first;
6142 if (kid->op_type == OP_CONST) {
6143 SV* sv = kSVOP->op_sv;
6144 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6146 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6147 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6150 kSVOP->op_sv = Nullsv;
6152 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6161 Perl_ck_null(pTHX_ OP *o)
6167 Perl_ck_open(pTHX_ OP *o)
6169 HV *table = GvHV(PL_hintgv);
6173 svp = hv_fetch(table, "open_IN", 7, FALSE);
6175 mode = mode_from_discipline(*svp);
6176 if (mode & O_BINARY)
6177 o->op_private |= OPpOPEN_IN_RAW;
6178 else if (mode & O_TEXT)
6179 o->op_private |= OPpOPEN_IN_CRLF;
6182 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6184 mode = mode_from_discipline(*svp);
6185 if (mode & O_BINARY)
6186 o->op_private |= OPpOPEN_OUT_RAW;
6187 else if (mode & O_TEXT)
6188 o->op_private |= OPpOPEN_OUT_CRLF;
6191 if (o->op_type == OP_BACKTICK)
6197 Perl_ck_repeat(pTHX_ OP *o)
6199 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6200 o->op_private |= OPpREPEAT_DOLIST;
6201 cBINOPo->op_first = force_list(cBINOPo->op_first);
6209 Perl_ck_require(pTHX_ OP *o)
6213 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6214 SVOP *kid = (SVOP*)cUNOPo->op_first;
6216 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6218 for (s = SvPVX(kid->op_sv); *s; s++) {
6219 if (*s == ':' && s[1] == ':') {
6221 Move(s+2, s+1, strlen(s+2)+1, char);
6222 --SvCUR(kid->op_sv);
6225 if (SvREADONLY(kid->op_sv)) {
6226 SvREADONLY_off(kid->op_sv);
6227 sv_catpvn(kid->op_sv, ".pm", 3);
6228 SvREADONLY_on(kid->op_sv);
6231 sv_catpvn(kid->op_sv, ".pm", 3);
6235 /* handle override, if any */
6236 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6237 if (!(gv && GvIMPORTED_CV(gv)))
6238 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6240 if (gv && GvIMPORTED_CV(gv)) {
6241 OP *kid = cUNOPo->op_first;
6242 cUNOPo->op_first = 0;
6244 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6245 append_elem(OP_LIST, kid,
6246 scalar(newUNOP(OP_RV2CV, 0,
6255 Perl_ck_return(pTHX_ OP *o)
6258 if (CvLVALUE(PL_compcv)) {
6259 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6260 mod(kid, OP_LEAVESUBLV);
6267 Perl_ck_retarget(pTHX_ OP *o)
6269 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6276 Perl_ck_select(pTHX_ OP *o)
6279 if (o->op_flags & OPf_KIDS) {
6280 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6281 if (kid && kid->op_sibling) {
6282 o->op_type = OP_SSELECT;
6283 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6285 return fold_constants(o);
6289 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6290 if (kid && kid->op_type == OP_RV2GV)
6291 kid->op_private &= ~HINT_STRICT_REFS;
6296 Perl_ck_shift(pTHX_ OP *o)
6298 I32 type = o->op_type;
6300 if (!(o->op_flags & OPf_KIDS)) {
6305 if (!CvUNIQUE(PL_compcv)) {
6306 argop = newOP(OP_PADAV, OPf_REF);
6307 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6310 argop = newUNOP(OP_RV2AV, 0,
6311 scalar(newGVOP(OP_GV, 0,
6312 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6315 argop = newUNOP(OP_RV2AV, 0,
6316 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6317 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6318 #endif /* USE_THREADS */
6319 return newUNOP(type, 0, scalar(argop));
6321 return scalar(modkids(ck_fun(o), type));
6325 Perl_ck_sort(pTHX_ OP *o)
6329 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6331 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6332 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6334 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6336 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6338 if (kid->op_type == OP_SCOPE) {
6342 else if (kid->op_type == OP_LEAVE) {
6343 if (o->op_type == OP_SORT) {
6344 op_null(kid); /* wipe out leave */
6347 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6348 if (k->op_next == kid)
6350 /* don't descend into loops */
6351 else if (k->op_type == OP_ENTERLOOP
6352 || k->op_type == OP_ENTERITER)
6354 k = cLOOPx(k)->op_lastop;
6359 kid->op_next = 0; /* just disconnect the leave */
6360 k = kLISTOP->op_first;
6365 if (o->op_type == OP_SORT) {
6366 /* provide scalar context for comparison function/block */
6372 o->op_flags |= OPf_SPECIAL;
6374 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6377 firstkid = firstkid->op_sibling;
6380 /* provide list context for arguments */
6381 if (o->op_type == OP_SORT)
6388 S_simplify_sort(pTHX_ OP *o)
6390 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6394 if (!(o->op_flags & OPf_STACKED))
6396 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6397 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6398 kid = kUNOP->op_first; /* get past null */
6399 if (kid->op_type != OP_SCOPE)
6401 kid = kLISTOP->op_last; /* get past scope */
6402 switch(kid->op_type) {
6410 k = kid; /* remember this node*/
6411 if (kBINOP->op_first->op_type != OP_RV2SV)
6413 kid = kBINOP->op_first; /* get past cmp */
6414 if (kUNOP->op_first->op_type != OP_GV)
6416 kid = kUNOP->op_first; /* get past rv2sv */
6418 if (GvSTASH(gv) != PL_curstash)
6420 if (strEQ(GvNAME(gv), "a"))
6422 else if (strEQ(GvNAME(gv), "b"))
6426 kid = k; /* back to cmp */
6427 if (kBINOP->op_last->op_type != OP_RV2SV)
6429 kid = kBINOP->op_last; /* down to 2nd arg */
6430 if (kUNOP->op_first->op_type != OP_GV)
6432 kid = kUNOP->op_first; /* get past rv2sv */
6434 if (GvSTASH(gv) != PL_curstash
6436 ? strNE(GvNAME(gv), "a")
6437 : strNE(GvNAME(gv), "b")))
6439 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6441 o->op_private |= OPpSORT_REVERSE;
6442 if (k->op_type == OP_NCMP)
6443 o->op_private |= OPpSORT_NUMERIC;
6444 if (k->op_type == OP_I_NCMP)
6445 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6446 kid = cLISTOPo->op_first->op_sibling;
6447 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6448 op_free(kid); /* then delete it */
6452 Perl_ck_split(pTHX_ OP *o)
6456 if (o->op_flags & OPf_STACKED)
6457 return no_fh_allowed(o);
6459 kid = cLISTOPo->op_first;
6460 if (kid->op_type != OP_NULL)
6461 Perl_croak(aTHX_ "panic: ck_split");
6462 kid = kid->op_sibling;
6463 op_free(cLISTOPo->op_first);
6464 cLISTOPo->op_first = kid;
6466 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6467 cLISTOPo->op_last = kid; /* There was only one element previously */
6470 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6471 OP *sibl = kid->op_sibling;
6472 kid->op_sibling = 0;
6473 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6474 if (cLISTOPo->op_first == cLISTOPo->op_last)
6475 cLISTOPo->op_last = kid;
6476 cLISTOPo->op_first = kid;
6477 kid->op_sibling = sibl;
6480 kid->op_type = OP_PUSHRE;
6481 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6484 if (!kid->op_sibling)
6485 append_elem(OP_SPLIT, o, newDEFSVOP());
6487 kid = kid->op_sibling;
6490 if (!kid->op_sibling)
6491 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6493 kid = kid->op_sibling;
6496 if (kid->op_sibling)
6497 return too_many_arguments(o,PL_op_desc[o->op_type]);
6503 Perl_ck_join(pTHX_ OP *o)
6505 if (ckWARN(WARN_SYNTAX)) {
6506 OP *kid = cLISTOPo->op_first->op_sibling;
6507 if (kid && kid->op_type == OP_MATCH) {
6508 char *pmstr = "STRING";
6509 if (PM_GETRE(kPMOP))
6510 pmstr = PM_GETRE(kPMOP)->precomp;
6511 Perl_warner(aTHX_ WARN_SYNTAX,
6512 "/%s/ should probably be written as \"%s\"",
6520 Perl_ck_subr(pTHX_ OP *o)
6522 OP *prev = ((cUNOPo->op_first->op_sibling)
6523 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6524 OP *o2 = prev->op_sibling;
6533 o->op_private |= OPpENTERSUB_HASTARG;
6534 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6535 if (cvop->op_type == OP_RV2CV) {
6537 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6538 op_null(cvop); /* disable rv2cv */
6539 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6540 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6541 GV *gv = cGVOPx_gv(tmpop);
6544 tmpop->op_private |= OPpEARLY_CV;
6545 else if (SvPOK(cv)) {
6546 namegv = CvANON(cv) ? gv : CvGV(cv);
6547 proto = SvPV((SV*)cv, n_a);
6551 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6552 if (o2->op_type == OP_CONST)
6553 o2->op_private &= ~OPpCONST_STRICT;
6554 else if (o2->op_type == OP_LIST) {
6555 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6556 if (o && o->op_type == OP_CONST)
6557 o->op_private &= ~OPpCONST_STRICT;
6560 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6561 if (PERLDB_SUB && PL_curstash != PL_debstash)
6562 o->op_private |= OPpENTERSUB_DB;
6563 while (o2 != cvop) {
6567 return too_many_arguments(o, gv_ename(namegv));
6585 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6587 arg == 1 ? "block or sub {}" : "sub {}",
6588 gv_ename(namegv), o2);
6591 /* '*' allows any scalar type, including bareword */
6594 if (o2->op_type == OP_RV2GV)
6595 goto wrapref; /* autoconvert GLOB -> GLOBref */
6596 else if (o2->op_type == OP_CONST)
6597 o2->op_private &= ~OPpCONST_STRICT;
6598 else if (o2->op_type == OP_ENTERSUB) {
6599 /* accidental subroutine, revert to bareword */
6600 OP *gvop = ((UNOP*)o2)->op_first;
6601 if (gvop && gvop->op_type == OP_NULL) {
6602 gvop = ((UNOP*)gvop)->op_first;
6604 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6607 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6608 (gvop = ((UNOP*)gvop)->op_first) &&
6609 gvop->op_type == OP_GV)
6611 GV *gv = cGVOPx_gv(gvop);
6612 OP *sibling = o2->op_sibling;
6613 SV *n = newSVpvn("",0);
6615 gv_fullname3(n, gv, "");
6616 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6617 sv_chop(n, SvPVX(n)+6);
6618 o2 = newSVOP(OP_CONST, 0, n);
6619 prev->op_sibling = o2;
6620 o2->op_sibling = sibling;
6632 if (o2->op_type != OP_RV2GV)
6633 bad_type(arg, "symbol", gv_ename(namegv), o2);
6636 if (o2->op_type != OP_ENTERSUB)
6637 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6640 if (o2->op_type != OP_RV2SV
6641 && o2->op_type != OP_PADSV
6642 && o2->op_type != OP_HELEM
6643 && o2->op_type != OP_AELEM
6644 && o2->op_type != OP_THREADSV)
6646 bad_type(arg, "scalar", gv_ename(namegv), o2);
6650 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6651 bad_type(arg, "array", gv_ename(namegv), o2);
6654 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6655 bad_type(arg, "hash", gv_ename(namegv), o2);
6659 OP* sib = kid->op_sibling;
6660 kid->op_sibling = 0;
6661 o2 = newUNOP(OP_REFGEN, 0, kid);
6662 o2->op_sibling = sib;
6663 prev->op_sibling = o2;
6674 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6675 gv_ename(namegv), SvPV((SV*)cv, n_a));
6680 mod(o2, OP_ENTERSUB);
6682 o2 = o2->op_sibling;
6684 if (proto && !optional &&
6685 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6686 return too_few_arguments(o, gv_ename(namegv));
6691 Perl_ck_svconst(pTHX_ OP *o)
6693 SvREADONLY_on(cSVOPo->op_sv);
6698 Perl_ck_trunc(pTHX_ OP *o)
6700 if (o->op_flags & OPf_KIDS) {
6701 SVOP *kid = (SVOP*)cUNOPo->op_first;
6703 if (kid->op_type == OP_NULL)
6704 kid = (SVOP*)kid->op_sibling;
6705 if (kid && kid->op_type == OP_CONST &&
6706 (kid->op_private & OPpCONST_BARE))
6708 o->op_flags |= OPf_SPECIAL;
6709 kid->op_private &= ~OPpCONST_STRICT;
6716 Perl_ck_substr(pTHX_ OP *o)
6719 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6720 OP *kid = cLISTOPo->op_first;
6722 if (kid->op_type == OP_NULL)
6723 kid = kid->op_sibling;
6725 kid->op_flags |= OPf_MOD;
6731 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6734 Perl_peep(pTHX_ register OP *o)
6736 register OP* oldop = 0;
6739 if (!o || o->op_seq)
6743 SAVEVPTR(PL_curcop);
6744 for (; o; o = o->op_next) {
6750 switch (o->op_type) {
6754 PL_curcop = ((COP*)o); /* for warnings */
6755 o->op_seq = PL_op_seqmax++;
6759 if (cSVOPo->op_private & OPpCONST_STRICT)
6760 no_bareword_allowed(o);
6762 /* Relocate sv to the pad for thread safety.
6763 * Despite being a "constant", the SV is written to,
6764 * for reference counts, sv_upgrade() etc. */
6766 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6767 if (SvPADTMP(cSVOPo->op_sv)) {
6768 /* If op_sv is already a PADTMP then it is being used by
6769 * some pad, so make a copy. */
6770 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6771 SvREADONLY_on(PL_curpad[ix]);
6772 SvREFCNT_dec(cSVOPo->op_sv);
6775 SvREFCNT_dec(PL_curpad[ix]);
6776 SvPADTMP_on(cSVOPo->op_sv);
6777 PL_curpad[ix] = cSVOPo->op_sv;
6778 /* XXX I don't know how this isn't readonly already. */
6779 SvREADONLY_on(PL_curpad[ix]);
6781 cSVOPo->op_sv = Nullsv;
6785 o->op_seq = PL_op_seqmax++;
6789 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6790 if (o->op_next->op_private & OPpTARGET_MY) {
6791 if (o->op_flags & OPf_STACKED) /* chained concats */
6792 goto ignore_optimization;
6794 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6795 o->op_targ = o->op_next->op_targ;
6796 o->op_next->op_targ = 0;
6797 o->op_private |= OPpTARGET_MY;
6800 op_null(o->op_next);
6802 ignore_optimization:
6803 o->op_seq = PL_op_seqmax++;
6806 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6807 o->op_seq = PL_op_seqmax++;
6808 break; /* Scalar stub must produce undef. List stub is noop */
6812 if (o->op_targ == OP_NEXTSTATE
6813 || o->op_targ == OP_DBSTATE
6814 || o->op_targ == OP_SETSTATE)
6816 PL_curcop = ((COP*)o);
6818 /* XXX: We avoid setting op_seq here to prevent later calls
6819 to peep() from mistakenly concluding that optimisation
6820 has already occurred. This doesn't fix the real problem,
6821 though (See 20010220.007). AMS 20010719 */
6822 if (oldop && o->op_next) {
6823 oldop->op_next = o->op_next;
6831 if (oldop && o->op_next) {
6832 oldop->op_next = o->op_next;
6835 o->op_seq = PL_op_seqmax++;
6839 if (o->op_next->op_type == OP_RV2SV) {
6840 if (!(o->op_next->op_private & OPpDEREF)) {
6841 op_null(o->op_next);
6842 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6844 o->op_next = o->op_next->op_next;
6845 o->op_type = OP_GVSV;
6846 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6849 else if (o->op_next->op_type == OP_RV2AV) {
6850 OP* pop = o->op_next->op_next;
6852 if (pop->op_type == OP_CONST &&
6853 (PL_op = pop->op_next) &&
6854 pop->op_next->op_type == OP_AELEM &&
6855 !(pop->op_next->op_private &
6856 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6857 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6862 op_null(o->op_next);
6863 op_null(pop->op_next);
6865 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6866 o->op_next = pop->op_next->op_next;
6867 o->op_type = OP_AELEMFAST;
6868 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6869 o->op_private = (U8)i;
6874 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6876 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6877 /* XXX could check prototype here instead of just carping */
6878 SV *sv = sv_newmortal();
6879 gv_efullname3(sv, gv, Nullch);
6880 Perl_warner(aTHX_ WARN_PROTOTYPE,
6881 "%s() called too early to check prototype",
6886 o->op_seq = PL_op_seqmax++;
6897 o->op_seq = PL_op_seqmax++;
6898 while (cLOGOP->op_other->op_type == OP_NULL)
6899 cLOGOP->op_other = cLOGOP->op_other->op_next;
6900 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6905 o->op_seq = PL_op_seqmax++;
6906 while (cLOOP->op_redoop->op_type == OP_NULL)
6907 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6908 peep(cLOOP->op_redoop);
6909 while (cLOOP->op_nextop->op_type == OP_NULL)
6910 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6911 peep(cLOOP->op_nextop);
6912 while (cLOOP->op_lastop->op_type == OP_NULL)
6913 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6914 peep(cLOOP->op_lastop);
6920 o->op_seq = PL_op_seqmax++;
6921 while (cPMOP->op_pmreplstart &&
6922 cPMOP->op_pmreplstart->op_type == OP_NULL)
6923 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6924 peep(cPMOP->op_pmreplstart);
6928 o->op_seq = PL_op_seqmax++;
6929 if (ckWARN(WARN_SYNTAX) && o->op_next
6930 && o->op_next->op_type == OP_NEXTSTATE) {
6931 if (o->op_next->op_sibling &&
6932 o->op_next->op_sibling->op_type != OP_EXIT &&
6933 o->op_next->op_sibling->op_type != OP_WARN &&
6934 o->op_next->op_sibling->op_type != OP_DIE) {
6935 line_t oldline = CopLINE(PL_curcop);
6937 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6938 Perl_warner(aTHX_ WARN_EXEC,
6939 "Statement unlikely to be reached");
6940 Perl_warner(aTHX_ WARN_EXEC,
6941 "\t(Maybe you meant system() when you said exec()?)\n");
6942 CopLINE_set(PL_curcop, oldline);
6951 SV **svp, **indsvp, *sv;
6956 o->op_seq = PL_op_seqmax++;
6958 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6961 /* Make the CONST have a shared SV */
6962 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6963 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6964 key = SvPV(sv, keylen);
6965 lexname = newSVpvn_share(key,
6966 SvUTF8(sv) ? -(I32)keylen : keylen,
6972 if ((o->op_private & (OPpLVAL_INTRO)))
6975 rop = (UNOP*)((BINOP*)o)->op_first;
6976 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6978 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6979 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6981 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6982 if (!fields || !GvHV(*fields))
6984 key = SvPV(*svp, keylen);
6985 indsvp = hv_fetch(GvHV(*fields), key,
6986 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6988 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6989 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6991 ind = SvIV(*indsvp);
6993 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6994 rop->op_type = OP_RV2AV;
6995 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6996 o->op_type = OP_AELEM;
6997 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6999 if (SvREADONLY(*svp))
7001 SvFLAGS(sv) |= (SvFLAGS(*svp)
7002 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7012 SV **svp, **indsvp, *sv;
7016 SVOP *first_key_op, *key_op;
7018 o->op_seq = PL_op_seqmax++;
7019 if ((o->op_private & (OPpLVAL_INTRO))
7020 /* I bet there's always a pushmark... */
7021 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7022 /* hmmm, no optimization if list contains only one key. */
7024 rop = (UNOP*)((LISTOP*)o)->op_last;
7025 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7027 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7028 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7030 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7031 if (!fields || !GvHV(*fields))
7033 /* Again guessing that the pushmark can be jumped over.... */
7034 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7035 ->op_first->op_sibling;
7036 /* Check that the key list contains only constants. */
7037 for (key_op = first_key_op; key_op;
7038 key_op = (SVOP*)key_op->op_sibling)
7039 if (key_op->op_type != OP_CONST)
7043 rop->op_type = OP_RV2AV;
7044 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7045 o->op_type = OP_ASLICE;
7046 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7047 for (key_op = first_key_op; key_op;
7048 key_op = (SVOP*)key_op->op_sibling) {
7049 svp = cSVOPx_svp(key_op);
7050 key = SvPV(*svp, keylen);
7051 indsvp = hv_fetch(GvHV(*fields), key,
7052 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7054 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7055 "in variable %s of type %s",
7056 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7058 ind = SvIV(*indsvp);
7060 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7062 if (SvREADONLY(*svp))
7064 SvFLAGS(sv) |= (SvFLAGS(*svp)
7065 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7073 o->op_seq = PL_op_seqmax++;
7083 /* Efficient sub that returns a constant scalar value. */
7085 const_sv_xsub(pTHXo_ CV* cv)
7090 Perl_croak(aTHX_ "usage: %s::%s()",
7091 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7095 ST(0) = (SV*)XSANY.any_ptr;