3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
25 /* #define PL_OP_SLAB_ALLOC */
27 #ifdef PL_OP_SLAB_ALLOC
28 #define SLAB_SIZE 8192
29 static char *PL_OpPtr = NULL;
30 static int PL_OpSpace = 0;
31 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
32 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
34 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
40 Newz(m,PL_OpPtr,SLAB_SIZE,char);
41 PL_OpSpace = SLAB_SIZE - sz;
42 return PL_OpPtr += PL_OpSpace;
46 #define NewOp(m, var, c, type) Newz(m, var, c, type)
49 * In the following definition, the ", Nullop" is just to make the compiler
50 * think the expression is of the right type: croak actually does a Siglongjmp.
52 #define CHECKOP(type,o) \
53 ((PL_op_mask && PL_op_mask[type]) \
54 ? ( op_free((OP*)o), \
55 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
57 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
59 #define PAD_MAX 999999999
60 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
63 S_gv_ename(pTHX_ GV *gv)
66 SV* tmpsv = sv_newmortal();
67 gv_efullname3(tmpsv, gv, Nullch);
68 return SvPV(tmpsv,n_a);
72 S_no_fh_allowed(pTHX_ OP *o)
74 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
80 S_too_few_arguments(pTHX_ OP *o, char *name)
82 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
87 S_too_many_arguments(pTHX_ OP *o, char *name)
89 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
94 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
96 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
97 (int)n, name, t, OP_DESC(kid)));
101 S_no_bareword_allowed(pTHX_ OP *o)
103 qerror(Perl_mess(aTHX_
104 "Bareword \"%s\" not allowed while \"strict subs\" in use",
105 SvPV_nolen(cSVOPo_sv)));
108 /* "register" allocation */
111 Perl_pad_allocmy(pTHX_ char *name)
116 if (!(PL_in_my == KEY_our ||
118 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
119 (name[1] == '_' && (int)strlen(name) > 2)))
121 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
122 /* 1999-02-27 mjd@plover.com */
124 p = strchr(name, '\0');
125 /* The next block assumes the buffer is at least 205 chars
126 long. At present, it's always at least 256 chars. */
128 strcpy(name+200, "...");
134 /* Move everything else down one character */
135 for (; p-name > 2; p--)
137 name[2] = toCTRL(name[1]);
140 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
142 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
143 SV **svp = AvARRAY(PL_comppad_name);
144 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
145 PADOFFSET top = AvFILLp(PL_comppad_name);
146 for (off = top; off > PL_comppad_name_floor; off--) {
148 && sv != &PL_sv_undef
149 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
150 && (PL_in_my != KEY_our
151 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
152 && strEQ(name, SvPVX(sv)))
154 Perl_warner(aTHX_ WARN_MISC,
155 "\"%s\" variable %s masks earlier declaration in same %s",
156 (PL_in_my == KEY_our ? "our" : "my"),
158 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
163 if (PL_in_my == KEY_our) {
166 && sv != &PL_sv_undef
167 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
168 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
169 && strEQ(name, SvPVX(sv)))
171 Perl_warner(aTHX_ WARN_MISC,
172 "\"our\" variable %s redeclared", name);
173 Perl_warner(aTHX_ WARN_MISC,
174 "\t(Did you mean \"local\" instead of \"our\"?)\n");
177 } while ( off-- > 0 );
180 off = pad_alloc(OP_PADSV, SVs_PADMY);
182 sv_upgrade(sv, SVt_PVNV);
184 if (PL_in_my_stash) {
186 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
187 name, PL_in_my == KEY_our ? "our" : "my"));
188 SvFLAGS(sv) |= SVpad_TYPED;
189 (void)SvUPGRADE(sv, SVt_PVMG);
190 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
192 if (PL_in_my == KEY_our) {
193 (void)SvUPGRADE(sv, SVt_PVGV);
194 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
195 SvFLAGS(sv) |= SVpad_OUR;
197 av_store(PL_comppad_name, off, sv);
198 SvNVX(sv) = (NV)PAD_MAX;
199 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
200 if (!PL_min_intro_pending)
201 PL_min_intro_pending = off;
202 PL_max_intro_pending = off;
204 av_store(PL_comppad, off, (SV*)newAV());
205 else if (*name == '%')
206 av_store(PL_comppad, off, (SV*)newHV());
207 SvPADMY_on(PL_curpad[off]);
212 S_pad_addlex(pTHX_ SV *proto_namesv)
214 SV *namesv = NEWSV(1103,0);
215 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
216 sv_upgrade(namesv, SVt_PVNV);
217 sv_setpv(namesv, SvPVX(proto_namesv));
218 av_store(PL_comppad_name, newoff, namesv);
219 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
220 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
221 SvFAKE_on(namesv); /* A ref, not a real var */
222 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
223 SvFLAGS(namesv) |= SVpad_OUR;
224 (void)SvUPGRADE(namesv, SVt_PVGV);
225 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
227 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
228 SvFLAGS(namesv) |= SVpad_TYPED;
229 (void)SvUPGRADE(namesv, SVt_PVMG);
230 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
235 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
238 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
239 I32 cx_ix, I32 saweval, U32 flags)
245 register PERL_CONTEXT *cx;
247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
252 if (!svp || *svp == &PL_sv_undef)
255 svp = AvARRAY(curname);
256 for (off = AvFILLp(curname); off > 0; off--) {
257 if ((sv = svp[off]) &&
258 sv != &PL_sv_undef &&
260 seq > I_32(SvNVX(sv)) &&
261 strEQ(SvPVX(sv), name))
272 return 0; /* don't clone from inactive stack frame */
276 oldpad = (AV*)AvARRAY(curlist)[depth];
277 oldsv = *av_fetch(oldpad, off, TRUE);
278 if (!newoff) { /* Not a mere clone operation. */
279 newoff = pad_addlex(sv);
280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
281 /* "It's closures all the way down." */
282 CvCLONE_on(PL_compcv);
284 if (CvANON(PL_compcv))
285 oldsv = Nullsv; /* no need to keep ref */
290 bcv && bcv != cv && !CvCLONE(bcv);
291 bcv = CvOUTSIDE(bcv))
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
314 Perl_warner(aTHX_ WARN_CLOSURE,
315 "Variable \"%s\" may be unavailable",
323 else if (!CvUNIQUE(PL_compcv)) {
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
327 Perl_warner(aTHX_ WARN_CLOSURE,
328 "Variable \"%s\" will not stay shared", name);
332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
338 if (flags & FINDLEX_NOSEARCH)
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
346 for (i = cx_ix; i >= 0; i--) {
348 switch (CxTYPE(cx)) {
350 if (i == 0 && saweval) {
351 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
355 switch (cx->blk_eval.old_op_type) {
357 if (CxREALEVAL(cx)) {
360 seq = cxstack[i].blk_oldcop->cop_seq;
361 startcv = cxstack[i].blk_eval.cv;
362 if (startcv && CvOUTSIDE(startcv)) {
363 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
365 if (off) /* continue looking if not found here */
372 /* require/do must have their own scope */
381 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
382 saweval = i; /* so we know where we were called from */
383 seq = cxstack[i].blk_oldcop->cop_seq;
386 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
394 Perl_pad_findmy(pTHX_ char *name)
399 SV **svp = AvARRAY(PL_comppad_name);
400 U32 seq = PL_cop_seqmax;
406 * Special case to get lexical (and hence per-thread) @_.
407 * XXX I need to find out how to tell at parse-time whether use
408 * of @_ should refer to a lexical (from a sub) or defgv (global
409 * scope and maybe weird sub-ish things like formats). See
410 * startsub in perly.y. It's possible that @_ could be lexical
411 * (at least from subs) even in non-threaded perl.
413 if (strEQ(name, "@_"))
414 return 0; /* success. (NOT_IN_PAD indicates failure) */
415 #endif /* USE_THREADS */
417 /* The one we're looking for is probably just before comppad_name_fill. */
418 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
419 if ((sv = svp[off]) &&
420 sv != &PL_sv_undef &&
423 seq > I_32(SvNVX(sv)))) &&
424 strEQ(SvPVX(sv), name))
426 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
427 return (PADOFFSET)off;
428 pendoff = off; /* this pending def. will override import */
432 outside = CvOUTSIDE(PL_compcv);
434 /* Check if if we're compiling an eval'', and adjust seq to be the
435 * eval's seq number. This depends on eval'' having a non-null
436 * CvOUTSIDE() while it is being compiled. The eval'' itself is
437 * identified by CvEVAL being true and CvGV being null. */
438 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
439 cx = &cxstack[cxstack_ix];
441 seq = cx->blk_oldcop->cop_seq;
444 /* See if it's in a nested scope */
445 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
447 /* If there is a pending local definition, this new alias must die */
449 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
450 return off; /* pad_findlex returns 0 for failure...*/
452 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
456 Perl_pad_leavemy(pTHX_ I32 fill)
459 SV **svp = AvARRAY(PL_comppad_name);
461 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
462 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
463 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
464 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
467 /* "Deintroduce" my variables that are leaving with this scope. */
468 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
469 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
470 SvIVX(sv) = PL_cop_seqmax;
475 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
480 if (AvARRAY(PL_comppad) != PL_curpad)
481 Perl_croak(aTHX_ "panic: pad_alloc");
482 if (PL_pad_reset_pending)
484 if (tmptype & SVs_PADMY) {
486 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
487 } while (SvPADBUSY(sv)); /* need a fresh one */
488 retval = AvFILLp(PL_comppad);
491 SV **names = AvARRAY(PL_comppad_name);
492 SSize_t names_fill = AvFILLp(PL_comppad_name);
495 * "foreach" index vars temporarily become aliases to non-"my"
496 * values. Thus we must skip, not just pad values that are
497 * marked as current pad values, but also those with names.
499 if (++PL_padix <= names_fill &&
500 (sv = names[PL_padix]) && sv != &PL_sv_undef)
502 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
503 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
504 !IS_PADGV(sv) && !IS_PADCONST(sv))
509 SvFLAGS(sv) |= tmptype;
510 PL_curpad = AvARRAY(PL_comppad);
512 DEBUG_X(PerlIO_printf(Perl_debug_log,
513 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
514 PTR2UV(thr), PTR2UV(PL_curpad),
515 (long) retval, PL_op_name[optype]));
517 DEBUG_X(PerlIO_printf(Perl_debug_log,
518 "Pad 0x%"UVxf" alloc %ld for %s\n",
520 (long) retval, PL_op_name[optype]));
521 #endif /* USE_THREADS */
522 return (PADOFFSET)retval;
526 Perl_pad_sv(pTHX_ PADOFFSET po)
529 DEBUG_X(PerlIO_printf(Perl_debug_log,
530 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
531 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
534 Perl_croak(aTHX_ "panic: pad_sv po");
535 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
536 PTR2UV(PL_curpad), (IV)po));
537 #endif /* USE_THREADS */
538 return PL_curpad[po]; /* eventually we'll turn this into a macro */
542 Perl_pad_free(pTHX_ PADOFFSET po)
546 if (AvARRAY(PL_comppad) != PL_curpad)
547 Perl_croak(aTHX_ "panic: pad_free curpad");
549 Perl_croak(aTHX_ "panic: pad_free po");
551 DEBUG_X(PerlIO_printf(Perl_debug_log,
552 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
553 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
555 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
556 PTR2UV(PL_curpad), (IV)po));
557 #endif /* USE_THREADS */
558 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
559 SvPADTMP_off(PL_curpad[po]);
561 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
564 if ((I32)po < PL_padix)
569 Perl_pad_swipe(pTHX_ PADOFFSET po)
571 if (AvARRAY(PL_comppad) != PL_curpad)
572 Perl_croak(aTHX_ "panic: pad_swipe curpad");
574 Perl_croak(aTHX_ "panic: pad_swipe po");
576 DEBUG_X(PerlIO_printf(Perl_debug_log,
577 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
580 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
581 PTR2UV(PL_curpad), (IV)po));
582 #endif /* USE_THREADS */
583 SvPADTMP_off(PL_curpad[po]);
584 PL_curpad[po] = NEWSV(1107,0);
585 SvPADTMP_on(PL_curpad[po]);
586 if ((I32)po < PL_padix)
590 /* XXX pad_reset() is currently disabled because it results in serious bugs.
591 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
592 * on the stack by OPs that use them, there are several ways to get an alias
593 * to a shared TARG. Such an alias will change randomly and unpredictably.
594 * We avoid doing this until we can think of a Better Way.
599 #ifdef USE_BROKEN_PAD_RESET
602 if (AvARRAY(PL_comppad) != PL_curpad)
603 Perl_croak(aTHX_ "panic: pad_reset curpad");
605 DEBUG_X(PerlIO_printf(Perl_debug_log,
606 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
607 PTR2UV(thr), PTR2UV(PL_curpad)));
609 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
611 #endif /* USE_THREADS */
612 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
613 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
614 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
615 SvPADTMP_off(PL_curpad[po]);
617 PL_padix = PL_padix_floor;
620 PL_pad_reset_pending = FALSE;
624 /* find_threadsv is not reentrant */
626 Perl_find_threadsv(pTHX_ const char *name)
631 /* We currently only handle names of a single character */
632 p = strchr(PL_threadsv_names, *name);
635 key = p - PL_threadsv_names;
636 MUTEX_LOCK(&thr->mutex);
637 svp = av_fetch(thr->threadsv, key, FALSE);
639 MUTEX_UNLOCK(&thr->mutex);
641 SV *sv = NEWSV(0, 0);
642 av_store(thr->threadsv, key, sv);
643 thr->threadsvp = AvARRAY(thr->threadsv);
644 MUTEX_UNLOCK(&thr->mutex);
646 * Some magic variables used to be automagically initialised
647 * in gv_fetchpv. Those which are now per-thread magicals get
648 * initialised here instead.
654 sv_setpv(sv, "\034");
655 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
660 PL_sawampersand = TRUE;
674 /* XXX %! tied to Errno.pm needs to be added here.
675 * See gv_fetchpv(). */
679 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
681 DEBUG_S(PerlIO_printf(Perl_error_log,
682 "find_threadsv: new SV %p for $%s%c\n",
683 sv, (*name < 32) ? "^" : "",
684 (*name < 32) ? toCTRL(*name) : *name));
688 #endif /* USE_THREADS */
693 Perl_op_free(pTHX_ OP *o)
695 register OP *kid, *nextkid;
698 if (!o || o->op_seq == (U16)-1)
701 if (o->op_private & OPpREFCOUNTED) {
702 switch (o->op_type) {
710 if (OpREFCNT_dec(o)) {
721 if (o->op_flags & OPf_KIDS) {
722 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
723 nextkid = kid->op_sibling; /* Get before next freeing kid */
731 /* COP* is not cleared by op_clear() so that we may track line
732 * numbers etc even after null() */
733 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
738 #ifdef PL_OP_SLAB_ALLOC
739 if ((char *) o == PL_OpPtr)
748 Perl_op_clear(pTHX_ OP *o)
751 switch (o->op_type) {
752 case OP_NULL: /* Was holding old type, if any. */
753 case OP_ENTEREVAL: /* Was holding hints. */
755 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
761 if (!(o->op_flags & OPf_SPECIAL))
764 #endif /* USE_THREADS */
766 if (!(o->op_flags & OPf_REF)
767 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
774 if (cPADOPo->op_padix > 0) {
777 pad_swipe(cPADOPo->op_padix);
778 /* No GvIN_PAD_off(gv) here, because other references may still
779 * exist on the pad */
782 cPADOPo->op_padix = 0;
785 SvREFCNT_dec(cSVOPo->op_sv);
786 cSVOPo->op_sv = Nullsv;
789 case OP_METHOD_NAMED:
791 SvREFCNT_dec(cSVOPo->op_sv);
792 cSVOPo->op_sv = Nullsv;
798 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
802 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
803 SvREFCNT_dec(cSVOPo->op_sv);
804 cSVOPo->op_sv = Nullsv;
807 Safefree(cPVOPo->op_pv);
808 cPVOPo->op_pv = Nullch;
812 op_free(cPMOPo->op_pmreplroot);
816 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
818 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
819 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
820 /* No GvIN_PAD_off(gv) here, because other references may still
821 * exist on the pad */
826 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
833 HV *pmstash = PmopSTASH(cPMOPo);
834 if (pmstash && SvREFCNT(pmstash)) {
835 PMOP *pmop = HvPMROOT(pmstash);
836 PMOP *lastpmop = NULL;
838 if (cPMOPo == pmop) {
840 lastpmop->op_pmnext = pmop->op_pmnext;
842 HvPMROOT(pmstash) = pmop->op_pmnext;
846 pmop = pmop->op_pmnext;
850 Safefree(PmopSTASHPV(cPMOPo));
852 /* NOTE: PMOP.op_pmstash is not refcounted */
855 cPMOPo->op_pmreplroot = Nullop;
856 /* we use the "SAFE" version of the PM_ macros here
857 * since sv_clean_all might release some PMOPs
858 * after PL_regex_padav has been cleared
859 * and the clearing of PL_regex_padav needs to
860 * happen before sv_clean_all
862 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
863 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
865 if(PL_regex_pad) { /* We could be in destruction */
866 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
867 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
874 if (o->op_targ > 0) {
875 pad_free(o->op_targ);
881 S_cop_free(pTHX_ COP* cop)
883 Safefree(cop->cop_label);
885 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
886 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
888 /* NOTE: COP.cop_stash is not refcounted */
889 SvREFCNT_dec(CopFILEGV(cop));
891 if (! specialWARN(cop->cop_warnings))
892 SvREFCNT_dec(cop->cop_warnings);
893 if (! specialCopIO(cop->cop_io))
894 SvREFCNT_dec(cop->cop_io);
898 Perl_op_null(pTHX_ OP *o)
900 if (o->op_type == OP_NULL)
903 o->op_targ = o->op_type;
904 o->op_type = OP_NULL;
905 o->op_ppaddr = PL_ppaddr[OP_NULL];
908 /* Contextualizers */
910 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
913 Perl_linklist(pTHX_ OP *o)
920 /* establish postfix order */
921 if (cUNOPo->op_first) {
922 o->op_next = LINKLIST(cUNOPo->op_first);
923 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
925 kid->op_next = LINKLIST(kid->op_sibling);
937 Perl_scalarkids(pTHX_ OP *o)
940 if (o && o->op_flags & OPf_KIDS) {
941 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
948 S_scalarboolean(pTHX_ OP *o)
950 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
951 if (ckWARN(WARN_SYNTAX)) {
952 line_t oldline = CopLINE(PL_curcop);
954 if (PL_copline != NOLINE)
955 CopLINE_set(PL_curcop, PL_copline);
956 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
957 CopLINE_set(PL_curcop, oldline);
964 Perl_scalar(pTHX_ OP *o)
968 /* assumes no premature commitment */
969 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
970 || o->op_type == OP_RETURN)
975 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
977 switch (o->op_type) {
979 scalar(cBINOPo->op_first);
984 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
988 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
989 if (!kPMOP->op_pmreplroot)
990 deprecate("implicit split to @_");
998 if (o->op_flags & OPf_KIDS) {
999 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1005 kid = cLISTOPo->op_first;
1007 while ((kid = kid->op_sibling)) {
1008 if (kid->op_sibling)
1013 WITH_THR(PL_curcop = &PL_compiling);
1018 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1019 if (kid->op_sibling)
1024 WITH_THR(PL_curcop = &PL_compiling);
1031 Perl_scalarvoid(pTHX_ OP *o)
1038 if (o->op_type == OP_NEXTSTATE
1039 || o->op_type == OP_SETSTATE
1040 || o->op_type == OP_DBSTATE
1041 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1042 || o->op_targ == OP_SETSTATE
1043 || o->op_targ == OP_DBSTATE)))
1044 PL_curcop = (COP*)o; /* for warning below */
1046 /* assumes no premature commitment */
1047 want = o->op_flags & OPf_WANT;
1048 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1049 || o->op_type == OP_RETURN)
1054 if ((o->op_private & OPpTARGET_MY)
1055 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1057 return scalar(o); /* As if inside SASSIGN */
1060 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1062 switch (o->op_type) {
1064 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1068 if (o->op_flags & OPf_STACKED)
1072 if (o->op_private == 4)
1114 case OP_GETSOCKNAME:
1115 case OP_GETPEERNAME:
1120 case OP_GETPRIORITY:
1143 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1144 useless = OP_DESC(o);
1151 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1152 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1153 useless = "a variable";
1158 if (cSVOPo->op_private & OPpCONST_STRICT)
1159 no_bareword_allowed(o);
1161 if (ckWARN(WARN_VOID)) {
1162 useless = "a constant";
1163 /* the constants 0 and 1 are permitted as they are
1164 conventionally used as dummies in constructs like
1165 1 while some_condition_with_side_effects; */
1166 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1168 else if (SvPOK(sv)) {
1169 /* perl4's way of mixing documentation and code
1170 (before the invention of POD) was based on a
1171 trick to mix nroff and perl code. The trick was
1172 built upon these three nroff macros being used in
1173 void context. The pink camel has the details in
1174 the script wrapman near page 319. */
1175 if (strnEQ(SvPVX(sv), "di", 2) ||
1176 strnEQ(SvPVX(sv), "ds", 2) ||
1177 strnEQ(SvPVX(sv), "ig", 2))
1182 op_null(o); /* don't execute or even remember it */
1186 o->op_type = OP_PREINC; /* pre-increment is faster */
1187 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1191 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1192 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1198 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1203 if (o->op_flags & OPf_STACKED)
1210 if (!(o->op_flags & OPf_KIDS))
1219 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1226 /* all requires must return a boolean value */
1227 o->op_flags &= ~OPf_WANT;
1232 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1233 if (!kPMOP->op_pmreplroot)
1234 deprecate("implicit split to @_");
1238 if (useless && ckWARN(WARN_VOID))
1239 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1244 Perl_listkids(pTHX_ OP *o)
1247 if (o && o->op_flags & OPf_KIDS) {
1248 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1255 Perl_list(pTHX_ OP *o)
1259 /* assumes no premature commitment */
1260 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1261 || o->op_type == OP_RETURN)
1266 if ((o->op_private & OPpTARGET_MY)
1267 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1269 return o; /* As if inside SASSIGN */
1272 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1274 switch (o->op_type) {
1277 list(cBINOPo->op_first);
1282 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1290 if (!(o->op_flags & OPf_KIDS))
1292 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1293 list(cBINOPo->op_first);
1294 return gen_constant_list(o);
1301 kid = cLISTOPo->op_first;
1303 while ((kid = kid->op_sibling)) {
1304 if (kid->op_sibling)
1309 WITH_THR(PL_curcop = &PL_compiling);
1313 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1314 if (kid->op_sibling)
1319 WITH_THR(PL_curcop = &PL_compiling);
1322 /* all requires must return a boolean value */
1323 o->op_flags &= ~OPf_WANT;
1330 Perl_scalarseq(pTHX_ OP *o)
1335 if (o->op_type == OP_LINESEQ ||
1336 o->op_type == OP_SCOPE ||
1337 o->op_type == OP_LEAVE ||
1338 o->op_type == OP_LEAVETRY)
1340 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1341 if (kid->op_sibling) {
1345 PL_curcop = &PL_compiling;
1347 o->op_flags &= ~OPf_PARENS;
1348 if (PL_hints & HINT_BLOCK_SCOPE)
1349 o->op_flags |= OPf_PARENS;
1352 o = newOP(OP_STUB, 0);
1357 S_modkids(pTHX_ OP *o, I32 type)
1360 if (o && o->op_flags & OPf_KIDS) {
1361 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1368 Perl_mod(pTHX_ OP *o, I32 type)
1373 if (!o || PL_error_count)
1376 if ((o->op_private & OPpTARGET_MY)
1377 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1382 switch (o->op_type) {
1387 if (!(o->op_private & (OPpCONST_ARYBASE)))
1389 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1390 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1394 SAVEI32(PL_compiling.cop_arybase);
1395 PL_compiling.cop_arybase = 0;
1397 else if (type == OP_REFGEN)
1400 Perl_croak(aTHX_ "That use of $[ is unsupported");
1403 if (o->op_flags & OPf_PARENS)
1407 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1408 !(o->op_flags & OPf_STACKED)) {
1409 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1410 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1411 assert(cUNOPo->op_first->op_type == OP_NULL);
1412 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1415 else { /* lvalue subroutine call */
1416 o->op_private |= OPpLVAL_INTRO;
1417 PL_modcount = RETURN_UNLIMITED_NUMBER;
1418 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1419 /* Backward compatibility mode: */
1420 o->op_private |= OPpENTERSUB_INARGS;
1423 else { /* Compile-time error message: */
1424 OP *kid = cUNOPo->op_first;
1428 if (kid->op_type == OP_PUSHMARK)
1430 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1432 "panic: unexpected lvalue entersub "
1433 "args: type/targ %ld:%ld",
1434 (long)kid->op_type,kid->op_targ);
1435 kid = kLISTOP->op_first;
1437 while (kid->op_sibling)
1438 kid = kid->op_sibling;
1439 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1441 if (kid->op_type == OP_METHOD_NAMED
1442 || kid->op_type == OP_METHOD)
1446 if (kid->op_sibling || kid->op_next != kid) {
1447 yyerror("panic: unexpected optree near method call");
1451 NewOp(1101, newop, 1, UNOP);
1452 newop->op_type = OP_RV2CV;
1453 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1454 newop->op_first = Nullop;
1455 newop->op_next = (OP*)newop;
1456 kid->op_sibling = (OP*)newop;
1457 newop->op_private |= OPpLVAL_INTRO;
1461 if (kid->op_type != OP_RV2CV)
1463 "panic: unexpected lvalue entersub "
1464 "entry via type/targ %ld:%ld",
1465 (long)kid->op_type,kid->op_targ);
1466 kid->op_private |= OPpLVAL_INTRO;
1467 break; /* Postpone until runtime */
1471 kid = kUNOP->op_first;
1472 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1473 kid = kUNOP->op_first;
1474 if (kid->op_type == OP_NULL)
1476 "Unexpected constant lvalue entersub "
1477 "entry via type/targ %ld:%ld",
1478 (long)kid->op_type,kid->op_targ);
1479 if (kid->op_type != OP_GV) {
1480 /* Restore RV2CV to check lvalueness */
1482 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1483 okid->op_next = kid->op_next;
1484 kid->op_next = okid;
1487 okid->op_next = Nullop;
1488 okid->op_type = OP_RV2CV;
1490 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1491 okid->op_private |= OPpLVAL_INTRO;
1495 cv = GvCV(kGVOP_gv);
1505 /* grep, foreach, subcalls, refgen */
1506 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1508 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1509 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1511 : (o->op_type == OP_ENTERSUB
1512 ? "non-lvalue subroutine call"
1514 type ? PL_op_desc[type] : "local"));
1528 case OP_RIGHT_SHIFT:
1537 if (!(o->op_flags & OPf_STACKED))
1543 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1549 if (!type && cUNOPo->op_first->op_type != OP_GV)
1550 Perl_croak(aTHX_ "Can't localize through a reference");
1551 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1552 PL_modcount = RETURN_UNLIMITED_NUMBER;
1553 return o; /* Treat \(@foo) like ordinary list. */
1557 if (scalar_mod_type(o, type))
1559 ref(cUNOPo->op_first, o->op_type);
1563 if (type == OP_LEAVESUBLV)
1564 o->op_private |= OPpMAYBE_LVSUB;
1570 PL_modcount = RETURN_UNLIMITED_NUMBER;
1573 if (!type && cUNOPo->op_first->op_type != OP_GV)
1574 Perl_croak(aTHX_ "Can't localize through a reference");
1575 ref(cUNOPo->op_first, o->op_type);
1579 PL_hints |= HINT_BLOCK_SCOPE;
1589 PL_modcount = RETURN_UNLIMITED_NUMBER;
1590 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1591 return o; /* Treat \(@foo) like ordinary list. */
1592 if (scalar_mod_type(o, type))
1594 if (type == OP_LEAVESUBLV)
1595 o->op_private |= OPpMAYBE_LVSUB;
1600 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1601 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1606 PL_modcount++; /* XXX ??? */
1608 #endif /* USE_THREADS */
1614 if (type != OP_SASSIGN)
1618 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1623 if (type == OP_LEAVESUBLV)
1624 o->op_private |= OPpMAYBE_LVSUB;
1626 pad_free(o->op_targ);
1627 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1628 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1629 if (o->op_flags & OPf_KIDS)
1630 mod(cBINOPo->op_first->op_sibling, type);
1635 ref(cBINOPo->op_first, o->op_type);
1636 if (type == OP_ENTERSUB &&
1637 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1638 o->op_private |= OPpLVAL_DEFER;
1639 if (type == OP_LEAVESUBLV)
1640 o->op_private |= OPpMAYBE_LVSUB;
1648 if (o->op_flags & OPf_KIDS)
1649 mod(cLISTOPo->op_last, type);
1653 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1655 else if (!(o->op_flags & OPf_KIDS))
1657 if (o->op_targ != OP_LIST) {
1658 mod(cBINOPo->op_first, type);
1663 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1668 if (type != OP_LEAVESUBLV)
1670 break; /* mod()ing was handled by ck_return() */
1672 if (type != OP_LEAVESUBLV)
1673 o->op_flags |= OPf_MOD;
1675 if (type == OP_AASSIGN || type == OP_SASSIGN)
1676 o->op_flags |= OPf_SPECIAL|OPf_REF;
1678 o->op_private |= OPpLVAL_INTRO;
1679 o->op_flags &= ~OPf_SPECIAL;
1680 PL_hints |= HINT_BLOCK_SCOPE;
1682 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1683 && type != OP_LEAVESUBLV)
1684 o->op_flags |= OPf_REF;
1689 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1693 if (o->op_type == OP_RV2GV)
1717 case OP_RIGHT_SHIFT:
1736 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1738 switch (o->op_type) {
1746 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1759 Perl_refkids(pTHX_ OP *o, I32 type)
1762 if (o && o->op_flags & OPf_KIDS) {
1763 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1770 Perl_ref(pTHX_ OP *o, I32 type)
1774 if (!o || PL_error_count)
1777 switch (o->op_type) {
1779 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1780 !(o->op_flags & OPf_STACKED)) {
1781 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1782 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1783 assert(cUNOPo->op_first->op_type == OP_NULL);
1784 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1785 o->op_flags |= OPf_SPECIAL;
1790 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1794 if (type == OP_DEFINED)
1795 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1796 ref(cUNOPo->op_first, o->op_type);
1799 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1800 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1801 : type == OP_RV2HV ? OPpDEREF_HV
1803 o->op_flags |= OPf_MOD;
1808 o->op_flags |= OPf_MOD; /* XXX ??? */
1813 o->op_flags |= OPf_REF;
1816 if (type == OP_DEFINED)
1817 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1818 ref(cUNOPo->op_first, o->op_type);
1823 o->op_flags |= OPf_REF;
1828 if (!(o->op_flags & OPf_KIDS))
1830 ref(cBINOPo->op_first, type);
1834 ref(cBINOPo->op_first, o->op_type);
1835 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1836 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1837 : type == OP_RV2HV ? OPpDEREF_HV
1839 o->op_flags |= OPf_MOD;
1847 if (!(o->op_flags & OPf_KIDS))
1849 ref(cLISTOPo->op_last, type);
1859 S_dup_attrlist(pTHX_ OP *o)
1863 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1864 * where the first kid is OP_PUSHMARK and the remaining ones
1865 * are OP_CONST. We need to push the OP_CONST values.
1867 if (o->op_type == OP_CONST)
1868 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1870 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1871 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1872 if (o->op_type == OP_CONST)
1873 rop = append_elem(OP_LIST, rop,
1874 newSVOP(OP_CONST, o->op_flags,
1875 SvREFCNT_inc(cSVOPo->op_sv)));
1882 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1886 /* fake up C<use attributes $pkg,$rv,@attrs> */
1887 ENTER; /* need to protect against side-effects of 'use' */
1890 stashsv = newSVpv(HvNAME(stash), 0);
1892 stashsv = &PL_sv_no;
1894 #define ATTRSMODULE "attributes"
1896 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1897 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1899 prepend_elem(OP_LIST,
1900 newSVOP(OP_CONST, 0, stashsv),
1901 prepend_elem(OP_LIST,
1902 newSVOP(OP_CONST, 0,
1904 dup_attrlist(attrs))));
1909 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1910 char *attrstr, STRLEN len)
1915 len = strlen(attrstr);
1919 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1921 char *sstr = attrstr;
1922 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1923 attrs = append_elem(OP_LIST, attrs,
1924 newSVOP(OP_CONST, 0,
1925 newSVpvn(sstr, attrstr-sstr)));
1929 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1930 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1931 Nullsv, prepend_elem(OP_LIST,
1932 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1933 prepend_elem(OP_LIST,
1934 newSVOP(OP_CONST, 0,
1940 S_my_kid(pTHX_ OP *o, OP *attrs)
1945 if (!o || PL_error_count)
1949 if (type == OP_LIST) {
1950 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1952 } else if (type == OP_UNDEF) {
1954 } else if (type == OP_RV2SV || /* "our" declaration */
1956 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1958 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1960 PL_in_my_stash = Nullhv;
1961 apply_attrs(GvSTASH(gv),
1962 (type == OP_RV2SV ? GvSV(gv) :
1963 type == OP_RV2AV ? (SV*)GvAV(gv) :
1964 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1967 o->op_private |= OPpOUR_INTRO;
1969 } else if (type != OP_PADSV &&
1972 type != OP_PUSHMARK)
1974 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1976 PL_in_my == KEY_our ? "our" : "my"));
1979 else if (attrs && type != OP_PUSHMARK) {
1985 PL_in_my_stash = Nullhv;
1987 /* check for C<my Dog $spot> when deciding package */
1988 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1989 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1990 stash = SvSTASH(*namesvp);
1992 stash = PL_curstash;
1993 padsv = PAD_SV(o->op_targ);
1994 apply_attrs(stash, padsv, attrs);
1996 o->op_flags |= OPf_MOD;
1997 o->op_private |= OPpLVAL_INTRO;
2002 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2004 if (o->op_flags & OPf_PARENS)
2008 o = my_kid(o, attrs);
2010 PL_in_my_stash = Nullhv;
2015 Perl_my(pTHX_ OP *o)
2017 return my_kid(o, Nullop);
2021 Perl_sawparens(pTHX_ OP *o)
2024 o->op_flags |= OPf_PARENS;
2029 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2033 if (ckWARN(WARN_MISC) &&
2034 (left->op_type == OP_RV2AV ||
2035 left->op_type == OP_RV2HV ||
2036 left->op_type == OP_PADAV ||
2037 left->op_type == OP_PADHV)) {
2038 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2039 right->op_type == OP_TRANS)
2040 ? right->op_type : OP_MATCH];
2041 const char *sample = ((left->op_type == OP_RV2AV ||
2042 left->op_type == OP_PADAV)
2043 ? "@array" : "%hash");
2044 Perl_warner(aTHX_ WARN_MISC,
2045 "Applying %s to %s will act on scalar(%s)",
2046 desc, sample, sample);
2049 if (!(right->op_flags & OPf_STACKED) &&
2050 (right->op_type == OP_MATCH ||
2051 right->op_type == OP_SUBST ||
2052 right->op_type == OP_TRANS)) {
2053 right->op_flags |= OPf_STACKED;
2054 if ((right->op_type != OP_MATCH &&
2055 ! (right->op_type == OP_TRANS &&
2056 right->op_private & OPpTRANS_IDENTICAL)) ||
2057 /* if SV has magic, then match on original SV, not on its copy.
2058 see note in pp_helem() */
2059 (right->op_type == OP_MATCH &&
2060 (left->op_type == OP_AELEM ||
2061 left->op_type == OP_HELEM ||
2062 left->op_type == OP_AELEMFAST)))
2063 left = mod(left, right->op_type);
2064 if (right->op_type == OP_TRANS)
2065 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2067 o = prepend_elem(right->op_type, scalar(left), right);
2069 return newUNOP(OP_NOT, 0, scalar(o));
2073 return bind_match(type, left,
2074 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2078 Perl_invert(pTHX_ OP *o)
2082 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2083 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2087 Perl_scope(pTHX_ OP *o)
2090 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2091 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2092 o->op_type = OP_LEAVE;
2093 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2096 if (o->op_type == OP_LINESEQ) {
2098 o->op_type = OP_SCOPE;
2099 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2100 kid = ((LISTOP*)o)->op_first;
2101 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2105 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2112 Perl_save_hints(pTHX)
2115 SAVESPTR(GvHV(PL_hintgv));
2116 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2117 SAVEFREESV(GvHV(PL_hintgv));
2121 Perl_block_start(pTHX_ int full)
2123 int retval = PL_savestack_ix;
2125 SAVEI32(PL_comppad_name_floor);
2126 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2128 PL_comppad_name_fill = PL_comppad_name_floor;
2129 if (PL_comppad_name_floor < 0)
2130 PL_comppad_name_floor = 0;
2131 SAVEI32(PL_min_intro_pending);
2132 SAVEI32(PL_max_intro_pending);
2133 PL_min_intro_pending = 0;
2134 SAVEI32(PL_comppad_name_fill);
2135 SAVEI32(PL_padix_floor);
2136 PL_padix_floor = PL_padix;
2137 PL_pad_reset_pending = FALSE;
2139 PL_hints &= ~HINT_BLOCK_SCOPE;
2140 SAVESPTR(PL_compiling.cop_warnings);
2141 if (! specialWARN(PL_compiling.cop_warnings)) {
2142 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2143 SAVEFREESV(PL_compiling.cop_warnings) ;
2145 SAVESPTR(PL_compiling.cop_io);
2146 if (! specialCopIO(PL_compiling.cop_io)) {
2147 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2148 SAVEFREESV(PL_compiling.cop_io) ;
2154 Perl_block_end(pTHX_ I32 floor, OP *seq)
2156 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2157 OP* retval = scalarseq(seq);
2159 PL_pad_reset_pending = FALSE;
2160 PL_compiling.op_private = PL_hints;
2162 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2163 pad_leavemy(PL_comppad_name_fill);
2172 OP *o = newOP(OP_THREADSV, 0);
2173 o->op_targ = find_threadsv("_");
2176 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2177 #endif /* USE_THREADS */
2181 Perl_newPROG(pTHX_ OP *o)
2186 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2187 ((PL_in_eval & EVAL_KEEPERR)
2188 ? OPf_SPECIAL : 0), o);
2189 PL_eval_start = linklist(PL_eval_root);
2190 PL_eval_root->op_private |= OPpREFCOUNTED;
2191 OpREFCNT_set(PL_eval_root, 1);
2192 PL_eval_root->op_next = 0;
2193 CALL_PEEP(PL_eval_start);
2198 PL_main_root = scope(sawparens(scalarvoid(o)));
2199 PL_curcop = &PL_compiling;
2200 PL_main_start = LINKLIST(PL_main_root);
2201 PL_main_root->op_private |= OPpREFCOUNTED;
2202 OpREFCNT_set(PL_main_root, 1);
2203 PL_main_root->op_next = 0;
2204 CALL_PEEP(PL_main_start);
2207 /* Register with debugger */
2209 CV *cv = get_cv("DB::postponed", FALSE);
2213 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2215 call_sv((SV*)cv, G_DISCARD);
2222 Perl_localize(pTHX_ OP *o, I32 lex)
2224 if (o->op_flags & OPf_PARENS)
2227 if (ckWARN(WARN_PARENTHESIS)
2228 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2230 char *s = PL_bufptr;
2232 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2235 if (*s == ';' || *s == '=')
2236 Perl_warner(aTHX_ WARN_PARENTHESIS,
2237 "Parentheses missing around \"%s\" list",
2238 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2244 o = mod(o, OP_NULL); /* a bit kludgey */
2246 PL_in_my_stash = Nullhv;
2251 Perl_jmaybe(pTHX_ OP *o)
2253 if (o->op_type == OP_LIST) {
2256 o2 = newOP(OP_THREADSV, 0);
2257 o2->op_targ = find_threadsv(";");
2259 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2260 #endif /* USE_THREADS */
2261 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2267 Perl_fold_constants(pTHX_ register OP *o)
2270 I32 type = o->op_type;
2273 if (PL_opargs[type] & OA_RETSCALAR)
2275 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2276 o->op_targ = pad_alloc(type, SVs_PADTMP);
2278 /* integerize op, unless it happens to be C<-foo>.
2279 * XXX should pp_i_negate() do magic string negation instead? */
2280 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2281 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2282 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2284 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2287 if (!(PL_opargs[type] & OA_FOLDCONST))
2292 /* XXX might want a ck_negate() for this */
2293 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2305 /* XXX what about the numeric ops? */
2306 if (PL_hints & HINT_LOCALE)
2311 goto nope; /* Don't try to run w/ errors */
2313 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2314 if ((curop->op_type != OP_CONST ||
2315 (curop->op_private & OPpCONST_BARE)) &&
2316 curop->op_type != OP_LIST &&
2317 curop->op_type != OP_SCALAR &&
2318 curop->op_type != OP_NULL &&
2319 curop->op_type != OP_PUSHMARK)
2325 curop = LINKLIST(o);
2329 sv = *(PL_stack_sp--);
2330 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2331 pad_swipe(o->op_targ);
2332 else if (SvTEMP(sv)) { /* grab mortal temp? */
2333 (void)SvREFCNT_inc(sv);
2337 if (type == OP_RV2GV)
2338 return newGVOP(OP_GV, 0, (GV*)sv);
2340 /* try to smush double to int, but don't smush -2.0 to -2 */
2341 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2344 #ifdef PERL_PRESERVE_IVUV
2345 /* Only bother to attempt to fold to IV if
2346 most operators will benefit */
2350 return newSVOP(OP_CONST, 0, sv);
2354 if (!(PL_opargs[type] & OA_OTHERINT))
2357 if (!(PL_hints & HINT_INTEGER)) {
2358 if (type == OP_MODULO
2359 || type == OP_DIVIDE
2360 || !(o->op_flags & OPf_KIDS))
2365 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2366 if (curop->op_type == OP_CONST) {
2367 if (SvIOK(((SVOP*)curop)->op_sv))
2371 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2375 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2382 Perl_gen_constant_list(pTHX_ register OP *o)
2385 I32 oldtmps_floor = PL_tmps_floor;
2389 return o; /* Don't attempt to run with errors */
2391 PL_op = curop = LINKLIST(o);
2398 PL_tmps_floor = oldtmps_floor;
2400 o->op_type = OP_RV2AV;
2401 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2402 curop = ((UNOP*)o)->op_first;
2403 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2410 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2412 if (!o || o->op_type != OP_LIST)
2413 o = newLISTOP(OP_LIST, 0, o, Nullop);
2415 o->op_flags &= ~OPf_WANT;
2417 if (!(PL_opargs[type] & OA_MARK))
2418 op_null(cLISTOPo->op_first);
2421 o->op_ppaddr = PL_ppaddr[type];
2422 o->op_flags |= flags;
2424 o = CHECKOP(type, o);
2425 if (o->op_type != type)
2428 return fold_constants(o);
2431 /* List constructors */
2434 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2442 if (first->op_type != type
2443 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2445 return newLISTOP(type, 0, first, last);
2448 if (first->op_flags & OPf_KIDS)
2449 ((LISTOP*)first)->op_last->op_sibling = last;
2451 first->op_flags |= OPf_KIDS;
2452 ((LISTOP*)first)->op_first = last;
2454 ((LISTOP*)first)->op_last = last;
2459 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2467 if (first->op_type != type)
2468 return prepend_elem(type, (OP*)first, (OP*)last);
2470 if (last->op_type != type)
2471 return append_elem(type, (OP*)first, (OP*)last);
2473 first->op_last->op_sibling = last->op_first;
2474 first->op_last = last->op_last;
2475 first->op_flags |= (last->op_flags & OPf_KIDS);
2477 #ifdef PL_OP_SLAB_ALLOC
2485 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2493 if (last->op_type == type) {
2494 if (type == OP_LIST) { /* already a PUSHMARK there */
2495 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2496 ((LISTOP*)last)->op_first->op_sibling = first;
2497 if (!(first->op_flags & OPf_PARENS))
2498 last->op_flags &= ~OPf_PARENS;
2501 if (!(last->op_flags & OPf_KIDS)) {
2502 ((LISTOP*)last)->op_last = first;
2503 last->op_flags |= OPf_KIDS;
2505 first->op_sibling = ((LISTOP*)last)->op_first;
2506 ((LISTOP*)last)->op_first = first;
2508 last->op_flags |= OPf_KIDS;
2512 return newLISTOP(type, 0, first, last);
2518 Perl_newNULLLIST(pTHX)
2520 return newOP(OP_STUB, 0);
2524 Perl_force_list(pTHX_ OP *o)
2526 if (!o || o->op_type != OP_LIST)
2527 o = newLISTOP(OP_LIST, 0, o, Nullop);
2533 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2537 NewOp(1101, listop, 1, LISTOP);
2539 listop->op_type = type;
2540 listop->op_ppaddr = PL_ppaddr[type];
2543 listop->op_flags = flags;
2547 else if (!first && last)
2550 first->op_sibling = last;
2551 listop->op_first = first;
2552 listop->op_last = last;
2553 if (type == OP_LIST) {
2555 pushop = newOP(OP_PUSHMARK, 0);
2556 pushop->op_sibling = first;
2557 listop->op_first = pushop;
2558 listop->op_flags |= OPf_KIDS;
2560 listop->op_last = pushop;
2567 Perl_newOP(pTHX_ I32 type, I32 flags)
2570 NewOp(1101, o, 1, OP);
2572 o->op_ppaddr = PL_ppaddr[type];
2573 o->op_flags = flags;
2576 o->op_private = 0 + (flags >> 8);
2577 if (PL_opargs[type] & OA_RETSCALAR)
2579 if (PL_opargs[type] & OA_TARGET)
2580 o->op_targ = pad_alloc(type, SVs_PADTMP);
2581 return CHECKOP(type, o);
2585 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2590 first = newOP(OP_STUB, 0);
2591 if (PL_opargs[type] & OA_MARK)
2592 first = force_list(first);
2594 NewOp(1101, unop, 1, UNOP);
2595 unop->op_type = type;
2596 unop->op_ppaddr = PL_ppaddr[type];
2597 unop->op_first = first;
2598 unop->op_flags = flags | OPf_KIDS;
2599 unop->op_private = 1 | (flags >> 8);
2600 unop = (UNOP*) CHECKOP(type, unop);
2604 return fold_constants((OP *) unop);
2608 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2611 NewOp(1101, binop, 1, BINOP);
2614 first = newOP(OP_NULL, 0);
2616 binop->op_type = type;
2617 binop->op_ppaddr = PL_ppaddr[type];
2618 binop->op_first = first;
2619 binop->op_flags = flags | OPf_KIDS;
2622 binop->op_private = 1 | (flags >> 8);
2625 binop->op_private = 2 | (flags >> 8);
2626 first->op_sibling = last;
2629 binop = (BINOP*)CHECKOP(type, binop);
2630 if (binop->op_next || binop->op_type != type)
2633 binop->op_last = binop->op_first->op_sibling;
2635 return fold_constants((OP *)binop);
2639 uvcompare(const void *a, const void *b)
2641 if (*((UV *)a) < (*(UV *)b))
2643 if (*((UV *)a) > (*(UV *)b))
2645 if (*((UV *)a+1) < (*(UV *)b+1))
2647 if (*((UV *)a+1) > (*(UV *)b+1))
2653 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2655 SV *tstr = ((SVOP*)expr)->op_sv;
2656 SV *rstr = ((SVOP*)repl)->op_sv;
2659 U8 *t = (U8*)SvPV(tstr, tlen);
2660 U8 *r = (U8*)SvPV(rstr, rlen);
2667 register short *tbl;
2669 PL_hints |= HINT_BLOCK_SCOPE;
2670 complement = o->op_private & OPpTRANS_COMPLEMENT;
2671 del = o->op_private & OPpTRANS_DELETE;
2672 squash = o->op_private & OPpTRANS_SQUASH;
2675 o->op_private |= OPpTRANS_FROM_UTF;
2678 o->op_private |= OPpTRANS_TO_UTF;
2680 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2681 SV* listsv = newSVpvn("# comment\n",10);
2683 U8* tend = t + tlen;
2684 U8* rend = r + rlen;
2698 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2699 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2705 tsave = t = bytes_to_utf8(t, &len);
2708 if (!to_utf && rlen) {
2710 rsave = r = bytes_to_utf8(r, &len);
2714 /* There are several snags with this code on EBCDIC:
2715 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2716 2. scan_const() in toke.c has encoded chars in native encoding which makes
2717 ranges at least in EBCDIC 0..255 range the bottom odd.
2721 U8 tmpbuf[UTF8_MAXLEN+1];
2724 New(1109, cp, 2*tlen, UV);
2726 transv = newSVpvn("",0);
2728 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2730 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2732 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2736 cp[2*i+1] = cp[2*i];
2740 qsort(cp, i, 2*sizeof(UV), uvcompare);
2741 for (j = 0; j < i; j++) {
2743 diff = val - nextmin;
2745 t = uvuni_to_utf8(tmpbuf,nextmin);
2746 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2748 U8 range_mark = UTF_TO_NATIVE(0xff);
2749 t = uvuni_to_utf8(tmpbuf, val - 1);
2750 sv_catpvn(transv, (char *)&range_mark, 1);
2751 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2758 t = uvuni_to_utf8(tmpbuf,nextmin);
2759 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2761 U8 range_mark = UTF_TO_NATIVE(0xff);
2762 sv_catpvn(transv, (char *)&range_mark, 1);
2764 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2765 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2766 t = (U8*)SvPVX(transv);
2767 tlen = SvCUR(transv);
2771 else if (!rlen && !del) {
2772 r = t; rlen = tlen; rend = tend;
2775 if ((!rlen && !del) || t == r ||
2776 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2778 o->op_private |= OPpTRANS_IDENTICAL;
2782 while (t < tend || tfirst <= tlast) {
2783 /* see if we need more "t" chars */
2784 if (tfirst > tlast) {
2785 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2787 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2789 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2796 /* now see if we need more "r" chars */
2797 if (rfirst > rlast) {
2799 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2801 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2803 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2812 rfirst = rlast = 0xffffffff;
2816 /* now see which range will peter our first, if either. */
2817 tdiff = tlast - tfirst;
2818 rdiff = rlast - rfirst;
2825 if (rfirst == 0xffffffff) {
2826 diff = tdiff; /* oops, pretend rdiff is infinite */
2828 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2829 (long)tfirst, (long)tlast);
2831 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2835 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2836 (long)tfirst, (long)(tfirst + diff),
2839 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2840 (long)tfirst, (long)rfirst);
2842 if (rfirst + diff > max)
2843 max = rfirst + diff;
2845 grows = (tfirst < rfirst &&
2846 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2858 else if (max > 0xff)
2863 Safefree(cPVOPo->op_pv);
2864 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2865 SvREFCNT_dec(listsv);
2867 SvREFCNT_dec(transv);
2869 if (!del && havefinal && rlen)
2870 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2871 newSVuv((UV)final), 0);
2874 o->op_private |= OPpTRANS_GROWS;
2886 tbl = (short*)cPVOPo->op_pv;
2888 Zero(tbl, 256, short);
2889 for (i = 0; i < tlen; i++)
2891 for (i = 0, j = 0; i < 256; i++) {
2902 if (i < 128 && r[j] >= 128)
2912 o->op_private |= OPpTRANS_IDENTICAL;
2917 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2918 tbl[0x100] = rlen - j;
2919 for (i=0; i < rlen - j; i++)
2920 tbl[0x101+i] = r[j+i];
2924 if (!rlen && !del) {
2927 o->op_private |= OPpTRANS_IDENTICAL;
2929 for (i = 0; i < 256; i++)
2931 for (i = 0, j = 0; i < tlen; i++,j++) {
2934 if (tbl[t[i]] == -1)
2940 if (tbl[t[i]] == -1) {
2941 if (t[i] < 128 && r[j] >= 128)
2948 o->op_private |= OPpTRANS_GROWS;
2956 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2960 NewOp(1101, pmop, 1, PMOP);
2961 pmop->op_type = type;
2962 pmop->op_ppaddr = PL_ppaddr[type];
2963 pmop->op_flags = flags;
2964 pmop->op_private = 0 | (flags >> 8);
2966 if (PL_hints & HINT_RE_TAINT)
2967 pmop->op_pmpermflags |= PMf_RETAINT;
2968 if (PL_hints & HINT_LOCALE)
2969 pmop->op_pmpermflags |= PMf_LOCALE;
2970 pmop->op_pmflags = pmop->op_pmpermflags;
2975 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2976 repointer = av_pop((AV*)PL_regex_pad[0]);
2977 pmop->op_pmoffset = SvIV(repointer);
2978 sv_setiv(repointer,0);
2980 repointer = newSViv(0);
2981 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2982 pmop->op_pmoffset = av_len(PL_regex_padav);
2983 PL_regex_pad = AvARRAY(PL_regex_padav);
2988 /* link into pm list */
2989 if (type != OP_TRANS && PL_curstash) {
2990 pmop->op_pmnext = HvPMROOT(PL_curstash);
2991 HvPMROOT(PL_curstash) = pmop;
2992 PmopSTASH_set(pmop,PL_curstash);
2999 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3003 I32 repl_has_vars = 0;
3005 if (o->op_type == OP_TRANS)
3006 return pmtrans(o, expr, repl);
3008 PL_hints |= HINT_BLOCK_SCOPE;
3011 if (expr->op_type == OP_CONST) {
3013 SV *pat = ((SVOP*)expr)->op_sv;
3014 char *p = SvPV(pat, plen);
3015 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3016 sv_setpvn(pat, "\\s+", 3);
3017 p = SvPV(pat, plen);
3018 pm->op_pmflags |= PMf_SKIPWHITE;
3020 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3021 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3022 pm->op_pmflags |= PMf_WHITE;
3026 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3027 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3029 : OP_REGCMAYBE),0,expr);
3031 NewOp(1101, rcop, 1, LOGOP);
3032 rcop->op_type = OP_REGCOMP;
3033 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3034 rcop->op_first = scalar(expr);
3035 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3036 ? (OPf_SPECIAL | OPf_KIDS)
3038 rcop->op_private = 1;
3041 /* establish postfix order */
3042 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3044 rcop->op_next = expr;
3045 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3048 rcop->op_next = LINKLIST(expr);
3049 expr->op_next = (OP*)rcop;
3052 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3057 if (pm->op_pmflags & PMf_EVAL) {
3059 if (CopLINE(PL_curcop) < PL_multi_end)
3060 CopLINE_set(PL_curcop, PL_multi_end);
3063 else if (repl->op_type == OP_THREADSV
3064 && strchr("&`'123456789+",
3065 PL_threadsv_names[repl->op_targ]))
3069 #endif /* USE_THREADS */
3070 else if (repl->op_type == OP_CONST)
3074 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3075 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3077 if (curop->op_type == OP_THREADSV) {
3079 if (strchr("&`'123456789+", curop->op_private))
3083 if (curop->op_type == OP_GV) {
3084 GV *gv = cGVOPx_gv(curop);
3086 if (strchr("&`'123456789+", *GvENAME(gv)))
3089 #endif /* USE_THREADS */
3090 else if (curop->op_type == OP_RV2CV)
3092 else if (curop->op_type == OP_RV2SV ||
3093 curop->op_type == OP_RV2AV ||
3094 curop->op_type == OP_RV2HV ||
3095 curop->op_type == OP_RV2GV) {
3096 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3099 else if (curop->op_type == OP_PADSV ||
3100 curop->op_type == OP_PADAV ||
3101 curop->op_type == OP_PADHV ||
3102 curop->op_type == OP_PADANY) {
3105 else if (curop->op_type == OP_PUSHRE)
3106 ; /* Okay here, dangerous in newASSIGNOP */
3116 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3117 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3118 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3119 prepend_elem(o->op_type, scalar(repl), o);
3122 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3123 pm->op_pmflags |= PMf_MAYBE_CONST;
3124 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3126 NewOp(1101, rcop, 1, LOGOP);
3127 rcop->op_type = OP_SUBSTCONT;
3128 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3129 rcop->op_first = scalar(repl);
3130 rcop->op_flags |= OPf_KIDS;
3131 rcop->op_private = 1;
3134 /* establish postfix order */
3135 rcop->op_next = LINKLIST(repl);
3136 repl->op_next = (OP*)rcop;
3138 pm->op_pmreplroot = scalar((OP*)rcop);
3139 pm->op_pmreplstart = LINKLIST(rcop);
3148 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3151 NewOp(1101, svop, 1, SVOP);
3152 svop->op_type = type;
3153 svop->op_ppaddr = PL_ppaddr[type];
3155 svop->op_next = (OP*)svop;
3156 svop->op_flags = flags;
3157 if (PL_opargs[type] & OA_RETSCALAR)
3159 if (PL_opargs[type] & OA_TARGET)
3160 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3161 return CHECKOP(type, svop);
3165 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3168 NewOp(1101, padop, 1, PADOP);
3169 padop->op_type = type;
3170 padop->op_ppaddr = PL_ppaddr[type];
3171 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3172 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3173 PL_curpad[padop->op_padix] = sv;
3175 padop->op_next = (OP*)padop;
3176 padop->op_flags = flags;
3177 if (PL_opargs[type] & OA_RETSCALAR)
3179 if (PL_opargs[type] & OA_TARGET)
3180 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3181 return CHECKOP(type, padop);
3185 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3189 return newPADOP(type, flags, SvREFCNT_inc(gv));
3191 return newSVOP(type, flags, SvREFCNT_inc(gv));
3196 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3199 NewOp(1101, pvop, 1, PVOP);
3200 pvop->op_type = type;
3201 pvop->op_ppaddr = PL_ppaddr[type];
3203 pvop->op_next = (OP*)pvop;
3204 pvop->op_flags = flags;
3205 if (PL_opargs[type] & OA_RETSCALAR)
3207 if (PL_opargs[type] & OA_TARGET)
3208 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3209 return CHECKOP(type, pvop);
3213 Perl_package(pTHX_ OP *o)
3217 save_hptr(&PL_curstash);
3218 save_item(PL_curstname);
3223 name = SvPV(sv, len);
3224 PL_curstash = gv_stashpvn(name,len,TRUE);
3225 sv_setpvn(PL_curstname, name, len);
3229 deprecate("\"package\" with no arguments");
3230 sv_setpv(PL_curstname,"<none>");
3231 PL_curstash = Nullhv;
3233 PL_hints |= HINT_BLOCK_SCOPE;
3234 PL_copline = NOLINE;
3239 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3244 char *packname = Nullch;
3248 if (id->op_type != OP_CONST)
3249 Perl_croak(aTHX_ "Module name must be constant");
3253 if (version != Nullop) {
3254 SV *vesv = ((SVOP*)version)->op_sv;
3256 if (arg == Nullop && !SvNIOKp(vesv)) {
3263 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3264 Perl_croak(aTHX_ "Version number must be constant number");
3266 /* Make copy of id so we don't free it twice */
3267 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3269 /* Fake up a method call to VERSION */
3270 meth = newSVpvn("VERSION",7);
3271 sv_upgrade(meth, SVt_PVIV);
3272 (void)SvIOK_on(meth);
3273 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3274 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3275 append_elem(OP_LIST,
3276 prepend_elem(OP_LIST, pack, list(version)),
3277 newSVOP(OP_METHOD_NAMED, 0, meth)));
3281 /* Fake up an import/unimport */
3282 if (arg && arg->op_type == OP_STUB)
3283 imop = arg; /* no import on explicit () */
3284 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3285 imop = Nullop; /* use 5.0; */
3290 /* Make copy of id so we don't free it twice */
3291 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3293 /* Fake up a method call to import/unimport */
3294 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3295 sv_upgrade(meth, SVt_PVIV);
3296 (void)SvIOK_on(meth);
3297 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3298 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3299 append_elem(OP_LIST,
3300 prepend_elem(OP_LIST, pack, list(arg)),
3301 newSVOP(OP_METHOD_NAMED, 0, meth)));
3304 if (ckWARN(WARN_MISC) &&
3305 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3306 SvPOK(packsv = ((SVOP*)id)->op_sv))
3308 /* BEGIN will free the ops, so we need to make a copy */
3309 packlen = SvCUR(packsv);
3310 packname = savepvn(SvPVX(packsv), packlen);
3313 /* Fake up the BEGIN {}, which does its thing immediately. */
3315 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3318 append_elem(OP_LINESEQ,
3319 append_elem(OP_LINESEQ,
3320 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3321 newSTATEOP(0, Nullch, veop)),
3322 newSTATEOP(0, Nullch, imop) ));
3325 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3326 Perl_warner(aTHX_ WARN_MISC,
3327 "Package `%s' not found "
3328 "(did you use the incorrect case?)", packname);
3333 PL_hints |= HINT_BLOCK_SCOPE;
3334 PL_copline = NOLINE;
3339 =for apidoc load_module
3341 Loads the module whose name is pointed to by the string part of name.
3342 Note that the actual module name, not its filename, should be given.
3343 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3344 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3345 (or 0 for no flags). ver, if specified, provides version semantics
3346 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3347 arguments can be used to specify arguments to the module's import()
3348 method, similar to C<use Foo::Bar VERSION LIST>.
3353 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3356 va_start(args, ver);
3357 vload_module(flags, name, ver, &args);
3361 #ifdef PERL_IMPLICIT_CONTEXT
3363 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3367 va_start(args, ver);
3368 vload_module(flags, name, ver, &args);
3374 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3376 OP *modname, *veop, *imop;
3378 modname = newSVOP(OP_CONST, 0, name);
3379 modname->op_private |= OPpCONST_BARE;
3381 veop = newSVOP(OP_CONST, 0, ver);
3385 if (flags & PERL_LOADMOD_NOIMPORT) {
3386 imop = sawparens(newNULLLIST());
3388 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3389 imop = va_arg(*args, OP*);
3394 sv = va_arg(*args, SV*);
3396 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3397 sv = va_arg(*args, SV*);
3401 line_t ocopline = PL_copline;
3402 int oexpect = PL_expect;
3404 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3405 veop, modname, imop);
3406 PL_expect = oexpect;
3407 PL_copline = ocopline;
3412 Perl_dofile(pTHX_ OP *term)
3417 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3418 if (!(gv && GvIMPORTED_CV(gv)))
3419 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3421 if (gv && GvIMPORTED_CV(gv)) {
3422 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3423 append_elem(OP_LIST, term,
3424 scalar(newUNOP(OP_RV2CV, 0,
3429 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3435 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3437 return newBINOP(OP_LSLICE, flags,
3438 list(force_list(subscript)),
3439 list(force_list(listval)) );
3443 S_list_assignment(pTHX_ register OP *o)
3448 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3449 o = cUNOPo->op_first;
3451 if (o->op_type == OP_COND_EXPR) {
3452 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3453 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3458 yyerror("Assignment to both a list and a scalar");
3462 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3463 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3464 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3467 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3470 if (o->op_type == OP_RV2SV)
3477 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3482 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3483 return newLOGOP(optype, 0,
3484 mod(scalar(left), optype),
3485 newUNOP(OP_SASSIGN, 0, scalar(right)));
3488 return newBINOP(optype, OPf_STACKED,
3489 mod(scalar(left), optype), scalar(right));
3493 if (list_assignment(left)) {
3497 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3498 left = mod(left, OP_AASSIGN);
3506 curop = list(force_list(left));
3507 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3508 o->op_private = 0 | (flags >> 8);
3509 for (curop = ((LISTOP*)curop)->op_first;
3510 curop; curop = curop->op_sibling)
3512 if (curop->op_type == OP_RV2HV &&
3513 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3514 o->op_private |= OPpASSIGN_HASH;
3518 if (!(left->op_private & OPpLVAL_INTRO)) {
3521 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3522 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3523 if (curop->op_type == OP_GV) {
3524 GV *gv = cGVOPx_gv(curop);
3525 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3527 SvCUR(gv) = PL_generation;
3529 else if (curop->op_type == OP_PADSV ||
3530 curop->op_type == OP_PADAV ||
3531 curop->op_type == OP_PADHV ||
3532 curop->op_type == OP_PADANY) {
3533 SV **svp = AvARRAY(PL_comppad_name);
3534 SV *sv = svp[curop->op_targ];
3535 if (SvCUR(sv) == PL_generation)
3537 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3539 else if (curop->op_type == OP_RV2CV)
3541 else if (curop->op_type == OP_RV2SV ||
3542 curop->op_type == OP_RV2AV ||
3543 curop->op_type == OP_RV2HV ||
3544 curop->op_type == OP_RV2GV) {
3545 if (lastop->op_type != OP_GV) /* funny deref? */
3548 else if (curop->op_type == OP_PUSHRE) {
3549 if (((PMOP*)curop)->op_pmreplroot) {
3551 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3553 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3555 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3557 SvCUR(gv) = PL_generation;
3566 o->op_private |= OPpASSIGN_COMMON;
3568 if (right && right->op_type == OP_SPLIT) {
3570 if ((tmpop = ((LISTOP*)right)->op_first) &&
3571 tmpop->op_type == OP_PUSHRE)
3573 PMOP *pm = (PMOP*)tmpop;
3574 if (left->op_type == OP_RV2AV &&
3575 !(left->op_private & OPpLVAL_INTRO) &&
3576 !(o->op_private & OPpASSIGN_COMMON) )
3578 tmpop = ((UNOP*)left)->op_first;
3579 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3581 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3582 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3584 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3585 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3587 pm->op_pmflags |= PMf_ONCE;
3588 tmpop = cUNOPo->op_first; /* to list (nulled) */
3589 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3590 tmpop->op_sibling = Nullop; /* don't free split */
3591 right->op_next = tmpop->op_next; /* fix starting loc */
3592 op_free(o); /* blow off assign */
3593 right->op_flags &= ~OPf_WANT;
3594 /* "I don't know and I don't care." */
3599 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3600 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3602 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3604 sv_setiv(sv, PL_modcount+1);
3612 right = newOP(OP_UNDEF, 0);
3613 if (right->op_type == OP_READLINE) {
3614 right->op_flags |= OPf_STACKED;
3615 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3618 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3619 o = newBINOP(OP_SASSIGN, flags,
3620 scalar(right), mod(scalar(left), OP_SASSIGN) );
3632 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3634 U32 seq = intro_my();
3637 NewOp(1101, cop, 1, COP);
3638 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3639 cop->op_type = OP_DBSTATE;
3640 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3643 cop->op_type = OP_NEXTSTATE;
3644 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3646 cop->op_flags = flags;
3647 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3649 cop->op_private |= NATIVE_HINTS;
3651 PL_compiling.op_private = cop->op_private;
3652 cop->op_next = (OP*)cop;
3655 cop->cop_label = label;
3656 PL_hints |= HINT_BLOCK_SCOPE;
3659 cop->cop_arybase = PL_curcop->cop_arybase;
3660 if (specialWARN(PL_curcop->cop_warnings))
3661 cop->cop_warnings = PL_curcop->cop_warnings ;
3663 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3664 if (specialCopIO(PL_curcop->cop_io))
3665 cop->cop_io = PL_curcop->cop_io;
3667 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3670 if (PL_copline == NOLINE)
3671 CopLINE_set(cop, CopLINE(PL_curcop));
3673 CopLINE_set(cop, PL_copline);
3674 PL_copline = NOLINE;
3677 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3679 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3681 CopSTASH_set(cop, PL_curstash);
3683 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3684 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3685 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3686 (void)SvIOK_on(*svp);
3687 SvIVX(*svp) = PTR2IV(cop);
3691 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3694 /* "Introduce" my variables to visible status. */
3702 if (! PL_min_intro_pending)
3703 return PL_cop_seqmax;
3705 svp = AvARRAY(PL_comppad_name);
3706 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3707 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3708 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3709 SvNVX(sv) = (NV)PL_cop_seqmax;
3712 PL_min_intro_pending = 0;
3713 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3714 return PL_cop_seqmax++;
3718 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3720 return new_logop(type, flags, &first, &other);
3724 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3728 OP *first = *firstp;
3729 OP *other = *otherp;
3731 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3732 return newBINOP(type, flags, scalar(first), scalar(other));
3734 scalarboolean(first);
3735 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3736 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3737 if (type == OP_AND || type == OP_OR) {
3743 first = *firstp = cUNOPo->op_first;
3745 first->op_next = o->op_next;
3746 cUNOPo->op_first = Nullop;
3750 if (first->op_type == OP_CONST) {
3751 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3752 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3753 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3764 else if (first->op_type == OP_WANTARRAY) {
3770 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3771 OP *k1 = ((UNOP*)first)->op_first;
3772 OP *k2 = k1->op_sibling;
3774 switch (first->op_type)
3777 if (k2 && k2->op_type == OP_READLINE
3778 && (k2->op_flags & OPf_STACKED)
3779 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3781 warnop = k2->op_type;
3786 if (k1->op_type == OP_READDIR
3787 || k1->op_type == OP_GLOB
3788 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3789 || k1->op_type == OP_EACH)
3791 warnop = ((k1->op_type == OP_NULL)
3792 ? k1->op_targ : k1->op_type);
3797 line_t oldline = CopLINE(PL_curcop);
3798 CopLINE_set(PL_curcop, PL_copline);
3799 Perl_warner(aTHX_ WARN_MISC,
3800 "Value of %s%s can be \"0\"; test with defined()",
3802 ((warnop == OP_READLINE || warnop == OP_GLOB)
3803 ? " construct" : "() operator"));
3804 CopLINE_set(PL_curcop, oldline);
3811 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3812 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3814 NewOp(1101, logop, 1, LOGOP);
3816 logop->op_type = type;
3817 logop->op_ppaddr = PL_ppaddr[type];
3818 logop->op_first = first;
3819 logop->op_flags = flags | OPf_KIDS;
3820 logop->op_other = LINKLIST(other);
3821 logop->op_private = 1 | (flags >> 8);
3823 /* establish postfix order */
3824 logop->op_next = LINKLIST(first);
3825 first->op_next = (OP*)logop;
3826 first->op_sibling = other;
3828 o = newUNOP(OP_NULL, 0, (OP*)logop);
3835 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3842 return newLOGOP(OP_AND, 0, first, trueop);
3844 return newLOGOP(OP_OR, 0, first, falseop);
3846 scalarboolean(first);
3847 if (first->op_type == OP_CONST) {
3848 if (SvTRUE(((SVOP*)first)->op_sv)) {
3859 else if (first->op_type == OP_WANTARRAY) {
3863 NewOp(1101, logop, 1, LOGOP);
3864 logop->op_type = OP_COND_EXPR;
3865 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3866 logop->op_first = first;
3867 logop->op_flags = flags | OPf_KIDS;
3868 logop->op_private = 1 | (flags >> 8);
3869 logop->op_other = LINKLIST(trueop);
3870 logop->op_next = LINKLIST(falseop);
3873 /* establish postfix order */
3874 start = LINKLIST(first);
3875 first->op_next = (OP*)logop;
3877 first->op_sibling = trueop;
3878 trueop->op_sibling = falseop;
3879 o = newUNOP(OP_NULL, 0, (OP*)logop);
3881 trueop->op_next = falseop->op_next = o;
3888 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3896 NewOp(1101, range, 1, LOGOP);
3898 range->op_type = OP_RANGE;
3899 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3900 range->op_first = left;
3901 range->op_flags = OPf_KIDS;
3902 leftstart = LINKLIST(left);
3903 range->op_other = LINKLIST(right);
3904 range->op_private = 1 | (flags >> 8);
3906 left->op_sibling = right;
3908 range->op_next = (OP*)range;
3909 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3910 flop = newUNOP(OP_FLOP, 0, flip);
3911 o = newUNOP(OP_NULL, 0, flop);
3913 range->op_next = leftstart;
3915 left->op_next = flip;
3916 right->op_next = flop;
3918 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3919 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3920 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3921 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3923 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3924 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3927 if (!flip->op_private || !flop->op_private)
3928 linklist(o); /* blow off optimizer unless constant */
3934 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3938 int once = block && block->op_flags & OPf_SPECIAL &&
3939 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3942 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3943 return block; /* do {} while 0 does once */
3944 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3945 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3946 expr = newUNOP(OP_DEFINED, 0,
3947 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3948 } else if (expr->op_flags & OPf_KIDS) {
3949 OP *k1 = ((UNOP*)expr)->op_first;
3950 OP *k2 = (k1) ? k1->op_sibling : NULL;
3951 switch (expr->op_type) {
3953 if (k2 && k2->op_type == OP_READLINE
3954 && (k2->op_flags & OPf_STACKED)
3955 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3956 expr = newUNOP(OP_DEFINED, 0, expr);
3960 if (k1->op_type == OP_READDIR
3961 || k1->op_type == OP_GLOB
3962 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3963 || k1->op_type == OP_EACH)
3964 expr = newUNOP(OP_DEFINED, 0, expr);
3970 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3971 o = new_logop(OP_AND, 0, &expr, &listop);
3974 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3976 if (once && o != listop)
3977 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3980 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3982 o->op_flags |= flags;
3984 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3989 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3997 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3998 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3999 expr = newUNOP(OP_DEFINED, 0,
4000 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4001 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4002 OP *k1 = ((UNOP*)expr)->op_first;
4003 OP *k2 = (k1) ? k1->op_sibling : NULL;
4004 switch (expr->op_type) {
4006 if (k2 && k2->op_type == OP_READLINE
4007 && (k2->op_flags & OPf_STACKED)
4008 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4009 expr = newUNOP(OP_DEFINED, 0, expr);
4013 if (k1->op_type == OP_READDIR
4014 || k1->op_type == OP_GLOB
4015 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4016 || k1->op_type == OP_EACH)
4017 expr = newUNOP(OP_DEFINED, 0, expr);
4023 block = newOP(OP_NULL, 0);
4025 block = scope(block);
4029 next = LINKLIST(cont);
4032 OP *unstack = newOP(OP_UNSTACK, 0);
4035 cont = append_elem(OP_LINESEQ, cont, unstack);
4036 if ((line_t)whileline != NOLINE) {
4037 PL_copline = whileline;
4038 cont = append_elem(OP_LINESEQ, cont,
4039 newSTATEOP(0, Nullch, Nullop));
4043 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4044 redo = LINKLIST(listop);
4047 PL_copline = whileline;
4049 o = new_logop(OP_AND, 0, &expr, &listop);
4050 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4051 op_free(expr); /* oops, it's a while (0) */
4053 return Nullop; /* listop already freed by new_logop */
4056 ((LISTOP*)listop)->op_last->op_next =
4057 (o == listop ? redo : LINKLIST(o));
4063 NewOp(1101,loop,1,LOOP);
4064 loop->op_type = OP_ENTERLOOP;
4065 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4066 loop->op_private = 0;
4067 loop->op_next = (OP*)loop;
4070 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4072 loop->op_redoop = redo;
4073 loop->op_lastop = o;
4074 o->op_private |= loopflags;
4077 loop->op_nextop = next;
4079 loop->op_nextop = o;
4081 o->op_flags |= flags;
4082 o->op_private |= (flags >> 8);
4087 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4095 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4096 sv->op_type = OP_RV2GV;
4097 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4099 else if (sv->op_type == OP_PADSV) { /* private variable */
4100 padoff = sv->op_targ;
4105 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4106 padoff = sv->op_targ;
4108 iterflags |= OPf_SPECIAL;
4113 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4117 padoff = find_threadsv("_");
4118 iterflags |= OPf_SPECIAL;
4120 sv = newGVOP(OP_GV, 0, PL_defgv);
4123 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4124 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4125 iterflags |= OPf_STACKED;
4127 else if (expr->op_type == OP_NULL &&
4128 (expr->op_flags & OPf_KIDS) &&
4129 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4131 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4132 * set the STACKED flag to indicate that these values are to be
4133 * treated as min/max values by 'pp_iterinit'.
4135 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4136 LOGOP* range = (LOGOP*) flip->op_first;
4137 OP* left = range->op_first;
4138 OP* right = left->op_sibling;
4141 range->op_flags &= ~OPf_KIDS;
4142 range->op_first = Nullop;
4144 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4145 listop->op_first->op_next = range->op_next;
4146 left->op_next = range->op_other;
4147 right->op_next = (OP*)listop;
4148 listop->op_next = listop->op_first;
4151 expr = (OP*)(listop);
4153 iterflags |= OPf_STACKED;
4156 expr = mod(force_list(expr), OP_GREPSTART);
4160 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4161 append_elem(OP_LIST, expr, scalar(sv))));
4162 assert(!loop->op_next);
4163 #ifdef PL_OP_SLAB_ALLOC
4166 NewOp(1234,tmp,1,LOOP);
4167 Copy(loop,tmp,1,LOOP);
4171 Renew(loop, 1, LOOP);
4173 loop->op_targ = padoff;
4174 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4175 PL_copline = forline;
4176 return newSTATEOP(0, label, wop);
4180 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4185 if (type != OP_GOTO || label->op_type == OP_CONST) {
4186 /* "last()" means "last" */
4187 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4188 o = newOP(type, OPf_SPECIAL);
4190 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4191 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4197 if (label->op_type == OP_ENTERSUB)
4198 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4199 o = newUNOP(type, OPf_STACKED, label);
4201 PL_hints |= HINT_BLOCK_SCOPE;
4206 Perl_cv_undef(pTHX_ CV *cv)
4210 MUTEX_DESTROY(CvMUTEXP(cv));
4211 Safefree(CvMUTEXP(cv));
4214 #endif /* USE_THREADS */
4217 if (CvFILE(cv) && !CvXSUB(cv)) {
4218 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4219 Safefree(CvFILE(cv));
4224 if (!CvXSUB(cv) && CvROOT(cv)) {
4226 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4227 Perl_croak(aTHX_ "Can't undef active subroutine");
4230 Perl_croak(aTHX_ "Can't undef active subroutine");
4231 #endif /* USE_THREADS */
4234 SAVEVPTR(PL_curpad);
4237 op_free(CvROOT(cv));
4238 CvROOT(cv) = Nullop;
4241 SvPOK_off((SV*)cv); /* forget prototype */
4243 /* Since closure prototypes have the same lifetime as the containing
4244 * CV, they don't hold a refcount on the outside CV. This avoids
4245 * the refcount loop between the outer CV (which keeps a refcount to
4246 * the closure prototype in the pad entry for pp_anoncode()) and the
4247 * closure prototype, and the ensuing memory leak. This does not
4248 * apply to closures generated within eval"", since eval"" CVs are
4249 * ephemeral. --GSAR */
4250 if (!CvANON(cv) || CvCLONED(cv)
4251 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4252 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4254 SvREFCNT_dec(CvOUTSIDE(cv));
4256 CvOUTSIDE(cv) = Nullcv;
4258 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4261 if (CvPADLIST(cv)) {
4262 /* may be during global destruction */
4263 if (SvREFCNT(CvPADLIST(cv))) {
4264 I32 i = AvFILLp(CvPADLIST(cv));
4266 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4267 SV* sv = svp ? *svp : Nullsv;
4270 if (sv == (SV*)PL_comppad_name)
4271 PL_comppad_name = Nullav;
4272 else if (sv == (SV*)PL_comppad) {
4273 PL_comppad = Nullav;
4274 PL_curpad = Null(SV**);
4278 SvREFCNT_dec((SV*)CvPADLIST(cv));
4280 CvPADLIST(cv) = Nullav;
4288 #ifdef DEBUG_CLOSURES
4290 S_cv_dump(pTHX_ CV *cv)
4293 CV *outside = CvOUTSIDE(cv);
4294 AV* padlist = CvPADLIST(cv);
4301 PerlIO_printf(Perl_debug_log,
4302 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4304 (CvANON(cv) ? "ANON"
4305 : (cv == PL_main_cv) ? "MAIN"
4306 : CvUNIQUE(cv) ? "UNIQUE"
4307 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4310 : CvANON(outside) ? "ANON"
4311 : (outside == PL_main_cv) ? "MAIN"
4312 : CvUNIQUE(outside) ? "UNIQUE"
4313 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4318 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4319 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4320 pname = AvARRAY(pad_name);
4321 ppad = AvARRAY(pad);
4323 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4324 if (SvPOK(pname[ix]))
4325 PerlIO_printf(Perl_debug_log,
4326 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4327 (int)ix, PTR2UV(ppad[ix]),
4328 SvFAKE(pname[ix]) ? "FAKE " : "",
4330 (IV)I_32(SvNVX(pname[ix])),
4333 #endif /* DEBUGGING */
4335 #endif /* DEBUG_CLOSURES */
4338 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4342 AV* protopadlist = CvPADLIST(proto);
4343 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4344 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4345 SV** pname = AvARRAY(protopad_name);
4346 SV** ppad = AvARRAY(protopad);
4347 I32 fname = AvFILLp(protopad_name);
4348 I32 fpad = AvFILLp(protopad);
4352 assert(!CvUNIQUE(proto));
4356 SAVESPTR(PL_comppad_name);
4357 SAVESPTR(PL_compcv);
4359 cv = PL_compcv = (CV*)NEWSV(1104,0);
4360 sv_upgrade((SV *)cv, SvTYPE(proto));
4361 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4365 New(666, CvMUTEXP(cv), 1, perl_mutex);
4366 MUTEX_INIT(CvMUTEXP(cv));
4368 #endif /* USE_THREADS */
4370 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4371 : savepv(CvFILE(proto));
4373 CvFILE(cv) = CvFILE(proto);
4375 CvGV(cv) = CvGV(proto);
4376 CvSTASH(cv) = CvSTASH(proto);
4377 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4378 CvSTART(cv) = CvSTART(proto);
4380 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4383 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4385 PL_comppad_name = newAV();
4386 for (ix = fname; ix >= 0; ix--)
4387 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4389 PL_comppad = newAV();
4391 comppadlist = newAV();
4392 AvREAL_off(comppadlist);
4393 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4394 av_store(comppadlist, 1, (SV*)PL_comppad);
4395 CvPADLIST(cv) = comppadlist;
4396 av_fill(PL_comppad, AvFILLp(protopad));
4397 PL_curpad = AvARRAY(PL_comppad);
4399 av = newAV(); /* will be @_ */
4401 av_store(PL_comppad, 0, (SV*)av);
4402 AvFLAGS(av) = AVf_REIFY;
4404 for (ix = fpad; ix > 0; ix--) {
4405 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4406 if (namesv && namesv != &PL_sv_undef) {
4407 char *name = SvPVX(namesv); /* XXX */
4408 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4409 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4410 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4412 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4414 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4416 else { /* our own lexical */
4419 /* anon code -- we'll come back for it */
4420 sv = SvREFCNT_inc(ppad[ix]);
4422 else if (*name == '@')
4424 else if (*name == '%')
4433 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4434 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4437 SV* sv = NEWSV(0,0);
4443 /* Now that vars are all in place, clone nested closures. */
4445 for (ix = fpad; ix > 0; ix--) {
4446 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4448 && namesv != &PL_sv_undef
4449 && !(SvFLAGS(namesv) & SVf_FAKE)
4450 && *SvPVX(namesv) == '&'
4451 && CvCLONE(ppad[ix]))
4453 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4454 SvREFCNT_dec(ppad[ix]);
4457 PL_curpad[ix] = (SV*)kid;
4461 #ifdef DEBUG_CLOSURES
4462 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4464 PerlIO_printf(Perl_debug_log, " from:\n");
4466 PerlIO_printf(Perl_debug_log, " to:\n");
4473 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4475 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4477 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4484 Perl_cv_clone(pTHX_ CV *proto)
4487 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4488 cv = cv_clone2(proto, CvOUTSIDE(proto));
4489 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4494 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4496 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4497 SV* msg = sv_newmortal();
4501 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4502 sv_setpv(msg, "Prototype mismatch:");
4504 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4506 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4507 sv_catpv(msg, " vs ");
4509 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4511 sv_catpv(msg, "none");
4512 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4516 static void const_sv_xsub(pTHXo_ CV* cv);
4519 =for apidoc cv_const_sv
4521 If C<cv> is a constant sub eligible for inlining. returns the constant
4522 value returned by the sub. Otherwise, returns NULL.
4524 Constant subs can be created with C<newCONSTSUB> or as described in
4525 L<perlsub/"Constant Functions">.
4530 Perl_cv_const_sv(pTHX_ CV *cv)
4532 if (!cv || !CvCONST(cv))
4534 return (SV*)CvXSUBANY(cv).any_ptr;
4538 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4545 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4546 o = cLISTOPo->op_first->op_sibling;
4548 for (; o; o = o->op_next) {
4549 OPCODE type = o->op_type;
4551 if (sv && o->op_next == o)
4553 if (o->op_next != o) {
4554 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4556 if (type == OP_DBSTATE)
4559 if (type == OP_LEAVESUB || type == OP_RETURN)
4563 if (type == OP_CONST && cSVOPo->op_sv)
4565 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4566 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4567 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4571 /* We get here only from cv_clone2() while creating a closure.
4572 Copy the const value here instead of in cv_clone2 so that
4573 SvREADONLY_on doesn't lead to problems when leaving
4578 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4590 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4600 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4604 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4606 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4610 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4616 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4621 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4622 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4623 SV *sv = sv_newmortal();
4624 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4625 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4630 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4631 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4641 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4642 maximum a prototype before. */
4643 if (SvTYPE(gv) > SVt_NULL) {
4644 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4645 && ckWARN_d(WARN_PROTOTYPE))
4647 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4649 cv_ckproto((CV*)gv, NULL, ps);
4652 sv_setpv((SV*)gv, ps);
4654 sv_setiv((SV*)gv, -1);
4655 SvREFCNT_dec(PL_compcv);
4656 cv = PL_compcv = NULL;
4657 PL_sub_generation++;
4661 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4663 #ifdef GV_UNIQUE_CHECK
4664 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4665 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4669 if (!block || !ps || *ps || attrs)
4672 const_sv = op_const_sv(block, Nullcv);
4675 bool exists = CvROOT(cv) || CvXSUB(cv);
4677 #ifdef GV_UNIQUE_CHECK
4678 if (exists && GvUNIQUE(gv)) {
4679 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4683 /* if the subroutine doesn't exist and wasn't pre-declared
4684 * with a prototype, assume it will be AUTOLOADed,
4685 * skipping the prototype check
4687 if (exists || SvPOK(cv))
4688 cv_ckproto(cv, gv, ps);
4689 /* already defined (or promised)? */
4690 if (exists || GvASSUMECV(gv)) {
4691 if (!block && !attrs) {
4692 /* just a "sub foo;" when &foo is already defined */
4693 SAVEFREESV(PL_compcv);
4696 /* ahem, death to those who redefine active sort subs */
4697 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4698 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4700 if (ckWARN(WARN_REDEFINE)
4702 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4704 line_t oldline = CopLINE(PL_curcop);
4705 CopLINE_set(PL_curcop, PL_copline);
4706 Perl_warner(aTHX_ WARN_REDEFINE,
4707 CvCONST(cv) ? "Constant subroutine %s redefined"
4708 : "Subroutine %s redefined", name);
4709 CopLINE_set(PL_curcop, oldline);
4717 SvREFCNT_inc(const_sv);
4719 assert(!CvROOT(cv) && !CvCONST(cv));
4720 sv_setpv((SV*)cv, ""); /* prototype is "" */
4721 CvXSUBANY(cv).any_ptr = const_sv;
4722 CvXSUB(cv) = const_sv_xsub;
4727 cv = newCONSTSUB(NULL, name, const_sv);
4730 SvREFCNT_dec(PL_compcv);
4732 PL_sub_generation++;
4739 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4740 * before we clobber PL_compcv.
4744 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4745 stash = GvSTASH(CvGV(cv));
4746 else if (CvSTASH(cv))
4747 stash = CvSTASH(cv);
4749 stash = PL_curstash;
4752 /* possibly about to re-define existing subr -- ignore old cv */
4753 rcv = (SV*)PL_compcv;
4754 if (name && GvSTASH(gv))
4755 stash = GvSTASH(gv);
4757 stash = PL_curstash;
4759 apply_attrs(stash, rcv, attrs);
4761 if (cv) { /* must reuse cv if autoloaded */
4763 /* got here with just attrs -- work done, so bug out */
4764 SAVEFREESV(PL_compcv);
4768 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4769 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4770 CvOUTSIDE(PL_compcv) = 0;
4771 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4772 CvPADLIST(PL_compcv) = 0;
4773 /* inner references to PL_compcv must be fixed up ... */
4775 AV *padlist = CvPADLIST(cv);
4776 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4777 AV *comppad = (AV*)AvARRAY(padlist)[1];
4778 SV **namepad = AvARRAY(comppad_name);
4779 SV **curpad = AvARRAY(comppad);
4780 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4781 SV *namesv = namepad[ix];
4782 if (namesv && namesv != &PL_sv_undef
4783 && *SvPVX(namesv) == '&')
4785 CV *innercv = (CV*)curpad[ix];
4786 if (CvOUTSIDE(innercv) == PL_compcv) {
4787 CvOUTSIDE(innercv) = cv;
4788 if (!CvANON(innercv) || CvCLONED(innercv)) {
4789 (void)SvREFCNT_inc(cv);
4790 SvREFCNT_dec(PL_compcv);
4796 /* ... before we throw it away */
4797 SvREFCNT_dec(PL_compcv);
4798 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4799 ++PL_sub_generation;
4806 PL_sub_generation++;
4810 CvFILE_set_from_cop(cv, PL_curcop);
4811 CvSTASH(cv) = PL_curstash;
4814 if (!CvMUTEXP(cv)) {
4815 New(666, CvMUTEXP(cv), 1, perl_mutex);
4816 MUTEX_INIT(CvMUTEXP(cv));
4818 #endif /* USE_THREADS */
4821 sv_setpv((SV*)cv, ps);
4823 if (PL_error_count) {
4827 char *s = strrchr(name, ':');
4829 if (strEQ(s, "BEGIN")) {
4831 "BEGIN not safe after errors--compilation aborted";
4832 if (PL_in_eval & EVAL_KEEPERR)
4833 Perl_croak(aTHX_ not_safe);
4835 /* force display of errors found but not reported */
4836 sv_catpv(ERRSV, not_safe);
4837 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4845 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4846 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4849 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4850 mod(scalarseq(block), OP_LEAVESUBLV));
4853 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4855 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4856 OpREFCNT_set(CvROOT(cv), 1);
4857 CvSTART(cv) = LINKLIST(CvROOT(cv));
4858 CvROOT(cv)->op_next = 0;
4859 CALL_PEEP(CvSTART(cv));
4861 /* now that optimizer has done its work, adjust pad values */
4863 SV **namep = AvARRAY(PL_comppad_name);
4864 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4867 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4870 * The only things that a clonable function needs in its
4871 * pad are references to outer lexicals and anonymous subs.
4872 * The rest are created anew during cloning.
4874 if (!((namesv = namep[ix]) != Nullsv &&
4875 namesv != &PL_sv_undef &&
4877 *SvPVX(namesv) == '&')))
4879 SvREFCNT_dec(PL_curpad[ix]);
4880 PL_curpad[ix] = Nullsv;
4883 assert(!CvCONST(cv));
4884 if (ps && !*ps && op_const_sv(block, cv))
4888 AV *av = newAV(); /* Will be @_ */
4890 av_store(PL_comppad, 0, (SV*)av);
4891 AvFLAGS(av) = AVf_REIFY;
4893 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4894 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4896 if (!SvPADMY(PL_curpad[ix]))
4897 SvPADTMP_on(PL_curpad[ix]);
4901 /* If a potential closure prototype, don't keep a refcount on
4902 * outer CV, unless the latter happens to be a passing eval"".
4903 * This is okay as the lifetime of the prototype is tied to the
4904 * lifetime of the outer CV. Avoids memory leak due to reference
4906 if (!name && CvOUTSIDE(cv)
4907 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4908 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4910 SvREFCNT_dec(CvOUTSIDE(cv));
4913 if (name || aname) {
4915 char *tname = (name ? name : aname);
4917 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4918 SV *sv = NEWSV(0,0);
4919 SV *tmpstr = sv_newmortal();
4920 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4924 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4926 (long)PL_subline, (long)CopLINE(PL_curcop));
4927 gv_efullname3(tmpstr, gv, Nullch);
4928 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4929 hv = GvHVn(db_postponed);
4930 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4931 && (pcv = GvCV(db_postponed)))
4937 call_sv((SV*)pcv, G_DISCARD);
4941 if ((s = strrchr(tname,':')))
4946 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4949 if (strEQ(s, "BEGIN")) {
4950 I32 oldscope = PL_scopestack_ix;
4952 SAVECOPFILE(&PL_compiling);
4953 SAVECOPLINE(&PL_compiling);
4955 sv_setsv(PL_rs, PL_nrs);
4958 PL_beginav = newAV();
4959 DEBUG_x( dump_sub(gv) );
4960 av_push(PL_beginav, (SV*)cv);
4961 GvCV(gv) = 0; /* cv has been hijacked */
4962 call_list(oldscope, PL_beginav);
4964 PL_curcop = &PL_compiling;
4965 PL_compiling.op_private = PL_hints;
4968 else if (strEQ(s, "END") && !PL_error_count) {
4971 DEBUG_x( dump_sub(gv) );
4972 av_unshift(PL_endav, 1);
4973 av_store(PL_endav, 0, (SV*)cv);
4974 GvCV(gv) = 0; /* cv has been hijacked */
4976 else if (strEQ(s, "CHECK") && !PL_error_count) {
4978 PL_checkav = newAV();
4979 DEBUG_x( dump_sub(gv) );
4980 if (PL_main_start && ckWARN(WARN_VOID))
4981 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4982 av_unshift(PL_checkav, 1);
4983 av_store(PL_checkav, 0, (SV*)cv);
4984 GvCV(gv) = 0; /* cv has been hijacked */
4986 else if (strEQ(s, "INIT") && !PL_error_count) {
4988 PL_initav = newAV();
4989 DEBUG_x( dump_sub(gv) );
4990 if (PL_main_start && ckWARN(WARN_VOID))
4991 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4992 av_push(PL_initav, (SV*)cv);
4993 GvCV(gv) = 0; /* cv has been hijacked */
4998 PL_copline = NOLINE;
5003 /* XXX unsafe for threads if eval_owner isn't held */
5005 =for apidoc newCONSTSUB
5007 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5008 eligible for inlining at compile-time.
5014 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5020 SAVECOPLINE(PL_curcop);
5021 CopLINE_set(PL_curcop, PL_copline);
5024 PL_hints &= ~HINT_BLOCK_SCOPE;
5027 SAVESPTR(PL_curstash);
5028 SAVECOPSTASH(PL_curcop);
5029 PL_curstash = stash;
5031 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5033 CopSTASH(PL_curcop) = stash;
5037 cv = newXS(name, const_sv_xsub, __FILE__);
5038 CvXSUBANY(cv).any_ptr = sv;
5040 sv_setpv((SV*)cv, ""); /* prototype is "" */
5048 =for apidoc U||newXS
5050 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5056 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5058 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5061 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5063 /* just a cached method */
5067 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5068 /* already defined (or promised) */
5069 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5070 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5071 line_t oldline = CopLINE(PL_curcop);
5072 if (PL_copline != NOLINE)
5073 CopLINE_set(PL_curcop, PL_copline);
5074 Perl_warner(aTHX_ WARN_REDEFINE,
5075 CvCONST(cv) ? "Constant subroutine %s redefined"
5076 : "Subroutine %s redefined"
5078 CopLINE_set(PL_curcop, oldline);
5085 if (cv) /* must reuse cv if autoloaded */
5088 cv = (CV*)NEWSV(1105,0);
5089 sv_upgrade((SV *)cv, SVt_PVCV);
5093 PL_sub_generation++;
5098 New(666, CvMUTEXP(cv), 1, perl_mutex);
5099 MUTEX_INIT(CvMUTEXP(cv));
5101 #endif /* USE_THREADS */
5102 (void)gv_fetchfile(filename);
5103 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5104 an external constant string */
5105 CvXSUB(cv) = subaddr;
5108 char *s = strrchr(name,':');
5114 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5117 if (strEQ(s, "BEGIN")) {
5119 PL_beginav = newAV();
5120 av_push(PL_beginav, (SV*)cv);
5121 GvCV(gv) = 0; /* cv has been hijacked */
5123 else if (strEQ(s, "END")) {
5126 av_unshift(PL_endav, 1);
5127 av_store(PL_endav, 0, (SV*)cv);
5128 GvCV(gv) = 0; /* cv has been hijacked */
5130 else if (strEQ(s, "CHECK")) {
5132 PL_checkav = newAV();
5133 if (PL_main_start && ckWARN(WARN_VOID))
5134 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5135 av_unshift(PL_checkav, 1);
5136 av_store(PL_checkav, 0, (SV*)cv);
5137 GvCV(gv) = 0; /* cv has been hijacked */
5139 else if (strEQ(s, "INIT")) {
5141 PL_initav = newAV();
5142 if (PL_main_start && ckWARN(WARN_VOID))
5143 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5144 av_push(PL_initav, (SV*)cv);
5145 GvCV(gv) = 0; /* cv has been hijacked */
5156 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5165 name = SvPVx(cSVOPo->op_sv, n_a);
5168 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5169 #ifdef GV_UNIQUE_CHECK
5171 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5175 if ((cv = GvFORM(gv))) {
5176 if (ckWARN(WARN_REDEFINE)) {
5177 line_t oldline = CopLINE(PL_curcop);
5179 CopLINE_set(PL_curcop, PL_copline);
5180 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5181 CopLINE_set(PL_curcop, oldline);
5188 CvFILE_set_from_cop(cv, PL_curcop);
5190 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5191 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5192 SvPADTMP_on(PL_curpad[ix]);
5195 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5196 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5197 OpREFCNT_set(CvROOT(cv), 1);
5198 CvSTART(cv) = LINKLIST(CvROOT(cv));
5199 CvROOT(cv)->op_next = 0;
5200 CALL_PEEP(CvSTART(cv));
5202 PL_copline = NOLINE;
5207 Perl_newANONLIST(pTHX_ OP *o)
5209 return newUNOP(OP_REFGEN, 0,
5210 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5214 Perl_newANONHASH(pTHX_ OP *o)
5216 return newUNOP(OP_REFGEN, 0,
5217 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5221 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5223 return newANONATTRSUB(floor, proto, Nullop, block);
5227 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5229 return newUNOP(OP_REFGEN, 0,
5230 newSVOP(OP_ANONCODE, 0,
5231 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5235 Perl_oopsAV(pTHX_ OP *o)
5237 switch (o->op_type) {
5239 o->op_type = OP_PADAV;
5240 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5241 return ref(o, OP_RV2AV);
5244 o->op_type = OP_RV2AV;
5245 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5250 if (ckWARN_d(WARN_INTERNAL))
5251 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5258 Perl_oopsHV(pTHX_ OP *o)
5260 switch (o->op_type) {
5263 o->op_type = OP_PADHV;
5264 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5265 return ref(o, OP_RV2HV);
5269 o->op_type = OP_RV2HV;
5270 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5275 if (ckWARN_d(WARN_INTERNAL))
5276 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5283 Perl_newAVREF(pTHX_ OP *o)
5285 if (o->op_type == OP_PADANY) {
5286 o->op_type = OP_PADAV;
5287 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5290 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5291 && ckWARN(WARN_DEPRECATED)) {
5292 Perl_warner(aTHX_ WARN_DEPRECATED,
5293 "Using an array as a reference is deprecated");
5295 return newUNOP(OP_RV2AV, 0, scalar(o));
5299 Perl_newGVREF(pTHX_ I32 type, OP *o)
5301 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5302 return newUNOP(OP_NULL, 0, o);
5303 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5307 Perl_newHVREF(pTHX_ OP *o)
5309 if (o->op_type == OP_PADANY) {
5310 o->op_type = OP_PADHV;
5311 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5314 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5315 && ckWARN(WARN_DEPRECATED)) {
5316 Perl_warner(aTHX_ WARN_DEPRECATED,
5317 "Using a hash as a reference is deprecated");
5319 return newUNOP(OP_RV2HV, 0, scalar(o));
5323 Perl_oopsCV(pTHX_ OP *o)
5325 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5331 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5333 return newUNOP(OP_RV2CV, flags, scalar(o));
5337 Perl_newSVREF(pTHX_ OP *o)
5339 if (o->op_type == OP_PADANY) {
5340 o->op_type = OP_PADSV;
5341 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5344 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5345 o->op_flags |= OPpDONE_SVREF;
5348 return newUNOP(OP_RV2SV, 0, scalar(o));
5351 /* Check routines. */
5354 Perl_ck_anoncode(pTHX_ OP *o)
5359 name = NEWSV(1106,0);
5360 sv_upgrade(name, SVt_PVNV);
5361 sv_setpvn(name, "&", 1);
5364 ix = pad_alloc(o->op_type, SVs_PADMY);
5365 av_store(PL_comppad_name, ix, name);
5366 av_store(PL_comppad, ix, cSVOPo->op_sv);
5367 SvPADMY_on(cSVOPo->op_sv);
5368 cSVOPo->op_sv = Nullsv;
5369 cSVOPo->op_targ = ix;
5374 Perl_ck_bitop(pTHX_ OP *o)
5376 o->op_private = PL_hints;
5381 Perl_ck_concat(pTHX_ OP *o)
5383 if (cUNOPo->op_first->op_type == OP_CONCAT)
5384 o->op_flags |= OPf_STACKED;
5389 Perl_ck_spair(pTHX_ OP *o)
5391 if (o->op_flags & OPf_KIDS) {
5394 OPCODE type = o->op_type;
5395 o = modkids(ck_fun(o), type);
5396 kid = cUNOPo->op_first;
5397 newop = kUNOP->op_first->op_sibling;
5399 (newop->op_sibling ||
5400 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5401 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5402 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5406 op_free(kUNOP->op_first);
5407 kUNOP->op_first = newop;
5409 o->op_ppaddr = PL_ppaddr[++o->op_type];
5414 Perl_ck_delete(pTHX_ OP *o)
5418 if (o->op_flags & OPf_KIDS) {
5419 OP *kid = cUNOPo->op_first;
5420 switch (kid->op_type) {
5422 o->op_flags |= OPf_SPECIAL;
5425 o->op_private |= OPpSLICE;
5428 o->op_flags |= OPf_SPECIAL;
5433 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5442 Perl_ck_eof(pTHX_ OP *o)
5444 I32 type = o->op_type;
5446 if (o->op_flags & OPf_KIDS) {
5447 if (cLISTOPo->op_first->op_type == OP_STUB) {
5449 o = newUNOP(type, OPf_SPECIAL,
5450 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5458 Perl_ck_eval(pTHX_ OP *o)
5460 PL_hints |= HINT_BLOCK_SCOPE;
5461 if (o->op_flags & OPf_KIDS) {
5462 SVOP *kid = (SVOP*)cUNOPo->op_first;
5465 o->op_flags &= ~OPf_KIDS;
5468 else if (kid->op_type == OP_LINESEQ) {
5471 kid->op_next = o->op_next;
5472 cUNOPo->op_first = 0;
5475 NewOp(1101, enter, 1, LOGOP);
5476 enter->op_type = OP_ENTERTRY;
5477 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5478 enter->op_private = 0;
5480 /* establish postfix order */
5481 enter->op_next = (OP*)enter;
5483 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5484 o->op_type = OP_LEAVETRY;
5485 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5486 enter->op_other = o;
5494 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5496 o->op_targ = (PADOFFSET)PL_hints;
5501 Perl_ck_exit(pTHX_ OP *o)
5504 HV *table = GvHV(PL_hintgv);
5506 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5507 if (svp && *svp && SvTRUE(*svp))
5508 o->op_private |= OPpEXIT_VMSISH;
5515 Perl_ck_exec(pTHX_ OP *o)
5518 if (o->op_flags & OPf_STACKED) {
5520 kid = cUNOPo->op_first->op_sibling;
5521 if (kid->op_type == OP_RV2GV)
5530 Perl_ck_exists(pTHX_ OP *o)
5533 if (o->op_flags & OPf_KIDS) {
5534 OP *kid = cUNOPo->op_first;
5535 if (kid->op_type == OP_ENTERSUB) {
5536 (void) ref(kid, o->op_type);
5537 if (kid->op_type != OP_RV2CV && !PL_error_count)
5538 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5540 o->op_private |= OPpEXISTS_SUB;
5542 else if (kid->op_type == OP_AELEM)
5543 o->op_flags |= OPf_SPECIAL;
5544 else if (kid->op_type != OP_HELEM)
5545 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5554 Perl_ck_gvconst(pTHX_ register OP *o)
5556 o = fold_constants(o);
5557 if (o->op_type == OP_CONST)
5564 Perl_ck_rvconst(pTHX_ register OP *o)
5566 SVOP *kid = (SVOP*)cUNOPo->op_first;
5568 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5569 if (kid->op_type == OP_CONST) {
5573 SV *kidsv = kid->op_sv;
5576 /* Is it a constant from cv_const_sv()? */
5577 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5578 SV *rsv = SvRV(kidsv);
5579 int svtype = SvTYPE(rsv);
5580 char *badtype = Nullch;
5582 switch (o->op_type) {
5584 if (svtype > SVt_PVMG)
5585 badtype = "a SCALAR";
5588 if (svtype != SVt_PVAV)
5589 badtype = "an ARRAY";
5592 if (svtype != SVt_PVHV) {
5593 if (svtype == SVt_PVAV) { /* pseudohash? */
5594 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5595 if (ksv && SvROK(*ksv)
5596 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5605 if (svtype != SVt_PVCV)
5610 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5613 name = SvPV(kidsv, n_a);
5614 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5615 char *badthing = Nullch;
5616 switch (o->op_type) {
5618 badthing = "a SCALAR";
5621 badthing = "an ARRAY";
5624 badthing = "a HASH";
5629 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5633 * This is a little tricky. We only want to add the symbol if we
5634 * didn't add it in the lexer. Otherwise we get duplicate strict
5635 * warnings. But if we didn't add it in the lexer, we must at
5636 * least pretend like we wanted to add it even if it existed before,
5637 * or we get possible typo warnings. OPpCONST_ENTERED says
5638 * whether the lexer already added THIS instance of this symbol.
5640 iscv = (o->op_type == OP_RV2CV) * 2;
5642 gv = gv_fetchpv(name,
5643 iscv | !(kid->op_private & OPpCONST_ENTERED),
5646 : o->op_type == OP_RV2SV
5648 : o->op_type == OP_RV2AV
5650 : o->op_type == OP_RV2HV
5653 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5655 kid->op_type = OP_GV;
5656 SvREFCNT_dec(kid->op_sv);
5658 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5659 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5660 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5662 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5664 kid->op_sv = SvREFCNT_inc(gv);
5666 kid->op_private = 0;
5667 kid->op_ppaddr = PL_ppaddr[OP_GV];
5674 Perl_ck_ftst(pTHX_ OP *o)
5676 I32 type = o->op_type;
5678 if (o->op_flags & OPf_REF) {
5681 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5682 SVOP *kid = (SVOP*)cUNOPo->op_first;
5684 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5686 OP *newop = newGVOP(type, OPf_REF,
5687 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5694 if (type == OP_FTTTY)
5695 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5698 o = newUNOP(type, 0, newDEFSVOP());
5704 Perl_ck_fun(pTHX_ OP *o)
5710 int type = o->op_type;
5711 register I32 oa = PL_opargs[type] >> OASHIFT;
5713 if (o->op_flags & OPf_STACKED) {
5714 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5717 return no_fh_allowed(o);
5720 if (o->op_flags & OPf_KIDS) {
5722 tokid = &cLISTOPo->op_first;
5723 kid = cLISTOPo->op_first;
5724 if (kid->op_type == OP_PUSHMARK ||
5725 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5727 tokid = &kid->op_sibling;
5728 kid = kid->op_sibling;
5730 if (!kid && PL_opargs[type] & OA_DEFGV)
5731 *tokid = kid = newDEFSVOP();
5735 sibl = kid->op_sibling;
5738 /* list seen where single (scalar) arg expected? */
5739 if (numargs == 1 && !(oa >> 4)
5740 && kid->op_type == OP_LIST && type != OP_SCALAR)
5742 return too_many_arguments(o,PL_op_desc[type]);
5755 if ((type == OP_PUSH || type == OP_UNSHIFT)
5756 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5757 Perl_warner(aTHX_ WARN_SYNTAX,
5758 "Useless use of %s with no values",
5761 if (kid->op_type == OP_CONST &&
5762 (kid->op_private & OPpCONST_BARE))
5764 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5765 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5766 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5767 if (ckWARN(WARN_DEPRECATED))
5768 Perl_warner(aTHX_ WARN_DEPRECATED,
5769 "Array @%s missing the @ in argument %"IVdf" of %s()",
5770 name, (IV)numargs, PL_op_desc[type]);
5773 kid->op_sibling = sibl;
5776 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5777 bad_type(numargs, "array", PL_op_desc[type], kid);
5781 if (kid->op_type == OP_CONST &&
5782 (kid->op_private & OPpCONST_BARE))
5784 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5785 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5786 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5787 if (ckWARN(WARN_DEPRECATED))
5788 Perl_warner(aTHX_ WARN_DEPRECATED,
5789 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5790 name, (IV)numargs, PL_op_desc[type]);
5793 kid->op_sibling = sibl;
5796 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5797 bad_type(numargs, "hash", PL_op_desc[type], kid);
5802 OP *newop = newUNOP(OP_NULL, 0, kid);
5803 kid->op_sibling = 0;
5805 newop->op_next = newop;
5807 kid->op_sibling = sibl;
5812 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5813 if (kid->op_type == OP_CONST &&
5814 (kid->op_private & OPpCONST_BARE))
5816 OP *newop = newGVOP(OP_GV, 0,
5817 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5822 else if (kid->op_type == OP_READLINE) {
5823 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5824 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5827 I32 flags = OPf_SPECIAL;
5831 /* is this op a FH constructor? */
5832 if (is_handle_constructor(o,numargs)) {
5833 char *name = Nullch;
5837 /* Set a flag to tell rv2gv to vivify
5838 * need to "prove" flag does not mean something
5839 * else already - NI-S 1999/05/07
5842 if (kid->op_type == OP_PADSV) {
5843 SV **namep = av_fetch(PL_comppad_name,
5845 if (namep && *namep)
5846 name = SvPV(*namep, len);
5848 else if (kid->op_type == OP_RV2SV
5849 && kUNOP->op_first->op_type == OP_GV)
5851 GV *gv = cGVOPx_gv(kUNOP->op_first);
5853 len = GvNAMELEN(gv);
5855 else if (kid->op_type == OP_AELEM
5856 || kid->op_type == OP_HELEM)
5858 name = "__ANONIO__";
5864 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5865 namesv = PL_curpad[targ];
5866 (void)SvUPGRADE(namesv, SVt_PV);
5868 sv_setpvn(namesv, "$", 1);
5869 sv_catpvn(namesv, name, len);
5872 kid->op_sibling = 0;
5873 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5874 kid->op_targ = targ;
5875 kid->op_private |= priv;
5877 kid->op_sibling = sibl;
5883 mod(scalar(kid), type);
5887 tokid = &kid->op_sibling;
5888 kid = kid->op_sibling;
5890 o->op_private |= numargs;
5892 return too_many_arguments(o,OP_DESC(o));
5895 else if (PL_opargs[type] & OA_DEFGV) {
5897 return newUNOP(type, 0, newDEFSVOP());
5901 while (oa & OA_OPTIONAL)
5903 if (oa && oa != OA_LIST)
5904 return too_few_arguments(o,OP_DESC(o));
5910 Perl_ck_glob(pTHX_ OP *o)
5915 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5916 append_elem(OP_GLOB, o, newDEFSVOP());
5918 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5919 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5921 #if !defined(PERL_EXTERNAL_GLOB)
5922 /* XXX this can be tightened up and made more failsafe. */
5926 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5928 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5929 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5930 GvCV(gv) = GvCV(glob_gv);
5931 SvREFCNT_inc((SV*)GvCV(gv));
5932 GvIMPORTED_CV_on(gv);
5935 #endif /* PERL_EXTERNAL_GLOB */
5937 if (gv && GvIMPORTED_CV(gv)) {
5938 append_elem(OP_GLOB, o,
5939 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5940 o->op_type = OP_LIST;
5941 o->op_ppaddr = PL_ppaddr[OP_LIST];
5942 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5943 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5944 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5945 append_elem(OP_LIST, o,
5946 scalar(newUNOP(OP_RV2CV, 0,
5947 newGVOP(OP_GV, 0, gv)))));
5948 o = newUNOP(OP_NULL, 0, ck_subr(o));
5949 o->op_targ = OP_GLOB; /* hint at what it used to be */
5952 gv = newGVgen("main");
5954 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5960 Perl_ck_grep(pTHX_ OP *o)
5964 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5966 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5967 NewOp(1101, gwop, 1, LOGOP);
5969 if (o->op_flags & OPf_STACKED) {
5972 kid = cLISTOPo->op_first->op_sibling;
5973 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5976 kid->op_next = (OP*)gwop;
5977 o->op_flags &= ~OPf_STACKED;
5979 kid = cLISTOPo->op_first->op_sibling;
5980 if (type == OP_MAPWHILE)
5987 kid = cLISTOPo->op_first->op_sibling;
5988 if (kid->op_type != OP_NULL)
5989 Perl_croak(aTHX_ "panic: ck_grep");
5990 kid = kUNOP->op_first;
5992 gwop->op_type = type;
5993 gwop->op_ppaddr = PL_ppaddr[type];
5994 gwop->op_first = listkids(o);
5995 gwop->op_flags |= OPf_KIDS;
5996 gwop->op_private = 1;
5997 gwop->op_other = LINKLIST(kid);
5998 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5999 kid->op_next = (OP*)gwop;
6001 kid = cLISTOPo->op_first->op_sibling;
6002 if (!kid || !kid->op_sibling)
6003 return too_few_arguments(o,OP_DESC(o));
6004 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6005 mod(kid, OP_GREPSTART);
6011 Perl_ck_index(pTHX_ OP *o)
6013 if (o->op_flags & OPf_KIDS) {
6014 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6016 kid = kid->op_sibling; /* get past "big" */
6017 if (kid && kid->op_type == OP_CONST)
6018 fbm_compile(((SVOP*)kid)->op_sv, 0);
6024 Perl_ck_lengthconst(pTHX_ OP *o)
6026 /* XXX length optimization goes here */
6031 Perl_ck_lfun(pTHX_ OP *o)
6033 OPCODE type = o->op_type;
6034 return modkids(ck_fun(o), type);
6038 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6040 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6041 switch (cUNOPo->op_first->op_type) {
6043 /* This is needed for
6044 if (defined %stash::)
6045 to work. Do not break Tk.
6047 break; /* Globals via GV can be undef */
6049 case OP_AASSIGN: /* Is this a good idea? */
6050 Perl_warner(aTHX_ WARN_DEPRECATED,
6051 "defined(@array) is deprecated");
6052 Perl_warner(aTHX_ WARN_DEPRECATED,
6053 "\t(Maybe you should just omit the defined()?)\n");
6056 /* This is needed for
6057 if (defined %stash::)
6058 to work. Do not break Tk.
6060 break; /* Globals via GV can be undef */
6062 Perl_warner(aTHX_ WARN_DEPRECATED,
6063 "defined(%%hash) is deprecated");
6064 Perl_warner(aTHX_ WARN_DEPRECATED,
6065 "\t(Maybe you should just omit the defined()?)\n");
6076 Perl_ck_rfun(pTHX_ OP *o)
6078 OPCODE type = o->op_type;
6079 return refkids(ck_fun(o), type);
6083 Perl_ck_listiob(pTHX_ OP *o)
6087 kid = cLISTOPo->op_first;
6090 kid = cLISTOPo->op_first;
6092 if (kid->op_type == OP_PUSHMARK)
6093 kid = kid->op_sibling;
6094 if (kid && o->op_flags & OPf_STACKED)
6095 kid = kid->op_sibling;
6096 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6097 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6098 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6099 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6100 cLISTOPo->op_first->op_sibling = kid;
6101 cLISTOPo->op_last = kid;
6102 kid = kid->op_sibling;
6107 append_elem(o->op_type, o, newDEFSVOP());
6113 Perl_ck_sassign(pTHX_ OP *o)
6115 OP *kid = cLISTOPo->op_first;
6116 /* has a disposable target? */
6117 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6118 && !(kid->op_flags & OPf_STACKED)
6119 /* Cannot steal the second time! */
6120 && !(kid->op_private & OPpTARGET_MY))
6122 OP *kkid = kid->op_sibling;
6124 /* Can just relocate the target. */
6125 if (kkid && kkid->op_type == OP_PADSV
6126 && !(kkid->op_private & OPpLVAL_INTRO))
6128 kid->op_targ = kkid->op_targ;
6130 /* Now we do not need PADSV and SASSIGN. */
6131 kid->op_sibling = o->op_sibling; /* NULL */
6132 cLISTOPo->op_first = NULL;
6135 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6143 Perl_ck_match(pTHX_ OP *o)
6145 o->op_private |= OPpRUNTIME;
6150 Perl_ck_method(pTHX_ OP *o)
6152 OP *kid = cUNOPo->op_first;
6153 if (kid->op_type == OP_CONST) {
6154 SV* sv = kSVOP->op_sv;
6155 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6157 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6158 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6161 kSVOP->op_sv = Nullsv;
6163 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6172 Perl_ck_null(pTHX_ OP *o)
6178 Perl_ck_open(pTHX_ OP *o)
6180 HV *table = GvHV(PL_hintgv);
6184 svp = hv_fetch(table, "open_IN", 7, FALSE);
6186 mode = mode_from_discipline(*svp);
6187 if (mode & O_BINARY)
6188 o->op_private |= OPpOPEN_IN_RAW;
6189 else if (mode & O_TEXT)
6190 o->op_private |= OPpOPEN_IN_CRLF;
6193 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6195 mode = mode_from_discipline(*svp);
6196 if (mode & O_BINARY)
6197 o->op_private |= OPpOPEN_OUT_RAW;
6198 else if (mode & O_TEXT)
6199 o->op_private |= OPpOPEN_OUT_CRLF;
6202 if (o->op_type == OP_BACKTICK)
6208 Perl_ck_repeat(pTHX_ OP *o)
6210 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6211 o->op_private |= OPpREPEAT_DOLIST;
6212 cBINOPo->op_first = force_list(cBINOPo->op_first);
6220 Perl_ck_require(pTHX_ OP *o)
6224 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6225 SVOP *kid = (SVOP*)cUNOPo->op_first;
6227 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6229 for (s = SvPVX(kid->op_sv); *s; s++) {
6230 if (*s == ':' && s[1] == ':') {
6232 Move(s+2, s+1, strlen(s+2)+1, char);
6233 --SvCUR(kid->op_sv);
6236 if (SvREADONLY(kid->op_sv)) {
6237 SvREADONLY_off(kid->op_sv);
6238 sv_catpvn(kid->op_sv, ".pm", 3);
6239 SvREADONLY_on(kid->op_sv);
6242 sv_catpvn(kid->op_sv, ".pm", 3);
6246 /* handle override, if any */
6247 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6248 if (!(gv && GvIMPORTED_CV(gv)))
6249 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6251 if (gv && GvIMPORTED_CV(gv)) {
6252 OP *kid = cUNOPo->op_first;
6253 cUNOPo->op_first = 0;
6255 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6256 append_elem(OP_LIST, kid,
6257 scalar(newUNOP(OP_RV2CV, 0,
6266 Perl_ck_return(pTHX_ OP *o)
6269 if (CvLVALUE(PL_compcv)) {
6270 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6271 mod(kid, OP_LEAVESUBLV);
6278 Perl_ck_retarget(pTHX_ OP *o)
6280 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6287 Perl_ck_select(pTHX_ OP *o)
6290 if (o->op_flags & OPf_KIDS) {
6291 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6292 if (kid && kid->op_sibling) {
6293 o->op_type = OP_SSELECT;
6294 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6296 return fold_constants(o);
6300 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6301 if (kid && kid->op_type == OP_RV2GV)
6302 kid->op_private &= ~HINT_STRICT_REFS;
6307 Perl_ck_shift(pTHX_ OP *o)
6309 I32 type = o->op_type;
6311 if (!(o->op_flags & OPf_KIDS)) {
6316 if (!CvUNIQUE(PL_compcv)) {
6317 argop = newOP(OP_PADAV, OPf_REF);
6318 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6321 argop = newUNOP(OP_RV2AV, 0,
6322 scalar(newGVOP(OP_GV, 0,
6323 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6326 argop = newUNOP(OP_RV2AV, 0,
6327 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6328 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6329 #endif /* USE_THREADS */
6330 return newUNOP(type, 0, scalar(argop));
6332 return scalar(modkids(ck_fun(o), type));
6336 Perl_ck_sort(pTHX_ OP *o)
6340 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6342 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6343 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6345 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6347 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6349 if (kid->op_type == OP_SCOPE) {
6353 else if (kid->op_type == OP_LEAVE) {
6354 if (o->op_type == OP_SORT) {
6355 op_null(kid); /* wipe out leave */
6358 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6359 if (k->op_next == kid)
6361 /* don't descend into loops */
6362 else if (k->op_type == OP_ENTERLOOP
6363 || k->op_type == OP_ENTERITER)
6365 k = cLOOPx(k)->op_lastop;
6370 kid->op_next = 0; /* just disconnect the leave */
6371 k = kLISTOP->op_first;
6376 if (o->op_type == OP_SORT) {
6377 /* provide scalar context for comparison function/block */
6383 o->op_flags |= OPf_SPECIAL;
6385 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6388 firstkid = firstkid->op_sibling;
6391 /* provide list context for arguments */
6392 if (o->op_type == OP_SORT)
6399 S_simplify_sort(pTHX_ OP *o)
6401 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6405 if (!(o->op_flags & OPf_STACKED))
6407 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6408 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6409 kid = kUNOP->op_first; /* get past null */
6410 if (kid->op_type != OP_SCOPE)
6412 kid = kLISTOP->op_last; /* get past scope */
6413 switch(kid->op_type) {
6421 k = kid; /* remember this node*/
6422 if (kBINOP->op_first->op_type != OP_RV2SV)
6424 kid = kBINOP->op_first; /* get past cmp */
6425 if (kUNOP->op_first->op_type != OP_GV)
6427 kid = kUNOP->op_first; /* get past rv2sv */
6429 if (GvSTASH(gv) != PL_curstash)
6431 if (strEQ(GvNAME(gv), "a"))
6433 else if (strEQ(GvNAME(gv), "b"))
6437 kid = k; /* back to cmp */
6438 if (kBINOP->op_last->op_type != OP_RV2SV)
6440 kid = kBINOP->op_last; /* down to 2nd arg */
6441 if (kUNOP->op_first->op_type != OP_GV)
6443 kid = kUNOP->op_first; /* get past rv2sv */
6445 if (GvSTASH(gv) != PL_curstash
6447 ? strNE(GvNAME(gv), "a")
6448 : strNE(GvNAME(gv), "b")))
6450 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6452 o->op_private |= OPpSORT_REVERSE;
6453 if (k->op_type == OP_NCMP)
6454 o->op_private |= OPpSORT_NUMERIC;
6455 if (k->op_type == OP_I_NCMP)
6456 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6457 kid = cLISTOPo->op_first->op_sibling;
6458 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6459 op_free(kid); /* then delete it */
6463 Perl_ck_split(pTHX_ OP *o)
6467 if (o->op_flags & OPf_STACKED)
6468 return no_fh_allowed(o);
6470 kid = cLISTOPo->op_first;
6471 if (kid->op_type != OP_NULL)
6472 Perl_croak(aTHX_ "panic: ck_split");
6473 kid = kid->op_sibling;
6474 op_free(cLISTOPo->op_first);
6475 cLISTOPo->op_first = kid;
6477 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6478 cLISTOPo->op_last = kid; /* There was only one element previously */
6481 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6482 OP *sibl = kid->op_sibling;
6483 kid->op_sibling = 0;
6484 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6485 if (cLISTOPo->op_first == cLISTOPo->op_last)
6486 cLISTOPo->op_last = kid;
6487 cLISTOPo->op_first = kid;
6488 kid->op_sibling = sibl;
6491 kid->op_type = OP_PUSHRE;
6492 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6495 if (!kid->op_sibling)
6496 append_elem(OP_SPLIT, o, newDEFSVOP());
6498 kid = kid->op_sibling;
6501 if (!kid->op_sibling)
6502 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6504 kid = kid->op_sibling;
6507 if (kid->op_sibling)
6508 return too_many_arguments(o,OP_DESC(o));
6514 Perl_ck_join(pTHX_ OP *o)
6516 if (ckWARN(WARN_SYNTAX)) {
6517 OP *kid = cLISTOPo->op_first->op_sibling;
6518 if (kid && kid->op_type == OP_MATCH) {
6519 char *pmstr = "STRING";
6520 if (PM_GETRE(kPMOP))
6521 pmstr = PM_GETRE(kPMOP)->precomp;
6522 Perl_warner(aTHX_ WARN_SYNTAX,
6523 "/%s/ should probably be written as \"%s\"",
6531 Perl_ck_subr(pTHX_ OP *o)
6533 OP *prev = ((cUNOPo->op_first->op_sibling)
6534 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6535 OP *o2 = prev->op_sibling;
6544 o->op_private |= OPpENTERSUB_HASTARG;
6545 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6546 if (cvop->op_type == OP_RV2CV) {
6548 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6549 op_null(cvop); /* disable rv2cv */
6550 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6551 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6552 GV *gv = cGVOPx_gv(tmpop);
6555 tmpop->op_private |= OPpEARLY_CV;
6556 else if (SvPOK(cv)) {
6557 namegv = CvANON(cv) ? gv : CvGV(cv);
6558 proto = SvPV((SV*)cv, n_a);
6562 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6563 if (o2->op_type == OP_CONST)
6564 o2->op_private &= ~OPpCONST_STRICT;
6565 else if (o2->op_type == OP_LIST) {
6566 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6567 if (o && o->op_type == OP_CONST)
6568 o->op_private &= ~OPpCONST_STRICT;
6571 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6572 if (PERLDB_SUB && PL_curstash != PL_debstash)
6573 o->op_private |= OPpENTERSUB_DB;
6574 while (o2 != cvop) {
6578 return too_many_arguments(o, gv_ename(namegv));
6596 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6598 arg == 1 ? "block or sub {}" : "sub {}",
6599 gv_ename(namegv), o2);
6602 /* '*' allows any scalar type, including bareword */
6605 if (o2->op_type == OP_RV2GV)
6606 goto wrapref; /* autoconvert GLOB -> GLOBref */
6607 else if (o2->op_type == OP_CONST)
6608 o2->op_private &= ~OPpCONST_STRICT;
6609 else if (o2->op_type == OP_ENTERSUB) {
6610 /* accidental subroutine, revert to bareword */
6611 OP *gvop = ((UNOP*)o2)->op_first;
6612 if (gvop && gvop->op_type == OP_NULL) {
6613 gvop = ((UNOP*)gvop)->op_first;
6615 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6618 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6619 (gvop = ((UNOP*)gvop)->op_first) &&
6620 gvop->op_type == OP_GV)
6622 GV *gv = cGVOPx_gv(gvop);
6623 OP *sibling = o2->op_sibling;
6624 SV *n = newSVpvn("",0);
6626 gv_fullname3(n, gv, "");
6627 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6628 sv_chop(n, SvPVX(n)+6);
6629 o2 = newSVOP(OP_CONST, 0, n);
6630 prev->op_sibling = o2;
6631 o2->op_sibling = sibling;
6643 if (o2->op_type != OP_RV2GV)
6644 bad_type(arg, "symbol", gv_ename(namegv), o2);
6647 if (o2->op_type != OP_ENTERSUB)
6648 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6651 if (o2->op_type != OP_RV2SV
6652 && o2->op_type != OP_PADSV
6653 && o2->op_type != OP_HELEM
6654 && o2->op_type != OP_AELEM
6655 && o2->op_type != OP_THREADSV)
6657 bad_type(arg, "scalar", gv_ename(namegv), o2);
6661 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6662 bad_type(arg, "array", gv_ename(namegv), o2);
6665 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6666 bad_type(arg, "hash", gv_ename(namegv), o2);
6670 OP* sib = kid->op_sibling;
6671 kid->op_sibling = 0;
6672 o2 = newUNOP(OP_REFGEN, 0, kid);
6673 o2->op_sibling = sib;
6674 prev->op_sibling = o2;
6685 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6686 gv_ename(namegv), SvPV((SV*)cv, n_a));
6691 mod(o2, OP_ENTERSUB);
6693 o2 = o2->op_sibling;
6695 if (proto && !optional &&
6696 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6697 return too_few_arguments(o, gv_ename(namegv));
6702 Perl_ck_svconst(pTHX_ OP *o)
6704 SvREADONLY_on(cSVOPo->op_sv);
6709 Perl_ck_trunc(pTHX_ OP *o)
6711 if (o->op_flags & OPf_KIDS) {
6712 SVOP *kid = (SVOP*)cUNOPo->op_first;
6714 if (kid->op_type == OP_NULL)
6715 kid = (SVOP*)kid->op_sibling;
6716 if (kid && kid->op_type == OP_CONST &&
6717 (kid->op_private & OPpCONST_BARE))
6719 o->op_flags |= OPf_SPECIAL;
6720 kid->op_private &= ~OPpCONST_STRICT;
6727 Perl_ck_substr(pTHX_ OP *o)
6730 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6731 OP *kid = cLISTOPo->op_first;
6733 if (kid->op_type == OP_NULL)
6734 kid = kid->op_sibling;
6736 kid->op_flags |= OPf_MOD;
6742 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6745 Perl_peep(pTHX_ register OP *o)
6747 register OP* oldop = 0;
6750 if (!o || o->op_seq)
6754 SAVEVPTR(PL_curcop);
6755 for (; o; o = o->op_next) {
6761 switch (o->op_type) {
6765 PL_curcop = ((COP*)o); /* for warnings */
6766 o->op_seq = PL_op_seqmax++;
6770 if (cSVOPo->op_private & OPpCONST_STRICT)
6771 no_bareword_allowed(o);
6773 /* Relocate sv to the pad for thread safety.
6774 * Despite being a "constant", the SV is written to,
6775 * for reference counts, sv_upgrade() etc. */
6777 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6778 if (SvPADTMP(cSVOPo->op_sv)) {
6779 /* If op_sv is already a PADTMP then it is being used by
6780 * some pad, so make a copy. */
6781 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6782 SvREADONLY_on(PL_curpad[ix]);
6783 SvREFCNT_dec(cSVOPo->op_sv);
6786 SvREFCNT_dec(PL_curpad[ix]);
6787 SvPADTMP_on(cSVOPo->op_sv);
6788 PL_curpad[ix] = cSVOPo->op_sv;
6789 /* XXX I don't know how this isn't readonly already. */
6790 SvREADONLY_on(PL_curpad[ix]);
6792 cSVOPo->op_sv = Nullsv;
6796 o->op_seq = PL_op_seqmax++;
6800 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6801 if (o->op_next->op_private & OPpTARGET_MY) {
6802 if (o->op_flags & OPf_STACKED) /* chained concats */
6803 goto ignore_optimization;
6805 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6806 o->op_targ = o->op_next->op_targ;
6807 o->op_next->op_targ = 0;
6808 o->op_private |= OPpTARGET_MY;
6811 op_null(o->op_next);
6813 ignore_optimization:
6814 o->op_seq = PL_op_seqmax++;
6817 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6818 o->op_seq = PL_op_seqmax++;
6819 break; /* Scalar stub must produce undef. List stub is noop */
6823 if (o->op_targ == OP_NEXTSTATE
6824 || o->op_targ == OP_DBSTATE
6825 || o->op_targ == OP_SETSTATE)
6827 PL_curcop = ((COP*)o);
6829 /* XXX: We avoid setting op_seq here to prevent later calls
6830 to peep() from mistakenly concluding that optimisation
6831 has already occurred. This doesn't fix the real problem,
6832 though (See 20010220.007). AMS 20010719 */
6833 if (oldop && o->op_next) {
6834 oldop->op_next = o->op_next;
6842 if (oldop && o->op_next) {
6843 oldop->op_next = o->op_next;
6846 o->op_seq = PL_op_seqmax++;
6850 if (o->op_next->op_type == OP_RV2SV) {
6851 if (!(o->op_next->op_private & OPpDEREF)) {
6852 op_null(o->op_next);
6853 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6855 o->op_next = o->op_next->op_next;
6856 o->op_type = OP_GVSV;
6857 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6860 else if (o->op_next->op_type == OP_RV2AV) {
6861 OP* pop = o->op_next->op_next;
6863 if (pop->op_type == OP_CONST &&
6864 (PL_op = pop->op_next) &&
6865 pop->op_next->op_type == OP_AELEM &&
6866 !(pop->op_next->op_private &
6867 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6868 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6873 op_null(o->op_next);
6874 op_null(pop->op_next);
6876 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6877 o->op_next = pop->op_next->op_next;
6878 o->op_type = OP_AELEMFAST;
6879 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6880 o->op_private = (U8)i;
6885 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6887 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6888 /* XXX could check prototype here instead of just carping */
6889 SV *sv = sv_newmortal();
6890 gv_efullname3(sv, gv, Nullch);
6891 Perl_warner(aTHX_ WARN_PROTOTYPE,
6892 "%s() called too early to check prototype",
6896 else if (o->op_next->op_type == OP_READLINE
6897 && o->op_next->op_next->op_type == OP_CONCAT
6898 && (o->op_next->op_next->op_flags & OPf_STACKED))
6900 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010811 */
6901 o->op_next->op_type = OP_RCATLINE;
6902 o->op_next->op_flags |= OPf_STACKED;
6903 op_null(o->op_next->op_next);
6906 o->op_seq = PL_op_seqmax++;
6917 o->op_seq = PL_op_seqmax++;
6918 while (cLOGOP->op_other->op_type == OP_NULL)
6919 cLOGOP->op_other = cLOGOP->op_other->op_next;
6920 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6925 o->op_seq = PL_op_seqmax++;
6926 while (cLOOP->op_redoop->op_type == OP_NULL)
6927 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6928 peep(cLOOP->op_redoop);
6929 while (cLOOP->op_nextop->op_type == OP_NULL)
6930 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6931 peep(cLOOP->op_nextop);
6932 while (cLOOP->op_lastop->op_type == OP_NULL)
6933 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6934 peep(cLOOP->op_lastop);
6940 o->op_seq = PL_op_seqmax++;
6941 while (cPMOP->op_pmreplstart &&
6942 cPMOP->op_pmreplstart->op_type == OP_NULL)
6943 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6944 peep(cPMOP->op_pmreplstart);
6948 o->op_seq = PL_op_seqmax++;
6949 if (ckWARN(WARN_SYNTAX) && o->op_next
6950 && o->op_next->op_type == OP_NEXTSTATE) {
6951 if (o->op_next->op_sibling &&
6952 o->op_next->op_sibling->op_type != OP_EXIT &&
6953 o->op_next->op_sibling->op_type != OP_WARN &&
6954 o->op_next->op_sibling->op_type != OP_DIE) {
6955 line_t oldline = CopLINE(PL_curcop);
6957 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6958 Perl_warner(aTHX_ WARN_EXEC,
6959 "Statement unlikely to be reached");
6960 Perl_warner(aTHX_ WARN_EXEC,
6961 "\t(Maybe you meant system() when you said exec()?)\n");
6962 CopLINE_set(PL_curcop, oldline);
6971 SV **svp, **indsvp, *sv;
6976 o->op_seq = PL_op_seqmax++;
6978 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6981 /* Make the CONST have a shared SV */
6982 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6983 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6984 key = SvPV(sv, keylen);
6985 lexname = newSVpvn_share(key,
6986 SvUTF8(sv) ? -(I32)keylen : keylen,
6992 if ((o->op_private & (OPpLVAL_INTRO)))
6995 rop = (UNOP*)((BINOP*)o)->op_first;
6996 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6998 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6999 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7001 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7002 if (!fields || !GvHV(*fields))
7004 key = SvPV(*svp, keylen);
7005 indsvp = hv_fetch(GvHV(*fields), key,
7006 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7008 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7009 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7011 ind = SvIV(*indsvp);
7013 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7014 rop->op_type = OP_RV2AV;
7015 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7016 o->op_type = OP_AELEM;
7017 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7019 if (SvREADONLY(*svp))
7021 SvFLAGS(sv) |= (SvFLAGS(*svp)
7022 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7032 SV **svp, **indsvp, *sv;
7036 SVOP *first_key_op, *key_op;
7038 o->op_seq = PL_op_seqmax++;
7039 if ((o->op_private & (OPpLVAL_INTRO))
7040 /* I bet there's always a pushmark... */
7041 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7042 /* hmmm, no optimization if list contains only one key. */
7044 rop = (UNOP*)((LISTOP*)o)->op_last;
7045 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7047 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7048 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7050 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7051 if (!fields || !GvHV(*fields))
7053 /* Again guessing that the pushmark can be jumped over.... */
7054 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7055 ->op_first->op_sibling;
7056 /* Check that the key list contains only constants. */
7057 for (key_op = first_key_op; key_op;
7058 key_op = (SVOP*)key_op->op_sibling)
7059 if (key_op->op_type != OP_CONST)
7063 rop->op_type = OP_RV2AV;
7064 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7065 o->op_type = OP_ASLICE;
7066 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7067 for (key_op = first_key_op; key_op;
7068 key_op = (SVOP*)key_op->op_sibling) {
7069 svp = cSVOPx_svp(key_op);
7070 key = SvPV(*svp, keylen);
7071 indsvp = hv_fetch(GvHV(*fields), key,
7072 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7074 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7075 "in variable %s of type %s",
7076 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7078 ind = SvIV(*indsvp);
7080 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7082 if (SvREADONLY(*svp))
7084 SvFLAGS(sv) |= (SvFLAGS(*svp)
7085 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7093 o->op_seq = PL_op_seqmax++;
7101 #ifdef PERL_CUSTOM_OPS
7102 char* custom_op_name(pTHX_ OP* o)
7104 IV index = PTR2IV(o->op_ppaddr);
7108 if (!PL_custom_op_names) /* This probably shouldn't happen */
7109 return PL_op_name[OP_CUSTOM];
7111 keysv = sv_2mortal(newSViv(index));
7113 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7115 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7117 return SvPV_nolen(HeVAL(he));
7120 char* custom_op_desc(pTHX_ OP* o)
7122 IV index = PTR2IV(o->op_ppaddr);
7126 if (!PL_custom_op_descs)
7127 return PL_op_desc[OP_CUSTOM];
7129 keysv = sv_2mortal(newSViv(index));
7131 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7133 return PL_op_desc[OP_CUSTOM];
7135 return SvPV_nolen(HeVAL(he));
7141 /* Efficient sub that returns a constant scalar value. */
7143 const_sv_xsub(pTHXo_ CV* cv)
7148 Perl_croak(aTHX_ "usage: %s::%s()",
7149 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7153 ST(0) = (SV*)XSANY.any_ptr;