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 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3006 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3007 pm->op_pmflags |= PMf_WHITE;
3011 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3012 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3014 : OP_REGCMAYBE),0,expr);
3016 NewOp(1101, rcop, 1, LOGOP);
3017 rcop->op_type = OP_REGCOMP;
3018 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3019 rcop->op_first = scalar(expr);
3020 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3021 ? (OPf_SPECIAL | OPf_KIDS)
3023 rcop->op_private = 1;
3026 /* establish postfix order */
3027 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3029 rcop->op_next = expr;
3030 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3033 rcop->op_next = LINKLIST(expr);
3034 expr->op_next = (OP*)rcop;
3037 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3042 if (pm->op_pmflags & PMf_EVAL) {
3044 if (CopLINE(PL_curcop) < PL_multi_end)
3045 CopLINE_set(PL_curcop, PL_multi_end);
3048 else if (repl->op_type == OP_THREADSV
3049 && strchr("&`'123456789+",
3050 PL_threadsv_names[repl->op_targ]))
3054 #endif /* USE_THREADS */
3055 else if (repl->op_type == OP_CONST)
3059 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3060 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3062 if (curop->op_type == OP_THREADSV) {
3064 if (strchr("&`'123456789+", curop->op_private))
3068 if (curop->op_type == OP_GV) {
3069 GV *gv = cGVOPx_gv(curop);
3071 if (strchr("&`'123456789+", *GvENAME(gv)))
3074 #endif /* USE_THREADS */
3075 else if (curop->op_type == OP_RV2CV)
3077 else if (curop->op_type == OP_RV2SV ||
3078 curop->op_type == OP_RV2AV ||
3079 curop->op_type == OP_RV2HV ||
3080 curop->op_type == OP_RV2GV) {
3081 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3084 else if (curop->op_type == OP_PADSV ||
3085 curop->op_type == OP_PADAV ||
3086 curop->op_type == OP_PADHV ||
3087 curop->op_type == OP_PADANY) {
3090 else if (curop->op_type == OP_PUSHRE)
3091 ; /* Okay here, dangerous in newASSIGNOP */
3101 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3102 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3103 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3104 prepend_elem(o->op_type, scalar(repl), o);
3107 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3108 pm->op_pmflags |= PMf_MAYBE_CONST;
3109 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3111 NewOp(1101, rcop, 1, LOGOP);
3112 rcop->op_type = OP_SUBSTCONT;
3113 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3114 rcop->op_first = scalar(repl);
3115 rcop->op_flags |= OPf_KIDS;
3116 rcop->op_private = 1;
3119 /* establish postfix order */
3120 rcop->op_next = LINKLIST(repl);
3121 repl->op_next = (OP*)rcop;
3123 pm->op_pmreplroot = scalar((OP*)rcop);
3124 pm->op_pmreplstart = LINKLIST(rcop);
3133 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3136 NewOp(1101, svop, 1, SVOP);
3137 svop->op_type = type;
3138 svop->op_ppaddr = PL_ppaddr[type];
3140 svop->op_next = (OP*)svop;
3141 svop->op_flags = flags;
3142 if (PL_opargs[type] & OA_RETSCALAR)
3144 if (PL_opargs[type] & OA_TARGET)
3145 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3146 return CHECKOP(type, svop);
3150 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3153 NewOp(1101, padop, 1, PADOP);
3154 padop->op_type = type;
3155 padop->op_ppaddr = PL_ppaddr[type];
3156 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3157 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3158 PL_curpad[padop->op_padix] = sv;
3160 padop->op_next = (OP*)padop;
3161 padop->op_flags = flags;
3162 if (PL_opargs[type] & OA_RETSCALAR)
3164 if (PL_opargs[type] & OA_TARGET)
3165 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3166 return CHECKOP(type, padop);
3170 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3174 return newPADOP(type, flags, SvREFCNT_inc(gv));
3176 return newSVOP(type, flags, SvREFCNT_inc(gv));
3181 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3184 NewOp(1101, pvop, 1, PVOP);
3185 pvop->op_type = type;
3186 pvop->op_ppaddr = PL_ppaddr[type];
3188 pvop->op_next = (OP*)pvop;
3189 pvop->op_flags = flags;
3190 if (PL_opargs[type] & OA_RETSCALAR)
3192 if (PL_opargs[type] & OA_TARGET)
3193 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3194 return CHECKOP(type, pvop);
3198 Perl_package(pTHX_ OP *o)
3202 save_hptr(&PL_curstash);
3203 save_item(PL_curstname);
3208 name = SvPV(sv, len);
3209 PL_curstash = gv_stashpvn(name,len,TRUE);
3210 sv_setpvn(PL_curstname, name, len);
3214 deprecate("\"package\" with no arguments");
3215 sv_setpv(PL_curstname,"<none>");
3216 PL_curstash = Nullhv;
3218 PL_hints |= HINT_BLOCK_SCOPE;
3219 PL_copline = NOLINE;
3224 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3229 char *packname = Nullch;
3233 if (id->op_type != OP_CONST)
3234 Perl_croak(aTHX_ "Module name must be constant");
3238 if (version != Nullop) {
3239 SV *vesv = ((SVOP*)version)->op_sv;
3241 if (arg == Nullop && !SvNIOKp(vesv)) {
3248 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3249 Perl_croak(aTHX_ "Version number must be constant number");
3251 /* Make copy of id so we don't free it twice */
3252 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3254 /* Fake up a method call to VERSION */
3255 meth = newSVpvn("VERSION",7);
3256 sv_upgrade(meth, SVt_PVIV);
3257 (void)SvIOK_on(meth);
3258 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3259 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3260 append_elem(OP_LIST,
3261 prepend_elem(OP_LIST, pack, list(version)),
3262 newSVOP(OP_METHOD_NAMED, 0, meth)));
3266 /* Fake up an import/unimport */
3267 if (arg && arg->op_type == OP_STUB)
3268 imop = arg; /* no import on explicit () */
3269 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3270 imop = Nullop; /* use 5.0; */
3275 /* Make copy of id so we don't free it twice */
3276 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3278 /* Fake up a method call to import/unimport */
3279 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3280 sv_upgrade(meth, SVt_PVIV);
3281 (void)SvIOK_on(meth);
3282 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3283 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3284 append_elem(OP_LIST,
3285 prepend_elem(OP_LIST, pack, list(arg)),
3286 newSVOP(OP_METHOD_NAMED, 0, meth)));
3289 if (ckWARN(WARN_MISC) &&
3290 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3291 SvPOK(packsv = ((SVOP*)id)->op_sv))
3293 /* BEGIN will free the ops, so we need to make a copy */
3294 packlen = SvCUR(packsv);
3295 packname = savepvn(SvPVX(packsv), packlen);
3298 /* Fake up the BEGIN {}, which does its thing immediately. */
3300 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3303 append_elem(OP_LINESEQ,
3304 append_elem(OP_LINESEQ,
3305 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3306 newSTATEOP(0, Nullch, veop)),
3307 newSTATEOP(0, Nullch, imop) ));
3310 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3311 Perl_warner(aTHX_ WARN_MISC,
3312 "Package `%s' not found "
3313 "(did you use the incorrect case?)", packname);
3318 PL_hints |= HINT_BLOCK_SCOPE;
3319 PL_copline = NOLINE;
3324 =for apidoc load_module
3326 Loads the module whose name is pointed to by the string part of name.
3327 Note that the actual module name, not its filename, should be given.
3328 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3329 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3330 (or 0 for no flags). ver, if specified, provides version semantics
3331 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3332 arguments can be used to specify arguments to the module's import()
3333 method, similar to C<use Foo::Bar VERSION LIST>.
3338 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3341 va_start(args, ver);
3342 vload_module(flags, name, ver, &args);
3346 #ifdef PERL_IMPLICIT_CONTEXT
3348 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3352 va_start(args, ver);
3353 vload_module(flags, name, ver, &args);
3359 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3361 OP *modname, *veop, *imop;
3363 modname = newSVOP(OP_CONST, 0, name);
3364 modname->op_private |= OPpCONST_BARE;
3366 veop = newSVOP(OP_CONST, 0, ver);
3370 if (flags & PERL_LOADMOD_NOIMPORT) {
3371 imop = sawparens(newNULLLIST());
3373 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3374 imop = va_arg(*args, OP*);
3379 sv = va_arg(*args, SV*);
3381 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3382 sv = va_arg(*args, SV*);
3386 line_t ocopline = PL_copline;
3387 int oexpect = PL_expect;
3389 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3390 veop, modname, imop);
3391 PL_expect = oexpect;
3392 PL_copline = ocopline;
3397 Perl_dofile(pTHX_ OP *term)
3402 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3403 if (!(gv && GvIMPORTED_CV(gv)))
3404 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3406 if (gv && GvIMPORTED_CV(gv)) {
3407 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3408 append_elem(OP_LIST, term,
3409 scalar(newUNOP(OP_RV2CV, 0,
3414 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3420 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3422 return newBINOP(OP_LSLICE, flags,
3423 list(force_list(subscript)),
3424 list(force_list(listval)) );
3428 S_list_assignment(pTHX_ register OP *o)
3433 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3434 o = cUNOPo->op_first;
3436 if (o->op_type == OP_COND_EXPR) {
3437 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3438 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3443 yyerror("Assignment to both a list and a scalar");
3447 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3448 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3449 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3452 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3455 if (o->op_type == OP_RV2SV)
3462 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3467 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3468 return newLOGOP(optype, 0,
3469 mod(scalar(left), optype),
3470 newUNOP(OP_SASSIGN, 0, scalar(right)));
3473 return newBINOP(optype, OPf_STACKED,
3474 mod(scalar(left), optype), scalar(right));
3478 if (list_assignment(left)) {
3482 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3483 left = mod(left, OP_AASSIGN);
3491 curop = list(force_list(left));
3492 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3493 o->op_private = 0 | (flags >> 8);
3494 for (curop = ((LISTOP*)curop)->op_first;
3495 curop; curop = curop->op_sibling)
3497 if (curop->op_type == OP_RV2HV &&
3498 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3499 o->op_private |= OPpASSIGN_HASH;
3503 if (!(left->op_private & OPpLVAL_INTRO)) {
3506 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3507 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3508 if (curop->op_type == OP_GV) {
3509 GV *gv = cGVOPx_gv(curop);
3510 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3512 SvCUR(gv) = PL_generation;
3514 else if (curop->op_type == OP_PADSV ||
3515 curop->op_type == OP_PADAV ||
3516 curop->op_type == OP_PADHV ||
3517 curop->op_type == OP_PADANY) {
3518 SV **svp = AvARRAY(PL_comppad_name);
3519 SV *sv = svp[curop->op_targ];
3520 if (SvCUR(sv) == PL_generation)
3522 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3524 else if (curop->op_type == OP_RV2CV)
3526 else if (curop->op_type == OP_RV2SV ||
3527 curop->op_type == OP_RV2AV ||
3528 curop->op_type == OP_RV2HV ||
3529 curop->op_type == OP_RV2GV) {
3530 if (lastop->op_type != OP_GV) /* funny deref? */
3533 else if (curop->op_type == OP_PUSHRE) {
3534 if (((PMOP*)curop)->op_pmreplroot) {
3536 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3538 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3540 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3542 SvCUR(gv) = PL_generation;
3551 o->op_private |= OPpASSIGN_COMMON;
3553 if (right && right->op_type == OP_SPLIT) {
3555 if ((tmpop = ((LISTOP*)right)->op_first) &&
3556 tmpop->op_type == OP_PUSHRE)
3558 PMOP *pm = (PMOP*)tmpop;
3559 if (left->op_type == OP_RV2AV &&
3560 !(left->op_private & OPpLVAL_INTRO) &&
3561 !(o->op_private & OPpASSIGN_COMMON) )
3563 tmpop = ((UNOP*)left)->op_first;
3564 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3566 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3567 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3569 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3570 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3572 pm->op_pmflags |= PMf_ONCE;
3573 tmpop = cUNOPo->op_first; /* to list (nulled) */
3574 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3575 tmpop->op_sibling = Nullop; /* don't free split */
3576 right->op_next = tmpop->op_next; /* fix starting loc */
3577 op_free(o); /* blow off assign */
3578 right->op_flags &= ~OPf_WANT;
3579 /* "I don't know and I don't care." */
3584 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3585 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3587 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3589 sv_setiv(sv, PL_modcount+1);
3597 right = newOP(OP_UNDEF, 0);
3598 if (right->op_type == OP_READLINE) {
3599 right->op_flags |= OPf_STACKED;
3600 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3603 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3604 o = newBINOP(OP_SASSIGN, flags,
3605 scalar(right), mod(scalar(left), OP_SASSIGN) );
3617 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3619 U32 seq = intro_my();
3622 NewOp(1101, cop, 1, COP);
3623 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3624 cop->op_type = OP_DBSTATE;
3625 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3628 cop->op_type = OP_NEXTSTATE;
3629 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3631 cop->op_flags = flags;
3632 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3634 cop->op_private |= NATIVE_HINTS;
3636 PL_compiling.op_private = cop->op_private;
3637 cop->op_next = (OP*)cop;
3640 cop->cop_label = label;
3641 PL_hints |= HINT_BLOCK_SCOPE;
3644 cop->cop_arybase = PL_curcop->cop_arybase;
3645 if (specialWARN(PL_curcop->cop_warnings))
3646 cop->cop_warnings = PL_curcop->cop_warnings ;
3648 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3649 if (specialCopIO(PL_curcop->cop_io))
3650 cop->cop_io = PL_curcop->cop_io;
3652 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3655 if (PL_copline == NOLINE)
3656 CopLINE_set(cop, CopLINE(PL_curcop));
3658 CopLINE_set(cop, PL_copline);
3659 PL_copline = NOLINE;
3662 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3664 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3666 CopSTASH_set(cop, PL_curstash);
3668 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3669 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3670 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3671 (void)SvIOK_on(*svp);
3672 SvIVX(*svp) = PTR2IV(cop);
3676 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3679 /* "Introduce" my variables to visible status. */
3687 if (! PL_min_intro_pending)
3688 return PL_cop_seqmax;
3690 svp = AvARRAY(PL_comppad_name);
3691 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3692 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3693 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3694 SvNVX(sv) = (NV)PL_cop_seqmax;
3697 PL_min_intro_pending = 0;
3698 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3699 return PL_cop_seqmax++;
3703 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3705 return new_logop(type, flags, &first, &other);
3709 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3713 OP *first = *firstp;
3714 OP *other = *otherp;
3716 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3717 return newBINOP(type, flags, scalar(first), scalar(other));
3719 scalarboolean(first);
3720 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3721 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3722 if (type == OP_AND || type == OP_OR) {
3728 first = *firstp = cUNOPo->op_first;
3730 first->op_next = o->op_next;
3731 cUNOPo->op_first = Nullop;
3735 if (first->op_type == OP_CONST) {
3736 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3737 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3738 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3749 else if (first->op_type == OP_WANTARRAY) {
3755 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3756 OP *k1 = ((UNOP*)first)->op_first;
3757 OP *k2 = k1->op_sibling;
3759 switch (first->op_type)
3762 if (k2 && k2->op_type == OP_READLINE
3763 && (k2->op_flags & OPf_STACKED)
3764 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3766 warnop = k2->op_type;
3771 if (k1->op_type == OP_READDIR
3772 || k1->op_type == OP_GLOB
3773 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3774 || k1->op_type == OP_EACH)
3776 warnop = ((k1->op_type == OP_NULL)
3777 ? k1->op_targ : k1->op_type);
3782 line_t oldline = CopLINE(PL_curcop);
3783 CopLINE_set(PL_curcop, PL_copline);
3784 Perl_warner(aTHX_ WARN_MISC,
3785 "Value of %s%s can be \"0\"; test with defined()",
3787 ((warnop == OP_READLINE || warnop == OP_GLOB)
3788 ? " construct" : "() operator"));
3789 CopLINE_set(PL_curcop, oldline);
3796 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3797 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3799 NewOp(1101, logop, 1, LOGOP);
3801 logop->op_type = type;
3802 logop->op_ppaddr = PL_ppaddr[type];
3803 logop->op_first = first;
3804 logop->op_flags = flags | OPf_KIDS;
3805 logop->op_other = LINKLIST(other);
3806 logop->op_private = 1 | (flags >> 8);
3808 /* establish postfix order */
3809 logop->op_next = LINKLIST(first);
3810 first->op_next = (OP*)logop;
3811 first->op_sibling = other;
3813 o = newUNOP(OP_NULL, 0, (OP*)logop);
3820 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3827 return newLOGOP(OP_AND, 0, first, trueop);
3829 return newLOGOP(OP_OR, 0, first, falseop);
3831 scalarboolean(first);
3832 if (first->op_type == OP_CONST) {
3833 if (SvTRUE(((SVOP*)first)->op_sv)) {
3844 else if (first->op_type == OP_WANTARRAY) {
3848 NewOp(1101, logop, 1, LOGOP);
3849 logop->op_type = OP_COND_EXPR;
3850 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3851 logop->op_first = first;
3852 logop->op_flags = flags | OPf_KIDS;
3853 logop->op_private = 1 | (flags >> 8);
3854 logop->op_other = LINKLIST(trueop);
3855 logop->op_next = LINKLIST(falseop);
3858 /* establish postfix order */
3859 start = LINKLIST(first);
3860 first->op_next = (OP*)logop;
3862 first->op_sibling = trueop;
3863 trueop->op_sibling = falseop;
3864 o = newUNOP(OP_NULL, 0, (OP*)logop);
3866 trueop->op_next = falseop->op_next = o;
3873 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3881 NewOp(1101, range, 1, LOGOP);
3883 range->op_type = OP_RANGE;
3884 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3885 range->op_first = left;
3886 range->op_flags = OPf_KIDS;
3887 leftstart = LINKLIST(left);
3888 range->op_other = LINKLIST(right);
3889 range->op_private = 1 | (flags >> 8);
3891 left->op_sibling = right;
3893 range->op_next = (OP*)range;
3894 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3895 flop = newUNOP(OP_FLOP, 0, flip);
3896 o = newUNOP(OP_NULL, 0, flop);
3898 range->op_next = leftstart;
3900 left->op_next = flip;
3901 right->op_next = flop;
3903 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3904 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3905 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3906 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3908 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3909 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3912 if (!flip->op_private || !flop->op_private)
3913 linklist(o); /* blow off optimizer unless constant */
3919 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3923 int once = block && block->op_flags & OPf_SPECIAL &&
3924 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3927 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3928 return block; /* do {} while 0 does once */
3929 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3930 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3931 expr = newUNOP(OP_DEFINED, 0,
3932 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3933 } else if (expr->op_flags & OPf_KIDS) {
3934 OP *k1 = ((UNOP*)expr)->op_first;
3935 OP *k2 = (k1) ? k1->op_sibling : NULL;
3936 switch (expr->op_type) {
3938 if (k2 && k2->op_type == OP_READLINE
3939 && (k2->op_flags & OPf_STACKED)
3940 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3941 expr = newUNOP(OP_DEFINED, 0, expr);
3945 if (k1->op_type == OP_READDIR
3946 || k1->op_type == OP_GLOB
3947 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3948 || k1->op_type == OP_EACH)
3949 expr = newUNOP(OP_DEFINED, 0, expr);
3955 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3956 o = new_logop(OP_AND, 0, &expr, &listop);
3959 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3961 if (once && o != listop)
3962 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3965 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3967 o->op_flags |= flags;
3969 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3974 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3982 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3983 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3984 expr = newUNOP(OP_DEFINED, 0,
3985 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3986 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3987 OP *k1 = ((UNOP*)expr)->op_first;
3988 OP *k2 = (k1) ? k1->op_sibling : NULL;
3989 switch (expr->op_type) {
3991 if (k2 && k2->op_type == OP_READLINE
3992 && (k2->op_flags & OPf_STACKED)
3993 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3994 expr = newUNOP(OP_DEFINED, 0, expr);
3998 if (k1->op_type == OP_READDIR
3999 || k1->op_type == OP_GLOB
4000 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4001 || k1->op_type == OP_EACH)
4002 expr = newUNOP(OP_DEFINED, 0, expr);
4008 block = newOP(OP_NULL, 0);
4010 block = scope(block);
4014 next = LINKLIST(cont);
4017 OP *unstack = newOP(OP_UNSTACK, 0);
4020 cont = append_elem(OP_LINESEQ, cont, unstack);
4021 if ((line_t)whileline != NOLINE) {
4022 PL_copline = whileline;
4023 cont = append_elem(OP_LINESEQ, cont,
4024 newSTATEOP(0, Nullch, Nullop));
4028 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4029 redo = LINKLIST(listop);
4032 PL_copline = whileline;
4034 o = new_logop(OP_AND, 0, &expr, &listop);
4035 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4036 op_free(expr); /* oops, it's a while (0) */
4038 return Nullop; /* listop already freed by new_logop */
4041 ((LISTOP*)listop)->op_last->op_next =
4042 (o == listop ? redo : LINKLIST(o));
4048 NewOp(1101,loop,1,LOOP);
4049 loop->op_type = OP_ENTERLOOP;
4050 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4051 loop->op_private = 0;
4052 loop->op_next = (OP*)loop;
4055 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4057 loop->op_redoop = redo;
4058 loop->op_lastop = o;
4059 o->op_private |= loopflags;
4062 loop->op_nextop = next;
4064 loop->op_nextop = o;
4066 o->op_flags |= flags;
4067 o->op_private |= (flags >> 8);
4072 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4080 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4081 sv->op_type = OP_RV2GV;
4082 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4084 else if (sv->op_type == OP_PADSV) { /* private variable */
4085 padoff = sv->op_targ;
4090 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4091 padoff = sv->op_targ;
4093 iterflags |= OPf_SPECIAL;
4098 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4102 padoff = find_threadsv("_");
4103 iterflags |= OPf_SPECIAL;
4105 sv = newGVOP(OP_GV, 0, PL_defgv);
4108 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4109 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4110 iterflags |= OPf_STACKED;
4112 else if (expr->op_type == OP_NULL &&
4113 (expr->op_flags & OPf_KIDS) &&
4114 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4116 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4117 * set the STACKED flag to indicate that these values are to be
4118 * treated as min/max values by 'pp_iterinit'.
4120 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4121 LOGOP* range = (LOGOP*) flip->op_first;
4122 OP* left = range->op_first;
4123 OP* right = left->op_sibling;
4126 range->op_flags &= ~OPf_KIDS;
4127 range->op_first = Nullop;
4129 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4130 listop->op_first->op_next = range->op_next;
4131 left->op_next = range->op_other;
4132 right->op_next = (OP*)listop;
4133 listop->op_next = listop->op_first;
4136 expr = (OP*)(listop);
4138 iterflags |= OPf_STACKED;
4141 expr = mod(force_list(expr), OP_GREPSTART);
4145 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4146 append_elem(OP_LIST, expr, scalar(sv))));
4147 assert(!loop->op_next);
4148 #ifdef PL_OP_SLAB_ALLOC
4151 NewOp(1234,tmp,1,LOOP);
4152 Copy(loop,tmp,1,LOOP);
4156 Renew(loop, 1, LOOP);
4158 loop->op_targ = padoff;
4159 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4160 PL_copline = forline;
4161 return newSTATEOP(0, label, wop);
4165 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4170 if (type != OP_GOTO || label->op_type == OP_CONST) {
4171 /* "last()" means "last" */
4172 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4173 o = newOP(type, OPf_SPECIAL);
4175 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4176 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4182 if (label->op_type == OP_ENTERSUB)
4183 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4184 o = newUNOP(type, OPf_STACKED, label);
4186 PL_hints |= HINT_BLOCK_SCOPE;
4191 Perl_cv_undef(pTHX_ CV *cv)
4195 MUTEX_DESTROY(CvMUTEXP(cv));
4196 Safefree(CvMUTEXP(cv));
4199 #endif /* USE_THREADS */
4202 if (CvFILE(cv) && !CvXSUB(cv)) {
4203 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4204 Safefree(CvFILE(cv));
4209 if (!CvXSUB(cv) && CvROOT(cv)) {
4211 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4212 Perl_croak(aTHX_ "Can't undef active subroutine");
4215 Perl_croak(aTHX_ "Can't undef active subroutine");
4216 #endif /* USE_THREADS */
4219 SAVEVPTR(PL_curpad);
4222 op_free(CvROOT(cv));
4223 CvROOT(cv) = Nullop;
4226 SvPOK_off((SV*)cv); /* forget prototype */
4228 /* Since closure prototypes have the same lifetime as the containing
4229 * CV, they don't hold a refcount on the outside CV. This avoids
4230 * the refcount loop between the outer CV (which keeps a refcount to
4231 * the closure prototype in the pad entry for pp_anoncode()) and the
4232 * closure prototype, and the ensuing memory leak. This does not
4233 * apply to closures generated within eval"", since eval"" CVs are
4234 * ephemeral. --GSAR */
4235 if (!CvANON(cv) || CvCLONED(cv)
4236 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4237 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4239 SvREFCNT_dec(CvOUTSIDE(cv));
4241 CvOUTSIDE(cv) = Nullcv;
4243 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4246 if (CvPADLIST(cv)) {
4247 /* may be during global destruction */
4248 if (SvREFCNT(CvPADLIST(cv))) {
4249 I32 i = AvFILLp(CvPADLIST(cv));
4251 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4252 SV* sv = svp ? *svp : Nullsv;
4255 if (sv == (SV*)PL_comppad_name)
4256 PL_comppad_name = Nullav;
4257 else if (sv == (SV*)PL_comppad) {
4258 PL_comppad = Nullav;
4259 PL_curpad = Null(SV**);
4263 SvREFCNT_dec((SV*)CvPADLIST(cv));
4265 CvPADLIST(cv) = Nullav;
4273 #ifdef DEBUG_CLOSURES
4275 S_cv_dump(pTHX_ CV *cv)
4278 CV *outside = CvOUTSIDE(cv);
4279 AV* padlist = CvPADLIST(cv);
4286 PerlIO_printf(Perl_debug_log,
4287 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4289 (CvANON(cv) ? "ANON"
4290 : (cv == PL_main_cv) ? "MAIN"
4291 : CvUNIQUE(cv) ? "UNIQUE"
4292 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4295 : CvANON(outside) ? "ANON"
4296 : (outside == PL_main_cv) ? "MAIN"
4297 : CvUNIQUE(outside) ? "UNIQUE"
4298 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4303 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4304 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4305 pname = AvARRAY(pad_name);
4306 ppad = AvARRAY(pad);
4308 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4309 if (SvPOK(pname[ix]))
4310 PerlIO_printf(Perl_debug_log,
4311 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4312 (int)ix, PTR2UV(ppad[ix]),
4313 SvFAKE(pname[ix]) ? "FAKE " : "",
4315 (IV)I_32(SvNVX(pname[ix])),
4318 #endif /* DEBUGGING */
4320 #endif /* DEBUG_CLOSURES */
4323 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4327 AV* protopadlist = CvPADLIST(proto);
4328 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4329 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4330 SV** pname = AvARRAY(protopad_name);
4331 SV** ppad = AvARRAY(protopad);
4332 I32 fname = AvFILLp(protopad_name);
4333 I32 fpad = AvFILLp(protopad);
4337 assert(!CvUNIQUE(proto));
4341 SAVESPTR(PL_comppad_name);
4342 SAVESPTR(PL_compcv);
4344 cv = PL_compcv = (CV*)NEWSV(1104,0);
4345 sv_upgrade((SV *)cv, SvTYPE(proto));
4346 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4350 New(666, CvMUTEXP(cv), 1, perl_mutex);
4351 MUTEX_INIT(CvMUTEXP(cv));
4353 #endif /* USE_THREADS */
4355 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4356 : savepv(CvFILE(proto));
4358 CvFILE(cv) = CvFILE(proto);
4360 CvGV(cv) = CvGV(proto);
4361 CvSTASH(cv) = CvSTASH(proto);
4362 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4363 CvSTART(cv) = CvSTART(proto);
4365 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4368 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4370 PL_comppad_name = newAV();
4371 for (ix = fname; ix >= 0; ix--)
4372 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4374 PL_comppad = newAV();
4376 comppadlist = newAV();
4377 AvREAL_off(comppadlist);
4378 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4379 av_store(comppadlist, 1, (SV*)PL_comppad);
4380 CvPADLIST(cv) = comppadlist;
4381 av_fill(PL_comppad, AvFILLp(protopad));
4382 PL_curpad = AvARRAY(PL_comppad);
4384 av = newAV(); /* will be @_ */
4386 av_store(PL_comppad, 0, (SV*)av);
4387 AvFLAGS(av) = AVf_REIFY;
4389 for (ix = fpad; ix > 0; ix--) {
4390 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4391 if (namesv && namesv != &PL_sv_undef) {
4392 char *name = SvPVX(namesv); /* XXX */
4393 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4394 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4395 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4397 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4399 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4401 else { /* our own lexical */
4404 /* anon code -- we'll come back for it */
4405 sv = SvREFCNT_inc(ppad[ix]);
4407 else if (*name == '@')
4409 else if (*name == '%')
4418 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4419 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4422 SV* sv = NEWSV(0,0);
4428 /* Now that vars are all in place, clone nested closures. */
4430 for (ix = fpad; ix > 0; ix--) {
4431 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4433 && namesv != &PL_sv_undef
4434 && !(SvFLAGS(namesv) & SVf_FAKE)
4435 && *SvPVX(namesv) == '&'
4436 && CvCLONE(ppad[ix]))
4438 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4439 SvREFCNT_dec(ppad[ix]);
4442 PL_curpad[ix] = (SV*)kid;
4446 #ifdef DEBUG_CLOSURES
4447 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4449 PerlIO_printf(Perl_debug_log, " from:\n");
4451 PerlIO_printf(Perl_debug_log, " to:\n");
4458 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4460 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4462 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4469 Perl_cv_clone(pTHX_ CV *proto)
4472 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4473 cv = cv_clone2(proto, CvOUTSIDE(proto));
4474 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4479 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4481 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4482 SV* msg = sv_newmortal();
4486 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4487 sv_setpv(msg, "Prototype mismatch:");
4489 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4491 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4492 sv_catpv(msg, " vs ");
4494 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4496 sv_catpv(msg, "none");
4497 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4501 static void const_sv_xsub(pTHXo_ CV* cv);
4504 =for apidoc cv_const_sv
4506 If C<cv> is a constant sub eligible for inlining. returns the constant
4507 value returned by the sub. Otherwise, returns NULL.
4509 Constant subs can be created with C<newCONSTSUB> or as described in
4510 L<perlsub/"Constant Functions">.
4515 Perl_cv_const_sv(pTHX_ CV *cv)
4517 if (!cv || !CvCONST(cv))
4519 return (SV*)CvXSUBANY(cv).any_ptr;
4523 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4530 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4531 o = cLISTOPo->op_first->op_sibling;
4533 for (; o; o = o->op_next) {
4534 OPCODE type = o->op_type;
4536 if (sv && o->op_next == o)
4538 if (o->op_next != o) {
4539 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4541 if (type == OP_DBSTATE)
4544 if (type == OP_LEAVESUB || type == OP_RETURN)
4548 if (type == OP_CONST && cSVOPo->op_sv)
4550 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4551 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4552 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4556 /* We get here only from cv_clone2() while creating a closure.
4557 Copy the const value here instead of in cv_clone2 so that
4558 SvREADONLY_on doesn't lead to problems when leaving
4563 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4575 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4585 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4589 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4591 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4595 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4601 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4606 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4607 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4608 SV *sv = sv_newmortal();
4609 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4610 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4615 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4616 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4626 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4627 maximum a prototype before. */
4628 if (SvTYPE(gv) > SVt_NULL) {
4629 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4630 && ckWARN_d(WARN_PROTOTYPE))
4632 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4634 cv_ckproto((CV*)gv, NULL, ps);
4637 sv_setpv((SV*)gv, ps);
4639 sv_setiv((SV*)gv, -1);
4640 SvREFCNT_dec(PL_compcv);
4641 cv = PL_compcv = NULL;
4642 PL_sub_generation++;
4646 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4648 #ifdef GV_UNIQUE_CHECK
4649 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4650 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4654 if (!block || !ps || *ps || attrs)
4657 const_sv = op_const_sv(block, Nullcv);
4660 bool exists = CvROOT(cv) || CvXSUB(cv);
4662 #ifdef GV_UNIQUE_CHECK
4663 if (exists && GvUNIQUE(gv)) {
4664 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4668 /* if the subroutine doesn't exist and wasn't pre-declared
4669 * with a prototype, assume it will be AUTOLOADed,
4670 * skipping the prototype check
4672 if (exists || SvPOK(cv))
4673 cv_ckproto(cv, gv, ps);
4674 /* already defined (or promised)? */
4675 if (exists || GvASSUMECV(gv)) {
4676 if (!block && !attrs) {
4677 /* just a "sub foo;" when &foo is already defined */
4678 SAVEFREESV(PL_compcv);
4681 /* ahem, death to those who redefine active sort subs */
4682 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4683 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4685 if (ckWARN(WARN_REDEFINE)
4687 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4689 line_t oldline = CopLINE(PL_curcop);
4690 CopLINE_set(PL_curcop, PL_copline);
4691 Perl_warner(aTHX_ WARN_REDEFINE,
4692 CvCONST(cv) ? "Constant subroutine %s redefined"
4693 : "Subroutine %s redefined", name);
4694 CopLINE_set(PL_curcop, oldline);
4702 SvREFCNT_inc(const_sv);
4704 assert(!CvROOT(cv) && !CvCONST(cv));
4705 sv_setpv((SV*)cv, ""); /* prototype is "" */
4706 CvXSUBANY(cv).any_ptr = const_sv;
4707 CvXSUB(cv) = const_sv_xsub;
4712 cv = newCONSTSUB(NULL, name, const_sv);
4715 SvREFCNT_dec(PL_compcv);
4717 PL_sub_generation++;
4724 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4725 * before we clobber PL_compcv.
4729 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4730 stash = GvSTASH(CvGV(cv));
4731 else if (CvSTASH(cv))
4732 stash = CvSTASH(cv);
4734 stash = PL_curstash;
4737 /* possibly about to re-define existing subr -- ignore old cv */
4738 rcv = (SV*)PL_compcv;
4739 if (name && GvSTASH(gv))
4740 stash = GvSTASH(gv);
4742 stash = PL_curstash;
4744 apply_attrs(stash, rcv, attrs);
4746 if (cv) { /* must reuse cv if autoloaded */
4748 /* got here with just attrs -- work done, so bug out */
4749 SAVEFREESV(PL_compcv);
4753 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4754 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4755 CvOUTSIDE(PL_compcv) = 0;
4756 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4757 CvPADLIST(PL_compcv) = 0;
4758 /* inner references to PL_compcv must be fixed up ... */
4760 AV *padlist = CvPADLIST(cv);
4761 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4762 AV *comppad = (AV*)AvARRAY(padlist)[1];
4763 SV **namepad = AvARRAY(comppad_name);
4764 SV **curpad = AvARRAY(comppad);
4765 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4766 SV *namesv = namepad[ix];
4767 if (namesv && namesv != &PL_sv_undef
4768 && *SvPVX(namesv) == '&')
4770 CV *innercv = (CV*)curpad[ix];
4771 if (CvOUTSIDE(innercv) == PL_compcv) {
4772 CvOUTSIDE(innercv) = cv;
4773 if (!CvANON(innercv) || CvCLONED(innercv)) {
4774 (void)SvREFCNT_inc(cv);
4775 SvREFCNT_dec(PL_compcv);
4781 /* ... before we throw it away */
4782 SvREFCNT_dec(PL_compcv);
4783 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4784 ++PL_sub_generation;
4791 PL_sub_generation++;
4795 CvFILE_set_from_cop(cv, PL_curcop);
4796 CvSTASH(cv) = PL_curstash;
4799 if (!CvMUTEXP(cv)) {
4800 New(666, CvMUTEXP(cv), 1, perl_mutex);
4801 MUTEX_INIT(CvMUTEXP(cv));
4803 #endif /* USE_THREADS */
4806 sv_setpv((SV*)cv, ps);
4808 if (PL_error_count) {
4812 char *s = strrchr(name, ':');
4814 if (strEQ(s, "BEGIN")) {
4816 "BEGIN not safe after errors--compilation aborted";
4817 if (PL_in_eval & EVAL_KEEPERR)
4818 Perl_croak(aTHX_ not_safe);
4820 /* force display of errors found but not reported */
4821 sv_catpv(ERRSV, not_safe);
4822 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4830 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4831 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4834 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4835 mod(scalarseq(block), OP_LEAVESUBLV));
4838 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4840 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4841 OpREFCNT_set(CvROOT(cv), 1);
4842 CvSTART(cv) = LINKLIST(CvROOT(cv));
4843 CvROOT(cv)->op_next = 0;
4844 CALL_PEEP(CvSTART(cv));
4846 /* now that optimizer has done its work, adjust pad values */
4848 SV **namep = AvARRAY(PL_comppad_name);
4849 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4852 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4855 * The only things that a clonable function needs in its
4856 * pad are references to outer lexicals and anonymous subs.
4857 * The rest are created anew during cloning.
4859 if (!((namesv = namep[ix]) != Nullsv &&
4860 namesv != &PL_sv_undef &&
4862 *SvPVX(namesv) == '&')))
4864 SvREFCNT_dec(PL_curpad[ix]);
4865 PL_curpad[ix] = Nullsv;
4868 assert(!CvCONST(cv));
4869 if (ps && !*ps && op_const_sv(block, cv))
4873 AV *av = newAV(); /* Will be @_ */
4875 av_store(PL_comppad, 0, (SV*)av);
4876 AvFLAGS(av) = AVf_REIFY;
4878 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4879 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4881 if (!SvPADMY(PL_curpad[ix]))
4882 SvPADTMP_on(PL_curpad[ix]);
4886 /* If a potential closure prototype, don't keep a refcount on
4887 * outer CV, unless the latter happens to be a passing eval"".
4888 * This is okay as the lifetime of the prototype is tied to the
4889 * lifetime of the outer CV. Avoids memory leak due to reference
4891 if (!name && CvOUTSIDE(cv)
4892 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4893 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4895 SvREFCNT_dec(CvOUTSIDE(cv));
4898 if (name || aname) {
4900 char *tname = (name ? name : aname);
4902 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4903 SV *sv = NEWSV(0,0);
4904 SV *tmpstr = sv_newmortal();
4905 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4909 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4911 (long)PL_subline, (long)CopLINE(PL_curcop));
4912 gv_efullname3(tmpstr, gv, Nullch);
4913 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4914 hv = GvHVn(db_postponed);
4915 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4916 && (pcv = GvCV(db_postponed)))
4922 call_sv((SV*)pcv, G_DISCARD);
4926 if ((s = strrchr(tname,':')))
4931 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4934 if (strEQ(s, "BEGIN")) {
4935 I32 oldscope = PL_scopestack_ix;
4937 SAVECOPFILE(&PL_compiling);
4938 SAVECOPLINE(&PL_compiling);
4940 sv_setsv(PL_rs, PL_nrs);
4943 PL_beginav = newAV();
4944 DEBUG_x( dump_sub(gv) );
4945 av_push(PL_beginav, (SV*)cv);
4946 GvCV(gv) = 0; /* cv has been hijacked */
4947 call_list(oldscope, PL_beginav);
4949 PL_curcop = &PL_compiling;
4950 PL_compiling.op_private = PL_hints;
4953 else if (strEQ(s, "END") && !PL_error_count) {
4956 DEBUG_x( dump_sub(gv) );
4957 av_unshift(PL_endav, 1);
4958 av_store(PL_endav, 0, (SV*)cv);
4959 GvCV(gv) = 0; /* cv has been hijacked */
4961 else if (strEQ(s, "CHECK") && !PL_error_count) {
4963 PL_checkav = newAV();
4964 DEBUG_x( dump_sub(gv) );
4965 if (PL_main_start && ckWARN(WARN_VOID))
4966 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4967 av_unshift(PL_checkav, 1);
4968 av_store(PL_checkav, 0, (SV*)cv);
4969 GvCV(gv) = 0; /* cv has been hijacked */
4971 else if (strEQ(s, "INIT") && !PL_error_count) {
4973 PL_initav = newAV();
4974 DEBUG_x( dump_sub(gv) );
4975 if (PL_main_start && ckWARN(WARN_VOID))
4976 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4977 av_push(PL_initav, (SV*)cv);
4978 GvCV(gv) = 0; /* cv has been hijacked */
4983 PL_copline = NOLINE;
4988 /* XXX unsafe for threads if eval_owner isn't held */
4990 =for apidoc newCONSTSUB
4992 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4993 eligible for inlining at compile-time.
4999 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5005 SAVECOPLINE(PL_curcop);
5006 CopLINE_set(PL_curcop, PL_copline);
5009 PL_hints &= ~HINT_BLOCK_SCOPE;
5012 SAVESPTR(PL_curstash);
5013 SAVECOPSTASH(PL_curcop);
5014 PL_curstash = stash;
5016 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5018 CopSTASH(PL_curcop) = stash;
5022 cv = newXS(name, const_sv_xsub, __FILE__);
5023 CvXSUBANY(cv).any_ptr = sv;
5025 sv_setpv((SV*)cv, ""); /* prototype is "" */
5033 =for apidoc U||newXS
5035 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5041 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5043 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5046 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5048 /* just a cached method */
5052 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5053 /* already defined (or promised) */
5054 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5055 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5056 line_t oldline = CopLINE(PL_curcop);
5057 if (PL_copline != NOLINE)
5058 CopLINE_set(PL_curcop, PL_copline);
5059 Perl_warner(aTHX_ WARN_REDEFINE,
5060 CvCONST(cv) ? "Constant subroutine %s redefined"
5061 : "Subroutine %s redefined"
5063 CopLINE_set(PL_curcop, oldline);
5070 if (cv) /* must reuse cv if autoloaded */
5073 cv = (CV*)NEWSV(1105,0);
5074 sv_upgrade((SV *)cv, SVt_PVCV);
5078 PL_sub_generation++;
5083 New(666, CvMUTEXP(cv), 1, perl_mutex);
5084 MUTEX_INIT(CvMUTEXP(cv));
5086 #endif /* USE_THREADS */
5087 (void)gv_fetchfile(filename);
5088 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5089 an external constant string */
5090 CvXSUB(cv) = subaddr;
5093 char *s = strrchr(name,':');
5099 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5102 if (strEQ(s, "BEGIN")) {
5104 PL_beginav = newAV();
5105 av_push(PL_beginav, (SV*)cv);
5106 GvCV(gv) = 0; /* cv has been hijacked */
5108 else if (strEQ(s, "END")) {
5111 av_unshift(PL_endav, 1);
5112 av_store(PL_endav, 0, (SV*)cv);
5113 GvCV(gv) = 0; /* cv has been hijacked */
5115 else if (strEQ(s, "CHECK")) {
5117 PL_checkav = newAV();
5118 if (PL_main_start && ckWARN(WARN_VOID))
5119 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5120 av_unshift(PL_checkav, 1);
5121 av_store(PL_checkav, 0, (SV*)cv);
5122 GvCV(gv) = 0; /* cv has been hijacked */
5124 else if (strEQ(s, "INIT")) {
5126 PL_initav = newAV();
5127 if (PL_main_start && ckWARN(WARN_VOID))
5128 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5129 av_push(PL_initav, (SV*)cv);
5130 GvCV(gv) = 0; /* cv has been hijacked */
5141 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5150 name = SvPVx(cSVOPo->op_sv, n_a);
5153 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5154 #ifdef GV_UNIQUE_CHECK
5156 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5160 if ((cv = GvFORM(gv))) {
5161 if (ckWARN(WARN_REDEFINE)) {
5162 line_t oldline = CopLINE(PL_curcop);
5164 CopLINE_set(PL_curcop, PL_copline);
5165 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5166 CopLINE_set(PL_curcop, oldline);
5173 CvFILE_set_from_cop(cv, PL_curcop);
5175 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5176 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5177 SvPADTMP_on(PL_curpad[ix]);
5180 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5181 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5182 OpREFCNT_set(CvROOT(cv), 1);
5183 CvSTART(cv) = LINKLIST(CvROOT(cv));
5184 CvROOT(cv)->op_next = 0;
5185 CALL_PEEP(CvSTART(cv));
5187 PL_copline = NOLINE;
5192 Perl_newANONLIST(pTHX_ OP *o)
5194 return newUNOP(OP_REFGEN, 0,
5195 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5199 Perl_newANONHASH(pTHX_ OP *o)
5201 return newUNOP(OP_REFGEN, 0,
5202 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5206 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5208 return newANONATTRSUB(floor, proto, Nullop, block);
5212 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5214 return newUNOP(OP_REFGEN, 0,
5215 newSVOP(OP_ANONCODE, 0,
5216 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5220 Perl_oopsAV(pTHX_ OP *o)
5222 switch (o->op_type) {
5224 o->op_type = OP_PADAV;
5225 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5226 return ref(o, OP_RV2AV);
5229 o->op_type = OP_RV2AV;
5230 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5235 if (ckWARN_d(WARN_INTERNAL))
5236 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5243 Perl_oopsHV(pTHX_ OP *o)
5245 switch (o->op_type) {
5248 o->op_type = OP_PADHV;
5249 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5250 return ref(o, OP_RV2HV);
5254 o->op_type = OP_RV2HV;
5255 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5260 if (ckWARN_d(WARN_INTERNAL))
5261 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5268 Perl_newAVREF(pTHX_ OP *o)
5270 if (o->op_type == OP_PADANY) {
5271 o->op_type = OP_PADAV;
5272 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5275 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5276 && ckWARN(WARN_DEPRECATED)) {
5277 Perl_warner(aTHX_ WARN_DEPRECATED,
5278 "Using an array as a reference is deprecated");
5280 return newUNOP(OP_RV2AV, 0, scalar(o));
5284 Perl_newGVREF(pTHX_ I32 type, OP *o)
5286 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5287 return newUNOP(OP_NULL, 0, o);
5288 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5292 Perl_newHVREF(pTHX_ OP *o)
5294 if (o->op_type == OP_PADANY) {
5295 o->op_type = OP_PADHV;
5296 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5299 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5300 && ckWARN(WARN_DEPRECATED)) {
5301 Perl_warner(aTHX_ WARN_DEPRECATED,
5302 "Using a hash as a reference is deprecated");
5304 return newUNOP(OP_RV2HV, 0, scalar(o));
5308 Perl_oopsCV(pTHX_ OP *o)
5310 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5316 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5318 return newUNOP(OP_RV2CV, flags, scalar(o));
5322 Perl_newSVREF(pTHX_ OP *o)
5324 if (o->op_type == OP_PADANY) {
5325 o->op_type = OP_PADSV;
5326 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5329 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5330 o->op_flags |= OPpDONE_SVREF;
5333 return newUNOP(OP_RV2SV, 0, scalar(o));
5336 /* Check routines. */
5339 Perl_ck_anoncode(pTHX_ OP *o)
5344 name = NEWSV(1106,0);
5345 sv_upgrade(name, SVt_PVNV);
5346 sv_setpvn(name, "&", 1);
5349 ix = pad_alloc(o->op_type, SVs_PADMY);
5350 av_store(PL_comppad_name, ix, name);
5351 av_store(PL_comppad, ix, cSVOPo->op_sv);
5352 SvPADMY_on(cSVOPo->op_sv);
5353 cSVOPo->op_sv = Nullsv;
5354 cSVOPo->op_targ = ix;
5359 Perl_ck_bitop(pTHX_ OP *o)
5361 o->op_private = PL_hints;
5366 Perl_ck_concat(pTHX_ OP *o)
5368 if (cUNOPo->op_first->op_type == OP_CONCAT)
5369 o->op_flags |= OPf_STACKED;
5374 Perl_ck_spair(pTHX_ OP *o)
5376 if (o->op_flags & OPf_KIDS) {
5379 OPCODE type = o->op_type;
5380 o = modkids(ck_fun(o), type);
5381 kid = cUNOPo->op_first;
5382 newop = kUNOP->op_first->op_sibling;
5384 (newop->op_sibling ||
5385 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5386 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5387 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5391 op_free(kUNOP->op_first);
5392 kUNOP->op_first = newop;
5394 o->op_ppaddr = PL_ppaddr[++o->op_type];
5399 Perl_ck_delete(pTHX_ OP *o)
5403 if (o->op_flags & OPf_KIDS) {
5404 OP *kid = cUNOPo->op_first;
5405 switch (kid->op_type) {
5407 o->op_flags |= OPf_SPECIAL;
5410 o->op_private |= OPpSLICE;
5413 o->op_flags |= OPf_SPECIAL;
5418 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5419 PL_op_desc[o->op_type]);
5427 Perl_ck_eof(pTHX_ OP *o)
5429 I32 type = o->op_type;
5431 if (o->op_flags & OPf_KIDS) {
5432 if (cLISTOPo->op_first->op_type == OP_STUB) {
5434 o = newUNOP(type, OPf_SPECIAL,
5435 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5443 Perl_ck_eval(pTHX_ OP *o)
5445 PL_hints |= HINT_BLOCK_SCOPE;
5446 if (o->op_flags & OPf_KIDS) {
5447 SVOP *kid = (SVOP*)cUNOPo->op_first;
5450 o->op_flags &= ~OPf_KIDS;
5453 else if (kid->op_type == OP_LINESEQ) {
5456 kid->op_next = o->op_next;
5457 cUNOPo->op_first = 0;
5460 NewOp(1101, enter, 1, LOGOP);
5461 enter->op_type = OP_ENTERTRY;
5462 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5463 enter->op_private = 0;
5465 /* establish postfix order */
5466 enter->op_next = (OP*)enter;
5468 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5469 o->op_type = OP_LEAVETRY;
5470 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5471 enter->op_other = o;
5479 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5481 o->op_targ = (PADOFFSET)PL_hints;
5486 Perl_ck_exit(pTHX_ OP *o)
5489 HV *table = GvHV(PL_hintgv);
5491 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5492 if (svp && *svp && SvTRUE(*svp))
5493 o->op_private |= OPpEXIT_VMSISH;
5500 Perl_ck_exec(pTHX_ OP *o)
5503 if (o->op_flags & OPf_STACKED) {
5505 kid = cUNOPo->op_first->op_sibling;
5506 if (kid->op_type == OP_RV2GV)
5515 Perl_ck_exists(pTHX_ OP *o)
5518 if (o->op_flags & OPf_KIDS) {
5519 OP *kid = cUNOPo->op_first;
5520 if (kid->op_type == OP_ENTERSUB) {
5521 (void) ref(kid, o->op_type);
5522 if (kid->op_type != OP_RV2CV && !PL_error_count)
5523 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5524 PL_op_desc[o->op_type]);
5525 o->op_private |= OPpEXISTS_SUB;
5527 else if (kid->op_type == OP_AELEM)
5528 o->op_flags |= OPf_SPECIAL;
5529 else if (kid->op_type != OP_HELEM)
5530 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5531 PL_op_desc[o->op_type]);
5539 Perl_ck_gvconst(pTHX_ register OP *o)
5541 o = fold_constants(o);
5542 if (o->op_type == OP_CONST)
5549 Perl_ck_rvconst(pTHX_ register OP *o)
5551 SVOP *kid = (SVOP*)cUNOPo->op_first;
5553 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5554 if (kid->op_type == OP_CONST) {
5558 SV *kidsv = kid->op_sv;
5561 /* Is it a constant from cv_const_sv()? */
5562 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5563 SV *rsv = SvRV(kidsv);
5564 int svtype = SvTYPE(rsv);
5565 char *badtype = Nullch;
5567 switch (o->op_type) {
5569 if (svtype > SVt_PVMG)
5570 badtype = "a SCALAR";
5573 if (svtype != SVt_PVAV)
5574 badtype = "an ARRAY";
5577 if (svtype != SVt_PVHV) {
5578 if (svtype == SVt_PVAV) { /* pseudohash? */
5579 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5580 if (ksv && SvROK(*ksv)
5581 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5590 if (svtype != SVt_PVCV)
5595 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5598 name = SvPV(kidsv, n_a);
5599 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5600 char *badthing = Nullch;
5601 switch (o->op_type) {
5603 badthing = "a SCALAR";
5606 badthing = "an ARRAY";
5609 badthing = "a HASH";
5614 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5618 * This is a little tricky. We only want to add the symbol if we
5619 * didn't add it in the lexer. Otherwise we get duplicate strict
5620 * warnings. But if we didn't add it in the lexer, we must at
5621 * least pretend like we wanted to add it even if it existed before,
5622 * or we get possible typo warnings. OPpCONST_ENTERED says
5623 * whether the lexer already added THIS instance of this symbol.
5625 iscv = (o->op_type == OP_RV2CV) * 2;
5627 gv = gv_fetchpv(name,
5628 iscv | !(kid->op_private & OPpCONST_ENTERED),
5631 : o->op_type == OP_RV2SV
5633 : o->op_type == OP_RV2AV
5635 : o->op_type == OP_RV2HV
5638 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5640 kid->op_type = OP_GV;
5641 SvREFCNT_dec(kid->op_sv);
5643 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5644 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5645 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5647 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5649 kid->op_sv = SvREFCNT_inc(gv);
5651 kid->op_private = 0;
5652 kid->op_ppaddr = PL_ppaddr[OP_GV];
5659 Perl_ck_ftst(pTHX_ OP *o)
5661 I32 type = o->op_type;
5663 if (o->op_flags & OPf_REF) {
5666 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5667 SVOP *kid = (SVOP*)cUNOPo->op_first;
5669 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5671 OP *newop = newGVOP(type, OPf_REF,
5672 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5679 if (type == OP_FTTTY)
5680 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5683 o = newUNOP(type, 0, newDEFSVOP());
5689 Perl_ck_fun(pTHX_ OP *o)
5695 int type = o->op_type;
5696 register I32 oa = PL_opargs[type] >> OASHIFT;
5698 if (o->op_flags & OPf_STACKED) {
5699 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5702 return no_fh_allowed(o);
5705 if (o->op_flags & OPf_KIDS) {
5707 tokid = &cLISTOPo->op_first;
5708 kid = cLISTOPo->op_first;
5709 if (kid->op_type == OP_PUSHMARK ||
5710 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5712 tokid = &kid->op_sibling;
5713 kid = kid->op_sibling;
5715 if (!kid && PL_opargs[type] & OA_DEFGV)
5716 *tokid = kid = newDEFSVOP();
5720 sibl = kid->op_sibling;
5723 /* list seen where single (scalar) arg expected? */
5724 if (numargs == 1 && !(oa >> 4)
5725 && kid->op_type == OP_LIST && type != OP_SCALAR)
5727 return too_many_arguments(o,PL_op_desc[type]);
5740 if ((type == OP_PUSH || type == OP_UNSHIFT)
5741 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5742 Perl_warner(aTHX_ WARN_SYNTAX,
5743 "Useless use of %s with no values",
5746 if (kid->op_type == OP_CONST &&
5747 (kid->op_private & OPpCONST_BARE))
5749 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5750 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5751 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5752 if (ckWARN(WARN_DEPRECATED))
5753 Perl_warner(aTHX_ WARN_DEPRECATED,
5754 "Array @%s missing the @ in argument %"IVdf" of %s()",
5755 name, (IV)numargs, PL_op_desc[type]);
5758 kid->op_sibling = sibl;
5761 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5762 bad_type(numargs, "array", PL_op_desc[type], kid);
5766 if (kid->op_type == OP_CONST &&
5767 (kid->op_private & OPpCONST_BARE))
5769 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5770 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5771 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5772 if (ckWARN(WARN_DEPRECATED))
5773 Perl_warner(aTHX_ WARN_DEPRECATED,
5774 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5775 name, (IV)numargs, PL_op_desc[type]);
5778 kid->op_sibling = sibl;
5781 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5782 bad_type(numargs, "hash", PL_op_desc[type], kid);
5787 OP *newop = newUNOP(OP_NULL, 0, kid);
5788 kid->op_sibling = 0;
5790 newop->op_next = newop;
5792 kid->op_sibling = sibl;
5797 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5798 if (kid->op_type == OP_CONST &&
5799 (kid->op_private & OPpCONST_BARE))
5801 OP *newop = newGVOP(OP_GV, 0,
5802 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5807 else if (kid->op_type == OP_READLINE) {
5808 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5809 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5812 I32 flags = OPf_SPECIAL;
5816 /* is this op a FH constructor? */
5817 if (is_handle_constructor(o,numargs)) {
5818 char *name = Nullch;
5822 /* Set a flag to tell rv2gv to vivify
5823 * need to "prove" flag does not mean something
5824 * else already - NI-S 1999/05/07
5827 if (kid->op_type == OP_PADSV) {
5828 SV **namep = av_fetch(PL_comppad_name,
5830 if (namep && *namep)
5831 name = SvPV(*namep, len);
5833 else if (kid->op_type == OP_RV2SV
5834 && kUNOP->op_first->op_type == OP_GV)
5836 GV *gv = cGVOPx_gv(kUNOP->op_first);
5838 len = GvNAMELEN(gv);
5840 else if (kid->op_type == OP_AELEM
5841 || kid->op_type == OP_HELEM)
5843 name = "__ANONIO__";
5849 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5850 namesv = PL_curpad[targ];
5851 (void)SvUPGRADE(namesv, SVt_PV);
5853 sv_setpvn(namesv, "$", 1);
5854 sv_catpvn(namesv, name, len);
5857 kid->op_sibling = 0;
5858 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5859 kid->op_targ = targ;
5860 kid->op_private |= priv;
5862 kid->op_sibling = sibl;
5868 mod(scalar(kid), type);
5872 tokid = &kid->op_sibling;
5873 kid = kid->op_sibling;
5875 o->op_private |= numargs;
5877 return too_many_arguments(o,PL_op_desc[o->op_type]);
5880 else if (PL_opargs[type] & OA_DEFGV) {
5882 return newUNOP(type, 0, newDEFSVOP());
5886 while (oa & OA_OPTIONAL)
5888 if (oa && oa != OA_LIST)
5889 return too_few_arguments(o,PL_op_desc[o->op_type]);
5895 Perl_ck_glob(pTHX_ OP *o)
5900 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5901 append_elem(OP_GLOB, o, newDEFSVOP());
5903 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5904 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5906 #if !defined(PERL_EXTERNAL_GLOB)
5907 /* XXX this can be tightened up and made more failsafe. */
5911 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5913 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5914 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5915 GvCV(gv) = GvCV(glob_gv);
5916 SvREFCNT_inc((SV*)GvCV(gv));
5917 GvIMPORTED_CV_on(gv);
5920 #endif /* PERL_EXTERNAL_GLOB */
5922 if (gv && GvIMPORTED_CV(gv)) {
5923 append_elem(OP_GLOB, o,
5924 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5925 o->op_type = OP_LIST;
5926 o->op_ppaddr = PL_ppaddr[OP_LIST];
5927 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5928 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5929 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5930 append_elem(OP_LIST, o,
5931 scalar(newUNOP(OP_RV2CV, 0,
5932 newGVOP(OP_GV, 0, gv)))));
5933 o = newUNOP(OP_NULL, 0, ck_subr(o));
5934 o->op_targ = OP_GLOB; /* hint at what it used to be */
5937 gv = newGVgen("main");
5939 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5945 Perl_ck_grep(pTHX_ OP *o)
5949 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5951 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5952 NewOp(1101, gwop, 1, LOGOP);
5954 if (o->op_flags & OPf_STACKED) {
5957 kid = cLISTOPo->op_first->op_sibling;
5958 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5961 kid->op_next = (OP*)gwop;
5962 o->op_flags &= ~OPf_STACKED;
5964 kid = cLISTOPo->op_first->op_sibling;
5965 if (type == OP_MAPWHILE)
5972 kid = cLISTOPo->op_first->op_sibling;
5973 if (kid->op_type != OP_NULL)
5974 Perl_croak(aTHX_ "panic: ck_grep");
5975 kid = kUNOP->op_first;
5977 gwop->op_type = type;
5978 gwop->op_ppaddr = PL_ppaddr[type];
5979 gwop->op_first = listkids(o);
5980 gwop->op_flags |= OPf_KIDS;
5981 gwop->op_private = 1;
5982 gwop->op_other = LINKLIST(kid);
5983 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5984 kid->op_next = (OP*)gwop;
5986 kid = cLISTOPo->op_first->op_sibling;
5987 if (!kid || !kid->op_sibling)
5988 return too_few_arguments(o,PL_op_desc[o->op_type]);
5989 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5990 mod(kid, OP_GREPSTART);
5996 Perl_ck_index(pTHX_ OP *o)
5998 if (o->op_flags & OPf_KIDS) {
5999 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6001 kid = kid->op_sibling; /* get past "big" */
6002 if (kid && kid->op_type == OP_CONST)
6003 fbm_compile(((SVOP*)kid)->op_sv, 0);
6009 Perl_ck_lengthconst(pTHX_ OP *o)
6011 /* XXX length optimization goes here */
6016 Perl_ck_lfun(pTHX_ OP *o)
6018 OPCODE type = o->op_type;
6019 return modkids(ck_fun(o), type);
6023 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6025 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6026 switch (cUNOPo->op_first->op_type) {
6028 /* This is needed for
6029 if (defined %stash::)
6030 to work. Do not break Tk.
6032 break; /* Globals via GV can be undef */
6034 case OP_AASSIGN: /* Is this a good idea? */
6035 Perl_warner(aTHX_ WARN_DEPRECATED,
6036 "defined(@array) is deprecated");
6037 Perl_warner(aTHX_ WARN_DEPRECATED,
6038 "\t(Maybe you should just omit the defined()?)\n");
6041 /* This is needed for
6042 if (defined %stash::)
6043 to work. Do not break Tk.
6045 break; /* Globals via GV can be undef */
6047 Perl_warner(aTHX_ WARN_DEPRECATED,
6048 "defined(%%hash) is deprecated");
6049 Perl_warner(aTHX_ WARN_DEPRECATED,
6050 "\t(Maybe you should just omit the defined()?)\n");
6061 Perl_ck_rfun(pTHX_ OP *o)
6063 OPCODE type = o->op_type;
6064 return refkids(ck_fun(o), type);
6068 Perl_ck_listiob(pTHX_ OP *o)
6072 kid = cLISTOPo->op_first;
6075 kid = cLISTOPo->op_first;
6077 if (kid->op_type == OP_PUSHMARK)
6078 kid = kid->op_sibling;
6079 if (kid && o->op_flags & OPf_STACKED)
6080 kid = kid->op_sibling;
6081 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6082 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6083 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6084 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6085 cLISTOPo->op_first->op_sibling = kid;
6086 cLISTOPo->op_last = kid;
6087 kid = kid->op_sibling;
6092 append_elem(o->op_type, o, newDEFSVOP());
6098 Perl_ck_sassign(pTHX_ OP *o)
6100 OP *kid = cLISTOPo->op_first;
6101 /* has a disposable target? */
6102 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6103 && !(kid->op_flags & OPf_STACKED)
6104 /* Cannot steal the second time! */
6105 && !(kid->op_private & OPpTARGET_MY))
6107 OP *kkid = kid->op_sibling;
6109 /* Can just relocate the target. */
6110 if (kkid && kkid->op_type == OP_PADSV
6111 && !(kkid->op_private & OPpLVAL_INTRO))
6113 kid->op_targ = kkid->op_targ;
6115 /* Now we do not need PADSV and SASSIGN. */
6116 kid->op_sibling = o->op_sibling; /* NULL */
6117 cLISTOPo->op_first = NULL;
6120 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6128 Perl_ck_match(pTHX_ OP *o)
6130 o->op_private |= OPpRUNTIME;
6135 Perl_ck_method(pTHX_ OP *o)
6137 OP *kid = cUNOPo->op_first;
6138 if (kid->op_type == OP_CONST) {
6139 SV* sv = kSVOP->op_sv;
6140 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6142 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6143 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6146 kSVOP->op_sv = Nullsv;
6148 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6157 Perl_ck_null(pTHX_ OP *o)
6163 Perl_ck_open(pTHX_ OP *o)
6165 HV *table = GvHV(PL_hintgv);
6169 svp = hv_fetch(table, "open_IN", 7, FALSE);
6171 mode = mode_from_discipline(*svp);
6172 if (mode & O_BINARY)
6173 o->op_private |= OPpOPEN_IN_RAW;
6174 else if (mode & O_TEXT)
6175 o->op_private |= OPpOPEN_IN_CRLF;
6178 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6180 mode = mode_from_discipline(*svp);
6181 if (mode & O_BINARY)
6182 o->op_private |= OPpOPEN_OUT_RAW;
6183 else if (mode & O_TEXT)
6184 o->op_private |= OPpOPEN_OUT_CRLF;
6187 if (o->op_type == OP_BACKTICK)
6193 Perl_ck_repeat(pTHX_ OP *o)
6195 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6196 o->op_private |= OPpREPEAT_DOLIST;
6197 cBINOPo->op_first = force_list(cBINOPo->op_first);
6205 Perl_ck_require(pTHX_ OP *o)
6209 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6210 SVOP *kid = (SVOP*)cUNOPo->op_first;
6212 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6214 for (s = SvPVX(kid->op_sv); *s; s++) {
6215 if (*s == ':' && s[1] == ':') {
6217 Move(s+2, s+1, strlen(s+2)+1, char);
6218 --SvCUR(kid->op_sv);
6221 if (SvREADONLY(kid->op_sv)) {
6222 SvREADONLY_off(kid->op_sv);
6223 sv_catpvn(kid->op_sv, ".pm", 3);
6224 SvREADONLY_on(kid->op_sv);
6227 sv_catpvn(kid->op_sv, ".pm", 3);
6231 /* handle override, if any */
6232 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6233 if (!(gv && GvIMPORTED_CV(gv)))
6234 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6236 if (gv && GvIMPORTED_CV(gv)) {
6237 OP *kid = cUNOPo->op_first;
6238 cUNOPo->op_first = 0;
6240 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6241 append_elem(OP_LIST, kid,
6242 scalar(newUNOP(OP_RV2CV, 0,
6251 Perl_ck_return(pTHX_ OP *o)
6254 if (CvLVALUE(PL_compcv)) {
6255 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6256 mod(kid, OP_LEAVESUBLV);
6263 Perl_ck_retarget(pTHX_ OP *o)
6265 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6272 Perl_ck_select(pTHX_ OP *o)
6275 if (o->op_flags & OPf_KIDS) {
6276 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6277 if (kid && kid->op_sibling) {
6278 o->op_type = OP_SSELECT;
6279 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6281 return fold_constants(o);
6285 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6286 if (kid && kid->op_type == OP_RV2GV)
6287 kid->op_private &= ~HINT_STRICT_REFS;
6292 Perl_ck_shift(pTHX_ OP *o)
6294 I32 type = o->op_type;
6296 if (!(o->op_flags & OPf_KIDS)) {
6301 if (!CvUNIQUE(PL_compcv)) {
6302 argop = newOP(OP_PADAV, OPf_REF);
6303 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6306 argop = newUNOP(OP_RV2AV, 0,
6307 scalar(newGVOP(OP_GV, 0,
6308 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6311 argop = newUNOP(OP_RV2AV, 0,
6312 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6313 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6314 #endif /* USE_THREADS */
6315 return newUNOP(type, 0, scalar(argop));
6317 return scalar(modkids(ck_fun(o), type));
6321 Perl_ck_sort(pTHX_ OP *o)
6325 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6327 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6328 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6330 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6332 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6334 if (kid->op_type == OP_SCOPE) {
6338 else if (kid->op_type == OP_LEAVE) {
6339 if (o->op_type == OP_SORT) {
6340 op_null(kid); /* wipe out leave */
6343 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6344 if (k->op_next == kid)
6346 /* don't descend into loops */
6347 else if (k->op_type == OP_ENTERLOOP
6348 || k->op_type == OP_ENTERITER)
6350 k = cLOOPx(k)->op_lastop;
6355 kid->op_next = 0; /* just disconnect the leave */
6356 k = kLISTOP->op_first;
6361 if (o->op_type == OP_SORT) {
6362 /* provide scalar context for comparison function/block */
6368 o->op_flags |= OPf_SPECIAL;
6370 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6373 firstkid = firstkid->op_sibling;
6376 /* provide list context for arguments */
6377 if (o->op_type == OP_SORT)
6384 S_simplify_sort(pTHX_ OP *o)
6386 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6390 if (!(o->op_flags & OPf_STACKED))
6392 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6393 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6394 kid = kUNOP->op_first; /* get past null */
6395 if (kid->op_type != OP_SCOPE)
6397 kid = kLISTOP->op_last; /* get past scope */
6398 switch(kid->op_type) {
6406 k = kid; /* remember this node*/
6407 if (kBINOP->op_first->op_type != OP_RV2SV)
6409 kid = kBINOP->op_first; /* get past cmp */
6410 if (kUNOP->op_first->op_type != OP_GV)
6412 kid = kUNOP->op_first; /* get past rv2sv */
6414 if (GvSTASH(gv) != PL_curstash)
6416 if (strEQ(GvNAME(gv), "a"))
6418 else if (strEQ(GvNAME(gv), "b"))
6422 kid = k; /* back to cmp */
6423 if (kBINOP->op_last->op_type != OP_RV2SV)
6425 kid = kBINOP->op_last; /* down to 2nd arg */
6426 if (kUNOP->op_first->op_type != OP_GV)
6428 kid = kUNOP->op_first; /* get past rv2sv */
6430 if (GvSTASH(gv) != PL_curstash
6432 ? strNE(GvNAME(gv), "a")
6433 : strNE(GvNAME(gv), "b")))
6435 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6437 o->op_private |= OPpSORT_REVERSE;
6438 if (k->op_type == OP_NCMP)
6439 o->op_private |= OPpSORT_NUMERIC;
6440 if (k->op_type == OP_I_NCMP)
6441 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6442 kid = cLISTOPo->op_first->op_sibling;
6443 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6444 op_free(kid); /* then delete it */
6448 Perl_ck_split(pTHX_ OP *o)
6452 if (o->op_flags & OPf_STACKED)
6453 return no_fh_allowed(o);
6455 kid = cLISTOPo->op_first;
6456 if (kid->op_type != OP_NULL)
6457 Perl_croak(aTHX_ "panic: ck_split");
6458 kid = kid->op_sibling;
6459 op_free(cLISTOPo->op_first);
6460 cLISTOPo->op_first = kid;
6462 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6463 cLISTOPo->op_last = kid; /* There was only one element previously */
6466 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6467 OP *sibl = kid->op_sibling;
6468 kid->op_sibling = 0;
6469 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6470 if (cLISTOPo->op_first == cLISTOPo->op_last)
6471 cLISTOPo->op_last = kid;
6472 cLISTOPo->op_first = kid;
6473 kid->op_sibling = sibl;
6476 kid->op_type = OP_PUSHRE;
6477 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6480 if (!kid->op_sibling)
6481 append_elem(OP_SPLIT, o, newDEFSVOP());
6483 kid = kid->op_sibling;
6486 if (!kid->op_sibling)
6487 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6489 kid = kid->op_sibling;
6492 if (kid->op_sibling)
6493 return too_many_arguments(o,PL_op_desc[o->op_type]);
6499 Perl_ck_join(pTHX_ OP *o)
6501 if (ckWARN(WARN_SYNTAX)) {
6502 OP *kid = cLISTOPo->op_first->op_sibling;
6503 if (kid && kid->op_type == OP_MATCH) {
6504 char *pmstr = "STRING";
6505 if (PM_GETRE(kPMOP))
6506 pmstr = PM_GETRE(kPMOP)->precomp;
6507 Perl_warner(aTHX_ WARN_SYNTAX,
6508 "/%s/ should probably be written as \"%s\"",
6516 Perl_ck_subr(pTHX_ OP *o)
6518 OP *prev = ((cUNOPo->op_first->op_sibling)
6519 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6520 OP *o2 = prev->op_sibling;
6529 o->op_private |= OPpENTERSUB_HASTARG;
6530 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6531 if (cvop->op_type == OP_RV2CV) {
6533 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6534 op_null(cvop); /* disable rv2cv */
6535 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6536 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6537 GV *gv = cGVOPx_gv(tmpop);
6540 tmpop->op_private |= OPpEARLY_CV;
6541 else if (SvPOK(cv)) {
6542 namegv = CvANON(cv) ? gv : CvGV(cv);
6543 proto = SvPV((SV*)cv, n_a);
6547 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6548 if (o2->op_type == OP_CONST)
6549 o2->op_private &= ~OPpCONST_STRICT;
6550 else if (o2->op_type == OP_LIST) {
6551 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6552 if (o && o->op_type == OP_CONST)
6553 o->op_private &= ~OPpCONST_STRICT;
6556 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6557 if (PERLDB_SUB && PL_curstash != PL_debstash)
6558 o->op_private |= OPpENTERSUB_DB;
6559 while (o2 != cvop) {
6563 return too_many_arguments(o, gv_ename(namegv));
6581 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6583 arg == 1 ? "block or sub {}" : "sub {}",
6584 gv_ename(namegv), o2);
6587 /* '*' allows any scalar type, including bareword */
6590 if (o2->op_type == OP_RV2GV)
6591 goto wrapref; /* autoconvert GLOB -> GLOBref */
6592 else if (o2->op_type == OP_CONST)
6593 o2->op_private &= ~OPpCONST_STRICT;
6594 else if (o2->op_type == OP_ENTERSUB) {
6595 /* accidental subroutine, revert to bareword */
6596 OP *gvop = ((UNOP*)o2)->op_first;
6597 if (gvop && gvop->op_type == OP_NULL) {
6598 gvop = ((UNOP*)gvop)->op_first;
6600 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6603 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6604 (gvop = ((UNOP*)gvop)->op_first) &&
6605 gvop->op_type == OP_GV)
6607 GV *gv = cGVOPx_gv(gvop);
6608 OP *sibling = o2->op_sibling;
6609 SV *n = newSVpvn("",0);
6611 gv_fullname3(n, gv, "");
6612 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6613 sv_chop(n, SvPVX(n)+6);
6614 o2 = newSVOP(OP_CONST, 0, n);
6615 prev->op_sibling = o2;
6616 o2->op_sibling = sibling;
6628 if (o2->op_type != OP_RV2GV)
6629 bad_type(arg, "symbol", gv_ename(namegv), o2);
6632 if (o2->op_type != OP_ENTERSUB)
6633 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6636 if (o2->op_type != OP_RV2SV
6637 && o2->op_type != OP_PADSV
6638 && o2->op_type != OP_HELEM
6639 && o2->op_type != OP_AELEM
6640 && o2->op_type != OP_THREADSV)
6642 bad_type(arg, "scalar", gv_ename(namegv), o2);
6646 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6647 bad_type(arg, "array", gv_ename(namegv), o2);
6650 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6651 bad_type(arg, "hash", gv_ename(namegv), o2);
6655 OP* sib = kid->op_sibling;
6656 kid->op_sibling = 0;
6657 o2 = newUNOP(OP_REFGEN, 0, kid);
6658 o2->op_sibling = sib;
6659 prev->op_sibling = o2;
6670 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6671 gv_ename(namegv), SvPV((SV*)cv, n_a));
6676 mod(o2, OP_ENTERSUB);
6678 o2 = o2->op_sibling;
6680 if (proto && !optional &&
6681 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6682 return too_few_arguments(o, gv_ename(namegv));
6687 Perl_ck_svconst(pTHX_ OP *o)
6689 SvREADONLY_on(cSVOPo->op_sv);
6694 Perl_ck_trunc(pTHX_ OP *o)
6696 if (o->op_flags & OPf_KIDS) {
6697 SVOP *kid = (SVOP*)cUNOPo->op_first;
6699 if (kid->op_type == OP_NULL)
6700 kid = (SVOP*)kid->op_sibling;
6701 if (kid && kid->op_type == OP_CONST &&
6702 (kid->op_private & OPpCONST_BARE))
6704 o->op_flags |= OPf_SPECIAL;
6705 kid->op_private &= ~OPpCONST_STRICT;
6712 Perl_ck_substr(pTHX_ OP *o)
6715 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6716 OP *kid = cLISTOPo->op_first;
6718 if (kid->op_type == OP_NULL)
6719 kid = kid->op_sibling;
6721 kid->op_flags |= OPf_MOD;
6727 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6730 Perl_peep(pTHX_ register OP *o)
6732 register OP* oldop = 0;
6735 if (!o || o->op_seq)
6739 SAVEVPTR(PL_curcop);
6740 for (; o; o = o->op_next) {
6746 switch (o->op_type) {
6750 PL_curcop = ((COP*)o); /* for warnings */
6751 o->op_seq = PL_op_seqmax++;
6755 if (cSVOPo->op_private & OPpCONST_STRICT)
6756 no_bareword_allowed(o);
6758 /* Relocate sv to the pad for thread safety.
6759 * Despite being a "constant", the SV is written to,
6760 * for reference counts, sv_upgrade() etc. */
6762 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6763 if (SvPADTMP(cSVOPo->op_sv)) {
6764 /* If op_sv is already a PADTMP then it is being used by
6765 * some pad, so make a copy. */
6766 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6767 SvREADONLY_on(PL_curpad[ix]);
6768 SvREFCNT_dec(cSVOPo->op_sv);
6771 SvREFCNT_dec(PL_curpad[ix]);
6772 SvPADTMP_on(cSVOPo->op_sv);
6773 PL_curpad[ix] = cSVOPo->op_sv;
6774 /* XXX I don't know how this isn't readonly already. */
6775 SvREADONLY_on(PL_curpad[ix]);
6777 cSVOPo->op_sv = Nullsv;
6781 o->op_seq = PL_op_seqmax++;
6785 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6786 if (o->op_next->op_private & OPpTARGET_MY) {
6787 if (o->op_flags & OPf_STACKED) /* chained concats */
6788 goto ignore_optimization;
6790 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6791 o->op_targ = o->op_next->op_targ;
6792 o->op_next->op_targ = 0;
6793 o->op_private |= OPpTARGET_MY;
6796 op_null(o->op_next);
6798 ignore_optimization:
6799 o->op_seq = PL_op_seqmax++;
6802 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6803 o->op_seq = PL_op_seqmax++;
6804 break; /* Scalar stub must produce undef. List stub is noop */
6808 if (o->op_targ == OP_NEXTSTATE
6809 || o->op_targ == OP_DBSTATE
6810 || o->op_targ == OP_SETSTATE)
6812 PL_curcop = ((COP*)o);
6814 /* XXX: We avoid setting op_seq here to prevent later calls
6815 to peep() from mistakenly concluding that optimisation
6816 has already occurred. This doesn't fix the real problem,
6817 though (See 20010220.007). AMS 20010719 */
6818 if (oldop && o->op_next) {
6819 oldop->op_next = o->op_next;
6827 if (oldop && o->op_next) {
6828 oldop->op_next = o->op_next;
6831 o->op_seq = PL_op_seqmax++;
6835 if (o->op_next->op_type == OP_RV2SV) {
6836 if (!(o->op_next->op_private & OPpDEREF)) {
6837 op_null(o->op_next);
6838 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6840 o->op_next = o->op_next->op_next;
6841 o->op_type = OP_GVSV;
6842 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6845 else if (o->op_next->op_type == OP_RV2AV) {
6846 OP* pop = o->op_next->op_next;
6848 if (pop->op_type == OP_CONST &&
6849 (PL_op = pop->op_next) &&
6850 pop->op_next->op_type == OP_AELEM &&
6851 !(pop->op_next->op_private &
6852 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6853 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6858 op_null(o->op_next);
6859 op_null(pop->op_next);
6861 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6862 o->op_next = pop->op_next->op_next;
6863 o->op_type = OP_AELEMFAST;
6864 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6865 o->op_private = (U8)i;
6870 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6872 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6873 /* XXX could check prototype here instead of just carping */
6874 SV *sv = sv_newmortal();
6875 gv_efullname3(sv, gv, Nullch);
6876 Perl_warner(aTHX_ WARN_PROTOTYPE,
6877 "%s() called too early to check prototype",
6881 else if (o->op_next->op_type == OP_READLINE
6882 && o->op_next->op_next->op_type == OP_CONCAT
6883 && (o->op_next->op_next->op_flags & OPf_STACKED))
6885 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010811 */
6886 o->op_next->op_type = OP_RCATLINE;
6887 o->op_next->op_flags |= OPf_STACKED;
6888 op_null(o->op_next->op_next);
6891 o->op_seq = PL_op_seqmax++;
6902 o->op_seq = PL_op_seqmax++;
6903 while (cLOGOP->op_other->op_type == OP_NULL)
6904 cLOGOP->op_other = cLOGOP->op_other->op_next;
6905 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6910 o->op_seq = PL_op_seqmax++;
6911 while (cLOOP->op_redoop->op_type == OP_NULL)
6912 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6913 peep(cLOOP->op_redoop);
6914 while (cLOOP->op_nextop->op_type == OP_NULL)
6915 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6916 peep(cLOOP->op_nextop);
6917 while (cLOOP->op_lastop->op_type == OP_NULL)
6918 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6919 peep(cLOOP->op_lastop);
6925 o->op_seq = PL_op_seqmax++;
6926 while (cPMOP->op_pmreplstart &&
6927 cPMOP->op_pmreplstart->op_type == OP_NULL)
6928 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6929 peep(cPMOP->op_pmreplstart);
6933 o->op_seq = PL_op_seqmax++;
6934 if (ckWARN(WARN_SYNTAX) && o->op_next
6935 && o->op_next->op_type == OP_NEXTSTATE) {
6936 if (o->op_next->op_sibling &&
6937 o->op_next->op_sibling->op_type != OP_EXIT &&
6938 o->op_next->op_sibling->op_type != OP_WARN &&
6939 o->op_next->op_sibling->op_type != OP_DIE) {
6940 line_t oldline = CopLINE(PL_curcop);
6942 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6943 Perl_warner(aTHX_ WARN_EXEC,
6944 "Statement unlikely to be reached");
6945 Perl_warner(aTHX_ WARN_EXEC,
6946 "\t(Maybe you meant system() when you said exec()?)\n");
6947 CopLINE_set(PL_curcop, oldline);
6956 SV **svp, **indsvp, *sv;
6961 o->op_seq = PL_op_seqmax++;
6963 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6966 /* Make the CONST have a shared SV */
6967 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6968 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6969 key = SvPV(sv, keylen);
6970 lexname = newSVpvn_share(key,
6971 SvUTF8(sv) ? -(I32)keylen : keylen,
6977 if ((o->op_private & (OPpLVAL_INTRO)))
6980 rop = (UNOP*)((BINOP*)o)->op_first;
6981 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6983 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6984 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6986 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6987 if (!fields || !GvHV(*fields))
6989 key = SvPV(*svp, keylen);
6990 indsvp = hv_fetch(GvHV(*fields), key,
6991 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6993 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6994 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6996 ind = SvIV(*indsvp);
6998 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6999 rop->op_type = OP_RV2AV;
7000 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7001 o->op_type = OP_AELEM;
7002 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7004 if (SvREADONLY(*svp))
7006 SvFLAGS(sv) |= (SvFLAGS(*svp)
7007 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7017 SV **svp, **indsvp, *sv;
7021 SVOP *first_key_op, *key_op;
7023 o->op_seq = PL_op_seqmax++;
7024 if ((o->op_private & (OPpLVAL_INTRO))
7025 /* I bet there's always a pushmark... */
7026 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7027 /* hmmm, no optimization if list contains only one key. */
7029 rop = (UNOP*)((LISTOP*)o)->op_last;
7030 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7032 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7033 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7035 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7036 if (!fields || !GvHV(*fields))
7038 /* Again guessing that the pushmark can be jumped over.... */
7039 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7040 ->op_first->op_sibling;
7041 /* Check that the key list contains only constants. */
7042 for (key_op = first_key_op; key_op;
7043 key_op = (SVOP*)key_op->op_sibling)
7044 if (key_op->op_type != OP_CONST)
7048 rop->op_type = OP_RV2AV;
7049 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7050 o->op_type = OP_ASLICE;
7051 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7052 for (key_op = first_key_op; key_op;
7053 key_op = (SVOP*)key_op->op_sibling) {
7054 svp = cSVOPx_svp(key_op);
7055 key = SvPV(*svp, keylen);
7056 indsvp = hv_fetch(GvHV(*fields), key,
7057 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7059 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7060 "in variable %s of type %s",
7061 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7063 ind = SvIV(*indsvp);
7065 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7067 if (SvREADONLY(*svp))
7069 SvFLAGS(sv) |= (SvFLAGS(*svp)
7070 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7078 o->op_seq = PL_op_seqmax++;
7088 /* Efficient sub that returns a constant scalar value. */
7090 const_sv_xsub(pTHXo_ CV* cv)
7095 Perl_croak(aTHX_ "usage: %s::%s()",
7096 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7100 ST(0) = (SV*)XSANY.any_ptr;