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 PL_OP_SLAB_ALLOC */
25 #ifdef PL_OP_SLAB_ALLOC
26 #define SLAB_SIZE 8192
27 static char *PL_OpPtr = NULL;
28 static int PL_OpSpace = 0;
29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
30 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
32 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
36 S_Slab_Alloc(pTHX_ int m, size_t sz)
38 Newz(m,PL_OpPtr,SLAB_SIZE,char);
39 PL_OpSpace = SLAB_SIZE - sz;
40 return PL_OpPtr += PL_OpSpace;
44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
47 * In the following definition, the ", Nullop" is just to make the compiler
48 * think the expression is of the right type: croak actually does a Siglongjmp.
50 #define CHECKOP(type,o) \
51 ((PL_op_mask && PL_op_mask[type]) \
52 ? ( op_free((OP*)o), \
53 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
55 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
57 #define PAD_MAX 999999999
58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
61 S_gv_ename(pTHX_ GV *gv)
64 SV* tmpsv = sv_newmortal();
65 gv_efullname3(tmpsv, gv, Nullch);
66 return SvPV(tmpsv,n_a);
70 S_no_fh_allowed(pTHX_ OP *o)
72 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
73 PL_op_desc[o->op_type]));
78 S_too_few_arguments(pTHX_ OP *o, char *name)
80 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
85 S_too_many_arguments(pTHX_ OP *o, char *name)
87 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
94 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
95 (int)n, name, t, PL_op_desc[kid->op_type]));
99 S_no_bareword_allowed(pTHX_ OP *o)
101 qerror(Perl_mess(aTHX_
102 "Bareword \"%s\" not allowed while \"strict subs\" in use",
103 SvPV_nolen(cSVOPo_sv)));
106 /* "register" allocation */
109 Perl_pad_allocmy(pTHX_ char *name)
114 if (!(PL_in_my == KEY_our ||
116 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
117 (name[1] == '_' && (int)strlen(name) > 2)))
119 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
120 /* 1999-02-27 mjd@plover.com */
122 p = strchr(name, '\0');
123 /* The next block assumes the buffer is at least 205 chars
124 long. At present, it's always at least 256 chars. */
126 strcpy(name+200, "...");
132 /* Move everything else down one character */
133 for (; p-name > 2; p--)
135 name[2] = toCTRL(name[1]);
138 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
140 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
141 SV **svp = AvARRAY(PL_comppad_name);
142 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
143 PADOFFSET top = AvFILLp(PL_comppad_name);
144 for (off = top; off > PL_comppad_name_floor; off--) {
146 && sv != &PL_sv_undef
147 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
148 && (PL_in_my != KEY_our
149 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
150 && strEQ(name, SvPVX(sv)))
152 Perl_warner(aTHX_ WARN_MISC,
153 "\"%s\" variable %s masks earlier declaration in same %s",
154 (PL_in_my == KEY_our ? "our" : "my"),
156 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
161 if (PL_in_my == KEY_our) {
164 && sv != &PL_sv_undef
165 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
166 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
167 && strEQ(name, SvPVX(sv)))
169 Perl_warner(aTHX_ WARN_MISC,
170 "\"our\" variable %s redeclared", name);
171 Perl_warner(aTHX_ WARN_MISC,
172 "\t(Did you mean \"local\" instead of \"our\"?)\n");
175 } while ( off-- > 0 );
178 off = pad_alloc(OP_PADSV, SVs_PADMY);
180 sv_upgrade(sv, SVt_PVNV);
182 if (PL_in_my_stash) {
184 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
185 name, PL_in_my == KEY_our ? "our" : "my"));
186 SvFLAGS(sv) |= SVpad_TYPED;
187 (void)SvUPGRADE(sv, SVt_PVMG);
188 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
190 if (PL_in_my == KEY_our) {
191 (void)SvUPGRADE(sv, SVt_PVGV);
192 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
193 SvFLAGS(sv) |= SVpad_OUR;
195 av_store(PL_comppad_name, off, sv);
196 SvNVX(sv) = (NV)PAD_MAX;
197 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
198 if (!PL_min_intro_pending)
199 PL_min_intro_pending = off;
200 PL_max_intro_pending = off;
202 av_store(PL_comppad, off, (SV*)newAV());
203 else if (*name == '%')
204 av_store(PL_comppad, off, (SV*)newHV());
205 SvPADMY_on(PL_curpad[off]);
210 S_pad_addlex(pTHX_ SV *proto_namesv)
212 SV *namesv = NEWSV(1103,0);
213 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
214 sv_upgrade(namesv, SVt_PVNV);
215 sv_setpv(namesv, SvPVX(proto_namesv));
216 av_store(PL_comppad_name, newoff, namesv);
217 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
218 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
219 SvFAKE_on(namesv); /* A ref, not a real var */
220 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
221 SvFLAGS(namesv) |= SVpad_OUR;
222 (void)SvUPGRADE(namesv, SVt_PVGV);
223 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
225 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
226 SvFLAGS(namesv) |= SVpad_TYPED;
227 (void)SvUPGRADE(namesv, SVt_PVMG);
228 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
233 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
236 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
237 I32 cx_ix, I32 saweval, U32 flags)
243 register PERL_CONTEXT *cx;
245 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
246 AV *curlist = CvPADLIST(cv);
247 SV **svp = av_fetch(curlist, 0, FALSE);
250 if (!svp || *svp == &PL_sv_undef)
253 svp = AvARRAY(curname);
254 for (off = AvFILLp(curname); off > 0; off--) {
255 if ((sv = svp[off]) &&
256 sv != &PL_sv_undef &&
258 seq > I_32(SvNVX(sv)) &&
259 strEQ(SvPVX(sv), name))
270 return 0; /* don't clone from inactive stack frame */
274 oldpad = (AV*)AvARRAY(curlist)[depth];
275 oldsv = *av_fetch(oldpad, off, TRUE);
276 if (!newoff) { /* Not a mere clone operation. */
277 newoff = pad_addlex(sv);
278 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
279 /* "It's closures all the way down." */
280 CvCLONE_on(PL_compcv);
282 if (CvANON(PL_compcv))
283 oldsv = Nullsv; /* no need to keep ref */
288 bcv && bcv != cv && !CvCLONE(bcv);
289 bcv = CvOUTSIDE(bcv))
292 /* install the missing pad entry in intervening
293 * nested subs and mark them cloneable.
294 * XXX fix pad_foo() to not use globals */
295 AV *ocomppad_name = PL_comppad_name;
296 AV *ocomppad = PL_comppad;
297 SV **ocurpad = PL_curpad;
298 AV *padlist = CvPADLIST(bcv);
299 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
300 PL_comppad = (AV*)AvARRAY(padlist)[1];
301 PL_curpad = AvARRAY(PL_comppad);
303 PL_comppad_name = ocomppad_name;
304 PL_comppad = ocomppad;
309 if (ckWARN(WARN_CLOSURE)
310 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
312 Perl_warner(aTHX_ WARN_CLOSURE,
313 "Variable \"%s\" may be unavailable",
321 else if (!CvUNIQUE(PL_compcv)) {
322 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
323 && !(SvFLAGS(sv) & SVpad_OUR))
325 Perl_warner(aTHX_ WARN_CLOSURE,
326 "Variable \"%s\" will not stay shared", name);
330 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
336 if (flags & FINDLEX_NOSEARCH)
339 /* Nothing in current lexical context--try eval's context, if any.
340 * This is necessary to let the perldb get at lexically scoped variables.
341 * XXX This will also probably interact badly with eval tree caching.
344 for (i = cx_ix; i >= 0; i--) {
346 switch (CxTYPE(cx)) {
348 if (i == 0 && saweval) {
349 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
353 switch (cx->blk_eval.old_op_type) {
355 if (CxREALEVAL(cx)) {
358 seq = cxstack[i].blk_oldcop->cop_seq;
359 startcv = cxstack[i].blk_eval.cv;
360 if (startcv && CvOUTSIDE(startcv)) {
361 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
363 if (off) /* continue looking if not found here */
370 /* require/do must have their own scope */
379 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
380 saweval = i; /* so we know where we were called from */
383 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
391 Perl_pad_findmy(pTHX_ char *name)
396 SV **svp = AvARRAY(PL_comppad_name);
397 U32 seq = PL_cop_seqmax;
403 * Special case to get lexical (and hence per-thread) @_.
404 * XXX I need to find out how to tell at parse-time whether use
405 * of @_ should refer to a lexical (from a sub) or defgv (global
406 * scope and maybe weird sub-ish things like formats). See
407 * startsub in perly.y. It's possible that @_ could be lexical
408 * (at least from subs) even in non-threaded perl.
410 if (strEQ(name, "@_"))
411 return 0; /* success. (NOT_IN_PAD indicates failure) */
412 #endif /* USE_THREADS */
414 /* The one we're looking for is probably just before comppad_name_fill. */
415 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
416 if ((sv = svp[off]) &&
417 sv != &PL_sv_undef &&
420 seq > I_32(SvNVX(sv)))) &&
421 strEQ(SvPVX(sv), name))
423 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
424 return (PADOFFSET)off;
425 pendoff = off; /* this pending def. will override import */
429 outside = CvOUTSIDE(PL_compcv);
431 /* Check if if we're compiling an eval'', and adjust seq to be the
432 * eval's seq number. This depends on eval'' having a non-null
433 * CvOUTSIDE() while it is being compiled. The eval'' itself is
434 * identified by CvEVAL being true and CvGV being null. */
435 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
436 cx = &cxstack[cxstack_ix];
438 seq = cx->blk_oldcop->cop_seq;
441 /* See if it's in a nested scope */
442 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
444 /* If there is a pending local definition, this new alias must die */
446 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
447 return off; /* pad_findlex returns 0 for failure...*/
449 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
453 Perl_pad_leavemy(pTHX_ I32 fill)
456 SV **svp = AvARRAY(PL_comppad_name);
458 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
459 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
460 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
461 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
464 /* "Deintroduce" my variables that are leaving with this scope. */
465 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
466 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
467 SvIVX(sv) = PL_cop_seqmax;
472 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
477 if (AvARRAY(PL_comppad) != PL_curpad)
478 Perl_croak(aTHX_ "panic: pad_alloc");
479 if (PL_pad_reset_pending)
481 if (tmptype & SVs_PADMY) {
483 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
484 } while (SvPADBUSY(sv)); /* need a fresh one */
485 retval = AvFILLp(PL_comppad);
488 SV **names = AvARRAY(PL_comppad_name);
489 SSize_t names_fill = AvFILLp(PL_comppad_name);
492 * "foreach" index vars temporarily become aliases to non-"my"
493 * values. Thus we must skip, not just pad values that are
494 * marked as current pad values, but also those with names.
496 if (++PL_padix <= names_fill &&
497 (sv = names[PL_padix]) && sv != &PL_sv_undef)
499 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
500 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
501 !IS_PADGV(sv) && !IS_PADCONST(sv))
506 SvFLAGS(sv) |= tmptype;
507 PL_curpad = AvARRAY(PL_comppad);
509 DEBUG_X(PerlIO_printf(Perl_debug_log,
510 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
511 PTR2UV(thr), PTR2UV(PL_curpad),
512 (long) retval, PL_op_name[optype]));
514 DEBUG_X(PerlIO_printf(Perl_debug_log,
515 "Pad 0x%"UVxf" alloc %ld for %s\n",
517 (long) retval, PL_op_name[optype]));
518 #endif /* USE_THREADS */
519 return (PADOFFSET)retval;
523 Perl_pad_sv(pTHX_ PADOFFSET po)
526 DEBUG_X(PerlIO_printf(Perl_debug_log,
527 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
528 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
531 Perl_croak(aTHX_ "panic: pad_sv po");
532 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
533 PTR2UV(PL_curpad), (IV)po));
534 #endif /* USE_THREADS */
535 return PL_curpad[po]; /* eventually we'll turn this into a macro */
539 Perl_pad_free(pTHX_ PADOFFSET po)
543 if (AvARRAY(PL_comppad) != PL_curpad)
544 Perl_croak(aTHX_ "panic: pad_free curpad");
546 Perl_croak(aTHX_ "panic: pad_free po");
548 DEBUG_X(PerlIO_printf(Perl_debug_log,
549 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
550 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
552 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
553 PTR2UV(PL_curpad), (IV)po));
554 #endif /* USE_THREADS */
555 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
556 SvPADTMP_off(PL_curpad[po]);
558 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
561 if ((I32)po < PL_padix)
566 Perl_pad_swipe(pTHX_ PADOFFSET po)
568 if (AvARRAY(PL_comppad) != PL_curpad)
569 Perl_croak(aTHX_ "panic: pad_swipe curpad");
571 Perl_croak(aTHX_ "panic: pad_swipe po");
573 DEBUG_X(PerlIO_printf(Perl_debug_log,
574 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
575 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
577 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(PL_curpad), (IV)po));
579 #endif /* USE_THREADS */
580 SvPADTMP_off(PL_curpad[po]);
581 PL_curpad[po] = NEWSV(1107,0);
582 SvPADTMP_on(PL_curpad[po]);
583 if ((I32)po < PL_padix)
587 /* XXX pad_reset() is currently disabled because it results in serious bugs.
588 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
589 * on the stack by OPs that use them, there are several ways to get an alias
590 * to a shared TARG. Such an alias will change randomly and unpredictably.
591 * We avoid doing this until we can think of a Better Way.
596 #ifdef USE_BROKEN_PAD_RESET
599 if (AvARRAY(PL_comppad) != PL_curpad)
600 Perl_croak(aTHX_ "panic: pad_reset curpad");
602 DEBUG_X(PerlIO_printf(Perl_debug_log,
603 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
604 PTR2UV(thr), PTR2UV(PL_curpad)));
606 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
608 #endif /* USE_THREADS */
609 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
610 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
611 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
612 SvPADTMP_off(PL_curpad[po]);
614 PL_padix = PL_padix_floor;
617 PL_pad_reset_pending = FALSE;
621 /* find_threadsv is not reentrant */
623 Perl_find_threadsv(pTHX_ const char *name)
628 /* We currently only handle names of a single character */
629 p = strchr(PL_threadsv_names, *name);
632 key = p - PL_threadsv_names;
633 MUTEX_LOCK(&thr->mutex);
634 svp = av_fetch(thr->threadsv, key, FALSE);
636 MUTEX_UNLOCK(&thr->mutex);
638 SV *sv = NEWSV(0, 0);
639 av_store(thr->threadsv, key, sv);
640 thr->threadsvp = AvARRAY(thr->threadsv);
641 MUTEX_UNLOCK(&thr->mutex);
643 * Some magic variables used to be automagically initialised
644 * in gv_fetchpv. Those which are now per-thread magicals get
645 * initialised here instead.
651 sv_setpv(sv, "\034");
652 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
657 PL_sawampersand = TRUE;
671 /* XXX %! tied to Errno.pm needs to be added here.
672 * See gv_fetchpv(). */
676 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
678 DEBUG_S(PerlIO_printf(Perl_error_log,
679 "find_threadsv: new SV %p for $%s%c\n",
680 sv, (*name < 32) ? "^" : "",
681 (*name < 32) ? toCTRL(*name) : *name));
685 #endif /* USE_THREADS */
690 Perl_op_free(pTHX_ OP *o)
692 register OP *kid, *nextkid;
695 if (!o || o->op_seq == (U16)-1)
698 if (o->op_private & OPpREFCOUNTED) {
699 switch (o->op_type) {
707 if (OpREFCNT_dec(o)) {
718 if (o->op_flags & OPf_KIDS) {
719 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
720 nextkid = kid->op_sibling; /* Get before next freeing kid */
728 /* COP* is not cleared by op_clear() so that we may track line
729 * numbers etc even after null() */
730 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
735 #ifdef PL_OP_SLAB_ALLOC
736 if ((char *) o == PL_OpPtr)
745 Perl_op_clear(pTHX_ OP *o)
747 switch (o->op_type) {
748 case OP_NULL: /* Was holding old type, if any. */
749 case OP_ENTEREVAL: /* Was holding hints. */
751 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
757 if (!(o->op_flags & OPf_SPECIAL))
760 #endif /* USE_THREADS */
762 if (!(o->op_flags & OPf_REF)
763 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
770 if (cPADOPo->op_padix > 0) {
773 pad_swipe(cPADOPo->op_padix);
774 /* No GvIN_PAD_off(gv) here, because other references may still
775 * exist on the pad */
778 cPADOPo->op_padix = 0;
781 SvREFCNT_dec(cSVOPo->op_sv);
782 cSVOPo->op_sv = Nullsv;
785 case OP_METHOD_NAMED:
787 SvREFCNT_dec(cSVOPo->op_sv);
788 cSVOPo->op_sv = Nullsv;
794 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
798 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
799 SvREFCNT_dec(cSVOPo->op_sv);
800 cSVOPo->op_sv = Nullsv;
803 Safefree(cPVOPo->op_pv);
804 cPVOPo->op_pv = Nullch;
808 op_free(cPMOPo->op_pmreplroot);
812 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
814 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
815 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
816 /* No GvIN_PAD_off(gv) here, because other references may still
817 * exist on the pad */
822 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
829 HV *pmstash = PmopSTASH(cPMOPo);
830 if (pmstash && SvREFCNT(pmstash)) {
831 PMOP *pmop = HvPMROOT(pmstash);
832 PMOP *lastpmop = NULL;
834 if (cPMOPo == pmop) {
836 lastpmop->op_pmnext = pmop->op_pmnext;
838 HvPMROOT(pmstash) = pmop->op_pmnext;
842 pmop = pmop->op_pmnext;
845 Safefree(PmopSTASHPV(cPMOPo));
847 /* NOTE: PMOP.op_pmstash is not refcounted */
851 cPMOPo->op_pmreplroot = Nullop;
852 ReREFCNT_dec(cPMOPo->op_pmregexp);
853 cPMOPo->op_pmregexp = (REGEXP*)NULL;
857 if (o->op_targ > 0) {
858 pad_free(o->op_targ);
864 S_cop_free(pTHX_ COP* cop)
866 Safefree(cop->cop_label);
868 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
869 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
871 /* NOTE: COP.cop_stash is not refcounted */
872 SvREFCNT_dec(CopFILEGV(cop));
874 if (! specialWARN(cop->cop_warnings))
875 SvREFCNT_dec(cop->cop_warnings);
876 if (! specialCopIO(cop->cop_io))
877 SvREFCNT_dec(cop->cop_io);
881 Perl_op_null(pTHX_ OP *o)
883 if (o->op_type == OP_NULL)
886 o->op_targ = o->op_type;
887 o->op_type = OP_NULL;
888 o->op_ppaddr = PL_ppaddr[OP_NULL];
891 /* Contextualizers */
893 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
896 Perl_linklist(pTHX_ OP *o)
903 /* establish postfix order */
904 if (cUNOPo->op_first) {
905 o->op_next = LINKLIST(cUNOPo->op_first);
906 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
908 kid->op_next = LINKLIST(kid->op_sibling);
920 Perl_scalarkids(pTHX_ OP *o)
923 if (o && o->op_flags & OPf_KIDS) {
924 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
931 S_scalarboolean(pTHX_ OP *o)
933 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
934 if (ckWARN(WARN_SYNTAX)) {
935 line_t oldline = CopLINE(PL_curcop);
937 if (PL_copline != NOLINE)
938 CopLINE_set(PL_curcop, PL_copline);
939 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
940 CopLINE_set(PL_curcop, oldline);
947 Perl_scalar(pTHX_ OP *o)
951 /* assumes no premature commitment */
952 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
953 || o->op_type == OP_RETURN)
958 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
960 switch (o->op_type) {
962 scalar(cBINOPo->op_first);
967 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
971 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
972 if (!kPMOP->op_pmreplroot)
973 deprecate("implicit split to @_");
981 if (o->op_flags & OPf_KIDS) {
982 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
988 kid = cLISTOPo->op_first;
990 while ((kid = kid->op_sibling)) {
996 WITH_THR(PL_curcop = &PL_compiling);
1001 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1002 if (kid->op_sibling)
1007 WITH_THR(PL_curcop = &PL_compiling);
1014 Perl_scalarvoid(pTHX_ OP *o)
1021 if (o->op_type == OP_NEXTSTATE
1022 || o->op_type == OP_SETSTATE
1023 || o->op_type == OP_DBSTATE
1024 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1025 || o->op_targ == OP_SETSTATE
1026 || o->op_targ == OP_DBSTATE)))
1027 PL_curcop = (COP*)o; /* for warning below */
1029 /* assumes no premature commitment */
1030 want = o->op_flags & OPf_WANT;
1031 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1032 || o->op_type == OP_RETURN)
1037 if ((o->op_private & OPpTARGET_MY)
1038 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1040 return scalar(o); /* As if inside SASSIGN */
1043 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1045 switch (o->op_type) {
1047 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1051 if (o->op_flags & OPf_STACKED)
1055 if (o->op_private == 4)
1097 case OP_GETSOCKNAME:
1098 case OP_GETPEERNAME:
1103 case OP_GETPRIORITY:
1126 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1127 useless = PL_op_desc[o->op_type];
1134 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1135 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1136 useless = "a variable";
1141 if (cSVOPo->op_private & OPpCONST_STRICT)
1142 no_bareword_allowed(o);
1144 if (ckWARN(WARN_VOID)) {
1145 useless = "a constant";
1146 /* the constants 0 and 1 are permitted as they are
1147 conventionally used as dummies in constructs like
1148 1 while some_condition_with_side_effects; */
1149 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1151 else if (SvPOK(sv)) {
1152 /* perl4's way of mixing documentation and code
1153 (before the invention of POD) was based on a
1154 trick to mix nroff and perl code. The trick was
1155 built upon these three nroff macros being used in
1156 void context. The pink camel has the details in
1157 the script wrapman near page 319. */
1158 if (strnEQ(SvPVX(sv), "di", 2) ||
1159 strnEQ(SvPVX(sv), "ds", 2) ||
1160 strnEQ(SvPVX(sv), "ig", 2))
1165 op_null(o); /* don't execute or even remember it */
1169 o->op_type = OP_PREINC; /* pre-increment is faster */
1170 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1174 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1175 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1181 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1186 if (o->op_flags & OPf_STACKED)
1193 if (!(o->op_flags & OPf_KIDS))
1202 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1209 /* all requires must return a boolean value */
1210 o->op_flags &= ~OPf_WANT;
1215 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1216 if (!kPMOP->op_pmreplroot)
1217 deprecate("implicit split to @_");
1221 if (useless && ckWARN(WARN_VOID))
1222 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1227 Perl_listkids(pTHX_ OP *o)
1230 if (o && o->op_flags & OPf_KIDS) {
1231 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1238 Perl_list(pTHX_ OP *o)
1242 /* assumes no premature commitment */
1243 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1244 || o->op_type == OP_RETURN)
1249 if ((o->op_private & OPpTARGET_MY)
1250 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1252 return o; /* As if inside SASSIGN */
1255 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1257 switch (o->op_type) {
1260 list(cBINOPo->op_first);
1265 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1273 if (!(o->op_flags & OPf_KIDS))
1275 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1276 list(cBINOPo->op_first);
1277 return gen_constant_list(o);
1284 kid = cLISTOPo->op_first;
1286 while ((kid = kid->op_sibling)) {
1287 if (kid->op_sibling)
1292 WITH_THR(PL_curcop = &PL_compiling);
1296 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1297 if (kid->op_sibling)
1302 WITH_THR(PL_curcop = &PL_compiling);
1305 /* all requires must return a boolean value */
1306 o->op_flags &= ~OPf_WANT;
1313 Perl_scalarseq(pTHX_ OP *o)
1318 if (o->op_type == OP_LINESEQ ||
1319 o->op_type == OP_SCOPE ||
1320 o->op_type == OP_LEAVE ||
1321 o->op_type == OP_LEAVETRY)
1323 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1324 if (kid->op_sibling) {
1328 PL_curcop = &PL_compiling;
1330 o->op_flags &= ~OPf_PARENS;
1331 if (PL_hints & HINT_BLOCK_SCOPE)
1332 o->op_flags |= OPf_PARENS;
1335 o = newOP(OP_STUB, 0);
1340 S_modkids(pTHX_ OP *o, I32 type)
1343 if (o && o->op_flags & OPf_KIDS) {
1344 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1351 Perl_mod(pTHX_ OP *o, I32 type)
1356 if (!o || PL_error_count)
1359 if ((o->op_private & OPpTARGET_MY)
1360 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1365 switch (o->op_type) {
1370 if (!(o->op_private & (OPpCONST_ARYBASE)))
1372 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1373 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1377 SAVEI32(PL_compiling.cop_arybase);
1378 PL_compiling.cop_arybase = 0;
1380 else if (type == OP_REFGEN)
1383 Perl_croak(aTHX_ "That use of $[ is unsupported");
1386 if (o->op_flags & OPf_PARENS)
1390 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1391 !(o->op_flags & OPf_STACKED)) {
1392 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1393 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1394 assert(cUNOPo->op_first->op_type == OP_NULL);
1395 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1398 else { /* lvalue subroutine call */
1399 o->op_private |= OPpLVAL_INTRO;
1400 PL_modcount = RETURN_UNLIMITED_NUMBER;
1401 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1402 /* Backward compatibility mode: */
1403 o->op_private |= OPpENTERSUB_INARGS;
1406 else { /* Compile-time error message: */
1407 OP *kid = cUNOPo->op_first;
1411 if (kid->op_type == OP_PUSHMARK)
1413 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1415 "panic: unexpected lvalue entersub "
1416 "args: type/targ %ld:%ld",
1417 (long)kid->op_type,kid->op_targ);
1418 kid = kLISTOP->op_first;
1420 while (kid->op_sibling)
1421 kid = kid->op_sibling;
1422 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1424 if (kid->op_type == OP_METHOD_NAMED
1425 || kid->op_type == OP_METHOD)
1429 if (kid->op_sibling || kid->op_next != kid) {
1430 yyerror("panic: unexpected optree near method call");
1434 NewOp(1101, newop, 1, UNOP);
1435 newop->op_type = OP_RV2CV;
1436 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1437 newop->op_first = Nullop;
1438 newop->op_next = (OP*)newop;
1439 kid->op_sibling = (OP*)newop;
1440 newop->op_private |= OPpLVAL_INTRO;
1444 if (kid->op_type != OP_RV2CV)
1446 "panic: unexpected lvalue entersub "
1447 "entry via type/targ %ld:%ld",
1448 (long)kid->op_type,kid->op_targ);
1449 kid->op_private |= OPpLVAL_INTRO;
1450 break; /* Postpone until runtime */
1454 kid = kUNOP->op_first;
1455 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1456 kid = kUNOP->op_first;
1457 if (kid->op_type == OP_NULL)
1459 "Unexpected constant lvalue entersub "
1460 "entry via type/targ %ld:%ld",
1461 (long)kid->op_type,kid->op_targ);
1462 if (kid->op_type != OP_GV) {
1463 /* Restore RV2CV to check lvalueness */
1465 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1466 okid->op_next = kid->op_next;
1467 kid->op_next = okid;
1470 okid->op_next = Nullop;
1471 okid->op_type = OP_RV2CV;
1473 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1474 okid->op_private |= OPpLVAL_INTRO;
1478 cv = GvCV(kGVOP_gv);
1488 /* grep, foreach, subcalls, refgen */
1489 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1491 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1492 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1494 : (o->op_type == OP_ENTERSUB
1495 ? "non-lvalue subroutine call"
1496 : PL_op_desc[o->op_type])),
1497 type ? PL_op_desc[type] : "local"));
1511 case OP_RIGHT_SHIFT:
1520 if (!(o->op_flags & OPf_STACKED))
1526 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1532 if (!type && cUNOPo->op_first->op_type != OP_GV)
1533 Perl_croak(aTHX_ "Can't localize through a reference");
1534 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1535 PL_modcount = RETURN_UNLIMITED_NUMBER;
1536 return o; /* Treat \(@foo) like ordinary list. */
1540 if (scalar_mod_type(o, type))
1542 ref(cUNOPo->op_first, o->op_type);
1546 if (type == OP_LEAVESUBLV)
1547 o->op_private |= OPpMAYBE_LVSUB;
1553 PL_modcount = RETURN_UNLIMITED_NUMBER;
1556 if (!type && cUNOPo->op_first->op_type != OP_GV)
1557 Perl_croak(aTHX_ "Can't localize through a reference");
1558 ref(cUNOPo->op_first, o->op_type);
1562 PL_hints |= HINT_BLOCK_SCOPE;
1572 PL_modcount = RETURN_UNLIMITED_NUMBER;
1573 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1574 return o; /* Treat \(@foo) like ordinary list. */
1575 if (scalar_mod_type(o, type))
1577 if (type == OP_LEAVESUBLV)
1578 o->op_private |= OPpMAYBE_LVSUB;
1583 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1584 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1589 PL_modcount++; /* XXX ??? */
1591 #endif /* USE_THREADS */
1597 if (type != OP_SASSIGN)
1601 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1606 if (type == OP_LEAVESUBLV)
1607 o->op_private |= OPpMAYBE_LVSUB;
1609 pad_free(o->op_targ);
1610 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1611 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1612 if (o->op_flags & OPf_KIDS)
1613 mod(cBINOPo->op_first->op_sibling, type);
1618 ref(cBINOPo->op_first, o->op_type);
1619 if (type == OP_ENTERSUB &&
1620 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1621 o->op_private |= OPpLVAL_DEFER;
1622 if (type == OP_LEAVESUBLV)
1623 o->op_private |= OPpMAYBE_LVSUB;
1631 if (o->op_flags & OPf_KIDS)
1632 mod(cLISTOPo->op_last, type);
1636 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1638 else if (!(o->op_flags & OPf_KIDS))
1640 if (o->op_targ != OP_LIST) {
1641 mod(cBINOPo->op_first, type);
1646 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1651 if (type != OP_LEAVESUBLV)
1653 break; /* mod()ing was handled by ck_return() */
1655 if (type != OP_LEAVESUBLV)
1656 o->op_flags |= OPf_MOD;
1658 if (type == OP_AASSIGN || type == OP_SASSIGN)
1659 o->op_flags |= OPf_SPECIAL|OPf_REF;
1661 o->op_private |= OPpLVAL_INTRO;
1662 o->op_flags &= ~OPf_SPECIAL;
1663 PL_hints |= HINT_BLOCK_SCOPE;
1665 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1666 && type != OP_LEAVESUBLV)
1667 o->op_flags |= OPf_REF;
1672 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1676 if (o->op_type == OP_RV2GV)
1700 case OP_RIGHT_SHIFT:
1719 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1721 switch (o->op_type) {
1729 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1742 Perl_refkids(pTHX_ OP *o, I32 type)
1745 if (o && o->op_flags & OPf_KIDS) {
1746 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1753 Perl_ref(pTHX_ OP *o, I32 type)
1757 if (!o || PL_error_count)
1760 switch (o->op_type) {
1762 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1763 !(o->op_flags & OPf_STACKED)) {
1764 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1765 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1766 assert(cUNOPo->op_first->op_type == OP_NULL);
1767 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1768 o->op_flags |= OPf_SPECIAL;
1773 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1777 if (type == OP_DEFINED)
1778 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1779 ref(cUNOPo->op_first, o->op_type);
1782 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1783 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1784 : type == OP_RV2HV ? OPpDEREF_HV
1786 o->op_flags |= OPf_MOD;
1791 o->op_flags |= OPf_MOD; /* XXX ??? */
1796 o->op_flags |= OPf_REF;
1799 if (type == OP_DEFINED)
1800 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1801 ref(cUNOPo->op_first, o->op_type);
1806 o->op_flags |= OPf_REF;
1811 if (!(o->op_flags & OPf_KIDS))
1813 ref(cBINOPo->op_first, type);
1817 ref(cBINOPo->op_first, o->op_type);
1818 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1819 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1820 : type == OP_RV2HV ? OPpDEREF_HV
1822 o->op_flags |= OPf_MOD;
1830 if (!(o->op_flags & OPf_KIDS))
1832 ref(cLISTOPo->op_last, type);
1842 S_dup_attrlist(pTHX_ OP *o)
1846 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1847 * where the first kid is OP_PUSHMARK and the remaining ones
1848 * are OP_CONST. We need to push the OP_CONST values.
1850 if (o->op_type == OP_CONST)
1851 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1853 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1854 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1855 if (o->op_type == OP_CONST)
1856 rop = append_elem(OP_LIST, rop,
1857 newSVOP(OP_CONST, o->op_flags,
1858 SvREFCNT_inc(cSVOPo->op_sv)));
1865 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1869 /* fake up C<use attributes $pkg,$rv,@attrs> */
1870 ENTER; /* need to protect against side-effects of 'use' */
1872 if (stash && HvNAME(stash))
1873 stashsv = newSVpv(HvNAME(stash), 0);
1875 stashsv = &PL_sv_no;
1877 #define ATTRSMODULE "attributes"
1879 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1880 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1882 prepend_elem(OP_LIST,
1883 newSVOP(OP_CONST, 0, stashsv),
1884 prepend_elem(OP_LIST,
1885 newSVOP(OP_CONST, 0,
1887 dup_attrlist(attrs))));
1892 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1893 char *attrstr, STRLEN len)
1898 len = strlen(attrstr);
1902 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1904 char *sstr = attrstr;
1905 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1906 attrs = append_elem(OP_LIST, attrs,
1907 newSVOP(OP_CONST, 0,
1908 newSVpvn(sstr, attrstr-sstr)));
1912 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1913 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1914 Nullsv, prepend_elem(OP_LIST,
1915 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1916 prepend_elem(OP_LIST,
1917 newSVOP(OP_CONST, 0,
1923 S_my_kid(pTHX_ OP *o, OP *attrs)
1928 if (!o || PL_error_count)
1932 if (type == OP_LIST) {
1933 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1935 } else if (type == OP_UNDEF) {
1937 } else if (type == OP_RV2SV || /* "our" declaration */
1939 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1941 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1943 PL_in_my_stash = Nullhv;
1944 apply_attrs(GvSTASH(gv),
1945 (type == OP_RV2SV ? GvSV(gv) :
1946 type == OP_RV2AV ? (SV*)GvAV(gv) :
1947 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1950 o->op_private |= OPpOUR_INTRO;
1952 } else if (type != OP_PADSV &&
1955 type != OP_PUSHMARK)
1957 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1958 PL_op_desc[o->op_type],
1959 PL_in_my == KEY_our ? "our" : "my"));
1962 else if (attrs && type != OP_PUSHMARK) {
1968 PL_in_my_stash = Nullhv;
1970 /* check for C<my Dog $spot> when deciding package */
1971 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1972 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED)
1973 && HvNAME(SvSTASH(*namesvp)))
1974 stash = SvSTASH(*namesvp);
1976 stash = PL_curstash;
1977 padsv = PAD_SV(o->op_targ);
1978 apply_attrs(stash, padsv, attrs);
1980 o->op_flags |= OPf_MOD;
1981 o->op_private |= OPpLVAL_INTRO;
1986 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1988 if (o->op_flags & OPf_PARENS)
1992 o = my_kid(o, attrs);
1994 PL_in_my_stash = Nullhv;
1999 Perl_my(pTHX_ OP *o)
2001 return my_kid(o, Nullop);
2005 Perl_sawparens(pTHX_ OP *o)
2008 o->op_flags |= OPf_PARENS;
2013 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2017 if (ckWARN(WARN_MISC) &&
2018 (left->op_type == OP_RV2AV ||
2019 left->op_type == OP_RV2HV ||
2020 left->op_type == OP_PADAV ||
2021 left->op_type == OP_PADHV)) {
2022 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2023 right->op_type == OP_TRANS)
2024 ? right->op_type : OP_MATCH];
2025 const char *sample = ((left->op_type == OP_RV2AV ||
2026 left->op_type == OP_PADAV)
2027 ? "@array" : "%hash");
2028 Perl_warner(aTHX_ WARN_MISC,
2029 "Applying %s to %s will act on scalar(%s)",
2030 desc, sample, sample);
2033 if (!(right->op_flags & OPf_STACKED) &&
2034 (right->op_type == OP_MATCH ||
2035 right->op_type == OP_SUBST ||
2036 right->op_type == OP_TRANS)) {
2037 right->op_flags |= OPf_STACKED;
2038 if (right->op_type != OP_MATCH &&
2039 ! (right->op_type == OP_TRANS &&
2040 right->op_private & OPpTRANS_IDENTICAL))
2041 left = mod(left, right->op_type);
2042 if (right->op_type == OP_TRANS)
2043 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2045 o = prepend_elem(right->op_type, scalar(left), right);
2047 return newUNOP(OP_NOT, 0, scalar(o));
2051 return bind_match(type, left,
2052 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2056 Perl_invert(pTHX_ OP *o)
2060 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2061 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2065 Perl_scope(pTHX_ OP *o)
2068 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2069 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2070 o->op_type = OP_LEAVE;
2071 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2074 if (o->op_type == OP_LINESEQ) {
2076 o->op_type = OP_SCOPE;
2077 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2078 kid = ((LISTOP*)o)->op_first;
2079 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2083 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2090 Perl_save_hints(pTHX)
2093 SAVESPTR(GvHV(PL_hintgv));
2094 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2095 SAVEFREESV(GvHV(PL_hintgv));
2099 Perl_block_start(pTHX_ int full)
2101 int retval = PL_savestack_ix;
2103 SAVEI32(PL_comppad_name_floor);
2104 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2106 PL_comppad_name_fill = PL_comppad_name_floor;
2107 if (PL_comppad_name_floor < 0)
2108 PL_comppad_name_floor = 0;
2109 SAVEI32(PL_min_intro_pending);
2110 SAVEI32(PL_max_intro_pending);
2111 PL_min_intro_pending = 0;
2112 SAVEI32(PL_comppad_name_fill);
2113 SAVEI32(PL_padix_floor);
2114 PL_padix_floor = PL_padix;
2115 PL_pad_reset_pending = FALSE;
2117 PL_hints &= ~HINT_BLOCK_SCOPE;
2118 SAVESPTR(PL_compiling.cop_warnings);
2119 if (! specialWARN(PL_compiling.cop_warnings)) {
2120 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2121 SAVEFREESV(PL_compiling.cop_warnings) ;
2123 SAVESPTR(PL_compiling.cop_io);
2124 if (! specialCopIO(PL_compiling.cop_io)) {
2125 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2126 SAVEFREESV(PL_compiling.cop_io) ;
2132 Perl_block_end(pTHX_ I32 floor, OP *seq)
2134 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2135 OP* retval = scalarseq(seq);
2137 PL_pad_reset_pending = FALSE;
2138 PL_compiling.op_private = PL_hints;
2140 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2141 pad_leavemy(PL_comppad_name_fill);
2150 OP *o = newOP(OP_THREADSV, 0);
2151 o->op_targ = find_threadsv("_");
2154 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2155 #endif /* USE_THREADS */
2159 Perl_newPROG(pTHX_ OP *o)
2164 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2165 ((PL_in_eval & EVAL_KEEPERR)
2166 ? OPf_SPECIAL : 0), o);
2167 PL_eval_start = linklist(PL_eval_root);
2168 PL_eval_root->op_private |= OPpREFCOUNTED;
2169 OpREFCNT_set(PL_eval_root, 1);
2170 PL_eval_root->op_next = 0;
2171 peep(PL_eval_start);
2176 PL_main_root = scope(sawparens(scalarvoid(o)));
2177 PL_curcop = &PL_compiling;
2178 PL_main_start = LINKLIST(PL_main_root);
2179 PL_main_root->op_private |= OPpREFCOUNTED;
2180 OpREFCNT_set(PL_main_root, 1);
2181 PL_main_root->op_next = 0;
2182 peep(PL_main_start);
2185 /* Register with debugger */
2187 CV *cv = get_cv("DB::postponed", FALSE);
2191 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2193 call_sv((SV*)cv, G_DISCARD);
2200 Perl_localize(pTHX_ OP *o, I32 lex)
2202 if (o->op_flags & OPf_PARENS)
2205 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2207 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2208 if (*s == ';' || *s == '=')
2209 Perl_warner(aTHX_ WARN_PARENTHESIS,
2210 "Parentheses missing around \"%s\" list",
2211 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2217 o = mod(o, OP_NULL); /* a bit kludgey */
2219 PL_in_my_stash = Nullhv;
2224 Perl_jmaybe(pTHX_ OP *o)
2226 if (o->op_type == OP_LIST) {
2229 o2 = newOP(OP_THREADSV, 0);
2230 o2->op_targ = find_threadsv(";");
2232 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2233 #endif /* USE_THREADS */
2234 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2240 Perl_fold_constants(pTHX_ register OP *o)
2243 I32 type = o->op_type;
2246 if (PL_opargs[type] & OA_RETSCALAR)
2248 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2249 o->op_targ = pad_alloc(type, SVs_PADTMP);
2251 /* integerize op, unless it happens to be C<-foo>.
2252 * XXX should pp_i_negate() do magic string negation instead? */
2253 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2254 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2255 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2257 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2260 if (!(PL_opargs[type] & OA_FOLDCONST))
2265 /* XXX might want a ck_negate() for this */
2266 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2278 /* XXX what about the numeric ops? */
2279 if (PL_hints & HINT_LOCALE)
2284 goto nope; /* Don't try to run w/ errors */
2286 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2287 if ((curop->op_type != OP_CONST ||
2288 (curop->op_private & OPpCONST_BARE)) &&
2289 curop->op_type != OP_LIST &&
2290 curop->op_type != OP_SCALAR &&
2291 curop->op_type != OP_NULL &&
2292 curop->op_type != OP_PUSHMARK)
2298 curop = LINKLIST(o);
2302 sv = *(PL_stack_sp--);
2303 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2304 pad_swipe(o->op_targ);
2305 else if (SvTEMP(sv)) { /* grab mortal temp? */
2306 (void)SvREFCNT_inc(sv);
2310 if (type == OP_RV2GV)
2311 return newGVOP(OP_GV, 0, (GV*)sv);
2313 /* try to smush double to int, but don't smush -2.0 to -2 */
2314 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2317 #ifdef PERL_PRESERVE_IVUV
2318 /* Only bother to attempt to fold to IV if
2319 most operators will benefit */
2323 return newSVOP(OP_CONST, 0, sv);
2327 if (!(PL_opargs[type] & OA_OTHERINT))
2330 if (!(PL_hints & HINT_INTEGER)) {
2331 if (type == OP_MODULO
2332 || type == OP_DIVIDE
2333 || !(o->op_flags & OPf_KIDS))
2338 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2339 if (curop->op_type == OP_CONST) {
2340 if (SvIOK(((SVOP*)curop)->op_sv))
2344 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2348 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2355 Perl_gen_constant_list(pTHX_ register OP *o)
2358 I32 oldtmps_floor = PL_tmps_floor;
2362 return o; /* Don't attempt to run with errors */
2364 PL_op = curop = LINKLIST(o);
2371 PL_tmps_floor = oldtmps_floor;
2373 o->op_type = OP_RV2AV;
2374 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2375 curop = ((UNOP*)o)->op_first;
2376 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2383 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2385 if (!o || o->op_type != OP_LIST)
2386 o = newLISTOP(OP_LIST, 0, o, Nullop);
2388 o->op_flags &= ~OPf_WANT;
2390 if (!(PL_opargs[type] & OA_MARK))
2391 op_null(cLISTOPo->op_first);
2394 o->op_ppaddr = PL_ppaddr[type];
2395 o->op_flags |= flags;
2397 o = CHECKOP(type, o);
2398 if (o->op_type != type)
2401 return fold_constants(o);
2404 /* List constructors */
2407 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2415 if (first->op_type != type
2416 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2418 return newLISTOP(type, 0, first, last);
2421 if (first->op_flags & OPf_KIDS)
2422 ((LISTOP*)first)->op_last->op_sibling = last;
2424 first->op_flags |= OPf_KIDS;
2425 ((LISTOP*)first)->op_first = last;
2427 ((LISTOP*)first)->op_last = last;
2432 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2440 if (first->op_type != type)
2441 return prepend_elem(type, (OP*)first, (OP*)last);
2443 if (last->op_type != type)
2444 return append_elem(type, (OP*)first, (OP*)last);
2446 first->op_last->op_sibling = last->op_first;
2447 first->op_last = last->op_last;
2448 first->op_flags |= (last->op_flags & OPf_KIDS);
2450 #ifdef PL_OP_SLAB_ALLOC
2458 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2466 if (last->op_type == type) {
2467 if (type == OP_LIST) { /* already a PUSHMARK there */
2468 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2469 ((LISTOP*)last)->op_first->op_sibling = first;
2470 if (!(first->op_flags & OPf_PARENS))
2471 last->op_flags &= ~OPf_PARENS;
2474 if (!(last->op_flags & OPf_KIDS)) {
2475 ((LISTOP*)last)->op_last = first;
2476 last->op_flags |= OPf_KIDS;
2478 first->op_sibling = ((LISTOP*)last)->op_first;
2479 ((LISTOP*)last)->op_first = first;
2481 last->op_flags |= OPf_KIDS;
2485 return newLISTOP(type, 0, first, last);
2491 Perl_newNULLLIST(pTHX)
2493 return newOP(OP_STUB, 0);
2497 Perl_force_list(pTHX_ OP *o)
2499 if (!o || o->op_type != OP_LIST)
2500 o = newLISTOP(OP_LIST, 0, o, Nullop);
2506 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2510 NewOp(1101, listop, 1, LISTOP);
2512 listop->op_type = type;
2513 listop->op_ppaddr = PL_ppaddr[type];
2516 listop->op_flags = flags;
2520 else if (!first && last)
2523 first->op_sibling = last;
2524 listop->op_first = first;
2525 listop->op_last = last;
2526 if (type == OP_LIST) {
2528 pushop = newOP(OP_PUSHMARK, 0);
2529 pushop->op_sibling = first;
2530 listop->op_first = pushop;
2531 listop->op_flags |= OPf_KIDS;
2533 listop->op_last = pushop;
2540 Perl_newOP(pTHX_ I32 type, I32 flags)
2543 NewOp(1101, o, 1, OP);
2545 o->op_ppaddr = PL_ppaddr[type];
2546 o->op_flags = flags;
2549 o->op_private = 0 + (flags >> 8);
2550 if (PL_opargs[type] & OA_RETSCALAR)
2552 if (PL_opargs[type] & OA_TARGET)
2553 o->op_targ = pad_alloc(type, SVs_PADTMP);
2554 return CHECKOP(type, o);
2558 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2563 first = newOP(OP_STUB, 0);
2564 if (PL_opargs[type] & OA_MARK)
2565 first = force_list(first);
2567 NewOp(1101, unop, 1, UNOP);
2568 unop->op_type = type;
2569 unop->op_ppaddr = PL_ppaddr[type];
2570 unop->op_first = first;
2571 unop->op_flags = flags | OPf_KIDS;
2572 unop->op_private = 1 | (flags >> 8);
2573 unop = (UNOP*) CHECKOP(type, unop);
2577 return fold_constants((OP *) unop);
2581 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2584 NewOp(1101, binop, 1, BINOP);
2587 first = newOP(OP_NULL, 0);
2589 binop->op_type = type;
2590 binop->op_ppaddr = PL_ppaddr[type];
2591 binop->op_first = first;
2592 binop->op_flags = flags | OPf_KIDS;
2595 binop->op_private = 1 | (flags >> 8);
2598 binop->op_private = 2 | (flags >> 8);
2599 first->op_sibling = last;
2602 binop = (BINOP*)CHECKOP(type, binop);
2603 if (binop->op_next || binop->op_type != type)
2606 binop->op_last = binop->op_first->op_sibling;
2608 return fold_constants((OP *)binop);
2612 uvcompare(const void *a, const void *b)
2614 if (*((UV *)a) < (*(UV *)b))
2616 if (*((UV *)a) > (*(UV *)b))
2618 if (*((UV *)a+1) < (*(UV *)b+1))
2620 if (*((UV *)a+1) > (*(UV *)b+1))
2626 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2628 SV *tstr = ((SVOP*)expr)->op_sv;
2629 SV *rstr = ((SVOP*)repl)->op_sv;
2632 U8 *t = (U8*)SvPV(tstr, tlen);
2633 U8 *r = (U8*)SvPV(rstr, rlen);
2640 register short *tbl;
2642 PL_hints |= HINT_BLOCK_SCOPE;
2643 complement = o->op_private & OPpTRANS_COMPLEMENT;
2644 del = o->op_private & OPpTRANS_DELETE;
2645 squash = o->op_private & OPpTRANS_SQUASH;
2648 o->op_private |= OPpTRANS_FROM_UTF;
2651 o->op_private |= OPpTRANS_TO_UTF;
2653 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2654 SV* listsv = newSVpvn("# comment\n",10);
2656 U8* tend = t + tlen;
2657 U8* rend = r + rlen;
2671 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2672 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2678 tsave = t = bytes_to_utf8(t, &len);
2681 if (!to_utf && rlen) {
2683 rsave = r = bytes_to_utf8(r, &len);
2687 /* There are several snags with this code on EBCDIC:
2688 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2689 2. scan_const() in toke.c has encoded chars in native encoding which makes
2690 ranges at least in EBCDIC 0..255 range the bottom odd.
2694 U8 tmpbuf[UTF8_MAXLEN+1];
2697 New(1109, cp, 2*tlen, UV);
2699 transv = newSVpvn("",0);
2701 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2703 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2705 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2709 cp[2*i+1] = cp[2*i];
2713 qsort(cp, i, 2*sizeof(UV), uvcompare);
2714 for (j = 0; j < i; j++) {
2716 diff = val - nextmin;
2718 t = uvuni_to_utf8(tmpbuf,nextmin);
2719 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2721 U8 range_mark = UTF_TO_NATIVE(0xff);
2722 t = uvuni_to_utf8(tmpbuf, val - 1);
2723 sv_catpvn(transv, (char *)&range_mark, 1);
2724 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2731 t = uvuni_to_utf8(tmpbuf,nextmin);
2732 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2734 U8 range_mark = UTF_TO_NATIVE(0xff);
2735 sv_catpvn(transv, (char *)&range_mark, 1);
2737 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2738 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2739 t = (U8*)SvPVX(transv);
2740 tlen = SvCUR(transv);
2744 else if (!rlen && !del) {
2745 r = t; rlen = tlen; rend = tend;
2748 if ((!rlen && !del) || t == r ||
2749 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2751 o->op_private |= OPpTRANS_IDENTICAL;
2755 while (t < tend || tfirst <= tlast) {
2756 /* see if we need more "t" chars */
2757 if (tfirst > tlast) {
2758 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2760 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2762 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2769 /* now see if we need more "r" chars */
2770 if (rfirst > rlast) {
2772 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2774 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2776 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2785 rfirst = rlast = 0xffffffff;
2789 /* now see which range will peter our first, if either. */
2790 tdiff = tlast - tfirst;
2791 rdiff = rlast - rfirst;
2798 if (rfirst == 0xffffffff) {
2799 diff = tdiff; /* oops, pretend rdiff is infinite */
2801 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2802 (long)tfirst, (long)tlast);
2804 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2808 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2809 (long)tfirst, (long)(tfirst + diff),
2812 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2813 (long)tfirst, (long)rfirst);
2815 if (rfirst + diff > max)
2816 max = rfirst + diff;
2818 grows = (tfirst < rfirst &&
2819 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2831 else if (max > 0xff)
2836 Safefree(cPVOPo->op_pv);
2837 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2838 SvREFCNT_dec(listsv);
2840 SvREFCNT_dec(transv);
2842 if (!del && havefinal && rlen)
2843 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2844 newSVuv((UV)final), 0);
2847 o->op_private |= OPpTRANS_GROWS;
2859 tbl = (short*)cPVOPo->op_pv;
2861 Zero(tbl, 256, short);
2862 for (i = 0; i < tlen; i++)
2864 for (i = 0, j = 0; i < 256; i++) {
2875 if (i < 128 && r[j] >= 128)
2885 o->op_private |= OPpTRANS_IDENTICAL;
2890 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2891 tbl[0x100] = rlen - j;
2892 for (i=0; i < rlen - j; i++)
2893 tbl[0x101+i] = r[j+i];
2897 if (!rlen && !del) {
2900 o->op_private |= OPpTRANS_IDENTICAL;
2902 for (i = 0; i < 256; i++)
2904 for (i = 0, j = 0; i < tlen; i++,j++) {
2907 if (tbl[t[i]] == -1)
2913 if (tbl[t[i]] == -1) {
2914 if (t[i] < 128 && r[j] >= 128)
2921 o->op_private |= OPpTRANS_GROWS;
2929 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2933 NewOp(1101, pmop, 1, PMOP);
2934 pmop->op_type = type;
2935 pmop->op_ppaddr = PL_ppaddr[type];
2936 pmop->op_flags = flags;
2937 pmop->op_private = 0 | (flags >> 8);
2939 if (PL_hints & HINT_RE_TAINT)
2940 pmop->op_pmpermflags |= PMf_RETAINT;
2941 if (PL_hints & HINT_LOCALE)
2942 pmop->op_pmpermflags |= PMf_LOCALE;
2943 pmop->op_pmflags = pmop->op_pmpermflags;
2945 /* link into pm list */
2946 if (type != OP_TRANS && PL_curstash) {
2947 pmop->op_pmnext = HvPMROOT(PL_curstash);
2948 HvPMROOT(PL_curstash) = pmop;
2949 PmopSTASH_set(pmop,PL_curstash);
2956 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2960 I32 repl_has_vars = 0;
2962 if (o->op_type == OP_TRANS)
2963 return pmtrans(o, expr, repl);
2965 PL_hints |= HINT_BLOCK_SCOPE;
2968 if (expr->op_type == OP_CONST) {
2970 SV *pat = ((SVOP*)expr)->op_sv;
2971 char *p = SvPV(pat, plen);
2972 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2973 sv_setpvn(pat, "\\s+", 3);
2974 p = SvPV(pat, plen);
2975 pm->op_pmflags |= PMf_SKIPWHITE;
2977 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2978 pm->op_pmdynflags |= PMdf_UTF8;
2979 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2980 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2981 pm->op_pmflags |= PMf_WHITE;
2985 if (PL_hints & HINT_UTF8)
2986 pm->op_pmdynflags |= PMdf_UTF8;
2987 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2988 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2990 : OP_REGCMAYBE),0,expr);
2992 NewOp(1101, rcop, 1, LOGOP);
2993 rcop->op_type = OP_REGCOMP;
2994 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2995 rcop->op_first = scalar(expr);
2996 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2997 ? (OPf_SPECIAL | OPf_KIDS)
2999 rcop->op_private = 1;
3002 /* establish postfix order */
3003 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3005 rcop->op_next = expr;
3006 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3009 rcop->op_next = LINKLIST(expr);
3010 expr->op_next = (OP*)rcop;
3013 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3018 if (pm->op_pmflags & PMf_EVAL) {
3020 if (CopLINE(PL_curcop) < PL_multi_end)
3021 CopLINE_set(PL_curcop, PL_multi_end);
3024 else if (repl->op_type == OP_THREADSV
3025 && strchr("&`'123456789+",
3026 PL_threadsv_names[repl->op_targ]))
3030 #endif /* USE_THREADS */
3031 else if (repl->op_type == OP_CONST)
3035 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3036 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3038 if (curop->op_type == OP_THREADSV) {
3040 if (strchr("&`'123456789+", curop->op_private))
3044 if (curop->op_type == OP_GV) {
3045 GV *gv = cGVOPx_gv(curop);
3047 if (strchr("&`'123456789+", *GvENAME(gv)))
3050 #endif /* USE_THREADS */
3051 else if (curop->op_type == OP_RV2CV)
3053 else if (curop->op_type == OP_RV2SV ||
3054 curop->op_type == OP_RV2AV ||
3055 curop->op_type == OP_RV2HV ||
3056 curop->op_type == OP_RV2GV) {
3057 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3060 else if (curop->op_type == OP_PADSV ||
3061 curop->op_type == OP_PADAV ||
3062 curop->op_type == OP_PADHV ||
3063 curop->op_type == OP_PADANY) {
3066 else if (curop->op_type == OP_PUSHRE)
3067 ; /* Okay here, dangerous in newASSIGNOP */
3076 && (!pm->op_pmregexp
3077 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3078 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3079 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3080 prepend_elem(o->op_type, scalar(repl), o);
3083 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3084 pm->op_pmflags |= PMf_MAYBE_CONST;
3085 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3087 NewOp(1101, rcop, 1, LOGOP);
3088 rcop->op_type = OP_SUBSTCONT;
3089 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3090 rcop->op_first = scalar(repl);
3091 rcop->op_flags |= OPf_KIDS;
3092 rcop->op_private = 1;
3095 /* establish postfix order */
3096 rcop->op_next = LINKLIST(repl);
3097 repl->op_next = (OP*)rcop;
3099 pm->op_pmreplroot = scalar((OP*)rcop);
3100 pm->op_pmreplstart = LINKLIST(rcop);
3109 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3112 NewOp(1101, svop, 1, SVOP);
3113 svop->op_type = type;
3114 svop->op_ppaddr = PL_ppaddr[type];
3116 svop->op_next = (OP*)svop;
3117 svop->op_flags = flags;
3118 if (PL_opargs[type] & OA_RETSCALAR)
3120 if (PL_opargs[type] & OA_TARGET)
3121 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3122 return CHECKOP(type, svop);
3126 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3129 NewOp(1101, padop, 1, PADOP);
3130 padop->op_type = type;
3131 padop->op_ppaddr = PL_ppaddr[type];
3132 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3133 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3134 PL_curpad[padop->op_padix] = sv;
3136 padop->op_next = (OP*)padop;
3137 padop->op_flags = flags;
3138 if (PL_opargs[type] & OA_RETSCALAR)
3140 if (PL_opargs[type] & OA_TARGET)
3141 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3142 return CHECKOP(type, padop);
3146 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3150 return newPADOP(type, flags, SvREFCNT_inc(gv));
3152 return newSVOP(type, flags, SvREFCNT_inc(gv));
3157 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3160 NewOp(1101, pvop, 1, PVOP);
3161 pvop->op_type = type;
3162 pvop->op_ppaddr = PL_ppaddr[type];
3164 pvop->op_next = (OP*)pvop;
3165 pvop->op_flags = flags;
3166 if (PL_opargs[type] & OA_RETSCALAR)
3168 if (PL_opargs[type] & OA_TARGET)
3169 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3170 return CHECKOP(type, pvop);
3174 Perl_package(pTHX_ OP *o)
3178 save_hptr(&PL_curstash);
3179 save_item(PL_curstname);
3184 name = SvPV(sv, len);
3185 PL_curstash = gv_stashpvn(name,len,TRUE);
3186 sv_setpvn(PL_curstname, name, len);
3190 sv_setpv(PL_curstname,"<none>");
3191 PL_curstash = Nullhv;
3193 PL_hints |= HINT_BLOCK_SCOPE;
3194 PL_copline = NOLINE;
3199 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3205 if (id->op_type != OP_CONST)
3206 Perl_croak(aTHX_ "Module name must be constant");
3210 if (version != Nullop) {
3211 SV *vesv = ((SVOP*)version)->op_sv;
3213 if (arg == Nullop && !SvNIOKp(vesv)) {
3220 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3221 Perl_croak(aTHX_ "Version number must be constant number");
3223 /* Make copy of id so we don't free it twice */
3224 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3226 /* Fake up a method call to VERSION */
3227 meth = newSVpvn("VERSION",7);
3228 sv_upgrade(meth, SVt_PVIV);
3229 (void)SvIOK_on(meth);
3230 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3231 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3232 append_elem(OP_LIST,
3233 prepend_elem(OP_LIST, pack, list(version)),
3234 newSVOP(OP_METHOD_NAMED, 0, meth)));
3238 /* Fake up an import/unimport */
3239 if (arg && arg->op_type == OP_STUB)
3240 imop = arg; /* no import on explicit () */
3241 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3242 imop = Nullop; /* use 5.0; */
3247 /* Make copy of id so we don't free it twice */
3248 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3250 /* Fake up a method call to import/unimport */
3251 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3252 sv_upgrade(meth, SVt_PVIV);
3253 (void)SvIOK_on(meth);
3254 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3255 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3256 append_elem(OP_LIST,
3257 prepend_elem(OP_LIST, pack, list(arg)),
3258 newSVOP(OP_METHOD_NAMED, 0, meth)));
3261 /* Fake up the BEGIN {}, which does its thing immediately. */
3263 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3266 append_elem(OP_LINESEQ,
3267 append_elem(OP_LINESEQ,
3268 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3269 newSTATEOP(0, Nullch, veop)),
3270 newSTATEOP(0, Nullch, imop) ));
3272 PL_hints |= HINT_BLOCK_SCOPE;
3273 PL_copline = NOLINE;
3278 =for apidoc load_module
3280 Loads the module whose name is pointed to by the string part of name.
3281 Note that the actual module name, not its filename, should be given.
3282 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3283 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3284 (or 0 for no flags). ver, if specified, provides version semantics
3285 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3286 arguments can be used to specify arguments to the module's import()
3287 method, similar to C<use Foo::Bar VERSION LIST>.
3292 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3295 va_start(args, ver);
3296 vload_module(flags, name, ver, &args);
3300 #ifdef PERL_IMPLICIT_CONTEXT
3302 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3306 va_start(args, ver);
3307 vload_module(flags, name, ver, &args);
3313 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3315 OP *modname, *veop, *imop;
3317 modname = newSVOP(OP_CONST, 0, name);
3318 modname->op_private |= OPpCONST_BARE;
3320 veop = newSVOP(OP_CONST, 0, ver);
3324 if (flags & PERL_LOADMOD_NOIMPORT) {
3325 imop = sawparens(newNULLLIST());
3327 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3328 imop = va_arg(*args, OP*);
3333 sv = va_arg(*args, SV*);
3335 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3336 sv = va_arg(*args, SV*);
3340 line_t ocopline = PL_copline;
3341 int oexpect = PL_expect;
3343 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3344 veop, modname, imop);
3345 PL_expect = oexpect;
3346 PL_copline = ocopline;
3351 Perl_dofile(pTHX_ OP *term)
3356 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3357 if (!(gv && GvIMPORTED_CV(gv)))
3358 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3360 if (gv && GvIMPORTED_CV(gv)) {
3361 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3362 append_elem(OP_LIST, term,
3363 scalar(newUNOP(OP_RV2CV, 0,
3368 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3374 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3376 return newBINOP(OP_LSLICE, flags,
3377 list(force_list(subscript)),
3378 list(force_list(listval)) );
3382 S_list_assignment(pTHX_ register OP *o)
3387 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3388 o = cUNOPo->op_first;
3390 if (o->op_type == OP_COND_EXPR) {
3391 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3392 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3397 yyerror("Assignment to both a list and a scalar");
3401 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3402 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3403 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3406 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3409 if (o->op_type == OP_RV2SV)
3416 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3421 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3422 return newLOGOP(optype, 0,
3423 mod(scalar(left), optype),
3424 newUNOP(OP_SASSIGN, 0, scalar(right)));
3427 return newBINOP(optype, OPf_STACKED,
3428 mod(scalar(left), optype), scalar(right));
3432 if (list_assignment(left)) {
3436 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3437 left = mod(left, OP_AASSIGN);
3445 curop = list(force_list(left));
3446 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3447 o->op_private = 0 | (flags >> 8);
3448 for (curop = ((LISTOP*)curop)->op_first;
3449 curop; curop = curop->op_sibling)
3451 if (curop->op_type == OP_RV2HV &&
3452 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3453 o->op_private |= OPpASSIGN_HASH;
3457 if (!(left->op_private & OPpLVAL_INTRO)) {
3460 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3461 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3462 if (curop->op_type == OP_GV) {
3463 GV *gv = cGVOPx_gv(curop);
3464 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3466 SvCUR(gv) = PL_generation;
3468 else if (curop->op_type == OP_PADSV ||
3469 curop->op_type == OP_PADAV ||
3470 curop->op_type == OP_PADHV ||
3471 curop->op_type == OP_PADANY) {
3472 SV **svp = AvARRAY(PL_comppad_name);
3473 SV *sv = svp[curop->op_targ];
3474 if (SvCUR(sv) == PL_generation)
3476 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3478 else if (curop->op_type == OP_RV2CV)
3480 else if (curop->op_type == OP_RV2SV ||
3481 curop->op_type == OP_RV2AV ||
3482 curop->op_type == OP_RV2HV ||
3483 curop->op_type == OP_RV2GV) {
3484 if (lastop->op_type != OP_GV) /* funny deref? */
3487 else if (curop->op_type == OP_PUSHRE) {
3488 if (((PMOP*)curop)->op_pmreplroot) {
3490 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3492 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3494 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3496 SvCUR(gv) = PL_generation;
3505 o->op_private |= OPpASSIGN_COMMON;
3507 if (right && right->op_type == OP_SPLIT) {
3509 if ((tmpop = ((LISTOP*)right)->op_first) &&
3510 tmpop->op_type == OP_PUSHRE)
3512 PMOP *pm = (PMOP*)tmpop;
3513 if (left->op_type == OP_RV2AV &&
3514 !(left->op_private & OPpLVAL_INTRO) &&
3515 !(o->op_private & OPpASSIGN_COMMON) )
3517 tmpop = ((UNOP*)left)->op_first;
3518 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3520 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3521 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3523 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3524 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3526 pm->op_pmflags |= PMf_ONCE;
3527 tmpop = cUNOPo->op_first; /* to list (nulled) */
3528 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3529 tmpop->op_sibling = Nullop; /* don't free split */
3530 right->op_next = tmpop->op_next; /* fix starting loc */
3531 op_free(o); /* blow off assign */
3532 right->op_flags &= ~OPf_WANT;
3533 /* "I don't know and I don't care." */
3538 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3539 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3541 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3543 sv_setiv(sv, PL_modcount+1);
3551 right = newOP(OP_UNDEF, 0);
3552 if (right->op_type == OP_READLINE) {
3553 right->op_flags |= OPf_STACKED;
3554 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3557 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3558 o = newBINOP(OP_SASSIGN, flags,
3559 scalar(right), mod(scalar(left), OP_SASSIGN) );
3571 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3573 U32 seq = intro_my();
3576 NewOp(1101, cop, 1, COP);
3577 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3578 cop->op_type = OP_DBSTATE;
3579 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3582 cop->op_type = OP_NEXTSTATE;
3583 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3585 cop->op_flags = flags;
3586 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3588 cop->op_private |= NATIVE_HINTS;
3590 PL_compiling.op_private = cop->op_private;
3591 cop->op_next = (OP*)cop;
3594 cop->cop_label = label;
3595 PL_hints |= HINT_BLOCK_SCOPE;
3598 cop->cop_arybase = PL_curcop->cop_arybase;
3599 if (specialWARN(PL_curcop->cop_warnings))
3600 cop->cop_warnings = PL_curcop->cop_warnings ;
3602 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3603 if (specialCopIO(PL_curcop->cop_io))
3604 cop->cop_io = PL_curcop->cop_io;
3606 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3609 if (PL_copline == NOLINE)
3610 CopLINE_set(cop, CopLINE(PL_curcop));
3612 CopLINE_set(cop, PL_copline);
3613 PL_copline = NOLINE;
3616 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3618 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3620 CopSTASH_set(cop, PL_curstash);
3622 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3623 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3624 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3625 (void)SvIOK_on(*svp);
3626 SvIVX(*svp) = PTR2IV(cop);
3630 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3633 /* "Introduce" my variables to visible status. */
3641 if (! PL_min_intro_pending)
3642 return PL_cop_seqmax;
3644 svp = AvARRAY(PL_comppad_name);
3645 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3646 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3647 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3648 SvNVX(sv) = (NV)PL_cop_seqmax;
3651 PL_min_intro_pending = 0;
3652 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3653 return PL_cop_seqmax++;
3657 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3659 return new_logop(type, flags, &first, &other);
3663 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3667 OP *first = *firstp;
3668 OP *other = *otherp;
3670 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3671 return newBINOP(type, flags, scalar(first), scalar(other));
3673 scalarboolean(first);
3674 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3675 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3676 if (type == OP_AND || type == OP_OR) {
3682 first = *firstp = cUNOPo->op_first;
3684 first->op_next = o->op_next;
3685 cUNOPo->op_first = Nullop;
3689 if (first->op_type == OP_CONST) {
3690 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3691 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3692 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3703 else if (first->op_type == OP_WANTARRAY) {
3709 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3710 OP *k1 = ((UNOP*)first)->op_first;
3711 OP *k2 = k1->op_sibling;
3713 switch (first->op_type)
3716 if (k2 && k2->op_type == OP_READLINE
3717 && (k2->op_flags & OPf_STACKED)
3718 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3720 warnop = k2->op_type;
3725 if (k1->op_type == OP_READDIR
3726 || k1->op_type == OP_GLOB
3727 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3728 || k1->op_type == OP_EACH)
3730 warnop = ((k1->op_type == OP_NULL)
3731 ? k1->op_targ : k1->op_type);
3736 line_t oldline = CopLINE(PL_curcop);
3737 CopLINE_set(PL_curcop, PL_copline);
3738 Perl_warner(aTHX_ WARN_MISC,
3739 "Value of %s%s can be \"0\"; test with defined()",
3741 ((warnop == OP_READLINE || warnop == OP_GLOB)
3742 ? " construct" : "() operator"));
3743 CopLINE_set(PL_curcop, oldline);
3750 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3751 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3753 NewOp(1101, logop, 1, LOGOP);
3755 logop->op_type = type;
3756 logop->op_ppaddr = PL_ppaddr[type];
3757 logop->op_first = first;
3758 logop->op_flags = flags | OPf_KIDS;
3759 logop->op_other = LINKLIST(other);
3760 logop->op_private = 1 | (flags >> 8);
3762 /* establish postfix order */
3763 logop->op_next = LINKLIST(first);
3764 first->op_next = (OP*)logop;
3765 first->op_sibling = other;
3767 o = newUNOP(OP_NULL, 0, (OP*)logop);
3774 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3781 return newLOGOP(OP_AND, 0, first, trueop);
3783 return newLOGOP(OP_OR, 0, first, falseop);
3785 scalarboolean(first);
3786 if (first->op_type == OP_CONST) {
3787 if (SvTRUE(((SVOP*)first)->op_sv)) {
3798 else if (first->op_type == OP_WANTARRAY) {
3802 NewOp(1101, logop, 1, LOGOP);
3803 logop->op_type = OP_COND_EXPR;
3804 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3805 logop->op_first = first;
3806 logop->op_flags = flags | OPf_KIDS;
3807 logop->op_private = 1 | (flags >> 8);
3808 logop->op_other = LINKLIST(trueop);
3809 logop->op_next = LINKLIST(falseop);
3812 /* establish postfix order */
3813 start = LINKLIST(first);
3814 first->op_next = (OP*)logop;
3816 first->op_sibling = trueop;
3817 trueop->op_sibling = falseop;
3818 o = newUNOP(OP_NULL, 0, (OP*)logop);
3820 trueop->op_next = falseop->op_next = o;
3827 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3835 NewOp(1101, range, 1, LOGOP);
3837 range->op_type = OP_RANGE;
3838 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3839 range->op_first = left;
3840 range->op_flags = OPf_KIDS;
3841 leftstart = LINKLIST(left);
3842 range->op_other = LINKLIST(right);
3843 range->op_private = 1 | (flags >> 8);
3845 left->op_sibling = right;
3847 range->op_next = (OP*)range;
3848 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3849 flop = newUNOP(OP_FLOP, 0, flip);
3850 o = newUNOP(OP_NULL, 0, flop);
3852 range->op_next = leftstart;
3854 left->op_next = flip;
3855 right->op_next = flop;
3857 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3858 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3859 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3860 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3862 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3863 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3866 if (!flip->op_private || !flop->op_private)
3867 linklist(o); /* blow off optimizer unless constant */
3873 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3877 int once = block && block->op_flags & OPf_SPECIAL &&
3878 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3881 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3882 return block; /* do {} while 0 does once */
3883 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3884 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3885 expr = newUNOP(OP_DEFINED, 0,
3886 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3887 } else if (expr->op_flags & OPf_KIDS) {
3888 OP *k1 = ((UNOP*)expr)->op_first;
3889 OP *k2 = (k1) ? k1->op_sibling : NULL;
3890 switch (expr->op_type) {
3892 if (k2 && k2->op_type == OP_READLINE
3893 && (k2->op_flags & OPf_STACKED)
3894 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3895 expr = newUNOP(OP_DEFINED, 0, expr);
3899 if (k1->op_type == OP_READDIR
3900 || k1->op_type == OP_GLOB
3901 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3902 || k1->op_type == OP_EACH)
3903 expr = newUNOP(OP_DEFINED, 0, expr);
3909 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3910 o = new_logop(OP_AND, 0, &expr, &listop);
3913 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3915 if (once && o != listop)
3916 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3919 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3921 o->op_flags |= flags;
3923 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3928 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3937 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3938 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3939 expr = newUNOP(OP_DEFINED, 0,
3940 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3941 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3942 OP *k1 = ((UNOP*)expr)->op_first;
3943 OP *k2 = (k1) ? k1->op_sibling : NULL;
3944 switch (expr->op_type) {
3946 if (k2 && k2->op_type == OP_READLINE
3947 && (k2->op_flags & OPf_STACKED)
3948 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3949 expr = newUNOP(OP_DEFINED, 0, expr);
3953 if (k1->op_type == OP_READDIR
3954 || k1->op_type == OP_GLOB
3955 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3956 || k1->op_type == OP_EACH)
3957 expr = newUNOP(OP_DEFINED, 0, expr);
3963 block = newOP(OP_NULL, 0);
3965 block = scope(block);
3969 next = LINKLIST(cont);
3972 OP *unstack = newOP(OP_UNSTACK, 0);
3975 cont = append_elem(OP_LINESEQ, cont, unstack);
3976 if ((line_t)whileline != NOLINE) {
3977 PL_copline = whileline;
3978 cont = append_elem(OP_LINESEQ, cont,
3979 newSTATEOP(0, Nullch, Nullop));
3983 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3984 redo = LINKLIST(listop);
3987 PL_copline = whileline;
3989 o = new_logop(OP_AND, 0, &expr, &listop);
3990 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3991 op_free(expr); /* oops, it's a while (0) */
3993 return Nullop; /* listop already freed by new_logop */
3996 ((LISTOP*)listop)->op_last->op_next = condop =
3997 (o == listop ? redo : LINKLIST(o));
4003 NewOp(1101,loop,1,LOOP);
4004 loop->op_type = OP_ENTERLOOP;
4005 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4006 loop->op_private = 0;
4007 loop->op_next = (OP*)loop;
4010 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4012 loop->op_redoop = redo;
4013 loop->op_lastop = o;
4014 o->op_private |= loopflags;
4017 loop->op_nextop = next;
4019 loop->op_nextop = o;
4021 o->op_flags |= flags;
4022 o->op_private |= (flags >> 8);
4027 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4035 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4036 sv->op_type = OP_RV2GV;
4037 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4039 else if (sv->op_type == OP_PADSV) { /* private variable */
4040 padoff = sv->op_targ;
4045 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4046 padoff = sv->op_targ;
4048 iterflags |= OPf_SPECIAL;
4053 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4057 padoff = find_threadsv("_");
4058 iterflags |= OPf_SPECIAL;
4060 sv = newGVOP(OP_GV, 0, PL_defgv);
4063 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4064 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4065 iterflags |= OPf_STACKED;
4067 else if (expr->op_type == OP_NULL &&
4068 (expr->op_flags & OPf_KIDS) &&
4069 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4071 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4072 * set the STACKED flag to indicate that these values are to be
4073 * treated as min/max values by 'pp_iterinit'.
4075 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4076 LOGOP* range = (LOGOP*) flip->op_first;
4077 OP* left = range->op_first;
4078 OP* right = left->op_sibling;
4081 range->op_flags &= ~OPf_KIDS;
4082 range->op_first = Nullop;
4084 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4085 listop->op_first->op_next = range->op_next;
4086 left->op_next = range->op_other;
4087 right->op_next = (OP*)listop;
4088 listop->op_next = listop->op_first;
4091 expr = (OP*)(listop);
4093 iterflags |= OPf_STACKED;
4096 expr = mod(force_list(expr), OP_GREPSTART);
4100 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4101 append_elem(OP_LIST, expr, scalar(sv))));
4102 assert(!loop->op_next);
4103 #ifdef PL_OP_SLAB_ALLOC
4106 NewOp(1234,tmp,1,LOOP);
4107 Copy(loop,tmp,1,LOOP);
4111 Renew(loop, 1, LOOP);
4113 loop->op_targ = padoff;
4114 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4115 PL_copline = forline;
4116 return newSTATEOP(0, label, wop);
4120 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4125 if (type != OP_GOTO || label->op_type == OP_CONST) {
4126 /* "last()" means "last" */
4127 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4128 o = newOP(type, OPf_SPECIAL);
4130 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4131 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4137 if (label->op_type == OP_ENTERSUB)
4138 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4139 o = newUNOP(type, OPf_STACKED, label);
4141 PL_hints |= HINT_BLOCK_SCOPE;
4146 Perl_cv_undef(pTHX_ CV *cv)
4150 MUTEX_DESTROY(CvMUTEXP(cv));
4151 Safefree(CvMUTEXP(cv));
4154 #endif /* USE_THREADS */
4156 if (!CvXSUB(cv) && CvROOT(cv)) {
4158 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4159 Perl_croak(aTHX_ "Can't undef active subroutine");
4162 Perl_croak(aTHX_ "Can't undef active subroutine");
4163 #endif /* USE_THREADS */
4166 SAVEVPTR(PL_curpad);
4169 op_free(CvROOT(cv));
4170 CvROOT(cv) = Nullop;
4173 SvPOK_off((SV*)cv); /* forget prototype */
4175 /* Since closure prototypes have the same lifetime as the containing
4176 * CV, they don't hold a refcount on the outside CV. This avoids
4177 * the refcount loop between the outer CV (which keeps a refcount to
4178 * the closure prototype in the pad entry for pp_anoncode()) and the
4179 * closure prototype, and the ensuing memory leak. This does not
4180 * apply to closures generated within eval"", since eval"" CVs are
4181 * ephemeral. --GSAR */
4182 if (!CvANON(cv) || CvCLONED(cv)
4183 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4184 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4186 SvREFCNT_dec(CvOUTSIDE(cv));
4188 CvOUTSIDE(cv) = Nullcv;
4190 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4193 if (CvPADLIST(cv)) {
4194 /* may be during global destruction */
4195 if (SvREFCNT(CvPADLIST(cv))) {
4196 I32 i = AvFILLp(CvPADLIST(cv));
4198 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4199 SV* sv = svp ? *svp : Nullsv;
4202 if (sv == (SV*)PL_comppad_name)
4203 PL_comppad_name = Nullav;
4204 else if (sv == (SV*)PL_comppad) {
4205 PL_comppad = Nullav;
4206 PL_curpad = Null(SV**);
4210 SvREFCNT_dec((SV*)CvPADLIST(cv));
4212 CvPADLIST(cv) = Nullav;
4220 #ifdef DEBUG_CLOSURES
4222 S_cv_dump(pTHX_ CV *cv)
4225 CV *outside = CvOUTSIDE(cv);
4226 AV* padlist = CvPADLIST(cv);
4233 PerlIO_printf(Perl_debug_log,
4234 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4236 (CvANON(cv) ? "ANON"
4237 : (cv == PL_main_cv) ? "MAIN"
4238 : CvUNIQUE(cv) ? "UNIQUE"
4239 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4242 : CvANON(outside) ? "ANON"
4243 : (outside == PL_main_cv) ? "MAIN"
4244 : CvUNIQUE(outside) ? "UNIQUE"
4245 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4250 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4251 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4252 pname = AvARRAY(pad_name);
4253 ppad = AvARRAY(pad);
4255 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4256 if (SvPOK(pname[ix]))
4257 PerlIO_printf(Perl_debug_log,
4258 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4259 (int)ix, PTR2UV(ppad[ix]),
4260 SvFAKE(pname[ix]) ? "FAKE " : "",
4262 (IV)I_32(SvNVX(pname[ix])),
4265 #endif /* DEBUGGING */
4267 #endif /* DEBUG_CLOSURES */
4270 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4274 AV* protopadlist = CvPADLIST(proto);
4275 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4276 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4277 SV** pname = AvARRAY(protopad_name);
4278 SV** ppad = AvARRAY(protopad);
4279 I32 fname = AvFILLp(protopad_name);
4280 I32 fpad = AvFILLp(protopad);
4284 assert(!CvUNIQUE(proto));
4288 SAVESPTR(PL_comppad_name);
4289 SAVESPTR(PL_compcv);
4291 cv = PL_compcv = (CV*)NEWSV(1104,0);
4292 sv_upgrade((SV *)cv, SvTYPE(proto));
4293 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4297 New(666, CvMUTEXP(cv), 1, perl_mutex);
4298 MUTEX_INIT(CvMUTEXP(cv));
4300 #endif /* USE_THREADS */
4301 CvFILE(cv) = CvFILE(proto);
4302 CvGV(cv) = CvGV(proto);
4303 CvSTASH(cv) = CvSTASH(proto);
4304 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4305 CvSTART(cv) = CvSTART(proto);
4307 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4310 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4312 PL_comppad_name = newAV();
4313 for (ix = fname; ix >= 0; ix--)
4314 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4316 PL_comppad = newAV();
4318 comppadlist = newAV();
4319 AvREAL_off(comppadlist);
4320 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4321 av_store(comppadlist, 1, (SV*)PL_comppad);
4322 CvPADLIST(cv) = comppadlist;
4323 av_fill(PL_comppad, AvFILLp(protopad));
4324 PL_curpad = AvARRAY(PL_comppad);
4326 av = newAV(); /* will be @_ */
4328 av_store(PL_comppad, 0, (SV*)av);
4329 AvFLAGS(av) = AVf_REIFY;
4331 for (ix = fpad; ix > 0; ix--) {
4332 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4333 if (namesv && namesv != &PL_sv_undef) {
4334 char *name = SvPVX(namesv); /* XXX */
4335 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4336 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4337 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4339 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4341 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4343 else { /* our own lexical */
4346 /* anon code -- we'll come back for it */
4347 sv = SvREFCNT_inc(ppad[ix]);
4349 else if (*name == '@')
4351 else if (*name == '%')
4360 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4361 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4364 SV* sv = NEWSV(0,0);
4370 /* Now that vars are all in place, clone nested closures. */
4372 for (ix = fpad; ix > 0; ix--) {
4373 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4375 && namesv != &PL_sv_undef
4376 && !(SvFLAGS(namesv) & SVf_FAKE)
4377 && *SvPVX(namesv) == '&'
4378 && CvCLONE(ppad[ix]))
4380 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4381 SvREFCNT_dec(ppad[ix]);
4384 PL_curpad[ix] = (SV*)kid;
4388 #ifdef DEBUG_CLOSURES
4389 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4391 PerlIO_printf(Perl_debug_log, " from:\n");
4393 PerlIO_printf(Perl_debug_log, " to:\n");
4400 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4402 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4404 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4411 Perl_cv_clone(pTHX_ CV *proto)
4414 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4415 cv = cv_clone2(proto, CvOUTSIDE(proto));
4416 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4421 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4423 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4424 SV* msg = sv_newmortal();
4428 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4429 sv_setpv(msg, "Prototype mismatch:");
4431 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4433 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4434 sv_catpv(msg, " vs ");
4436 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4438 sv_catpv(msg, "none");
4439 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4443 static void const_sv_xsub(pTHXo_ CV* cv);
4446 =for apidoc cv_const_sv
4448 If C<cv> is a constant sub eligible for inlining. returns the constant
4449 value returned by the sub. Otherwise, returns NULL.
4451 Constant subs can be created with C<newCONSTSUB> or as described in
4452 L<perlsub/"Constant Functions">.
4457 Perl_cv_const_sv(pTHX_ CV *cv)
4459 if (!cv || !CvCONST(cv))
4461 return (SV*)CvXSUBANY(cv).any_ptr;
4465 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4472 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4473 o = cLISTOPo->op_first->op_sibling;
4475 for (; o; o = o->op_next) {
4476 OPCODE type = o->op_type;
4478 if (sv && o->op_next == o)
4480 if (o->op_next != o) {
4481 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4483 if (type == OP_DBSTATE)
4486 if (type == OP_LEAVESUB || type == OP_RETURN)
4490 if (type == OP_CONST && cSVOPo->op_sv)
4492 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4493 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4494 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4498 /* We get here only from cv_clone2() while creating a closure.
4499 Copy the const value here instead of in cv_clone2 so that
4500 SvREADONLY_on doesn't lead to problems when leaving
4505 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4517 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4527 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4531 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4533 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4537 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4543 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4548 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4549 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4550 SV *sv = sv_newmortal();
4551 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4552 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4557 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4558 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4568 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4569 maximum a prototype before. */
4570 if (SvTYPE(gv) > SVt_NULL) {
4571 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4572 && ckWARN_d(WARN_PROTOTYPE))
4574 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4576 cv_ckproto((CV*)gv, NULL, ps);
4579 sv_setpv((SV*)gv, ps);
4581 sv_setiv((SV*)gv, -1);
4582 SvREFCNT_dec(PL_compcv);
4583 cv = PL_compcv = NULL;
4584 PL_sub_generation++;
4588 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4590 #ifdef GV_SHARED_CHECK
4591 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4592 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4596 if (!block || !ps || *ps || attrs)
4599 const_sv = op_const_sv(block, Nullcv);
4602 bool exists = CvROOT(cv) || CvXSUB(cv);
4604 #ifdef GV_SHARED_CHECK
4605 if (exists && GvSHARED(gv)) {
4606 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4610 /* if the subroutine doesn't exist and wasn't pre-declared
4611 * with a prototype, assume it will be AUTOLOADed,
4612 * skipping the prototype check
4614 if (exists || SvPOK(cv))
4615 cv_ckproto(cv, gv, ps);
4616 /* already defined (or promised)? */
4617 if (exists || GvASSUMECV(gv)) {
4618 if (!block && !attrs) {
4619 /* just a "sub foo;" when &foo is already defined */
4620 SAVEFREESV(PL_compcv);
4623 /* ahem, death to those who redefine active sort subs */
4624 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4625 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4627 if (ckWARN(WARN_REDEFINE)
4629 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4631 line_t oldline = CopLINE(PL_curcop);
4632 CopLINE_set(PL_curcop, PL_copline);
4633 Perl_warner(aTHX_ WARN_REDEFINE,
4634 CvCONST(cv) ? "Constant subroutine %s redefined"
4635 : "Subroutine %s redefined", name);
4636 CopLINE_set(PL_curcop, oldline);
4644 SvREFCNT_inc(const_sv);
4646 assert(!CvROOT(cv) && !CvCONST(cv));
4647 sv_setpv((SV*)cv, ""); /* prototype is "" */
4648 CvXSUBANY(cv).any_ptr = const_sv;
4649 CvXSUB(cv) = const_sv_xsub;
4654 cv = newCONSTSUB(NULL, name, const_sv);
4657 SvREFCNT_dec(PL_compcv);
4659 PL_sub_generation++;
4666 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4667 * before we clobber PL_compcv.
4671 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4672 stash = GvSTASH(CvGV(cv));
4673 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4674 stash = CvSTASH(cv);
4676 stash = PL_curstash;
4679 /* possibly about to re-define existing subr -- ignore old cv */
4680 rcv = (SV*)PL_compcv;
4681 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4682 stash = GvSTASH(gv);
4684 stash = PL_curstash;
4686 apply_attrs(stash, rcv, attrs);
4688 if (cv) { /* must reuse cv if autoloaded */
4690 /* got here with just attrs -- work done, so bug out */
4691 SAVEFREESV(PL_compcv);
4695 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4696 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4697 CvOUTSIDE(PL_compcv) = 0;
4698 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4699 CvPADLIST(PL_compcv) = 0;
4700 /* inner references to PL_compcv must be fixed up ... */
4702 AV *padlist = CvPADLIST(cv);
4703 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4704 AV *comppad = (AV*)AvARRAY(padlist)[1];
4705 SV **namepad = AvARRAY(comppad_name);
4706 SV **curpad = AvARRAY(comppad);
4707 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4708 SV *namesv = namepad[ix];
4709 if (namesv && namesv != &PL_sv_undef
4710 && *SvPVX(namesv) == '&')
4712 CV *innercv = (CV*)curpad[ix];
4713 if (CvOUTSIDE(innercv) == PL_compcv) {
4714 CvOUTSIDE(innercv) = cv;
4715 if (!CvANON(innercv) || CvCLONED(innercv)) {
4716 (void)SvREFCNT_inc(cv);
4717 SvREFCNT_dec(PL_compcv);
4723 /* ... before we throw it away */
4724 SvREFCNT_dec(PL_compcv);
4731 PL_sub_generation++;
4735 CvFILE(cv) = CopFILE(PL_curcop);
4736 CvSTASH(cv) = PL_curstash;
4739 if (!CvMUTEXP(cv)) {
4740 New(666, CvMUTEXP(cv), 1, perl_mutex);
4741 MUTEX_INIT(CvMUTEXP(cv));
4743 #endif /* USE_THREADS */
4746 sv_setpv((SV*)cv, ps);
4748 if (PL_error_count) {
4752 char *s = strrchr(name, ':');
4754 if (strEQ(s, "BEGIN")) {
4756 "BEGIN not safe after errors--compilation aborted";
4757 if (PL_in_eval & EVAL_KEEPERR)
4758 Perl_croak(aTHX_ not_safe);
4760 /* force display of errors found but not reported */
4761 sv_catpv(ERRSV, not_safe);
4762 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4770 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4771 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4774 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4775 mod(scalarseq(block), OP_LEAVESUBLV));
4778 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4780 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4781 OpREFCNT_set(CvROOT(cv), 1);
4782 CvSTART(cv) = LINKLIST(CvROOT(cv));
4783 CvROOT(cv)->op_next = 0;
4786 /* now that optimizer has done its work, adjust pad values */
4788 SV **namep = AvARRAY(PL_comppad_name);
4789 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4792 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4795 * The only things that a clonable function needs in its
4796 * pad are references to outer lexicals and anonymous subs.
4797 * The rest are created anew during cloning.
4799 if (!((namesv = namep[ix]) != Nullsv &&
4800 namesv != &PL_sv_undef &&
4802 *SvPVX(namesv) == '&')))
4804 SvREFCNT_dec(PL_curpad[ix]);
4805 PL_curpad[ix] = Nullsv;
4808 assert(!CvCONST(cv));
4809 if (ps && !*ps && op_const_sv(block, cv))
4813 AV *av = newAV(); /* Will be @_ */
4815 av_store(PL_comppad, 0, (SV*)av);
4816 AvFLAGS(av) = AVf_REIFY;
4818 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4819 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4821 if (!SvPADMY(PL_curpad[ix]))
4822 SvPADTMP_on(PL_curpad[ix]);
4826 /* If a potential closure prototype, don't keep a refcount on
4827 * outer CV, unless the latter happens to be a passing eval"".
4828 * This is okay as the lifetime of the prototype is tied to the
4829 * lifetime of the outer CV. Avoids memory leak due to reference
4831 if (!name && CvOUTSIDE(cv)
4832 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4833 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4835 SvREFCNT_dec(CvOUTSIDE(cv));
4838 if (name || aname) {
4840 char *tname = (name ? name : aname);
4842 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4843 SV *sv = NEWSV(0,0);
4844 SV *tmpstr = sv_newmortal();
4845 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4849 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4851 (long)PL_subline, (long)CopLINE(PL_curcop));
4852 gv_efullname3(tmpstr, gv, Nullch);
4853 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4854 hv = GvHVn(db_postponed);
4855 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4856 && (pcv = GvCV(db_postponed)))
4862 call_sv((SV*)pcv, G_DISCARD);
4866 if ((s = strrchr(tname,':')))
4871 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4874 if (strEQ(s, "BEGIN")) {
4875 I32 oldscope = PL_scopestack_ix;
4877 SAVECOPFILE(&PL_compiling);
4878 SAVECOPLINE(&PL_compiling);
4880 sv_setsv(PL_rs, PL_nrs);
4883 PL_beginav = newAV();
4884 DEBUG_x( dump_sub(gv) );
4885 av_push(PL_beginav, (SV*)cv);
4886 GvCV(gv) = 0; /* cv has been hijacked */
4887 call_list(oldscope, PL_beginav);
4889 PL_curcop = &PL_compiling;
4890 PL_compiling.op_private = PL_hints;
4893 else if (strEQ(s, "END") && !PL_error_count) {
4896 DEBUG_x( dump_sub(gv) );
4897 av_unshift(PL_endav, 1);
4898 av_store(PL_endav, 0, (SV*)cv);
4899 GvCV(gv) = 0; /* cv has been hijacked */
4901 else if (strEQ(s, "CHECK") && !PL_error_count) {
4903 PL_checkav = newAV();
4904 DEBUG_x( dump_sub(gv) );
4905 if (PL_main_start && ckWARN(WARN_VOID))
4906 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4907 av_unshift(PL_checkav, 1);
4908 av_store(PL_checkav, 0, (SV*)cv);
4909 GvCV(gv) = 0; /* cv has been hijacked */
4911 else if (strEQ(s, "INIT") && !PL_error_count) {
4913 PL_initav = newAV();
4914 DEBUG_x( dump_sub(gv) );
4915 if (PL_main_start && ckWARN(WARN_VOID))
4916 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4917 av_push(PL_initav, (SV*)cv);
4918 GvCV(gv) = 0; /* cv has been hijacked */
4923 PL_copline = NOLINE;
4928 /* XXX unsafe for threads if eval_owner isn't held */
4930 =for apidoc newCONSTSUB
4932 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4933 eligible for inlining at compile-time.
4939 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4945 SAVECOPLINE(PL_curcop);
4946 CopLINE_set(PL_curcop, PL_copline);
4949 PL_hints &= ~HINT_BLOCK_SCOPE;
4952 SAVESPTR(PL_curstash);
4953 SAVECOPSTASH(PL_curcop);
4954 PL_curstash = stash;
4956 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4958 CopSTASH(PL_curcop) = stash;
4962 cv = newXS(name, const_sv_xsub, __FILE__);
4963 CvXSUBANY(cv).any_ptr = sv;
4965 sv_setpv((SV*)cv, ""); /* prototype is "" */
4973 =for apidoc U||newXS
4975 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4981 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4983 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4986 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4988 /* just a cached method */
4992 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4993 /* already defined (or promised) */
4994 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4995 && HvNAME(GvSTASH(CvGV(cv)))
4996 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4997 line_t oldline = CopLINE(PL_curcop);
4998 if (PL_copline != NOLINE)
4999 CopLINE_set(PL_curcop, PL_copline);
5000 Perl_warner(aTHX_ WARN_REDEFINE,
5001 CvCONST(cv) ? "Constant subroutine %s redefined"
5002 : "Subroutine %s redefined"
5004 CopLINE_set(PL_curcop, oldline);
5011 if (cv) /* must reuse cv if autoloaded */
5014 cv = (CV*)NEWSV(1105,0);
5015 sv_upgrade((SV *)cv, SVt_PVCV);
5019 PL_sub_generation++;
5024 New(666, CvMUTEXP(cv), 1, perl_mutex);
5025 MUTEX_INIT(CvMUTEXP(cv));
5027 #endif /* USE_THREADS */
5028 (void)gv_fetchfile(filename);
5029 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5030 an external constant string */
5031 CvXSUB(cv) = subaddr;
5034 char *s = strrchr(name,':');
5040 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5043 if (strEQ(s, "BEGIN")) {
5045 PL_beginav = newAV();
5046 av_push(PL_beginav, (SV*)cv);
5047 GvCV(gv) = 0; /* cv has been hijacked */
5049 else if (strEQ(s, "END")) {
5052 av_unshift(PL_endav, 1);
5053 av_store(PL_endav, 0, (SV*)cv);
5054 GvCV(gv) = 0; /* cv has been hijacked */
5056 else if (strEQ(s, "CHECK")) {
5058 PL_checkav = newAV();
5059 if (PL_main_start && ckWARN(WARN_VOID))
5060 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5061 av_unshift(PL_checkav, 1);
5062 av_store(PL_checkav, 0, (SV*)cv);
5063 GvCV(gv) = 0; /* cv has been hijacked */
5065 else if (strEQ(s, "INIT")) {
5067 PL_initav = newAV();
5068 if (PL_main_start && ckWARN(WARN_VOID))
5069 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5070 av_push(PL_initav, (SV*)cv);
5071 GvCV(gv) = 0; /* cv has been hijacked */
5082 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5091 name = SvPVx(cSVOPo->op_sv, n_a);
5094 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5095 #ifdef GV_SHARED_CHECK
5097 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5101 if ((cv = GvFORM(gv))) {
5102 if (ckWARN(WARN_REDEFINE)) {
5103 line_t oldline = CopLINE(PL_curcop);
5105 CopLINE_set(PL_curcop, PL_copline);
5106 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5107 CopLINE_set(PL_curcop, oldline);
5114 CvFILE(cv) = CopFILE(PL_curcop);
5116 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5117 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5118 SvPADTMP_on(PL_curpad[ix]);
5121 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5122 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5123 OpREFCNT_set(CvROOT(cv), 1);
5124 CvSTART(cv) = LINKLIST(CvROOT(cv));
5125 CvROOT(cv)->op_next = 0;
5128 PL_copline = NOLINE;
5133 Perl_newANONLIST(pTHX_ OP *o)
5135 return newUNOP(OP_REFGEN, 0,
5136 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5140 Perl_newANONHASH(pTHX_ OP *o)
5142 return newUNOP(OP_REFGEN, 0,
5143 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5147 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5149 return newANONATTRSUB(floor, proto, Nullop, block);
5153 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5155 return newUNOP(OP_REFGEN, 0,
5156 newSVOP(OP_ANONCODE, 0,
5157 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5161 Perl_oopsAV(pTHX_ OP *o)
5163 switch (o->op_type) {
5165 o->op_type = OP_PADAV;
5166 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5167 return ref(o, OP_RV2AV);
5170 o->op_type = OP_RV2AV;
5171 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5176 if (ckWARN_d(WARN_INTERNAL))
5177 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5184 Perl_oopsHV(pTHX_ OP *o)
5186 switch (o->op_type) {
5189 o->op_type = OP_PADHV;
5190 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5191 return ref(o, OP_RV2HV);
5195 o->op_type = OP_RV2HV;
5196 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5201 if (ckWARN_d(WARN_INTERNAL))
5202 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5209 Perl_newAVREF(pTHX_ OP *o)
5211 if (o->op_type == OP_PADANY) {
5212 o->op_type = OP_PADAV;
5213 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5216 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5217 && ckWARN(WARN_DEPRECATED)) {
5218 Perl_warner(aTHX_ WARN_DEPRECATED,
5219 "Using an array as a reference is deprecated");
5221 return newUNOP(OP_RV2AV, 0, scalar(o));
5225 Perl_newGVREF(pTHX_ I32 type, OP *o)
5227 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5228 return newUNOP(OP_NULL, 0, o);
5229 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5233 Perl_newHVREF(pTHX_ OP *o)
5235 if (o->op_type == OP_PADANY) {
5236 o->op_type = OP_PADHV;
5237 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5240 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5241 && ckWARN(WARN_DEPRECATED)) {
5242 Perl_warner(aTHX_ WARN_DEPRECATED,
5243 "Using a hash as a reference is deprecated");
5245 return newUNOP(OP_RV2HV, 0, scalar(o));
5249 Perl_oopsCV(pTHX_ OP *o)
5251 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5257 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5259 return newUNOP(OP_RV2CV, flags, scalar(o));
5263 Perl_newSVREF(pTHX_ OP *o)
5265 if (o->op_type == OP_PADANY) {
5266 o->op_type = OP_PADSV;
5267 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5270 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5271 o->op_flags |= OPpDONE_SVREF;
5274 return newUNOP(OP_RV2SV, 0, scalar(o));
5277 /* Check routines. */
5280 Perl_ck_anoncode(pTHX_ OP *o)
5285 name = NEWSV(1106,0);
5286 sv_upgrade(name, SVt_PVNV);
5287 sv_setpvn(name, "&", 1);
5290 ix = pad_alloc(o->op_type, SVs_PADMY);
5291 av_store(PL_comppad_name, ix, name);
5292 av_store(PL_comppad, ix, cSVOPo->op_sv);
5293 SvPADMY_on(cSVOPo->op_sv);
5294 cSVOPo->op_sv = Nullsv;
5295 cSVOPo->op_targ = ix;
5300 Perl_ck_bitop(pTHX_ OP *o)
5302 o->op_private = PL_hints;
5307 Perl_ck_concat(pTHX_ OP *o)
5309 if (cUNOPo->op_first->op_type == OP_CONCAT)
5310 o->op_flags |= OPf_STACKED;
5315 Perl_ck_spair(pTHX_ OP *o)
5317 if (o->op_flags & OPf_KIDS) {
5320 OPCODE type = o->op_type;
5321 o = modkids(ck_fun(o), type);
5322 kid = cUNOPo->op_first;
5323 newop = kUNOP->op_first->op_sibling;
5325 (newop->op_sibling ||
5326 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5327 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5328 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5332 op_free(kUNOP->op_first);
5333 kUNOP->op_first = newop;
5335 o->op_ppaddr = PL_ppaddr[++o->op_type];
5340 Perl_ck_delete(pTHX_ OP *o)
5344 if (o->op_flags & OPf_KIDS) {
5345 OP *kid = cUNOPo->op_first;
5346 switch (kid->op_type) {
5348 o->op_flags |= OPf_SPECIAL;
5351 o->op_private |= OPpSLICE;
5354 o->op_flags |= OPf_SPECIAL;
5359 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5360 PL_op_desc[o->op_type]);
5368 Perl_ck_eof(pTHX_ OP *o)
5370 I32 type = o->op_type;
5372 if (o->op_flags & OPf_KIDS) {
5373 if (cLISTOPo->op_first->op_type == OP_STUB) {
5375 o = newUNOP(type, OPf_SPECIAL,
5376 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5384 Perl_ck_eval(pTHX_ OP *o)
5386 PL_hints |= HINT_BLOCK_SCOPE;
5387 if (o->op_flags & OPf_KIDS) {
5388 SVOP *kid = (SVOP*)cUNOPo->op_first;
5391 o->op_flags &= ~OPf_KIDS;
5394 else if (kid->op_type == OP_LINESEQ) {
5397 kid->op_next = o->op_next;
5398 cUNOPo->op_first = 0;
5401 NewOp(1101, enter, 1, LOGOP);
5402 enter->op_type = OP_ENTERTRY;
5403 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5404 enter->op_private = 0;
5406 /* establish postfix order */
5407 enter->op_next = (OP*)enter;
5409 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5410 o->op_type = OP_LEAVETRY;
5411 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5412 enter->op_other = o;
5420 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5422 o->op_targ = (PADOFFSET)PL_hints;
5427 Perl_ck_exit(pTHX_ OP *o)
5430 HV *table = GvHV(PL_hintgv);
5432 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5433 if (svp && *svp && SvTRUE(*svp))
5434 o->op_private |= OPpEXIT_VMSISH;
5441 Perl_ck_exec(pTHX_ OP *o)
5444 if (o->op_flags & OPf_STACKED) {
5446 kid = cUNOPo->op_first->op_sibling;
5447 if (kid->op_type == OP_RV2GV)
5456 Perl_ck_exists(pTHX_ OP *o)
5459 if (o->op_flags & OPf_KIDS) {
5460 OP *kid = cUNOPo->op_first;
5461 if (kid->op_type == OP_ENTERSUB) {
5462 (void) ref(kid, o->op_type);
5463 if (kid->op_type != OP_RV2CV && !PL_error_count)
5464 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5465 PL_op_desc[o->op_type]);
5466 o->op_private |= OPpEXISTS_SUB;
5468 else if (kid->op_type == OP_AELEM)
5469 o->op_flags |= OPf_SPECIAL;
5470 else if (kid->op_type != OP_HELEM)
5471 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5472 PL_op_desc[o->op_type]);
5480 Perl_ck_gvconst(pTHX_ register OP *o)
5482 o = fold_constants(o);
5483 if (o->op_type == OP_CONST)
5490 Perl_ck_rvconst(pTHX_ register OP *o)
5492 SVOP *kid = (SVOP*)cUNOPo->op_first;
5494 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5495 if (kid->op_type == OP_CONST) {
5499 SV *kidsv = kid->op_sv;
5502 /* Is it a constant from cv_const_sv()? */
5503 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5504 SV *rsv = SvRV(kidsv);
5505 int svtype = SvTYPE(rsv);
5506 char *badtype = Nullch;
5508 switch (o->op_type) {
5510 if (svtype > SVt_PVMG)
5511 badtype = "a SCALAR";
5514 if (svtype != SVt_PVAV)
5515 badtype = "an ARRAY";
5518 if (svtype != SVt_PVHV) {
5519 if (svtype == SVt_PVAV) { /* pseudohash? */
5520 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5521 if (ksv && SvROK(*ksv)
5522 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5531 if (svtype != SVt_PVCV)
5536 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5539 name = SvPV(kidsv, n_a);
5540 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5541 char *badthing = Nullch;
5542 switch (o->op_type) {
5544 badthing = "a SCALAR";
5547 badthing = "an ARRAY";
5550 badthing = "a HASH";
5555 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5559 * This is a little tricky. We only want to add the symbol if we
5560 * didn't add it in the lexer. Otherwise we get duplicate strict
5561 * warnings. But if we didn't add it in the lexer, we must at
5562 * least pretend like we wanted to add it even if it existed before,
5563 * or we get possible typo warnings. OPpCONST_ENTERED says
5564 * whether the lexer already added THIS instance of this symbol.
5566 iscv = (o->op_type == OP_RV2CV) * 2;
5568 gv = gv_fetchpv(name,
5569 iscv | !(kid->op_private & OPpCONST_ENTERED),
5572 : o->op_type == OP_RV2SV
5574 : o->op_type == OP_RV2AV
5576 : o->op_type == OP_RV2HV
5579 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5581 kid->op_type = OP_GV;
5582 SvREFCNT_dec(kid->op_sv);
5584 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5585 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5586 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5588 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5590 kid->op_sv = SvREFCNT_inc(gv);
5592 kid->op_private = 0;
5593 kid->op_ppaddr = PL_ppaddr[OP_GV];
5600 Perl_ck_ftst(pTHX_ OP *o)
5602 I32 type = o->op_type;
5604 if (o->op_flags & OPf_REF) {
5607 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5608 SVOP *kid = (SVOP*)cUNOPo->op_first;
5610 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5612 OP *newop = newGVOP(type, OPf_REF,
5613 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5620 if (type == OP_FTTTY)
5621 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5624 o = newUNOP(type, 0, newDEFSVOP());
5630 Perl_ck_fun(pTHX_ OP *o)
5636 int type = o->op_type;
5637 register I32 oa = PL_opargs[type] >> OASHIFT;
5639 if (o->op_flags & OPf_STACKED) {
5640 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5643 return no_fh_allowed(o);
5646 if (o->op_flags & OPf_KIDS) {
5648 tokid = &cLISTOPo->op_first;
5649 kid = cLISTOPo->op_first;
5650 if (kid->op_type == OP_PUSHMARK ||
5651 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5653 tokid = &kid->op_sibling;
5654 kid = kid->op_sibling;
5656 if (!kid && PL_opargs[type] & OA_DEFGV)
5657 *tokid = kid = newDEFSVOP();
5661 sibl = kid->op_sibling;
5664 /* list seen where single (scalar) arg expected? */
5665 if (numargs == 1 && !(oa >> 4)
5666 && kid->op_type == OP_LIST && type != OP_SCALAR)
5668 return too_many_arguments(o,PL_op_desc[type]);
5681 if ((type == OP_PUSH || type == OP_UNSHIFT)
5682 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5683 Perl_warner(aTHX_ WARN_SYNTAX,
5684 "Useless use of %s with no values",
5687 if (kid->op_type == OP_CONST &&
5688 (kid->op_private & OPpCONST_BARE))
5690 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5691 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5692 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5693 if (ckWARN(WARN_DEPRECATED))
5694 Perl_warner(aTHX_ WARN_DEPRECATED,
5695 "Array @%s missing the @ in argument %"IVdf" of %s()",
5696 name, (IV)numargs, PL_op_desc[type]);
5699 kid->op_sibling = sibl;
5702 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5703 bad_type(numargs, "array", PL_op_desc[type], kid);
5707 if (kid->op_type == OP_CONST &&
5708 (kid->op_private & OPpCONST_BARE))
5710 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5711 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5712 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5713 if (ckWARN(WARN_DEPRECATED))
5714 Perl_warner(aTHX_ WARN_DEPRECATED,
5715 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5716 name, (IV)numargs, PL_op_desc[type]);
5719 kid->op_sibling = sibl;
5722 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5723 bad_type(numargs, "hash", PL_op_desc[type], kid);
5728 OP *newop = newUNOP(OP_NULL, 0, kid);
5729 kid->op_sibling = 0;
5731 newop->op_next = newop;
5733 kid->op_sibling = sibl;
5738 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5739 if (kid->op_type == OP_CONST &&
5740 (kid->op_private & OPpCONST_BARE))
5742 OP *newop = newGVOP(OP_GV, 0,
5743 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5748 else if (kid->op_type == OP_READLINE) {
5749 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5750 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5753 I32 flags = OPf_SPECIAL;
5757 /* is this op a FH constructor? */
5758 if (is_handle_constructor(o,numargs)) {
5759 char *name = Nullch;
5763 /* Set a flag to tell rv2gv to vivify
5764 * need to "prove" flag does not mean something
5765 * else already - NI-S 1999/05/07
5768 if (kid->op_type == OP_PADSV) {
5769 SV **namep = av_fetch(PL_comppad_name,
5771 if (namep && *namep)
5772 name = SvPV(*namep, len);
5774 else if (kid->op_type == OP_RV2SV
5775 && kUNOP->op_first->op_type == OP_GV)
5777 GV *gv = cGVOPx_gv(kUNOP->op_first);
5779 len = GvNAMELEN(gv);
5781 else if (kid->op_type == OP_AELEM
5782 || kid->op_type == OP_HELEM)
5784 name = "__ANONIO__";
5790 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5791 namesv = PL_curpad[targ];
5792 (void)SvUPGRADE(namesv, SVt_PV);
5794 sv_setpvn(namesv, "$", 1);
5795 sv_catpvn(namesv, name, len);
5798 kid->op_sibling = 0;
5799 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5800 kid->op_targ = targ;
5801 kid->op_private |= priv;
5803 kid->op_sibling = sibl;
5809 mod(scalar(kid), type);
5813 tokid = &kid->op_sibling;
5814 kid = kid->op_sibling;
5816 o->op_private |= numargs;
5818 return too_many_arguments(o,PL_op_desc[o->op_type]);
5821 else if (PL_opargs[type] & OA_DEFGV) {
5823 return newUNOP(type, 0, newDEFSVOP());
5827 while (oa & OA_OPTIONAL)
5829 if (oa && oa != OA_LIST)
5830 return too_few_arguments(o,PL_op_desc[o->op_type]);
5836 Perl_ck_glob(pTHX_ OP *o)
5841 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5842 append_elem(OP_GLOB, o, newDEFSVOP());
5844 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5845 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5847 #if !defined(PERL_EXTERNAL_GLOB)
5848 /* XXX this can be tightened up and made more failsafe. */
5852 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5854 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5855 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5856 GvCV(gv) = GvCV(glob_gv);
5857 SvREFCNT_inc((SV*)GvCV(gv));
5858 GvIMPORTED_CV_on(gv);
5861 #endif /* PERL_EXTERNAL_GLOB */
5863 if (gv && GvIMPORTED_CV(gv)) {
5864 append_elem(OP_GLOB, o,
5865 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5866 o->op_type = OP_LIST;
5867 o->op_ppaddr = PL_ppaddr[OP_LIST];
5868 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5869 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5870 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5871 append_elem(OP_LIST, o,
5872 scalar(newUNOP(OP_RV2CV, 0,
5873 newGVOP(OP_GV, 0, gv)))));
5874 o = newUNOP(OP_NULL, 0, ck_subr(o));
5875 o->op_targ = OP_GLOB; /* hint at what it used to be */
5878 gv = newGVgen("main");
5880 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5886 Perl_ck_grep(pTHX_ OP *o)
5890 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5892 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5893 NewOp(1101, gwop, 1, LOGOP);
5895 if (o->op_flags & OPf_STACKED) {
5898 kid = cLISTOPo->op_first->op_sibling;
5899 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5902 kid->op_next = (OP*)gwop;
5903 o->op_flags &= ~OPf_STACKED;
5905 kid = cLISTOPo->op_first->op_sibling;
5906 if (type == OP_MAPWHILE)
5913 kid = cLISTOPo->op_first->op_sibling;
5914 if (kid->op_type != OP_NULL)
5915 Perl_croak(aTHX_ "panic: ck_grep");
5916 kid = kUNOP->op_first;
5918 gwop->op_type = type;
5919 gwop->op_ppaddr = PL_ppaddr[type];
5920 gwop->op_first = listkids(o);
5921 gwop->op_flags |= OPf_KIDS;
5922 gwop->op_private = 1;
5923 gwop->op_other = LINKLIST(kid);
5924 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5925 kid->op_next = (OP*)gwop;
5927 kid = cLISTOPo->op_first->op_sibling;
5928 if (!kid || !kid->op_sibling)
5929 return too_few_arguments(o,PL_op_desc[o->op_type]);
5930 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5931 mod(kid, OP_GREPSTART);
5937 Perl_ck_index(pTHX_ OP *o)
5939 if (o->op_flags & OPf_KIDS) {
5940 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5942 kid = kid->op_sibling; /* get past "big" */
5943 if (kid && kid->op_type == OP_CONST)
5944 fbm_compile(((SVOP*)kid)->op_sv, 0);
5950 Perl_ck_lengthconst(pTHX_ OP *o)
5952 /* XXX length optimization goes here */
5957 Perl_ck_lfun(pTHX_ OP *o)
5959 OPCODE type = o->op_type;
5960 return modkids(ck_fun(o), type);
5964 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5966 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5967 switch (cUNOPo->op_first->op_type) {
5969 /* This is needed for
5970 if (defined %stash::)
5971 to work. Do not break Tk.
5973 break; /* Globals via GV can be undef */
5975 case OP_AASSIGN: /* Is this a good idea? */
5976 Perl_warner(aTHX_ WARN_DEPRECATED,
5977 "defined(@array) is deprecated");
5978 Perl_warner(aTHX_ WARN_DEPRECATED,
5979 "\t(Maybe you should just omit the defined()?)\n");
5982 /* This is needed for
5983 if (defined %stash::)
5984 to work. Do not break Tk.
5986 break; /* Globals via GV can be undef */
5988 Perl_warner(aTHX_ WARN_DEPRECATED,
5989 "defined(%%hash) is deprecated");
5990 Perl_warner(aTHX_ WARN_DEPRECATED,
5991 "\t(Maybe you should just omit the defined()?)\n");
6002 Perl_ck_rfun(pTHX_ OP *o)
6004 OPCODE type = o->op_type;
6005 return refkids(ck_fun(o), type);
6009 Perl_ck_listiob(pTHX_ OP *o)
6013 kid = cLISTOPo->op_first;
6016 kid = cLISTOPo->op_first;
6018 if (kid->op_type == OP_PUSHMARK)
6019 kid = kid->op_sibling;
6020 if (kid && o->op_flags & OPf_STACKED)
6021 kid = kid->op_sibling;
6022 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6023 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6024 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6025 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6026 cLISTOPo->op_first->op_sibling = kid;
6027 cLISTOPo->op_last = kid;
6028 kid = kid->op_sibling;
6033 append_elem(o->op_type, o, newDEFSVOP());
6039 Perl_ck_sassign(pTHX_ OP *o)
6041 OP *kid = cLISTOPo->op_first;
6042 /* has a disposable target? */
6043 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6044 && !(kid->op_flags & OPf_STACKED)
6045 /* Cannot steal the second time! */
6046 && !(kid->op_private & OPpTARGET_MY))
6048 OP *kkid = kid->op_sibling;
6050 /* Can just relocate the target. */
6051 if (kkid && kkid->op_type == OP_PADSV
6052 && !(kkid->op_private & OPpLVAL_INTRO))
6054 kid->op_targ = kkid->op_targ;
6056 /* Now we do not need PADSV and SASSIGN. */
6057 kid->op_sibling = o->op_sibling; /* NULL */
6058 cLISTOPo->op_first = NULL;
6061 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6069 Perl_ck_match(pTHX_ OP *o)
6071 o->op_private |= OPpRUNTIME;
6076 Perl_ck_method(pTHX_ OP *o)
6078 OP *kid = cUNOPo->op_first;
6079 if (kid->op_type == OP_CONST) {
6080 SV* sv = kSVOP->op_sv;
6081 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6083 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6084 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6087 kSVOP->op_sv = Nullsv;
6089 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6098 Perl_ck_null(pTHX_ OP *o)
6104 Perl_ck_open(pTHX_ OP *o)
6106 HV *table = GvHV(PL_hintgv);
6110 svp = hv_fetch(table, "open_IN", 7, FALSE);
6112 mode = mode_from_discipline(*svp);
6113 if (mode & O_BINARY)
6114 o->op_private |= OPpOPEN_IN_RAW;
6115 else if (mode & O_TEXT)
6116 o->op_private |= OPpOPEN_IN_CRLF;
6119 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6121 mode = mode_from_discipline(*svp);
6122 if (mode & O_BINARY)
6123 o->op_private |= OPpOPEN_OUT_RAW;
6124 else if (mode & O_TEXT)
6125 o->op_private |= OPpOPEN_OUT_CRLF;
6128 if (o->op_type == OP_BACKTICK)
6134 Perl_ck_repeat(pTHX_ OP *o)
6136 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6137 o->op_private |= OPpREPEAT_DOLIST;
6138 cBINOPo->op_first = force_list(cBINOPo->op_first);
6146 Perl_ck_require(pTHX_ OP *o)
6150 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6151 SVOP *kid = (SVOP*)cUNOPo->op_first;
6153 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6155 for (s = SvPVX(kid->op_sv); *s; s++) {
6156 if (*s == ':' && s[1] == ':') {
6158 Move(s+2, s+1, strlen(s+2)+1, char);
6159 --SvCUR(kid->op_sv);
6162 if (SvREADONLY(kid->op_sv)) {
6163 SvREADONLY_off(kid->op_sv);
6164 sv_catpvn(kid->op_sv, ".pm", 3);
6165 SvREADONLY_on(kid->op_sv);
6168 sv_catpvn(kid->op_sv, ".pm", 3);
6172 /* handle override, if any */
6173 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6174 if (!(gv && GvIMPORTED_CV(gv)))
6175 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6177 if (gv && GvIMPORTED_CV(gv)) {
6178 OP *kid = cUNOPo->op_first;
6179 cUNOPo->op_first = 0;
6181 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6182 append_elem(OP_LIST, kid,
6183 scalar(newUNOP(OP_RV2CV, 0,
6192 Perl_ck_return(pTHX_ OP *o)
6195 if (CvLVALUE(PL_compcv)) {
6196 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6197 mod(kid, OP_LEAVESUBLV);
6204 Perl_ck_retarget(pTHX_ OP *o)
6206 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6213 Perl_ck_select(pTHX_ OP *o)
6216 if (o->op_flags & OPf_KIDS) {
6217 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6218 if (kid && kid->op_sibling) {
6219 o->op_type = OP_SSELECT;
6220 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6222 return fold_constants(o);
6226 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6227 if (kid && kid->op_type == OP_RV2GV)
6228 kid->op_private &= ~HINT_STRICT_REFS;
6233 Perl_ck_shift(pTHX_ OP *o)
6235 I32 type = o->op_type;
6237 if (!(o->op_flags & OPf_KIDS)) {
6242 if (!CvUNIQUE(PL_compcv)) {
6243 argop = newOP(OP_PADAV, OPf_REF);
6244 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6247 argop = newUNOP(OP_RV2AV, 0,
6248 scalar(newGVOP(OP_GV, 0,
6249 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6252 argop = newUNOP(OP_RV2AV, 0,
6253 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6254 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6255 #endif /* USE_THREADS */
6256 return newUNOP(type, 0, scalar(argop));
6258 return scalar(modkids(ck_fun(o), type));
6262 Perl_ck_sort(pTHX_ OP *o)
6266 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6268 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6269 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6271 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6273 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6275 if (kid->op_type == OP_SCOPE) {
6279 else if (kid->op_type == OP_LEAVE) {
6280 if (o->op_type == OP_SORT) {
6281 op_null(kid); /* wipe out leave */
6284 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6285 if (k->op_next == kid)
6287 /* don't descend into loops */
6288 else if (k->op_type == OP_ENTERLOOP
6289 || k->op_type == OP_ENTERITER)
6291 k = cLOOPx(k)->op_lastop;
6296 kid->op_next = 0; /* just disconnect the leave */
6297 k = kLISTOP->op_first;
6302 if (o->op_type == OP_SORT) {
6303 /* provide scalar context for comparison function/block */
6309 o->op_flags |= OPf_SPECIAL;
6311 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6314 firstkid = firstkid->op_sibling;
6317 /* provide list context for arguments */
6318 if (o->op_type == OP_SORT)
6325 S_simplify_sort(pTHX_ OP *o)
6327 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6331 if (!(o->op_flags & OPf_STACKED))
6333 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6334 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6335 kid = kUNOP->op_first; /* get past null */
6336 if (kid->op_type != OP_SCOPE)
6338 kid = kLISTOP->op_last; /* get past scope */
6339 switch(kid->op_type) {
6347 k = kid; /* remember this node*/
6348 if (kBINOP->op_first->op_type != OP_RV2SV)
6350 kid = kBINOP->op_first; /* get past cmp */
6351 if (kUNOP->op_first->op_type != OP_GV)
6353 kid = kUNOP->op_first; /* get past rv2sv */
6355 if (GvSTASH(gv) != PL_curstash)
6357 if (strEQ(GvNAME(gv), "a"))
6359 else if (strEQ(GvNAME(gv), "b"))
6363 kid = k; /* back to cmp */
6364 if (kBINOP->op_last->op_type != OP_RV2SV)
6366 kid = kBINOP->op_last; /* down to 2nd arg */
6367 if (kUNOP->op_first->op_type != OP_GV)
6369 kid = kUNOP->op_first; /* get past rv2sv */
6371 if (GvSTASH(gv) != PL_curstash
6373 ? strNE(GvNAME(gv), "a")
6374 : strNE(GvNAME(gv), "b")))
6376 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6378 o->op_private |= OPpSORT_REVERSE;
6379 if (k->op_type == OP_NCMP)
6380 o->op_private |= OPpSORT_NUMERIC;
6381 if (k->op_type == OP_I_NCMP)
6382 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6383 kid = cLISTOPo->op_first->op_sibling;
6384 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6385 op_free(kid); /* then delete it */
6389 Perl_ck_split(pTHX_ OP *o)
6393 if (o->op_flags & OPf_STACKED)
6394 return no_fh_allowed(o);
6396 kid = cLISTOPo->op_first;
6397 if (kid->op_type != OP_NULL)
6398 Perl_croak(aTHX_ "panic: ck_split");
6399 kid = kid->op_sibling;
6400 op_free(cLISTOPo->op_first);
6401 cLISTOPo->op_first = kid;
6403 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6404 cLISTOPo->op_last = kid; /* There was only one element previously */
6407 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6408 OP *sibl = kid->op_sibling;
6409 kid->op_sibling = 0;
6410 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6411 if (cLISTOPo->op_first == cLISTOPo->op_last)
6412 cLISTOPo->op_last = kid;
6413 cLISTOPo->op_first = kid;
6414 kid->op_sibling = sibl;
6417 kid->op_type = OP_PUSHRE;
6418 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6421 if (!kid->op_sibling)
6422 append_elem(OP_SPLIT, o, newDEFSVOP());
6424 kid = kid->op_sibling;
6427 if (!kid->op_sibling)
6428 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6430 kid = kid->op_sibling;
6433 if (kid->op_sibling)
6434 return too_many_arguments(o,PL_op_desc[o->op_type]);
6440 Perl_ck_join(pTHX_ OP *o)
6442 if (ckWARN(WARN_SYNTAX)) {
6443 OP *kid = cLISTOPo->op_first->op_sibling;
6444 if (kid && kid->op_type == OP_MATCH) {
6445 char *pmstr = "STRING";
6446 if (kPMOP->op_pmregexp)
6447 pmstr = kPMOP->op_pmregexp->precomp;
6448 Perl_warner(aTHX_ WARN_SYNTAX,
6449 "/%s/ should probably be written as \"%s\"",
6457 Perl_ck_subr(pTHX_ OP *o)
6459 OP *prev = ((cUNOPo->op_first->op_sibling)
6460 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6461 OP *o2 = prev->op_sibling;
6470 o->op_private |= OPpENTERSUB_HASTARG;
6471 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6472 if (cvop->op_type == OP_RV2CV) {
6474 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6475 op_null(cvop); /* disable rv2cv */
6476 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6477 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6478 GV *gv = cGVOPx_gv(tmpop);
6481 tmpop->op_private |= OPpEARLY_CV;
6482 else if (SvPOK(cv)) {
6483 namegv = CvANON(cv) ? gv : CvGV(cv);
6484 proto = SvPV((SV*)cv, n_a);
6488 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6489 if (o2->op_type == OP_CONST)
6490 o2->op_private &= ~OPpCONST_STRICT;
6491 else if (o2->op_type == OP_LIST) {
6492 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6493 if (o && o->op_type == OP_CONST)
6494 o->op_private &= ~OPpCONST_STRICT;
6497 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6498 if (PERLDB_SUB && PL_curstash != PL_debstash)
6499 o->op_private |= OPpENTERSUB_DB;
6500 while (o2 != cvop) {
6504 return too_many_arguments(o, gv_ename(namegv));
6522 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6524 arg == 1 ? "block or sub {}" : "sub {}",
6525 gv_ename(namegv), o2);
6528 /* '*' allows any scalar type, including bareword */
6531 if (o2->op_type == OP_RV2GV)
6532 goto wrapref; /* autoconvert GLOB -> GLOBref */
6533 else if (o2->op_type == OP_CONST)
6534 o2->op_private &= ~OPpCONST_STRICT;
6535 else if (o2->op_type == OP_ENTERSUB) {
6536 /* accidental subroutine, revert to bareword */
6537 OP *gvop = ((UNOP*)o2)->op_first;
6538 if (gvop && gvop->op_type == OP_NULL) {
6539 gvop = ((UNOP*)gvop)->op_first;
6541 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6544 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6545 (gvop = ((UNOP*)gvop)->op_first) &&
6546 gvop->op_type == OP_GV)
6548 GV *gv = cGVOPx_gv(gvop);
6549 OP *sibling = o2->op_sibling;
6550 SV *n = newSVpvn("",0);
6552 gv_fullname3(n, gv, "");
6553 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6554 sv_chop(n, SvPVX(n)+6);
6555 o2 = newSVOP(OP_CONST, 0, n);
6556 prev->op_sibling = o2;
6557 o2->op_sibling = sibling;
6569 if (o2->op_type != OP_RV2GV)
6570 bad_type(arg, "symbol", gv_ename(namegv), o2);
6573 if (o2->op_type != OP_ENTERSUB)
6574 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6577 if (o2->op_type != OP_RV2SV
6578 && o2->op_type != OP_PADSV
6579 && o2->op_type != OP_HELEM
6580 && o2->op_type != OP_AELEM
6581 && o2->op_type != OP_THREADSV)
6583 bad_type(arg, "scalar", gv_ename(namegv), o2);
6587 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6588 bad_type(arg, "array", gv_ename(namegv), o2);
6591 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6592 bad_type(arg, "hash", gv_ename(namegv), o2);
6596 OP* sib = kid->op_sibling;
6597 kid->op_sibling = 0;
6598 o2 = newUNOP(OP_REFGEN, 0, kid);
6599 o2->op_sibling = sib;
6600 prev->op_sibling = o2;
6611 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6612 gv_ename(namegv), SvPV((SV*)cv, n_a));
6617 mod(o2, OP_ENTERSUB);
6619 o2 = o2->op_sibling;
6621 if (proto && !optional &&
6622 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6623 return too_few_arguments(o, gv_ename(namegv));
6628 Perl_ck_svconst(pTHX_ OP *o)
6630 SvREADONLY_on(cSVOPo->op_sv);
6635 Perl_ck_trunc(pTHX_ OP *o)
6637 if (o->op_flags & OPf_KIDS) {
6638 SVOP *kid = (SVOP*)cUNOPo->op_first;
6640 if (kid->op_type == OP_NULL)
6641 kid = (SVOP*)kid->op_sibling;
6642 if (kid && kid->op_type == OP_CONST &&
6643 (kid->op_private & OPpCONST_BARE))
6645 o->op_flags |= OPf_SPECIAL;
6646 kid->op_private &= ~OPpCONST_STRICT;
6653 Perl_ck_substr(pTHX_ OP *o)
6656 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6657 OP *kid = cLISTOPo->op_first;
6659 if (kid->op_type == OP_NULL)
6660 kid = kid->op_sibling;
6662 kid->op_flags |= OPf_MOD;
6668 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6671 Perl_peep(pTHX_ register OP *o)
6673 register OP* oldop = 0;
6676 if (!o || o->op_seq)
6680 SAVEVPTR(PL_curcop);
6681 for (; o; o = o->op_next) {
6687 switch (o->op_type) {
6691 PL_curcop = ((COP*)o); /* for warnings */
6692 o->op_seq = PL_op_seqmax++;
6696 if (cSVOPo->op_private & OPpCONST_STRICT)
6697 no_bareword_allowed(o);
6699 /* Relocate sv to the pad for thread safety.
6700 * Despite being a "constant", the SV is written to,
6701 * for reference counts, sv_upgrade() etc. */
6703 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6704 if (SvPADTMP(cSVOPo->op_sv)) {
6705 /* If op_sv is already a PADTMP then it is being used by
6706 * some pad, so make a copy. */
6707 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6708 SvREADONLY_on(PL_curpad[ix]);
6709 SvREFCNT_dec(cSVOPo->op_sv);
6712 SvREFCNT_dec(PL_curpad[ix]);
6713 SvPADTMP_on(cSVOPo->op_sv);
6714 PL_curpad[ix] = cSVOPo->op_sv;
6715 /* XXX I don't know how this isn't readonly already. */
6716 SvREADONLY_on(PL_curpad[ix]);
6718 cSVOPo->op_sv = Nullsv;
6722 o->op_seq = PL_op_seqmax++;
6726 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6727 if (o->op_next->op_private & OPpTARGET_MY) {
6728 if (o->op_flags & OPf_STACKED) /* chained concats */
6729 goto ignore_optimization;
6731 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6732 o->op_targ = o->op_next->op_targ;
6733 o->op_next->op_targ = 0;
6734 o->op_private |= OPpTARGET_MY;
6737 op_null(o->op_next);
6739 ignore_optimization:
6740 o->op_seq = PL_op_seqmax++;
6743 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6744 o->op_seq = PL_op_seqmax++;
6745 break; /* Scalar stub must produce undef. List stub is noop */
6749 if (o->op_targ == OP_NEXTSTATE
6750 || o->op_targ == OP_DBSTATE
6751 || o->op_targ == OP_SETSTATE)
6753 PL_curcop = ((COP*)o);
6760 if (oldop && o->op_next) {
6761 oldop->op_next = o->op_next;
6764 o->op_seq = PL_op_seqmax++;
6768 if (o->op_next->op_type == OP_RV2SV) {
6769 if (!(o->op_next->op_private & OPpDEREF)) {
6770 op_null(o->op_next);
6771 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6773 o->op_next = o->op_next->op_next;
6774 o->op_type = OP_GVSV;
6775 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6778 else if (o->op_next->op_type == OP_RV2AV) {
6779 OP* pop = o->op_next->op_next;
6781 if (pop->op_type == OP_CONST &&
6782 (PL_op = pop->op_next) &&
6783 pop->op_next->op_type == OP_AELEM &&
6784 !(pop->op_next->op_private &
6785 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6786 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6791 op_null(o->op_next);
6792 op_null(pop->op_next);
6794 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6795 o->op_next = pop->op_next->op_next;
6796 o->op_type = OP_AELEMFAST;
6797 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6798 o->op_private = (U8)i;
6803 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6805 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6806 /* XXX could check prototype here instead of just carping */
6807 SV *sv = sv_newmortal();
6808 gv_efullname3(sv, gv, Nullch);
6809 Perl_warner(aTHX_ WARN_PROTOTYPE,
6810 "%s() called too early to check prototype",
6815 o->op_seq = PL_op_seqmax++;
6826 o->op_seq = PL_op_seqmax++;
6827 while (cLOGOP->op_other->op_type == OP_NULL)
6828 cLOGOP->op_other = cLOGOP->op_other->op_next;
6829 peep(cLOGOP->op_other);
6834 o->op_seq = PL_op_seqmax++;
6835 while (cLOOP->op_redoop->op_type == OP_NULL)
6836 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6837 peep(cLOOP->op_redoop);
6838 while (cLOOP->op_nextop->op_type == OP_NULL)
6839 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6840 peep(cLOOP->op_nextop);
6841 while (cLOOP->op_lastop->op_type == OP_NULL)
6842 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6843 peep(cLOOP->op_lastop);
6849 o->op_seq = PL_op_seqmax++;
6850 while (cPMOP->op_pmreplstart &&
6851 cPMOP->op_pmreplstart->op_type == OP_NULL)
6852 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6853 peep(cPMOP->op_pmreplstart);
6857 o->op_seq = PL_op_seqmax++;
6858 if (ckWARN(WARN_SYNTAX) && o->op_next
6859 && o->op_next->op_type == OP_NEXTSTATE) {
6860 if (o->op_next->op_sibling &&
6861 o->op_next->op_sibling->op_type != OP_EXIT &&
6862 o->op_next->op_sibling->op_type != OP_WARN &&
6863 o->op_next->op_sibling->op_type != OP_DIE) {
6864 line_t oldline = CopLINE(PL_curcop);
6866 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6867 Perl_warner(aTHX_ WARN_EXEC,
6868 "Statement unlikely to be reached");
6869 Perl_warner(aTHX_ WARN_EXEC,
6870 "\t(Maybe you meant system() when you said exec()?)\n");
6871 CopLINE_set(PL_curcop, oldline);
6880 SV **svp, **indsvp, *sv;
6885 o->op_seq = PL_op_seqmax++;
6887 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6890 /* Make the CONST have a shared SV */
6891 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6892 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6893 key = SvPV(sv, keylen);
6896 lexname = newSVpvn_share(key, keylen, 0);
6901 if ((o->op_private & (OPpLVAL_INTRO)))
6904 rop = (UNOP*)((BINOP*)o)->op_first;
6905 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6907 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6908 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6910 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6911 if (!fields || !GvHV(*fields))
6913 key = SvPV(*svp, keylen);
6916 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6918 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6919 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6921 ind = SvIV(*indsvp);
6923 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6924 rop->op_type = OP_RV2AV;
6925 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6926 o->op_type = OP_AELEM;
6927 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6929 if (SvREADONLY(*svp))
6931 SvFLAGS(sv) |= (SvFLAGS(*svp)
6932 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6942 SV **svp, **indsvp, *sv;
6946 SVOP *first_key_op, *key_op;
6948 o->op_seq = PL_op_seqmax++;
6949 if ((o->op_private & (OPpLVAL_INTRO))
6950 /* I bet there's always a pushmark... */
6951 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6952 /* hmmm, no optimization if list contains only one key. */
6954 rop = (UNOP*)((LISTOP*)o)->op_last;
6955 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6957 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6958 if (!(SvFLAGS(lexname) & SVpad_TYPED))
6960 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6961 if (!fields || !GvHV(*fields))
6963 /* Again guessing that the pushmark can be jumped over.... */
6964 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6965 ->op_first->op_sibling;
6966 /* Check that the key list contains only constants. */
6967 for (key_op = first_key_op; key_op;
6968 key_op = (SVOP*)key_op->op_sibling)
6969 if (key_op->op_type != OP_CONST)
6973 rop->op_type = OP_RV2AV;
6974 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6975 o->op_type = OP_ASLICE;
6976 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6977 for (key_op = first_key_op; key_op;
6978 key_op = (SVOP*)key_op->op_sibling) {
6979 svp = cSVOPx_svp(key_op);
6980 key = SvPV(*svp, keylen);
6983 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6985 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6986 "in variable %s of type %s",
6987 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6989 ind = SvIV(*indsvp);
6991 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6993 if (SvREADONLY(*svp))
6995 SvFLAGS(sv) |= (SvFLAGS(*svp)
6996 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7004 o->op_seq = PL_op_seqmax++;
7014 /* Efficient sub that returns a constant scalar value. */
7016 const_sv_xsub(pTHXo_ CV* cv)
7021 Perl_croak(aTHX_ "usage: %s::%s()",
7022 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7026 ST(0) = (SV*)XSANY.any_ptr;