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)(o)
25 /* #define PL_OP_SLAB_ALLOC */
27 #ifdef PL_OP_SLAB_ALLOC
28 #define SLAB_SIZE 8192
29 static char *PL_OpPtr = NULL;
30 static int PL_OpSpace = 0;
31 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
32 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
34 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
40 Newz(m,PL_OpPtr,SLAB_SIZE,char);
41 PL_OpSpace = SLAB_SIZE - sz;
42 return PL_OpPtr += PL_OpSpace;
46 #define NewOp(m, var, c, type) Newz(m, var, c, type)
49 * In the following definition, the ", Nullop" is just to make the compiler
50 * think the expression is of the right type: croak actually does a Siglongjmp.
52 #define CHECKOP(type,o) \
53 ((PL_op_mask && PL_op_mask[type]) \
54 ? ( op_free((OP*)o), \
55 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
57 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
59 #define PAD_MAX 999999999
60 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
63 S_gv_ename(pTHX_ GV *gv)
66 SV* tmpsv = sv_newmortal();
67 gv_efullname3(tmpsv, gv, Nullch);
68 return SvPV(tmpsv,n_a);
72 S_no_fh_allowed(pTHX_ OP *o)
74 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
75 PL_op_desc[o->op_type]));
80 S_too_few_arguments(pTHX_ OP *o, char *name)
82 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
87 S_too_many_arguments(pTHX_ OP *o, char *name)
89 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
94 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
96 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
97 (int)n, name, t, PL_op_desc[kid->op_type]));
101 S_no_bareword_allowed(pTHX_ OP *o)
103 qerror(Perl_mess(aTHX_
104 "Bareword \"%s\" not allowed while \"strict subs\" in use",
105 SvPV_nolen(cSVOPo_sv)));
108 /* "register" allocation */
111 Perl_pad_allocmy(pTHX_ char *name)
116 if (!(PL_in_my == KEY_our ||
118 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
119 (name[1] == '_' && (int)strlen(name) > 2)))
121 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
122 /* 1999-02-27 mjd@plover.com */
124 p = strchr(name, '\0');
125 /* The next block assumes the buffer is at least 205 chars
126 long. At present, it's always at least 256 chars. */
128 strcpy(name+200, "...");
134 /* Move everything else down one character */
135 for (; p-name > 2; p--)
137 name[2] = toCTRL(name[1]);
140 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
142 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
143 SV **svp = AvARRAY(PL_comppad_name);
144 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
145 PADOFFSET top = AvFILLp(PL_comppad_name);
146 for (off = top; off > PL_comppad_name_floor; off--) {
148 && sv != &PL_sv_undef
149 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
150 && (PL_in_my != KEY_our
151 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
152 && strEQ(name, SvPVX(sv)))
154 Perl_warner(aTHX_ WARN_MISC,
155 "\"%s\" variable %s masks earlier declaration in same %s",
156 (PL_in_my == KEY_our ? "our" : "my"),
158 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
163 if (PL_in_my == KEY_our) {
166 && sv != &PL_sv_undef
167 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
168 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
169 && strEQ(name, SvPVX(sv)))
171 Perl_warner(aTHX_ WARN_MISC,
172 "\"our\" variable %s redeclared", name);
173 Perl_warner(aTHX_ WARN_MISC,
174 "\t(Did you mean \"local\" instead of \"our\"?)\n");
177 } while ( off-- > 0 );
180 off = pad_alloc(OP_PADSV, SVs_PADMY);
182 sv_upgrade(sv, SVt_PVNV);
184 if (PL_in_my_stash) {
186 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
187 name, PL_in_my == KEY_our ? "our" : "my"));
188 SvFLAGS(sv) |= SVpad_TYPED;
189 (void)SvUPGRADE(sv, SVt_PVMG);
190 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
192 if (PL_in_my == KEY_our) {
193 (void)SvUPGRADE(sv, SVt_PVGV);
194 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
195 SvFLAGS(sv) |= SVpad_OUR;
197 av_store(PL_comppad_name, off, sv);
198 SvNVX(sv) = (NV)PAD_MAX;
199 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
200 if (!PL_min_intro_pending)
201 PL_min_intro_pending = off;
202 PL_max_intro_pending = off;
204 av_store(PL_comppad, off, (SV*)newAV());
205 else if (*name == '%')
206 av_store(PL_comppad, off, (SV*)newHV());
207 SvPADMY_on(PL_curpad[off]);
212 S_pad_addlex(pTHX_ SV *proto_namesv)
214 SV *namesv = NEWSV(1103,0);
215 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
216 sv_upgrade(namesv, SVt_PVNV);
217 sv_setpv(namesv, SvPVX(proto_namesv));
218 av_store(PL_comppad_name, newoff, namesv);
219 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
220 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
221 SvFAKE_on(namesv); /* A ref, not a real var */
222 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
223 SvFLAGS(namesv) |= SVpad_OUR;
224 (void)SvUPGRADE(namesv, SVt_PVGV);
225 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
227 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
228 SvFLAGS(namesv) |= SVpad_TYPED;
229 (void)SvUPGRADE(namesv, SVt_PVMG);
230 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
235 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
238 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
239 I32 cx_ix, I32 saweval, U32 flags)
245 register PERL_CONTEXT *cx;
247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
252 if (!svp || *svp == &PL_sv_undef)
255 svp = AvARRAY(curname);
256 for (off = AvFILLp(curname); off > 0; off--) {
257 if ((sv = svp[off]) &&
258 sv != &PL_sv_undef &&
260 seq > I_32(SvNVX(sv)) &&
261 strEQ(SvPVX(sv), name))
272 return 0; /* don't clone from inactive stack frame */
276 oldpad = (AV*)AvARRAY(curlist)[depth];
277 oldsv = *av_fetch(oldpad, off, TRUE);
278 if (!newoff) { /* Not a mere clone operation. */
279 newoff = pad_addlex(sv);
280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
281 /* "It's closures all the way down." */
282 CvCLONE_on(PL_compcv);
284 if (CvANON(PL_compcv))
285 oldsv = Nullsv; /* no need to keep ref */
290 bcv && bcv != cv && !CvCLONE(bcv);
291 bcv = CvOUTSIDE(bcv))
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
314 Perl_warner(aTHX_ WARN_CLOSURE,
315 "Variable \"%s\" may be unavailable",
323 else if (!CvUNIQUE(PL_compcv)) {
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
327 Perl_warner(aTHX_ WARN_CLOSURE,
328 "Variable \"%s\" will not stay shared", name);
332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
338 if (flags & FINDLEX_NOSEARCH)
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
346 for (i = cx_ix; i >= 0; i--) {
348 switch (CxTYPE(cx)) {
350 if (i == 0 && saweval) {
351 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
355 switch (cx->blk_eval.old_op_type) {
357 if (CxREALEVAL(cx)) {
360 seq = cxstack[i].blk_oldcop->cop_seq;
361 startcv = cxstack[i].blk_eval.cv;
362 if (startcv && CvOUTSIDE(startcv)) {
363 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
365 if (off) /* continue looking if not found here */
372 /* require/do must have their own scope */
381 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
382 saweval = i; /* so we know where we were called from */
383 seq = cxstack[i].blk_oldcop->cop_seq;
386 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
394 Perl_pad_findmy(pTHX_ char *name)
399 SV **svp = AvARRAY(PL_comppad_name);
400 U32 seq = PL_cop_seqmax;
406 * Special case to get lexical (and hence per-thread) @_.
407 * XXX I need to find out how to tell at parse-time whether use
408 * of @_ should refer to a lexical (from a sub) or defgv (global
409 * scope and maybe weird sub-ish things like formats). See
410 * startsub in perly.y. It's possible that @_ could be lexical
411 * (at least from subs) even in non-threaded perl.
413 if (strEQ(name, "@_"))
414 return 0; /* success. (NOT_IN_PAD indicates failure) */
415 #endif /* USE_THREADS */
417 /* The one we're looking for is probably just before comppad_name_fill. */
418 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
419 if ((sv = svp[off]) &&
420 sv != &PL_sv_undef &&
423 seq > I_32(SvNVX(sv)))) &&
424 strEQ(SvPVX(sv), name))
426 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
427 return (PADOFFSET)off;
428 pendoff = off; /* this pending def. will override import */
432 outside = CvOUTSIDE(PL_compcv);
434 /* Check if if we're compiling an eval'', and adjust seq to be the
435 * eval's seq number. This depends on eval'' having a non-null
436 * CvOUTSIDE() while it is being compiled. The eval'' itself is
437 * identified by CvEVAL being true and CvGV being null. */
438 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
439 cx = &cxstack[cxstack_ix];
441 seq = cx->blk_oldcop->cop_seq;
444 /* See if it's in a nested scope */
445 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
447 /* If there is a pending local definition, this new alias must die */
449 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
450 return off; /* pad_findlex returns 0 for failure...*/
452 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
456 Perl_pad_leavemy(pTHX_ I32 fill)
459 SV **svp = AvARRAY(PL_comppad_name);
461 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
462 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
463 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
464 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
467 /* "Deintroduce" my variables that are leaving with this scope. */
468 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
469 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
470 SvIVX(sv) = PL_cop_seqmax;
475 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
480 if (AvARRAY(PL_comppad) != PL_curpad)
481 Perl_croak(aTHX_ "panic: pad_alloc");
482 if (PL_pad_reset_pending)
484 if (tmptype & SVs_PADMY) {
486 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
487 } while (SvPADBUSY(sv)); /* need a fresh one */
488 retval = AvFILLp(PL_comppad);
491 SV **names = AvARRAY(PL_comppad_name);
492 SSize_t names_fill = AvFILLp(PL_comppad_name);
495 * "foreach" index vars temporarily become aliases to non-"my"
496 * values. Thus we must skip, not just pad values that are
497 * marked as current pad values, but also those with names.
499 if (++PL_padix <= names_fill &&
500 (sv = names[PL_padix]) && sv != &PL_sv_undef)
502 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
503 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
504 !IS_PADGV(sv) && !IS_PADCONST(sv))
509 SvFLAGS(sv) |= tmptype;
510 PL_curpad = AvARRAY(PL_comppad);
512 DEBUG_X(PerlIO_printf(Perl_debug_log,
513 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
514 PTR2UV(thr), PTR2UV(PL_curpad),
515 (long) retval, PL_op_name[optype]));
517 DEBUG_X(PerlIO_printf(Perl_debug_log,
518 "Pad 0x%"UVxf" alloc %ld for %s\n",
520 (long) retval, PL_op_name[optype]));
521 #endif /* USE_THREADS */
522 return (PADOFFSET)retval;
526 Perl_pad_sv(pTHX_ PADOFFSET po)
529 DEBUG_X(PerlIO_printf(Perl_debug_log,
530 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
531 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
534 Perl_croak(aTHX_ "panic: pad_sv po");
535 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
536 PTR2UV(PL_curpad), (IV)po));
537 #endif /* USE_THREADS */
538 return PL_curpad[po]; /* eventually we'll turn this into a macro */
542 Perl_pad_free(pTHX_ PADOFFSET po)
546 if (AvARRAY(PL_comppad) != PL_curpad)
547 Perl_croak(aTHX_ "panic: pad_free curpad");
549 Perl_croak(aTHX_ "panic: pad_free po");
551 DEBUG_X(PerlIO_printf(Perl_debug_log,
552 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
553 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
555 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
556 PTR2UV(PL_curpad), (IV)po));
557 #endif /* USE_THREADS */
558 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
559 SvPADTMP_off(PL_curpad[po]);
561 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
564 if ((I32)po < PL_padix)
569 Perl_pad_swipe(pTHX_ PADOFFSET po)
571 if (AvARRAY(PL_comppad) != PL_curpad)
572 Perl_croak(aTHX_ "panic: pad_swipe curpad");
574 Perl_croak(aTHX_ "panic: pad_swipe po");
576 DEBUG_X(PerlIO_printf(Perl_debug_log,
577 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
580 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
581 PTR2UV(PL_curpad), (IV)po));
582 #endif /* USE_THREADS */
583 SvPADTMP_off(PL_curpad[po]);
584 PL_curpad[po] = NEWSV(1107,0);
585 SvPADTMP_on(PL_curpad[po]);
586 if ((I32)po < PL_padix)
590 /* XXX pad_reset() is currently disabled because it results in serious bugs.
591 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
592 * on the stack by OPs that use them, there are several ways to get an alias
593 * to a shared TARG. Such an alias will change randomly and unpredictably.
594 * We avoid doing this until we can think of a Better Way.
599 #ifdef USE_BROKEN_PAD_RESET
602 if (AvARRAY(PL_comppad) != PL_curpad)
603 Perl_croak(aTHX_ "panic: pad_reset curpad");
605 DEBUG_X(PerlIO_printf(Perl_debug_log,
606 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
607 PTR2UV(thr), PTR2UV(PL_curpad)));
609 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
611 #endif /* USE_THREADS */
612 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
613 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
614 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
615 SvPADTMP_off(PL_curpad[po]);
617 PL_padix = PL_padix_floor;
620 PL_pad_reset_pending = FALSE;
624 /* find_threadsv is not reentrant */
626 Perl_find_threadsv(pTHX_ const char *name)
631 /* We currently only handle names of a single character */
632 p = strchr(PL_threadsv_names, *name);
635 key = p - PL_threadsv_names;
636 MUTEX_LOCK(&thr->mutex);
637 svp = av_fetch(thr->threadsv, key, FALSE);
639 MUTEX_UNLOCK(&thr->mutex);
641 SV *sv = NEWSV(0, 0);
642 av_store(thr->threadsv, key, sv);
643 thr->threadsvp = AvARRAY(thr->threadsv);
644 MUTEX_UNLOCK(&thr->mutex);
646 * Some magic variables used to be automagically initialised
647 * in gv_fetchpv. Those which are now per-thread magicals get
648 * initialised here instead.
654 sv_setpv(sv, "\034");
655 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
660 PL_sawampersand = TRUE;
674 /* XXX %! tied to Errno.pm needs to be added here.
675 * See gv_fetchpv(). */
679 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
681 DEBUG_S(PerlIO_printf(Perl_error_log,
682 "find_threadsv: new SV %p for $%s%c\n",
683 sv, (*name < 32) ? "^" : "",
684 (*name < 32) ? toCTRL(*name) : *name));
688 #endif /* USE_THREADS */
693 Perl_op_free(pTHX_ OP *o)
695 register OP *kid, *nextkid;
698 if (!o || o->op_seq == (U16)-1)
701 if (o->op_private & OPpREFCOUNTED) {
702 switch (o->op_type) {
710 if (OpREFCNT_dec(o)) {
721 if (o->op_flags & OPf_KIDS) {
722 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
723 nextkid = kid->op_sibling; /* Get before next freeing kid */
731 /* COP* is not cleared by op_clear() so that we may track line
732 * numbers etc even after null() */
733 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
738 #ifdef PL_OP_SLAB_ALLOC
739 if ((char *) o == PL_OpPtr)
748 Perl_op_clear(pTHX_ OP *o)
750 switch (o->op_type) {
751 case OP_NULL: /* Was holding old type, if any. */
752 case OP_ENTEREVAL: /* Was holding hints. */
754 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
760 if (!(o->op_flags & OPf_SPECIAL))
763 #endif /* USE_THREADS */
765 if (!(o->op_flags & OPf_REF)
766 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
773 if (cPADOPo->op_padix > 0) {
776 pad_swipe(cPADOPo->op_padix);
777 /* No GvIN_PAD_off(gv) here, because other references may still
778 * exist on the pad */
781 cPADOPo->op_padix = 0;
784 SvREFCNT_dec(cSVOPo->op_sv);
785 cSVOPo->op_sv = Nullsv;
788 case OP_METHOD_NAMED:
790 SvREFCNT_dec(cSVOPo->op_sv);
791 cSVOPo->op_sv = Nullsv;
797 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
801 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
802 SvREFCNT_dec(cSVOPo->op_sv);
803 cSVOPo->op_sv = Nullsv;
806 Safefree(cPVOPo->op_pv);
807 cPVOPo->op_pv = Nullch;
811 op_free(cPMOPo->op_pmreplroot);
815 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
817 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
818 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
819 /* No GvIN_PAD_off(gv) here, because other references may still
820 * exist on the pad */
825 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
832 HV *pmstash = PmopSTASH(cPMOPo);
833 if (pmstash && SvREFCNT(pmstash)) {
834 PMOP *pmop = HvPMROOT(pmstash);
835 PMOP *lastpmop = NULL;
837 if (cPMOPo == pmop) {
839 lastpmop->op_pmnext = pmop->op_pmnext;
841 HvPMROOT(pmstash) = pmop->op_pmnext;
845 pmop = pmop->op_pmnext;
849 Safefree(PmopSTASHPV(cPMOPo));
851 /* NOTE: PMOP.op_pmstash is not refcounted */
854 cPMOPo->op_pmreplroot = Nullop;
855 ReREFCNT_dec(PM_GETRE(cPMOPo));
856 PM_SETRE(cPMOPo, (REGEXP*)NULL);
860 if (o->op_targ > 0) {
861 pad_free(o->op_targ);
867 S_cop_free(pTHX_ COP* cop)
869 Safefree(cop->cop_label);
871 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
872 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
874 /* NOTE: COP.cop_stash is not refcounted */
875 SvREFCNT_dec(CopFILEGV(cop));
877 if (! specialWARN(cop->cop_warnings))
878 SvREFCNT_dec(cop->cop_warnings);
879 if (! specialCopIO(cop->cop_io))
880 SvREFCNT_dec(cop->cop_io);
884 Perl_op_null(pTHX_ OP *o)
886 if (o->op_type == OP_NULL)
889 o->op_targ = o->op_type;
890 o->op_type = OP_NULL;
891 o->op_ppaddr = PL_ppaddr[OP_NULL];
894 /* Contextualizers */
896 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
899 Perl_linklist(pTHX_ OP *o)
906 /* establish postfix order */
907 if (cUNOPo->op_first) {
908 o->op_next = LINKLIST(cUNOPo->op_first);
909 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
911 kid->op_next = LINKLIST(kid->op_sibling);
923 Perl_scalarkids(pTHX_ OP *o)
926 if (o && o->op_flags & OPf_KIDS) {
927 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
934 S_scalarboolean(pTHX_ OP *o)
936 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
937 if (ckWARN(WARN_SYNTAX)) {
938 line_t oldline = CopLINE(PL_curcop);
940 if (PL_copline != NOLINE)
941 CopLINE_set(PL_curcop, PL_copline);
942 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
943 CopLINE_set(PL_curcop, oldline);
950 Perl_scalar(pTHX_ OP *o)
954 /* assumes no premature commitment */
955 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
956 || o->op_type == OP_RETURN)
961 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
963 switch (o->op_type) {
965 scalar(cBINOPo->op_first);
970 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
974 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
975 if (!kPMOP->op_pmreplroot)
976 deprecate("implicit split to @_");
984 if (o->op_flags & OPf_KIDS) {
985 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
991 kid = cLISTOPo->op_first;
993 while ((kid = kid->op_sibling)) {
999 WITH_THR(PL_curcop = &PL_compiling);
1004 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1005 if (kid->op_sibling)
1010 WITH_THR(PL_curcop = &PL_compiling);
1017 Perl_scalarvoid(pTHX_ OP *o)
1024 if (o->op_type == OP_NEXTSTATE
1025 || o->op_type == OP_SETSTATE
1026 || o->op_type == OP_DBSTATE
1027 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1028 || o->op_targ == OP_SETSTATE
1029 || o->op_targ == OP_DBSTATE)))
1030 PL_curcop = (COP*)o; /* for warning below */
1032 /* assumes no premature commitment */
1033 want = o->op_flags & OPf_WANT;
1034 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1035 || o->op_type == OP_RETURN)
1040 if ((o->op_private & OPpTARGET_MY)
1041 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1043 return scalar(o); /* As if inside SASSIGN */
1046 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1048 switch (o->op_type) {
1050 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1054 if (o->op_flags & OPf_STACKED)
1058 if (o->op_private == 4)
1100 case OP_GETSOCKNAME:
1101 case OP_GETPEERNAME:
1106 case OP_GETPRIORITY:
1129 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1130 useless = PL_op_desc[o->op_type];
1137 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1138 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1139 useless = "a variable";
1144 if (cSVOPo->op_private & OPpCONST_STRICT)
1145 no_bareword_allowed(o);
1147 if (ckWARN(WARN_VOID)) {
1148 useless = "a constant";
1149 /* the constants 0 and 1 are permitted as they are
1150 conventionally used as dummies in constructs like
1151 1 while some_condition_with_side_effects; */
1152 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1154 else if (SvPOK(sv)) {
1155 /* perl4's way of mixing documentation and code
1156 (before the invention of POD) was based on a
1157 trick to mix nroff and perl code. The trick was
1158 built upon these three nroff macros being used in
1159 void context. The pink camel has the details in
1160 the script wrapman near page 319. */
1161 if (strnEQ(SvPVX(sv), "di", 2) ||
1162 strnEQ(SvPVX(sv), "ds", 2) ||
1163 strnEQ(SvPVX(sv), "ig", 2))
1168 op_null(o); /* don't execute or even remember it */
1172 o->op_type = OP_PREINC; /* pre-increment is faster */
1173 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1177 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1178 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1184 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1189 if (o->op_flags & OPf_STACKED)
1196 if (!(o->op_flags & OPf_KIDS))
1205 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1212 /* all requires must return a boolean value */
1213 o->op_flags &= ~OPf_WANT;
1218 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1219 if (!kPMOP->op_pmreplroot)
1220 deprecate("implicit split to @_");
1224 if (useless && ckWARN(WARN_VOID))
1225 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1230 Perl_listkids(pTHX_ OP *o)
1233 if (o && o->op_flags & OPf_KIDS) {
1234 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1241 Perl_list(pTHX_ OP *o)
1245 /* assumes no premature commitment */
1246 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1247 || o->op_type == OP_RETURN)
1252 if ((o->op_private & OPpTARGET_MY)
1253 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1255 return o; /* As if inside SASSIGN */
1258 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1260 switch (o->op_type) {
1263 list(cBINOPo->op_first);
1268 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1276 if (!(o->op_flags & OPf_KIDS))
1278 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1279 list(cBINOPo->op_first);
1280 return gen_constant_list(o);
1287 kid = cLISTOPo->op_first;
1289 while ((kid = kid->op_sibling)) {
1290 if (kid->op_sibling)
1295 WITH_THR(PL_curcop = &PL_compiling);
1299 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1300 if (kid->op_sibling)
1305 WITH_THR(PL_curcop = &PL_compiling);
1308 /* all requires must return a boolean value */
1309 o->op_flags &= ~OPf_WANT;
1316 Perl_scalarseq(pTHX_ OP *o)
1321 if (o->op_type == OP_LINESEQ ||
1322 o->op_type == OP_SCOPE ||
1323 o->op_type == OP_LEAVE ||
1324 o->op_type == OP_LEAVETRY)
1326 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1327 if (kid->op_sibling) {
1331 PL_curcop = &PL_compiling;
1333 o->op_flags &= ~OPf_PARENS;
1334 if (PL_hints & HINT_BLOCK_SCOPE)
1335 o->op_flags |= OPf_PARENS;
1338 o = newOP(OP_STUB, 0);
1343 S_modkids(pTHX_ OP *o, I32 type)
1346 if (o && o->op_flags & OPf_KIDS) {
1347 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1354 Perl_mod(pTHX_ OP *o, I32 type)
1359 if (!o || PL_error_count)
1362 if ((o->op_private & OPpTARGET_MY)
1363 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1368 switch (o->op_type) {
1373 if (!(o->op_private & (OPpCONST_ARYBASE)))
1375 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1376 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1380 SAVEI32(PL_compiling.cop_arybase);
1381 PL_compiling.cop_arybase = 0;
1383 else if (type == OP_REFGEN)
1386 Perl_croak(aTHX_ "That use of $[ is unsupported");
1389 if (o->op_flags & OPf_PARENS)
1393 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1394 !(o->op_flags & OPf_STACKED)) {
1395 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1396 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1397 assert(cUNOPo->op_first->op_type == OP_NULL);
1398 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1401 else { /* lvalue subroutine call */
1402 o->op_private |= OPpLVAL_INTRO;
1403 PL_modcount = RETURN_UNLIMITED_NUMBER;
1404 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1405 /* Backward compatibility mode: */
1406 o->op_private |= OPpENTERSUB_INARGS;
1409 else { /* Compile-time error message: */
1410 OP *kid = cUNOPo->op_first;
1414 if (kid->op_type == OP_PUSHMARK)
1416 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1418 "panic: unexpected lvalue entersub "
1419 "args: type/targ %ld:%ld",
1420 (long)kid->op_type,kid->op_targ);
1421 kid = kLISTOP->op_first;
1423 while (kid->op_sibling)
1424 kid = kid->op_sibling;
1425 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1427 if (kid->op_type == OP_METHOD_NAMED
1428 || kid->op_type == OP_METHOD)
1432 if (kid->op_sibling || kid->op_next != kid) {
1433 yyerror("panic: unexpected optree near method call");
1437 NewOp(1101, newop, 1, UNOP);
1438 newop->op_type = OP_RV2CV;
1439 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1440 newop->op_first = Nullop;
1441 newop->op_next = (OP*)newop;
1442 kid->op_sibling = (OP*)newop;
1443 newop->op_private |= OPpLVAL_INTRO;
1447 if (kid->op_type != OP_RV2CV)
1449 "panic: unexpected lvalue entersub "
1450 "entry via type/targ %ld:%ld",
1451 (long)kid->op_type,kid->op_targ);
1452 kid->op_private |= OPpLVAL_INTRO;
1453 break; /* Postpone until runtime */
1457 kid = kUNOP->op_first;
1458 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1459 kid = kUNOP->op_first;
1460 if (kid->op_type == OP_NULL)
1462 "Unexpected constant lvalue entersub "
1463 "entry via type/targ %ld:%ld",
1464 (long)kid->op_type,kid->op_targ);
1465 if (kid->op_type != OP_GV) {
1466 /* Restore RV2CV to check lvalueness */
1468 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1469 okid->op_next = kid->op_next;
1470 kid->op_next = okid;
1473 okid->op_next = Nullop;
1474 okid->op_type = OP_RV2CV;
1476 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1477 okid->op_private |= OPpLVAL_INTRO;
1481 cv = GvCV(kGVOP_gv);
1491 /* grep, foreach, subcalls, refgen */
1492 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1494 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1495 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1497 : (o->op_type == OP_ENTERSUB
1498 ? "non-lvalue subroutine call"
1499 : PL_op_desc[o->op_type])),
1500 type ? PL_op_desc[type] : "local"));
1514 case OP_RIGHT_SHIFT:
1523 if (!(o->op_flags & OPf_STACKED))
1529 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1535 if (!type && cUNOPo->op_first->op_type != OP_GV)
1536 Perl_croak(aTHX_ "Can't localize through a reference");
1537 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1538 PL_modcount = RETURN_UNLIMITED_NUMBER;
1539 return o; /* Treat \(@foo) like ordinary list. */
1543 if (scalar_mod_type(o, type))
1545 ref(cUNOPo->op_first, o->op_type);
1549 if (type == OP_LEAVESUBLV)
1550 o->op_private |= OPpMAYBE_LVSUB;
1556 PL_modcount = RETURN_UNLIMITED_NUMBER;
1559 if (!type && cUNOPo->op_first->op_type != OP_GV)
1560 Perl_croak(aTHX_ "Can't localize through a reference");
1561 ref(cUNOPo->op_first, o->op_type);
1565 PL_hints |= HINT_BLOCK_SCOPE;
1575 PL_modcount = RETURN_UNLIMITED_NUMBER;
1576 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1577 return o; /* Treat \(@foo) like ordinary list. */
1578 if (scalar_mod_type(o, type))
1580 if (type == OP_LEAVESUBLV)
1581 o->op_private |= OPpMAYBE_LVSUB;
1586 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1587 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1592 PL_modcount++; /* XXX ??? */
1594 #endif /* USE_THREADS */
1600 if (type != OP_SASSIGN)
1604 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1609 if (type == OP_LEAVESUBLV)
1610 o->op_private |= OPpMAYBE_LVSUB;
1612 pad_free(o->op_targ);
1613 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1614 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1615 if (o->op_flags & OPf_KIDS)
1616 mod(cBINOPo->op_first->op_sibling, type);
1621 ref(cBINOPo->op_first, o->op_type);
1622 if (type == OP_ENTERSUB &&
1623 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1624 o->op_private |= OPpLVAL_DEFER;
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1634 if (o->op_flags & OPf_KIDS)
1635 mod(cLISTOPo->op_last, type);
1639 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1641 else if (!(o->op_flags & OPf_KIDS))
1643 if (o->op_targ != OP_LIST) {
1644 mod(cBINOPo->op_first, type);
1649 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1654 if (type != OP_LEAVESUBLV)
1656 break; /* mod()ing was handled by ck_return() */
1658 if (type != OP_LEAVESUBLV)
1659 o->op_flags |= OPf_MOD;
1661 if (type == OP_AASSIGN || type == OP_SASSIGN)
1662 o->op_flags |= OPf_SPECIAL|OPf_REF;
1664 o->op_private |= OPpLVAL_INTRO;
1665 o->op_flags &= ~OPf_SPECIAL;
1666 PL_hints |= HINT_BLOCK_SCOPE;
1668 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1669 && type != OP_LEAVESUBLV)
1670 o->op_flags |= OPf_REF;
1675 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1679 if (o->op_type == OP_RV2GV)
1703 case OP_RIGHT_SHIFT:
1722 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1724 switch (o->op_type) {
1732 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1745 Perl_refkids(pTHX_ OP *o, I32 type)
1748 if (o && o->op_flags & OPf_KIDS) {
1749 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1756 Perl_ref(pTHX_ OP *o, I32 type)
1760 if (!o || PL_error_count)
1763 switch (o->op_type) {
1765 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1766 !(o->op_flags & OPf_STACKED)) {
1767 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1768 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1769 assert(cUNOPo->op_first->op_type == OP_NULL);
1770 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1771 o->op_flags |= OPf_SPECIAL;
1776 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1780 if (type == OP_DEFINED)
1781 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1782 ref(cUNOPo->op_first, o->op_type);
1785 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1786 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1787 : type == OP_RV2HV ? OPpDEREF_HV
1789 o->op_flags |= OPf_MOD;
1794 o->op_flags |= OPf_MOD; /* XXX ??? */
1799 o->op_flags |= OPf_REF;
1802 if (type == OP_DEFINED)
1803 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1804 ref(cUNOPo->op_first, o->op_type);
1809 o->op_flags |= OPf_REF;
1814 if (!(o->op_flags & OPf_KIDS))
1816 ref(cBINOPo->op_first, type);
1820 ref(cBINOPo->op_first, o->op_type);
1821 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1822 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1823 : type == OP_RV2HV ? OPpDEREF_HV
1825 o->op_flags |= OPf_MOD;
1833 if (!(o->op_flags & OPf_KIDS))
1835 ref(cLISTOPo->op_last, type);
1845 S_dup_attrlist(pTHX_ OP *o)
1849 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1850 * where the first kid is OP_PUSHMARK and the remaining ones
1851 * are OP_CONST. We need to push the OP_CONST values.
1853 if (o->op_type == OP_CONST)
1854 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1856 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1857 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1858 if (o->op_type == OP_CONST)
1859 rop = append_elem(OP_LIST, rop,
1860 newSVOP(OP_CONST, o->op_flags,
1861 SvREFCNT_inc(cSVOPo->op_sv)));
1868 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1872 /* fake up C<use attributes $pkg,$rv,@attrs> */
1873 ENTER; /* need to protect against side-effects of 'use' */
1876 stashsv = newSVpv(HvNAME(stash), 0);
1878 stashsv = &PL_sv_no;
1880 #define ATTRSMODULE "attributes"
1882 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1883 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1885 prepend_elem(OP_LIST,
1886 newSVOP(OP_CONST, 0, stashsv),
1887 prepend_elem(OP_LIST,
1888 newSVOP(OP_CONST, 0,
1890 dup_attrlist(attrs))));
1895 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1896 char *attrstr, STRLEN len)
1901 len = strlen(attrstr);
1905 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1907 char *sstr = attrstr;
1908 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1909 attrs = append_elem(OP_LIST, attrs,
1910 newSVOP(OP_CONST, 0,
1911 newSVpvn(sstr, attrstr-sstr)));
1915 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1916 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1917 Nullsv, prepend_elem(OP_LIST,
1918 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1919 prepend_elem(OP_LIST,
1920 newSVOP(OP_CONST, 0,
1926 S_my_kid(pTHX_ OP *o, OP *attrs)
1931 if (!o || PL_error_count)
1935 if (type == OP_LIST) {
1936 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1938 } else if (type == OP_UNDEF) {
1940 } else if (type == OP_RV2SV || /* "our" declaration */
1942 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1944 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1946 PL_in_my_stash = Nullhv;
1947 apply_attrs(GvSTASH(gv),
1948 (type == OP_RV2SV ? GvSV(gv) :
1949 type == OP_RV2AV ? (SV*)GvAV(gv) :
1950 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1953 o->op_private |= OPpOUR_INTRO;
1955 } else if (type != OP_PADSV &&
1958 type != OP_PUSHMARK)
1960 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1961 PL_op_desc[o->op_type],
1962 PL_in_my == KEY_our ? "our" : "my"));
1965 else if (attrs && type != OP_PUSHMARK) {
1971 PL_in_my_stash = Nullhv;
1973 /* check for C<my Dog $spot> when deciding package */
1974 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1975 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1976 stash = SvSTASH(*namesvp);
1978 stash = PL_curstash;
1979 padsv = PAD_SV(o->op_targ);
1980 apply_attrs(stash, padsv, attrs);
1982 o->op_flags |= OPf_MOD;
1983 o->op_private |= OPpLVAL_INTRO;
1988 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1990 if (o->op_flags & OPf_PARENS)
1994 o = my_kid(o, attrs);
1996 PL_in_my_stash = Nullhv;
2001 Perl_my(pTHX_ OP *o)
2003 return my_kid(o, Nullop);
2007 Perl_sawparens(pTHX_ OP *o)
2010 o->op_flags |= OPf_PARENS;
2015 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2019 if (ckWARN(WARN_MISC) &&
2020 (left->op_type == OP_RV2AV ||
2021 left->op_type == OP_RV2HV ||
2022 left->op_type == OP_PADAV ||
2023 left->op_type == OP_PADHV)) {
2024 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2025 right->op_type == OP_TRANS)
2026 ? right->op_type : OP_MATCH];
2027 const char *sample = ((left->op_type == OP_RV2AV ||
2028 left->op_type == OP_PADAV)
2029 ? "@array" : "%hash");
2030 Perl_warner(aTHX_ WARN_MISC,
2031 "Applying %s to %s will act on scalar(%s)",
2032 desc, sample, sample);
2035 if (!(right->op_flags & OPf_STACKED) &&
2036 (right->op_type == OP_MATCH ||
2037 right->op_type == OP_SUBST ||
2038 right->op_type == OP_TRANS)) {
2039 right->op_flags |= OPf_STACKED;
2040 if ((right->op_type != OP_MATCH &&
2041 ! (right->op_type == OP_TRANS &&
2042 right->op_private & OPpTRANS_IDENTICAL)) ||
2043 /* if SV has magic, then match on original SV, not on its copy.
2044 see note in pp_helem() */
2045 (right->op_type == OP_MATCH &&
2046 (left->op_type == OP_AELEM ||
2047 left->op_type == OP_HELEM ||
2048 left->op_type == OP_AELEMFAST)))
2049 left = mod(left, right->op_type);
2050 if (right->op_type == OP_TRANS)
2051 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2053 o = prepend_elem(right->op_type, scalar(left), right);
2055 return newUNOP(OP_NOT, 0, scalar(o));
2059 return bind_match(type, left,
2060 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2064 Perl_invert(pTHX_ OP *o)
2068 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2069 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2073 Perl_scope(pTHX_ OP *o)
2076 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2077 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2078 o->op_type = OP_LEAVE;
2079 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2082 if (o->op_type == OP_LINESEQ) {
2084 o->op_type = OP_SCOPE;
2085 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2086 kid = ((LISTOP*)o)->op_first;
2087 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2091 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2098 Perl_save_hints(pTHX)
2101 SAVESPTR(GvHV(PL_hintgv));
2102 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2103 SAVEFREESV(GvHV(PL_hintgv));
2107 Perl_block_start(pTHX_ int full)
2109 int retval = PL_savestack_ix;
2111 SAVEI32(PL_comppad_name_floor);
2112 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2114 PL_comppad_name_fill = PL_comppad_name_floor;
2115 if (PL_comppad_name_floor < 0)
2116 PL_comppad_name_floor = 0;
2117 SAVEI32(PL_min_intro_pending);
2118 SAVEI32(PL_max_intro_pending);
2119 PL_min_intro_pending = 0;
2120 SAVEI32(PL_comppad_name_fill);
2121 SAVEI32(PL_padix_floor);
2122 PL_padix_floor = PL_padix;
2123 PL_pad_reset_pending = FALSE;
2125 PL_hints &= ~HINT_BLOCK_SCOPE;
2126 SAVESPTR(PL_compiling.cop_warnings);
2127 if (! specialWARN(PL_compiling.cop_warnings)) {
2128 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2129 SAVEFREESV(PL_compiling.cop_warnings) ;
2131 SAVESPTR(PL_compiling.cop_io);
2132 if (! specialCopIO(PL_compiling.cop_io)) {
2133 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2134 SAVEFREESV(PL_compiling.cop_io) ;
2140 Perl_block_end(pTHX_ I32 floor, OP *seq)
2142 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2143 OP* retval = scalarseq(seq);
2145 PL_pad_reset_pending = FALSE;
2146 PL_compiling.op_private = PL_hints;
2148 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2149 pad_leavemy(PL_comppad_name_fill);
2158 OP *o = newOP(OP_THREADSV, 0);
2159 o->op_targ = find_threadsv("_");
2162 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2163 #endif /* USE_THREADS */
2167 Perl_newPROG(pTHX_ OP *o)
2172 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2173 ((PL_in_eval & EVAL_KEEPERR)
2174 ? OPf_SPECIAL : 0), o);
2175 PL_eval_start = linklist(PL_eval_root);
2176 PL_eval_root->op_private |= OPpREFCOUNTED;
2177 OpREFCNT_set(PL_eval_root, 1);
2178 PL_eval_root->op_next = 0;
2179 CALL_PEEP(PL_eval_start);
2184 PL_main_root = scope(sawparens(scalarvoid(o)));
2185 PL_curcop = &PL_compiling;
2186 PL_main_start = LINKLIST(PL_main_root);
2187 PL_main_root->op_private |= OPpREFCOUNTED;
2188 OpREFCNT_set(PL_main_root, 1);
2189 PL_main_root->op_next = 0;
2190 CALL_PEEP(PL_main_start);
2193 /* Register with debugger */
2195 CV *cv = get_cv("DB::postponed", FALSE);
2199 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2201 call_sv((SV*)cv, G_DISCARD);
2208 Perl_localize(pTHX_ OP *o, I32 lex)
2210 if (o->op_flags & OPf_PARENS)
2213 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2215 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2216 if (*s == ';' || *s == '=')
2217 Perl_warner(aTHX_ WARN_PARENTHESIS,
2218 "Parentheses missing around \"%s\" list",
2219 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2225 o = mod(o, OP_NULL); /* a bit kludgey */
2227 PL_in_my_stash = Nullhv;
2232 Perl_jmaybe(pTHX_ OP *o)
2234 if (o->op_type == OP_LIST) {
2237 o2 = newOP(OP_THREADSV, 0);
2238 o2->op_targ = find_threadsv(";");
2240 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2241 #endif /* USE_THREADS */
2242 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2248 Perl_fold_constants(pTHX_ register OP *o)
2251 I32 type = o->op_type;
2254 if (PL_opargs[type] & OA_RETSCALAR)
2256 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2257 o->op_targ = pad_alloc(type, SVs_PADTMP);
2259 /* integerize op, unless it happens to be C<-foo>.
2260 * XXX should pp_i_negate() do magic string negation instead? */
2261 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2262 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2263 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2265 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2268 if (!(PL_opargs[type] & OA_FOLDCONST))
2273 /* XXX might want a ck_negate() for this */
2274 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2286 /* XXX what about the numeric ops? */
2287 if (PL_hints & HINT_LOCALE)
2292 goto nope; /* Don't try to run w/ errors */
2294 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2295 if ((curop->op_type != OP_CONST ||
2296 (curop->op_private & OPpCONST_BARE)) &&
2297 curop->op_type != OP_LIST &&
2298 curop->op_type != OP_SCALAR &&
2299 curop->op_type != OP_NULL &&
2300 curop->op_type != OP_PUSHMARK)
2306 curop = LINKLIST(o);
2310 sv = *(PL_stack_sp--);
2311 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2312 pad_swipe(o->op_targ);
2313 else if (SvTEMP(sv)) { /* grab mortal temp? */
2314 (void)SvREFCNT_inc(sv);
2318 if (type == OP_RV2GV)
2319 return newGVOP(OP_GV, 0, (GV*)sv);
2321 /* try to smush double to int, but don't smush -2.0 to -2 */
2322 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2325 #ifdef PERL_PRESERVE_IVUV
2326 /* Only bother to attempt to fold to IV if
2327 most operators will benefit */
2331 return newSVOP(OP_CONST, 0, sv);
2335 if (!(PL_opargs[type] & OA_OTHERINT))
2338 if (!(PL_hints & HINT_INTEGER)) {
2339 if (type == OP_MODULO
2340 || type == OP_DIVIDE
2341 || !(o->op_flags & OPf_KIDS))
2346 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2347 if (curop->op_type == OP_CONST) {
2348 if (SvIOK(((SVOP*)curop)->op_sv))
2352 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2356 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2363 Perl_gen_constant_list(pTHX_ register OP *o)
2366 I32 oldtmps_floor = PL_tmps_floor;
2370 return o; /* Don't attempt to run with errors */
2372 PL_op = curop = LINKLIST(o);
2379 PL_tmps_floor = oldtmps_floor;
2381 o->op_type = OP_RV2AV;
2382 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2383 curop = ((UNOP*)o)->op_first;
2384 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2391 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2393 if (!o || o->op_type != OP_LIST)
2394 o = newLISTOP(OP_LIST, 0, o, Nullop);
2396 o->op_flags &= ~OPf_WANT;
2398 if (!(PL_opargs[type] & OA_MARK))
2399 op_null(cLISTOPo->op_first);
2402 o->op_ppaddr = PL_ppaddr[type];
2403 o->op_flags |= flags;
2405 o = CHECKOP(type, o);
2406 if (o->op_type != type)
2409 return fold_constants(o);
2412 /* List constructors */
2415 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2423 if (first->op_type != type
2424 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2426 return newLISTOP(type, 0, first, last);
2429 if (first->op_flags & OPf_KIDS)
2430 ((LISTOP*)first)->op_last->op_sibling = last;
2432 first->op_flags |= OPf_KIDS;
2433 ((LISTOP*)first)->op_first = last;
2435 ((LISTOP*)first)->op_last = last;
2440 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2448 if (first->op_type != type)
2449 return prepend_elem(type, (OP*)first, (OP*)last);
2451 if (last->op_type != type)
2452 return append_elem(type, (OP*)first, (OP*)last);
2454 first->op_last->op_sibling = last->op_first;
2455 first->op_last = last->op_last;
2456 first->op_flags |= (last->op_flags & OPf_KIDS);
2458 #ifdef PL_OP_SLAB_ALLOC
2466 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2474 if (last->op_type == type) {
2475 if (type == OP_LIST) { /* already a PUSHMARK there */
2476 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2477 ((LISTOP*)last)->op_first->op_sibling = first;
2478 if (!(first->op_flags & OPf_PARENS))
2479 last->op_flags &= ~OPf_PARENS;
2482 if (!(last->op_flags & OPf_KIDS)) {
2483 ((LISTOP*)last)->op_last = first;
2484 last->op_flags |= OPf_KIDS;
2486 first->op_sibling = ((LISTOP*)last)->op_first;
2487 ((LISTOP*)last)->op_first = first;
2489 last->op_flags |= OPf_KIDS;
2493 return newLISTOP(type, 0, first, last);
2499 Perl_newNULLLIST(pTHX)
2501 return newOP(OP_STUB, 0);
2505 Perl_force_list(pTHX_ OP *o)
2507 if (!o || o->op_type != OP_LIST)
2508 o = newLISTOP(OP_LIST, 0, o, Nullop);
2514 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2518 NewOp(1101, listop, 1, LISTOP);
2520 listop->op_type = type;
2521 listop->op_ppaddr = PL_ppaddr[type];
2524 listop->op_flags = flags;
2528 else if (!first && last)
2531 first->op_sibling = last;
2532 listop->op_first = first;
2533 listop->op_last = last;
2534 if (type == OP_LIST) {
2536 pushop = newOP(OP_PUSHMARK, 0);
2537 pushop->op_sibling = first;
2538 listop->op_first = pushop;
2539 listop->op_flags |= OPf_KIDS;
2541 listop->op_last = pushop;
2548 Perl_newOP(pTHX_ I32 type, I32 flags)
2551 NewOp(1101, o, 1, OP);
2553 o->op_ppaddr = PL_ppaddr[type];
2554 o->op_flags = flags;
2557 o->op_private = 0 + (flags >> 8);
2558 if (PL_opargs[type] & OA_RETSCALAR)
2560 if (PL_opargs[type] & OA_TARGET)
2561 o->op_targ = pad_alloc(type, SVs_PADTMP);
2562 return CHECKOP(type, o);
2566 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2571 first = newOP(OP_STUB, 0);
2572 if (PL_opargs[type] & OA_MARK)
2573 first = force_list(first);
2575 NewOp(1101, unop, 1, UNOP);
2576 unop->op_type = type;
2577 unop->op_ppaddr = PL_ppaddr[type];
2578 unop->op_first = first;
2579 unop->op_flags = flags | OPf_KIDS;
2580 unop->op_private = 1 | (flags >> 8);
2581 unop = (UNOP*) CHECKOP(type, unop);
2585 return fold_constants((OP *) unop);
2589 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2592 NewOp(1101, binop, 1, BINOP);
2595 first = newOP(OP_NULL, 0);
2597 binop->op_type = type;
2598 binop->op_ppaddr = PL_ppaddr[type];
2599 binop->op_first = first;
2600 binop->op_flags = flags | OPf_KIDS;
2603 binop->op_private = 1 | (flags >> 8);
2606 binop->op_private = 2 | (flags >> 8);
2607 first->op_sibling = last;
2610 binop = (BINOP*)CHECKOP(type, binop);
2611 if (binop->op_next || binop->op_type != type)
2614 binop->op_last = binop->op_first->op_sibling;
2616 return fold_constants((OP *)binop);
2620 uvcompare(const void *a, const void *b)
2622 if (*((UV *)a) < (*(UV *)b))
2624 if (*((UV *)a) > (*(UV *)b))
2626 if (*((UV *)a+1) < (*(UV *)b+1))
2628 if (*((UV *)a+1) > (*(UV *)b+1))
2634 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2636 SV *tstr = ((SVOP*)expr)->op_sv;
2637 SV *rstr = ((SVOP*)repl)->op_sv;
2640 U8 *t = (U8*)SvPV(tstr, tlen);
2641 U8 *r = (U8*)SvPV(rstr, rlen);
2648 register short *tbl;
2650 PL_hints |= HINT_BLOCK_SCOPE;
2651 complement = o->op_private & OPpTRANS_COMPLEMENT;
2652 del = o->op_private & OPpTRANS_DELETE;
2653 squash = o->op_private & OPpTRANS_SQUASH;
2656 o->op_private |= OPpTRANS_FROM_UTF;
2659 o->op_private |= OPpTRANS_TO_UTF;
2661 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2662 SV* listsv = newSVpvn("# comment\n",10);
2664 U8* tend = t + tlen;
2665 U8* rend = r + rlen;
2679 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2680 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2686 tsave = t = bytes_to_utf8(t, &len);
2689 if (!to_utf && rlen) {
2691 rsave = r = bytes_to_utf8(r, &len);
2695 /* There are several snags with this code on EBCDIC:
2696 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2697 2. scan_const() in toke.c has encoded chars in native encoding which makes
2698 ranges at least in EBCDIC 0..255 range the bottom odd.
2702 U8 tmpbuf[UTF8_MAXLEN+1];
2705 New(1109, cp, 2*tlen, UV);
2707 transv = newSVpvn("",0);
2709 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2711 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2713 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2717 cp[2*i+1] = cp[2*i];
2721 qsort(cp, i, 2*sizeof(UV), uvcompare);
2722 for (j = 0; j < i; j++) {
2724 diff = val - nextmin;
2726 t = uvuni_to_utf8(tmpbuf,nextmin);
2727 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2729 U8 range_mark = UTF_TO_NATIVE(0xff);
2730 t = uvuni_to_utf8(tmpbuf, val - 1);
2731 sv_catpvn(transv, (char *)&range_mark, 1);
2732 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2739 t = uvuni_to_utf8(tmpbuf,nextmin);
2740 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2742 U8 range_mark = UTF_TO_NATIVE(0xff);
2743 sv_catpvn(transv, (char *)&range_mark, 1);
2745 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2746 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2747 t = (U8*)SvPVX(transv);
2748 tlen = SvCUR(transv);
2752 else if (!rlen && !del) {
2753 r = t; rlen = tlen; rend = tend;
2756 if ((!rlen && !del) || t == r ||
2757 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2759 o->op_private |= OPpTRANS_IDENTICAL;
2763 while (t < tend || tfirst <= tlast) {
2764 /* see if we need more "t" chars */
2765 if (tfirst > tlast) {
2766 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2768 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2770 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2777 /* now see if we need more "r" chars */
2778 if (rfirst > rlast) {
2780 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2782 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2784 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2793 rfirst = rlast = 0xffffffff;
2797 /* now see which range will peter our first, if either. */
2798 tdiff = tlast - tfirst;
2799 rdiff = rlast - rfirst;
2806 if (rfirst == 0xffffffff) {
2807 diff = tdiff; /* oops, pretend rdiff is infinite */
2809 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2810 (long)tfirst, (long)tlast);
2812 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2816 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2817 (long)tfirst, (long)(tfirst + diff),
2820 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2821 (long)tfirst, (long)rfirst);
2823 if (rfirst + diff > max)
2824 max = rfirst + diff;
2826 grows = (tfirst < rfirst &&
2827 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2839 else if (max > 0xff)
2844 Safefree(cPVOPo->op_pv);
2845 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2846 SvREFCNT_dec(listsv);
2848 SvREFCNT_dec(transv);
2850 if (!del && havefinal && rlen)
2851 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2852 newSVuv((UV)final), 0);
2855 o->op_private |= OPpTRANS_GROWS;
2867 tbl = (short*)cPVOPo->op_pv;
2869 Zero(tbl, 256, short);
2870 for (i = 0; i < tlen; i++)
2872 for (i = 0, j = 0; i < 256; i++) {
2883 if (i < 128 && r[j] >= 128)
2893 o->op_private |= OPpTRANS_IDENTICAL;
2898 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2899 tbl[0x100] = rlen - j;
2900 for (i=0; i < rlen - j; i++)
2901 tbl[0x101+i] = r[j+i];
2905 if (!rlen && !del) {
2908 o->op_private |= OPpTRANS_IDENTICAL;
2910 for (i = 0; i < 256; i++)
2912 for (i = 0, j = 0; i < tlen; i++,j++) {
2915 if (tbl[t[i]] == -1)
2921 if (tbl[t[i]] == -1) {
2922 if (t[i] < 128 && r[j] >= 128)
2929 o->op_private |= OPpTRANS_GROWS;
2937 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2941 NewOp(1101, pmop, 1, PMOP);
2942 pmop->op_type = type;
2943 pmop->op_ppaddr = PL_ppaddr[type];
2944 pmop->op_flags = flags;
2945 pmop->op_private = 0 | (flags >> 8);
2947 if (PL_hints & HINT_RE_TAINT)
2948 pmop->op_pmpermflags |= PMf_RETAINT;
2949 if (PL_hints & HINT_LOCALE)
2950 pmop->op_pmpermflags |= PMf_LOCALE;
2951 pmop->op_pmflags = pmop->op_pmpermflags;
2955 SV* repointer = newSViv(0);
2956 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2957 pmop->op_pmoffset = av_len(PL_regex_padav);
2958 PL_regex_pad = AvARRAY(PL_regex_padav);
2962 /* link into pm list */
2963 if (type != OP_TRANS && PL_curstash) {
2964 pmop->op_pmnext = HvPMROOT(PL_curstash);
2965 HvPMROOT(PL_curstash) = pmop;
2966 PmopSTASH_set(pmop,PL_curstash);
2973 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2977 I32 repl_has_vars = 0;
2979 if (o->op_type == OP_TRANS)
2980 return pmtrans(o, expr, repl);
2982 PL_hints |= HINT_BLOCK_SCOPE;
2985 if (expr->op_type == OP_CONST) {
2987 SV *pat = ((SVOP*)expr)->op_sv;
2988 char *p = SvPV(pat, plen);
2989 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2990 sv_setpvn(pat, "\\s+", 3);
2991 p = SvPV(pat, plen);
2992 pm->op_pmflags |= PMf_SKIPWHITE;
2994 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2995 pm->op_pmdynflags |= PMdf_UTF8;
2996 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2997 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2998 pm->op_pmflags |= PMf_WHITE;
3002 if (PL_hints & HINT_UTF8)
3003 pm->op_pmdynflags |= PMdf_UTF8;
3004 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3005 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3007 : OP_REGCMAYBE),0,expr);
3009 NewOp(1101, rcop, 1, LOGOP);
3010 rcop->op_type = OP_REGCOMP;
3011 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3012 rcop->op_first = scalar(expr);
3013 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3014 ? (OPf_SPECIAL | OPf_KIDS)
3016 rcop->op_private = 1;
3019 /* establish postfix order */
3020 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3022 rcop->op_next = expr;
3023 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3026 rcop->op_next = LINKLIST(expr);
3027 expr->op_next = (OP*)rcop;
3030 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3035 if (pm->op_pmflags & PMf_EVAL) {
3037 if (CopLINE(PL_curcop) < PL_multi_end)
3038 CopLINE_set(PL_curcop, PL_multi_end);
3041 else if (repl->op_type == OP_THREADSV
3042 && strchr("&`'123456789+",
3043 PL_threadsv_names[repl->op_targ]))
3047 #endif /* USE_THREADS */
3048 else if (repl->op_type == OP_CONST)
3052 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3053 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3055 if (curop->op_type == OP_THREADSV) {
3057 if (strchr("&`'123456789+", curop->op_private))
3061 if (curop->op_type == OP_GV) {
3062 GV *gv = cGVOPx_gv(curop);
3064 if (strchr("&`'123456789+", *GvENAME(gv)))
3067 #endif /* USE_THREADS */
3068 else if (curop->op_type == OP_RV2CV)
3070 else if (curop->op_type == OP_RV2SV ||
3071 curop->op_type == OP_RV2AV ||
3072 curop->op_type == OP_RV2HV ||
3073 curop->op_type == OP_RV2GV) {
3074 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3077 else if (curop->op_type == OP_PADSV ||
3078 curop->op_type == OP_PADAV ||
3079 curop->op_type == OP_PADHV ||
3080 curop->op_type == OP_PADANY) {
3083 else if (curop->op_type == OP_PUSHRE)
3084 ; /* Okay here, dangerous in newASSIGNOP */
3094 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3095 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3096 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3097 prepend_elem(o->op_type, scalar(repl), o);
3100 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3101 pm->op_pmflags |= PMf_MAYBE_CONST;
3102 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3104 NewOp(1101, rcop, 1, LOGOP);
3105 rcop->op_type = OP_SUBSTCONT;
3106 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3107 rcop->op_first = scalar(repl);
3108 rcop->op_flags |= OPf_KIDS;
3109 rcop->op_private = 1;
3112 /* establish postfix order */
3113 rcop->op_next = LINKLIST(repl);
3114 repl->op_next = (OP*)rcop;
3116 pm->op_pmreplroot = scalar((OP*)rcop);
3117 pm->op_pmreplstart = LINKLIST(rcop);
3126 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3129 NewOp(1101, svop, 1, SVOP);
3130 svop->op_type = type;
3131 svop->op_ppaddr = PL_ppaddr[type];
3133 svop->op_next = (OP*)svop;
3134 svop->op_flags = flags;
3135 if (PL_opargs[type] & OA_RETSCALAR)
3137 if (PL_opargs[type] & OA_TARGET)
3138 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3139 return CHECKOP(type, svop);
3143 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3146 NewOp(1101, padop, 1, PADOP);
3147 padop->op_type = type;
3148 padop->op_ppaddr = PL_ppaddr[type];
3149 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3150 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3151 PL_curpad[padop->op_padix] = sv;
3153 padop->op_next = (OP*)padop;
3154 padop->op_flags = flags;
3155 if (PL_opargs[type] & OA_RETSCALAR)
3157 if (PL_opargs[type] & OA_TARGET)
3158 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3159 return CHECKOP(type, padop);
3163 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3167 return newPADOP(type, flags, SvREFCNT_inc(gv));
3169 return newSVOP(type, flags, SvREFCNT_inc(gv));
3174 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3177 NewOp(1101, pvop, 1, PVOP);
3178 pvop->op_type = type;
3179 pvop->op_ppaddr = PL_ppaddr[type];
3181 pvop->op_next = (OP*)pvop;
3182 pvop->op_flags = flags;
3183 if (PL_opargs[type] & OA_RETSCALAR)
3185 if (PL_opargs[type] & OA_TARGET)
3186 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3187 return CHECKOP(type, pvop);
3191 Perl_package(pTHX_ OP *o)
3195 save_hptr(&PL_curstash);
3196 save_item(PL_curstname);
3201 name = SvPV(sv, len);
3202 PL_curstash = gv_stashpvn(name,len,TRUE);
3203 sv_setpvn(PL_curstname, name, len);
3207 deprecate("\"package\" with no arguments");
3208 sv_setpv(PL_curstname,"<none>");
3209 PL_curstash = Nullhv;
3211 PL_hints |= HINT_BLOCK_SCOPE;
3212 PL_copline = NOLINE;
3217 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3222 char *packname = Nullch;
3226 if (id->op_type != OP_CONST)
3227 Perl_croak(aTHX_ "Module name must be constant");
3231 if (version != Nullop) {
3232 SV *vesv = ((SVOP*)version)->op_sv;
3234 if (arg == Nullop && !SvNIOKp(vesv)) {
3241 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3242 Perl_croak(aTHX_ "Version number must be constant number");
3244 /* Make copy of id so we don't free it twice */
3245 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3247 /* Fake up a method call to VERSION */
3248 meth = newSVpvn("VERSION",7);
3249 sv_upgrade(meth, SVt_PVIV);
3250 (void)SvIOK_on(meth);
3251 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3252 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3253 append_elem(OP_LIST,
3254 prepend_elem(OP_LIST, pack, list(version)),
3255 newSVOP(OP_METHOD_NAMED, 0, meth)));
3259 /* Fake up an import/unimport */
3260 if (arg && arg->op_type == OP_STUB)
3261 imop = arg; /* no import on explicit () */
3262 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3263 imop = Nullop; /* use 5.0; */
3268 /* Make copy of id so we don't free it twice */
3269 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3271 /* Fake up a method call to import/unimport */
3272 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3273 sv_upgrade(meth, SVt_PVIV);
3274 (void)SvIOK_on(meth);
3275 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3276 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3277 append_elem(OP_LIST,
3278 prepend_elem(OP_LIST, pack, list(arg)),
3279 newSVOP(OP_METHOD_NAMED, 0, meth)));
3282 if (ckWARN(WARN_MISC) && imop && SvPOK(packsv = ((SVOP*)id)->op_sv)) {
3283 /* BEGIN will free the ops, so we need to make a copy */
3284 packlen = SvCUR(packsv);
3285 packname = savepvn(SvPVX(packsv), packlen);
3288 /* Fake up the BEGIN {}, which does its thing immediately. */
3290 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3293 append_elem(OP_LINESEQ,
3294 append_elem(OP_LINESEQ,
3295 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3296 newSTATEOP(0, Nullch, veop)),
3297 newSTATEOP(0, Nullch, imop) ));
3300 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3301 Perl_warner(aTHX_ WARN_MISC,
3302 "Package `%s' not found "
3303 "(did you use the incorrect case?)", packname);
3308 PL_hints |= HINT_BLOCK_SCOPE;
3309 PL_copline = NOLINE;
3314 =for apidoc load_module
3316 Loads the module whose name is pointed to by the string part of name.
3317 Note that the actual module name, not its filename, should be given.
3318 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3319 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3320 (or 0 for no flags). ver, if specified, provides version semantics
3321 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3322 arguments can be used to specify arguments to the module's import()
3323 method, similar to C<use Foo::Bar VERSION LIST>.
3328 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3331 va_start(args, ver);
3332 vload_module(flags, name, ver, &args);
3336 #ifdef PERL_IMPLICIT_CONTEXT
3338 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3342 va_start(args, ver);
3343 vload_module(flags, name, ver, &args);
3349 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3351 OP *modname, *veop, *imop;
3353 modname = newSVOP(OP_CONST, 0, name);
3354 modname->op_private |= OPpCONST_BARE;
3356 veop = newSVOP(OP_CONST, 0, ver);
3360 if (flags & PERL_LOADMOD_NOIMPORT) {
3361 imop = sawparens(newNULLLIST());
3363 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3364 imop = va_arg(*args, OP*);
3369 sv = va_arg(*args, SV*);
3371 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3372 sv = va_arg(*args, SV*);
3376 line_t ocopline = PL_copline;
3377 int oexpect = PL_expect;
3379 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3380 veop, modname, imop);
3381 PL_expect = oexpect;
3382 PL_copline = ocopline;
3387 Perl_dofile(pTHX_ OP *term)
3392 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3393 if (!(gv && GvIMPORTED_CV(gv)))
3394 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3396 if (gv && GvIMPORTED_CV(gv)) {
3397 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3398 append_elem(OP_LIST, term,
3399 scalar(newUNOP(OP_RV2CV, 0,
3404 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3410 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3412 return newBINOP(OP_LSLICE, flags,
3413 list(force_list(subscript)),
3414 list(force_list(listval)) );
3418 S_list_assignment(pTHX_ register OP *o)
3423 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3424 o = cUNOPo->op_first;
3426 if (o->op_type == OP_COND_EXPR) {
3427 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3428 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3433 yyerror("Assignment to both a list and a scalar");
3437 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3438 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3439 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3442 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3445 if (o->op_type == OP_RV2SV)
3452 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3457 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3458 return newLOGOP(optype, 0,
3459 mod(scalar(left), optype),
3460 newUNOP(OP_SASSIGN, 0, scalar(right)));
3463 return newBINOP(optype, OPf_STACKED,
3464 mod(scalar(left), optype), scalar(right));
3468 if (list_assignment(left)) {
3472 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3473 left = mod(left, OP_AASSIGN);
3481 curop = list(force_list(left));
3482 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3483 o->op_private = 0 | (flags >> 8);
3484 for (curop = ((LISTOP*)curop)->op_first;
3485 curop; curop = curop->op_sibling)
3487 if (curop->op_type == OP_RV2HV &&
3488 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3489 o->op_private |= OPpASSIGN_HASH;
3493 if (!(left->op_private & OPpLVAL_INTRO)) {
3496 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3497 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3498 if (curop->op_type == OP_GV) {
3499 GV *gv = cGVOPx_gv(curop);
3500 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3502 SvCUR(gv) = PL_generation;
3504 else if (curop->op_type == OP_PADSV ||
3505 curop->op_type == OP_PADAV ||
3506 curop->op_type == OP_PADHV ||
3507 curop->op_type == OP_PADANY) {
3508 SV **svp = AvARRAY(PL_comppad_name);
3509 SV *sv = svp[curop->op_targ];
3510 if (SvCUR(sv) == PL_generation)
3512 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3514 else if (curop->op_type == OP_RV2CV)
3516 else if (curop->op_type == OP_RV2SV ||
3517 curop->op_type == OP_RV2AV ||
3518 curop->op_type == OP_RV2HV ||
3519 curop->op_type == OP_RV2GV) {
3520 if (lastop->op_type != OP_GV) /* funny deref? */
3523 else if (curop->op_type == OP_PUSHRE) {
3524 if (((PMOP*)curop)->op_pmreplroot) {
3526 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3528 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3530 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3532 SvCUR(gv) = PL_generation;
3541 o->op_private |= OPpASSIGN_COMMON;
3543 if (right && right->op_type == OP_SPLIT) {
3545 if ((tmpop = ((LISTOP*)right)->op_first) &&
3546 tmpop->op_type == OP_PUSHRE)
3548 PMOP *pm = (PMOP*)tmpop;
3549 if (left->op_type == OP_RV2AV &&
3550 !(left->op_private & OPpLVAL_INTRO) &&
3551 !(o->op_private & OPpASSIGN_COMMON) )
3553 tmpop = ((UNOP*)left)->op_first;
3554 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3556 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3557 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3559 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3560 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3562 pm->op_pmflags |= PMf_ONCE;
3563 tmpop = cUNOPo->op_first; /* to list (nulled) */
3564 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3565 tmpop->op_sibling = Nullop; /* don't free split */
3566 right->op_next = tmpop->op_next; /* fix starting loc */
3567 op_free(o); /* blow off assign */
3568 right->op_flags &= ~OPf_WANT;
3569 /* "I don't know and I don't care." */
3574 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3575 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3577 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3579 sv_setiv(sv, PL_modcount+1);
3587 right = newOP(OP_UNDEF, 0);
3588 if (right->op_type == OP_READLINE) {
3589 right->op_flags |= OPf_STACKED;
3590 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3593 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3594 o = newBINOP(OP_SASSIGN, flags,
3595 scalar(right), mod(scalar(left), OP_SASSIGN) );
3607 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3609 U32 seq = intro_my();
3612 NewOp(1101, cop, 1, COP);
3613 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3614 cop->op_type = OP_DBSTATE;
3615 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3618 cop->op_type = OP_NEXTSTATE;
3619 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3621 cop->op_flags = flags;
3622 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3624 cop->op_private |= NATIVE_HINTS;
3626 PL_compiling.op_private = cop->op_private;
3627 cop->op_next = (OP*)cop;
3630 cop->cop_label = label;
3631 PL_hints |= HINT_BLOCK_SCOPE;
3634 cop->cop_arybase = PL_curcop->cop_arybase;
3635 if (specialWARN(PL_curcop->cop_warnings))
3636 cop->cop_warnings = PL_curcop->cop_warnings ;
3638 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3639 if (specialCopIO(PL_curcop->cop_io))
3640 cop->cop_io = PL_curcop->cop_io;
3642 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3645 if (PL_copline == NOLINE)
3646 CopLINE_set(cop, CopLINE(PL_curcop));
3648 CopLINE_set(cop, PL_copline);
3649 PL_copline = NOLINE;
3652 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3654 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3656 CopSTASH_set(cop, PL_curstash);
3658 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3659 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3660 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3661 (void)SvIOK_on(*svp);
3662 SvIVX(*svp) = PTR2IV(cop);
3666 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3669 /* "Introduce" my variables to visible status. */
3677 if (! PL_min_intro_pending)
3678 return PL_cop_seqmax;
3680 svp = AvARRAY(PL_comppad_name);
3681 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3682 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3683 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3684 SvNVX(sv) = (NV)PL_cop_seqmax;
3687 PL_min_intro_pending = 0;
3688 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3689 return PL_cop_seqmax++;
3693 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3695 return new_logop(type, flags, &first, &other);
3699 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3703 OP *first = *firstp;
3704 OP *other = *otherp;
3706 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3707 return newBINOP(type, flags, scalar(first), scalar(other));
3709 scalarboolean(first);
3710 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3711 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3712 if (type == OP_AND || type == OP_OR) {
3718 first = *firstp = cUNOPo->op_first;
3720 first->op_next = o->op_next;
3721 cUNOPo->op_first = Nullop;
3725 if (first->op_type == OP_CONST) {
3726 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3727 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3728 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3739 else if (first->op_type == OP_WANTARRAY) {
3745 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3746 OP *k1 = ((UNOP*)first)->op_first;
3747 OP *k2 = k1->op_sibling;
3749 switch (first->op_type)
3752 if (k2 && k2->op_type == OP_READLINE
3753 && (k2->op_flags & OPf_STACKED)
3754 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3756 warnop = k2->op_type;
3761 if (k1->op_type == OP_READDIR
3762 || k1->op_type == OP_GLOB
3763 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3764 || k1->op_type == OP_EACH)
3766 warnop = ((k1->op_type == OP_NULL)
3767 ? k1->op_targ : k1->op_type);
3772 line_t oldline = CopLINE(PL_curcop);
3773 CopLINE_set(PL_curcop, PL_copline);
3774 Perl_warner(aTHX_ WARN_MISC,
3775 "Value of %s%s can be \"0\"; test with defined()",
3777 ((warnop == OP_READLINE || warnop == OP_GLOB)
3778 ? " construct" : "() operator"));
3779 CopLINE_set(PL_curcop, oldline);
3786 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3787 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3789 NewOp(1101, logop, 1, LOGOP);
3791 logop->op_type = type;
3792 logop->op_ppaddr = PL_ppaddr[type];
3793 logop->op_first = first;
3794 logop->op_flags = flags | OPf_KIDS;
3795 logop->op_other = LINKLIST(other);
3796 logop->op_private = 1 | (flags >> 8);
3798 /* establish postfix order */
3799 logop->op_next = LINKLIST(first);
3800 first->op_next = (OP*)logop;
3801 first->op_sibling = other;
3803 o = newUNOP(OP_NULL, 0, (OP*)logop);
3810 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3817 return newLOGOP(OP_AND, 0, first, trueop);
3819 return newLOGOP(OP_OR, 0, first, falseop);
3821 scalarboolean(first);
3822 if (first->op_type == OP_CONST) {
3823 if (SvTRUE(((SVOP*)first)->op_sv)) {
3834 else if (first->op_type == OP_WANTARRAY) {
3838 NewOp(1101, logop, 1, LOGOP);
3839 logop->op_type = OP_COND_EXPR;
3840 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3841 logop->op_first = first;
3842 logop->op_flags = flags | OPf_KIDS;
3843 logop->op_private = 1 | (flags >> 8);
3844 logop->op_other = LINKLIST(trueop);
3845 logop->op_next = LINKLIST(falseop);
3848 /* establish postfix order */
3849 start = LINKLIST(first);
3850 first->op_next = (OP*)logop;
3852 first->op_sibling = trueop;
3853 trueop->op_sibling = falseop;
3854 o = newUNOP(OP_NULL, 0, (OP*)logop);
3856 trueop->op_next = falseop->op_next = o;
3863 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3871 NewOp(1101, range, 1, LOGOP);
3873 range->op_type = OP_RANGE;
3874 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3875 range->op_first = left;
3876 range->op_flags = OPf_KIDS;
3877 leftstart = LINKLIST(left);
3878 range->op_other = LINKLIST(right);
3879 range->op_private = 1 | (flags >> 8);
3881 left->op_sibling = right;
3883 range->op_next = (OP*)range;
3884 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3885 flop = newUNOP(OP_FLOP, 0, flip);
3886 o = newUNOP(OP_NULL, 0, flop);
3888 range->op_next = leftstart;
3890 left->op_next = flip;
3891 right->op_next = flop;
3893 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3894 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3895 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3896 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3898 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3899 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3902 if (!flip->op_private || !flop->op_private)
3903 linklist(o); /* blow off optimizer unless constant */
3909 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3913 int once = block && block->op_flags & OPf_SPECIAL &&
3914 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3917 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3918 return block; /* do {} while 0 does once */
3919 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3920 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3921 expr = newUNOP(OP_DEFINED, 0,
3922 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3923 } else if (expr->op_flags & OPf_KIDS) {
3924 OP *k1 = ((UNOP*)expr)->op_first;
3925 OP *k2 = (k1) ? k1->op_sibling : NULL;
3926 switch (expr->op_type) {
3928 if (k2 && k2->op_type == OP_READLINE
3929 && (k2->op_flags & OPf_STACKED)
3930 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3931 expr = newUNOP(OP_DEFINED, 0, expr);
3935 if (k1->op_type == OP_READDIR
3936 || k1->op_type == OP_GLOB
3937 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3938 || k1->op_type == OP_EACH)
3939 expr = newUNOP(OP_DEFINED, 0, expr);
3945 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3946 o = new_logop(OP_AND, 0, &expr, &listop);
3949 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3951 if (once && o != listop)
3952 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3955 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3957 o->op_flags |= flags;
3959 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3964 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3972 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3973 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3974 expr = newUNOP(OP_DEFINED, 0,
3975 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3976 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3977 OP *k1 = ((UNOP*)expr)->op_first;
3978 OP *k2 = (k1) ? k1->op_sibling : NULL;
3979 switch (expr->op_type) {
3981 if (k2 && k2->op_type == OP_READLINE
3982 && (k2->op_flags & OPf_STACKED)
3983 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3984 expr = newUNOP(OP_DEFINED, 0, expr);
3988 if (k1->op_type == OP_READDIR
3989 || k1->op_type == OP_GLOB
3990 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3991 || k1->op_type == OP_EACH)
3992 expr = newUNOP(OP_DEFINED, 0, expr);
3998 block = newOP(OP_NULL, 0);
4000 block = scope(block);
4004 next = LINKLIST(cont);
4007 OP *unstack = newOP(OP_UNSTACK, 0);
4010 cont = append_elem(OP_LINESEQ, cont, unstack);
4011 if ((line_t)whileline != NOLINE) {
4012 PL_copline = whileline;
4013 cont = append_elem(OP_LINESEQ, cont,
4014 newSTATEOP(0, Nullch, Nullop));
4018 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4019 redo = LINKLIST(listop);
4022 PL_copline = whileline;
4024 o = new_logop(OP_AND, 0, &expr, &listop);
4025 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4026 op_free(expr); /* oops, it's a while (0) */
4028 return Nullop; /* listop already freed by new_logop */
4031 ((LISTOP*)listop)->op_last->op_next =
4032 (o == listop ? redo : LINKLIST(o));
4038 NewOp(1101,loop,1,LOOP);
4039 loop->op_type = OP_ENTERLOOP;
4040 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4041 loop->op_private = 0;
4042 loop->op_next = (OP*)loop;
4045 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4047 loop->op_redoop = redo;
4048 loop->op_lastop = o;
4049 o->op_private |= loopflags;
4052 loop->op_nextop = next;
4054 loop->op_nextop = o;
4056 o->op_flags |= flags;
4057 o->op_private |= (flags >> 8);
4062 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4070 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4071 sv->op_type = OP_RV2GV;
4072 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4074 else if (sv->op_type == OP_PADSV) { /* private variable */
4075 padoff = sv->op_targ;
4080 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4081 padoff = sv->op_targ;
4083 iterflags |= OPf_SPECIAL;
4088 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4092 padoff = find_threadsv("_");
4093 iterflags |= OPf_SPECIAL;
4095 sv = newGVOP(OP_GV, 0, PL_defgv);
4098 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4099 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4100 iterflags |= OPf_STACKED;
4102 else if (expr->op_type == OP_NULL &&
4103 (expr->op_flags & OPf_KIDS) &&
4104 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4106 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4107 * set the STACKED flag to indicate that these values are to be
4108 * treated as min/max values by 'pp_iterinit'.
4110 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4111 LOGOP* range = (LOGOP*) flip->op_first;
4112 OP* left = range->op_first;
4113 OP* right = left->op_sibling;
4116 range->op_flags &= ~OPf_KIDS;
4117 range->op_first = Nullop;
4119 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4120 listop->op_first->op_next = range->op_next;
4121 left->op_next = range->op_other;
4122 right->op_next = (OP*)listop;
4123 listop->op_next = listop->op_first;
4126 expr = (OP*)(listop);
4128 iterflags |= OPf_STACKED;
4131 expr = mod(force_list(expr), OP_GREPSTART);
4135 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4136 append_elem(OP_LIST, expr, scalar(sv))));
4137 assert(!loop->op_next);
4138 #ifdef PL_OP_SLAB_ALLOC
4141 NewOp(1234,tmp,1,LOOP);
4142 Copy(loop,tmp,1,LOOP);
4146 Renew(loop, 1, LOOP);
4148 loop->op_targ = padoff;
4149 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4150 PL_copline = forline;
4151 return newSTATEOP(0, label, wop);
4155 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4160 if (type != OP_GOTO || label->op_type == OP_CONST) {
4161 /* "last()" means "last" */
4162 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4163 o = newOP(type, OPf_SPECIAL);
4165 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4166 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4172 if (label->op_type == OP_ENTERSUB)
4173 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4174 o = newUNOP(type, OPf_STACKED, label);
4176 PL_hints |= HINT_BLOCK_SCOPE;
4181 Perl_cv_undef(pTHX_ CV *cv)
4185 MUTEX_DESTROY(CvMUTEXP(cv));
4186 Safefree(CvMUTEXP(cv));
4189 #endif /* USE_THREADS */
4192 if (CvFILE(cv) && !CvXSUB(cv)) {
4193 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4194 Safefree(CvFILE(cv));
4199 if (!CvXSUB(cv) && CvROOT(cv)) {
4201 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4202 Perl_croak(aTHX_ "Can't undef active subroutine");
4205 Perl_croak(aTHX_ "Can't undef active subroutine");
4206 #endif /* USE_THREADS */
4209 SAVEVPTR(PL_curpad);
4212 op_free(CvROOT(cv));
4213 CvROOT(cv) = Nullop;
4216 SvPOK_off((SV*)cv); /* forget prototype */
4218 /* Since closure prototypes have the same lifetime as the containing
4219 * CV, they don't hold a refcount on the outside CV. This avoids
4220 * the refcount loop between the outer CV (which keeps a refcount to
4221 * the closure prototype in the pad entry for pp_anoncode()) and the
4222 * closure prototype, and the ensuing memory leak. This does not
4223 * apply to closures generated within eval"", since eval"" CVs are
4224 * ephemeral. --GSAR */
4225 if (!CvANON(cv) || CvCLONED(cv)
4226 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4227 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4229 SvREFCNT_dec(CvOUTSIDE(cv));
4231 CvOUTSIDE(cv) = Nullcv;
4233 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4236 if (CvPADLIST(cv)) {
4237 /* may be during global destruction */
4238 if (SvREFCNT(CvPADLIST(cv))) {
4239 I32 i = AvFILLp(CvPADLIST(cv));
4241 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4242 SV* sv = svp ? *svp : Nullsv;
4245 if (sv == (SV*)PL_comppad_name)
4246 PL_comppad_name = Nullav;
4247 else if (sv == (SV*)PL_comppad) {
4248 PL_comppad = Nullav;
4249 PL_curpad = Null(SV**);
4253 SvREFCNT_dec((SV*)CvPADLIST(cv));
4255 CvPADLIST(cv) = Nullav;
4263 #ifdef DEBUG_CLOSURES
4265 S_cv_dump(pTHX_ CV *cv)
4268 CV *outside = CvOUTSIDE(cv);
4269 AV* padlist = CvPADLIST(cv);
4276 PerlIO_printf(Perl_debug_log,
4277 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4279 (CvANON(cv) ? "ANON"
4280 : (cv == PL_main_cv) ? "MAIN"
4281 : CvUNIQUE(cv) ? "UNIQUE"
4282 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4285 : CvANON(outside) ? "ANON"
4286 : (outside == PL_main_cv) ? "MAIN"
4287 : CvUNIQUE(outside) ? "UNIQUE"
4288 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4293 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4294 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4295 pname = AvARRAY(pad_name);
4296 ppad = AvARRAY(pad);
4298 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4299 if (SvPOK(pname[ix]))
4300 PerlIO_printf(Perl_debug_log,
4301 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4302 (int)ix, PTR2UV(ppad[ix]),
4303 SvFAKE(pname[ix]) ? "FAKE " : "",
4305 (IV)I_32(SvNVX(pname[ix])),
4308 #endif /* DEBUGGING */
4310 #endif /* DEBUG_CLOSURES */
4313 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4317 AV* protopadlist = CvPADLIST(proto);
4318 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4319 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4320 SV** pname = AvARRAY(protopad_name);
4321 SV** ppad = AvARRAY(protopad);
4322 I32 fname = AvFILLp(protopad_name);
4323 I32 fpad = AvFILLp(protopad);
4327 assert(!CvUNIQUE(proto));
4331 SAVESPTR(PL_comppad_name);
4332 SAVESPTR(PL_compcv);
4334 cv = PL_compcv = (CV*)NEWSV(1104,0);
4335 sv_upgrade((SV *)cv, SvTYPE(proto));
4336 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4340 New(666, CvMUTEXP(cv), 1, perl_mutex);
4341 MUTEX_INIT(CvMUTEXP(cv));
4343 #endif /* USE_THREADS */
4345 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4346 : savepv(CvFILE(proto));
4348 CvFILE(cv) = CvFILE(proto);
4350 CvGV(cv) = CvGV(proto);
4351 CvSTASH(cv) = CvSTASH(proto);
4352 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4353 CvSTART(cv) = CvSTART(proto);
4355 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4358 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4360 PL_comppad_name = newAV();
4361 for (ix = fname; ix >= 0; ix--)
4362 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4364 PL_comppad = newAV();
4366 comppadlist = newAV();
4367 AvREAL_off(comppadlist);
4368 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4369 av_store(comppadlist, 1, (SV*)PL_comppad);
4370 CvPADLIST(cv) = comppadlist;
4371 av_fill(PL_comppad, AvFILLp(protopad));
4372 PL_curpad = AvARRAY(PL_comppad);
4374 av = newAV(); /* will be @_ */
4376 av_store(PL_comppad, 0, (SV*)av);
4377 AvFLAGS(av) = AVf_REIFY;
4379 for (ix = fpad; ix > 0; ix--) {
4380 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4381 if (namesv && namesv != &PL_sv_undef) {
4382 char *name = SvPVX(namesv); /* XXX */
4383 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4384 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4385 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4387 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4389 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4391 else { /* our own lexical */
4394 /* anon code -- we'll come back for it */
4395 sv = SvREFCNT_inc(ppad[ix]);
4397 else if (*name == '@')
4399 else if (*name == '%')
4408 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4409 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4412 SV* sv = NEWSV(0,0);
4418 /* Now that vars are all in place, clone nested closures. */
4420 for (ix = fpad; ix > 0; ix--) {
4421 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4423 && namesv != &PL_sv_undef
4424 && !(SvFLAGS(namesv) & SVf_FAKE)
4425 && *SvPVX(namesv) == '&'
4426 && CvCLONE(ppad[ix]))
4428 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4429 SvREFCNT_dec(ppad[ix]);
4432 PL_curpad[ix] = (SV*)kid;
4436 #ifdef DEBUG_CLOSURES
4437 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4439 PerlIO_printf(Perl_debug_log, " from:\n");
4441 PerlIO_printf(Perl_debug_log, " to:\n");
4448 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4450 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4452 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4459 Perl_cv_clone(pTHX_ CV *proto)
4462 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4463 cv = cv_clone2(proto, CvOUTSIDE(proto));
4464 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4469 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4471 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4472 SV* msg = sv_newmortal();
4476 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4477 sv_setpv(msg, "Prototype mismatch:");
4479 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4481 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4482 sv_catpv(msg, " vs ");
4484 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4486 sv_catpv(msg, "none");
4487 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4491 static void const_sv_xsub(pTHXo_ CV* cv);
4494 =for apidoc cv_const_sv
4496 If C<cv> is a constant sub eligible for inlining. returns the constant
4497 value returned by the sub. Otherwise, returns NULL.
4499 Constant subs can be created with C<newCONSTSUB> or as described in
4500 L<perlsub/"Constant Functions">.
4505 Perl_cv_const_sv(pTHX_ CV *cv)
4507 if (!cv || !CvCONST(cv))
4509 return (SV*)CvXSUBANY(cv).any_ptr;
4513 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4520 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4521 o = cLISTOPo->op_first->op_sibling;
4523 for (; o; o = o->op_next) {
4524 OPCODE type = o->op_type;
4526 if (sv && o->op_next == o)
4528 if (o->op_next != o) {
4529 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4531 if (type == OP_DBSTATE)
4534 if (type == OP_LEAVESUB || type == OP_RETURN)
4538 if (type == OP_CONST && cSVOPo->op_sv)
4540 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4541 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4542 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4546 /* We get here only from cv_clone2() while creating a closure.
4547 Copy the const value here instead of in cv_clone2 so that
4548 SvREADONLY_on doesn't lead to problems when leaving
4553 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4565 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4575 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4579 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4581 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4585 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4591 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4596 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4597 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4598 SV *sv = sv_newmortal();
4599 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4600 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4605 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4606 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4616 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4617 maximum a prototype before. */
4618 if (SvTYPE(gv) > SVt_NULL) {
4619 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4620 && ckWARN_d(WARN_PROTOTYPE))
4622 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4624 cv_ckproto((CV*)gv, NULL, ps);
4627 sv_setpv((SV*)gv, ps);
4629 sv_setiv((SV*)gv, -1);
4630 SvREFCNT_dec(PL_compcv);
4631 cv = PL_compcv = NULL;
4632 PL_sub_generation++;
4636 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4638 #ifdef GV_UNIQUE_CHECK
4639 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4640 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4644 if (!block || !ps || *ps || attrs)
4647 const_sv = op_const_sv(block, Nullcv);
4650 bool exists = CvROOT(cv) || CvXSUB(cv);
4652 #ifdef GV_UNIQUE_CHECK
4653 if (exists && GvUNIQUE(gv)) {
4654 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4658 /* if the subroutine doesn't exist and wasn't pre-declared
4659 * with a prototype, assume it will be AUTOLOADed,
4660 * skipping the prototype check
4662 if (exists || SvPOK(cv))
4663 cv_ckproto(cv, gv, ps);
4664 /* already defined (or promised)? */
4665 if (exists || GvASSUMECV(gv)) {
4666 if (!block && !attrs) {
4667 /* just a "sub foo;" when &foo is already defined */
4668 SAVEFREESV(PL_compcv);
4671 /* ahem, death to those who redefine active sort subs */
4672 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4673 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4675 if (ckWARN(WARN_REDEFINE)
4677 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4679 line_t oldline = CopLINE(PL_curcop);
4680 CopLINE_set(PL_curcop, PL_copline);
4681 Perl_warner(aTHX_ WARN_REDEFINE,
4682 CvCONST(cv) ? "Constant subroutine %s redefined"
4683 : "Subroutine %s redefined", name);
4684 CopLINE_set(PL_curcop, oldline);
4692 SvREFCNT_inc(const_sv);
4694 assert(!CvROOT(cv) && !CvCONST(cv));
4695 sv_setpv((SV*)cv, ""); /* prototype is "" */
4696 CvXSUBANY(cv).any_ptr = const_sv;
4697 CvXSUB(cv) = const_sv_xsub;
4702 cv = newCONSTSUB(NULL, name, const_sv);
4705 SvREFCNT_dec(PL_compcv);
4707 PL_sub_generation++;
4714 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4715 * before we clobber PL_compcv.
4719 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4720 stash = GvSTASH(CvGV(cv));
4721 else if (CvSTASH(cv))
4722 stash = CvSTASH(cv);
4724 stash = PL_curstash;
4727 /* possibly about to re-define existing subr -- ignore old cv */
4728 rcv = (SV*)PL_compcv;
4729 if (name && GvSTASH(gv))
4730 stash = GvSTASH(gv);
4732 stash = PL_curstash;
4734 apply_attrs(stash, rcv, attrs);
4736 if (cv) { /* must reuse cv if autoloaded */
4738 /* got here with just attrs -- work done, so bug out */
4739 SAVEFREESV(PL_compcv);
4743 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4744 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4745 CvOUTSIDE(PL_compcv) = 0;
4746 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4747 CvPADLIST(PL_compcv) = 0;
4748 /* inner references to PL_compcv must be fixed up ... */
4750 AV *padlist = CvPADLIST(cv);
4751 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4752 AV *comppad = (AV*)AvARRAY(padlist)[1];
4753 SV **namepad = AvARRAY(comppad_name);
4754 SV **curpad = AvARRAY(comppad);
4755 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4756 SV *namesv = namepad[ix];
4757 if (namesv && namesv != &PL_sv_undef
4758 && *SvPVX(namesv) == '&')
4760 CV *innercv = (CV*)curpad[ix];
4761 if (CvOUTSIDE(innercv) == PL_compcv) {
4762 CvOUTSIDE(innercv) = cv;
4763 if (!CvANON(innercv) || CvCLONED(innercv)) {
4764 (void)SvREFCNT_inc(cv);
4765 SvREFCNT_dec(PL_compcv);
4771 /* ... before we throw it away */
4772 SvREFCNT_dec(PL_compcv);
4773 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4774 ++PL_sub_generation;
4781 PL_sub_generation++;
4785 CvFILE_set_from_cop(cv, PL_curcop);
4786 CvSTASH(cv) = PL_curstash;
4789 if (!CvMUTEXP(cv)) {
4790 New(666, CvMUTEXP(cv), 1, perl_mutex);
4791 MUTEX_INIT(CvMUTEXP(cv));
4793 #endif /* USE_THREADS */
4796 sv_setpv((SV*)cv, ps);
4798 if (PL_error_count) {
4802 char *s = strrchr(name, ':');
4804 if (strEQ(s, "BEGIN")) {
4806 "BEGIN not safe after errors--compilation aborted";
4807 if (PL_in_eval & EVAL_KEEPERR)
4808 Perl_croak(aTHX_ not_safe);
4810 /* force display of errors found but not reported */
4811 sv_catpv(ERRSV, not_safe);
4812 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4820 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4821 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4824 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4825 mod(scalarseq(block), OP_LEAVESUBLV));
4828 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4830 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4831 OpREFCNT_set(CvROOT(cv), 1);
4832 CvSTART(cv) = LINKLIST(CvROOT(cv));
4833 CvROOT(cv)->op_next = 0;
4834 CALL_PEEP(CvSTART(cv));
4836 /* now that optimizer has done its work, adjust pad values */
4838 SV **namep = AvARRAY(PL_comppad_name);
4839 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4842 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4845 * The only things that a clonable function needs in its
4846 * pad are references to outer lexicals and anonymous subs.
4847 * The rest are created anew during cloning.
4849 if (!((namesv = namep[ix]) != Nullsv &&
4850 namesv != &PL_sv_undef &&
4852 *SvPVX(namesv) == '&')))
4854 SvREFCNT_dec(PL_curpad[ix]);
4855 PL_curpad[ix] = Nullsv;
4858 assert(!CvCONST(cv));
4859 if (ps && !*ps && op_const_sv(block, cv))
4863 AV *av = newAV(); /* Will be @_ */
4865 av_store(PL_comppad, 0, (SV*)av);
4866 AvFLAGS(av) = AVf_REIFY;
4868 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4869 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4871 if (!SvPADMY(PL_curpad[ix]))
4872 SvPADTMP_on(PL_curpad[ix]);
4876 /* If a potential closure prototype, don't keep a refcount on
4877 * outer CV, unless the latter happens to be a passing eval"".
4878 * This is okay as the lifetime of the prototype is tied to the
4879 * lifetime of the outer CV. Avoids memory leak due to reference
4881 if (!name && CvOUTSIDE(cv)
4882 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4883 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4885 SvREFCNT_dec(CvOUTSIDE(cv));
4888 if (name || aname) {
4890 char *tname = (name ? name : aname);
4892 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4893 SV *sv = NEWSV(0,0);
4894 SV *tmpstr = sv_newmortal();
4895 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4899 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4901 (long)PL_subline, (long)CopLINE(PL_curcop));
4902 gv_efullname3(tmpstr, gv, Nullch);
4903 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4904 hv = GvHVn(db_postponed);
4905 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4906 && (pcv = GvCV(db_postponed)))
4912 call_sv((SV*)pcv, G_DISCARD);
4916 if ((s = strrchr(tname,':')))
4921 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4924 if (strEQ(s, "BEGIN")) {
4925 I32 oldscope = PL_scopestack_ix;
4927 SAVECOPFILE(&PL_compiling);
4928 SAVECOPLINE(&PL_compiling);
4930 sv_setsv(PL_rs, PL_nrs);
4933 PL_beginav = newAV();
4934 DEBUG_x( dump_sub(gv) );
4935 av_push(PL_beginav, (SV*)cv);
4936 GvCV(gv) = 0; /* cv has been hijacked */
4937 call_list(oldscope, PL_beginav);
4939 PL_curcop = &PL_compiling;
4940 PL_compiling.op_private = PL_hints;
4943 else if (strEQ(s, "END") && !PL_error_count) {
4946 DEBUG_x( dump_sub(gv) );
4947 av_unshift(PL_endav, 1);
4948 av_store(PL_endav, 0, (SV*)cv);
4949 GvCV(gv) = 0; /* cv has been hijacked */
4951 else if (strEQ(s, "CHECK") && !PL_error_count) {
4953 PL_checkav = newAV();
4954 DEBUG_x( dump_sub(gv) );
4955 if (PL_main_start && ckWARN(WARN_VOID))
4956 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4957 av_unshift(PL_checkav, 1);
4958 av_store(PL_checkav, 0, (SV*)cv);
4959 GvCV(gv) = 0; /* cv has been hijacked */
4961 else if (strEQ(s, "INIT") && !PL_error_count) {
4963 PL_initav = newAV();
4964 DEBUG_x( dump_sub(gv) );
4965 if (PL_main_start && ckWARN(WARN_VOID))
4966 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4967 av_push(PL_initav, (SV*)cv);
4968 GvCV(gv) = 0; /* cv has been hijacked */
4973 PL_copline = NOLINE;
4978 /* XXX unsafe for threads if eval_owner isn't held */
4980 =for apidoc newCONSTSUB
4982 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4983 eligible for inlining at compile-time.
4989 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4995 SAVECOPLINE(PL_curcop);
4996 CopLINE_set(PL_curcop, PL_copline);
4999 PL_hints &= ~HINT_BLOCK_SCOPE;
5002 SAVESPTR(PL_curstash);
5003 SAVECOPSTASH(PL_curcop);
5004 PL_curstash = stash;
5006 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5008 CopSTASH(PL_curcop) = stash;
5012 cv = newXS(name, const_sv_xsub, __FILE__);
5013 CvXSUBANY(cv).any_ptr = sv;
5015 sv_setpv((SV*)cv, ""); /* prototype is "" */
5023 =for apidoc U||newXS
5025 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5031 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5033 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5036 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5038 /* just a cached method */
5042 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5043 /* already defined (or promised) */
5044 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5045 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5046 line_t oldline = CopLINE(PL_curcop);
5047 if (PL_copline != NOLINE)
5048 CopLINE_set(PL_curcop, PL_copline);
5049 Perl_warner(aTHX_ WARN_REDEFINE,
5050 CvCONST(cv) ? "Constant subroutine %s redefined"
5051 : "Subroutine %s redefined"
5053 CopLINE_set(PL_curcop, oldline);
5060 if (cv) /* must reuse cv if autoloaded */
5063 cv = (CV*)NEWSV(1105,0);
5064 sv_upgrade((SV *)cv, SVt_PVCV);
5068 PL_sub_generation++;
5073 New(666, CvMUTEXP(cv), 1, perl_mutex);
5074 MUTEX_INIT(CvMUTEXP(cv));
5076 #endif /* USE_THREADS */
5077 (void)gv_fetchfile(filename);
5078 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5079 an external constant string */
5080 CvXSUB(cv) = subaddr;
5083 char *s = strrchr(name,':');
5089 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5092 if (strEQ(s, "BEGIN")) {
5094 PL_beginav = newAV();
5095 av_push(PL_beginav, (SV*)cv);
5096 GvCV(gv) = 0; /* cv has been hijacked */
5098 else if (strEQ(s, "END")) {
5101 av_unshift(PL_endav, 1);
5102 av_store(PL_endav, 0, (SV*)cv);
5103 GvCV(gv) = 0; /* cv has been hijacked */
5105 else if (strEQ(s, "CHECK")) {
5107 PL_checkav = newAV();
5108 if (PL_main_start && ckWARN(WARN_VOID))
5109 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5110 av_unshift(PL_checkav, 1);
5111 av_store(PL_checkav, 0, (SV*)cv);
5112 GvCV(gv) = 0; /* cv has been hijacked */
5114 else if (strEQ(s, "INIT")) {
5116 PL_initav = newAV();
5117 if (PL_main_start && ckWARN(WARN_VOID))
5118 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5119 av_push(PL_initav, (SV*)cv);
5120 GvCV(gv) = 0; /* cv has been hijacked */
5131 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5140 name = SvPVx(cSVOPo->op_sv, n_a);
5143 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5144 #ifdef GV_UNIQUE_CHECK
5146 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5150 if ((cv = GvFORM(gv))) {
5151 if (ckWARN(WARN_REDEFINE)) {
5152 line_t oldline = CopLINE(PL_curcop);
5154 CopLINE_set(PL_curcop, PL_copline);
5155 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5156 CopLINE_set(PL_curcop, oldline);
5163 CvFILE_set_from_cop(cv, PL_curcop);
5165 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5166 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5167 SvPADTMP_on(PL_curpad[ix]);
5170 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5171 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5172 OpREFCNT_set(CvROOT(cv), 1);
5173 CvSTART(cv) = LINKLIST(CvROOT(cv));
5174 CvROOT(cv)->op_next = 0;
5175 CALL_PEEP(CvSTART(cv));
5177 PL_copline = NOLINE;
5182 Perl_newANONLIST(pTHX_ OP *o)
5184 return newUNOP(OP_REFGEN, 0,
5185 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5189 Perl_newANONHASH(pTHX_ OP *o)
5191 return newUNOP(OP_REFGEN, 0,
5192 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5196 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5198 return newANONATTRSUB(floor, proto, Nullop, block);
5202 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5204 return newUNOP(OP_REFGEN, 0,
5205 newSVOP(OP_ANONCODE, 0,
5206 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5210 Perl_oopsAV(pTHX_ OP *o)
5212 switch (o->op_type) {
5214 o->op_type = OP_PADAV;
5215 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5216 return ref(o, OP_RV2AV);
5219 o->op_type = OP_RV2AV;
5220 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5225 if (ckWARN_d(WARN_INTERNAL))
5226 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5233 Perl_oopsHV(pTHX_ OP *o)
5235 switch (o->op_type) {
5238 o->op_type = OP_PADHV;
5239 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5240 return ref(o, OP_RV2HV);
5244 o->op_type = OP_RV2HV;
5245 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5250 if (ckWARN_d(WARN_INTERNAL))
5251 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5258 Perl_newAVREF(pTHX_ OP *o)
5260 if (o->op_type == OP_PADANY) {
5261 o->op_type = OP_PADAV;
5262 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5265 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5266 && ckWARN(WARN_DEPRECATED)) {
5267 Perl_warner(aTHX_ WARN_DEPRECATED,
5268 "Using an array as a reference is deprecated");
5270 return newUNOP(OP_RV2AV, 0, scalar(o));
5274 Perl_newGVREF(pTHX_ I32 type, OP *o)
5276 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5277 return newUNOP(OP_NULL, 0, o);
5278 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5282 Perl_newHVREF(pTHX_ OP *o)
5284 if (o->op_type == OP_PADANY) {
5285 o->op_type = OP_PADHV;
5286 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5289 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5290 && ckWARN(WARN_DEPRECATED)) {
5291 Perl_warner(aTHX_ WARN_DEPRECATED,
5292 "Using a hash as a reference is deprecated");
5294 return newUNOP(OP_RV2HV, 0, scalar(o));
5298 Perl_oopsCV(pTHX_ OP *o)
5300 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5306 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5308 return newUNOP(OP_RV2CV, flags, scalar(o));
5312 Perl_newSVREF(pTHX_ OP *o)
5314 if (o->op_type == OP_PADANY) {
5315 o->op_type = OP_PADSV;
5316 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5319 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5320 o->op_flags |= OPpDONE_SVREF;
5323 return newUNOP(OP_RV2SV, 0, scalar(o));
5326 /* Check routines. */
5329 Perl_ck_anoncode(pTHX_ OP *o)
5334 name = NEWSV(1106,0);
5335 sv_upgrade(name, SVt_PVNV);
5336 sv_setpvn(name, "&", 1);
5339 ix = pad_alloc(o->op_type, SVs_PADMY);
5340 av_store(PL_comppad_name, ix, name);
5341 av_store(PL_comppad, ix, cSVOPo->op_sv);
5342 SvPADMY_on(cSVOPo->op_sv);
5343 cSVOPo->op_sv = Nullsv;
5344 cSVOPo->op_targ = ix;
5349 Perl_ck_bitop(pTHX_ OP *o)
5351 o->op_private = PL_hints;
5356 Perl_ck_concat(pTHX_ OP *o)
5358 if (cUNOPo->op_first->op_type == OP_CONCAT)
5359 o->op_flags |= OPf_STACKED;
5364 Perl_ck_spair(pTHX_ OP *o)
5366 if (o->op_flags & OPf_KIDS) {
5369 OPCODE type = o->op_type;
5370 o = modkids(ck_fun(o), type);
5371 kid = cUNOPo->op_first;
5372 newop = kUNOP->op_first->op_sibling;
5374 (newop->op_sibling ||
5375 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5376 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5377 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5381 op_free(kUNOP->op_first);
5382 kUNOP->op_first = newop;
5384 o->op_ppaddr = PL_ppaddr[++o->op_type];
5389 Perl_ck_delete(pTHX_ OP *o)
5393 if (o->op_flags & OPf_KIDS) {
5394 OP *kid = cUNOPo->op_first;
5395 switch (kid->op_type) {
5397 o->op_flags |= OPf_SPECIAL;
5400 o->op_private |= OPpSLICE;
5403 o->op_flags |= OPf_SPECIAL;
5408 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5409 PL_op_desc[o->op_type]);
5417 Perl_ck_eof(pTHX_ OP *o)
5419 I32 type = o->op_type;
5421 if (o->op_flags & OPf_KIDS) {
5422 if (cLISTOPo->op_first->op_type == OP_STUB) {
5424 o = newUNOP(type, OPf_SPECIAL,
5425 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5433 Perl_ck_eval(pTHX_ OP *o)
5435 PL_hints |= HINT_BLOCK_SCOPE;
5436 if (o->op_flags & OPf_KIDS) {
5437 SVOP *kid = (SVOP*)cUNOPo->op_first;
5440 o->op_flags &= ~OPf_KIDS;
5443 else if (kid->op_type == OP_LINESEQ) {
5446 kid->op_next = o->op_next;
5447 cUNOPo->op_first = 0;
5450 NewOp(1101, enter, 1, LOGOP);
5451 enter->op_type = OP_ENTERTRY;
5452 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5453 enter->op_private = 0;
5455 /* establish postfix order */
5456 enter->op_next = (OP*)enter;
5458 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5459 o->op_type = OP_LEAVETRY;
5460 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5461 enter->op_other = o;
5469 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5471 o->op_targ = (PADOFFSET)PL_hints;
5476 Perl_ck_exit(pTHX_ OP *o)
5479 HV *table = GvHV(PL_hintgv);
5481 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5482 if (svp && *svp && SvTRUE(*svp))
5483 o->op_private |= OPpEXIT_VMSISH;
5490 Perl_ck_exec(pTHX_ OP *o)
5493 if (o->op_flags & OPf_STACKED) {
5495 kid = cUNOPo->op_first->op_sibling;
5496 if (kid->op_type == OP_RV2GV)
5505 Perl_ck_exists(pTHX_ OP *o)
5508 if (o->op_flags & OPf_KIDS) {
5509 OP *kid = cUNOPo->op_first;
5510 if (kid->op_type == OP_ENTERSUB) {
5511 (void) ref(kid, o->op_type);
5512 if (kid->op_type != OP_RV2CV && !PL_error_count)
5513 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5514 PL_op_desc[o->op_type]);
5515 o->op_private |= OPpEXISTS_SUB;
5517 else if (kid->op_type == OP_AELEM)
5518 o->op_flags |= OPf_SPECIAL;
5519 else if (kid->op_type != OP_HELEM)
5520 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5521 PL_op_desc[o->op_type]);
5529 Perl_ck_gvconst(pTHX_ register OP *o)
5531 o = fold_constants(o);
5532 if (o->op_type == OP_CONST)
5539 Perl_ck_rvconst(pTHX_ register OP *o)
5541 SVOP *kid = (SVOP*)cUNOPo->op_first;
5543 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5544 if (kid->op_type == OP_CONST) {
5548 SV *kidsv = kid->op_sv;
5551 /* Is it a constant from cv_const_sv()? */
5552 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5553 SV *rsv = SvRV(kidsv);
5554 int svtype = SvTYPE(rsv);
5555 char *badtype = Nullch;
5557 switch (o->op_type) {
5559 if (svtype > SVt_PVMG)
5560 badtype = "a SCALAR";
5563 if (svtype != SVt_PVAV)
5564 badtype = "an ARRAY";
5567 if (svtype != SVt_PVHV) {
5568 if (svtype == SVt_PVAV) { /* pseudohash? */
5569 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5570 if (ksv && SvROK(*ksv)
5571 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5580 if (svtype != SVt_PVCV)
5585 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5588 name = SvPV(kidsv, n_a);
5589 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5590 char *badthing = Nullch;
5591 switch (o->op_type) {
5593 badthing = "a SCALAR";
5596 badthing = "an ARRAY";
5599 badthing = "a HASH";
5604 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5608 * This is a little tricky. We only want to add the symbol if we
5609 * didn't add it in the lexer. Otherwise we get duplicate strict
5610 * warnings. But if we didn't add it in the lexer, we must at
5611 * least pretend like we wanted to add it even if it existed before,
5612 * or we get possible typo warnings. OPpCONST_ENTERED says
5613 * whether the lexer already added THIS instance of this symbol.
5615 iscv = (o->op_type == OP_RV2CV) * 2;
5617 gv = gv_fetchpv(name,
5618 iscv | !(kid->op_private & OPpCONST_ENTERED),
5621 : o->op_type == OP_RV2SV
5623 : o->op_type == OP_RV2AV
5625 : o->op_type == OP_RV2HV
5628 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5630 kid->op_type = OP_GV;
5631 SvREFCNT_dec(kid->op_sv);
5633 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5634 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5635 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5637 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5639 kid->op_sv = SvREFCNT_inc(gv);
5641 kid->op_private = 0;
5642 kid->op_ppaddr = PL_ppaddr[OP_GV];
5649 Perl_ck_ftst(pTHX_ OP *o)
5651 I32 type = o->op_type;
5653 if (o->op_flags & OPf_REF) {
5656 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5657 SVOP *kid = (SVOP*)cUNOPo->op_first;
5659 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5661 OP *newop = newGVOP(type, OPf_REF,
5662 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5669 if (type == OP_FTTTY)
5670 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5673 o = newUNOP(type, 0, newDEFSVOP());
5679 Perl_ck_fun(pTHX_ OP *o)
5685 int type = o->op_type;
5686 register I32 oa = PL_opargs[type] >> OASHIFT;
5688 if (o->op_flags & OPf_STACKED) {
5689 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5692 return no_fh_allowed(o);
5695 if (o->op_flags & OPf_KIDS) {
5697 tokid = &cLISTOPo->op_first;
5698 kid = cLISTOPo->op_first;
5699 if (kid->op_type == OP_PUSHMARK ||
5700 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5702 tokid = &kid->op_sibling;
5703 kid = kid->op_sibling;
5705 if (!kid && PL_opargs[type] & OA_DEFGV)
5706 *tokid = kid = newDEFSVOP();
5710 sibl = kid->op_sibling;
5713 /* list seen where single (scalar) arg expected? */
5714 if (numargs == 1 && !(oa >> 4)
5715 && kid->op_type == OP_LIST && type != OP_SCALAR)
5717 return too_many_arguments(o,PL_op_desc[type]);
5730 if ((type == OP_PUSH || type == OP_UNSHIFT)
5731 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5732 Perl_warner(aTHX_ WARN_SYNTAX,
5733 "Useless use of %s with no values",
5736 if (kid->op_type == OP_CONST &&
5737 (kid->op_private & OPpCONST_BARE))
5739 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5740 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5741 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5742 if (ckWARN(WARN_DEPRECATED))
5743 Perl_warner(aTHX_ WARN_DEPRECATED,
5744 "Array @%s missing the @ in argument %"IVdf" of %s()",
5745 name, (IV)numargs, PL_op_desc[type]);
5748 kid->op_sibling = sibl;
5751 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5752 bad_type(numargs, "array", PL_op_desc[type], kid);
5756 if (kid->op_type == OP_CONST &&
5757 (kid->op_private & OPpCONST_BARE))
5759 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5760 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5761 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5762 if (ckWARN(WARN_DEPRECATED))
5763 Perl_warner(aTHX_ WARN_DEPRECATED,
5764 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5765 name, (IV)numargs, PL_op_desc[type]);
5768 kid->op_sibling = sibl;
5771 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5772 bad_type(numargs, "hash", PL_op_desc[type], kid);
5777 OP *newop = newUNOP(OP_NULL, 0, kid);
5778 kid->op_sibling = 0;
5780 newop->op_next = newop;
5782 kid->op_sibling = sibl;
5787 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5788 if (kid->op_type == OP_CONST &&
5789 (kid->op_private & OPpCONST_BARE))
5791 OP *newop = newGVOP(OP_GV, 0,
5792 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5797 else if (kid->op_type == OP_READLINE) {
5798 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5799 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5802 I32 flags = OPf_SPECIAL;
5806 /* is this op a FH constructor? */
5807 if (is_handle_constructor(o,numargs)) {
5808 char *name = Nullch;
5812 /* Set a flag to tell rv2gv to vivify
5813 * need to "prove" flag does not mean something
5814 * else already - NI-S 1999/05/07
5817 if (kid->op_type == OP_PADSV) {
5818 SV **namep = av_fetch(PL_comppad_name,
5820 if (namep && *namep)
5821 name = SvPV(*namep, len);
5823 else if (kid->op_type == OP_RV2SV
5824 && kUNOP->op_first->op_type == OP_GV)
5826 GV *gv = cGVOPx_gv(kUNOP->op_first);
5828 len = GvNAMELEN(gv);
5830 else if (kid->op_type == OP_AELEM
5831 || kid->op_type == OP_HELEM)
5833 name = "__ANONIO__";
5839 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5840 namesv = PL_curpad[targ];
5841 (void)SvUPGRADE(namesv, SVt_PV);
5843 sv_setpvn(namesv, "$", 1);
5844 sv_catpvn(namesv, name, len);
5847 kid->op_sibling = 0;
5848 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5849 kid->op_targ = targ;
5850 kid->op_private |= priv;
5852 kid->op_sibling = sibl;
5858 mod(scalar(kid), type);
5862 tokid = &kid->op_sibling;
5863 kid = kid->op_sibling;
5865 o->op_private |= numargs;
5867 return too_many_arguments(o,PL_op_desc[o->op_type]);
5870 else if (PL_opargs[type] & OA_DEFGV) {
5872 return newUNOP(type, 0, newDEFSVOP());
5876 while (oa & OA_OPTIONAL)
5878 if (oa && oa != OA_LIST)
5879 return too_few_arguments(o,PL_op_desc[o->op_type]);
5885 Perl_ck_glob(pTHX_ OP *o)
5890 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5891 append_elem(OP_GLOB, o, newDEFSVOP());
5893 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5894 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5896 #if !defined(PERL_EXTERNAL_GLOB)
5897 /* XXX this can be tightened up and made more failsafe. */
5901 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5903 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5904 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5905 GvCV(gv) = GvCV(glob_gv);
5906 SvREFCNT_inc((SV*)GvCV(gv));
5907 GvIMPORTED_CV_on(gv);
5910 #endif /* PERL_EXTERNAL_GLOB */
5912 if (gv && GvIMPORTED_CV(gv)) {
5913 append_elem(OP_GLOB, o,
5914 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5915 o->op_type = OP_LIST;
5916 o->op_ppaddr = PL_ppaddr[OP_LIST];
5917 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5918 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5919 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5920 append_elem(OP_LIST, o,
5921 scalar(newUNOP(OP_RV2CV, 0,
5922 newGVOP(OP_GV, 0, gv)))));
5923 o = newUNOP(OP_NULL, 0, ck_subr(o));
5924 o->op_targ = OP_GLOB; /* hint at what it used to be */
5927 gv = newGVgen("main");
5929 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5935 Perl_ck_grep(pTHX_ OP *o)
5939 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5941 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5942 NewOp(1101, gwop, 1, LOGOP);
5944 if (o->op_flags & OPf_STACKED) {
5947 kid = cLISTOPo->op_first->op_sibling;
5948 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5951 kid->op_next = (OP*)gwop;
5952 o->op_flags &= ~OPf_STACKED;
5954 kid = cLISTOPo->op_first->op_sibling;
5955 if (type == OP_MAPWHILE)
5962 kid = cLISTOPo->op_first->op_sibling;
5963 if (kid->op_type != OP_NULL)
5964 Perl_croak(aTHX_ "panic: ck_grep");
5965 kid = kUNOP->op_first;
5967 gwop->op_type = type;
5968 gwop->op_ppaddr = PL_ppaddr[type];
5969 gwop->op_first = listkids(o);
5970 gwop->op_flags |= OPf_KIDS;
5971 gwop->op_private = 1;
5972 gwop->op_other = LINKLIST(kid);
5973 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5974 kid->op_next = (OP*)gwop;
5976 kid = cLISTOPo->op_first->op_sibling;
5977 if (!kid || !kid->op_sibling)
5978 return too_few_arguments(o,PL_op_desc[o->op_type]);
5979 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5980 mod(kid, OP_GREPSTART);
5986 Perl_ck_index(pTHX_ OP *o)
5988 if (o->op_flags & OPf_KIDS) {
5989 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5991 kid = kid->op_sibling; /* get past "big" */
5992 if (kid && kid->op_type == OP_CONST)
5993 fbm_compile(((SVOP*)kid)->op_sv, 0);
5999 Perl_ck_lengthconst(pTHX_ OP *o)
6001 /* XXX length optimization goes here */
6006 Perl_ck_lfun(pTHX_ OP *o)
6008 OPCODE type = o->op_type;
6009 return modkids(ck_fun(o), type);
6013 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6015 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6016 switch (cUNOPo->op_first->op_type) {
6018 /* This is needed for
6019 if (defined %stash::)
6020 to work. Do not break Tk.
6022 break; /* Globals via GV can be undef */
6024 case OP_AASSIGN: /* Is this a good idea? */
6025 Perl_warner(aTHX_ WARN_DEPRECATED,
6026 "defined(@array) is deprecated");
6027 Perl_warner(aTHX_ WARN_DEPRECATED,
6028 "\t(Maybe you should just omit the defined()?)\n");
6031 /* This is needed for
6032 if (defined %stash::)
6033 to work. Do not break Tk.
6035 break; /* Globals via GV can be undef */
6037 Perl_warner(aTHX_ WARN_DEPRECATED,
6038 "defined(%%hash) is deprecated");
6039 Perl_warner(aTHX_ WARN_DEPRECATED,
6040 "\t(Maybe you should just omit the defined()?)\n");
6051 Perl_ck_rfun(pTHX_ OP *o)
6053 OPCODE type = o->op_type;
6054 return refkids(ck_fun(o), type);
6058 Perl_ck_listiob(pTHX_ OP *o)
6062 kid = cLISTOPo->op_first;
6065 kid = cLISTOPo->op_first;
6067 if (kid->op_type == OP_PUSHMARK)
6068 kid = kid->op_sibling;
6069 if (kid && o->op_flags & OPf_STACKED)
6070 kid = kid->op_sibling;
6071 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6072 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6073 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6074 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6075 cLISTOPo->op_first->op_sibling = kid;
6076 cLISTOPo->op_last = kid;
6077 kid = kid->op_sibling;
6082 append_elem(o->op_type, o, newDEFSVOP());
6088 Perl_ck_sassign(pTHX_ OP *o)
6090 OP *kid = cLISTOPo->op_first;
6091 /* has a disposable target? */
6092 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6093 && !(kid->op_flags & OPf_STACKED)
6094 /* Cannot steal the second time! */
6095 && !(kid->op_private & OPpTARGET_MY))
6097 OP *kkid = kid->op_sibling;
6099 /* Can just relocate the target. */
6100 if (kkid && kkid->op_type == OP_PADSV
6101 && !(kkid->op_private & OPpLVAL_INTRO))
6103 kid->op_targ = kkid->op_targ;
6105 /* Now we do not need PADSV and SASSIGN. */
6106 kid->op_sibling = o->op_sibling; /* NULL */
6107 cLISTOPo->op_first = NULL;
6110 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6118 Perl_ck_match(pTHX_ OP *o)
6120 o->op_private |= OPpRUNTIME;
6125 Perl_ck_method(pTHX_ OP *o)
6127 OP *kid = cUNOPo->op_first;
6128 if (kid->op_type == OP_CONST) {
6129 SV* sv = kSVOP->op_sv;
6130 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6132 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6133 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6136 kSVOP->op_sv = Nullsv;
6138 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6147 Perl_ck_null(pTHX_ OP *o)
6153 Perl_ck_open(pTHX_ OP *o)
6155 HV *table = GvHV(PL_hintgv);
6159 svp = hv_fetch(table, "open_IN", 7, FALSE);
6161 mode = mode_from_discipline(*svp);
6162 if (mode & O_BINARY)
6163 o->op_private |= OPpOPEN_IN_RAW;
6164 else if (mode & O_TEXT)
6165 o->op_private |= OPpOPEN_IN_CRLF;
6168 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6170 mode = mode_from_discipline(*svp);
6171 if (mode & O_BINARY)
6172 o->op_private |= OPpOPEN_OUT_RAW;
6173 else if (mode & O_TEXT)
6174 o->op_private |= OPpOPEN_OUT_CRLF;
6177 if (o->op_type == OP_BACKTICK)
6183 Perl_ck_repeat(pTHX_ OP *o)
6185 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6186 o->op_private |= OPpREPEAT_DOLIST;
6187 cBINOPo->op_first = force_list(cBINOPo->op_first);
6195 Perl_ck_require(pTHX_ OP *o)
6199 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6200 SVOP *kid = (SVOP*)cUNOPo->op_first;
6202 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6204 for (s = SvPVX(kid->op_sv); *s; s++) {
6205 if (*s == ':' && s[1] == ':') {
6207 Move(s+2, s+1, strlen(s+2)+1, char);
6208 --SvCUR(kid->op_sv);
6211 if (SvREADONLY(kid->op_sv)) {
6212 SvREADONLY_off(kid->op_sv);
6213 sv_catpvn(kid->op_sv, ".pm", 3);
6214 SvREADONLY_on(kid->op_sv);
6217 sv_catpvn(kid->op_sv, ".pm", 3);
6221 /* handle override, if any */
6222 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6223 if (!(gv && GvIMPORTED_CV(gv)))
6224 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6226 if (gv && GvIMPORTED_CV(gv)) {
6227 OP *kid = cUNOPo->op_first;
6228 cUNOPo->op_first = 0;
6230 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6231 append_elem(OP_LIST, kid,
6232 scalar(newUNOP(OP_RV2CV, 0,
6241 Perl_ck_return(pTHX_ OP *o)
6244 if (CvLVALUE(PL_compcv)) {
6245 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6246 mod(kid, OP_LEAVESUBLV);
6253 Perl_ck_retarget(pTHX_ OP *o)
6255 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6262 Perl_ck_select(pTHX_ OP *o)
6265 if (o->op_flags & OPf_KIDS) {
6266 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6267 if (kid && kid->op_sibling) {
6268 o->op_type = OP_SSELECT;
6269 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6271 return fold_constants(o);
6275 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6276 if (kid && kid->op_type == OP_RV2GV)
6277 kid->op_private &= ~HINT_STRICT_REFS;
6282 Perl_ck_shift(pTHX_ OP *o)
6284 I32 type = o->op_type;
6286 if (!(o->op_flags & OPf_KIDS)) {
6291 if (!CvUNIQUE(PL_compcv)) {
6292 argop = newOP(OP_PADAV, OPf_REF);
6293 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6296 argop = newUNOP(OP_RV2AV, 0,
6297 scalar(newGVOP(OP_GV, 0,
6298 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6301 argop = newUNOP(OP_RV2AV, 0,
6302 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6303 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6304 #endif /* USE_THREADS */
6305 return newUNOP(type, 0, scalar(argop));
6307 return scalar(modkids(ck_fun(o), type));
6311 Perl_ck_sort(pTHX_ OP *o)
6315 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6317 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6318 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6320 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6322 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6324 if (kid->op_type == OP_SCOPE) {
6328 else if (kid->op_type == OP_LEAVE) {
6329 if (o->op_type == OP_SORT) {
6330 op_null(kid); /* wipe out leave */
6333 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6334 if (k->op_next == kid)
6336 /* don't descend into loops */
6337 else if (k->op_type == OP_ENTERLOOP
6338 || k->op_type == OP_ENTERITER)
6340 k = cLOOPx(k)->op_lastop;
6345 kid->op_next = 0; /* just disconnect the leave */
6346 k = kLISTOP->op_first;
6351 if (o->op_type == OP_SORT) {
6352 /* provide scalar context for comparison function/block */
6358 o->op_flags |= OPf_SPECIAL;
6360 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6363 firstkid = firstkid->op_sibling;
6366 /* provide list context for arguments */
6367 if (o->op_type == OP_SORT)
6374 S_simplify_sort(pTHX_ OP *o)
6376 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6380 if (!(o->op_flags & OPf_STACKED))
6382 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6383 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6384 kid = kUNOP->op_first; /* get past null */
6385 if (kid->op_type != OP_SCOPE)
6387 kid = kLISTOP->op_last; /* get past scope */
6388 switch(kid->op_type) {
6396 k = kid; /* remember this node*/
6397 if (kBINOP->op_first->op_type != OP_RV2SV)
6399 kid = kBINOP->op_first; /* get past cmp */
6400 if (kUNOP->op_first->op_type != OP_GV)
6402 kid = kUNOP->op_first; /* get past rv2sv */
6404 if (GvSTASH(gv) != PL_curstash)
6406 if (strEQ(GvNAME(gv), "a"))
6408 else if (strEQ(GvNAME(gv), "b"))
6412 kid = k; /* back to cmp */
6413 if (kBINOP->op_last->op_type != OP_RV2SV)
6415 kid = kBINOP->op_last; /* down to 2nd arg */
6416 if (kUNOP->op_first->op_type != OP_GV)
6418 kid = kUNOP->op_first; /* get past rv2sv */
6420 if (GvSTASH(gv) != PL_curstash
6422 ? strNE(GvNAME(gv), "a")
6423 : strNE(GvNAME(gv), "b")))
6425 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6427 o->op_private |= OPpSORT_REVERSE;
6428 if (k->op_type == OP_NCMP)
6429 o->op_private |= OPpSORT_NUMERIC;
6430 if (k->op_type == OP_I_NCMP)
6431 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6432 kid = cLISTOPo->op_first->op_sibling;
6433 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6434 op_free(kid); /* then delete it */
6438 Perl_ck_split(pTHX_ OP *o)
6442 if (o->op_flags & OPf_STACKED)
6443 return no_fh_allowed(o);
6445 kid = cLISTOPo->op_first;
6446 if (kid->op_type != OP_NULL)
6447 Perl_croak(aTHX_ "panic: ck_split");
6448 kid = kid->op_sibling;
6449 op_free(cLISTOPo->op_first);
6450 cLISTOPo->op_first = kid;
6452 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6453 cLISTOPo->op_last = kid; /* There was only one element previously */
6456 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6457 OP *sibl = kid->op_sibling;
6458 kid->op_sibling = 0;
6459 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6460 if (cLISTOPo->op_first == cLISTOPo->op_last)
6461 cLISTOPo->op_last = kid;
6462 cLISTOPo->op_first = kid;
6463 kid->op_sibling = sibl;
6466 kid->op_type = OP_PUSHRE;
6467 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6470 if (!kid->op_sibling)
6471 append_elem(OP_SPLIT, o, newDEFSVOP());
6473 kid = kid->op_sibling;
6476 if (!kid->op_sibling)
6477 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6479 kid = kid->op_sibling;
6482 if (kid->op_sibling)
6483 return too_many_arguments(o,PL_op_desc[o->op_type]);
6489 Perl_ck_join(pTHX_ OP *o)
6491 if (ckWARN(WARN_SYNTAX)) {
6492 OP *kid = cLISTOPo->op_first->op_sibling;
6493 if (kid && kid->op_type == OP_MATCH) {
6494 char *pmstr = "STRING";
6495 if (PM_GETRE(kPMOP))
6496 pmstr = PM_GETRE(kPMOP)->precomp;
6497 Perl_warner(aTHX_ WARN_SYNTAX,
6498 "/%s/ should probably be written as \"%s\"",
6506 Perl_ck_subr(pTHX_ OP *o)
6508 OP *prev = ((cUNOPo->op_first->op_sibling)
6509 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6510 OP *o2 = prev->op_sibling;
6519 o->op_private |= OPpENTERSUB_HASTARG;
6520 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6521 if (cvop->op_type == OP_RV2CV) {
6523 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6524 op_null(cvop); /* disable rv2cv */
6525 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6526 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6527 GV *gv = cGVOPx_gv(tmpop);
6530 tmpop->op_private |= OPpEARLY_CV;
6531 else if (SvPOK(cv)) {
6532 namegv = CvANON(cv) ? gv : CvGV(cv);
6533 proto = SvPV((SV*)cv, n_a);
6537 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6538 if (o2->op_type == OP_CONST)
6539 o2->op_private &= ~OPpCONST_STRICT;
6540 else if (o2->op_type == OP_LIST) {
6541 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6542 if (o && o->op_type == OP_CONST)
6543 o->op_private &= ~OPpCONST_STRICT;
6546 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6547 if (PERLDB_SUB && PL_curstash != PL_debstash)
6548 o->op_private |= OPpENTERSUB_DB;
6549 while (o2 != cvop) {
6553 return too_many_arguments(o, gv_ename(namegv));
6571 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6573 arg == 1 ? "block or sub {}" : "sub {}",
6574 gv_ename(namegv), o2);
6577 /* '*' allows any scalar type, including bareword */
6580 if (o2->op_type == OP_RV2GV)
6581 goto wrapref; /* autoconvert GLOB -> GLOBref */
6582 else if (o2->op_type == OP_CONST)
6583 o2->op_private &= ~OPpCONST_STRICT;
6584 else if (o2->op_type == OP_ENTERSUB) {
6585 /* accidental subroutine, revert to bareword */
6586 OP *gvop = ((UNOP*)o2)->op_first;
6587 if (gvop && gvop->op_type == OP_NULL) {
6588 gvop = ((UNOP*)gvop)->op_first;
6590 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6593 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6594 (gvop = ((UNOP*)gvop)->op_first) &&
6595 gvop->op_type == OP_GV)
6597 GV *gv = cGVOPx_gv(gvop);
6598 OP *sibling = o2->op_sibling;
6599 SV *n = newSVpvn("",0);
6601 gv_fullname3(n, gv, "");
6602 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6603 sv_chop(n, SvPVX(n)+6);
6604 o2 = newSVOP(OP_CONST, 0, n);
6605 prev->op_sibling = o2;
6606 o2->op_sibling = sibling;
6618 if (o2->op_type != OP_RV2GV)
6619 bad_type(arg, "symbol", gv_ename(namegv), o2);
6622 if (o2->op_type != OP_ENTERSUB)
6623 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6626 if (o2->op_type != OP_RV2SV
6627 && o2->op_type != OP_PADSV
6628 && o2->op_type != OP_HELEM
6629 && o2->op_type != OP_AELEM
6630 && o2->op_type != OP_THREADSV)
6632 bad_type(arg, "scalar", gv_ename(namegv), o2);
6636 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6637 bad_type(arg, "array", gv_ename(namegv), o2);
6640 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6641 bad_type(arg, "hash", gv_ename(namegv), o2);
6645 OP* sib = kid->op_sibling;
6646 kid->op_sibling = 0;
6647 o2 = newUNOP(OP_REFGEN, 0, kid);
6648 o2->op_sibling = sib;
6649 prev->op_sibling = o2;
6660 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6661 gv_ename(namegv), SvPV((SV*)cv, n_a));
6666 mod(o2, OP_ENTERSUB);
6668 o2 = o2->op_sibling;
6670 if (proto && !optional &&
6671 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6672 return too_few_arguments(o, gv_ename(namegv));
6677 Perl_ck_svconst(pTHX_ OP *o)
6679 SvREADONLY_on(cSVOPo->op_sv);
6684 Perl_ck_trunc(pTHX_ OP *o)
6686 if (o->op_flags & OPf_KIDS) {
6687 SVOP *kid = (SVOP*)cUNOPo->op_first;
6689 if (kid->op_type == OP_NULL)
6690 kid = (SVOP*)kid->op_sibling;
6691 if (kid && kid->op_type == OP_CONST &&
6692 (kid->op_private & OPpCONST_BARE))
6694 o->op_flags |= OPf_SPECIAL;
6695 kid->op_private &= ~OPpCONST_STRICT;
6702 Perl_ck_substr(pTHX_ OP *o)
6705 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6706 OP *kid = cLISTOPo->op_first;
6708 if (kid->op_type == OP_NULL)
6709 kid = kid->op_sibling;
6711 kid->op_flags |= OPf_MOD;
6717 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6720 Perl_peep(pTHX_ register OP *o)
6722 register OP* oldop = 0;
6725 if (!o || o->op_seq)
6729 SAVEVPTR(PL_curcop);
6730 for (; o; o = o->op_next) {
6736 switch (o->op_type) {
6740 PL_curcop = ((COP*)o); /* for warnings */
6741 o->op_seq = PL_op_seqmax++;
6745 if (cSVOPo->op_private & OPpCONST_STRICT)
6746 no_bareword_allowed(o);
6748 /* Relocate sv to the pad for thread safety.
6749 * Despite being a "constant", the SV is written to,
6750 * for reference counts, sv_upgrade() etc. */
6752 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6753 if (SvPADTMP(cSVOPo->op_sv)) {
6754 /* If op_sv is already a PADTMP then it is being used by
6755 * some pad, so make a copy. */
6756 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6757 SvREADONLY_on(PL_curpad[ix]);
6758 SvREFCNT_dec(cSVOPo->op_sv);
6761 SvREFCNT_dec(PL_curpad[ix]);
6762 SvPADTMP_on(cSVOPo->op_sv);
6763 PL_curpad[ix] = cSVOPo->op_sv;
6764 /* XXX I don't know how this isn't readonly already. */
6765 SvREADONLY_on(PL_curpad[ix]);
6767 cSVOPo->op_sv = Nullsv;
6771 o->op_seq = PL_op_seqmax++;
6775 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6776 if (o->op_next->op_private & OPpTARGET_MY) {
6777 if (o->op_flags & OPf_STACKED) /* chained concats */
6778 goto ignore_optimization;
6780 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6781 o->op_targ = o->op_next->op_targ;
6782 o->op_next->op_targ = 0;
6783 o->op_private |= OPpTARGET_MY;
6786 op_null(o->op_next);
6788 ignore_optimization:
6789 o->op_seq = PL_op_seqmax++;
6792 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6793 o->op_seq = PL_op_seqmax++;
6794 break; /* Scalar stub must produce undef. List stub is noop */
6798 if (o->op_targ == OP_NEXTSTATE
6799 || o->op_targ == OP_DBSTATE
6800 || o->op_targ == OP_SETSTATE)
6802 PL_curcop = ((COP*)o);
6804 /* XXX: We avoid setting op_seq here to prevent later calls
6805 to peep() from mistakenly concluding that optimisation
6806 has already occurred. This doesn't fix the real problem,
6807 though (See 20010220.007). AMS 20010719 */
6808 if (oldop && o->op_next) {
6809 oldop->op_next = o->op_next;
6817 if (oldop && o->op_next) {
6818 oldop->op_next = o->op_next;
6821 o->op_seq = PL_op_seqmax++;
6825 if (o->op_next->op_type == OP_RV2SV) {
6826 if (!(o->op_next->op_private & OPpDEREF)) {
6827 op_null(o->op_next);
6828 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6830 o->op_next = o->op_next->op_next;
6831 o->op_type = OP_GVSV;
6832 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6835 else if (o->op_next->op_type == OP_RV2AV) {
6836 OP* pop = o->op_next->op_next;
6838 if (pop->op_type == OP_CONST &&
6839 (PL_op = pop->op_next) &&
6840 pop->op_next->op_type == OP_AELEM &&
6841 !(pop->op_next->op_private &
6842 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6843 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6848 op_null(o->op_next);
6849 op_null(pop->op_next);
6851 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6852 o->op_next = pop->op_next->op_next;
6853 o->op_type = OP_AELEMFAST;
6854 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6855 o->op_private = (U8)i;
6860 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6862 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6863 /* XXX could check prototype here instead of just carping */
6864 SV *sv = sv_newmortal();
6865 gv_efullname3(sv, gv, Nullch);
6866 Perl_warner(aTHX_ WARN_PROTOTYPE,
6867 "%s() called too early to check prototype",
6872 o->op_seq = PL_op_seqmax++;
6883 o->op_seq = PL_op_seqmax++;
6884 while (cLOGOP->op_other->op_type == OP_NULL)
6885 cLOGOP->op_other = cLOGOP->op_other->op_next;
6886 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6891 o->op_seq = PL_op_seqmax++;
6892 while (cLOOP->op_redoop->op_type == OP_NULL)
6893 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6894 peep(cLOOP->op_redoop);
6895 while (cLOOP->op_nextop->op_type == OP_NULL)
6896 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6897 peep(cLOOP->op_nextop);
6898 while (cLOOP->op_lastop->op_type == OP_NULL)
6899 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6900 peep(cLOOP->op_lastop);
6906 o->op_seq = PL_op_seqmax++;
6907 while (cPMOP->op_pmreplstart &&
6908 cPMOP->op_pmreplstart->op_type == OP_NULL)
6909 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6910 peep(cPMOP->op_pmreplstart);
6914 o->op_seq = PL_op_seqmax++;
6915 if (ckWARN(WARN_SYNTAX) && o->op_next
6916 && o->op_next->op_type == OP_NEXTSTATE) {
6917 if (o->op_next->op_sibling &&
6918 o->op_next->op_sibling->op_type != OP_EXIT &&
6919 o->op_next->op_sibling->op_type != OP_WARN &&
6920 o->op_next->op_sibling->op_type != OP_DIE) {
6921 line_t oldline = CopLINE(PL_curcop);
6923 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6924 Perl_warner(aTHX_ WARN_EXEC,
6925 "Statement unlikely to be reached");
6926 Perl_warner(aTHX_ WARN_EXEC,
6927 "\t(Maybe you meant system() when you said exec()?)\n");
6928 CopLINE_set(PL_curcop, oldline);
6937 SV **svp, **indsvp, *sv;
6942 o->op_seq = PL_op_seqmax++;
6944 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6947 /* Make the CONST have a shared SV */
6948 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6949 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6950 key = SvPV(sv, keylen);
6951 lexname = newSVpvn_share(key,
6952 SvUTF8(sv) ? -(I32)keylen : keylen,
6958 if ((o->op_private & (OPpLVAL_INTRO)))
6961 rop = (UNOP*)((BINOP*)o)->op_first;
6962 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6964 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6965 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6967 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6968 if (!fields || !GvHV(*fields))
6970 key = SvPV(*svp, keylen);
6971 indsvp = hv_fetch(GvHV(*fields), key,
6972 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6974 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6975 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6977 ind = SvIV(*indsvp);
6979 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6980 rop->op_type = OP_RV2AV;
6981 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6982 o->op_type = OP_AELEM;
6983 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6985 if (SvREADONLY(*svp))
6987 SvFLAGS(sv) |= (SvFLAGS(*svp)
6988 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6998 SV **svp, **indsvp, *sv;
7002 SVOP *first_key_op, *key_op;
7004 o->op_seq = PL_op_seqmax++;
7005 if ((o->op_private & (OPpLVAL_INTRO))
7006 /* I bet there's always a pushmark... */
7007 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7008 /* hmmm, no optimization if list contains only one key. */
7010 rop = (UNOP*)((LISTOP*)o)->op_last;
7011 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7013 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7014 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7016 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7017 if (!fields || !GvHV(*fields))
7019 /* Again guessing that the pushmark can be jumped over.... */
7020 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7021 ->op_first->op_sibling;
7022 /* Check that the key list contains only constants. */
7023 for (key_op = first_key_op; key_op;
7024 key_op = (SVOP*)key_op->op_sibling)
7025 if (key_op->op_type != OP_CONST)
7029 rop->op_type = OP_RV2AV;
7030 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7031 o->op_type = OP_ASLICE;
7032 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7033 for (key_op = first_key_op; key_op;
7034 key_op = (SVOP*)key_op->op_sibling) {
7035 svp = cSVOPx_svp(key_op);
7036 key = SvPV(*svp, keylen);
7037 indsvp = hv_fetch(GvHV(*fields), key,
7038 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7040 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7041 "in variable %s of type %s",
7042 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7044 ind = SvIV(*indsvp);
7046 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7048 if (SvREADONLY(*svp))
7050 SvFLAGS(sv) |= (SvFLAGS(*svp)
7051 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7059 o->op_seq = PL_op_seqmax++;
7069 /* Efficient sub that returns a constant scalar value. */
7071 const_sv_xsub(pTHXo_ CV* cv)
7076 Perl_croak(aTHX_ "usage: %s::%s()",
7077 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7081 ST(0) = (SV*)XSANY.any_ptr;