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 (USE_UTF8_IN_NAMES && 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);
2150 if (!PL_error_count)
2152 PL_pad_reset_pending = FALSE;
2153 PL_compiling.op_private = PL_hints;
2155 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2156 pad_leavemy(PL_comppad_name_fill);
2165 OP *o = newOP(OP_THREADSV, 0);
2166 o->op_targ = find_threadsv("_");
2169 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2170 #endif /* USE_THREADS */
2174 Perl_newPROG(pTHX_ OP *o)
2179 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2180 ((PL_in_eval & EVAL_KEEPERR)
2181 ? OPf_SPECIAL : 0), o);
2182 PL_eval_start = linklist(PL_eval_root);
2183 PL_eval_root->op_private |= OPpREFCOUNTED;
2184 OpREFCNT_set(PL_eval_root, 1);
2185 PL_eval_root->op_next = 0;
2186 CALL_PEEP(PL_eval_start);
2191 PL_main_root = scope(sawparens(scalarvoid(o)));
2192 PL_curcop = &PL_compiling;
2193 PL_main_start = LINKLIST(PL_main_root);
2194 PL_main_root->op_private |= OPpREFCOUNTED;
2195 OpREFCNT_set(PL_main_root, 1);
2196 PL_main_root->op_next = 0;
2197 CALL_PEEP(PL_main_start);
2200 /* Register with debugger */
2202 CV *cv = get_cv("DB::postponed", FALSE);
2206 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2208 call_sv((SV*)cv, G_DISCARD);
2215 Perl_localize(pTHX_ OP *o, I32 lex)
2217 if (o->op_flags & OPf_PARENS)
2220 if (ckWARN(WARN_PARENTHESIS)
2221 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2223 char *s = PL_bufptr;
2225 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2228 if (*s == ';' || *s == '=')
2229 Perl_warner(aTHX_ WARN_PARENTHESIS,
2230 "Parentheses missing around \"%s\" list",
2231 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2237 o = mod(o, OP_NULL); /* a bit kludgey */
2239 PL_in_my_stash = Nullhv;
2244 Perl_jmaybe(pTHX_ OP *o)
2246 if (o->op_type == OP_LIST) {
2249 o2 = newOP(OP_THREADSV, 0);
2250 o2->op_targ = find_threadsv(";");
2252 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2253 #endif /* USE_THREADS */
2254 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2260 Perl_fold_constants(pTHX_ register OP *o)
2263 I32 type = o->op_type;
2266 if (PL_opargs[type] & OA_RETSCALAR)
2268 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2269 o->op_targ = pad_alloc(type, SVs_PADTMP);
2271 /* integerize op, unless it happens to be C<-foo>.
2272 * XXX should pp_i_negate() do magic string negation instead? */
2273 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2274 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2275 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2277 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2280 if (!(PL_opargs[type] & OA_FOLDCONST))
2285 /* XXX might want a ck_negate() for this */
2286 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2298 /* XXX what about the numeric ops? */
2299 if (PL_hints & HINT_LOCALE)
2304 goto nope; /* Don't try to run w/ errors */
2306 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2307 if ((curop->op_type != OP_CONST ||
2308 (curop->op_private & OPpCONST_BARE)) &&
2309 curop->op_type != OP_LIST &&
2310 curop->op_type != OP_SCALAR &&
2311 curop->op_type != OP_NULL &&
2312 curop->op_type != OP_PUSHMARK)
2318 curop = LINKLIST(o);
2322 sv = *(PL_stack_sp--);
2323 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2324 pad_swipe(o->op_targ);
2325 else if (SvTEMP(sv)) { /* grab mortal temp? */
2326 (void)SvREFCNT_inc(sv);
2330 if (type == OP_RV2GV)
2331 return newGVOP(OP_GV, 0, (GV*)sv);
2333 /* try to smush double to int, but don't smush -2.0 to -2 */
2334 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2337 #ifdef PERL_PRESERVE_IVUV
2338 /* Only bother to attempt to fold to IV if
2339 most operators will benefit */
2343 return newSVOP(OP_CONST, 0, sv);
2347 if (!(PL_opargs[type] & OA_OTHERINT))
2350 if (!(PL_hints & HINT_INTEGER)) {
2351 if (type == OP_MODULO
2352 || type == OP_DIVIDE
2353 || !(o->op_flags & OPf_KIDS))
2358 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2359 if (curop->op_type == OP_CONST) {
2360 if (SvIOK(((SVOP*)curop)->op_sv))
2364 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2368 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2375 Perl_gen_constant_list(pTHX_ register OP *o)
2378 I32 oldtmps_floor = PL_tmps_floor;
2382 return o; /* Don't attempt to run with errors */
2384 PL_op = curop = LINKLIST(o);
2391 PL_tmps_floor = oldtmps_floor;
2393 o->op_type = OP_RV2AV;
2394 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2395 curop = ((UNOP*)o)->op_first;
2396 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2403 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2405 if (!o || o->op_type != OP_LIST)
2406 o = newLISTOP(OP_LIST, 0, o, Nullop);
2408 o->op_flags &= ~OPf_WANT;
2410 if (!(PL_opargs[type] & OA_MARK))
2411 op_null(cLISTOPo->op_first);
2414 o->op_ppaddr = PL_ppaddr[type];
2415 o->op_flags |= flags;
2417 o = CHECKOP(type, o);
2418 if (o->op_type != type)
2421 return fold_constants(o);
2424 /* List constructors */
2427 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2435 if (first->op_type != type
2436 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2438 return newLISTOP(type, 0, first, last);
2441 if (first->op_flags & OPf_KIDS)
2442 ((LISTOP*)first)->op_last->op_sibling = last;
2444 first->op_flags |= OPf_KIDS;
2445 ((LISTOP*)first)->op_first = last;
2447 ((LISTOP*)first)->op_last = last;
2452 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2460 if (first->op_type != type)
2461 return prepend_elem(type, (OP*)first, (OP*)last);
2463 if (last->op_type != type)
2464 return append_elem(type, (OP*)first, (OP*)last);
2466 first->op_last->op_sibling = last->op_first;
2467 first->op_last = last->op_last;
2468 first->op_flags |= (last->op_flags & OPf_KIDS);
2470 #ifdef PL_OP_SLAB_ALLOC
2478 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2486 if (last->op_type == type) {
2487 if (type == OP_LIST) { /* already a PUSHMARK there */
2488 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2489 ((LISTOP*)last)->op_first->op_sibling = first;
2490 if (!(first->op_flags & OPf_PARENS))
2491 last->op_flags &= ~OPf_PARENS;
2494 if (!(last->op_flags & OPf_KIDS)) {
2495 ((LISTOP*)last)->op_last = first;
2496 last->op_flags |= OPf_KIDS;
2498 first->op_sibling = ((LISTOP*)last)->op_first;
2499 ((LISTOP*)last)->op_first = first;
2501 last->op_flags |= OPf_KIDS;
2505 return newLISTOP(type, 0, first, last);
2511 Perl_newNULLLIST(pTHX)
2513 return newOP(OP_STUB, 0);
2517 Perl_force_list(pTHX_ OP *o)
2519 if (!o || o->op_type != OP_LIST)
2520 o = newLISTOP(OP_LIST, 0, o, Nullop);
2526 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2530 NewOp(1101, listop, 1, LISTOP);
2532 listop->op_type = type;
2533 listop->op_ppaddr = PL_ppaddr[type];
2536 listop->op_flags = flags;
2540 else if (!first && last)
2543 first->op_sibling = last;
2544 listop->op_first = first;
2545 listop->op_last = last;
2546 if (type == OP_LIST) {
2548 pushop = newOP(OP_PUSHMARK, 0);
2549 pushop->op_sibling = first;
2550 listop->op_first = pushop;
2551 listop->op_flags |= OPf_KIDS;
2553 listop->op_last = pushop;
2560 Perl_newOP(pTHX_ I32 type, I32 flags)
2563 NewOp(1101, o, 1, OP);
2565 o->op_ppaddr = PL_ppaddr[type];
2566 o->op_flags = flags;
2569 o->op_private = 0 + (flags >> 8);
2570 if (PL_opargs[type] & OA_RETSCALAR)
2572 if (PL_opargs[type] & OA_TARGET)
2573 o->op_targ = pad_alloc(type, SVs_PADTMP);
2574 return CHECKOP(type, o);
2578 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2583 first = newOP(OP_STUB, 0);
2584 if (PL_opargs[type] & OA_MARK)
2585 first = force_list(first);
2587 NewOp(1101, unop, 1, UNOP);
2588 unop->op_type = type;
2589 unop->op_ppaddr = PL_ppaddr[type];
2590 unop->op_first = first;
2591 unop->op_flags = flags | OPf_KIDS;
2592 unop->op_private = 1 | (flags >> 8);
2593 unop = (UNOP*) CHECKOP(type, unop);
2597 return fold_constants((OP *) unop);
2601 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2604 NewOp(1101, binop, 1, BINOP);
2607 first = newOP(OP_NULL, 0);
2609 binop->op_type = type;
2610 binop->op_ppaddr = PL_ppaddr[type];
2611 binop->op_first = first;
2612 binop->op_flags = flags | OPf_KIDS;
2615 binop->op_private = 1 | (flags >> 8);
2618 binop->op_private = 2 | (flags >> 8);
2619 first->op_sibling = last;
2622 binop = (BINOP*)CHECKOP(type, binop);
2623 if (binop->op_next || binop->op_type != type)
2626 binop->op_last = binop->op_first->op_sibling;
2628 return fold_constants((OP *)binop);
2632 uvcompare(const void *a, const void *b)
2634 if (*((UV *)a) < (*(UV *)b))
2636 if (*((UV *)a) > (*(UV *)b))
2638 if (*((UV *)a+1) < (*(UV *)b+1))
2640 if (*((UV *)a+1) > (*(UV *)b+1))
2646 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2648 SV *tstr = ((SVOP*)expr)->op_sv;
2649 SV *rstr = ((SVOP*)repl)->op_sv;
2652 U8 *t = (U8*)SvPV(tstr, tlen);
2653 U8 *r = (U8*)SvPV(rstr, rlen);
2660 register short *tbl;
2662 PL_hints |= HINT_BLOCK_SCOPE;
2663 complement = o->op_private & OPpTRANS_COMPLEMENT;
2664 del = o->op_private & OPpTRANS_DELETE;
2665 squash = o->op_private & OPpTRANS_SQUASH;
2668 o->op_private |= OPpTRANS_FROM_UTF;
2671 o->op_private |= OPpTRANS_TO_UTF;
2673 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2674 SV* listsv = newSVpvn("# comment\n",10);
2676 U8* tend = t + tlen;
2677 U8* rend = r + rlen;
2691 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2692 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2698 tsave = t = bytes_to_utf8(t, &len);
2701 if (!to_utf && rlen) {
2703 rsave = r = bytes_to_utf8(r, &len);
2707 /* There are several snags with this code on EBCDIC:
2708 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2709 2. scan_const() in toke.c has encoded chars in native encoding which makes
2710 ranges at least in EBCDIC 0..255 range the bottom odd.
2714 U8 tmpbuf[UTF8_MAXLEN+1];
2717 New(1109, cp, 2*tlen, UV);
2719 transv = newSVpvn("",0);
2721 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2723 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2725 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2729 cp[2*i+1] = cp[2*i];
2733 qsort(cp, i, 2*sizeof(UV), uvcompare);
2734 for (j = 0; j < i; j++) {
2736 diff = val - nextmin;
2738 t = uvuni_to_utf8(tmpbuf,nextmin);
2739 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2741 U8 range_mark = UTF_TO_NATIVE(0xff);
2742 t = uvuni_to_utf8(tmpbuf, val - 1);
2743 sv_catpvn(transv, (char *)&range_mark, 1);
2744 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2751 t = uvuni_to_utf8(tmpbuf,nextmin);
2752 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2754 U8 range_mark = UTF_TO_NATIVE(0xff);
2755 sv_catpvn(transv, (char *)&range_mark, 1);
2757 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2758 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2759 t = (U8*)SvPVX(transv);
2760 tlen = SvCUR(transv);
2764 else if (!rlen && !del) {
2765 r = t; rlen = tlen; rend = tend;
2768 if ((!rlen && !del) || t == r ||
2769 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2771 o->op_private |= OPpTRANS_IDENTICAL;
2775 while (t < tend || tfirst <= tlast) {
2776 /* see if we need more "t" chars */
2777 if (tfirst > tlast) {
2778 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2780 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2782 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2789 /* now see if we need more "r" chars */
2790 if (rfirst > rlast) {
2792 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2794 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2796 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2805 rfirst = rlast = 0xffffffff;
2809 /* now see which range will peter our first, if either. */
2810 tdiff = tlast - tfirst;
2811 rdiff = rlast - rfirst;
2818 if (rfirst == 0xffffffff) {
2819 diff = tdiff; /* oops, pretend rdiff is infinite */
2821 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2822 (long)tfirst, (long)tlast);
2824 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2828 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2829 (long)tfirst, (long)(tfirst + diff),
2832 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2833 (long)tfirst, (long)rfirst);
2835 if (rfirst + diff > max)
2836 max = rfirst + diff;
2838 grows = (tfirst < rfirst &&
2839 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2851 else if (max > 0xff)
2856 Safefree(cPVOPo->op_pv);
2857 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2858 SvREFCNT_dec(listsv);
2860 SvREFCNT_dec(transv);
2862 if (!del && havefinal && rlen)
2863 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2864 newSVuv((UV)final), 0);
2867 o->op_private |= OPpTRANS_GROWS;
2879 tbl = (short*)cPVOPo->op_pv;
2881 Zero(tbl, 256, short);
2882 for (i = 0; i < tlen; i++)
2884 for (i = 0, j = 0; i < 256; i++) {
2895 if (i < 128 && r[j] >= 128)
2905 o->op_private |= OPpTRANS_IDENTICAL;
2910 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2911 tbl[0x100] = rlen - j;
2912 for (i=0; i < rlen - j; i++)
2913 tbl[0x101+i] = r[j+i];
2917 if (!rlen && !del) {
2920 o->op_private |= OPpTRANS_IDENTICAL;
2922 for (i = 0; i < 256; i++)
2924 for (i = 0, j = 0; i < tlen; i++,j++) {
2927 if (tbl[t[i]] == -1)
2933 if (tbl[t[i]] == -1) {
2934 if (t[i] < 128 && r[j] >= 128)
2941 o->op_private |= OPpTRANS_GROWS;
2949 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2953 NewOp(1101, pmop, 1, PMOP);
2954 pmop->op_type = type;
2955 pmop->op_ppaddr = PL_ppaddr[type];
2956 pmop->op_flags = flags;
2957 pmop->op_private = 0 | (flags >> 8);
2959 if (PL_hints & HINT_RE_TAINT)
2960 pmop->op_pmpermflags |= PMf_RETAINT;
2961 if (PL_hints & HINT_LOCALE)
2962 pmop->op_pmpermflags |= PMf_LOCALE;
2963 pmop->op_pmflags = pmop->op_pmpermflags;
2967 SV* repointer = newSViv(0);
2968 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2969 pmop->op_pmoffset = av_len(PL_regex_padav);
2970 PL_regex_pad = AvARRAY(PL_regex_padav);
2974 /* link into pm list */
2975 if (type != OP_TRANS && PL_curstash) {
2976 pmop->op_pmnext = HvPMROOT(PL_curstash);
2977 HvPMROOT(PL_curstash) = pmop;
2978 PmopSTASH_set(pmop,PL_curstash);
2985 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2989 I32 repl_has_vars = 0;
2991 if (o->op_type == OP_TRANS)
2992 return pmtrans(o, expr, repl);
2994 PL_hints |= HINT_BLOCK_SCOPE;
2997 if (expr->op_type == OP_CONST) {
2999 SV *pat = ((SVOP*)expr)->op_sv;
3000 char *p = SvPV(pat, plen);
3001 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3002 sv_setpvn(pat, "\\s+", 3);
3003 p = SvPV(pat, plen);
3004 pm->op_pmflags |= PMf_SKIPWHITE;
3006 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3007 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3008 pm->op_pmflags |= PMf_WHITE;
3012 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3013 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3015 : OP_REGCMAYBE),0,expr);
3017 NewOp(1101, rcop, 1, LOGOP);
3018 rcop->op_type = OP_REGCOMP;
3019 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3020 rcop->op_first = scalar(expr);
3021 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3022 ? (OPf_SPECIAL | OPf_KIDS)
3024 rcop->op_private = 1;
3027 /* establish postfix order */
3028 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3030 rcop->op_next = expr;
3031 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3034 rcop->op_next = LINKLIST(expr);
3035 expr->op_next = (OP*)rcop;
3038 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3043 if (pm->op_pmflags & PMf_EVAL) {
3045 if (CopLINE(PL_curcop) < PL_multi_end)
3046 CopLINE_set(PL_curcop, PL_multi_end);
3049 else if (repl->op_type == OP_THREADSV
3050 && strchr("&`'123456789+",
3051 PL_threadsv_names[repl->op_targ]))
3055 #endif /* USE_THREADS */
3056 else if (repl->op_type == OP_CONST)
3060 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3061 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3063 if (curop->op_type == OP_THREADSV) {
3065 if (strchr("&`'123456789+", curop->op_private))
3069 if (curop->op_type == OP_GV) {
3070 GV *gv = cGVOPx_gv(curop);
3072 if (strchr("&`'123456789+", *GvENAME(gv)))
3075 #endif /* USE_THREADS */
3076 else if (curop->op_type == OP_RV2CV)
3078 else if (curop->op_type == OP_RV2SV ||
3079 curop->op_type == OP_RV2AV ||
3080 curop->op_type == OP_RV2HV ||
3081 curop->op_type == OP_RV2GV) {
3082 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3085 else if (curop->op_type == OP_PADSV ||
3086 curop->op_type == OP_PADAV ||
3087 curop->op_type == OP_PADHV ||
3088 curop->op_type == OP_PADANY) {
3091 else if (curop->op_type == OP_PUSHRE)
3092 ; /* Okay here, dangerous in newASSIGNOP */
3102 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3103 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3104 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3105 prepend_elem(o->op_type, scalar(repl), o);
3108 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3109 pm->op_pmflags |= PMf_MAYBE_CONST;
3110 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3112 NewOp(1101, rcop, 1, LOGOP);
3113 rcop->op_type = OP_SUBSTCONT;
3114 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3115 rcop->op_first = scalar(repl);
3116 rcop->op_flags |= OPf_KIDS;
3117 rcop->op_private = 1;
3120 /* establish postfix order */
3121 rcop->op_next = LINKLIST(repl);
3122 repl->op_next = (OP*)rcop;
3124 pm->op_pmreplroot = scalar((OP*)rcop);
3125 pm->op_pmreplstart = LINKLIST(rcop);
3134 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3137 NewOp(1101, svop, 1, SVOP);
3138 svop->op_type = type;
3139 svop->op_ppaddr = PL_ppaddr[type];
3141 svop->op_next = (OP*)svop;
3142 svop->op_flags = flags;
3143 if (PL_opargs[type] & OA_RETSCALAR)
3145 if (PL_opargs[type] & OA_TARGET)
3146 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3147 return CHECKOP(type, svop);
3151 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3154 NewOp(1101, padop, 1, PADOP);
3155 padop->op_type = type;
3156 padop->op_ppaddr = PL_ppaddr[type];
3157 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3158 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3159 PL_curpad[padop->op_padix] = sv;
3161 padop->op_next = (OP*)padop;
3162 padop->op_flags = flags;
3163 if (PL_opargs[type] & OA_RETSCALAR)
3165 if (PL_opargs[type] & OA_TARGET)
3166 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3167 return CHECKOP(type, padop);
3171 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3175 return newPADOP(type, flags, SvREFCNT_inc(gv));
3177 return newSVOP(type, flags, SvREFCNT_inc(gv));
3182 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3185 NewOp(1101, pvop, 1, PVOP);
3186 pvop->op_type = type;
3187 pvop->op_ppaddr = PL_ppaddr[type];
3189 pvop->op_next = (OP*)pvop;
3190 pvop->op_flags = flags;
3191 if (PL_opargs[type] & OA_RETSCALAR)
3193 if (PL_opargs[type] & OA_TARGET)
3194 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3195 return CHECKOP(type, pvop);
3199 Perl_package(pTHX_ OP *o)
3203 save_hptr(&PL_curstash);
3204 save_item(PL_curstname);
3209 name = SvPV(sv, len);
3210 PL_curstash = gv_stashpvn(name,len,TRUE);
3211 sv_setpvn(PL_curstname, name, len);
3215 deprecate("\"package\" with no arguments");
3216 sv_setpv(PL_curstname,"<none>");
3217 PL_curstash = Nullhv;
3219 PL_hints |= HINT_BLOCK_SCOPE;
3220 PL_copline = NOLINE;
3225 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3230 char *packname = Nullch;
3234 if (id->op_type != OP_CONST)
3235 Perl_croak(aTHX_ "Module name must be constant");
3239 if (version != Nullop) {
3240 SV *vesv = ((SVOP*)version)->op_sv;
3242 if (arg == Nullop && !SvNIOKp(vesv)) {
3249 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3250 Perl_croak(aTHX_ "Version number must be constant number");
3252 /* Make copy of id so we don't free it twice */
3253 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3255 /* Fake up a method call to VERSION */
3256 meth = newSVpvn("VERSION",7);
3257 sv_upgrade(meth, SVt_PVIV);
3258 (void)SvIOK_on(meth);
3259 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3260 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3261 append_elem(OP_LIST,
3262 prepend_elem(OP_LIST, pack, list(version)),
3263 newSVOP(OP_METHOD_NAMED, 0, meth)));
3267 /* Fake up an import/unimport */
3268 if (arg && arg->op_type == OP_STUB)
3269 imop = arg; /* no import on explicit () */
3270 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3271 imop = Nullop; /* use 5.0; */
3276 /* Make copy of id so we don't free it twice */
3277 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3279 /* Fake up a method call to import/unimport */
3280 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3281 sv_upgrade(meth, SVt_PVIV);
3282 (void)SvIOK_on(meth);
3283 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3284 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3285 append_elem(OP_LIST,
3286 prepend_elem(OP_LIST, pack, list(arg)),
3287 newSVOP(OP_METHOD_NAMED, 0, meth)));
3290 if (ckWARN(WARN_MISC) &&
3291 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3292 SvPOK(packsv = ((SVOP*)id)->op_sv))
3294 /* BEGIN will free the ops, so we need to make a copy */
3295 packlen = SvCUR(packsv);
3296 packname = savepvn(SvPVX(packsv), packlen);
3299 /* Fake up the BEGIN {}, which does its thing immediately. */
3301 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3304 append_elem(OP_LINESEQ,
3305 append_elem(OP_LINESEQ,
3306 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3307 newSTATEOP(0, Nullch, veop)),
3308 newSTATEOP(0, Nullch, imop) ));
3311 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3312 Perl_warner(aTHX_ WARN_MISC,
3313 "Package `%s' not found "
3314 "(did you use the incorrect case?)", packname);
3319 PL_hints |= HINT_BLOCK_SCOPE;
3320 PL_copline = NOLINE;
3325 =for apidoc load_module
3327 Loads the module whose name is pointed to by the string part of name.
3328 Note that the actual module name, not its filename, should be given.
3329 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3330 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3331 (or 0 for no flags). ver, if specified, provides version semantics
3332 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3333 arguments can be used to specify arguments to the module's import()
3334 method, similar to C<use Foo::Bar VERSION LIST>.
3339 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3342 va_start(args, ver);
3343 vload_module(flags, name, ver, &args);
3347 #ifdef PERL_IMPLICIT_CONTEXT
3349 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3353 va_start(args, ver);
3354 vload_module(flags, name, ver, &args);
3360 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3362 OP *modname, *veop, *imop;
3364 modname = newSVOP(OP_CONST, 0, name);
3365 modname->op_private |= OPpCONST_BARE;
3367 veop = newSVOP(OP_CONST, 0, ver);
3371 if (flags & PERL_LOADMOD_NOIMPORT) {
3372 imop = sawparens(newNULLLIST());
3374 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3375 imop = va_arg(*args, OP*);
3380 sv = va_arg(*args, SV*);
3382 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3383 sv = va_arg(*args, SV*);
3387 line_t ocopline = PL_copline;
3388 int oexpect = PL_expect;
3390 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3391 veop, modname, imop);
3392 PL_expect = oexpect;
3393 PL_copline = ocopline;
3398 Perl_dofile(pTHX_ OP *term)
3403 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3404 if (!(gv && GvIMPORTED_CV(gv)))
3405 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3407 if (gv && GvIMPORTED_CV(gv)) {
3408 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3409 append_elem(OP_LIST, term,
3410 scalar(newUNOP(OP_RV2CV, 0,
3415 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3421 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3423 return newBINOP(OP_LSLICE, flags,
3424 list(force_list(subscript)),
3425 list(force_list(listval)) );
3429 S_list_assignment(pTHX_ register OP *o)
3434 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3435 o = cUNOPo->op_first;
3437 if (o->op_type == OP_COND_EXPR) {
3438 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3439 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3444 yyerror("Assignment to both a list and a scalar");
3448 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3449 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3450 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3453 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3456 if (o->op_type == OP_RV2SV)
3463 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3468 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3469 return newLOGOP(optype, 0,
3470 mod(scalar(left), optype),
3471 newUNOP(OP_SASSIGN, 0, scalar(right)));
3474 return newBINOP(optype, OPf_STACKED,
3475 mod(scalar(left), optype), scalar(right));
3479 if (list_assignment(left)) {
3483 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3484 left = mod(left, OP_AASSIGN);
3492 curop = list(force_list(left));
3493 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3494 o->op_private = 0 | (flags >> 8);
3495 for (curop = ((LISTOP*)curop)->op_first;
3496 curop; curop = curop->op_sibling)
3498 if (curop->op_type == OP_RV2HV &&
3499 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3500 o->op_private |= OPpASSIGN_HASH;
3504 if (!(left->op_private & OPpLVAL_INTRO)) {
3507 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3508 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3509 if (curop->op_type == OP_GV) {
3510 GV *gv = cGVOPx_gv(curop);
3511 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3513 SvCUR(gv) = PL_generation;
3515 else if (curop->op_type == OP_PADSV ||
3516 curop->op_type == OP_PADAV ||
3517 curop->op_type == OP_PADHV ||
3518 curop->op_type == OP_PADANY) {
3519 SV **svp = AvARRAY(PL_comppad_name);
3520 SV *sv = svp[curop->op_targ];
3521 if (SvCUR(sv) == PL_generation)
3523 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3525 else if (curop->op_type == OP_RV2CV)
3527 else if (curop->op_type == OP_RV2SV ||
3528 curop->op_type == OP_RV2AV ||
3529 curop->op_type == OP_RV2HV ||
3530 curop->op_type == OP_RV2GV) {
3531 if (lastop->op_type != OP_GV) /* funny deref? */
3534 else if (curop->op_type == OP_PUSHRE) {
3535 if (((PMOP*)curop)->op_pmreplroot) {
3537 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3539 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3541 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3543 SvCUR(gv) = PL_generation;
3552 o->op_private |= OPpASSIGN_COMMON;
3554 if (right && right->op_type == OP_SPLIT) {
3556 if ((tmpop = ((LISTOP*)right)->op_first) &&
3557 tmpop->op_type == OP_PUSHRE)
3559 PMOP *pm = (PMOP*)tmpop;
3560 if (left->op_type == OP_RV2AV &&
3561 !(left->op_private & OPpLVAL_INTRO) &&
3562 !(o->op_private & OPpASSIGN_COMMON) )
3564 tmpop = ((UNOP*)left)->op_first;
3565 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3567 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3568 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3570 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3571 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3573 pm->op_pmflags |= PMf_ONCE;
3574 tmpop = cUNOPo->op_first; /* to list (nulled) */
3575 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3576 tmpop->op_sibling = Nullop; /* don't free split */
3577 right->op_next = tmpop->op_next; /* fix starting loc */
3578 op_free(o); /* blow off assign */
3579 right->op_flags &= ~OPf_WANT;
3580 /* "I don't know and I don't care." */
3585 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3586 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3588 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3590 sv_setiv(sv, PL_modcount+1);
3598 right = newOP(OP_UNDEF, 0);
3599 if (right->op_type == OP_READLINE) {
3600 right->op_flags |= OPf_STACKED;
3601 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3604 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3605 o = newBINOP(OP_SASSIGN, flags,
3606 scalar(right), mod(scalar(left), OP_SASSIGN) );
3618 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3620 U32 seq = intro_my();
3623 NewOp(1101, cop, 1, COP);
3624 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3625 cop->op_type = OP_DBSTATE;
3626 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3629 cop->op_type = OP_NEXTSTATE;
3630 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3632 cop->op_flags = flags;
3633 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3635 cop->op_private |= NATIVE_HINTS;
3637 PL_compiling.op_private = cop->op_private;
3638 cop->op_next = (OP*)cop;
3641 cop->cop_label = label;
3642 PL_hints |= HINT_BLOCK_SCOPE;
3645 cop->cop_arybase = PL_curcop->cop_arybase;
3646 if (specialWARN(PL_curcop->cop_warnings))
3647 cop->cop_warnings = PL_curcop->cop_warnings ;
3649 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3650 if (specialCopIO(PL_curcop->cop_io))
3651 cop->cop_io = PL_curcop->cop_io;
3653 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3656 if (PL_copline == NOLINE)
3657 CopLINE_set(cop, CopLINE(PL_curcop));
3659 CopLINE_set(cop, PL_copline);
3660 PL_copline = NOLINE;
3663 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3665 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3667 CopSTASH_set(cop, PL_curstash);
3669 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3670 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3671 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3672 (void)SvIOK_on(*svp);
3673 SvIVX(*svp) = PTR2IV(cop);
3677 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3680 /* "Introduce" my variables to visible status. */
3688 if (! PL_min_intro_pending)
3689 return PL_cop_seqmax;
3691 svp = AvARRAY(PL_comppad_name);
3692 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3693 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3694 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3695 SvNVX(sv) = (NV)PL_cop_seqmax;
3698 PL_min_intro_pending = 0;
3699 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3700 return PL_cop_seqmax++;
3704 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3706 return new_logop(type, flags, &first, &other);
3710 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3714 OP *first = *firstp;
3715 OP *other = *otherp;
3717 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3718 return newBINOP(type, flags, scalar(first), scalar(other));
3720 scalarboolean(first);
3721 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3722 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3723 if (type == OP_AND || type == OP_OR) {
3729 first = *firstp = cUNOPo->op_first;
3731 first->op_next = o->op_next;
3732 cUNOPo->op_first = Nullop;
3736 if (first->op_type == OP_CONST) {
3737 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3738 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3739 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3750 else if (first->op_type == OP_WANTARRAY) {
3756 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3757 OP *k1 = ((UNOP*)first)->op_first;
3758 OP *k2 = k1->op_sibling;
3760 switch (first->op_type)
3763 if (k2 && k2->op_type == OP_READLINE
3764 && (k2->op_flags & OPf_STACKED)
3765 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3767 warnop = k2->op_type;
3772 if (k1->op_type == OP_READDIR
3773 || k1->op_type == OP_GLOB
3774 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3775 || k1->op_type == OP_EACH)
3777 warnop = ((k1->op_type == OP_NULL)
3778 ? k1->op_targ : k1->op_type);
3783 line_t oldline = CopLINE(PL_curcop);
3784 CopLINE_set(PL_curcop, PL_copline);
3785 Perl_warner(aTHX_ WARN_MISC,
3786 "Value of %s%s can be \"0\"; test with defined()",
3788 ((warnop == OP_READLINE || warnop == OP_GLOB)
3789 ? " construct" : "() operator"));
3790 CopLINE_set(PL_curcop, oldline);
3797 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3798 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3800 NewOp(1101, logop, 1, LOGOP);
3802 logop->op_type = type;
3803 logop->op_ppaddr = PL_ppaddr[type];
3804 logop->op_first = first;
3805 logop->op_flags = flags | OPf_KIDS;
3806 logop->op_other = LINKLIST(other);
3807 logop->op_private = 1 | (flags >> 8);
3809 /* establish postfix order */
3810 logop->op_next = LINKLIST(first);
3811 first->op_next = (OP*)logop;
3812 first->op_sibling = other;
3814 o = newUNOP(OP_NULL, 0, (OP*)logop);
3821 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3828 return newLOGOP(OP_AND, 0, first, trueop);
3830 return newLOGOP(OP_OR, 0, first, falseop);
3832 scalarboolean(first);
3833 if (first->op_type == OP_CONST) {
3834 if (SvTRUE(((SVOP*)first)->op_sv)) {
3845 else if (first->op_type == OP_WANTARRAY) {
3849 NewOp(1101, logop, 1, LOGOP);
3850 logop->op_type = OP_COND_EXPR;
3851 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3852 logop->op_first = first;
3853 logop->op_flags = flags | OPf_KIDS;
3854 logop->op_private = 1 | (flags >> 8);
3855 logop->op_other = LINKLIST(trueop);
3856 logop->op_next = LINKLIST(falseop);
3859 /* establish postfix order */
3860 start = LINKLIST(first);
3861 first->op_next = (OP*)logop;
3863 first->op_sibling = trueop;
3864 trueop->op_sibling = falseop;
3865 o = newUNOP(OP_NULL, 0, (OP*)logop);
3867 trueop->op_next = falseop->op_next = o;
3874 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3882 NewOp(1101, range, 1, LOGOP);
3884 range->op_type = OP_RANGE;
3885 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3886 range->op_first = left;
3887 range->op_flags = OPf_KIDS;
3888 leftstart = LINKLIST(left);
3889 range->op_other = LINKLIST(right);
3890 range->op_private = 1 | (flags >> 8);
3892 left->op_sibling = right;
3894 range->op_next = (OP*)range;
3895 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3896 flop = newUNOP(OP_FLOP, 0, flip);
3897 o = newUNOP(OP_NULL, 0, flop);
3899 range->op_next = leftstart;
3901 left->op_next = flip;
3902 right->op_next = flop;
3904 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3905 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3906 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3907 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3909 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3910 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3913 if (!flip->op_private || !flop->op_private)
3914 linklist(o); /* blow off optimizer unless constant */
3920 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3924 int once = block && block->op_flags & OPf_SPECIAL &&
3925 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3928 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3929 return block; /* do {} while 0 does once */
3930 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3931 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3932 expr = newUNOP(OP_DEFINED, 0,
3933 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3934 } else if (expr->op_flags & OPf_KIDS) {
3935 OP *k1 = ((UNOP*)expr)->op_first;
3936 OP *k2 = (k1) ? k1->op_sibling : NULL;
3937 switch (expr->op_type) {
3939 if (k2 && k2->op_type == OP_READLINE
3940 && (k2->op_flags & OPf_STACKED)
3941 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3942 expr = newUNOP(OP_DEFINED, 0, expr);
3946 if (k1->op_type == OP_READDIR
3947 || k1->op_type == OP_GLOB
3948 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3949 || k1->op_type == OP_EACH)
3950 expr = newUNOP(OP_DEFINED, 0, expr);
3956 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3957 o = new_logop(OP_AND, 0, &expr, &listop);
3960 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3962 if (once && o != listop)
3963 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3966 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3968 o->op_flags |= flags;
3970 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3975 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3983 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3984 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3985 expr = newUNOP(OP_DEFINED, 0,
3986 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3987 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3988 OP *k1 = ((UNOP*)expr)->op_first;
3989 OP *k2 = (k1) ? k1->op_sibling : NULL;
3990 switch (expr->op_type) {
3992 if (k2 && k2->op_type == OP_READLINE
3993 && (k2->op_flags & OPf_STACKED)
3994 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3995 expr = newUNOP(OP_DEFINED, 0, expr);
3999 if (k1->op_type == OP_READDIR
4000 || k1->op_type == OP_GLOB
4001 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4002 || k1->op_type == OP_EACH)
4003 expr = newUNOP(OP_DEFINED, 0, expr);
4009 block = newOP(OP_NULL, 0);
4011 block = scope(block);
4015 next = LINKLIST(cont);
4018 OP *unstack = newOP(OP_UNSTACK, 0);
4021 cont = append_elem(OP_LINESEQ, cont, unstack);
4022 if ((line_t)whileline != NOLINE) {
4023 PL_copline = whileline;
4024 cont = append_elem(OP_LINESEQ, cont,
4025 newSTATEOP(0, Nullch, Nullop));
4029 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4030 redo = LINKLIST(listop);
4033 PL_copline = whileline;
4035 o = new_logop(OP_AND, 0, &expr, &listop);
4036 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4037 op_free(expr); /* oops, it's a while (0) */
4039 return Nullop; /* listop already freed by new_logop */
4042 ((LISTOP*)listop)->op_last->op_next =
4043 (o == listop ? redo : LINKLIST(o));
4049 NewOp(1101,loop,1,LOOP);
4050 loop->op_type = OP_ENTERLOOP;
4051 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4052 loop->op_private = 0;
4053 loop->op_next = (OP*)loop;
4056 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4058 loop->op_redoop = redo;
4059 loop->op_lastop = o;
4060 o->op_private |= loopflags;
4063 loop->op_nextop = next;
4065 loop->op_nextop = o;
4067 o->op_flags |= flags;
4068 o->op_private |= (flags >> 8);
4073 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4081 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4082 sv->op_type = OP_RV2GV;
4083 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4085 else if (sv->op_type == OP_PADSV) { /* private variable */
4086 padoff = sv->op_targ;
4091 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4092 padoff = sv->op_targ;
4094 iterflags |= OPf_SPECIAL;
4099 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4103 padoff = find_threadsv("_");
4104 iterflags |= OPf_SPECIAL;
4106 sv = newGVOP(OP_GV, 0, PL_defgv);
4109 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4110 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4111 iterflags |= OPf_STACKED;
4113 else if (expr->op_type == OP_NULL &&
4114 (expr->op_flags & OPf_KIDS) &&
4115 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4117 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4118 * set the STACKED flag to indicate that these values are to be
4119 * treated as min/max values by 'pp_iterinit'.
4121 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4122 LOGOP* range = (LOGOP*) flip->op_first;
4123 OP* left = range->op_first;
4124 OP* right = left->op_sibling;
4127 range->op_flags &= ~OPf_KIDS;
4128 range->op_first = Nullop;
4130 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4131 listop->op_first->op_next = range->op_next;
4132 left->op_next = range->op_other;
4133 right->op_next = (OP*)listop;
4134 listop->op_next = listop->op_first;
4137 expr = (OP*)(listop);
4139 iterflags |= OPf_STACKED;
4142 expr = mod(force_list(expr), OP_GREPSTART);
4146 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4147 append_elem(OP_LIST, expr, scalar(sv))));
4148 assert(!loop->op_next);
4149 #ifdef PL_OP_SLAB_ALLOC
4152 NewOp(1234,tmp,1,LOOP);
4153 Copy(loop,tmp,1,LOOP);
4157 Renew(loop, 1, LOOP);
4159 loop->op_targ = padoff;
4160 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4161 PL_copline = forline;
4162 return newSTATEOP(0, label, wop);
4166 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4171 if (type != OP_GOTO || label->op_type == OP_CONST) {
4172 /* "last()" means "last" */
4173 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4174 o = newOP(type, OPf_SPECIAL);
4176 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4177 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4183 if (label->op_type == OP_ENTERSUB)
4184 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4185 o = newUNOP(type, OPf_STACKED, label);
4187 PL_hints |= HINT_BLOCK_SCOPE;
4192 Perl_cv_undef(pTHX_ CV *cv)
4196 MUTEX_DESTROY(CvMUTEXP(cv));
4197 Safefree(CvMUTEXP(cv));
4200 #endif /* USE_THREADS */
4203 if (CvFILE(cv) && !CvXSUB(cv)) {
4204 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4205 Safefree(CvFILE(cv));
4210 if (!CvXSUB(cv) && CvROOT(cv)) {
4212 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4213 Perl_croak(aTHX_ "Can't undef active subroutine");
4216 Perl_croak(aTHX_ "Can't undef active subroutine");
4217 #endif /* USE_THREADS */
4220 SAVEVPTR(PL_curpad);
4223 op_free(CvROOT(cv));
4224 CvROOT(cv) = Nullop;
4227 SvPOK_off((SV*)cv); /* forget prototype */
4229 /* Since closure prototypes have the same lifetime as the containing
4230 * CV, they don't hold a refcount on the outside CV. This avoids
4231 * the refcount loop between the outer CV (which keeps a refcount to
4232 * the closure prototype in the pad entry for pp_anoncode()) and the
4233 * closure prototype, and the ensuing memory leak. This does not
4234 * apply to closures generated within eval"", since eval"" CVs are
4235 * ephemeral. --GSAR */
4236 if (!CvANON(cv) || CvCLONED(cv)
4237 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4238 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4240 SvREFCNT_dec(CvOUTSIDE(cv));
4242 CvOUTSIDE(cv) = Nullcv;
4244 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4247 if (CvPADLIST(cv)) {
4248 /* may be during global destruction */
4249 if (SvREFCNT(CvPADLIST(cv))) {
4250 I32 i = AvFILLp(CvPADLIST(cv));
4252 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4253 SV* sv = svp ? *svp : Nullsv;
4256 if (sv == (SV*)PL_comppad_name)
4257 PL_comppad_name = Nullav;
4258 else if (sv == (SV*)PL_comppad) {
4259 PL_comppad = Nullav;
4260 PL_curpad = Null(SV**);
4264 SvREFCNT_dec((SV*)CvPADLIST(cv));
4266 CvPADLIST(cv) = Nullav;
4274 #ifdef DEBUG_CLOSURES
4276 S_cv_dump(pTHX_ CV *cv)
4279 CV *outside = CvOUTSIDE(cv);
4280 AV* padlist = CvPADLIST(cv);
4287 PerlIO_printf(Perl_debug_log,
4288 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4290 (CvANON(cv) ? "ANON"
4291 : (cv == PL_main_cv) ? "MAIN"
4292 : CvUNIQUE(cv) ? "UNIQUE"
4293 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4296 : CvANON(outside) ? "ANON"
4297 : (outside == PL_main_cv) ? "MAIN"
4298 : CvUNIQUE(outside) ? "UNIQUE"
4299 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4304 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4305 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4306 pname = AvARRAY(pad_name);
4307 ppad = AvARRAY(pad);
4309 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4310 if (SvPOK(pname[ix]))
4311 PerlIO_printf(Perl_debug_log,
4312 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4313 (int)ix, PTR2UV(ppad[ix]),
4314 SvFAKE(pname[ix]) ? "FAKE " : "",
4316 (IV)I_32(SvNVX(pname[ix])),
4319 #endif /* DEBUGGING */
4321 #endif /* DEBUG_CLOSURES */
4324 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4328 AV* protopadlist = CvPADLIST(proto);
4329 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4330 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4331 SV** pname = AvARRAY(protopad_name);
4332 SV** ppad = AvARRAY(protopad);
4333 I32 fname = AvFILLp(protopad_name);
4334 I32 fpad = AvFILLp(protopad);
4338 assert(!CvUNIQUE(proto));
4342 SAVESPTR(PL_comppad_name);
4343 SAVESPTR(PL_compcv);
4345 cv = PL_compcv = (CV*)NEWSV(1104,0);
4346 sv_upgrade((SV *)cv, SvTYPE(proto));
4347 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4351 New(666, CvMUTEXP(cv), 1, perl_mutex);
4352 MUTEX_INIT(CvMUTEXP(cv));
4354 #endif /* USE_THREADS */
4356 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4357 : savepv(CvFILE(proto));
4359 CvFILE(cv) = CvFILE(proto);
4361 CvGV(cv) = CvGV(proto);
4362 CvSTASH(cv) = CvSTASH(proto);
4363 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4364 CvSTART(cv) = CvSTART(proto);
4366 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4369 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4371 PL_comppad_name = newAV();
4372 for (ix = fname; ix >= 0; ix--)
4373 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4375 PL_comppad = newAV();
4377 comppadlist = newAV();
4378 AvREAL_off(comppadlist);
4379 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4380 av_store(comppadlist, 1, (SV*)PL_comppad);
4381 CvPADLIST(cv) = comppadlist;
4382 av_fill(PL_comppad, AvFILLp(protopad));
4383 PL_curpad = AvARRAY(PL_comppad);
4385 av = newAV(); /* will be @_ */
4387 av_store(PL_comppad, 0, (SV*)av);
4388 AvFLAGS(av) = AVf_REIFY;
4390 for (ix = fpad; ix > 0; ix--) {
4391 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4392 if (namesv && namesv != &PL_sv_undef) {
4393 char *name = SvPVX(namesv); /* XXX */
4394 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4395 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4396 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4398 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4400 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4402 else { /* our own lexical */
4405 /* anon code -- we'll come back for it */
4406 sv = SvREFCNT_inc(ppad[ix]);
4408 else if (*name == '@')
4410 else if (*name == '%')
4419 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4420 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4423 SV* sv = NEWSV(0,0);
4429 /* Now that vars are all in place, clone nested closures. */
4431 for (ix = fpad; ix > 0; ix--) {
4432 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4434 && namesv != &PL_sv_undef
4435 && !(SvFLAGS(namesv) & SVf_FAKE)
4436 && *SvPVX(namesv) == '&'
4437 && CvCLONE(ppad[ix]))
4439 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4440 SvREFCNT_dec(ppad[ix]);
4443 PL_curpad[ix] = (SV*)kid;
4447 #ifdef DEBUG_CLOSURES
4448 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4450 PerlIO_printf(Perl_debug_log, " from:\n");
4452 PerlIO_printf(Perl_debug_log, " to:\n");
4459 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4461 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4463 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4470 Perl_cv_clone(pTHX_ CV *proto)
4473 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4474 cv = cv_clone2(proto, CvOUTSIDE(proto));
4475 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4480 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4482 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4483 SV* msg = sv_newmortal();
4487 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4488 sv_setpv(msg, "Prototype mismatch:");
4490 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4492 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4493 sv_catpv(msg, " vs ");
4495 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4497 sv_catpv(msg, "none");
4498 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4502 static void const_sv_xsub(pTHXo_ CV* cv);
4505 =for apidoc cv_const_sv
4507 If C<cv> is a constant sub eligible for inlining. returns the constant
4508 value returned by the sub. Otherwise, returns NULL.
4510 Constant subs can be created with C<newCONSTSUB> or as described in
4511 L<perlsub/"Constant Functions">.
4516 Perl_cv_const_sv(pTHX_ CV *cv)
4518 if (!cv || !CvCONST(cv))
4520 return (SV*)CvXSUBANY(cv).any_ptr;
4524 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4531 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4532 o = cLISTOPo->op_first->op_sibling;
4534 for (; o; o = o->op_next) {
4535 OPCODE type = o->op_type;
4537 if (sv && o->op_next == o)
4539 if (o->op_next != o) {
4540 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4542 if (type == OP_DBSTATE)
4545 if (type == OP_LEAVESUB || type == OP_RETURN)
4549 if (type == OP_CONST && cSVOPo->op_sv)
4551 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4552 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4553 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4557 /* We get here only from cv_clone2() while creating a closure.
4558 Copy the const value here instead of in cv_clone2 so that
4559 SvREADONLY_on doesn't lead to problems when leaving
4564 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4576 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4586 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4590 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4592 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4596 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4602 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4607 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4608 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4609 SV *sv = sv_newmortal();
4610 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4611 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4616 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4617 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4627 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4628 maximum a prototype before. */
4629 if (SvTYPE(gv) > SVt_NULL) {
4630 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4631 && ckWARN_d(WARN_PROTOTYPE))
4633 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4635 cv_ckproto((CV*)gv, NULL, ps);
4638 sv_setpv((SV*)gv, ps);
4640 sv_setiv((SV*)gv, -1);
4641 SvREFCNT_dec(PL_compcv);
4642 cv = PL_compcv = NULL;
4643 PL_sub_generation++;
4647 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4649 #ifdef GV_UNIQUE_CHECK
4650 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4651 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4655 if (!block || !ps || *ps || attrs)
4658 const_sv = op_const_sv(block, Nullcv);
4661 bool exists = CvROOT(cv) || CvXSUB(cv);
4663 #ifdef GV_UNIQUE_CHECK
4664 if (exists && GvUNIQUE(gv)) {
4665 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4669 /* if the subroutine doesn't exist and wasn't pre-declared
4670 * with a prototype, assume it will be AUTOLOADed,
4671 * skipping the prototype check
4673 if (exists || SvPOK(cv))
4674 cv_ckproto(cv, gv, ps);
4675 /* already defined (or promised)? */
4676 if (exists || GvASSUMECV(gv)) {
4677 if (!block && !attrs) {
4678 /* just a "sub foo;" when &foo is already defined */
4679 SAVEFREESV(PL_compcv);
4682 /* ahem, death to those who redefine active sort subs */
4683 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4684 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4686 if (ckWARN(WARN_REDEFINE)
4688 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4690 line_t oldline = CopLINE(PL_curcop);
4691 CopLINE_set(PL_curcop, PL_copline);
4692 Perl_warner(aTHX_ WARN_REDEFINE,
4693 CvCONST(cv) ? "Constant subroutine %s redefined"
4694 : "Subroutine %s redefined", name);
4695 CopLINE_set(PL_curcop, oldline);
4703 SvREFCNT_inc(const_sv);
4705 assert(!CvROOT(cv) && !CvCONST(cv));
4706 sv_setpv((SV*)cv, ""); /* prototype is "" */
4707 CvXSUBANY(cv).any_ptr = const_sv;
4708 CvXSUB(cv) = const_sv_xsub;
4713 cv = newCONSTSUB(NULL, name, const_sv);
4716 SvREFCNT_dec(PL_compcv);
4718 PL_sub_generation++;
4725 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4726 * before we clobber PL_compcv.
4730 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4731 stash = GvSTASH(CvGV(cv));
4732 else if (CvSTASH(cv))
4733 stash = CvSTASH(cv);
4735 stash = PL_curstash;
4738 /* possibly about to re-define existing subr -- ignore old cv */
4739 rcv = (SV*)PL_compcv;
4740 if (name && GvSTASH(gv))
4741 stash = GvSTASH(gv);
4743 stash = PL_curstash;
4745 apply_attrs(stash, rcv, attrs);
4747 if (cv) { /* must reuse cv if autoloaded */
4749 /* got here with just attrs -- work done, so bug out */
4750 SAVEFREESV(PL_compcv);
4754 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4755 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4756 CvOUTSIDE(PL_compcv) = 0;
4757 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4758 CvPADLIST(PL_compcv) = 0;
4759 /* inner references to PL_compcv must be fixed up ... */
4761 AV *padlist = CvPADLIST(cv);
4762 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4763 AV *comppad = (AV*)AvARRAY(padlist)[1];
4764 SV **namepad = AvARRAY(comppad_name);
4765 SV **curpad = AvARRAY(comppad);
4766 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4767 SV *namesv = namepad[ix];
4768 if (namesv && namesv != &PL_sv_undef
4769 && *SvPVX(namesv) == '&')
4771 CV *innercv = (CV*)curpad[ix];
4772 if (CvOUTSIDE(innercv) == PL_compcv) {
4773 CvOUTSIDE(innercv) = cv;
4774 if (!CvANON(innercv) || CvCLONED(innercv)) {
4775 (void)SvREFCNT_inc(cv);
4776 SvREFCNT_dec(PL_compcv);
4782 /* ... before we throw it away */
4783 SvREFCNT_dec(PL_compcv);
4784 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4785 ++PL_sub_generation;
4792 PL_sub_generation++;
4796 CvFILE_set_from_cop(cv, PL_curcop);
4797 CvSTASH(cv) = PL_curstash;
4800 if (!CvMUTEXP(cv)) {
4801 New(666, CvMUTEXP(cv), 1, perl_mutex);
4802 MUTEX_INIT(CvMUTEXP(cv));
4804 #endif /* USE_THREADS */
4807 sv_setpv((SV*)cv, ps);
4809 if (PL_error_count) {
4813 char *s = strrchr(name, ':');
4815 if (strEQ(s, "BEGIN")) {
4817 "BEGIN not safe after errors--compilation aborted";
4818 if (PL_in_eval & EVAL_KEEPERR)
4819 Perl_croak(aTHX_ not_safe);
4821 /* force display of errors found but not reported */
4822 sv_catpv(ERRSV, not_safe);
4823 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4831 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4832 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4835 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4836 mod(scalarseq(block), OP_LEAVESUBLV));
4839 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4841 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4842 OpREFCNT_set(CvROOT(cv), 1);
4843 CvSTART(cv) = LINKLIST(CvROOT(cv));
4844 CvROOT(cv)->op_next = 0;
4845 CALL_PEEP(CvSTART(cv));
4847 /* now that optimizer has done its work, adjust pad values */
4849 SV **namep = AvARRAY(PL_comppad_name);
4850 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4853 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4856 * The only things that a clonable function needs in its
4857 * pad are references to outer lexicals and anonymous subs.
4858 * The rest are created anew during cloning.
4860 if (!((namesv = namep[ix]) != Nullsv &&
4861 namesv != &PL_sv_undef &&
4863 *SvPVX(namesv) == '&')))
4865 SvREFCNT_dec(PL_curpad[ix]);
4866 PL_curpad[ix] = Nullsv;
4869 assert(!CvCONST(cv));
4870 if (ps && !*ps && op_const_sv(block, cv))
4874 AV *av = newAV(); /* Will be @_ */
4876 av_store(PL_comppad, 0, (SV*)av);
4877 AvFLAGS(av) = AVf_REIFY;
4879 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4880 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4882 if (!SvPADMY(PL_curpad[ix]))
4883 SvPADTMP_on(PL_curpad[ix]);
4887 /* If a potential closure prototype, don't keep a refcount on
4888 * outer CV, unless the latter happens to be a passing eval"".
4889 * This is okay as the lifetime of the prototype is tied to the
4890 * lifetime of the outer CV. Avoids memory leak due to reference
4892 if (!name && CvOUTSIDE(cv)
4893 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4894 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4896 SvREFCNT_dec(CvOUTSIDE(cv));
4899 if (name || aname) {
4901 char *tname = (name ? name : aname);
4903 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4904 SV *sv = NEWSV(0,0);
4905 SV *tmpstr = sv_newmortal();
4906 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4910 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4912 (long)PL_subline, (long)CopLINE(PL_curcop));
4913 gv_efullname3(tmpstr, gv, Nullch);
4914 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4915 hv = GvHVn(db_postponed);
4916 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4917 && (pcv = GvCV(db_postponed)))
4923 call_sv((SV*)pcv, G_DISCARD);
4927 if ((s = strrchr(tname,':')))
4932 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4935 if (strEQ(s, "BEGIN")) {
4936 I32 oldscope = PL_scopestack_ix;
4938 SAVECOPFILE(&PL_compiling);
4939 SAVECOPLINE(&PL_compiling);
4941 sv_setsv(PL_rs, PL_nrs);
4944 PL_beginav = newAV();
4945 DEBUG_x( dump_sub(gv) );
4946 av_push(PL_beginav, (SV*)cv);
4947 GvCV(gv) = 0; /* cv has been hijacked */
4948 call_list(oldscope, PL_beginav);
4950 PL_curcop = &PL_compiling;
4951 PL_compiling.op_private = PL_hints;
4954 else if (strEQ(s, "END") && !PL_error_count) {
4957 DEBUG_x( dump_sub(gv) );
4958 av_unshift(PL_endav, 1);
4959 av_store(PL_endav, 0, (SV*)cv);
4960 GvCV(gv) = 0; /* cv has been hijacked */
4962 else if (strEQ(s, "CHECK") && !PL_error_count) {
4964 PL_checkav = newAV();
4965 DEBUG_x( dump_sub(gv) );
4966 if (PL_main_start && ckWARN(WARN_VOID))
4967 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4968 av_unshift(PL_checkav, 1);
4969 av_store(PL_checkav, 0, (SV*)cv);
4970 GvCV(gv) = 0; /* cv has been hijacked */
4972 else if (strEQ(s, "INIT") && !PL_error_count) {
4974 PL_initav = newAV();
4975 DEBUG_x( dump_sub(gv) );
4976 if (PL_main_start && ckWARN(WARN_VOID))
4977 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4978 av_push(PL_initav, (SV*)cv);
4979 GvCV(gv) = 0; /* cv has been hijacked */
4984 PL_copline = NOLINE;
4989 /* XXX unsafe for threads if eval_owner isn't held */
4991 =for apidoc newCONSTSUB
4993 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4994 eligible for inlining at compile-time.
5000 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5006 SAVECOPLINE(PL_curcop);
5007 CopLINE_set(PL_curcop, PL_copline);
5010 PL_hints &= ~HINT_BLOCK_SCOPE;
5013 SAVESPTR(PL_curstash);
5014 SAVECOPSTASH(PL_curcop);
5015 PL_curstash = stash;
5017 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5019 CopSTASH(PL_curcop) = stash;
5023 cv = newXS(name, const_sv_xsub, __FILE__);
5024 CvXSUBANY(cv).any_ptr = sv;
5026 sv_setpv((SV*)cv, ""); /* prototype is "" */
5034 =for apidoc U||newXS
5036 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5042 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5044 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5047 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5049 /* just a cached method */
5053 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5054 /* already defined (or promised) */
5055 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5056 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5057 line_t oldline = CopLINE(PL_curcop);
5058 if (PL_copline != NOLINE)
5059 CopLINE_set(PL_curcop, PL_copline);
5060 Perl_warner(aTHX_ WARN_REDEFINE,
5061 CvCONST(cv) ? "Constant subroutine %s redefined"
5062 : "Subroutine %s redefined"
5064 CopLINE_set(PL_curcop, oldline);
5071 if (cv) /* must reuse cv if autoloaded */
5074 cv = (CV*)NEWSV(1105,0);
5075 sv_upgrade((SV *)cv, SVt_PVCV);
5079 PL_sub_generation++;
5084 New(666, CvMUTEXP(cv), 1, perl_mutex);
5085 MUTEX_INIT(CvMUTEXP(cv));
5087 #endif /* USE_THREADS */
5088 (void)gv_fetchfile(filename);
5089 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5090 an external constant string */
5091 CvXSUB(cv) = subaddr;
5094 char *s = strrchr(name,':');
5100 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5103 if (strEQ(s, "BEGIN")) {
5105 PL_beginav = newAV();
5106 av_push(PL_beginav, (SV*)cv);
5107 GvCV(gv) = 0; /* cv has been hijacked */
5109 else if (strEQ(s, "END")) {
5112 av_unshift(PL_endav, 1);
5113 av_store(PL_endav, 0, (SV*)cv);
5114 GvCV(gv) = 0; /* cv has been hijacked */
5116 else if (strEQ(s, "CHECK")) {
5118 PL_checkav = newAV();
5119 if (PL_main_start && ckWARN(WARN_VOID))
5120 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5121 av_unshift(PL_checkav, 1);
5122 av_store(PL_checkav, 0, (SV*)cv);
5123 GvCV(gv) = 0; /* cv has been hijacked */
5125 else if (strEQ(s, "INIT")) {
5127 PL_initav = newAV();
5128 if (PL_main_start && ckWARN(WARN_VOID))
5129 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5130 av_push(PL_initav, (SV*)cv);
5131 GvCV(gv) = 0; /* cv has been hijacked */
5142 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5151 name = SvPVx(cSVOPo->op_sv, n_a);
5154 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5155 #ifdef GV_UNIQUE_CHECK
5157 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5161 if ((cv = GvFORM(gv))) {
5162 if (ckWARN(WARN_REDEFINE)) {
5163 line_t oldline = CopLINE(PL_curcop);
5165 CopLINE_set(PL_curcop, PL_copline);
5166 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5167 CopLINE_set(PL_curcop, oldline);
5174 CvFILE_set_from_cop(cv, PL_curcop);
5176 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5177 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5178 SvPADTMP_on(PL_curpad[ix]);
5181 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5182 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5183 OpREFCNT_set(CvROOT(cv), 1);
5184 CvSTART(cv) = LINKLIST(CvROOT(cv));
5185 CvROOT(cv)->op_next = 0;
5186 CALL_PEEP(CvSTART(cv));
5188 PL_copline = NOLINE;
5193 Perl_newANONLIST(pTHX_ OP *o)
5195 return newUNOP(OP_REFGEN, 0,
5196 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5200 Perl_newANONHASH(pTHX_ OP *o)
5202 return newUNOP(OP_REFGEN, 0,
5203 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5207 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5209 return newANONATTRSUB(floor, proto, Nullop, block);
5213 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5215 return newUNOP(OP_REFGEN, 0,
5216 newSVOP(OP_ANONCODE, 0,
5217 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5221 Perl_oopsAV(pTHX_ OP *o)
5223 switch (o->op_type) {
5225 o->op_type = OP_PADAV;
5226 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5227 return ref(o, OP_RV2AV);
5230 o->op_type = OP_RV2AV;
5231 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5236 if (ckWARN_d(WARN_INTERNAL))
5237 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5244 Perl_oopsHV(pTHX_ OP *o)
5246 switch (o->op_type) {
5249 o->op_type = OP_PADHV;
5250 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5251 return ref(o, OP_RV2HV);
5255 o->op_type = OP_RV2HV;
5256 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5261 if (ckWARN_d(WARN_INTERNAL))
5262 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5269 Perl_newAVREF(pTHX_ OP *o)
5271 if (o->op_type == OP_PADANY) {
5272 o->op_type = OP_PADAV;
5273 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5276 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5277 && ckWARN(WARN_DEPRECATED)) {
5278 Perl_warner(aTHX_ WARN_DEPRECATED,
5279 "Using an array as a reference is deprecated");
5281 return newUNOP(OP_RV2AV, 0, scalar(o));
5285 Perl_newGVREF(pTHX_ I32 type, OP *o)
5287 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5288 return newUNOP(OP_NULL, 0, o);
5289 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5293 Perl_newHVREF(pTHX_ OP *o)
5295 if (o->op_type == OP_PADANY) {
5296 o->op_type = OP_PADHV;
5297 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5300 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5301 && ckWARN(WARN_DEPRECATED)) {
5302 Perl_warner(aTHX_ WARN_DEPRECATED,
5303 "Using a hash as a reference is deprecated");
5305 return newUNOP(OP_RV2HV, 0, scalar(o));
5309 Perl_oopsCV(pTHX_ OP *o)
5311 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5317 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5319 return newUNOP(OP_RV2CV, flags, scalar(o));
5323 Perl_newSVREF(pTHX_ OP *o)
5325 if (o->op_type == OP_PADANY) {
5326 o->op_type = OP_PADSV;
5327 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5330 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5331 o->op_flags |= OPpDONE_SVREF;
5334 return newUNOP(OP_RV2SV, 0, scalar(o));
5337 /* Check routines. */
5340 Perl_ck_anoncode(pTHX_ OP *o)
5345 name = NEWSV(1106,0);
5346 sv_upgrade(name, SVt_PVNV);
5347 sv_setpvn(name, "&", 1);
5350 ix = pad_alloc(o->op_type, SVs_PADMY);
5351 av_store(PL_comppad_name, ix, name);
5352 av_store(PL_comppad, ix, cSVOPo->op_sv);
5353 SvPADMY_on(cSVOPo->op_sv);
5354 cSVOPo->op_sv = Nullsv;
5355 cSVOPo->op_targ = ix;
5360 Perl_ck_bitop(pTHX_ OP *o)
5362 o->op_private = PL_hints;
5367 Perl_ck_concat(pTHX_ OP *o)
5369 if (cUNOPo->op_first->op_type == OP_CONCAT)
5370 o->op_flags |= OPf_STACKED;
5375 Perl_ck_spair(pTHX_ OP *o)
5377 if (o->op_flags & OPf_KIDS) {
5380 OPCODE type = o->op_type;
5381 o = modkids(ck_fun(o), type);
5382 kid = cUNOPo->op_first;
5383 newop = kUNOP->op_first->op_sibling;
5385 (newop->op_sibling ||
5386 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5387 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5388 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5392 op_free(kUNOP->op_first);
5393 kUNOP->op_first = newop;
5395 o->op_ppaddr = PL_ppaddr[++o->op_type];
5400 Perl_ck_delete(pTHX_ OP *o)
5404 if (o->op_flags & OPf_KIDS) {
5405 OP *kid = cUNOPo->op_first;
5406 switch (kid->op_type) {
5408 o->op_flags |= OPf_SPECIAL;
5411 o->op_private |= OPpSLICE;
5414 o->op_flags |= OPf_SPECIAL;
5419 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5420 PL_op_desc[o->op_type]);
5428 Perl_ck_eof(pTHX_ OP *o)
5430 I32 type = o->op_type;
5432 if (o->op_flags & OPf_KIDS) {
5433 if (cLISTOPo->op_first->op_type == OP_STUB) {
5435 o = newUNOP(type, OPf_SPECIAL,
5436 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5444 Perl_ck_eval(pTHX_ OP *o)
5446 PL_hints |= HINT_BLOCK_SCOPE;
5447 if (o->op_flags & OPf_KIDS) {
5448 SVOP *kid = (SVOP*)cUNOPo->op_first;
5451 o->op_flags &= ~OPf_KIDS;
5454 else if (kid->op_type == OP_LINESEQ) {
5457 kid->op_next = o->op_next;
5458 cUNOPo->op_first = 0;
5461 NewOp(1101, enter, 1, LOGOP);
5462 enter->op_type = OP_ENTERTRY;
5463 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5464 enter->op_private = 0;
5466 /* establish postfix order */
5467 enter->op_next = (OP*)enter;
5469 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5470 o->op_type = OP_LEAVETRY;
5471 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5472 enter->op_other = o;
5480 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5482 o->op_targ = (PADOFFSET)PL_hints;
5487 Perl_ck_exit(pTHX_ OP *o)
5490 HV *table = GvHV(PL_hintgv);
5492 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5493 if (svp && *svp && SvTRUE(*svp))
5494 o->op_private |= OPpEXIT_VMSISH;
5501 Perl_ck_exec(pTHX_ OP *o)
5504 if (o->op_flags & OPf_STACKED) {
5506 kid = cUNOPo->op_first->op_sibling;
5507 if (kid->op_type == OP_RV2GV)
5516 Perl_ck_exists(pTHX_ OP *o)
5519 if (o->op_flags & OPf_KIDS) {
5520 OP *kid = cUNOPo->op_first;
5521 if (kid->op_type == OP_ENTERSUB) {
5522 (void) ref(kid, o->op_type);
5523 if (kid->op_type != OP_RV2CV && !PL_error_count)
5524 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5525 PL_op_desc[o->op_type]);
5526 o->op_private |= OPpEXISTS_SUB;
5528 else if (kid->op_type == OP_AELEM)
5529 o->op_flags |= OPf_SPECIAL;
5530 else if (kid->op_type != OP_HELEM)
5531 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5532 PL_op_desc[o->op_type]);
5540 Perl_ck_gvconst(pTHX_ register OP *o)
5542 o = fold_constants(o);
5543 if (o->op_type == OP_CONST)
5550 Perl_ck_rvconst(pTHX_ register OP *o)
5552 SVOP *kid = (SVOP*)cUNOPo->op_first;
5554 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5555 if (kid->op_type == OP_CONST) {
5559 SV *kidsv = kid->op_sv;
5562 /* Is it a constant from cv_const_sv()? */
5563 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5564 SV *rsv = SvRV(kidsv);
5565 int svtype = SvTYPE(rsv);
5566 char *badtype = Nullch;
5568 switch (o->op_type) {
5570 if (svtype > SVt_PVMG)
5571 badtype = "a SCALAR";
5574 if (svtype != SVt_PVAV)
5575 badtype = "an ARRAY";
5578 if (svtype != SVt_PVHV) {
5579 if (svtype == SVt_PVAV) { /* pseudohash? */
5580 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5581 if (ksv && SvROK(*ksv)
5582 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5591 if (svtype != SVt_PVCV)
5596 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5599 name = SvPV(kidsv, n_a);
5600 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5601 char *badthing = Nullch;
5602 switch (o->op_type) {
5604 badthing = "a SCALAR";
5607 badthing = "an ARRAY";
5610 badthing = "a HASH";
5615 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5619 * This is a little tricky. We only want to add the symbol if we
5620 * didn't add it in the lexer. Otherwise we get duplicate strict
5621 * warnings. But if we didn't add it in the lexer, we must at
5622 * least pretend like we wanted to add it even if it existed before,
5623 * or we get possible typo warnings. OPpCONST_ENTERED says
5624 * whether the lexer already added THIS instance of this symbol.
5626 iscv = (o->op_type == OP_RV2CV) * 2;
5628 gv = gv_fetchpv(name,
5629 iscv | !(kid->op_private & OPpCONST_ENTERED),
5632 : o->op_type == OP_RV2SV
5634 : o->op_type == OP_RV2AV
5636 : o->op_type == OP_RV2HV
5639 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5641 kid->op_type = OP_GV;
5642 SvREFCNT_dec(kid->op_sv);
5644 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5645 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5646 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5648 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5650 kid->op_sv = SvREFCNT_inc(gv);
5652 kid->op_private = 0;
5653 kid->op_ppaddr = PL_ppaddr[OP_GV];
5660 Perl_ck_ftst(pTHX_ OP *o)
5662 I32 type = o->op_type;
5664 if (o->op_flags & OPf_REF) {
5667 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5668 SVOP *kid = (SVOP*)cUNOPo->op_first;
5670 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5672 OP *newop = newGVOP(type, OPf_REF,
5673 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5680 if (type == OP_FTTTY)
5681 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5684 o = newUNOP(type, 0, newDEFSVOP());
5690 Perl_ck_fun(pTHX_ OP *o)
5696 int type = o->op_type;
5697 register I32 oa = PL_opargs[type] >> OASHIFT;
5699 if (o->op_flags & OPf_STACKED) {
5700 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5703 return no_fh_allowed(o);
5706 if (o->op_flags & OPf_KIDS) {
5708 tokid = &cLISTOPo->op_first;
5709 kid = cLISTOPo->op_first;
5710 if (kid->op_type == OP_PUSHMARK ||
5711 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5713 tokid = &kid->op_sibling;
5714 kid = kid->op_sibling;
5716 if (!kid && PL_opargs[type] & OA_DEFGV)
5717 *tokid = kid = newDEFSVOP();
5721 sibl = kid->op_sibling;
5724 /* list seen where single (scalar) arg expected? */
5725 if (numargs == 1 && !(oa >> 4)
5726 && kid->op_type == OP_LIST && type != OP_SCALAR)
5728 return too_many_arguments(o,PL_op_desc[type]);
5741 if ((type == OP_PUSH || type == OP_UNSHIFT)
5742 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5743 Perl_warner(aTHX_ WARN_SYNTAX,
5744 "Useless use of %s with no values",
5747 if (kid->op_type == OP_CONST &&
5748 (kid->op_private & OPpCONST_BARE))
5750 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5751 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5752 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5753 if (ckWARN(WARN_DEPRECATED))
5754 Perl_warner(aTHX_ WARN_DEPRECATED,
5755 "Array @%s missing the @ in argument %"IVdf" of %s()",
5756 name, (IV)numargs, PL_op_desc[type]);
5759 kid->op_sibling = sibl;
5762 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5763 bad_type(numargs, "array", PL_op_desc[type], kid);
5767 if (kid->op_type == OP_CONST &&
5768 (kid->op_private & OPpCONST_BARE))
5770 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5771 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5772 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5773 if (ckWARN(WARN_DEPRECATED))
5774 Perl_warner(aTHX_ WARN_DEPRECATED,
5775 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5776 name, (IV)numargs, PL_op_desc[type]);
5779 kid->op_sibling = sibl;
5782 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5783 bad_type(numargs, "hash", PL_op_desc[type], kid);
5788 OP *newop = newUNOP(OP_NULL, 0, kid);
5789 kid->op_sibling = 0;
5791 newop->op_next = newop;
5793 kid->op_sibling = sibl;
5798 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5799 if (kid->op_type == OP_CONST &&
5800 (kid->op_private & OPpCONST_BARE))
5802 OP *newop = newGVOP(OP_GV, 0,
5803 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5808 else if (kid->op_type == OP_READLINE) {
5809 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5810 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5813 I32 flags = OPf_SPECIAL;
5817 /* is this op a FH constructor? */
5818 if (is_handle_constructor(o,numargs)) {
5819 char *name = Nullch;
5823 /* Set a flag to tell rv2gv to vivify
5824 * need to "prove" flag does not mean something
5825 * else already - NI-S 1999/05/07
5828 if (kid->op_type == OP_PADSV) {
5829 SV **namep = av_fetch(PL_comppad_name,
5831 if (namep && *namep)
5832 name = SvPV(*namep, len);
5834 else if (kid->op_type == OP_RV2SV
5835 && kUNOP->op_first->op_type == OP_GV)
5837 GV *gv = cGVOPx_gv(kUNOP->op_first);
5839 len = GvNAMELEN(gv);
5841 else if (kid->op_type == OP_AELEM
5842 || kid->op_type == OP_HELEM)
5844 name = "__ANONIO__";
5850 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5851 namesv = PL_curpad[targ];
5852 (void)SvUPGRADE(namesv, SVt_PV);
5854 sv_setpvn(namesv, "$", 1);
5855 sv_catpvn(namesv, name, len);
5858 kid->op_sibling = 0;
5859 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5860 kid->op_targ = targ;
5861 kid->op_private |= priv;
5863 kid->op_sibling = sibl;
5869 mod(scalar(kid), type);
5873 tokid = &kid->op_sibling;
5874 kid = kid->op_sibling;
5876 o->op_private |= numargs;
5878 return too_many_arguments(o,PL_op_desc[o->op_type]);
5881 else if (PL_opargs[type] & OA_DEFGV) {
5883 return newUNOP(type, 0, newDEFSVOP());
5887 while (oa & OA_OPTIONAL)
5889 if (oa && oa != OA_LIST)
5890 return too_few_arguments(o,PL_op_desc[o->op_type]);
5896 Perl_ck_glob(pTHX_ OP *o)
5901 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5902 append_elem(OP_GLOB, o, newDEFSVOP());
5904 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5905 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5907 #if !defined(PERL_EXTERNAL_GLOB)
5908 /* XXX this can be tightened up and made more failsafe. */
5912 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5914 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5915 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5916 GvCV(gv) = GvCV(glob_gv);
5917 SvREFCNT_inc((SV*)GvCV(gv));
5918 GvIMPORTED_CV_on(gv);
5921 #endif /* PERL_EXTERNAL_GLOB */
5923 if (gv && GvIMPORTED_CV(gv)) {
5924 append_elem(OP_GLOB, o,
5925 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5926 o->op_type = OP_LIST;
5927 o->op_ppaddr = PL_ppaddr[OP_LIST];
5928 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5929 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5930 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5931 append_elem(OP_LIST, o,
5932 scalar(newUNOP(OP_RV2CV, 0,
5933 newGVOP(OP_GV, 0, gv)))));
5934 o = newUNOP(OP_NULL, 0, ck_subr(o));
5935 o->op_targ = OP_GLOB; /* hint at what it used to be */
5938 gv = newGVgen("main");
5940 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5946 Perl_ck_grep(pTHX_ OP *o)
5950 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5952 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5953 NewOp(1101, gwop, 1, LOGOP);
5955 if (o->op_flags & OPf_STACKED) {
5958 kid = cLISTOPo->op_first->op_sibling;
5959 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5962 kid->op_next = (OP*)gwop;
5963 o->op_flags &= ~OPf_STACKED;
5965 kid = cLISTOPo->op_first->op_sibling;
5966 if (type == OP_MAPWHILE)
5973 kid = cLISTOPo->op_first->op_sibling;
5974 if (kid->op_type != OP_NULL)
5975 Perl_croak(aTHX_ "panic: ck_grep");
5976 kid = kUNOP->op_first;
5978 gwop->op_type = type;
5979 gwop->op_ppaddr = PL_ppaddr[type];
5980 gwop->op_first = listkids(o);
5981 gwop->op_flags |= OPf_KIDS;
5982 gwop->op_private = 1;
5983 gwop->op_other = LINKLIST(kid);
5984 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5985 kid->op_next = (OP*)gwop;
5987 kid = cLISTOPo->op_first->op_sibling;
5988 if (!kid || !kid->op_sibling)
5989 return too_few_arguments(o,PL_op_desc[o->op_type]);
5990 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5991 mod(kid, OP_GREPSTART);
5997 Perl_ck_index(pTHX_ OP *o)
5999 if (o->op_flags & OPf_KIDS) {
6000 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6002 kid = kid->op_sibling; /* get past "big" */
6003 if (kid && kid->op_type == OP_CONST)
6004 fbm_compile(((SVOP*)kid)->op_sv, 0);
6010 Perl_ck_lengthconst(pTHX_ OP *o)
6012 /* XXX length optimization goes here */
6017 Perl_ck_lfun(pTHX_ OP *o)
6019 OPCODE type = o->op_type;
6020 return modkids(ck_fun(o), type);
6024 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6026 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6027 switch (cUNOPo->op_first->op_type) {
6029 /* This is needed for
6030 if (defined %stash::)
6031 to work. Do not break Tk.
6033 break; /* Globals via GV can be undef */
6035 case OP_AASSIGN: /* Is this a good idea? */
6036 Perl_warner(aTHX_ WARN_DEPRECATED,
6037 "defined(@array) is deprecated");
6038 Perl_warner(aTHX_ WARN_DEPRECATED,
6039 "\t(Maybe you should just omit the defined()?)\n");
6042 /* This is needed for
6043 if (defined %stash::)
6044 to work. Do not break Tk.
6046 break; /* Globals via GV can be undef */
6048 Perl_warner(aTHX_ WARN_DEPRECATED,
6049 "defined(%%hash) is deprecated");
6050 Perl_warner(aTHX_ WARN_DEPRECATED,
6051 "\t(Maybe you should just omit the defined()?)\n");
6062 Perl_ck_rfun(pTHX_ OP *o)
6064 OPCODE type = o->op_type;
6065 return refkids(ck_fun(o), type);
6069 Perl_ck_listiob(pTHX_ OP *o)
6073 kid = cLISTOPo->op_first;
6076 kid = cLISTOPo->op_first;
6078 if (kid->op_type == OP_PUSHMARK)
6079 kid = kid->op_sibling;
6080 if (kid && o->op_flags & OPf_STACKED)
6081 kid = kid->op_sibling;
6082 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6083 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6084 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6085 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6086 cLISTOPo->op_first->op_sibling = kid;
6087 cLISTOPo->op_last = kid;
6088 kid = kid->op_sibling;
6093 append_elem(o->op_type, o, newDEFSVOP());
6099 Perl_ck_sassign(pTHX_ OP *o)
6101 OP *kid = cLISTOPo->op_first;
6102 /* has a disposable target? */
6103 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6104 && !(kid->op_flags & OPf_STACKED)
6105 /* Cannot steal the second time! */
6106 && !(kid->op_private & OPpTARGET_MY))
6108 OP *kkid = kid->op_sibling;
6110 /* Can just relocate the target. */
6111 if (kkid && kkid->op_type == OP_PADSV
6112 && !(kkid->op_private & OPpLVAL_INTRO))
6114 kid->op_targ = kkid->op_targ;
6116 /* Now we do not need PADSV and SASSIGN. */
6117 kid->op_sibling = o->op_sibling; /* NULL */
6118 cLISTOPo->op_first = NULL;
6121 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6129 Perl_ck_match(pTHX_ OP *o)
6131 o->op_private |= OPpRUNTIME;
6136 Perl_ck_method(pTHX_ OP *o)
6138 OP *kid = cUNOPo->op_first;
6139 if (kid->op_type == OP_CONST) {
6140 SV* sv = kSVOP->op_sv;
6141 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6143 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6144 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6147 kSVOP->op_sv = Nullsv;
6149 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6158 Perl_ck_null(pTHX_ OP *o)
6164 Perl_ck_open(pTHX_ OP *o)
6166 HV *table = GvHV(PL_hintgv);
6170 svp = hv_fetch(table, "open_IN", 7, FALSE);
6172 mode = mode_from_discipline(*svp);
6173 if (mode & O_BINARY)
6174 o->op_private |= OPpOPEN_IN_RAW;
6175 else if (mode & O_TEXT)
6176 o->op_private |= OPpOPEN_IN_CRLF;
6179 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6181 mode = mode_from_discipline(*svp);
6182 if (mode & O_BINARY)
6183 o->op_private |= OPpOPEN_OUT_RAW;
6184 else if (mode & O_TEXT)
6185 o->op_private |= OPpOPEN_OUT_CRLF;
6188 if (o->op_type == OP_BACKTICK)
6194 Perl_ck_repeat(pTHX_ OP *o)
6196 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6197 o->op_private |= OPpREPEAT_DOLIST;
6198 cBINOPo->op_first = force_list(cBINOPo->op_first);
6206 Perl_ck_require(pTHX_ OP *o)
6210 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6211 SVOP *kid = (SVOP*)cUNOPo->op_first;
6213 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6215 for (s = SvPVX(kid->op_sv); *s; s++) {
6216 if (*s == ':' && s[1] == ':') {
6218 Move(s+2, s+1, strlen(s+2)+1, char);
6219 --SvCUR(kid->op_sv);
6222 if (SvREADONLY(kid->op_sv)) {
6223 SvREADONLY_off(kid->op_sv);
6224 sv_catpvn(kid->op_sv, ".pm", 3);
6225 SvREADONLY_on(kid->op_sv);
6228 sv_catpvn(kid->op_sv, ".pm", 3);
6232 /* handle override, if any */
6233 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6234 if (!(gv && GvIMPORTED_CV(gv)))
6235 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6237 if (gv && GvIMPORTED_CV(gv)) {
6238 OP *kid = cUNOPo->op_first;
6239 cUNOPo->op_first = 0;
6241 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6242 append_elem(OP_LIST, kid,
6243 scalar(newUNOP(OP_RV2CV, 0,
6252 Perl_ck_return(pTHX_ OP *o)
6255 if (CvLVALUE(PL_compcv)) {
6256 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6257 mod(kid, OP_LEAVESUBLV);
6264 Perl_ck_retarget(pTHX_ OP *o)
6266 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6273 Perl_ck_select(pTHX_ OP *o)
6276 if (o->op_flags & OPf_KIDS) {
6277 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6278 if (kid && kid->op_sibling) {
6279 o->op_type = OP_SSELECT;
6280 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6282 return fold_constants(o);
6286 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6287 if (kid && kid->op_type == OP_RV2GV)
6288 kid->op_private &= ~HINT_STRICT_REFS;
6293 Perl_ck_shift(pTHX_ OP *o)
6295 I32 type = o->op_type;
6297 if (!(o->op_flags & OPf_KIDS)) {
6302 if (!CvUNIQUE(PL_compcv)) {
6303 argop = newOP(OP_PADAV, OPf_REF);
6304 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6307 argop = newUNOP(OP_RV2AV, 0,
6308 scalar(newGVOP(OP_GV, 0,
6309 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6312 argop = newUNOP(OP_RV2AV, 0,
6313 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6314 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6315 #endif /* USE_THREADS */
6316 return newUNOP(type, 0, scalar(argop));
6318 return scalar(modkids(ck_fun(o), type));
6322 Perl_ck_sort(pTHX_ OP *o)
6326 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6328 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6329 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6331 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6333 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6335 if (kid->op_type == OP_SCOPE) {
6339 else if (kid->op_type == OP_LEAVE) {
6340 if (o->op_type == OP_SORT) {
6341 op_null(kid); /* wipe out leave */
6344 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6345 if (k->op_next == kid)
6347 /* don't descend into loops */
6348 else if (k->op_type == OP_ENTERLOOP
6349 || k->op_type == OP_ENTERITER)
6351 k = cLOOPx(k)->op_lastop;
6356 kid->op_next = 0; /* just disconnect the leave */
6357 k = kLISTOP->op_first;
6362 if (o->op_type == OP_SORT) {
6363 /* provide scalar context for comparison function/block */
6369 o->op_flags |= OPf_SPECIAL;
6371 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6374 firstkid = firstkid->op_sibling;
6377 /* provide list context for arguments */
6378 if (o->op_type == OP_SORT)
6385 S_simplify_sort(pTHX_ OP *o)
6387 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6391 if (!(o->op_flags & OPf_STACKED))
6393 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6394 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6395 kid = kUNOP->op_first; /* get past null */
6396 if (kid->op_type != OP_SCOPE)
6398 kid = kLISTOP->op_last; /* get past scope */
6399 switch(kid->op_type) {
6407 k = kid; /* remember this node*/
6408 if (kBINOP->op_first->op_type != OP_RV2SV)
6410 kid = kBINOP->op_first; /* get past cmp */
6411 if (kUNOP->op_first->op_type != OP_GV)
6413 kid = kUNOP->op_first; /* get past rv2sv */
6415 if (GvSTASH(gv) != PL_curstash)
6417 if (strEQ(GvNAME(gv), "a"))
6419 else if (strEQ(GvNAME(gv), "b"))
6423 kid = k; /* back to cmp */
6424 if (kBINOP->op_last->op_type != OP_RV2SV)
6426 kid = kBINOP->op_last; /* down to 2nd arg */
6427 if (kUNOP->op_first->op_type != OP_GV)
6429 kid = kUNOP->op_first; /* get past rv2sv */
6431 if (GvSTASH(gv) != PL_curstash
6433 ? strNE(GvNAME(gv), "a")
6434 : strNE(GvNAME(gv), "b")))
6436 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6438 o->op_private |= OPpSORT_REVERSE;
6439 if (k->op_type == OP_NCMP)
6440 o->op_private |= OPpSORT_NUMERIC;
6441 if (k->op_type == OP_I_NCMP)
6442 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6443 kid = cLISTOPo->op_first->op_sibling;
6444 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6445 op_free(kid); /* then delete it */
6449 Perl_ck_split(pTHX_ OP *o)
6453 if (o->op_flags & OPf_STACKED)
6454 return no_fh_allowed(o);
6456 kid = cLISTOPo->op_first;
6457 if (kid->op_type != OP_NULL)
6458 Perl_croak(aTHX_ "panic: ck_split");
6459 kid = kid->op_sibling;
6460 op_free(cLISTOPo->op_first);
6461 cLISTOPo->op_first = kid;
6463 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6464 cLISTOPo->op_last = kid; /* There was only one element previously */
6467 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6468 OP *sibl = kid->op_sibling;
6469 kid->op_sibling = 0;
6470 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6471 if (cLISTOPo->op_first == cLISTOPo->op_last)
6472 cLISTOPo->op_last = kid;
6473 cLISTOPo->op_first = kid;
6474 kid->op_sibling = sibl;
6477 kid->op_type = OP_PUSHRE;
6478 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6481 if (!kid->op_sibling)
6482 append_elem(OP_SPLIT, o, newDEFSVOP());
6484 kid = kid->op_sibling;
6487 if (!kid->op_sibling)
6488 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6490 kid = kid->op_sibling;
6493 if (kid->op_sibling)
6494 return too_many_arguments(o,PL_op_desc[o->op_type]);
6500 Perl_ck_join(pTHX_ OP *o)
6502 if (ckWARN(WARN_SYNTAX)) {
6503 OP *kid = cLISTOPo->op_first->op_sibling;
6504 if (kid && kid->op_type == OP_MATCH) {
6505 char *pmstr = "STRING";
6506 if (PM_GETRE(kPMOP))
6507 pmstr = PM_GETRE(kPMOP)->precomp;
6508 Perl_warner(aTHX_ WARN_SYNTAX,
6509 "/%s/ should probably be written as \"%s\"",
6517 Perl_ck_subr(pTHX_ OP *o)
6519 OP *prev = ((cUNOPo->op_first->op_sibling)
6520 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6521 OP *o2 = prev->op_sibling;
6530 o->op_private |= OPpENTERSUB_HASTARG;
6531 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6532 if (cvop->op_type == OP_RV2CV) {
6534 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6535 op_null(cvop); /* disable rv2cv */
6536 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6537 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6538 GV *gv = cGVOPx_gv(tmpop);
6541 tmpop->op_private |= OPpEARLY_CV;
6542 else if (SvPOK(cv)) {
6543 namegv = CvANON(cv) ? gv : CvGV(cv);
6544 proto = SvPV((SV*)cv, n_a);
6548 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6549 if (o2->op_type == OP_CONST)
6550 o2->op_private &= ~OPpCONST_STRICT;
6551 else if (o2->op_type == OP_LIST) {
6552 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6553 if (o && o->op_type == OP_CONST)
6554 o->op_private &= ~OPpCONST_STRICT;
6557 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6558 if (PERLDB_SUB && PL_curstash != PL_debstash)
6559 o->op_private |= OPpENTERSUB_DB;
6560 while (o2 != cvop) {
6564 return too_many_arguments(o, gv_ename(namegv));
6582 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6584 arg == 1 ? "block or sub {}" : "sub {}",
6585 gv_ename(namegv), o2);
6588 /* '*' allows any scalar type, including bareword */
6591 if (o2->op_type == OP_RV2GV)
6592 goto wrapref; /* autoconvert GLOB -> GLOBref */
6593 else if (o2->op_type == OP_CONST)
6594 o2->op_private &= ~OPpCONST_STRICT;
6595 else if (o2->op_type == OP_ENTERSUB) {
6596 /* accidental subroutine, revert to bareword */
6597 OP *gvop = ((UNOP*)o2)->op_first;
6598 if (gvop && gvop->op_type == OP_NULL) {
6599 gvop = ((UNOP*)gvop)->op_first;
6601 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6604 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6605 (gvop = ((UNOP*)gvop)->op_first) &&
6606 gvop->op_type == OP_GV)
6608 GV *gv = cGVOPx_gv(gvop);
6609 OP *sibling = o2->op_sibling;
6610 SV *n = newSVpvn("",0);
6612 gv_fullname3(n, gv, "");
6613 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6614 sv_chop(n, SvPVX(n)+6);
6615 o2 = newSVOP(OP_CONST, 0, n);
6616 prev->op_sibling = o2;
6617 o2->op_sibling = sibling;
6629 if (o2->op_type != OP_RV2GV)
6630 bad_type(arg, "symbol", gv_ename(namegv), o2);
6633 if (o2->op_type != OP_ENTERSUB)
6634 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6637 if (o2->op_type != OP_RV2SV
6638 && o2->op_type != OP_PADSV
6639 && o2->op_type != OP_HELEM
6640 && o2->op_type != OP_AELEM
6641 && o2->op_type != OP_THREADSV)
6643 bad_type(arg, "scalar", gv_ename(namegv), o2);
6647 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6648 bad_type(arg, "array", gv_ename(namegv), o2);
6651 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6652 bad_type(arg, "hash", gv_ename(namegv), o2);
6656 OP* sib = kid->op_sibling;
6657 kid->op_sibling = 0;
6658 o2 = newUNOP(OP_REFGEN, 0, kid);
6659 o2->op_sibling = sib;
6660 prev->op_sibling = o2;
6671 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6672 gv_ename(namegv), SvPV((SV*)cv, n_a));
6677 mod(o2, OP_ENTERSUB);
6679 o2 = o2->op_sibling;
6681 if (proto && !optional &&
6682 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6683 return too_few_arguments(o, gv_ename(namegv));
6688 Perl_ck_svconst(pTHX_ OP *o)
6690 SvREADONLY_on(cSVOPo->op_sv);
6695 Perl_ck_trunc(pTHX_ OP *o)
6697 if (o->op_flags & OPf_KIDS) {
6698 SVOP *kid = (SVOP*)cUNOPo->op_first;
6700 if (kid->op_type == OP_NULL)
6701 kid = (SVOP*)kid->op_sibling;
6702 if (kid && kid->op_type == OP_CONST &&
6703 (kid->op_private & OPpCONST_BARE))
6705 o->op_flags |= OPf_SPECIAL;
6706 kid->op_private &= ~OPpCONST_STRICT;
6713 Perl_ck_substr(pTHX_ OP *o)
6716 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6717 OP *kid = cLISTOPo->op_first;
6719 if (kid->op_type == OP_NULL)
6720 kid = kid->op_sibling;
6722 kid->op_flags |= OPf_MOD;
6728 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6731 Perl_peep(pTHX_ register OP *o)
6733 register OP* oldop = 0;
6736 if (!o || o->op_seq)
6740 SAVEVPTR(PL_curcop);
6741 for (; o; o = o->op_next) {
6747 switch (o->op_type) {
6751 PL_curcop = ((COP*)o); /* for warnings */
6752 o->op_seq = PL_op_seqmax++;
6756 if (cSVOPo->op_private & OPpCONST_STRICT)
6757 no_bareword_allowed(o);
6759 /* Relocate sv to the pad for thread safety.
6760 * Despite being a "constant", the SV is written to,
6761 * for reference counts, sv_upgrade() etc. */
6763 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6764 if (SvPADTMP(cSVOPo->op_sv)) {
6765 /* If op_sv is already a PADTMP then it is being used by
6766 * some pad, so make a copy. */
6767 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6768 SvREADONLY_on(PL_curpad[ix]);
6769 SvREFCNT_dec(cSVOPo->op_sv);
6772 SvREFCNT_dec(PL_curpad[ix]);
6773 SvPADTMP_on(cSVOPo->op_sv);
6774 PL_curpad[ix] = cSVOPo->op_sv;
6775 /* XXX I don't know how this isn't readonly already. */
6776 SvREADONLY_on(PL_curpad[ix]);
6778 cSVOPo->op_sv = Nullsv;
6782 o->op_seq = PL_op_seqmax++;
6786 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6787 if (o->op_next->op_private & OPpTARGET_MY) {
6788 if (o->op_flags & OPf_STACKED) /* chained concats */
6789 goto ignore_optimization;
6791 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6792 o->op_targ = o->op_next->op_targ;
6793 o->op_next->op_targ = 0;
6794 o->op_private |= OPpTARGET_MY;
6797 op_null(o->op_next);
6799 ignore_optimization:
6800 o->op_seq = PL_op_seqmax++;
6803 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6804 o->op_seq = PL_op_seqmax++;
6805 break; /* Scalar stub must produce undef. List stub is noop */
6809 if (o->op_targ == OP_NEXTSTATE
6810 || o->op_targ == OP_DBSTATE
6811 || o->op_targ == OP_SETSTATE)
6813 PL_curcop = ((COP*)o);
6815 /* XXX: We avoid setting op_seq here to prevent later calls
6816 to peep() from mistakenly concluding that optimisation
6817 has already occurred. This doesn't fix the real problem,
6818 though (See 20010220.007). AMS 20010719 */
6819 if (oldop && o->op_next) {
6820 oldop->op_next = o->op_next;
6828 if (oldop && o->op_next) {
6829 oldop->op_next = o->op_next;
6832 o->op_seq = PL_op_seqmax++;
6836 if (o->op_next->op_type == OP_RV2SV) {
6837 if (!(o->op_next->op_private & OPpDEREF)) {
6838 op_null(o->op_next);
6839 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6841 o->op_next = o->op_next->op_next;
6842 o->op_type = OP_GVSV;
6843 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6846 else if (o->op_next->op_type == OP_RV2AV) {
6847 OP* pop = o->op_next->op_next;
6849 if (pop->op_type == OP_CONST &&
6850 (PL_op = pop->op_next) &&
6851 pop->op_next->op_type == OP_AELEM &&
6852 !(pop->op_next->op_private &
6853 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6854 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6859 op_null(o->op_next);
6860 op_null(pop->op_next);
6862 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6863 o->op_next = pop->op_next->op_next;
6864 o->op_type = OP_AELEMFAST;
6865 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6866 o->op_private = (U8)i;
6871 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6873 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6874 /* XXX could check prototype here instead of just carping */
6875 SV *sv = sv_newmortal();
6876 gv_efullname3(sv, gv, Nullch);
6877 Perl_warner(aTHX_ WARN_PROTOTYPE,
6878 "%s() called too early to check prototype",
6882 else if (o->op_next->op_type == OP_READLINE
6883 && o->op_next->op_next->op_type == OP_CONCAT
6884 && (o->op_next->op_next->op_flags & OPf_STACKED))
6886 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010811 */
6887 o->op_next->op_type = OP_RCATLINE;
6888 o->op_next->op_flags |= OPf_STACKED;
6889 op_null(o->op_next->op_next);
6892 o->op_seq = PL_op_seqmax++;
6903 o->op_seq = PL_op_seqmax++;
6904 while (cLOGOP->op_other->op_type == OP_NULL)
6905 cLOGOP->op_other = cLOGOP->op_other->op_next;
6906 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6911 o->op_seq = PL_op_seqmax++;
6912 while (cLOOP->op_redoop->op_type == OP_NULL)
6913 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6914 peep(cLOOP->op_redoop);
6915 while (cLOOP->op_nextop->op_type == OP_NULL)
6916 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6917 peep(cLOOP->op_nextop);
6918 while (cLOOP->op_lastop->op_type == OP_NULL)
6919 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6920 peep(cLOOP->op_lastop);
6926 o->op_seq = PL_op_seqmax++;
6927 while (cPMOP->op_pmreplstart &&
6928 cPMOP->op_pmreplstart->op_type == OP_NULL)
6929 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6930 peep(cPMOP->op_pmreplstart);
6934 o->op_seq = PL_op_seqmax++;
6935 if (ckWARN(WARN_SYNTAX) && o->op_next
6936 && o->op_next->op_type == OP_NEXTSTATE) {
6937 if (o->op_next->op_sibling &&
6938 o->op_next->op_sibling->op_type != OP_EXIT &&
6939 o->op_next->op_sibling->op_type != OP_WARN &&
6940 o->op_next->op_sibling->op_type != OP_DIE) {
6941 line_t oldline = CopLINE(PL_curcop);
6943 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6944 Perl_warner(aTHX_ WARN_EXEC,
6945 "Statement unlikely to be reached");
6946 Perl_warner(aTHX_ WARN_EXEC,
6947 "\t(Maybe you meant system() when you said exec()?)\n");
6948 CopLINE_set(PL_curcop, oldline);
6957 SV **svp, **indsvp, *sv;
6962 o->op_seq = PL_op_seqmax++;
6964 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6967 /* Make the CONST have a shared SV */
6968 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6969 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6970 key = SvPV(sv, keylen);
6971 lexname = newSVpvn_share(key,
6972 SvUTF8(sv) ? -(I32)keylen : keylen,
6978 if ((o->op_private & (OPpLVAL_INTRO)))
6981 rop = (UNOP*)((BINOP*)o)->op_first;
6982 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6984 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6985 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6987 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6988 if (!fields || !GvHV(*fields))
6990 key = SvPV(*svp, keylen);
6991 indsvp = hv_fetch(GvHV(*fields), key,
6992 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6994 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6995 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6997 ind = SvIV(*indsvp);
6999 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7000 rop->op_type = OP_RV2AV;
7001 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7002 o->op_type = OP_AELEM;
7003 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7005 if (SvREADONLY(*svp))
7007 SvFLAGS(sv) |= (SvFLAGS(*svp)
7008 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7018 SV **svp, **indsvp, *sv;
7022 SVOP *first_key_op, *key_op;
7024 o->op_seq = PL_op_seqmax++;
7025 if ((o->op_private & (OPpLVAL_INTRO))
7026 /* I bet there's always a pushmark... */
7027 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7028 /* hmmm, no optimization if list contains only one key. */
7030 rop = (UNOP*)((LISTOP*)o)->op_last;
7031 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7033 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7034 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7036 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7037 if (!fields || !GvHV(*fields))
7039 /* Again guessing that the pushmark can be jumped over.... */
7040 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7041 ->op_first->op_sibling;
7042 /* Check that the key list contains only constants. */
7043 for (key_op = first_key_op; key_op;
7044 key_op = (SVOP*)key_op->op_sibling)
7045 if (key_op->op_type != OP_CONST)
7049 rop->op_type = OP_RV2AV;
7050 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7051 o->op_type = OP_ASLICE;
7052 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7053 for (key_op = first_key_op; key_op;
7054 key_op = (SVOP*)key_op->op_sibling) {
7055 svp = cSVOPx_svp(key_op);
7056 key = SvPV(*svp, keylen);
7057 indsvp = hv_fetch(GvHV(*fields), key,
7058 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7060 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7061 "in variable %s of type %s",
7062 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7064 ind = SvIV(*indsvp);
7066 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7068 if (SvREADONLY(*svp))
7070 SvFLAGS(sv) |= (SvFLAGS(*svp)
7071 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7079 o->op_seq = PL_op_seqmax++;
7089 /* Efficient sub that returns a constant scalar value. */
7091 const_sv_xsub(pTHXo_ CV* cv)
7096 Perl_croak(aTHX_ "usage: %s::%s()",
7097 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7101 ST(0) = (SV*)XSANY.any_ptr;