3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 /* #define PL_OP_SLAB_ALLOC */
25 #ifdef PL_OP_SLAB_ALLOC
26 #define SLAB_SIZE 8192
27 static char *PL_OpPtr = NULL;
28 static int PL_OpSpace = 0;
29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
30 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
32 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
36 S_Slab_Alloc(pTHX_ int m, size_t sz)
38 Newz(m,PL_OpPtr,SLAB_SIZE,char);
39 PL_OpSpace = SLAB_SIZE - sz;
40 return PL_OpPtr += PL_OpSpace;
44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
47 * In the following definition, the ", Nullop" is just to make the compiler
48 * think the expression is of the right type: croak actually does a Siglongjmp.
50 #define CHECKOP(type,o) \
51 ((PL_op_mask && PL_op_mask[type]) \
52 ? ( op_free((OP*)o), \
53 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
55 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
57 #define PAD_MAX 999999999
58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
61 S_gv_ename(pTHX_ GV *gv)
64 SV* tmpsv = sv_newmortal();
65 gv_efullname3(tmpsv, gv, Nullch);
66 return SvPV(tmpsv,n_a);
70 S_no_fh_allowed(pTHX_ OP *o)
72 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
73 PL_op_desc[o->op_type]));
78 S_too_few_arguments(pTHX_ OP *o, char *name)
80 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
85 S_too_many_arguments(pTHX_ OP *o, char *name)
87 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
94 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
95 (int)n, name, t, PL_op_desc[kid->op_type]));
99 S_no_bareword_allowed(pTHX_ OP *o)
101 qerror(Perl_mess(aTHX_
102 "Bareword \"%s\" not allowed while \"strict subs\" in use",
103 SvPV_nolen(cSVOPo_sv)));
107 S_trlist_upgrade(pTHX_ U8** sp, U8** ep)
113 Newz(801, d, (e - s) * 2, U8);
117 if (NATIVE_IS_INVARIANT(*s) || NATIVE_TO_UTF(*s) == 0xff)
120 U8 c = NATIVE_TO_ASCII(*s++);
121 *d++ = UTF8_EIGHT_BIT_HI(c);
122 *d++ = UTF8_EIGHT_BIT_LO(c);
130 /* "register" allocation */
133 Perl_pad_allocmy(pTHX_ char *name)
138 if (!(PL_in_my == KEY_our ||
140 (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
141 (name[1] == '_' && (int)strlen(name) > 2)))
143 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
144 /* 1999-02-27 mjd@plover.com */
146 p = strchr(name, '\0');
147 /* The next block assumes the buffer is at least 205 chars
148 long. At present, it's always at least 256 chars. */
150 strcpy(name+200, "...");
156 /* Move everything else down one character */
157 for (; p-name > 2; p--)
159 name[2] = toCTRL(name[1]);
162 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
164 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
165 SV **svp = AvARRAY(PL_comppad_name);
166 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
167 PADOFFSET top = AvFILLp(PL_comppad_name);
168 for (off = top; off > PL_comppad_name_floor; off--) {
170 && sv != &PL_sv_undef
171 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
172 && (PL_in_my != KEY_our
173 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
174 && strEQ(name, SvPVX(sv)))
176 Perl_warner(aTHX_ WARN_MISC,
177 "\"%s\" variable %s masks earlier declaration in same %s",
178 (PL_in_my == KEY_our ? "our" : "my"),
180 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
185 if (PL_in_my == KEY_our) {
188 && sv != &PL_sv_undef
189 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
190 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
191 && strEQ(name, SvPVX(sv)))
193 Perl_warner(aTHX_ WARN_MISC,
194 "\"our\" variable %s redeclared", name);
195 Perl_warner(aTHX_ WARN_MISC,
196 "\t(Did you mean \"local\" instead of \"our\"?)\n");
199 } while ( off-- > 0 );
202 off = pad_alloc(OP_PADSV, SVs_PADMY);
204 sv_upgrade(sv, SVt_PVNV);
206 if (PL_in_my_stash) {
208 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
209 name, PL_in_my == KEY_our ? "our" : "my"));
211 (void)SvUPGRADE(sv, SVt_PVMG);
212 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
215 if (PL_in_my == KEY_our) {
216 (void)SvUPGRADE(sv, SVt_PVGV);
217 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
218 SvFLAGS(sv) |= SVpad_OUR;
220 av_store(PL_comppad_name, off, sv);
221 SvNVX(sv) = (NV)PAD_MAX;
222 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
223 if (!PL_min_intro_pending)
224 PL_min_intro_pending = off;
225 PL_max_intro_pending = off;
227 av_store(PL_comppad, off, (SV*)newAV());
228 else if (*name == '%')
229 av_store(PL_comppad, off, (SV*)newHV());
230 SvPADMY_on(PL_curpad[off]);
235 S_pad_addlex(pTHX_ SV *proto_namesv)
237 SV *namesv = NEWSV(1103,0);
238 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
239 sv_upgrade(namesv, SVt_PVNV);
240 sv_setpv(namesv, SvPVX(proto_namesv));
241 av_store(PL_comppad_name, newoff, namesv);
242 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
243 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
244 SvFAKE_on(namesv); /* A ref, not a real var */
245 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
246 SvFLAGS(namesv) |= SVpad_OUR;
247 (void)SvUPGRADE(namesv, SVt_PVGV);
248 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
250 if (SvOBJECT(proto_namesv)) { /* A typed var */
252 (void)SvUPGRADE(namesv, SVt_PVMG);
253 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
259 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
262 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
263 I32 cx_ix, I32 saweval, U32 flags)
269 register PERL_CONTEXT *cx;
271 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
272 AV *curlist = CvPADLIST(cv);
273 SV **svp = av_fetch(curlist, 0, FALSE);
276 if (!svp || *svp == &PL_sv_undef)
279 svp = AvARRAY(curname);
280 for (off = AvFILLp(curname); off > 0; off--) {
281 if ((sv = svp[off]) &&
282 sv != &PL_sv_undef &&
284 seq > I_32(SvNVX(sv)) &&
285 strEQ(SvPVX(sv), name))
296 return 0; /* don't clone from inactive stack frame */
300 oldpad = (AV*)AvARRAY(curlist)[depth];
301 oldsv = *av_fetch(oldpad, off, TRUE);
302 if (!newoff) { /* Not a mere clone operation. */
303 newoff = pad_addlex(sv);
304 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
305 /* "It's closures all the way down." */
306 CvCLONE_on(PL_compcv);
308 if (CvANON(PL_compcv))
309 oldsv = Nullsv; /* no need to keep ref */
314 bcv && bcv != cv && !CvCLONE(bcv);
315 bcv = CvOUTSIDE(bcv))
318 /* install the missing pad entry in intervening
319 * nested subs and mark them cloneable.
320 * XXX fix pad_foo() to not use globals */
321 AV *ocomppad_name = PL_comppad_name;
322 AV *ocomppad = PL_comppad;
323 SV **ocurpad = PL_curpad;
324 AV *padlist = CvPADLIST(bcv);
325 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
326 PL_comppad = (AV*)AvARRAY(padlist)[1];
327 PL_curpad = AvARRAY(PL_comppad);
329 PL_comppad_name = ocomppad_name;
330 PL_comppad = ocomppad;
335 if (ckWARN(WARN_CLOSURE)
336 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
338 Perl_warner(aTHX_ WARN_CLOSURE,
339 "Variable \"%s\" may be unavailable",
347 else if (!CvUNIQUE(PL_compcv)) {
348 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
349 && !(SvFLAGS(sv) & SVpad_OUR))
351 Perl_warner(aTHX_ WARN_CLOSURE,
352 "Variable \"%s\" will not stay shared", name);
356 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
362 if (flags & FINDLEX_NOSEARCH)
365 /* Nothing in current lexical context--try eval's context, if any.
366 * This is necessary to let the perldb get at lexically scoped variables.
367 * XXX This will also probably interact badly with eval tree caching.
370 for (i = cx_ix; i >= 0; i--) {
372 switch (CxTYPE(cx)) {
374 if (i == 0 && saweval) {
375 seq = cxstack[saweval].blk_oldcop->cop_seq;
376 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
380 switch (cx->blk_eval.old_op_type) {
387 /* require/do must have their own scope */
396 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
397 saweval = i; /* so we know where we were called from */
400 seq = cxstack[saweval].blk_oldcop->cop_seq;
401 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
409 Perl_pad_findmy(pTHX_ char *name)
414 SV **svp = AvARRAY(PL_comppad_name);
415 U32 seq = PL_cop_seqmax;
421 * Special case to get lexical (and hence per-thread) @_.
422 * XXX I need to find out how to tell at parse-time whether use
423 * of @_ should refer to a lexical (from a sub) or defgv (global
424 * scope and maybe weird sub-ish things like formats). See
425 * startsub in perly.y. It's possible that @_ could be lexical
426 * (at least from subs) even in non-threaded perl.
428 if (strEQ(name, "@_"))
429 return 0; /* success. (NOT_IN_PAD indicates failure) */
430 #endif /* USE_THREADS */
432 /* The one we're looking for is probably just before comppad_name_fill. */
433 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
434 if ((sv = svp[off]) &&
435 sv != &PL_sv_undef &&
438 seq > I_32(SvNVX(sv)))) &&
439 strEQ(SvPVX(sv), name))
441 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
442 return (PADOFFSET)off;
443 pendoff = off; /* this pending def. will override import */
447 outside = CvOUTSIDE(PL_compcv);
449 /* Check if if we're compiling an eval'', and adjust seq to be the
450 * eval's seq number. This depends on eval'' having a non-null
451 * CvOUTSIDE() while it is being compiled. The eval'' itself is
452 * identified by CvEVAL being true and CvGV being null. */
453 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
454 cx = &cxstack[cxstack_ix];
456 seq = cx->blk_oldcop->cop_seq;
459 /* See if it's in a nested scope */
460 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
462 /* If there is a pending local definition, this new alias must die */
464 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
465 return off; /* pad_findlex returns 0 for failure...*/
467 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
471 Perl_pad_leavemy(pTHX_ I32 fill)
474 SV **svp = AvARRAY(PL_comppad_name);
476 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
477 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
478 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
479 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
482 /* "Deintroduce" my variables that are leaving with this scope. */
483 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
484 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
485 SvIVX(sv) = PL_cop_seqmax;
490 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
495 if (AvARRAY(PL_comppad) != PL_curpad)
496 Perl_croak(aTHX_ "panic: pad_alloc");
497 if (PL_pad_reset_pending)
499 if (tmptype & SVs_PADMY) {
501 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
502 } while (SvPADBUSY(sv)); /* need a fresh one */
503 retval = AvFILLp(PL_comppad);
506 SV **names = AvARRAY(PL_comppad_name);
507 SSize_t names_fill = AvFILLp(PL_comppad_name);
510 * "foreach" index vars temporarily become aliases to non-"my"
511 * values. Thus we must skip, not just pad values that are
512 * marked as current pad values, but also those with names.
514 if (++PL_padix <= names_fill &&
515 (sv = names[PL_padix]) && sv != &PL_sv_undef)
517 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
518 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
519 !IS_PADGV(sv) && !IS_PADCONST(sv))
524 SvFLAGS(sv) |= tmptype;
525 PL_curpad = AvARRAY(PL_comppad);
527 DEBUG_X(PerlIO_printf(Perl_debug_log,
528 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
529 PTR2UV(thr), PTR2UV(PL_curpad),
530 (long) retval, PL_op_name[optype]));
532 DEBUG_X(PerlIO_printf(Perl_debug_log,
533 "Pad 0x%"UVxf" alloc %ld for %s\n",
535 (long) retval, PL_op_name[optype]));
536 #endif /* USE_THREADS */
537 return (PADOFFSET)retval;
541 Perl_pad_sv(pTHX_ PADOFFSET po)
544 DEBUG_X(PerlIO_printf(Perl_debug_log,
545 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
546 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
549 Perl_croak(aTHX_ "panic: pad_sv po");
550 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
551 PTR2UV(PL_curpad), (IV)po));
552 #endif /* USE_THREADS */
553 return PL_curpad[po]; /* eventually we'll turn this into a macro */
557 Perl_pad_free(pTHX_ PADOFFSET po)
561 if (AvARRAY(PL_comppad) != PL_curpad)
562 Perl_croak(aTHX_ "panic: pad_free curpad");
564 Perl_croak(aTHX_ "panic: pad_free po");
566 DEBUG_X(PerlIO_printf(Perl_debug_log,
567 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
568 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
570 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
571 PTR2UV(PL_curpad), (IV)po));
572 #endif /* USE_THREADS */
573 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
574 SvPADTMP_off(PL_curpad[po]);
576 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
579 if ((I32)po < PL_padix)
584 Perl_pad_swipe(pTHX_ PADOFFSET po)
586 if (AvARRAY(PL_comppad) != PL_curpad)
587 Perl_croak(aTHX_ "panic: pad_swipe curpad");
589 Perl_croak(aTHX_ "panic: pad_swipe po");
591 DEBUG_X(PerlIO_printf(Perl_debug_log,
592 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
593 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
595 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
596 PTR2UV(PL_curpad), (IV)po));
597 #endif /* USE_THREADS */
598 SvPADTMP_off(PL_curpad[po]);
599 PL_curpad[po] = NEWSV(1107,0);
600 SvPADTMP_on(PL_curpad[po]);
601 if ((I32)po < PL_padix)
605 /* XXX pad_reset() is currently disabled because it results in serious bugs.
606 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
607 * on the stack by OPs that use them, there are several ways to get an alias
608 * to a shared TARG. Such an alias will change randomly and unpredictably.
609 * We avoid doing this until we can think of a Better Way.
614 #ifdef USE_BROKEN_PAD_RESET
617 if (AvARRAY(PL_comppad) != PL_curpad)
618 Perl_croak(aTHX_ "panic: pad_reset curpad");
620 DEBUG_X(PerlIO_printf(Perl_debug_log,
621 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
622 PTR2UV(thr), PTR2UV(PL_curpad)));
624 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
626 #endif /* USE_THREADS */
627 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
628 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
629 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
630 SvPADTMP_off(PL_curpad[po]);
632 PL_padix = PL_padix_floor;
635 PL_pad_reset_pending = FALSE;
639 /* find_threadsv is not reentrant */
641 Perl_find_threadsv(pTHX_ const char *name)
646 /* We currently only handle names of a single character */
647 p = strchr(PL_threadsv_names, *name);
650 key = p - PL_threadsv_names;
651 MUTEX_LOCK(&thr->mutex);
652 svp = av_fetch(thr->threadsv, key, FALSE);
654 MUTEX_UNLOCK(&thr->mutex);
656 SV *sv = NEWSV(0, 0);
657 av_store(thr->threadsv, key, sv);
658 thr->threadsvp = AvARRAY(thr->threadsv);
659 MUTEX_UNLOCK(&thr->mutex);
661 * Some magic variables used to be automagically initialised
662 * in gv_fetchpv. Those which are now per-thread magicals get
663 * initialised here instead.
669 sv_setpv(sv, "\034");
670 sv_magic(sv, 0, 0, name, 1);
675 PL_sawampersand = TRUE;
689 /* XXX %! tied to Errno.pm needs to be added here.
690 * See gv_fetchpv(). */
694 sv_magic(sv, 0, 0, name, 1);
696 DEBUG_S(PerlIO_printf(Perl_error_log,
697 "find_threadsv: new SV %p for $%s%c\n",
698 sv, (*name < 32) ? "^" : "",
699 (*name < 32) ? toCTRL(*name) : *name));
703 #endif /* USE_THREADS */
708 Perl_op_free(pTHX_ OP *o)
710 register OP *kid, *nextkid;
713 if (!o || o->op_seq == (U16)-1)
716 if (o->op_private & OPpREFCOUNTED) {
717 switch (o->op_type) {
725 if (OpREFCNT_dec(o)) {
736 if (o->op_flags & OPf_KIDS) {
737 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
738 nextkid = kid->op_sibling; /* Get before next freeing kid */
746 /* COP* is not cleared by op_clear() so that we may track line
747 * numbers etc even after null() */
748 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
753 #ifdef PL_OP_SLAB_ALLOC
754 if ((char *) o == PL_OpPtr)
763 S_op_clear(pTHX_ OP *o)
765 switch (o->op_type) {
766 case OP_NULL: /* Was holding old type, if any. */
767 case OP_ENTEREVAL: /* Was holding hints. */
769 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
775 if (!(o->op_flags & OPf_SPECIAL))
778 #endif /* USE_THREADS */
780 if (!(o->op_flags & OPf_REF)
781 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
788 if (cPADOPo->op_padix > 0) {
791 pad_swipe(cPADOPo->op_padix);
792 /* No GvIN_PAD_off(gv) here, because other references may still
793 * exist on the pad */
796 cPADOPo->op_padix = 0;
799 SvREFCNT_dec(cSVOPo->op_sv);
800 cSVOPo->op_sv = Nullsv;
803 case OP_METHOD_NAMED:
805 SvREFCNT_dec(cSVOPo->op_sv);
806 cSVOPo->op_sv = Nullsv;
812 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
816 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
817 SvREFCNT_dec(cSVOPo->op_sv);
818 cSVOPo->op_sv = Nullsv;
821 Safefree(cPVOPo->op_pv);
822 cPVOPo->op_pv = Nullch;
826 op_free(cPMOPo->op_pmreplroot);
830 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
832 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
833 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
834 /* No GvIN_PAD_off(gv) here, because other references may still
835 * exist on the pad */
840 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
847 HV *pmstash = PmopSTASH(cPMOPo);
848 if (pmstash && SvREFCNT(pmstash)) {
849 PMOP *pmop = HvPMROOT(pmstash);
850 PMOP *lastpmop = NULL;
852 if (cPMOPo == pmop) {
854 lastpmop->op_pmnext = pmop->op_pmnext;
856 HvPMROOT(pmstash) = pmop->op_pmnext;
860 pmop = pmop->op_pmnext;
863 Safefree(PmopSTASHPV(cPMOPo));
865 /* NOTE: PMOP.op_pmstash is not refcounted */
869 cPMOPo->op_pmreplroot = Nullop;
870 ReREFCNT_dec(cPMOPo->op_pmregexp);
871 cPMOPo->op_pmregexp = (REGEXP*)NULL;
875 if (o->op_targ > 0) {
876 pad_free(o->op_targ);
882 S_cop_free(pTHX_ COP* cop)
884 Safefree(cop->cop_label);
886 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
887 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
889 /* NOTE: COP.cop_stash is not refcounted */
890 SvREFCNT_dec(CopFILEGV(cop));
892 if (! specialWARN(cop->cop_warnings))
893 SvREFCNT_dec(cop->cop_warnings);
894 if (! specialCopIO(cop->cop_io))
895 SvREFCNT_dec(cop->cop_io);
901 if (o->op_type == OP_NULL)
904 o->op_targ = o->op_type;
905 o->op_type = OP_NULL;
906 o->op_ppaddr = PL_ppaddr[OP_NULL];
909 /* Contextualizers */
911 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
914 Perl_linklist(pTHX_ OP *o)
921 /* establish postfix order */
922 if (cUNOPo->op_first) {
923 o->op_next = LINKLIST(cUNOPo->op_first);
924 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
926 kid->op_next = LINKLIST(kid->op_sibling);
938 Perl_scalarkids(pTHX_ OP *o)
941 if (o && o->op_flags & OPf_KIDS) {
942 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
949 S_scalarboolean(pTHX_ OP *o)
951 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
952 if (ckWARN(WARN_SYNTAX)) {
953 line_t oldline = CopLINE(PL_curcop);
955 if (PL_copline != NOLINE)
956 CopLINE_set(PL_curcop, PL_copline);
957 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
958 CopLINE_set(PL_curcop, oldline);
965 Perl_scalar(pTHX_ OP *o)
969 /* assumes no premature commitment */
970 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
971 || o->op_type == OP_RETURN)
976 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
978 switch (o->op_type) {
980 if (o->op_private & OPpREPEAT_DOLIST)
981 null(((LISTOP*)cBINOPo->op_first)->op_first);
982 scalar(cBINOPo->op_first);
987 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
991 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
992 if (!kPMOP->op_pmreplroot)
993 deprecate("implicit split to @_");
1001 if (o->op_flags & OPf_KIDS) {
1002 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1008 kid = cLISTOPo->op_first;
1010 while ((kid = kid->op_sibling)) {
1011 if (kid->op_sibling)
1016 WITH_THR(PL_curcop = &PL_compiling);
1021 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1022 if (kid->op_sibling)
1027 WITH_THR(PL_curcop = &PL_compiling);
1034 Perl_scalarvoid(pTHX_ OP *o)
1041 if (o->op_type == OP_NEXTSTATE
1042 || o->op_type == OP_SETSTATE
1043 || o->op_type == OP_DBSTATE
1044 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1045 || o->op_targ == OP_SETSTATE
1046 || o->op_targ == OP_DBSTATE)))
1047 PL_curcop = (COP*)o; /* for warning below */
1049 /* assumes no premature commitment */
1050 want = o->op_flags & OPf_WANT;
1051 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1052 || o->op_type == OP_RETURN)
1057 if ((o->op_private & OPpTARGET_MY)
1058 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1060 return scalar(o); /* As if inside SASSIGN */
1063 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1065 switch (o->op_type) {
1067 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1071 if (o->op_flags & OPf_STACKED)
1075 if (o->op_private == 4)
1117 case OP_GETSOCKNAME:
1118 case OP_GETPEERNAME:
1123 case OP_GETPRIORITY:
1146 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1147 useless = PL_op_desc[o->op_type];
1154 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1155 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1156 useless = "a variable";
1161 if (cSVOPo->op_private & OPpCONST_STRICT)
1162 no_bareword_allowed(o);
1164 if (ckWARN(WARN_VOID)) {
1165 useless = "a constant";
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 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_BARE) &&
1388 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1389 SV *sv = ((SVOP*)o)->op_sv;
1392 /* Could be a filehandle */
1393 if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1394 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1398 /* OK, it's a sub */
1400 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1402 enter = newUNOP(OP_ENTERSUB,0,
1403 newUNOP(OP_RV2CV, 0,
1404 newGVOP(OP_GV, 0, gv)
1406 enter->op_private |= OPpLVAL_INTRO;
1412 if (!(o->op_private & (OPpCONST_ARYBASE)))
1414 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1415 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1419 SAVEI32(PL_compiling.cop_arybase);
1420 PL_compiling.cop_arybase = 0;
1422 else if (type == OP_REFGEN)
1425 Perl_croak(aTHX_ "That use of $[ is unsupported");
1428 if (o->op_flags & OPf_PARENS)
1432 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1433 !(o->op_flags & OPf_STACKED)) {
1434 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1435 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1436 assert(cUNOPo->op_first->op_type == OP_NULL);
1437 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1440 else { /* lvalue subroutine call */
1441 o->op_private |= OPpLVAL_INTRO;
1442 PL_modcount = RETURN_UNLIMITED_NUMBER;
1443 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1444 /* Backward compatibility mode: */
1445 o->op_private |= OPpENTERSUB_INARGS;
1448 else { /* Compile-time error message: */
1449 OP *kid = cUNOPo->op_first;
1453 if (kid->op_type == OP_PUSHMARK)
1455 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1457 "panic: unexpected lvalue entersub "
1458 "args: type/targ %ld:%ld",
1459 (long)kid->op_type,kid->op_targ);
1460 kid = kLISTOP->op_first;
1462 while (kid->op_sibling)
1463 kid = kid->op_sibling;
1464 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1466 if (kid->op_type == OP_METHOD_NAMED
1467 || kid->op_type == OP_METHOD)
1471 if (kid->op_sibling || kid->op_next != kid) {
1472 yyerror("panic: unexpected optree near method call");
1476 NewOp(1101, newop, 1, UNOP);
1477 newop->op_type = OP_RV2CV;
1478 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1479 newop->op_first = Nullop;
1480 newop->op_next = (OP*)newop;
1481 kid->op_sibling = (OP*)newop;
1482 newop->op_private |= OPpLVAL_INTRO;
1486 if (kid->op_type != OP_RV2CV)
1488 "panic: unexpected lvalue entersub "
1489 "entry via type/targ %ld:%ld",
1490 (long)kid->op_type,kid->op_targ);
1491 kid->op_private |= OPpLVAL_INTRO;
1492 break; /* Postpone until runtime */
1496 kid = kUNOP->op_first;
1497 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1498 kid = kUNOP->op_first;
1499 if (kid->op_type == OP_NULL)
1501 "Unexpected constant lvalue entersub "
1502 "entry via type/targ %ld:%ld",
1503 (long)kid->op_type,kid->op_targ);
1504 if (kid->op_type != OP_GV) {
1505 /* Restore RV2CV to check lvalueness */
1507 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1508 okid->op_next = kid->op_next;
1509 kid->op_next = okid;
1512 okid->op_next = Nullop;
1513 okid->op_type = OP_RV2CV;
1515 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1516 okid->op_private |= OPpLVAL_INTRO;
1520 cv = GvCV(kGVOP_gv);
1530 /* grep, foreach, subcalls, refgen */
1531 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1533 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1534 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1536 : (o->op_type == OP_ENTERSUB
1537 ? "non-lvalue subroutine call"
1538 : PL_op_desc[o->op_type])),
1539 type ? PL_op_desc[type] : "local"));
1553 case OP_RIGHT_SHIFT:
1562 if (!(o->op_flags & OPf_STACKED))
1568 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1574 if (!type && cUNOPo->op_first->op_type != OP_GV)
1575 Perl_croak(aTHX_ "Can't localize through a reference");
1576 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1577 PL_modcount = RETURN_UNLIMITED_NUMBER;
1578 return o; /* Treat \(@foo) like ordinary list. */
1582 if (scalar_mod_type(o, type))
1584 ref(cUNOPo->op_first, o->op_type);
1588 if (type == OP_LEAVESUBLV)
1589 o->op_private |= OPpMAYBE_LVSUB;
1595 PL_modcount = RETURN_UNLIMITED_NUMBER;
1598 if (!type && cUNOPo->op_first->op_type != OP_GV)
1599 Perl_croak(aTHX_ "Can't localize through a reference");
1600 ref(cUNOPo->op_first, o->op_type);
1604 PL_hints |= HINT_BLOCK_SCOPE;
1614 PL_modcount = RETURN_UNLIMITED_NUMBER;
1615 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1616 return o; /* Treat \(@foo) like ordinary list. */
1617 if (scalar_mod_type(o, type))
1619 if (type == OP_LEAVESUBLV)
1620 o->op_private |= OPpMAYBE_LVSUB;
1625 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1626 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1631 PL_modcount++; /* XXX ??? */
1633 #endif /* USE_THREADS */
1639 if (type != OP_SASSIGN)
1643 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1648 if (type == OP_LEAVESUBLV)
1649 o->op_private |= OPpMAYBE_LVSUB;
1651 pad_free(o->op_targ);
1652 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1653 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1654 if (o->op_flags & OPf_KIDS)
1655 mod(cBINOPo->op_first->op_sibling, type);
1660 ref(cBINOPo->op_first, o->op_type);
1661 if (type == OP_ENTERSUB &&
1662 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1663 o->op_private |= OPpLVAL_DEFER;
1664 if (type == OP_LEAVESUBLV)
1665 o->op_private |= OPpMAYBE_LVSUB;
1673 if (o->op_flags & OPf_KIDS)
1674 mod(cLISTOPo->op_last, type);
1678 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1680 else if (!(o->op_flags & OPf_KIDS))
1682 if (o->op_targ != OP_LIST) {
1683 mod(cBINOPo->op_first, type);
1688 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1693 if (type != OP_LEAVESUBLV)
1695 break; /* mod()ing was handled by ck_return() */
1697 if (type != OP_LEAVESUBLV)
1698 o->op_flags |= OPf_MOD;
1700 if (type == OP_AASSIGN || type == OP_SASSIGN)
1701 o->op_flags |= OPf_SPECIAL|OPf_REF;
1703 o->op_private |= OPpLVAL_INTRO;
1704 o->op_flags &= ~OPf_SPECIAL;
1705 PL_hints |= HINT_BLOCK_SCOPE;
1707 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1708 && type != OP_LEAVESUBLV)
1709 o->op_flags |= OPf_REF;
1714 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1718 if (o->op_type == OP_RV2GV)
1742 case OP_RIGHT_SHIFT:
1761 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1763 switch (o->op_type) {
1771 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1784 Perl_refkids(pTHX_ OP *o, I32 type)
1787 if (o && o->op_flags & OPf_KIDS) {
1788 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1795 Perl_ref(pTHX_ OP *o, I32 type)
1799 if (!o || PL_error_count)
1802 switch (o->op_type) {
1804 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1805 !(o->op_flags & OPf_STACKED)) {
1806 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1807 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1808 assert(cUNOPo->op_first->op_type == OP_NULL);
1809 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1810 o->op_flags |= OPf_SPECIAL;
1815 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1819 if (type == OP_DEFINED)
1820 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1821 ref(cUNOPo->op_first, o->op_type);
1824 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1825 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1826 : type == OP_RV2HV ? OPpDEREF_HV
1828 o->op_flags |= OPf_MOD;
1833 o->op_flags |= OPf_MOD; /* XXX ??? */
1838 o->op_flags |= OPf_REF;
1841 if (type == OP_DEFINED)
1842 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1843 ref(cUNOPo->op_first, o->op_type);
1848 o->op_flags |= OPf_REF;
1853 if (!(o->op_flags & OPf_KIDS))
1855 ref(cBINOPo->op_first, type);
1859 ref(cBINOPo->op_first, o->op_type);
1860 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1861 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1862 : type == OP_RV2HV ? OPpDEREF_HV
1864 o->op_flags |= OPf_MOD;
1872 if (!(o->op_flags & OPf_KIDS))
1874 ref(cLISTOPo->op_last, type);
1884 S_dup_attrlist(pTHX_ OP *o)
1888 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1889 * where the first kid is OP_PUSHMARK and the remaining ones
1890 * are OP_CONST. We need to push the OP_CONST values.
1892 if (o->op_type == OP_CONST)
1893 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1895 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1896 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1897 if (o->op_type == OP_CONST)
1898 rop = append_elem(OP_LIST, rop,
1899 newSVOP(OP_CONST, o->op_flags,
1900 SvREFCNT_inc(cSVOPo->op_sv)));
1907 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1911 /* fake up C<use attributes $pkg,$rv,@attrs> */
1912 ENTER; /* need to protect against side-effects of 'use' */
1914 if (stash && HvNAME(stash))
1915 stashsv = newSVpv(HvNAME(stash), 0);
1917 stashsv = &PL_sv_no;
1919 #define ATTRSMODULE "attributes"
1921 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1922 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1924 prepend_elem(OP_LIST,
1925 newSVOP(OP_CONST, 0, stashsv),
1926 prepend_elem(OP_LIST,
1927 newSVOP(OP_CONST, 0,
1929 dup_attrlist(attrs))));
1934 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1935 char *attrstr, STRLEN len)
1940 len = strlen(attrstr);
1944 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1946 char *sstr = attrstr;
1947 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1948 attrs = append_elem(OP_LIST, attrs,
1949 newSVOP(OP_CONST, 0,
1950 newSVpvn(sstr, attrstr-sstr)));
1954 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1955 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1956 Nullsv, prepend_elem(OP_LIST,
1957 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1958 prepend_elem(OP_LIST,
1959 newSVOP(OP_CONST, 0,
1965 S_my_kid(pTHX_ OP *o, OP *attrs)
1970 if (!o || PL_error_count)
1974 if (type == OP_LIST) {
1975 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1977 } else if (type == OP_UNDEF) {
1979 } else if (type == OP_RV2SV || /* "our" declaration */
1981 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1983 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1985 PL_in_my_stash = Nullhv;
1986 apply_attrs(GvSTASH(gv),
1987 (type == OP_RV2SV ? GvSV(gv) :
1988 type == OP_RV2AV ? (SV*)GvAV(gv) :
1989 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1992 o->op_private |= OPpOUR_INTRO;
1994 } else if (type != OP_PADSV &&
1997 type != OP_PUSHMARK)
1999 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2000 PL_op_desc[o->op_type],
2001 PL_in_my == KEY_our ? "our" : "my"));
2004 else if (attrs && type != OP_PUSHMARK) {
2010 PL_in_my_stash = Nullhv;
2012 /* check for C<my Dog $spot> when deciding package */
2013 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2014 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
2015 stash = SvSTASH(*namesvp);
2017 stash = PL_curstash;
2018 padsv = PAD_SV(o->op_targ);
2019 apply_attrs(stash, padsv, attrs);
2021 o->op_flags |= OPf_MOD;
2022 o->op_private |= OPpLVAL_INTRO;
2027 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2029 if (o->op_flags & OPf_PARENS)
2033 o = my_kid(o, attrs);
2035 PL_in_my_stash = Nullhv;
2040 Perl_my(pTHX_ OP *o)
2042 return my_kid(o, Nullop);
2046 Perl_sawparens(pTHX_ OP *o)
2049 o->op_flags |= OPf_PARENS;
2054 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2058 if (ckWARN(WARN_MISC) &&
2059 (left->op_type == OP_RV2AV ||
2060 left->op_type == OP_RV2HV ||
2061 left->op_type == OP_PADAV ||
2062 left->op_type == OP_PADHV)) {
2063 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2064 right->op_type == OP_TRANS)
2065 ? right->op_type : OP_MATCH];
2066 const char *sample = ((left->op_type == OP_RV2AV ||
2067 left->op_type == OP_PADAV)
2068 ? "@array" : "%hash");
2069 Perl_warner(aTHX_ WARN_MISC,
2070 "Applying %s to %s will act on scalar(%s)",
2071 desc, sample, sample);
2074 if (!(right->op_flags & OPf_STACKED) &&
2075 (right->op_type == OP_MATCH ||
2076 right->op_type == OP_SUBST ||
2077 right->op_type == OP_TRANS)) {
2078 right->op_flags |= OPf_STACKED;
2079 if (right->op_type != OP_MATCH &&
2080 ! (right->op_type == OP_TRANS &&
2081 right->op_private & OPpTRANS_IDENTICAL))
2082 left = mod(left, right->op_type);
2083 if (right->op_type == OP_TRANS)
2084 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2086 o = prepend_elem(right->op_type, scalar(left), right);
2088 return newUNOP(OP_NOT, 0, scalar(o));
2092 return bind_match(type, left,
2093 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2097 Perl_invert(pTHX_ OP *o)
2101 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2102 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2106 Perl_scope(pTHX_ OP *o)
2109 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2110 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2111 o->op_type = OP_LEAVE;
2112 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2115 if (o->op_type == OP_LINESEQ) {
2117 o->op_type = OP_SCOPE;
2118 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2119 kid = ((LISTOP*)o)->op_first;
2120 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2124 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2131 Perl_save_hints(pTHX)
2134 SAVESPTR(GvHV(PL_hintgv));
2135 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2136 SAVEFREESV(GvHV(PL_hintgv));
2140 Perl_block_start(pTHX_ int full)
2142 int retval = PL_savestack_ix;
2144 SAVEI32(PL_comppad_name_floor);
2145 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2147 PL_comppad_name_fill = PL_comppad_name_floor;
2148 if (PL_comppad_name_floor < 0)
2149 PL_comppad_name_floor = 0;
2150 SAVEI32(PL_min_intro_pending);
2151 SAVEI32(PL_max_intro_pending);
2152 PL_min_intro_pending = 0;
2153 SAVEI32(PL_comppad_name_fill);
2154 SAVEI32(PL_padix_floor);
2155 PL_padix_floor = PL_padix;
2156 PL_pad_reset_pending = FALSE;
2158 PL_hints &= ~HINT_BLOCK_SCOPE;
2159 SAVESPTR(PL_compiling.cop_warnings);
2160 if (! specialWARN(PL_compiling.cop_warnings)) {
2161 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2162 SAVEFREESV(PL_compiling.cop_warnings) ;
2164 SAVESPTR(PL_compiling.cop_io);
2165 if (! specialCopIO(PL_compiling.cop_io)) {
2166 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2167 SAVEFREESV(PL_compiling.cop_io) ;
2173 Perl_block_end(pTHX_ I32 floor, OP *seq)
2175 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2176 OP* retval = scalarseq(seq);
2178 PL_pad_reset_pending = FALSE;
2179 PL_compiling.op_private = PL_hints;
2181 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2182 pad_leavemy(PL_comppad_name_fill);
2191 OP *o = newOP(OP_THREADSV, 0);
2192 o->op_targ = find_threadsv("_");
2195 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2196 #endif /* USE_THREADS */
2200 Perl_newPROG(pTHX_ OP *o)
2205 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2206 ((PL_in_eval & EVAL_KEEPERR)
2207 ? OPf_SPECIAL : 0), o);
2208 PL_eval_start = linklist(PL_eval_root);
2209 PL_eval_root->op_private |= OPpREFCOUNTED;
2210 OpREFCNT_set(PL_eval_root, 1);
2211 PL_eval_root->op_next = 0;
2212 peep(PL_eval_start);
2217 PL_main_root = scope(sawparens(scalarvoid(o)));
2218 PL_curcop = &PL_compiling;
2219 PL_main_start = LINKLIST(PL_main_root);
2220 PL_main_root->op_private |= OPpREFCOUNTED;
2221 OpREFCNT_set(PL_main_root, 1);
2222 PL_main_root->op_next = 0;
2223 peep(PL_main_start);
2226 /* Register with debugger */
2228 CV *cv = get_cv("DB::postponed", FALSE);
2232 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2234 call_sv((SV*)cv, G_DISCARD);
2241 Perl_localize(pTHX_ OP *o, I32 lex)
2243 if (o->op_flags & OPf_PARENS)
2246 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2248 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2249 if (*s == ';' || *s == '=')
2250 Perl_warner(aTHX_ WARN_PARENTHESIS,
2251 "Parentheses missing around \"%s\" list",
2252 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2258 o = mod(o, OP_NULL); /* a bit kludgey */
2260 PL_in_my_stash = Nullhv;
2265 Perl_jmaybe(pTHX_ OP *o)
2267 if (o->op_type == OP_LIST) {
2270 o2 = newOP(OP_THREADSV, 0);
2271 o2->op_targ = find_threadsv(";");
2273 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2274 #endif /* USE_THREADS */
2275 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2281 Perl_fold_constants(pTHX_ register OP *o)
2284 I32 type = o->op_type;
2287 if (PL_opargs[type] & OA_RETSCALAR)
2289 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2290 o->op_targ = pad_alloc(type, SVs_PADTMP);
2292 /* integerize op, unless it happens to be C<-foo>.
2293 * XXX should pp_i_negate() do magic string negation instead? */
2294 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2295 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2296 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2298 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2301 if (!(PL_opargs[type] & OA_FOLDCONST))
2306 /* XXX might want a ck_negate() for this */
2307 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2320 if (o->op_private & OPpLOCALE)
2325 goto nope; /* Don't try to run w/ errors */
2327 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2328 if ((curop->op_type != OP_CONST ||
2329 (curop->op_private & OPpCONST_BARE)) &&
2330 curop->op_type != OP_LIST &&
2331 curop->op_type != OP_SCALAR &&
2332 curop->op_type != OP_NULL &&
2333 curop->op_type != OP_PUSHMARK)
2339 curop = LINKLIST(o);
2343 sv = *(PL_stack_sp--);
2344 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2345 pad_swipe(o->op_targ);
2346 else if (SvTEMP(sv)) { /* grab mortal temp? */
2347 (void)SvREFCNT_inc(sv);
2351 if (type == OP_RV2GV)
2352 return newGVOP(OP_GV, 0, (GV*)sv);
2354 /* try to smush double to int, but don't smush -2.0 to -2 */
2355 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2358 #ifdef PERL_PRESERVE_IVUV
2359 /* Only bother to attempt to fold to IV if
2360 most operators will benefit */
2364 return newSVOP(OP_CONST, 0, sv);
2368 if (!(PL_opargs[type] & OA_OTHERINT))
2371 if (!(PL_hints & HINT_INTEGER)) {
2372 if (type == OP_MODULO
2373 || type == OP_DIVIDE
2374 || !(o->op_flags & OPf_KIDS))
2379 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2380 if (curop->op_type == OP_CONST) {
2381 if (SvIOK(((SVOP*)curop)->op_sv))
2385 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2389 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2396 Perl_gen_constant_list(pTHX_ register OP *o)
2399 I32 oldtmps_floor = PL_tmps_floor;
2403 return o; /* Don't attempt to run with errors */
2405 PL_op = curop = LINKLIST(o);
2412 PL_tmps_floor = oldtmps_floor;
2414 o->op_type = OP_RV2AV;
2415 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2416 curop = ((UNOP*)o)->op_first;
2417 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2424 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2426 if (!o || o->op_type != OP_LIST)
2427 o = newLISTOP(OP_LIST, 0, o, Nullop);
2429 o->op_flags &= ~OPf_WANT;
2431 if (!(PL_opargs[type] & OA_MARK))
2432 null(cLISTOPo->op_first);
2435 o->op_ppaddr = PL_ppaddr[type];
2436 o->op_flags |= flags;
2438 o = CHECKOP(type, o);
2439 if (o->op_type != type)
2442 return fold_constants(o);
2445 /* List constructors */
2448 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2456 if (first->op_type != type
2457 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2459 return newLISTOP(type, 0, first, last);
2462 if (first->op_flags & OPf_KIDS)
2463 ((LISTOP*)first)->op_last->op_sibling = last;
2465 first->op_flags |= OPf_KIDS;
2466 ((LISTOP*)first)->op_first = last;
2468 ((LISTOP*)first)->op_last = last;
2473 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2481 if (first->op_type != type)
2482 return prepend_elem(type, (OP*)first, (OP*)last);
2484 if (last->op_type != type)
2485 return append_elem(type, (OP*)first, (OP*)last);
2487 first->op_last->op_sibling = last->op_first;
2488 first->op_last = last->op_last;
2489 first->op_flags |= (last->op_flags & OPf_KIDS);
2491 #ifdef PL_OP_SLAB_ALLOC
2499 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2507 if (last->op_type == type) {
2508 if (type == OP_LIST) { /* already a PUSHMARK there */
2509 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2510 ((LISTOP*)last)->op_first->op_sibling = first;
2511 if (!(first->op_flags & OPf_PARENS))
2512 last->op_flags &= ~OPf_PARENS;
2515 if (!(last->op_flags & OPf_KIDS)) {
2516 ((LISTOP*)last)->op_last = first;
2517 last->op_flags |= OPf_KIDS;
2519 first->op_sibling = ((LISTOP*)last)->op_first;
2520 ((LISTOP*)last)->op_first = first;
2522 last->op_flags |= OPf_KIDS;
2526 return newLISTOP(type, 0, first, last);
2532 Perl_newNULLLIST(pTHX)
2534 return newOP(OP_STUB, 0);
2538 Perl_force_list(pTHX_ OP *o)
2540 if (!o || o->op_type != OP_LIST)
2541 o = newLISTOP(OP_LIST, 0, o, Nullop);
2547 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2551 NewOp(1101, listop, 1, LISTOP);
2553 listop->op_type = type;
2554 listop->op_ppaddr = PL_ppaddr[type];
2557 listop->op_flags = flags;
2561 else if (!first && last)
2564 first->op_sibling = last;
2565 listop->op_first = first;
2566 listop->op_last = last;
2567 if (type == OP_LIST) {
2569 pushop = newOP(OP_PUSHMARK, 0);
2570 pushop->op_sibling = first;
2571 listop->op_first = pushop;
2572 listop->op_flags |= OPf_KIDS;
2574 listop->op_last = pushop;
2581 Perl_newOP(pTHX_ I32 type, I32 flags)
2584 NewOp(1101, o, 1, OP);
2586 o->op_ppaddr = PL_ppaddr[type];
2587 o->op_flags = flags;
2590 o->op_private = 0 + (flags >> 8);
2591 if (PL_opargs[type] & OA_RETSCALAR)
2593 if (PL_opargs[type] & OA_TARGET)
2594 o->op_targ = pad_alloc(type, SVs_PADTMP);
2595 return CHECKOP(type, o);
2599 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2604 first = newOP(OP_STUB, 0);
2605 if (PL_opargs[type] & OA_MARK)
2606 first = force_list(first);
2608 NewOp(1101, unop, 1, UNOP);
2609 unop->op_type = type;
2610 unop->op_ppaddr = PL_ppaddr[type];
2611 unop->op_first = first;
2612 unop->op_flags = flags | OPf_KIDS;
2613 unop->op_private = 1 | (flags >> 8);
2614 unop = (UNOP*) CHECKOP(type, unop);
2618 return fold_constants((OP *) unop);
2622 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2625 NewOp(1101, binop, 1, BINOP);
2628 first = newOP(OP_NULL, 0);
2630 binop->op_type = type;
2631 binop->op_ppaddr = PL_ppaddr[type];
2632 binop->op_first = first;
2633 binop->op_flags = flags | OPf_KIDS;
2636 binop->op_private = 1 | (flags >> 8);
2639 binop->op_private = 2 | (flags >> 8);
2640 first->op_sibling = last;
2643 binop = (BINOP*)CHECKOP(type, binop);
2644 if (binop->op_next || binop->op_type != type)
2647 binop->op_last = binop->op_first->op_sibling;
2649 return fold_constants((OP *)binop);
2653 uvcompare(const void *a, const void *b)
2655 if (*((UV *)a) < (*(UV *)b))
2657 if (*((UV *)a) > (*(UV *)b))
2659 if (*((UV *)a+1) < (*(UV *)b+1))
2661 if (*((UV *)a+1) > (*(UV *)b+1))
2667 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2669 SV *tstr = ((SVOP*)expr)->op_sv;
2670 SV *rstr = ((SVOP*)repl)->op_sv;
2673 U8 *t = (U8*)SvPV(tstr, tlen);
2674 U8 *r = (U8*)SvPV(rstr, rlen);
2681 register short *tbl;
2683 complement = o->op_private & OPpTRANS_COMPLEMENT;
2684 del = o->op_private & OPpTRANS_DELETE;
2685 squash = o->op_private & OPpTRANS_SQUASH;
2688 o->op_private |= OPpTRANS_FROM_UTF;
2691 o->op_private |= OPpTRANS_TO_UTF;
2693 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2694 SV* listsv = newSVpvn("# comment\n",10);
2696 U8* tend = t + tlen;
2697 U8* rend = r + rlen;
2711 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2712 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2713 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2714 U8* rsave = (to_utf || !rlen) ? NULL : trlist_upgrade(&r, &rend);
2716 /* There are several snags with this code on EBCDIC:
2717 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2718 2. scan_const() in toke.c has encoded chars in native encoding which makes
2719 ranges at least in EBCDIC 0..255 range the bottom odd.
2723 U8 tmpbuf[UTF8_MAXLEN+1];
2726 New(1109, cp, 2*tlen, UV);
2728 transv = newSVpvn("",0);
2730 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2732 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2734 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2738 cp[2*i+1] = cp[2*i];
2742 qsort(cp, i, 2*sizeof(UV), uvcompare);
2743 for (j = 0; j < i; j++) {
2745 diff = val - nextmin;
2747 t = uvuni_to_utf8(tmpbuf,nextmin);
2748 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2750 U8 range_mark = UTF_TO_NATIVE(0xff);
2751 t = uvuni_to_utf8(tmpbuf, val - 1);
2752 sv_catpvn(transv, (char *)&range_mark, 1);
2753 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2760 t = uvuni_to_utf8(tmpbuf,nextmin);
2761 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2763 U8 range_mark = UTF_TO_NATIVE(0xff);
2764 sv_catpvn(transv, (char *)&range_mark, 1);
2766 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2767 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2768 t = (U8*)SvPVX(transv);
2769 tlen = SvCUR(transv);
2773 else if (!rlen && !del) {
2774 r = t; rlen = tlen; rend = tend;
2777 if ((!rlen && !del) || t == r ||
2778 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2780 o->op_private |= OPpTRANS_IDENTICAL;
2784 while (t < tend || tfirst <= tlast) {
2785 /* see if we need more "t" chars */
2786 if (tfirst > tlast) {
2787 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2789 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2791 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2798 /* now see if we need more "r" chars */
2799 if (rfirst > rlast) {
2801 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2803 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2805 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2814 rfirst = rlast = 0xffffffff;
2818 /* now see which range will peter our first, if either. */
2819 tdiff = tlast - tfirst;
2820 rdiff = rlast - rfirst;
2827 if (rfirst == 0xffffffff) {
2828 diff = tdiff; /* oops, pretend rdiff is infinite */
2830 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2831 (long)tfirst, (long)tlast);
2833 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2837 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2838 (long)tfirst, (long)(tfirst + diff),
2841 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2842 (long)tfirst, (long)rfirst);
2844 if (rfirst + diff > max)
2845 max = rfirst + diff;
2847 grows = (tfirst < rfirst &&
2848 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2860 else if (max > 0xff)
2865 Safefree(cPVOPo->op_pv);
2866 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2867 SvREFCNT_dec(listsv);
2869 SvREFCNT_dec(transv);
2871 if (!del && havefinal && rlen)
2872 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2873 newSVuv((UV)final), 0);
2876 o->op_private |= OPpTRANS_GROWS;
2888 tbl = (short*)cPVOPo->op_pv;
2890 Zero(tbl, 256, short);
2891 for (i = 0; i < tlen; i++)
2893 for (i = 0, j = 0; i < 256; i++) {
2904 if (i < 128 && r[j] >= 128)
2914 o->op_private |= OPpTRANS_IDENTICAL;
2919 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2920 tbl[0x100] = rlen - j;
2921 for (i=0; i < rlen - j; i++)
2922 tbl[0x101+i] = r[j+i];
2926 if (!rlen && !del) {
2929 o->op_private |= OPpTRANS_IDENTICAL;
2931 for (i = 0; i < 256; i++)
2933 for (i = 0, j = 0; i < tlen; i++,j++) {
2936 if (tbl[t[i]] == -1)
2942 if (tbl[t[i]] == -1) {
2943 if (t[i] < 128 && r[j] >= 128)
2950 o->op_private |= OPpTRANS_GROWS;
2958 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2962 NewOp(1101, pmop, 1, PMOP);
2963 pmop->op_type = type;
2964 pmop->op_ppaddr = PL_ppaddr[type];
2965 pmop->op_flags = flags;
2966 pmop->op_private = 0 | (flags >> 8);
2968 if (PL_hints & HINT_RE_TAINT)
2969 pmop->op_pmpermflags |= PMf_RETAINT;
2970 if (PL_hints & HINT_LOCALE)
2971 pmop->op_pmpermflags |= PMf_LOCALE;
2972 pmop->op_pmflags = pmop->op_pmpermflags;
2974 /* link into pm list */
2975 if (type != OP_TRANS && PL_curstash) {
2976 pmop->op_pmnext = HvPMROOT(PL_curstash);
2977 HvPMROOT(PL_curstash) = pmop;
2978 PmopSTASH_set(pmop,PL_curstash);
2985 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2989 I32 repl_has_vars = 0;
2991 if (o->op_type == OP_TRANS)
2992 return pmtrans(o, expr, repl);
2994 PL_hints |= HINT_BLOCK_SCOPE;
2997 if (expr->op_type == OP_CONST) {
2999 SV *pat = ((SVOP*)expr)->op_sv;
3000 char *p = SvPV(pat, plen);
3001 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3002 sv_setpvn(pat, "\\s+", 3);
3003 p = SvPV(pat, plen);
3004 pm->op_pmflags |= PMf_SKIPWHITE;
3006 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
3007 pm->op_pmdynflags |= PMdf_UTF8;
3008 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
3009 if (strEQ("\\s+", pm->op_pmregexp->precomp))
3010 pm->op_pmflags |= PMf_WHITE;
3014 if (PL_hints & HINT_UTF8)
3015 pm->op_pmdynflags |= PMdf_UTF8;
3016 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3017 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3019 : OP_REGCMAYBE),0,expr);
3021 NewOp(1101, rcop, 1, LOGOP);
3022 rcop->op_type = OP_REGCOMP;
3023 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3024 rcop->op_first = scalar(expr);
3025 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3026 ? (OPf_SPECIAL | OPf_KIDS)
3028 rcop->op_private = 1;
3031 /* establish postfix order */
3032 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3034 rcop->op_next = expr;
3035 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3038 rcop->op_next = LINKLIST(expr);
3039 expr->op_next = (OP*)rcop;
3042 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3047 if (pm->op_pmflags & PMf_EVAL) {
3049 if (CopLINE(PL_curcop) < PL_multi_end)
3050 CopLINE_set(PL_curcop, PL_multi_end);
3053 else if (repl->op_type == OP_THREADSV
3054 && strchr("&`'123456789+",
3055 PL_threadsv_names[repl->op_targ]))
3059 #endif /* USE_THREADS */
3060 else if (repl->op_type == OP_CONST)
3064 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3065 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3067 if (curop->op_type == OP_THREADSV) {
3069 if (strchr("&`'123456789+", curop->op_private))
3073 if (curop->op_type == OP_GV) {
3074 GV *gv = cGVOPx_gv(curop);
3076 if (strchr("&`'123456789+", *GvENAME(gv)))
3079 #endif /* USE_THREADS */
3080 else if (curop->op_type == OP_RV2CV)
3082 else if (curop->op_type == OP_RV2SV ||
3083 curop->op_type == OP_RV2AV ||
3084 curop->op_type == OP_RV2HV ||
3085 curop->op_type == OP_RV2GV) {
3086 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3089 else if (curop->op_type == OP_PADSV ||
3090 curop->op_type == OP_PADAV ||
3091 curop->op_type == OP_PADHV ||
3092 curop->op_type == OP_PADANY) {
3095 else if (curop->op_type == OP_PUSHRE)
3096 ; /* Okay here, dangerous in newASSIGNOP */
3105 && (!pm->op_pmregexp
3106 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3107 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3108 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3109 prepend_elem(o->op_type, scalar(repl), o);
3112 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3113 pm->op_pmflags |= PMf_MAYBE_CONST;
3114 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3116 NewOp(1101, rcop, 1, LOGOP);
3117 rcop->op_type = OP_SUBSTCONT;
3118 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3119 rcop->op_first = scalar(repl);
3120 rcop->op_flags |= OPf_KIDS;
3121 rcop->op_private = 1;
3124 /* establish postfix order */
3125 rcop->op_next = LINKLIST(repl);
3126 repl->op_next = (OP*)rcop;
3128 pm->op_pmreplroot = scalar((OP*)rcop);
3129 pm->op_pmreplstart = LINKLIST(rcop);
3138 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3141 NewOp(1101, svop, 1, SVOP);
3142 svop->op_type = type;
3143 svop->op_ppaddr = PL_ppaddr[type];
3145 svop->op_next = (OP*)svop;
3146 svop->op_flags = flags;
3147 if (PL_opargs[type] & OA_RETSCALAR)
3149 if (PL_opargs[type] & OA_TARGET)
3150 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3151 return CHECKOP(type, svop);
3155 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3158 NewOp(1101, padop, 1, PADOP);
3159 padop->op_type = type;
3160 padop->op_ppaddr = PL_ppaddr[type];
3161 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3162 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3163 PL_curpad[padop->op_padix] = sv;
3165 padop->op_next = (OP*)padop;
3166 padop->op_flags = flags;
3167 if (PL_opargs[type] & OA_RETSCALAR)
3169 if (PL_opargs[type] & OA_TARGET)
3170 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3171 return CHECKOP(type, padop);
3175 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3179 return newPADOP(type, flags, SvREFCNT_inc(gv));
3181 return newSVOP(type, flags, SvREFCNT_inc(gv));
3186 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3189 NewOp(1101, pvop, 1, PVOP);
3190 pvop->op_type = type;
3191 pvop->op_ppaddr = PL_ppaddr[type];
3193 pvop->op_next = (OP*)pvop;
3194 pvop->op_flags = flags;
3195 if (PL_opargs[type] & OA_RETSCALAR)
3197 if (PL_opargs[type] & OA_TARGET)
3198 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3199 return CHECKOP(type, pvop);
3203 Perl_package(pTHX_ OP *o)
3207 save_hptr(&PL_curstash);
3208 save_item(PL_curstname);
3213 name = SvPV(sv, len);
3214 PL_curstash = gv_stashpvn(name,len,TRUE);
3215 sv_setpvn(PL_curstname, name, len);
3219 sv_setpv(PL_curstname,"<none>");
3220 PL_curstash = Nullhv;
3222 PL_hints |= HINT_BLOCK_SCOPE;
3223 PL_copline = NOLINE;
3228 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3236 if (id->op_type != OP_CONST)
3237 Perl_croak(aTHX_ "Module name must be constant");
3241 if (version != Nullop) {
3242 SV *vesv = ((SVOP*)version)->op_sv;
3244 if (arg == Nullop && !SvNIOKp(vesv)) {
3251 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3252 Perl_croak(aTHX_ "Version number must be constant number");
3254 /* Make copy of id so we don't free it twice */
3255 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3257 /* Fake up a method call to VERSION */
3258 meth = newSVpvn("VERSION",7);
3259 sv_upgrade(meth, SVt_PVIV);
3260 (void)SvIOK_on(meth);
3261 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3262 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3263 append_elem(OP_LIST,
3264 prepend_elem(OP_LIST, pack, list(version)),
3265 newSVOP(OP_METHOD_NAMED, 0, meth)));
3269 /* Fake up an import/unimport */
3270 if (arg && arg->op_type == OP_STUB)
3271 imop = arg; /* no import on explicit () */
3272 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3273 imop = Nullop; /* use 5.0; */
3278 /* Make copy of id so we don't free it twice */
3279 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3281 /* Fake up a method call to import/unimport */
3282 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3283 sv_upgrade(meth, SVt_PVIV);
3284 (void)SvIOK_on(meth);
3285 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3286 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3287 append_elem(OP_LIST,
3288 prepend_elem(OP_LIST, pack, list(arg)),
3289 newSVOP(OP_METHOD_NAMED, 0, meth)));
3292 /* Fake up a require, handle override, if any */
3293 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3294 if (!(gv && GvIMPORTED_CV(gv)))
3295 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3297 if (gv && GvIMPORTED_CV(gv)) {
3298 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3299 append_elem(OP_LIST, id,
3300 scalar(newUNOP(OP_RV2CV, 0,
3305 rqop = newUNOP(OP_REQUIRE, 0, id);
3308 /* Fake up the BEGIN {}, which does its thing immediately. */
3310 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3313 append_elem(OP_LINESEQ,
3314 append_elem(OP_LINESEQ,
3315 newSTATEOP(0, Nullch, rqop),
3316 newSTATEOP(0, Nullch, veop)),
3317 newSTATEOP(0, Nullch, imop) ));
3319 PL_hints |= HINT_BLOCK_SCOPE;
3320 PL_copline = NOLINE;
3325 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3328 va_start(args, ver);
3329 vload_module(flags, name, ver, &args);
3333 #ifdef PERL_IMPLICIT_CONTEXT
3335 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3339 va_start(args, ver);
3340 vload_module(flags, name, ver, &args);
3346 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3348 OP *modname, *veop, *imop;
3350 modname = newSVOP(OP_CONST, 0, name);
3351 modname->op_private |= OPpCONST_BARE;
3353 veop = newSVOP(OP_CONST, 0, ver);
3357 if (flags & PERL_LOADMOD_NOIMPORT) {
3358 imop = sawparens(newNULLLIST());
3360 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3361 imop = va_arg(*args, OP*);
3366 sv = va_arg(*args, SV*);
3368 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3369 sv = va_arg(*args, SV*);
3373 line_t ocopline = PL_copline;
3374 int oexpect = PL_expect;
3376 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3377 veop, modname, imop);
3378 PL_expect = oexpect;
3379 PL_copline = ocopline;
3384 Perl_dofile(pTHX_ OP *term)
3389 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3390 if (!(gv && GvIMPORTED_CV(gv)))
3391 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3393 if (gv && GvIMPORTED_CV(gv)) {
3394 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3395 append_elem(OP_LIST, term,
3396 scalar(newUNOP(OP_RV2CV, 0,
3401 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3407 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3409 return newBINOP(OP_LSLICE, flags,
3410 list(force_list(subscript)),
3411 list(force_list(listval)) );
3415 S_list_assignment(pTHX_ register OP *o)
3420 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3421 o = cUNOPo->op_first;
3423 if (o->op_type == OP_COND_EXPR) {
3424 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3425 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3430 yyerror("Assignment to both a list and a scalar");
3434 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3435 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3436 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3439 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3442 if (o->op_type == OP_RV2SV)
3449 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3454 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3455 return newLOGOP(optype, 0,
3456 mod(scalar(left), optype),
3457 newUNOP(OP_SASSIGN, 0, scalar(right)));
3460 return newBINOP(optype, OPf_STACKED,
3461 mod(scalar(left), optype), scalar(right));
3465 if (list_assignment(left)) {
3469 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3470 left = mod(left, OP_AASSIGN);
3478 curop = list(force_list(left));
3479 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3480 o->op_private = 0 | (flags >> 8);
3481 for (curop = ((LISTOP*)curop)->op_first;
3482 curop; curop = curop->op_sibling)
3484 if (curop->op_type == OP_RV2HV &&
3485 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3486 o->op_private |= OPpASSIGN_HASH;
3490 if (!(left->op_private & OPpLVAL_INTRO)) {
3493 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3494 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3495 if (curop->op_type == OP_GV) {
3496 GV *gv = cGVOPx_gv(curop);
3497 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3499 SvCUR(gv) = PL_generation;
3501 else if (curop->op_type == OP_PADSV ||
3502 curop->op_type == OP_PADAV ||
3503 curop->op_type == OP_PADHV ||
3504 curop->op_type == OP_PADANY) {
3505 SV **svp = AvARRAY(PL_comppad_name);
3506 SV *sv = svp[curop->op_targ];
3507 if (SvCUR(sv) == PL_generation)
3509 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3511 else if (curop->op_type == OP_RV2CV)
3513 else if (curop->op_type == OP_RV2SV ||
3514 curop->op_type == OP_RV2AV ||
3515 curop->op_type == OP_RV2HV ||
3516 curop->op_type == OP_RV2GV) {
3517 if (lastop->op_type != OP_GV) /* funny deref? */
3520 else if (curop->op_type == OP_PUSHRE) {
3521 if (((PMOP*)curop)->op_pmreplroot) {
3523 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3525 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3527 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3529 SvCUR(gv) = PL_generation;
3538 o->op_private |= OPpASSIGN_COMMON;
3540 if (right && right->op_type == OP_SPLIT) {
3542 if ((tmpop = ((LISTOP*)right)->op_first) &&
3543 tmpop->op_type == OP_PUSHRE)
3545 PMOP *pm = (PMOP*)tmpop;
3546 if (left->op_type == OP_RV2AV &&
3547 !(left->op_private & OPpLVAL_INTRO) &&
3548 !(o->op_private & OPpASSIGN_COMMON) )
3550 tmpop = ((UNOP*)left)->op_first;
3551 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3553 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3554 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3556 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3557 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3559 pm->op_pmflags |= PMf_ONCE;
3560 tmpop = cUNOPo->op_first; /* to list (nulled) */
3561 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3562 tmpop->op_sibling = Nullop; /* don't free split */
3563 right->op_next = tmpop->op_next; /* fix starting loc */
3564 op_free(o); /* blow off assign */
3565 right->op_flags &= ~OPf_WANT;
3566 /* "I don't know and I don't care." */
3571 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3572 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3574 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3576 sv_setiv(sv, PL_modcount+1);
3584 right = newOP(OP_UNDEF, 0);
3585 if (right->op_type == OP_READLINE) {
3586 right->op_flags |= OPf_STACKED;
3587 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3590 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3591 o = newBINOP(OP_SASSIGN, flags,
3592 scalar(right), mod(scalar(left), OP_SASSIGN) );
3604 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3606 U32 seq = intro_my();
3609 NewOp(1101, cop, 1, COP);
3610 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3611 cop->op_type = OP_DBSTATE;
3612 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3615 cop->op_type = OP_NEXTSTATE;
3616 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3618 cop->op_flags = flags;
3619 cop->op_private = (PL_hints & HINT_BYTE);
3621 cop->op_private |= NATIVE_HINTS;
3623 PL_compiling.op_private = cop->op_private;
3624 cop->op_next = (OP*)cop;
3627 cop->cop_label = label;
3628 PL_hints |= HINT_BLOCK_SCOPE;
3631 cop->cop_arybase = PL_curcop->cop_arybase;
3632 if (specialWARN(PL_curcop->cop_warnings))
3633 cop->cop_warnings = PL_curcop->cop_warnings ;
3635 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3636 if (specialCopIO(PL_curcop->cop_io))
3637 cop->cop_io = PL_curcop->cop_io;
3639 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3642 if (PL_copline == NOLINE)
3643 CopLINE_set(cop, CopLINE(PL_curcop));
3645 CopLINE_set(cop, PL_copline);
3646 PL_copline = NOLINE;
3649 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3651 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3653 CopSTASH_set(cop, PL_curstash);
3655 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3656 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3657 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3658 (void)SvIOK_on(*svp);
3659 SvIVX(*svp) = PTR2IV(cop);
3663 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3666 /* "Introduce" my variables to visible status. */
3674 if (! PL_min_intro_pending)
3675 return PL_cop_seqmax;
3677 svp = AvARRAY(PL_comppad_name);
3678 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3679 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3680 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3681 SvNVX(sv) = (NV)PL_cop_seqmax;
3684 PL_min_intro_pending = 0;
3685 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3686 return PL_cop_seqmax++;
3690 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3692 return new_logop(type, flags, &first, &other);
3696 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3700 OP *first = *firstp;
3701 OP *other = *otherp;
3703 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3704 return newBINOP(type, flags, scalar(first), scalar(other));
3706 scalarboolean(first);
3707 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3708 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3709 if (type == OP_AND || type == OP_OR) {
3715 first = *firstp = cUNOPo->op_first;
3717 first->op_next = o->op_next;
3718 cUNOPo->op_first = Nullop;
3722 if (first->op_type == OP_CONST) {
3723 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3724 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3725 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3736 else if (first->op_type == OP_WANTARRAY) {
3742 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3743 OP *k1 = ((UNOP*)first)->op_first;
3744 OP *k2 = k1->op_sibling;
3746 switch (first->op_type)
3749 if (k2 && k2->op_type == OP_READLINE
3750 && (k2->op_flags & OPf_STACKED)
3751 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3753 warnop = k2->op_type;
3758 if (k1->op_type == OP_READDIR
3759 || k1->op_type == OP_GLOB
3760 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3761 || k1->op_type == OP_EACH)
3763 warnop = ((k1->op_type == OP_NULL)
3764 ? k1->op_targ : k1->op_type);
3769 line_t oldline = CopLINE(PL_curcop);
3770 CopLINE_set(PL_curcop, PL_copline);
3771 Perl_warner(aTHX_ WARN_MISC,
3772 "Value of %s%s can be \"0\"; test with defined()",
3774 ((warnop == OP_READLINE || warnop == OP_GLOB)
3775 ? " construct" : "() operator"));
3776 CopLINE_set(PL_curcop, oldline);
3783 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3784 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3786 NewOp(1101, logop, 1, LOGOP);
3788 logop->op_type = type;
3789 logop->op_ppaddr = PL_ppaddr[type];
3790 logop->op_first = first;
3791 logop->op_flags = flags | OPf_KIDS;
3792 logop->op_other = LINKLIST(other);
3793 logop->op_private = 1 | (flags >> 8);
3795 /* establish postfix order */
3796 logop->op_next = LINKLIST(first);
3797 first->op_next = (OP*)logop;
3798 first->op_sibling = other;
3800 o = newUNOP(OP_NULL, 0, (OP*)logop);
3807 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3814 return newLOGOP(OP_AND, 0, first, trueop);
3816 return newLOGOP(OP_OR, 0, first, falseop);
3818 scalarboolean(first);
3819 if (first->op_type == OP_CONST) {
3820 if (SvTRUE(((SVOP*)first)->op_sv)) {
3831 else if (first->op_type == OP_WANTARRAY) {
3835 NewOp(1101, logop, 1, LOGOP);
3836 logop->op_type = OP_COND_EXPR;
3837 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3838 logop->op_first = first;
3839 logop->op_flags = flags | OPf_KIDS;
3840 logop->op_private = 1 | (flags >> 8);
3841 logop->op_other = LINKLIST(trueop);
3842 logop->op_next = LINKLIST(falseop);
3845 /* establish postfix order */
3846 start = LINKLIST(first);
3847 first->op_next = (OP*)logop;
3849 first->op_sibling = trueop;
3850 trueop->op_sibling = falseop;
3851 o = newUNOP(OP_NULL, 0, (OP*)logop);
3853 trueop->op_next = falseop->op_next = o;
3860 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3868 NewOp(1101, range, 1, LOGOP);
3870 range->op_type = OP_RANGE;
3871 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3872 range->op_first = left;
3873 range->op_flags = OPf_KIDS;
3874 leftstart = LINKLIST(left);
3875 range->op_other = LINKLIST(right);
3876 range->op_private = 1 | (flags >> 8);
3878 left->op_sibling = right;
3880 range->op_next = (OP*)range;
3881 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3882 flop = newUNOP(OP_FLOP, 0, flip);
3883 o = newUNOP(OP_NULL, 0, flop);
3885 range->op_next = leftstart;
3887 left->op_next = flip;
3888 right->op_next = flop;
3890 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3891 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3892 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3893 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3895 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3896 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3899 if (!flip->op_private || !flop->op_private)
3900 linklist(o); /* blow off optimizer unless constant */
3906 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3910 int once = block && block->op_flags & OPf_SPECIAL &&
3911 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3914 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3915 return block; /* do {} while 0 does once */
3916 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3917 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3918 expr = newUNOP(OP_DEFINED, 0,
3919 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3920 } else if (expr->op_flags & OPf_KIDS) {
3921 OP *k1 = ((UNOP*)expr)->op_first;
3922 OP *k2 = (k1) ? k1->op_sibling : NULL;
3923 switch (expr->op_type) {
3925 if (k2 && k2->op_type == OP_READLINE
3926 && (k2->op_flags & OPf_STACKED)
3927 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3928 expr = newUNOP(OP_DEFINED, 0, expr);
3932 if (k1->op_type == OP_READDIR
3933 || k1->op_type == OP_GLOB
3934 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3935 || k1->op_type == OP_EACH)
3936 expr = newUNOP(OP_DEFINED, 0, expr);
3942 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3943 o = new_logop(OP_AND, 0, &expr, &listop);
3946 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3948 if (once && o != listop)
3949 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3952 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3954 o->op_flags |= flags;
3956 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3961 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3970 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3971 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3972 expr = newUNOP(OP_DEFINED, 0,
3973 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3974 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3975 OP *k1 = ((UNOP*)expr)->op_first;
3976 OP *k2 = (k1) ? k1->op_sibling : NULL;
3977 switch (expr->op_type) {
3979 if (k2 && k2->op_type == OP_READLINE
3980 && (k2->op_flags & OPf_STACKED)
3981 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3982 expr = newUNOP(OP_DEFINED, 0, expr);
3986 if (k1->op_type == OP_READDIR
3987 || k1->op_type == OP_GLOB
3988 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3989 || k1->op_type == OP_EACH)
3990 expr = newUNOP(OP_DEFINED, 0, expr);
3996 block = newOP(OP_NULL, 0);
3998 block = scope(block);
4002 next = LINKLIST(cont);
4005 OP *unstack = newOP(OP_UNSTACK, 0);
4008 cont = append_elem(OP_LINESEQ, cont, unstack);
4009 if ((line_t)whileline != NOLINE) {
4010 PL_copline = whileline;
4011 cont = append_elem(OP_LINESEQ, cont,
4012 newSTATEOP(0, Nullch, Nullop));
4016 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4017 redo = LINKLIST(listop);
4020 PL_copline = whileline;
4022 o = new_logop(OP_AND, 0, &expr, &listop);
4023 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4024 op_free(expr); /* oops, it's a while (0) */
4026 return Nullop; /* listop already freed by new_logop */
4029 ((LISTOP*)listop)->op_last->op_next = condop =
4030 (o == listop ? redo : LINKLIST(o));
4036 NewOp(1101,loop,1,LOOP);
4037 loop->op_type = OP_ENTERLOOP;
4038 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4039 loop->op_private = 0;
4040 loop->op_next = (OP*)loop;
4043 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4045 loop->op_redoop = redo;
4046 loop->op_lastop = o;
4047 o->op_private |= loopflags;
4050 loop->op_nextop = next;
4052 loop->op_nextop = o;
4054 o->op_flags |= flags;
4055 o->op_private |= (flags >> 8);
4060 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4068 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4069 sv->op_type = OP_RV2GV;
4070 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4072 else if (sv->op_type == OP_PADSV) { /* private variable */
4073 padoff = sv->op_targ;
4078 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4079 padoff = sv->op_targ;
4081 iterflags |= OPf_SPECIAL;
4086 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4090 padoff = find_threadsv("_");
4091 iterflags |= OPf_SPECIAL;
4093 sv = newGVOP(OP_GV, 0, PL_defgv);
4096 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4097 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4098 iterflags |= OPf_STACKED;
4100 else if (expr->op_type == OP_NULL &&
4101 (expr->op_flags & OPf_KIDS) &&
4102 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4104 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4105 * set the STACKED flag to indicate that these values are to be
4106 * treated as min/max values by 'pp_iterinit'.
4108 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4109 LOGOP* range = (LOGOP*) flip->op_first;
4110 OP* left = range->op_first;
4111 OP* right = left->op_sibling;
4114 range->op_flags &= ~OPf_KIDS;
4115 range->op_first = Nullop;
4117 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4118 listop->op_first->op_next = range->op_next;
4119 left->op_next = range->op_other;
4120 right->op_next = (OP*)listop;
4121 listop->op_next = listop->op_first;
4124 expr = (OP*)(listop);
4126 iterflags |= OPf_STACKED;
4129 expr = mod(force_list(expr), OP_GREPSTART);
4133 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4134 append_elem(OP_LIST, expr, scalar(sv))));
4135 assert(!loop->op_next);
4136 #ifdef PL_OP_SLAB_ALLOC
4139 NewOp(1234,tmp,1,LOOP);
4140 Copy(loop,tmp,1,LOOP);
4144 Renew(loop, 1, LOOP);
4146 loop->op_targ = padoff;
4147 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4148 PL_copline = forline;
4149 return newSTATEOP(0, label, wop);
4153 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4158 if (type != OP_GOTO || label->op_type == OP_CONST) {
4159 /* "last()" means "last" */
4160 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4161 o = newOP(type, OPf_SPECIAL);
4163 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4164 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4170 if (label->op_type == OP_ENTERSUB)
4171 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4172 o = newUNOP(type, OPf_STACKED, label);
4174 PL_hints |= HINT_BLOCK_SCOPE;
4179 Perl_cv_undef(pTHX_ CV *cv)
4183 MUTEX_DESTROY(CvMUTEXP(cv));
4184 Safefree(CvMUTEXP(cv));
4187 #endif /* USE_THREADS */
4189 if (!CvXSUB(cv) && CvROOT(cv)) {
4191 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4192 Perl_croak(aTHX_ "Can't undef active subroutine");
4195 Perl_croak(aTHX_ "Can't undef active subroutine");
4196 #endif /* USE_THREADS */
4199 SAVEVPTR(PL_curpad);
4202 op_free(CvROOT(cv));
4203 CvROOT(cv) = Nullop;
4206 SvPOK_off((SV*)cv); /* forget prototype */
4208 /* Since closure prototypes have the same lifetime as the containing
4209 * CV, they don't hold a refcount on the outside CV. This avoids
4210 * the refcount loop between the outer CV (which keeps a refcount to
4211 * the closure prototype in the pad entry for pp_anoncode()) and the
4212 * closure prototype, and the ensuing memory leak. --GSAR */
4213 if (!CvANON(cv) || CvCLONED(cv))
4214 SvREFCNT_dec(CvOUTSIDE(cv));
4215 CvOUTSIDE(cv) = Nullcv;
4217 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4220 if (CvPADLIST(cv)) {
4221 /* may be during global destruction */
4222 if (SvREFCNT(CvPADLIST(cv))) {
4223 I32 i = AvFILLp(CvPADLIST(cv));
4225 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4226 SV* sv = svp ? *svp : Nullsv;
4229 if (sv == (SV*)PL_comppad_name)
4230 PL_comppad_name = Nullav;
4231 else if (sv == (SV*)PL_comppad) {
4232 PL_comppad = Nullav;
4233 PL_curpad = Null(SV**);
4237 SvREFCNT_dec((SV*)CvPADLIST(cv));
4239 CvPADLIST(cv) = Nullav;
4244 #ifdef DEBUG_CLOSURES
4246 S_cv_dump(pTHX_ CV *cv)
4249 CV *outside = CvOUTSIDE(cv);
4250 AV* padlist = CvPADLIST(cv);
4257 PerlIO_printf(Perl_debug_log,
4258 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4260 (CvANON(cv) ? "ANON"
4261 : (cv == PL_main_cv) ? "MAIN"
4262 : CvUNIQUE(cv) ? "UNIQUE"
4263 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4266 : CvANON(outside) ? "ANON"
4267 : (outside == PL_main_cv) ? "MAIN"
4268 : CvUNIQUE(outside) ? "UNIQUE"
4269 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4274 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4275 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4276 pname = AvARRAY(pad_name);
4277 ppad = AvARRAY(pad);
4279 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4280 if (SvPOK(pname[ix]))
4281 PerlIO_printf(Perl_debug_log,
4282 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4283 (int)ix, PTR2UV(ppad[ix]),
4284 SvFAKE(pname[ix]) ? "FAKE " : "",
4286 (IV)I_32(SvNVX(pname[ix])),
4289 #endif /* DEBUGGING */
4291 #endif /* DEBUG_CLOSURES */
4294 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4298 AV* protopadlist = CvPADLIST(proto);
4299 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4300 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4301 SV** pname = AvARRAY(protopad_name);
4302 SV** ppad = AvARRAY(protopad);
4303 I32 fname = AvFILLp(protopad_name);
4304 I32 fpad = AvFILLp(protopad);
4308 assert(!CvUNIQUE(proto));
4312 SAVESPTR(PL_comppad_name);
4313 SAVESPTR(PL_compcv);
4315 cv = PL_compcv = (CV*)NEWSV(1104,0);
4316 sv_upgrade((SV *)cv, SvTYPE(proto));
4317 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4321 New(666, CvMUTEXP(cv), 1, perl_mutex);
4322 MUTEX_INIT(CvMUTEXP(cv));
4324 #endif /* USE_THREADS */
4325 CvFILE(cv) = CvFILE(proto);
4326 CvGV(cv) = CvGV(proto);
4327 CvSTASH(cv) = CvSTASH(proto);
4328 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4329 CvSTART(cv) = CvSTART(proto);
4331 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4334 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4336 PL_comppad_name = newAV();
4337 for (ix = fname; ix >= 0; ix--)
4338 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4340 PL_comppad = newAV();
4342 comppadlist = newAV();
4343 AvREAL_off(comppadlist);
4344 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4345 av_store(comppadlist, 1, (SV*)PL_comppad);
4346 CvPADLIST(cv) = comppadlist;
4347 av_fill(PL_comppad, AvFILLp(protopad));
4348 PL_curpad = AvARRAY(PL_comppad);
4350 av = newAV(); /* will be @_ */
4352 av_store(PL_comppad, 0, (SV*)av);
4353 AvFLAGS(av) = AVf_REIFY;
4355 for (ix = fpad; ix > 0; ix--) {
4356 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4357 if (namesv && namesv != &PL_sv_undef) {
4358 char *name = SvPVX(namesv); /* XXX */
4359 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4360 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4361 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4363 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4365 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4367 else { /* our own lexical */
4370 /* anon code -- we'll come back for it */
4371 sv = SvREFCNT_inc(ppad[ix]);
4373 else if (*name == '@')
4375 else if (*name == '%')
4384 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4385 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4388 SV* sv = NEWSV(0,0);
4394 /* Now that vars are all in place, clone nested closures. */
4396 for (ix = fpad; ix > 0; ix--) {
4397 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4399 && namesv != &PL_sv_undef
4400 && !(SvFLAGS(namesv) & SVf_FAKE)
4401 && *SvPVX(namesv) == '&'
4402 && CvCLONE(ppad[ix]))
4404 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4405 SvREFCNT_dec(ppad[ix]);
4408 PL_curpad[ix] = (SV*)kid;
4412 #ifdef DEBUG_CLOSURES
4413 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4415 PerlIO_printf(Perl_debug_log, " from:\n");
4417 PerlIO_printf(Perl_debug_log, " to:\n");
4424 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4426 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4428 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4435 Perl_cv_clone(pTHX_ CV *proto)
4438 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4439 cv = cv_clone2(proto, CvOUTSIDE(proto));
4440 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4445 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4447 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4448 SV* msg = sv_newmortal();
4452 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4453 sv_setpv(msg, "Prototype mismatch:");
4455 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4457 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4458 sv_catpv(msg, " vs ");
4460 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4462 sv_catpv(msg, "none");
4463 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4467 static void const_sv_xsub(pTHXo_ CV* cv);
4470 =for apidoc cv_const_sv
4472 If C<cv> is a constant sub eligible for inlining. returns the constant
4473 value returned by the sub. Otherwise, returns NULL.
4475 Constant subs can be created with C<newCONSTSUB> or as described in
4476 L<perlsub/"Constant Functions">.
4481 Perl_cv_const_sv(pTHX_ CV *cv)
4483 if (!cv || !CvCONST(cv))
4485 return (SV*)CvXSUBANY(cv).any_ptr;
4489 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4496 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4497 o = cLISTOPo->op_first->op_sibling;
4499 for (; o; o = o->op_next) {
4500 OPCODE type = o->op_type;
4502 if (sv && o->op_next == o)
4504 if (o->op_next != o) {
4505 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4507 if (type == OP_DBSTATE)
4510 if (type == OP_LEAVESUB || type == OP_RETURN)
4514 if (type == OP_CONST && cSVOPo->op_sv)
4516 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4517 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4518 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4522 /* We get here only from cv_clone2() while creating a closure.
4523 Copy the const value here instead of in cv_clone2 so that
4524 SvREADONLY_on doesn't lead to problems when leaving
4529 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4541 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4551 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4555 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4557 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4561 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4567 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4572 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4573 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4574 SV *sv = sv_newmortal();
4575 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4576 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4581 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4582 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4592 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4593 maximum a prototype before. */
4594 if (SvTYPE(gv) > SVt_NULL) {
4595 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4596 && ckWARN_d(WARN_PROTOTYPE))
4598 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4600 cv_ckproto((CV*)gv, NULL, ps);
4603 sv_setpv((SV*)gv, ps);
4605 sv_setiv((SV*)gv, -1);
4606 SvREFCNT_dec(PL_compcv);
4607 cv = PL_compcv = NULL;
4608 PL_sub_generation++;
4612 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4614 #ifdef GV_SHARED_CHECK
4615 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4616 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4620 if (!block || !ps || *ps || attrs)
4623 const_sv = op_const_sv(block, Nullcv);
4626 bool exists = CvROOT(cv) || CvXSUB(cv);
4628 #ifdef GV_SHARED_CHECK
4629 if (exists && GvSHARED(gv)) {
4630 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4634 /* if the subroutine doesn't exist and wasn't pre-declared
4635 * with a prototype, assume it will be AUTOLOADed,
4636 * skipping the prototype check
4638 if (exists || SvPOK(cv))
4639 cv_ckproto(cv, gv, ps);
4640 /* already defined (or promised)? */
4641 if (exists || GvASSUMECV(gv)) {
4642 if (!block && !attrs) {
4643 /* just a "sub foo;" when &foo is already defined */
4644 SAVEFREESV(PL_compcv);
4647 /* ahem, death to those who redefine active sort subs */
4648 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4649 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4651 if (ckWARN(WARN_REDEFINE)
4653 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4655 line_t oldline = CopLINE(PL_curcop);
4656 CopLINE_set(PL_curcop, PL_copline);
4657 Perl_warner(aTHX_ WARN_REDEFINE,
4658 CvCONST(cv) ? "Constant subroutine %s redefined"
4659 : "Subroutine %s redefined", name);
4660 CopLINE_set(PL_curcop, oldline);
4668 SvREFCNT_inc(const_sv);
4670 assert(!CvROOT(cv) && !CvCONST(cv));
4671 sv_setpv((SV*)cv, ""); /* prototype is "" */
4672 CvXSUBANY(cv).any_ptr = const_sv;
4673 CvXSUB(cv) = const_sv_xsub;
4678 cv = newCONSTSUB(NULL, name, const_sv);
4681 SvREFCNT_dec(PL_compcv);
4683 PL_sub_generation++;
4690 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4691 * before we clobber PL_compcv.
4695 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4696 stash = GvSTASH(CvGV(cv));
4697 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4698 stash = CvSTASH(cv);
4700 stash = PL_curstash;
4703 /* possibly about to re-define existing subr -- ignore old cv */
4704 rcv = (SV*)PL_compcv;
4705 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4706 stash = GvSTASH(gv);
4708 stash = PL_curstash;
4710 apply_attrs(stash, rcv, attrs);
4712 if (cv) { /* must reuse cv if autoloaded */
4714 /* got here with just attrs -- work done, so bug out */
4715 SAVEFREESV(PL_compcv);
4719 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4720 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4721 CvOUTSIDE(PL_compcv) = 0;
4722 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4723 CvPADLIST(PL_compcv) = 0;
4724 /* inner references to PL_compcv must be fixed up ... */
4726 AV *padlist = CvPADLIST(cv);
4727 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4728 AV *comppad = (AV*)AvARRAY(padlist)[1];
4729 SV **namepad = AvARRAY(comppad_name);
4730 SV **curpad = AvARRAY(comppad);
4731 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4732 SV *namesv = namepad[ix];
4733 if (namesv && namesv != &PL_sv_undef
4734 && *SvPVX(namesv) == '&')
4736 CV *innercv = (CV*)curpad[ix];
4737 if (CvOUTSIDE(innercv) == PL_compcv) {
4738 CvOUTSIDE(innercv) = cv;
4739 if (!CvANON(innercv) || CvCLONED(innercv)) {
4740 (void)SvREFCNT_inc(cv);
4741 SvREFCNT_dec(PL_compcv);
4747 /* ... before we throw it away */
4748 SvREFCNT_dec(PL_compcv);
4755 PL_sub_generation++;
4759 CvFILE(cv) = CopFILE(PL_curcop);
4760 CvSTASH(cv) = PL_curstash;
4763 if (!CvMUTEXP(cv)) {
4764 New(666, CvMUTEXP(cv), 1, perl_mutex);
4765 MUTEX_INIT(CvMUTEXP(cv));
4767 #endif /* USE_THREADS */
4770 sv_setpv((SV*)cv, ps);
4772 if (PL_error_count) {
4776 char *s = strrchr(name, ':');
4778 if (strEQ(s, "BEGIN")) {
4780 "BEGIN not safe after errors--compilation aborted";
4781 if (PL_in_eval & EVAL_KEEPERR)
4782 Perl_croak(aTHX_ not_safe);
4784 /* force display of errors found but not reported */
4785 sv_catpv(ERRSV, not_safe);
4786 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4794 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4795 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4798 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4799 mod(scalarseq(block), OP_LEAVESUBLV));
4802 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4804 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4805 OpREFCNT_set(CvROOT(cv), 1);
4806 CvSTART(cv) = LINKLIST(CvROOT(cv));
4807 CvROOT(cv)->op_next = 0;
4810 /* now that optimizer has done its work, adjust pad values */
4812 SV **namep = AvARRAY(PL_comppad_name);
4813 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4816 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4819 * The only things that a clonable function needs in its
4820 * pad are references to outer lexicals and anonymous subs.
4821 * The rest are created anew during cloning.
4823 if (!((namesv = namep[ix]) != Nullsv &&
4824 namesv != &PL_sv_undef &&
4826 *SvPVX(namesv) == '&')))
4828 SvREFCNT_dec(PL_curpad[ix]);
4829 PL_curpad[ix] = Nullsv;
4832 assert(!CvCONST(cv));
4833 if (ps && !*ps && op_const_sv(block, cv))
4837 AV *av = newAV(); /* Will be @_ */
4839 av_store(PL_comppad, 0, (SV*)av);
4840 AvFLAGS(av) = AVf_REIFY;
4842 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4843 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4845 if (!SvPADMY(PL_curpad[ix]))
4846 SvPADTMP_on(PL_curpad[ix]);
4850 /* If a potential closure prototype, don't keep a refcount on outer CV.
4851 * This is okay as the lifetime of the prototype is tied to the
4852 * lifetime of the outer CV. Avoids memory leak due to reference
4855 SvREFCNT_dec(CvOUTSIDE(cv));
4857 if (name || aname) {
4859 char *tname = (name ? name : aname);
4861 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4862 SV *sv = NEWSV(0,0);
4863 SV *tmpstr = sv_newmortal();
4864 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4868 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4870 (long)PL_subline, (long)CopLINE(PL_curcop));
4871 gv_efullname3(tmpstr, gv, Nullch);
4872 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4873 hv = GvHVn(db_postponed);
4874 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4875 && (pcv = GvCV(db_postponed)))
4881 call_sv((SV*)pcv, G_DISCARD);
4885 if ((s = strrchr(tname,':')))
4890 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4893 if (strEQ(s, "BEGIN")) {
4894 I32 oldscope = PL_scopestack_ix;
4896 SAVECOPFILE(&PL_compiling);
4897 SAVECOPLINE(&PL_compiling);
4899 sv_setsv(PL_rs, PL_nrs);
4902 PL_beginav = newAV();
4903 DEBUG_x( dump_sub(gv) );
4904 av_push(PL_beginav, (SV*)cv);
4905 GvCV(gv) = 0; /* cv has been hijacked */
4906 call_list(oldscope, PL_beginav);
4908 PL_curcop = &PL_compiling;
4909 PL_compiling.op_private = PL_hints;
4912 else if (strEQ(s, "END") && !PL_error_count) {
4915 DEBUG_x( dump_sub(gv) );
4916 av_unshift(PL_endav, 1);
4917 av_store(PL_endav, 0, (SV*)cv);
4918 GvCV(gv) = 0; /* cv has been hijacked */
4920 else if (strEQ(s, "CHECK") && !PL_error_count) {
4922 PL_checkav = newAV();
4923 DEBUG_x( dump_sub(gv) );
4924 if (PL_main_start && ckWARN(WARN_VOID))
4925 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4926 av_unshift(PL_checkav, 1);
4927 av_store(PL_checkav, 0, (SV*)cv);
4928 GvCV(gv) = 0; /* cv has been hijacked */
4930 else if (strEQ(s, "INIT") && !PL_error_count) {
4932 PL_initav = newAV();
4933 DEBUG_x( dump_sub(gv) );
4934 if (PL_main_start && ckWARN(WARN_VOID))
4935 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4936 av_push(PL_initav, (SV*)cv);
4937 GvCV(gv) = 0; /* cv has been hijacked */
4942 PL_copline = NOLINE;
4947 /* XXX unsafe for threads if eval_owner isn't held */
4949 =for apidoc newCONSTSUB
4951 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4952 eligible for inlining at compile-time.
4958 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4964 SAVECOPLINE(PL_curcop);
4965 CopLINE_set(PL_curcop, PL_copline);
4968 PL_hints &= ~HINT_BLOCK_SCOPE;
4971 SAVESPTR(PL_curstash);
4972 SAVECOPSTASH(PL_curcop);
4973 PL_curstash = stash;
4975 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4977 CopSTASH(PL_curcop) = stash;
4981 cv = newXS(name, const_sv_xsub, __FILE__);
4982 CvXSUBANY(cv).any_ptr = sv;
4984 sv_setpv((SV*)cv, ""); /* prototype is "" */
4992 =for apidoc U||newXS
4994 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5000 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5002 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5005 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5007 /* just a cached method */
5011 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5012 /* already defined (or promised) */
5013 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5014 && HvNAME(GvSTASH(CvGV(cv)))
5015 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5016 line_t oldline = CopLINE(PL_curcop);
5017 if (PL_copline != NOLINE)
5018 CopLINE_set(PL_curcop, PL_copline);
5019 Perl_warner(aTHX_ WARN_REDEFINE,
5020 CvCONST(cv) ? "Constant subroutine %s redefined"
5021 : "Subroutine %s redefined"
5023 CopLINE_set(PL_curcop, oldline);
5030 if (cv) /* must reuse cv if autoloaded */
5033 cv = (CV*)NEWSV(1105,0);
5034 sv_upgrade((SV *)cv, SVt_PVCV);
5038 PL_sub_generation++;
5043 New(666, CvMUTEXP(cv), 1, perl_mutex);
5044 MUTEX_INIT(CvMUTEXP(cv));
5046 #endif /* USE_THREADS */
5047 (void)gv_fetchfile(filename);
5048 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5049 an external constant string */
5050 CvXSUB(cv) = subaddr;
5053 char *s = strrchr(name,':');
5059 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5062 if (strEQ(s, "BEGIN")) {
5064 PL_beginav = newAV();
5065 av_push(PL_beginav, (SV*)cv);
5066 GvCV(gv) = 0; /* cv has been hijacked */
5068 else if (strEQ(s, "END")) {
5071 av_unshift(PL_endav, 1);
5072 av_store(PL_endav, 0, (SV*)cv);
5073 GvCV(gv) = 0; /* cv has been hijacked */
5075 else if (strEQ(s, "CHECK")) {
5077 PL_checkav = newAV();
5078 if (PL_main_start && ckWARN(WARN_VOID))
5079 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5080 av_unshift(PL_checkav, 1);
5081 av_store(PL_checkav, 0, (SV*)cv);
5082 GvCV(gv) = 0; /* cv has been hijacked */
5084 else if (strEQ(s, "INIT")) {
5086 PL_initav = newAV();
5087 if (PL_main_start && ckWARN(WARN_VOID))
5088 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5089 av_push(PL_initav, (SV*)cv);
5090 GvCV(gv) = 0; /* cv has been hijacked */
5101 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5110 name = SvPVx(cSVOPo->op_sv, n_a);
5113 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5114 #ifdef GV_SHARED_CHECK
5116 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5120 if ((cv = GvFORM(gv))) {
5121 if (ckWARN(WARN_REDEFINE)) {
5122 line_t oldline = CopLINE(PL_curcop);
5124 CopLINE_set(PL_curcop, PL_copline);
5125 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5126 CopLINE_set(PL_curcop, oldline);
5133 CvFILE(cv) = CopFILE(PL_curcop);
5135 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5136 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5137 SvPADTMP_on(PL_curpad[ix]);
5140 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5141 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5142 OpREFCNT_set(CvROOT(cv), 1);
5143 CvSTART(cv) = LINKLIST(CvROOT(cv));
5144 CvROOT(cv)->op_next = 0;
5147 PL_copline = NOLINE;
5152 Perl_newANONLIST(pTHX_ OP *o)
5154 return newUNOP(OP_REFGEN, 0,
5155 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5159 Perl_newANONHASH(pTHX_ OP *o)
5161 return newUNOP(OP_REFGEN, 0,
5162 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5166 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5168 return newANONATTRSUB(floor, proto, Nullop, block);
5172 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5174 return newUNOP(OP_REFGEN, 0,
5175 newSVOP(OP_ANONCODE, 0,
5176 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5180 Perl_oopsAV(pTHX_ OP *o)
5182 switch (o->op_type) {
5184 o->op_type = OP_PADAV;
5185 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5186 return ref(o, OP_RV2AV);
5189 o->op_type = OP_RV2AV;
5190 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5195 if (ckWARN_d(WARN_INTERNAL))
5196 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5203 Perl_oopsHV(pTHX_ OP *o)
5205 switch (o->op_type) {
5208 o->op_type = OP_PADHV;
5209 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5210 return ref(o, OP_RV2HV);
5214 o->op_type = OP_RV2HV;
5215 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5220 if (ckWARN_d(WARN_INTERNAL))
5221 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5228 Perl_newAVREF(pTHX_ OP *o)
5230 if (o->op_type == OP_PADANY) {
5231 o->op_type = OP_PADAV;
5232 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5235 return newUNOP(OP_RV2AV, 0, scalar(o));
5239 Perl_newGVREF(pTHX_ I32 type, OP *o)
5241 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5242 return newUNOP(OP_NULL, 0, o);
5243 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5247 Perl_newHVREF(pTHX_ OP *o)
5249 if (o->op_type == OP_PADANY) {
5250 o->op_type = OP_PADHV;
5251 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5254 return newUNOP(OP_RV2HV, 0, scalar(o));
5258 Perl_oopsCV(pTHX_ OP *o)
5260 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5266 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5268 return newUNOP(OP_RV2CV, flags, scalar(o));
5272 Perl_newSVREF(pTHX_ OP *o)
5274 if (o->op_type == OP_PADANY) {
5275 o->op_type = OP_PADSV;
5276 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5279 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5280 o->op_flags |= OPpDONE_SVREF;
5283 return newUNOP(OP_RV2SV, 0, scalar(o));
5286 /* Check routines. */
5289 Perl_ck_anoncode(pTHX_ OP *o)
5294 name = NEWSV(1106,0);
5295 sv_upgrade(name, SVt_PVNV);
5296 sv_setpvn(name, "&", 1);
5299 ix = pad_alloc(o->op_type, SVs_PADMY);
5300 av_store(PL_comppad_name, ix, name);
5301 av_store(PL_comppad, ix, cSVOPo->op_sv);
5302 SvPADMY_on(cSVOPo->op_sv);
5303 cSVOPo->op_sv = Nullsv;
5304 cSVOPo->op_targ = ix;
5309 Perl_ck_bitop(pTHX_ OP *o)
5311 o->op_private = PL_hints;
5316 Perl_ck_concat(pTHX_ OP *o)
5318 if (cUNOPo->op_first->op_type == OP_CONCAT)
5319 o->op_flags |= OPf_STACKED;
5324 Perl_ck_spair(pTHX_ OP *o)
5326 if (o->op_flags & OPf_KIDS) {
5329 OPCODE type = o->op_type;
5330 o = modkids(ck_fun(o), type);
5331 kid = cUNOPo->op_first;
5332 newop = kUNOP->op_first->op_sibling;
5334 (newop->op_sibling ||
5335 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5336 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5337 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5341 op_free(kUNOP->op_first);
5342 kUNOP->op_first = newop;
5344 o->op_ppaddr = PL_ppaddr[++o->op_type];
5349 Perl_ck_delete(pTHX_ OP *o)
5353 if (o->op_flags & OPf_KIDS) {
5354 OP *kid = cUNOPo->op_first;
5355 switch (kid->op_type) {
5357 o->op_flags |= OPf_SPECIAL;
5360 o->op_private |= OPpSLICE;
5363 o->op_flags |= OPf_SPECIAL;
5368 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5369 PL_op_desc[o->op_type]);
5377 Perl_ck_eof(pTHX_ OP *o)
5379 I32 type = o->op_type;
5381 if (o->op_flags & OPf_KIDS) {
5382 if (cLISTOPo->op_first->op_type == OP_STUB) {
5384 o = newUNOP(type, OPf_SPECIAL,
5385 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5393 Perl_ck_eval(pTHX_ OP *o)
5395 PL_hints |= HINT_BLOCK_SCOPE;
5396 if (o->op_flags & OPf_KIDS) {
5397 SVOP *kid = (SVOP*)cUNOPo->op_first;
5400 o->op_flags &= ~OPf_KIDS;
5403 else if (kid->op_type == OP_LINESEQ) {
5406 kid->op_next = o->op_next;
5407 cUNOPo->op_first = 0;
5410 NewOp(1101, enter, 1, LOGOP);
5411 enter->op_type = OP_ENTERTRY;
5412 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5413 enter->op_private = 0;
5415 /* establish postfix order */
5416 enter->op_next = (OP*)enter;
5418 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5419 o->op_type = OP_LEAVETRY;
5420 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5421 enter->op_other = o;
5429 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5431 o->op_targ = (PADOFFSET)PL_hints;
5436 Perl_ck_exit(pTHX_ OP *o)
5439 HV *table = GvHV(PL_hintgv);
5441 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5442 if (svp && *svp && SvTRUE(*svp))
5443 o->op_private |= OPpEXIT_VMSISH;
5450 Perl_ck_exec(pTHX_ OP *o)
5453 if (o->op_flags & OPf_STACKED) {
5455 kid = cUNOPo->op_first->op_sibling;
5456 if (kid->op_type == OP_RV2GV)
5465 Perl_ck_exists(pTHX_ OP *o)
5468 if (o->op_flags & OPf_KIDS) {
5469 OP *kid = cUNOPo->op_first;
5470 if (kid->op_type == OP_ENTERSUB) {
5471 (void) ref(kid, o->op_type);
5472 if (kid->op_type != OP_RV2CV && !PL_error_count)
5473 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5474 PL_op_desc[o->op_type]);
5475 o->op_private |= OPpEXISTS_SUB;
5477 else if (kid->op_type == OP_AELEM)
5478 o->op_flags |= OPf_SPECIAL;
5479 else if (kid->op_type != OP_HELEM)
5480 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5481 PL_op_desc[o->op_type]);
5489 Perl_ck_gvconst(pTHX_ register OP *o)
5491 o = fold_constants(o);
5492 if (o->op_type == OP_CONST)
5499 Perl_ck_rvconst(pTHX_ register OP *o)
5501 SVOP *kid = (SVOP*)cUNOPo->op_first;
5503 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5504 if (kid->op_type == OP_CONST) {
5508 SV *kidsv = kid->op_sv;
5511 /* Is it a constant from cv_const_sv()? */
5512 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5513 SV *rsv = SvRV(kidsv);
5514 int svtype = SvTYPE(rsv);
5515 char *badtype = Nullch;
5517 switch (o->op_type) {
5519 if (svtype > SVt_PVMG)
5520 badtype = "a SCALAR";
5523 if (svtype != SVt_PVAV)
5524 badtype = "an ARRAY";
5527 if (svtype != SVt_PVHV) {
5528 if (svtype == SVt_PVAV) { /* pseudohash? */
5529 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5530 if (ksv && SvROK(*ksv)
5531 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5540 if (svtype != SVt_PVCV)
5545 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5548 name = SvPV(kidsv, n_a);
5549 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5550 char *badthing = Nullch;
5551 switch (o->op_type) {
5553 badthing = "a SCALAR";
5556 badthing = "an ARRAY";
5559 badthing = "a HASH";
5564 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5568 * This is a little tricky. We only want to add the symbol if we
5569 * didn't add it in the lexer. Otherwise we get duplicate strict
5570 * warnings. But if we didn't add it in the lexer, we must at
5571 * least pretend like we wanted to add it even if it existed before,
5572 * or we get possible typo warnings. OPpCONST_ENTERED says
5573 * whether the lexer already added THIS instance of this symbol.
5575 iscv = (o->op_type == OP_RV2CV) * 2;
5577 gv = gv_fetchpv(name,
5578 iscv | !(kid->op_private & OPpCONST_ENTERED),
5581 : o->op_type == OP_RV2SV
5583 : o->op_type == OP_RV2AV
5585 : o->op_type == OP_RV2HV
5588 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5590 kid->op_type = OP_GV;
5591 SvREFCNT_dec(kid->op_sv);
5593 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5594 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5595 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5597 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5599 kid->op_sv = SvREFCNT_inc(gv);
5601 kid->op_private = 0;
5602 kid->op_ppaddr = PL_ppaddr[OP_GV];
5609 Perl_ck_ftst(pTHX_ OP *o)
5611 I32 type = o->op_type;
5613 if (o->op_flags & OPf_REF) {
5616 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5617 SVOP *kid = (SVOP*)cUNOPo->op_first;
5619 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5621 OP *newop = newGVOP(type, OPf_REF,
5622 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5629 if (type == OP_FTTTY)
5630 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5633 o = newUNOP(type, 0, newDEFSVOP());
5636 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5638 if (PL_hints & HINT_LOCALE)
5639 o->op_private |= OPpLOCALE;
5646 Perl_ck_fun(pTHX_ OP *o)
5652 int type = o->op_type;
5653 register I32 oa = PL_opargs[type] >> OASHIFT;
5655 if (o->op_flags & OPf_STACKED) {
5656 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5659 return no_fh_allowed(o);
5662 if (o->op_flags & OPf_KIDS) {
5664 tokid = &cLISTOPo->op_first;
5665 kid = cLISTOPo->op_first;
5666 if (kid->op_type == OP_PUSHMARK ||
5667 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5669 tokid = &kid->op_sibling;
5670 kid = kid->op_sibling;
5672 if (!kid && PL_opargs[type] & OA_DEFGV)
5673 *tokid = kid = newDEFSVOP();
5677 sibl = kid->op_sibling;
5680 /* list seen where single (scalar) arg expected? */
5681 if (numargs == 1 && !(oa >> 4)
5682 && kid->op_type == OP_LIST && type != OP_SCALAR)
5684 return too_many_arguments(o,PL_op_desc[type]);
5697 if (kid->op_type == OP_CONST &&
5698 (kid->op_private & OPpCONST_BARE))
5700 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5701 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5702 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5703 if (ckWARN(WARN_DEPRECATED))
5704 Perl_warner(aTHX_ WARN_DEPRECATED,
5705 "Array @%s missing the @ in argument %"IVdf" of %s()",
5706 name, (IV)numargs, PL_op_desc[type]);
5709 kid->op_sibling = sibl;
5712 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5713 bad_type(numargs, "array", PL_op_desc[type], kid);
5717 if (kid->op_type == OP_CONST &&
5718 (kid->op_private & OPpCONST_BARE))
5720 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5721 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5722 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5723 if (ckWARN(WARN_DEPRECATED))
5724 Perl_warner(aTHX_ WARN_DEPRECATED,
5725 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5726 name, (IV)numargs, PL_op_desc[type]);
5729 kid->op_sibling = sibl;
5732 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5733 bad_type(numargs, "hash", PL_op_desc[type], kid);
5738 OP *newop = newUNOP(OP_NULL, 0, kid);
5739 kid->op_sibling = 0;
5741 newop->op_next = newop;
5743 kid->op_sibling = sibl;
5748 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5749 if (kid->op_type == OP_CONST &&
5750 (kid->op_private & OPpCONST_BARE))
5752 OP *newop = newGVOP(OP_GV, 0,
5753 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5758 else if (kid->op_type == OP_READLINE) {
5759 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5760 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5763 I32 flags = OPf_SPECIAL;
5767 /* is this op a FH constructor? */
5768 if (is_handle_constructor(o,numargs)) {
5769 char *name = Nullch;
5773 /* Set a flag to tell rv2gv to vivify
5774 * need to "prove" flag does not mean something
5775 * else already - NI-S 1999/05/07
5778 if (kid->op_type == OP_PADSV) {
5779 SV **namep = av_fetch(PL_comppad_name,
5781 if (namep && *namep)
5782 name = SvPV(*namep, len);
5784 else if (kid->op_type == OP_RV2SV
5785 && kUNOP->op_first->op_type == OP_GV)
5787 GV *gv = cGVOPx_gv(kUNOP->op_first);
5789 len = GvNAMELEN(gv);
5791 else if (kid->op_type == OP_AELEM
5792 || kid->op_type == OP_HELEM)
5794 name = "__ANONIO__";
5800 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5801 namesv = PL_curpad[targ];
5802 (void)SvUPGRADE(namesv, SVt_PV);
5804 sv_setpvn(namesv, "$", 1);
5805 sv_catpvn(namesv, name, len);
5808 kid->op_sibling = 0;
5809 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5810 kid->op_targ = targ;
5811 kid->op_private |= priv;
5813 kid->op_sibling = sibl;
5819 mod(scalar(kid), type);
5823 tokid = &kid->op_sibling;
5824 kid = kid->op_sibling;
5826 o->op_private |= numargs;
5828 return too_many_arguments(o,PL_op_desc[o->op_type]);
5831 else if (PL_opargs[type] & OA_DEFGV) {
5833 return newUNOP(type, 0, newDEFSVOP());
5837 while (oa & OA_OPTIONAL)
5839 if (oa && oa != OA_LIST)
5840 return too_few_arguments(o,PL_op_desc[o->op_type]);
5846 Perl_ck_glob(pTHX_ OP *o)
5851 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5852 append_elem(OP_GLOB, o, newDEFSVOP());
5854 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5855 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5857 #if !defined(PERL_EXTERNAL_GLOB)
5858 /* XXX this can be tightened up and made more failsafe. */
5861 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5862 /* null-terminated import list */
5863 newSVpvn(":globally", 9), Nullsv);
5864 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5867 #endif /* PERL_EXTERNAL_GLOB */
5869 if (gv && GvIMPORTED_CV(gv)) {
5870 append_elem(OP_GLOB, o,
5871 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5872 o->op_type = OP_LIST;
5873 o->op_ppaddr = PL_ppaddr[OP_LIST];
5874 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5875 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5876 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5877 append_elem(OP_LIST, o,
5878 scalar(newUNOP(OP_RV2CV, 0,
5879 newGVOP(OP_GV, 0, gv)))));
5880 o = newUNOP(OP_NULL, 0, ck_subr(o));
5881 o->op_targ = OP_GLOB; /* hint at what it used to be */
5884 gv = newGVgen("main");
5886 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5892 Perl_ck_grep(pTHX_ OP *o)
5896 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5898 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5899 NewOp(1101, gwop, 1, LOGOP);
5901 if (o->op_flags & OPf_STACKED) {
5904 kid = cLISTOPo->op_first->op_sibling;
5905 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5908 kid->op_next = (OP*)gwop;
5909 o->op_flags &= ~OPf_STACKED;
5911 kid = cLISTOPo->op_first->op_sibling;
5912 if (type == OP_MAPWHILE)
5919 kid = cLISTOPo->op_first->op_sibling;
5920 if (kid->op_type != OP_NULL)
5921 Perl_croak(aTHX_ "panic: ck_grep");
5922 kid = kUNOP->op_first;
5924 gwop->op_type = type;
5925 gwop->op_ppaddr = PL_ppaddr[type];
5926 gwop->op_first = listkids(o);
5927 gwop->op_flags |= OPf_KIDS;
5928 gwop->op_private = 1;
5929 gwop->op_other = LINKLIST(kid);
5930 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5931 kid->op_next = (OP*)gwop;
5933 kid = cLISTOPo->op_first->op_sibling;
5934 if (!kid || !kid->op_sibling)
5935 return too_few_arguments(o,PL_op_desc[o->op_type]);
5936 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5937 mod(kid, OP_GREPSTART);
5943 Perl_ck_index(pTHX_ OP *o)
5945 if (o->op_flags & OPf_KIDS) {
5946 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5948 kid = kid->op_sibling; /* get past "big" */
5949 if (kid && kid->op_type == OP_CONST)
5950 fbm_compile(((SVOP*)kid)->op_sv, 0);
5956 Perl_ck_lengthconst(pTHX_ OP *o)
5958 /* XXX length optimization goes here */
5963 Perl_ck_lfun(pTHX_ OP *o)
5965 OPCODE type = o->op_type;
5966 return modkids(ck_fun(o), type);
5970 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5972 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5973 switch (cUNOPo->op_first->op_type) {
5975 /* This is needed for
5976 if (defined %stash::)
5977 to work. Do not break Tk.
5979 break; /* Globals via GV can be undef */
5981 case OP_AASSIGN: /* Is this a good idea? */
5982 Perl_warner(aTHX_ WARN_DEPRECATED,
5983 "defined(@array) is deprecated");
5984 Perl_warner(aTHX_ WARN_DEPRECATED,
5985 "\t(Maybe you should just omit the defined()?)\n");
5988 /* This is needed for
5989 if (defined %stash::)
5990 to work. Do not break Tk.
5992 break; /* Globals via GV can be undef */
5994 Perl_warner(aTHX_ WARN_DEPRECATED,
5995 "defined(%%hash) is deprecated");
5996 Perl_warner(aTHX_ WARN_DEPRECATED,
5997 "\t(Maybe you should just omit the defined()?)\n");
6008 Perl_ck_rfun(pTHX_ OP *o)
6010 OPCODE type = o->op_type;
6011 return refkids(ck_fun(o), type);
6015 Perl_ck_listiob(pTHX_ OP *o)
6019 kid = cLISTOPo->op_first;
6022 kid = cLISTOPo->op_first;
6024 if (kid->op_type == OP_PUSHMARK)
6025 kid = kid->op_sibling;
6026 if (kid && o->op_flags & OPf_STACKED)
6027 kid = kid->op_sibling;
6028 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6029 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6030 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6031 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6032 cLISTOPo->op_first->op_sibling = kid;
6033 cLISTOPo->op_last = kid;
6034 kid = kid->op_sibling;
6039 append_elem(o->op_type, o, newDEFSVOP());
6045 if (PL_hints & HINT_LOCALE)
6046 o->op_private |= OPpLOCALE;
6053 Perl_ck_fun_locale(pTHX_ OP *o)
6059 if (PL_hints & HINT_LOCALE)
6060 o->op_private |= OPpLOCALE;
6067 Perl_ck_sassign(pTHX_ OP *o)
6069 OP *kid = cLISTOPo->op_first;
6070 /* has a disposable target? */
6071 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6072 && !(kid->op_flags & OPf_STACKED)
6073 /* Cannot steal the second time! */
6074 && !(kid->op_private & OPpTARGET_MY))
6076 OP *kkid = kid->op_sibling;
6078 /* Can just relocate the target. */
6079 if (kkid && kkid->op_type == OP_PADSV
6080 && !(kkid->op_private & OPpLVAL_INTRO))
6082 kid->op_targ = kkid->op_targ;
6084 /* Now we do not need PADSV and SASSIGN. */
6085 kid->op_sibling = o->op_sibling; /* NULL */
6086 cLISTOPo->op_first = NULL;
6089 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6097 Perl_ck_scmp(pTHX_ OP *o)
6101 if (PL_hints & HINT_LOCALE)
6102 o->op_private |= OPpLOCALE;
6109 Perl_ck_match(pTHX_ OP *o)
6111 o->op_private |= OPpRUNTIME;
6116 Perl_ck_method(pTHX_ OP *o)
6118 OP *kid = cUNOPo->op_first;
6119 if (kid->op_type == OP_CONST) {
6120 SV* sv = kSVOP->op_sv;
6121 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6123 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6124 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6127 kSVOP->op_sv = Nullsv;
6129 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6138 Perl_ck_null(pTHX_ OP *o)
6144 Perl_ck_open(pTHX_ OP *o)
6146 HV *table = GvHV(PL_hintgv);
6150 svp = hv_fetch(table, "open_IN", 7, FALSE);
6152 mode = mode_from_discipline(*svp);
6153 if (mode & O_BINARY)
6154 o->op_private |= OPpOPEN_IN_RAW;
6155 else if (mode & O_TEXT)
6156 o->op_private |= OPpOPEN_IN_CRLF;
6159 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6161 mode = mode_from_discipline(*svp);
6162 if (mode & O_BINARY)
6163 o->op_private |= OPpOPEN_OUT_RAW;
6164 else if (mode & O_TEXT)
6165 o->op_private |= OPpOPEN_OUT_CRLF;
6168 if (o->op_type == OP_BACKTICK)
6174 Perl_ck_repeat(pTHX_ OP *o)
6176 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6177 o->op_private |= OPpREPEAT_DOLIST;
6178 cBINOPo->op_first = force_list(cBINOPo->op_first);
6186 Perl_ck_require(pTHX_ OP *o)
6188 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6189 SVOP *kid = (SVOP*)cUNOPo->op_first;
6191 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6193 for (s = SvPVX(kid->op_sv); *s; s++) {
6194 if (*s == ':' && s[1] == ':') {
6196 Move(s+2, s+1, strlen(s+2)+1, char);
6197 --SvCUR(kid->op_sv);
6200 if (SvREADONLY(kid->op_sv)) {
6201 SvREADONLY_off(kid->op_sv);
6202 sv_catpvn(kid->op_sv, ".pm", 3);
6203 SvREADONLY_on(kid->op_sv);
6206 sv_catpvn(kid->op_sv, ".pm", 3);
6213 Perl_ck_return(pTHX_ OP *o)
6216 if (CvLVALUE(PL_compcv)) {
6217 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6218 mod(kid, OP_LEAVESUBLV);
6225 Perl_ck_retarget(pTHX_ OP *o)
6227 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6234 Perl_ck_select(pTHX_ OP *o)
6237 if (o->op_flags & OPf_KIDS) {
6238 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6239 if (kid && kid->op_sibling) {
6240 o->op_type = OP_SSELECT;
6241 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6243 return fold_constants(o);
6247 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6248 if (kid && kid->op_type == OP_RV2GV)
6249 kid->op_private &= ~HINT_STRICT_REFS;
6254 Perl_ck_shift(pTHX_ OP *o)
6256 I32 type = o->op_type;
6258 if (!(o->op_flags & OPf_KIDS)) {
6263 if (!CvUNIQUE(PL_compcv)) {
6264 argop = newOP(OP_PADAV, OPf_REF);
6265 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6268 argop = newUNOP(OP_RV2AV, 0,
6269 scalar(newGVOP(OP_GV, 0,
6270 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6273 argop = newUNOP(OP_RV2AV, 0,
6274 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6275 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6276 #endif /* USE_THREADS */
6277 return newUNOP(type, 0, scalar(argop));
6279 return scalar(modkids(ck_fun(o), type));
6283 Perl_ck_sort(pTHX_ OP *o)
6288 if (PL_hints & HINT_LOCALE)
6289 o->op_private |= OPpLOCALE;
6292 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6294 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6295 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6297 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6299 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6301 if (kid->op_type == OP_SCOPE) {
6305 else if (kid->op_type == OP_LEAVE) {
6306 if (o->op_type == OP_SORT) {
6307 null(kid); /* wipe out leave */
6310 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6311 if (k->op_next == kid)
6313 /* don't descend into loops */
6314 else if (k->op_type == OP_ENTERLOOP
6315 || k->op_type == OP_ENTERITER)
6317 k = cLOOPx(k)->op_lastop;
6322 kid->op_next = 0; /* just disconnect the leave */
6323 k = kLISTOP->op_first;
6328 if (o->op_type == OP_SORT) {
6329 /* provide scalar context for comparison function/block */
6335 o->op_flags |= OPf_SPECIAL;
6337 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6340 firstkid = firstkid->op_sibling;
6343 /* provide list context for arguments */
6344 if (o->op_type == OP_SORT)
6351 S_simplify_sort(pTHX_ OP *o)
6353 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6357 if (!(o->op_flags & OPf_STACKED))
6359 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6360 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6361 kid = kUNOP->op_first; /* get past null */
6362 if (kid->op_type != OP_SCOPE)
6364 kid = kLISTOP->op_last; /* get past scope */
6365 switch(kid->op_type) {
6373 k = kid; /* remember this node*/
6374 if (kBINOP->op_first->op_type != OP_RV2SV)
6376 kid = kBINOP->op_first; /* get past cmp */
6377 if (kUNOP->op_first->op_type != OP_GV)
6379 kid = kUNOP->op_first; /* get past rv2sv */
6381 if (GvSTASH(gv) != PL_curstash)
6383 if (strEQ(GvNAME(gv), "a"))
6385 else if (strEQ(GvNAME(gv), "b"))
6389 kid = k; /* back to cmp */
6390 if (kBINOP->op_last->op_type != OP_RV2SV)
6392 kid = kBINOP->op_last; /* down to 2nd arg */
6393 if (kUNOP->op_first->op_type != OP_GV)
6395 kid = kUNOP->op_first; /* get past rv2sv */
6397 if (GvSTASH(gv) != PL_curstash
6399 ? strNE(GvNAME(gv), "a")
6400 : strNE(GvNAME(gv), "b")))
6402 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6404 o->op_private |= OPpSORT_REVERSE;
6405 if (k->op_type == OP_NCMP)
6406 o->op_private |= OPpSORT_NUMERIC;
6407 if (k->op_type == OP_I_NCMP)
6408 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6409 kid = cLISTOPo->op_first->op_sibling;
6410 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6411 op_free(kid); /* then delete it */
6415 Perl_ck_split(pTHX_ OP *o)
6419 if (o->op_flags & OPf_STACKED)
6420 return no_fh_allowed(o);
6422 kid = cLISTOPo->op_first;
6423 if (kid->op_type != OP_NULL)
6424 Perl_croak(aTHX_ "panic: ck_split");
6425 kid = kid->op_sibling;
6426 op_free(cLISTOPo->op_first);
6427 cLISTOPo->op_first = kid;
6429 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6430 cLISTOPo->op_last = kid; /* There was only one element previously */
6433 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6434 OP *sibl = kid->op_sibling;
6435 kid->op_sibling = 0;
6436 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6437 if (cLISTOPo->op_first == cLISTOPo->op_last)
6438 cLISTOPo->op_last = kid;
6439 cLISTOPo->op_first = kid;
6440 kid->op_sibling = sibl;
6443 kid->op_type = OP_PUSHRE;
6444 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6447 if (!kid->op_sibling)
6448 append_elem(OP_SPLIT, o, newDEFSVOP());
6450 kid = kid->op_sibling;
6453 if (!kid->op_sibling)
6454 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6456 kid = kid->op_sibling;
6459 if (kid->op_sibling)
6460 return too_many_arguments(o,PL_op_desc[o->op_type]);
6466 Perl_ck_join(pTHX_ OP *o)
6468 if (ckWARN(WARN_SYNTAX)) {
6469 OP *kid = cLISTOPo->op_first->op_sibling;
6470 if (kid && kid->op_type == OP_MATCH) {
6471 char *pmstr = "STRING";
6472 if (kPMOP->op_pmregexp)
6473 pmstr = kPMOP->op_pmregexp->precomp;
6474 Perl_warner(aTHX_ WARN_SYNTAX,
6475 "/%s/ should probably be written as \"%s\"",
6483 Perl_ck_subr(pTHX_ OP *o)
6485 OP *prev = ((cUNOPo->op_first->op_sibling)
6486 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6487 OP *o2 = prev->op_sibling;
6496 o->op_private |= OPpENTERSUB_HASTARG;
6497 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6498 if (cvop->op_type == OP_RV2CV) {
6500 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6501 null(cvop); /* disable rv2cv */
6502 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6503 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6504 GV *gv = cGVOPx_gv(tmpop);
6507 tmpop->op_private |= OPpEARLY_CV;
6508 else if (SvPOK(cv)) {
6509 namegv = CvANON(cv) ? gv : CvGV(cv);
6510 proto = SvPV((SV*)cv, n_a);
6514 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6515 if (o2->op_type == OP_CONST)
6516 o2->op_private &= ~OPpCONST_STRICT;
6517 else if (o2->op_type == OP_LIST) {
6518 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6519 if (o && o->op_type == OP_CONST)
6520 o->op_private &= ~OPpCONST_STRICT;
6523 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6524 if (PERLDB_SUB && PL_curstash != PL_debstash)
6525 o->op_private |= OPpENTERSUB_DB;
6526 while (o2 != cvop) {
6530 return too_many_arguments(o, gv_ename(namegv));
6548 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6550 arg == 1 ? "block or sub {}" : "sub {}",
6551 gv_ename(namegv), o2);
6554 /* '*' allows any scalar type, including bareword */
6557 if (o2->op_type == OP_RV2GV)
6558 goto wrapref; /* autoconvert GLOB -> GLOBref */
6559 else if (o2->op_type == OP_CONST)
6560 o2->op_private &= ~OPpCONST_STRICT;
6561 else if (o2->op_type == OP_ENTERSUB) {
6562 /* accidental subroutine, revert to bareword */
6563 OP *gvop = ((UNOP*)o2)->op_first;
6564 if (gvop && gvop->op_type == OP_NULL) {
6565 gvop = ((UNOP*)gvop)->op_first;
6567 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6570 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6571 (gvop = ((UNOP*)gvop)->op_first) &&
6572 gvop->op_type == OP_GV)
6574 GV *gv = cGVOPx_gv(gvop);
6575 OP *sibling = o2->op_sibling;
6576 SV *n = newSVpvn("",0);
6578 gv_fullname3(n, gv, "");
6579 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6580 sv_chop(n, SvPVX(n)+6);
6581 o2 = newSVOP(OP_CONST, 0, n);
6582 prev->op_sibling = o2;
6583 o2->op_sibling = sibling;
6595 if (o2->op_type != OP_RV2GV)
6596 bad_type(arg, "symbol", gv_ename(namegv), o2);
6599 if (o2->op_type != OP_ENTERSUB)
6600 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6603 if (o2->op_type != OP_RV2SV
6604 && o2->op_type != OP_PADSV
6605 && o2->op_type != OP_HELEM
6606 && o2->op_type != OP_AELEM
6607 && o2->op_type != OP_THREADSV)
6609 bad_type(arg, "scalar", gv_ename(namegv), o2);
6613 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6614 bad_type(arg, "array", gv_ename(namegv), o2);
6617 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6618 bad_type(arg, "hash", gv_ename(namegv), o2);
6622 OP* sib = kid->op_sibling;
6623 kid->op_sibling = 0;
6624 o2 = newUNOP(OP_REFGEN, 0, kid);
6625 o2->op_sibling = sib;
6626 prev->op_sibling = o2;
6637 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6638 gv_ename(namegv), SvPV((SV*)cv, n_a));
6643 mod(o2, OP_ENTERSUB);
6645 o2 = o2->op_sibling;
6647 if (proto && !optional &&
6648 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6649 return too_few_arguments(o, gv_ename(namegv));
6654 Perl_ck_svconst(pTHX_ OP *o)
6656 SvREADONLY_on(cSVOPo->op_sv);
6661 Perl_ck_trunc(pTHX_ OP *o)
6663 if (o->op_flags & OPf_KIDS) {
6664 SVOP *kid = (SVOP*)cUNOPo->op_first;
6666 if (kid->op_type == OP_NULL)
6667 kid = (SVOP*)kid->op_sibling;
6668 if (kid && kid->op_type == OP_CONST &&
6669 (kid->op_private & OPpCONST_BARE))
6671 o->op_flags |= OPf_SPECIAL;
6672 kid->op_private &= ~OPpCONST_STRICT;
6679 Perl_ck_substr(pTHX_ OP *o)
6682 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6683 OP *kid = cLISTOPo->op_first;
6685 if (kid->op_type == OP_NULL)
6686 kid = kid->op_sibling;
6688 kid->op_flags |= OPf_MOD;
6694 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6697 Perl_peep(pTHX_ register OP *o)
6699 register OP* oldop = 0;
6702 if (!o || o->op_seq)
6706 SAVEVPTR(PL_curcop);
6707 for (; o; o = o->op_next) {
6713 switch (o->op_type) {
6717 PL_curcop = ((COP*)o); /* for warnings */
6718 o->op_seq = PL_op_seqmax++;
6722 if (cSVOPo->op_private & OPpCONST_STRICT)
6723 no_bareword_allowed(o);
6725 /* Relocate sv to the pad for thread safety.
6726 * Despite being a "constant", the SV is written to,
6727 * for reference counts, sv_upgrade() etc. */
6729 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6730 if (SvPADTMP(cSVOPo->op_sv)) {
6731 /* If op_sv is already a PADTMP then it is being used by
6732 * some pad, so make a copy. */
6733 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6734 SvREADONLY_on(PL_curpad[ix]);
6735 SvREFCNT_dec(cSVOPo->op_sv);
6738 SvREFCNT_dec(PL_curpad[ix]);
6739 SvPADTMP_on(cSVOPo->op_sv);
6740 PL_curpad[ix] = cSVOPo->op_sv;
6741 /* XXX I don't know how this isn't readonly already. */
6742 SvREADONLY_on(PL_curpad[ix]);
6744 cSVOPo->op_sv = Nullsv;
6748 o->op_seq = PL_op_seqmax++;
6752 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6753 if (o->op_next->op_private & OPpTARGET_MY) {
6754 if (o->op_flags & OPf_STACKED) /* chained concats */
6755 goto ignore_optimization;
6757 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6758 o->op_targ = o->op_next->op_targ;
6759 o->op_next->op_targ = 0;
6760 o->op_private |= OPpTARGET_MY;
6765 ignore_optimization:
6766 o->op_seq = PL_op_seqmax++;
6769 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6770 o->op_seq = PL_op_seqmax++;
6771 break; /* Scalar stub must produce undef. List stub is noop */
6775 if (o->op_targ == OP_NEXTSTATE
6776 || o->op_targ == OP_DBSTATE
6777 || o->op_targ == OP_SETSTATE)
6779 PL_curcop = ((COP*)o);
6786 if (oldop && o->op_next) {
6787 oldop->op_next = o->op_next;
6790 o->op_seq = PL_op_seqmax++;
6794 if (o->op_next->op_type == OP_RV2SV) {
6795 if (!(o->op_next->op_private & OPpDEREF)) {
6797 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6799 o->op_next = o->op_next->op_next;
6800 o->op_type = OP_GVSV;
6801 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6804 else if (o->op_next->op_type == OP_RV2AV) {
6805 OP* pop = o->op_next->op_next;
6807 if (pop->op_type == OP_CONST &&
6808 (PL_op = pop->op_next) &&
6809 pop->op_next->op_type == OP_AELEM &&
6810 !(pop->op_next->op_private &
6811 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6812 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6820 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6821 o->op_next = pop->op_next->op_next;
6822 o->op_type = OP_AELEMFAST;
6823 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6824 o->op_private = (U8)i;
6829 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6831 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6832 /* XXX could check prototype here instead of just carping */
6833 SV *sv = sv_newmortal();
6834 gv_efullname3(sv, gv, Nullch);
6835 Perl_warner(aTHX_ WARN_PROTOTYPE,
6836 "%s() called too early to check prototype",
6841 o->op_seq = PL_op_seqmax++;
6852 o->op_seq = PL_op_seqmax++;
6853 while (cLOGOP->op_other->op_type == OP_NULL)
6854 cLOGOP->op_other = cLOGOP->op_other->op_next;
6855 peep(cLOGOP->op_other);
6859 o->op_seq = PL_op_seqmax++;
6860 while (cLOOP->op_redoop->op_type == OP_NULL)
6861 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6862 peep(cLOOP->op_redoop);
6863 while (cLOOP->op_nextop->op_type == OP_NULL)
6864 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6865 peep(cLOOP->op_nextop);
6866 while (cLOOP->op_lastop->op_type == OP_NULL)
6867 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6868 peep(cLOOP->op_lastop);
6874 o->op_seq = PL_op_seqmax++;
6875 while (cPMOP->op_pmreplstart &&
6876 cPMOP->op_pmreplstart->op_type == OP_NULL)
6877 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6878 peep(cPMOP->op_pmreplstart);
6882 o->op_seq = PL_op_seqmax++;
6883 if (ckWARN(WARN_SYNTAX) && o->op_next
6884 && o->op_next->op_type == OP_NEXTSTATE) {
6885 if (o->op_next->op_sibling &&
6886 o->op_next->op_sibling->op_type != OP_EXIT &&
6887 o->op_next->op_sibling->op_type != OP_WARN &&
6888 o->op_next->op_sibling->op_type != OP_DIE) {
6889 line_t oldline = CopLINE(PL_curcop);
6891 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6892 Perl_warner(aTHX_ WARN_EXEC,
6893 "Statement unlikely to be reached");
6894 Perl_warner(aTHX_ WARN_EXEC,
6895 "\t(Maybe you meant system() when you said exec()?)\n");
6896 CopLINE_set(PL_curcop, oldline);
6905 SV **svp, **indsvp, *sv;
6910 o->op_seq = PL_op_seqmax++;
6912 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6915 /* Make the CONST have a shared SV */
6916 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6917 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6918 key = SvPV(sv, keylen);
6921 lexname = newSVpvn_share(key, keylen, 0);
6926 if ((o->op_private & (OPpLVAL_INTRO)))
6929 rop = (UNOP*)((BINOP*)o)->op_first;
6930 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6932 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6933 if (!SvOBJECT(lexname))
6935 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6936 if (!fields || !GvHV(*fields))
6938 key = SvPV(*svp, keylen);
6941 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6943 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6944 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6946 ind = SvIV(*indsvp);
6948 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6949 rop->op_type = OP_RV2AV;
6950 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6951 o->op_type = OP_AELEM;
6952 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6954 if (SvREADONLY(*svp))
6956 SvFLAGS(sv) |= (SvFLAGS(*svp)
6957 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6967 SV **svp, **indsvp, *sv;
6971 SVOP *first_key_op, *key_op;
6973 o->op_seq = PL_op_seqmax++;
6974 if ((o->op_private & (OPpLVAL_INTRO))
6975 /* I bet there's always a pushmark... */
6976 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6977 /* hmmm, no optimization if list contains only one key. */
6979 rop = (UNOP*)((LISTOP*)o)->op_last;
6980 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6982 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6983 if (!SvOBJECT(lexname))
6985 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6986 if (!fields || !GvHV(*fields))
6988 /* Again guessing that the pushmark can be jumped over.... */
6989 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6990 ->op_first->op_sibling;
6991 /* Check that the key list contains only constants. */
6992 for (key_op = first_key_op; key_op;
6993 key_op = (SVOP*)key_op->op_sibling)
6994 if (key_op->op_type != OP_CONST)
6998 rop->op_type = OP_RV2AV;
6999 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7000 o->op_type = OP_ASLICE;
7001 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7002 for (key_op = first_key_op; key_op;
7003 key_op = (SVOP*)key_op->op_sibling) {
7004 svp = cSVOPx_svp(key_op);
7005 key = SvPV(*svp, keylen);
7008 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7010 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7011 "in variable %s of type %s",
7012 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7014 ind = SvIV(*indsvp);
7016 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7018 if (SvREADONLY(*svp))
7020 SvFLAGS(sv) |= (SvFLAGS(*svp)
7021 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7029 o->op_seq = PL_op_seqmax++;
7039 /* Efficient sub that returns a constant scalar value. */
7041 const_sv_xsub(pTHXo_ CV* cv)
7046 Perl_croak(aTHX_ "usage: %s::%s()",
7047 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7051 ST(0) = (SV*)XSANY.any_ptr;