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 RETVAL_MAX ( 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 (*s < 0x80 || *s == 0xff)
121 *d++ = ((c >> 6) | 0xc0);
122 *d++ = ((c & 0x3f) | 0x80);
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);
846 cPMOPo->op_pmreplroot = Nullop;
847 ReREFCNT_dec(cPMOPo->op_pmregexp);
848 cPMOPo->op_pmregexp = (REGEXP*)NULL;
852 if (o->op_targ > 0) {
853 pad_free(o->op_targ);
859 S_cop_free(pTHX_ COP* cop)
861 Safefree(cop->cop_label);
863 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
864 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
866 /* NOTE: COP.cop_stash is not refcounted */
867 SvREFCNT_dec(CopFILEGV(cop));
869 if (! specialWARN(cop->cop_warnings))
870 SvREFCNT_dec(cop->cop_warnings);
871 if (! specialCopIO(cop->cop_io))
872 SvREFCNT_dec(cop->cop_io);
878 if (o->op_type == OP_NULL)
881 o->op_targ = o->op_type;
882 o->op_type = OP_NULL;
883 o->op_ppaddr = PL_ppaddr[OP_NULL];
886 /* Contextualizers */
888 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
891 Perl_linklist(pTHX_ OP *o)
898 /* establish postfix order */
899 if (cUNOPo->op_first) {
900 o->op_next = LINKLIST(cUNOPo->op_first);
901 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
903 kid->op_next = LINKLIST(kid->op_sibling);
915 Perl_scalarkids(pTHX_ OP *o)
918 if (o && o->op_flags & OPf_KIDS) {
919 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
926 S_scalarboolean(pTHX_ OP *o)
928 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
929 if (ckWARN(WARN_SYNTAX)) {
930 line_t oldline = CopLINE(PL_curcop);
932 if (PL_copline != NOLINE)
933 CopLINE_set(PL_curcop, PL_copline);
934 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
935 CopLINE_set(PL_curcop, oldline);
942 Perl_scalar(pTHX_ OP *o)
946 /* assumes no premature commitment */
947 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
948 || o->op_type == OP_RETURN)
953 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
955 switch (o->op_type) {
957 if (o->op_private & OPpREPEAT_DOLIST)
958 null(((LISTOP*)cBINOPo->op_first)->op_first);
959 scalar(cBINOPo->op_first);
964 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
968 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
969 if (!kPMOP->op_pmreplroot)
970 deprecate("implicit split to @_");
978 if (o->op_flags & OPf_KIDS) {
979 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
985 kid = cLISTOPo->op_first;
987 while ((kid = kid->op_sibling)) {
993 WITH_THR(PL_curcop = &PL_compiling);
998 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1004 WITH_THR(PL_curcop = &PL_compiling);
1011 Perl_scalarvoid(pTHX_ OP *o)
1018 if (o->op_type == OP_NEXTSTATE
1019 || o->op_type == OP_SETSTATE
1020 || o->op_type == OP_DBSTATE
1021 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1022 || o->op_targ == OP_SETSTATE
1023 || o->op_targ == OP_DBSTATE)))
1024 PL_curcop = (COP*)o; /* for warning below */
1026 /* assumes no premature commitment */
1027 want = o->op_flags & OPf_WANT;
1028 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1029 || o->op_type == OP_RETURN)
1034 if ((o->op_private & OPpTARGET_MY)
1035 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1037 return scalar(o); /* As if inside SASSIGN */
1040 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1042 switch (o->op_type) {
1044 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1048 if (o->op_flags & OPf_STACKED)
1052 if (o->op_private == 4)
1094 case OP_GETSOCKNAME:
1095 case OP_GETPEERNAME:
1100 case OP_GETPRIORITY:
1123 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1124 useless = PL_op_desc[o->op_type];
1131 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1132 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1133 useless = "a variable";
1138 if (cSVOPo->op_private & OPpCONST_STRICT)
1139 no_bareword_allowed(o);
1141 if (ckWARN(WARN_VOID)) {
1142 useless = "a constant";
1143 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1145 else if (SvPOK(sv)) {
1146 /* perl4's way of mixing documentation and code
1147 (before the invention of POD) was based on a
1148 trick to mix nroff and perl code. The trick was
1149 built upon these three nroff macros being used in
1150 void context. The pink camel has the details in
1151 the script wrapman near page 319. */
1152 if (strnEQ(SvPVX(sv), "di", 2) ||
1153 strnEQ(SvPVX(sv), "ds", 2) ||
1154 strnEQ(SvPVX(sv), "ig", 2))
1159 null(o); /* don't execute or even remember it */
1163 o->op_type = OP_PREINC; /* pre-increment is faster */
1164 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1168 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1169 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1175 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1180 if (o->op_flags & OPf_STACKED)
1187 if (!(o->op_flags & OPf_KIDS))
1196 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1203 /* all requires must return a boolean value */
1204 o->op_flags &= ~OPf_WANT;
1209 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1210 if (!kPMOP->op_pmreplroot)
1211 deprecate("implicit split to @_");
1215 if (useless && ckWARN(WARN_VOID))
1216 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1221 Perl_listkids(pTHX_ OP *o)
1224 if (o && o->op_flags & OPf_KIDS) {
1225 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1232 Perl_list(pTHX_ OP *o)
1236 /* assumes no premature commitment */
1237 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1238 || o->op_type == OP_RETURN)
1243 if ((o->op_private & OPpTARGET_MY)
1244 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1246 return o; /* As if inside SASSIGN */
1249 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1251 switch (o->op_type) {
1254 list(cBINOPo->op_first);
1259 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1267 if (!(o->op_flags & OPf_KIDS))
1269 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1270 list(cBINOPo->op_first);
1271 return gen_constant_list(o);
1278 kid = cLISTOPo->op_first;
1280 while ((kid = kid->op_sibling)) {
1281 if (kid->op_sibling)
1286 WITH_THR(PL_curcop = &PL_compiling);
1290 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1291 if (kid->op_sibling)
1296 WITH_THR(PL_curcop = &PL_compiling);
1299 /* all requires must return a boolean value */
1300 o->op_flags &= ~OPf_WANT;
1307 Perl_scalarseq(pTHX_ OP *o)
1312 if (o->op_type == OP_LINESEQ ||
1313 o->op_type == OP_SCOPE ||
1314 o->op_type == OP_LEAVE ||
1315 o->op_type == OP_LEAVETRY)
1317 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1318 if (kid->op_sibling) {
1322 PL_curcop = &PL_compiling;
1324 o->op_flags &= ~OPf_PARENS;
1325 if (PL_hints & HINT_BLOCK_SCOPE)
1326 o->op_flags |= OPf_PARENS;
1329 o = newOP(OP_STUB, 0);
1334 S_modkids(pTHX_ OP *o, I32 type)
1337 if (o && o->op_flags & OPf_KIDS) {
1338 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1345 Perl_mod(pTHX_ OP *o, I32 type)
1350 if (!o || PL_error_count)
1353 if ((o->op_private & OPpTARGET_MY)
1354 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1359 switch (o->op_type) {
1364 if (o->op_private & (OPpCONST_BARE) &&
1365 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1366 SV *sv = ((SVOP*)o)->op_sv;
1369 /* Could be a filehandle */
1370 if (gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO)) {
1371 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1375 /* OK, it's a sub */
1377 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1379 enter = newUNOP(OP_ENTERSUB,0,
1380 newUNOP(OP_RV2CV, 0,
1381 newGVOP(OP_GV, 0, gv)
1383 enter->op_private |= OPpLVAL_INTRO;
1389 if (!(o->op_private & (OPpCONST_ARYBASE)))
1391 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1392 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1396 SAVEI32(PL_compiling.cop_arybase);
1397 PL_compiling.cop_arybase = 0;
1399 else if (type == OP_REFGEN)
1402 Perl_croak(aTHX_ "That use of $[ is unsupported");
1405 if (o->op_flags & OPf_PARENS)
1409 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1410 !(o->op_flags & OPf_STACKED)) {
1411 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1412 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1413 assert(cUNOPo->op_first->op_type == OP_NULL);
1414 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1417 else { /* lvalue subroutine call */
1418 o->op_private |= OPpLVAL_INTRO;
1419 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1420 /* Backward compatibility mode: */
1421 o->op_private |= OPpENTERSUB_INARGS;
1424 else { /* Compile-time error message: */
1425 OP *kid = cUNOPo->op_first;
1429 if (kid->op_type == OP_PUSHMARK)
1431 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1433 "panic: unexpected lvalue entersub "
1434 "args: type/targ %ld:%ld",
1435 (long)kid->op_type,kid->op_targ);
1436 kid = kLISTOP->op_first;
1438 while (kid->op_sibling)
1439 kid = kid->op_sibling;
1440 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1442 if (kid->op_type == OP_METHOD_NAMED
1443 || kid->op_type == OP_METHOD)
1447 if (kid->op_sibling || kid->op_next != kid) {
1448 yyerror("panic: unexpected optree near method call");
1452 NewOp(1101, newop, 1, UNOP);
1453 newop->op_type = OP_RV2CV;
1454 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1455 newop->op_first = Nullop;
1456 newop->op_next = (OP*)newop;
1457 kid->op_sibling = (OP*)newop;
1458 newop->op_private |= OPpLVAL_INTRO;
1462 if (kid->op_type != OP_RV2CV)
1464 "panic: unexpected lvalue entersub "
1465 "entry via type/targ %ld:%ld",
1466 (long)kid->op_type,kid->op_targ);
1467 kid->op_private |= OPpLVAL_INTRO;
1468 break; /* Postpone until runtime */
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1474 kid = kUNOP->op_first;
1475 if (kid->op_type == OP_NULL)
1477 "Unexpected constant lvalue entersub "
1478 "entry via type/targ %ld:%ld",
1479 (long)kid->op_type,kid->op_targ);
1480 if (kid->op_type != OP_GV) {
1481 /* Restore RV2CV to check lvalueness */
1483 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1484 okid->op_next = kid->op_next;
1485 kid->op_next = okid;
1488 okid->op_next = Nullop;
1489 okid->op_type = OP_RV2CV;
1491 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1492 okid->op_private |= OPpLVAL_INTRO;
1496 cv = GvCV(kGVOP_gv);
1506 /* grep, foreach, subcalls, refgen */
1507 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1509 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1510 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1512 : (o->op_type == OP_ENTERSUB
1513 ? "non-lvalue subroutine call"
1514 : PL_op_desc[o->op_type])),
1515 type ? PL_op_desc[type] : "local"));
1529 case OP_RIGHT_SHIFT:
1538 if (!(o->op_flags & OPf_STACKED))
1544 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1550 if (!type && cUNOPo->op_first->op_type != OP_GV)
1551 Perl_croak(aTHX_ "Can't localize through a reference");
1552 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1553 PL_modcount = RETVAL_MAX;
1554 return o; /* Treat \(@foo) like ordinary list. */
1558 if (scalar_mod_type(o, type))
1560 ref(cUNOPo->op_first, o->op_type);
1569 PL_modcount = RETVAL_MAX;
1572 if (!type && cUNOPo->op_first->op_type != OP_GV)
1573 Perl_croak(aTHX_ "Can't localize through a reference");
1574 ref(cUNOPo->op_first, o->op_type);
1578 PL_hints |= HINT_BLOCK_SCOPE;
1588 PL_modcount = RETVAL_MAX;
1589 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1590 return o; /* Treat \(@foo) like ordinary list. */
1591 if (scalar_mod_type(o, type))
1597 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1598 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1603 PL_modcount++; /* XXX ??? */
1605 #endif /* USE_THREADS */
1611 if (type != OP_SASSIGN)
1615 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1621 pad_free(o->op_targ);
1622 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1623 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1624 if (o->op_flags & OPf_KIDS)
1625 mod(cBINOPo->op_first->op_sibling, type);
1630 ref(cBINOPo->op_first, o->op_type);
1631 if (type == OP_ENTERSUB &&
1632 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1633 o->op_private |= OPpLVAL_DEFER;
1640 if (o->op_flags & OPf_KIDS)
1641 mod(cLISTOPo->op_last, type);
1645 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1647 else if (!(o->op_flags & OPf_KIDS))
1649 if (o->op_targ != OP_LIST) {
1650 mod(cBINOPo->op_first, type);
1655 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1659 o->op_flags |= OPf_MOD;
1661 if (type == OP_AASSIGN || type == OP_SASSIGN)
1662 o->op_flags |= OPf_SPECIAL|OPf_REF;
1664 o->op_private |= OPpLVAL_INTRO;
1665 o->op_flags &= ~OPf_SPECIAL;
1666 PL_hints |= HINT_BLOCK_SCOPE;
1668 else if (type != OP_GREPSTART && type != OP_ENTERSUB)
1669 o->op_flags |= OPf_REF;
1674 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1678 if (o->op_type == OP_RV2GV)
1702 case OP_RIGHT_SHIFT:
1721 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1723 switch (o->op_type) {
1731 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1744 Perl_refkids(pTHX_ OP *o, I32 type)
1747 if (o && o->op_flags & OPf_KIDS) {
1748 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1755 Perl_ref(pTHX_ OP *o, I32 type)
1759 if (!o || PL_error_count)
1762 switch (o->op_type) {
1764 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1765 !(o->op_flags & OPf_STACKED)) {
1766 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1767 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1768 assert(cUNOPo->op_first->op_type == OP_NULL);
1769 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1770 o->op_flags |= OPf_SPECIAL;
1775 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1779 if (type == OP_DEFINED)
1780 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1781 ref(cUNOPo->op_first, o->op_type);
1784 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1785 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1786 : type == OP_RV2HV ? OPpDEREF_HV
1788 o->op_flags |= OPf_MOD;
1793 o->op_flags |= OPf_MOD; /* XXX ??? */
1798 o->op_flags |= OPf_REF;
1801 if (type == OP_DEFINED)
1802 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1803 ref(cUNOPo->op_first, o->op_type);
1808 o->op_flags |= OPf_REF;
1813 if (!(o->op_flags & OPf_KIDS))
1815 ref(cBINOPo->op_first, type);
1819 ref(cBINOPo->op_first, o->op_type);
1820 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1821 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1822 : type == OP_RV2HV ? OPpDEREF_HV
1824 o->op_flags |= OPf_MOD;
1832 if (!(o->op_flags & OPf_KIDS))
1834 ref(cLISTOPo->op_last, type);
1844 S_dup_attrlist(pTHX_ OP *o)
1848 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1849 * where the first kid is OP_PUSHMARK and the remaining ones
1850 * are OP_CONST. We need to push the OP_CONST values.
1852 if (o->op_type == OP_CONST)
1853 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1855 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1856 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1857 if (o->op_type == OP_CONST)
1858 rop = append_elem(OP_LIST, rop,
1859 newSVOP(OP_CONST, o->op_flags,
1860 SvREFCNT_inc(cSVOPo->op_sv)));
1867 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1871 /* fake up C<use attributes $pkg,$rv,@attrs> */
1872 ENTER; /* need to protect against side-effects of 'use' */
1874 if (stash && HvNAME(stash))
1875 stashsv = newSVpv(HvNAME(stash), 0);
1877 stashsv = &PL_sv_no;
1879 #define ATTRSMODULE "attributes"
1881 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1882 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1884 prepend_elem(OP_LIST,
1885 newSVOP(OP_CONST, 0, stashsv),
1886 prepend_elem(OP_LIST,
1887 newSVOP(OP_CONST, 0,
1889 dup_attrlist(attrs))));
1894 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1895 char *attrstr, STRLEN len)
1900 len = strlen(attrstr);
1904 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1906 char *sstr = attrstr;
1907 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1908 attrs = append_elem(OP_LIST, attrs,
1909 newSVOP(OP_CONST, 0,
1910 newSVpvn(sstr, attrstr-sstr)));
1914 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1915 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1916 Nullsv, prepend_elem(OP_LIST,
1917 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1918 prepend_elem(OP_LIST,
1919 newSVOP(OP_CONST, 0,
1925 S_my_kid(pTHX_ OP *o, OP *attrs)
1930 if (!o || PL_error_count)
1934 if (type == OP_LIST) {
1935 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1937 } else if (type == OP_UNDEF) {
1939 } else if (type == OP_RV2SV || /* "our" declaration */
1941 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1942 o->op_private |= OPpOUR_INTRO;
1944 } else if (type != OP_PADSV &&
1947 type != OP_PUSHMARK)
1949 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1950 PL_op_desc[o->op_type],
1951 PL_in_my == KEY_our ? "our" : "my"));
1954 else if (attrs && type != OP_PUSHMARK) {
1960 PL_in_my_stash = Nullhv;
1962 /* check for C<my Dog $spot> when deciding package */
1963 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1964 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1965 stash = SvSTASH(*namesvp);
1967 stash = PL_curstash;
1968 padsv = PAD_SV(o->op_targ);
1969 apply_attrs(stash, padsv, attrs);
1971 o->op_flags |= OPf_MOD;
1972 o->op_private |= OPpLVAL_INTRO;
1977 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1979 if (o->op_flags & OPf_PARENS)
1983 o = my_kid(o, attrs);
1985 PL_in_my_stash = Nullhv;
1990 Perl_my(pTHX_ OP *o)
1992 return my_kid(o, Nullop);
1996 Perl_sawparens(pTHX_ OP *o)
1999 o->op_flags |= OPf_PARENS;
2004 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2008 if (ckWARN(WARN_MISC) &&
2009 (left->op_type == OP_RV2AV ||
2010 left->op_type == OP_RV2HV ||
2011 left->op_type == OP_PADAV ||
2012 left->op_type == OP_PADHV)) {
2013 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2014 right->op_type == OP_TRANS)
2015 ? right->op_type : OP_MATCH];
2016 const char *sample = ((left->op_type == OP_RV2AV ||
2017 left->op_type == OP_PADAV)
2018 ? "@array" : "%hash");
2019 Perl_warner(aTHX_ WARN_MISC,
2020 "Applying %s to %s will act on scalar(%s)",
2021 desc, sample, sample);
2024 if (!(right->op_flags & OPf_STACKED) &&
2025 (right->op_type == OP_MATCH ||
2026 right->op_type == OP_SUBST ||
2027 right->op_type == OP_TRANS)) {
2028 right->op_flags |= OPf_STACKED;
2029 if (right->op_type != OP_MATCH &&
2030 ! (right->op_type == OP_TRANS &&
2031 right->op_private & OPpTRANS_IDENTICAL))
2032 left = mod(left, right->op_type);
2033 if (right->op_type == OP_TRANS)
2034 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2036 o = prepend_elem(right->op_type, scalar(left), right);
2038 return newUNOP(OP_NOT, 0, scalar(o));
2042 return bind_match(type, left,
2043 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2047 Perl_invert(pTHX_ OP *o)
2051 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2052 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2056 Perl_scope(pTHX_ OP *o)
2059 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2060 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2061 o->op_type = OP_LEAVE;
2062 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2065 if (o->op_type == OP_LINESEQ) {
2067 o->op_type = OP_SCOPE;
2068 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2069 kid = ((LISTOP*)o)->op_first;
2070 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2074 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2081 Perl_save_hints(pTHX)
2084 SAVESPTR(GvHV(PL_hintgv));
2085 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2086 SAVEFREESV(GvHV(PL_hintgv));
2090 Perl_block_start(pTHX_ int full)
2092 int retval = PL_savestack_ix;
2094 SAVEI32(PL_comppad_name_floor);
2095 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2097 PL_comppad_name_fill = PL_comppad_name_floor;
2098 if (PL_comppad_name_floor < 0)
2099 PL_comppad_name_floor = 0;
2100 SAVEI32(PL_min_intro_pending);
2101 SAVEI32(PL_max_intro_pending);
2102 PL_min_intro_pending = 0;
2103 SAVEI32(PL_comppad_name_fill);
2104 SAVEI32(PL_padix_floor);
2105 PL_padix_floor = PL_padix;
2106 PL_pad_reset_pending = FALSE;
2108 PL_hints &= ~HINT_BLOCK_SCOPE;
2109 SAVESPTR(PL_compiling.cop_warnings);
2110 if (! specialWARN(PL_compiling.cop_warnings)) {
2111 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2112 SAVEFREESV(PL_compiling.cop_warnings) ;
2114 SAVESPTR(PL_compiling.cop_io);
2115 if (! specialCopIO(PL_compiling.cop_io)) {
2116 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2117 SAVEFREESV(PL_compiling.cop_io) ;
2123 Perl_block_end(pTHX_ I32 floor, OP *seq)
2125 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2126 OP* retval = scalarseq(seq);
2128 PL_pad_reset_pending = FALSE;
2129 PL_compiling.op_private = PL_hints;
2131 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2132 pad_leavemy(PL_comppad_name_fill);
2141 OP *o = newOP(OP_THREADSV, 0);
2142 o->op_targ = find_threadsv("_");
2145 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2146 #endif /* USE_THREADS */
2150 Perl_newPROG(pTHX_ OP *o)
2155 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2156 ((PL_in_eval & EVAL_KEEPERR)
2157 ? OPf_SPECIAL : 0), o);
2158 PL_eval_start = linklist(PL_eval_root);
2159 PL_eval_root->op_private |= OPpREFCOUNTED;
2160 OpREFCNT_set(PL_eval_root, 1);
2161 PL_eval_root->op_next = 0;
2162 peep(PL_eval_start);
2167 PL_main_root = scope(sawparens(scalarvoid(o)));
2168 PL_curcop = &PL_compiling;
2169 PL_main_start = LINKLIST(PL_main_root);
2170 PL_main_root->op_private |= OPpREFCOUNTED;
2171 OpREFCNT_set(PL_main_root, 1);
2172 PL_main_root->op_next = 0;
2173 peep(PL_main_start);
2176 /* Register with debugger */
2178 CV *cv = get_cv("DB::postponed", FALSE);
2182 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2184 call_sv((SV*)cv, G_DISCARD);
2191 Perl_localize(pTHX_ OP *o, I32 lex)
2193 if (o->op_flags & OPf_PARENS)
2196 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2198 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2199 if (*s == ';' || *s == '=')
2200 Perl_warner(aTHX_ WARN_PARENTHESIS,
2201 "Parentheses missing around \"%s\" list",
2202 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2208 o = mod(o, OP_NULL); /* a bit kludgey */
2210 PL_in_my_stash = Nullhv;
2215 Perl_jmaybe(pTHX_ OP *o)
2217 if (o->op_type == OP_LIST) {
2220 o2 = newOP(OP_THREADSV, 0);
2221 o2->op_targ = find_threadsv(";");
2223 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2224 #endif /* USE_THREADS */
2225 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2231 Perl_fold_constants(pTHX_ register OP *o)
2234 I32 type = o->op_type;
2237 if (PL_opargs[type] & OA_RETSCALAR)
2239 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2240 o->op_targ = pad_alloc(type, SVs_PADTMP);
2242 /* integerize op, unless it happens to be C<-foo>.
2243 * XXX should pp_i_negate() do magic string negation instead? */
2244 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2245 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2246 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2248 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2251 if (!(PL_opargs[type] & OA_FOLDCONST))
2256 /* XXX might want a ck_negate() for this */
2257 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2270 if (o->op_private & OPpLOCALE)
2275 goto nope; /* Don't try to run w/ errors */
2277 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2278 if ((curop->op_type != OP_CONST ||
2279 (curop->op_private & OPpCONST_BARE)) &&
2280 curop->op_type != OP_LIST &&
2281 curop->op_type != OP_SCALAR &&
2282 curop->op_type != OP_NULL &&
2283 curop->op_type != OP_PUSHMARK)
2289 curop = LINKLIST(o);
2293 sv = *(PL_stack_sp--);
2294 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2295 pad_swipe(o->op_targ);
2296 else if (SvTEMP(sv)) { /* grab mortal temp? */
2297 (void)SvREFCNT_inc(sv);
2301 if (type == OP_RV2GV)
2302 return newGVOP(OP_GV, 0, (GV*)sv);
2304 /* try to smush double to int, but don't smush -2.0 to -2 */
2305 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2308 #ifdef PERL_PRESERVE_IVUV
2309 /* Only bother to attempt to fold to IV if
2310 most operators will benefit */
2314 return newSVOP(OP_CONST, 0, sv);
2318 if (!(PL_opargs[type] & OA_OTHERINT))
2321 if (!(PL_hints & HINT_INTEGER)) {
2322 if (type == OP_MODULO
2323 || type == OP_DIVIDE
2324 || !(o->op_flags & OPf_KIDS))
2329 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2330 if (curop->op_type == OP_CONST) {
2331 if (SvIOK(((SVOP*)curop)->op_sv))
2335 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2339 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2346 Perl_gen_constant_list(pTHX_ register OP *o)
2349 I32 oldtmps_floor = PL_tmps_floor;
2353 return o; /* Don't attempt to run with errors */
2355 PL_op = curop = LINKLIST(o);
2362 PL_tmps_floor = oldtmps_floor;
2364 o->op_type = OP_RV2AV;
2365 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2366 curop = ((UNOP*)o)->op_first;
2367 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2374 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2379 if (!o || o->op_type != OP_LIST)
2380 o = newLISTOP(OP_LIST, 0, o, Nullop);
2382 o->op_flags &= ~OPf_WANT;
2384 if (!(PL_opargs[type] & OA_MARK))
2385 null(cLISTOPo->op_first);
2388 o->op_ppaddr = PL_ppaddr[type];
2389 o->op_flags |= flags;
2391 o = CHECKOP(type, o);
2392 if (o->op_type != type)
2395 if (cLISTOPo->op_children < 7) {
2396 /* XXX do we really need to do this if we're done appending?? */
2397 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2399 cLISTOPo->op_last = last; /* in case check substituted last arg */
2402 return fold_constants(o);
2405 /* List constructors */
2408 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2416 if (first->op_type != type
2417 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2419 return newLISTOP(type, 0, first, last);
2422 if (first->op_flags & OPf_KIDS)
2423 ((LISTOP*)first)->op_last->op_sibling = last;
2425 first->op_flags |= OPf_KIDS;
2426 ((LISTOP*)first)->op_first = last;
2428 ((LISTOP*)first)->op_last = last;
2429 ((LISTOP*)first)->op_children++;
2434 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2442 if (first->op_type != type)
2443 return prepend_elem(type, (OP*)first, (OP*)last);
2445 if (last->op_type != type)
2446 return append_elem(type, (OP*)first, (OP*)last);
2448 first->op_last->op_sibling = last->op_first;
2449 first->op_last = last->op_last;
2450 first->op_children += last->op_children;
2451 if (first->op_children)
2452 first->op_flags |= OPf_KIDS;
2454 #ifdef PL_OP_SLAB_ALLOC
2462 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2470 if (last->op_type == type) {
2471 if (type == OP_LIST) { /* already a PUSHMARK there */
2472 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2473 ((LISTOP*)last)->op_first->op_sibling = first;
2474 if (!(first->op_flags & OPf_PARENS))
2475 last->op_flags &= ~OPf_PARENS;
2478 if (!(last->op_flags & OPf_KIDS)) {
2479 ((LISTOP*)last)->op_last = first;
2480 last->op_flags |= OPf_KIDS;
2482 first->op_sibling = ((LISTOP*)last)->op_first;
2483 ((LISTOP*)last)->op_first = first;
2485 ((LISTOP*)last)->op_children++;
2489 return newLISTOP(type, 0, first, last);
2495 Perl_newNULLLIST(pTHX)
2497 return newOP(OP_STUB, 0);
2501 Perl_force_list(pTHX_ OP *o)
2503 if (!o || o->op_type != OP_LIST)
2504 o = newLISTOP(OP_LIST, 0, o, Nullop);
2510 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2514 NewOp(1101, listop, 1, LISTOP);
2516 listop->op_type = type;
2517 listop->op_ppaddr = PL_ppaddr[type];
2518 listop->op_children = (first != 0) + (last != 0);
2519 listop->op_flags = flags;
2523 else if (!first && last)
2526 first->op_sibling = last;
2527 listop->op_first = first;
2528 listop->op_last = last;
2529 if (type == OP_LIST) {
2531 pushop = newOP(OP_PUSHMARK, 0);
2532 pushop->op_sibling = first;
2533 listop->op_first = pushop;
2534 listop->op_flags |= OPf_KIDS;
2536 listop->op_last = pushop;
2538 else if (listop->op_children)
2539 listop->op_flags |= OPf_KIDS;
2545 Perl_newOP(pTHX_ I32 type, I32 flags)
2548 NewOp(1101, o, 1, OP);
2550 o->op_ppaddr = PL_ppaddr[type];
2551 o->op_flags = flags;
2554 o->op_private = 0 + (flags >> 8);
2555 if (PL_opargs[type] & OA_RETSCALAR)
2557 if (PL_opargs[type] & OA_TARGET)
2558 o->op_targ = pad_alloc(type, SVs_PADTMP);
2559 return CHECKOP(type, o);
2563 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2568 first = newOP(OP_STUB, 0);
2569 if (PL_opargs[type] & OA_MARK)
2570 first = force_list(first);
2572 NewOp(1101, unop, 1, UNOP);
2573 unop->op_type = type;
2574 unop->op_ppaddr = PL_ppaddr[type];
2575 unop->op_first = first;
2576 unop->op_flags = flags | OPf_KIDS;
2577 unop->op_private = 1 | (flags >> 8);
2578 unop = (UNOP*) CHECKOP(type, unop);
2582 return fold_constants((OP *) unop);
2586 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2589 NewOp(1101, binop, 1, BINOP);
2592 first = newOP(OP_NULL, 0);
2594 binop->op_type = type;
2595 binop->op_ppaddr = PL_ppaddr[type];
2596 binop->op_first = first;
2597 binop->op_flags = flags | OPf_KIDS;
2600 binop->op_private = 1 | (flags >> 8);
2603 binop->op_private = 2 | (flags >> 8);
2604 first->op_sibling = last;
2607 binop = (BINOP*)CHECKOP(type, binop);
2608 if (binop->op_next || binop->op_type != type)
2611 binop->op_last = binop->op_first->op_sibling;
2613 return fold_constants((OP *)binop);
2617 utf8compare(const void *a, const void *b)
2620 for (i = 0; i < 10; i++) {
2621 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2623 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2630 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2632 SV *tstr = ((SVOP*)expr)->op_sv;
2633 SV *rstr = ((SVOP*)repl)->op_sv;
2636 U8 *t = (U8*)SvPV(tstr, tlen);
2637 U8 *r = (U8*)SvPV(rstr, rlen);
2644 register short *tbl;
2646 complement = o->op_private & OPpTRANS_COMPLEMENT;
2647 del = o->op_private & OPpTRANS_DELETE;
2648 squash = o->op_private & OPpTRANS_SQUASH;
2651 o->op_private |= OPpTRANS_FROM_UTF;
2654 o->op_private |= OPpTRANS_TO_UTF;
2656 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2657 SV* listsv = newSVpvn("# comment\n",10);
2659 U8* tend = t + tlen;
2660 U8* rend = r + rlen;
2674 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2675 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2676 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2677 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2680 U8 tmpbuf[UTF8_MAXLEN+1];
2684 New(1109, cp, tlen, U8*);
2686 transv = newSVpvn("",0);
2695 qsort(cp, i, sizeof(U8*), utf8compare);
2696 for (j = 0; j < i; j++) {
2698 I32 cur = j < i ? cp[j+1] - s : tend - s;
2699 UV val = utf8_to_uv(s, cur, &ulen, 0);
2701 diff = val - nextmin;
2703 t = uv_to_utf8(tmpbuf,nextmin);
2704 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2706 t = uv_to_utf8(tmpbuf, val - 1);
2707 sv_catpvn(transv, "\377", 1);
2708 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2712 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2716 t = uv_to_utf8(tmpbuf,nextmin);
2717 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2718 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2719 sv_catpvn(transv, "\377", 1);
2720 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2721 t = (U8*)SvPVX(transv);
2722 tlen = SvCUR(transv);
2725 else if (!rlen && !del) {
2726 r = t; rlen = tlen; rend = tend;
2730 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2732 o->op_private |= OPpTRANS_IDENTICAL;
2736 while (t < tend || tfirst <= tlast) {
2737 /* see if we need more "t" chars */
2738 if (tfirst > tlast) {
2739 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2741 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2743 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2750 /* now see if we need more "r" chars */
2751 if (rfirst > rlast) {
2753 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2755 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2757 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2766 rfirst = rlast = 0xffffffff;
2770 /* now see which range will peter our first, if either. */
2771 tdiff = tlast - tfirst;
2772 rdiff = rlast - rfirst;
2779 if (rfirst == 0xffffffff) {
2780 diff = tdiff; /* oops, pretend rdiff is infinite */
2782 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2783 (long)tfirst, (long)tlast);
2785 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2789 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2790 (long)tfirst, (long)(tfirst + diff),
2793 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2794 (long)tfirst, (long)rfirst);
2796 if (rfirst + diff > max)
2797 max = rfirst + diff;
2800 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2811 else if (max > 0xff)
2816 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2817 SvREFCNT_dec(listsv);
2819 SvREFCNT_dec(transv);
2821 if (!del && havefinal)
2822 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2823 newSVuv((UV)final), 0);
2826 o->op_private |= OPpTRANS_GROWS;
2838 tbl = (short*)cPVOPo->op_pv;
2840 Zero(tbl, 256, short);
2841 for (i = 0; i < tlen; i++)
2843 for (i = 0, j = 0; i < 256; i++) {
2854 if (i < 128 && r[j] >= 128)
2862 if (!rlen && !del) {
2865 o->op_private |= OPpTRANS_IDENTICAL;
2867 for (i = 0; i < 256; i++)
2869 for (i = 0, j = 0; i < tlen; i++,j++) {
2872 if (tbl[t[i]] == -1)
2878 if (tbl[t[i]] == -1) {
2879 if (t[i] < 128 && r[j] >= 128)
2886 o->op_private |= OPpTRANS_GROWS;
2894 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2898 NewOp(1101, pmop, 1, PMOP);
2899 pmop->op_type = type;
2900 pmop->op_ppaddr = PL_ppaddr[type];
2901 pmop->op_flags = flags;
2902 pmop->op_private = 0 | (flags >> 8);
2904 if (PL_hints & HINT_RE_TAINT)
2905 pmop->op_pmpermflags |= PMf_RETAINT;
2906 if (PL_hints & HINT_LOCALE)
2907 pmop->op_pmpermflags |= PMf_LOCALE;
2908 pmop->op_pmflags = pmop->op_pmpermflags;
2910 /* link into pm list */
2911 if (type != OP_TRANS && PL_curstash) {
2912 pmop->op_pmnext = HvPMROOT(PL_curstash);
2913 HvPMROOT(PL_curstash) = pmop;
2920 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2924 I32 repl_has_vars = 0;
2926 if (o->op_type == OP_TRANS)
2927 return pmtrans(o, expr, repl);
2929 PL_hints |= HINT_BLOCK_SCOPE;
2932 if (expr->op_type == OP_CONST) {
2934 SV *pat = ((SVOP*)expr)->op_sv;
2935 char *p = SvPV(pat, plen);
2936 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2937 sv_setpvn(pat, "\\s+", 3);
2938 p = SvPV(pat, plen);
2939 pm->op_pmflags |= PMf_SKIPWHITE;
2941 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2942 pm->op_pmdynflags |= PMdf_UTF8;
2943 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2944 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2945 pm->op_pmflags |= PMf_WHITE;
2949 if (PL_hints & HINT_UTF8)
2950 pm->op_pmdynflags |= PMdf_UTF8;
2951 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2952 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2954 : OP_REGCMAYBE),0,expr);
2956 NewOp(1101, rcop, 1, LOGOP);
2957 rcop->op_type = OP_REGCOMP;
2958 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2959 rcop->op_first = scalar(expr);
2960 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2961 ? (OPf_SPECIAL | OPf_KIDS)
2963 rcop->op_private = 1;
2966 /* establish postfix order */
2967 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2969 rcop->op_next = expr;
2970 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2973 rcop->op_next = LINKLIST(expr);
2974 expr->op_next = (OP*)rcop;
2977 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2982 if (pm->op_pmflags & PMf_EVAL) {
2984 if (CopLINE(PL_curcop) < PL_multi_end)
2985 CopLINE_set(PL_curcop, PL_multi_end);
2988 else if (repl->op_type == OP_THREADSV
2989 && strchr("&`'123456789+",
2990 PL_threadsv_names[repl->op_targ]))
2994 #endif /* USE_THREADS */
2995 else if (repl->op_type == OP_CONST)
2999 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3000 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3002 if (curop->op_type == OP_THREADSV) {
3004 if (strchr("&`'123456789+", curop->op_private))
3008 if (curop->op_type == OP_GV) {
3009 GV *gv = cGVOPx_gv(curop);
3011 if (strchr("&`'123456789+", *GvENAME(gv)))
3014 #endif /* USE_THREADS */
3015 else if (curop->op_type == OP_RV2CV)
3017 else if (curop->op_type == OP_RV2SV ||
3018 curop->op_type == OP_RV2AV ||
3019 curop->op_type == OP_RV2HV ||
3020 curop->op_type == OP_RV2GV) {
3021 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3024 else if (curop->op_type == OP_PADSV ||
3025 curop->op_type == OP_PADAV ||
3026 curop->op_type == OP_PADHV ||
3027 curop->op_type == OP_PADANY) {
3030 else if (curop->op_type == OP_PUSHRE)
3031 ; /* Okay here, dangerous in newASSIGNOP */
3040 && (!pm->op_pmregexp
3041 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3042 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3043 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3044 prepend_elem(o->op_type, scalar(repl), o);
3047 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3048 pm->op_pmflags |= PMf_MAYBE_CONST;
3049 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3051 NewOp(1101, rcop, 1, LOGOP);
3052 rcop->op_type = OP_SUBSTCONT;
3053 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3054 rcop->op_first = scalar(repl);
3055 rcop->op_flags |= OPf_KIDS;
3056 rcop->op_private = 1;
3059 /* establish postfix order */
3060 rcop->op_next = LINKLIST(repl);
3061 repl->op_next = (OP*)rcop;
3063 pm->op_pmreplroot = scalar((OP*)rcop);
3064 pm->op_pmreplstart = LINKLIST(rcop);
3073 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3076 NewOp(1101, svop, 1, SVOP);
3077 svop->op_type = type;
3078 svop->op_ppaddr = PL_ppaddr[type];
3080 svop->op_next = (OP*)svop;
3081 svop->op_flags = flags;
3082 if (PL_opargs[type] & OA_RETSCALAR)
3084 if (PL_opargs[type] & OA_TARGET)
3085 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3086 return CHECKOP(type, svop);
3090 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3093 NewOp(1101, padop, 1, PADOP);
3094 padop->op_type = type;
3095 padop->op_ppaddr = PL_ppaddr[type];
3096 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3097 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3098 PL_curpad[padop->op_padix] = sv;
3100 padop->op_next = (OP*)padop;
3101 padop->op_flags = flags;
3102 if (PL_opargs[type] & OA_RETSCALAR)
3104 if (PL_opargs[type] & OA_TARGET)
3105 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3106 return CHECKOP(type, padop);
3110 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3114 return newPADOP(type, flags, SvREFCNT_inc(gv));
3116 return newSVOP(type, flags, SvREFCNT_inc(gv));
3121 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3124 NewOp(1101, pvop, 1, PVOP);
3125 pvop->op_type = type;
3126 pvop->op_ppaddr = PL_ppaddr[type];
3128 pvop->op_next = (OP*)pvop;
3129 pvop->op_flags = flags;
3130 if (PL_opargs[type] & OA_RETSCALAR)
3132 if (PL_opargs[type] & OA_TARGET)
3133 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3134 return CHECKOP(type, pvop);
3138 Perl_package(pTHX_ OP *o)
3142 save_hptr(&PL_curstash);
3143 save_item(PL_curstname);
3148 name = SvPV(sv, len);
3149 PL_curstash = gv_stashpvn(name,len,TRUE);
3150 sv_setpvn(PL_curstname, name, len);
3154 sv_setpv(PL_curstname,"<none>");
3155 PL_curstash = Nullhv;
3157 PL_hints |= HINT_BLOCK_SCOPE;
3158 PL_copline = NOLINE;
3163 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3171 if (id->op_type != OP_CONST)
3172 Perl_croak(aTHX_ "Module name must be constant");
3176 if (version != Nullop) {
3177 SV *vesv = ((SVOP*)version)->op_sv;
3179 if (arg == Nullop && !SvNIOKp(vesv)) {
3186 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3187 Perl_croak(aTHX_ "Version number must be constant number");
3189 /* Make copy of id so we don't free it twice */
3190 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3192 /* Fake up a method call to VERSION */
3193 meth = newSVpvn("VERSION",7);
3194 sv_upgrade(meth, SVt_PVIV);
3195 (void)SvIOK_on(meth);
3196 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3197 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3198 append_elem(OP_LIST,
3199 prepend_elem(OP_LIST, pack, list(version)),
3200 newSVOP(OP_METHOD_NAMED, 0, meth)));
3204 /* Fake up an import/unimport */
3205 if (arg && arg->op_type == OP_STUB)
3206 imop = arg; /* no import on explicit () */
3207 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3208 imop = Nullop; /* use 5.0; */
3213 /* Make copy of id so we don't free it twice */
3214 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3216 /* Fake up a method call to import/unimport */
3217 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3218 sv_upgrade(meth, SVt_PVIV);
3219 (void)SvIOK_on(meth);
3220 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3221 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3222 append_elem(OP_LIST,
3223 prepend_elem(OP_LIST, pack, list(arg)),
3224 newSVOP(OP_METHOD_NAMED, 0, meth)));
3227 /* Fake up a require, handle override, if any */
3228 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3229 if (!(gv && GvIMPORTED_CV(gv)))
3230 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3232 if (gv && GvIMPORTED_CV(gv)) {
3233 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3234 append_elem(OP_LIST, id,
3235 scalar(newUNOP(OP_RV2CV, 0,
3240 rqop = newUNOP(OP_REQUIRE, 0, id);
3243 /* Fake up the BEGIN {}, which does its thing immediately. */
3245 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3248 append_elem(OP_LINESEQ,
3249 append_elem(OP_LINESEQ,
3250 newSTATEOP(0, Nullch, rqop),
3251 newSTATEOP(0, Nullch, veop)),
3252 newSTATEOP(0, Nullch, imop) ));
3254 PL_hints |= HINT_BLOCK_SCOPE;
3255 PL_copline = NOLINE;
3260 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3263 va_start(args, ver);
3264 vload_module(flags, name, ver, &args);
3268 #ifdef PERL_IMPLICIT_CONTEXT
3270 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3274 va_start(args, ver);
3275 vload_module(flags, name, ver, &args);
3281 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3283 OP *modname, *veop, *imop;
3285 modname = newSVOP(OP_CONST, 0, name);
3286 modname->op_private |= OPpCONST_BARE;
3288 veop = newSVOP(OP_CONST, 0, ver);
3292 if (flags & PERL_LOADMOD_NOIMPORT) {
3293 imop = sawparens(newNULLLIST());
3295 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3296 imop = va_arg(*args, OP*);
3301 sv = va_arg(*args, SV*);
3303 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3304 sv = va_arg(*args, SV*);
3308 line_t ocopline = PL_copline;
3309 int oexpect = PL_expect;
3311 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3312 veop, modname, imop);
3313 PL_expect = oexpect;
3314 PL_copline = ocopline;
3319 Perl_dofile(pTHX_ OP *term)
3324 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3325 if (!(gv && GvIMPORTED_CV(gv)))
3326 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3328 if (gv && GvIMPORTED_CV(gv)) {
3329 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3330 append_elem(OP_LIST, term,
3331 scalar(newUNOP(OP_RV2CV, 0,
3336 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3342 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3344 return newBINOP(OP_LSLICE, flags,
3345 list(force_list(subscript)),
3346 list(force_list(listval)) );
3350 S_list_assignment(pTHX_ register OP *o)
3355 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3356 o = cUNOPo->op_first;
3358 if (o->op_type == OP_COND_EXPR) {
3359 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3360 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3365 yyerror("Assignment to both a list and a scalar");
3369 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3370 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3371 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3374 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3377 if (o->op_type == OP_RV2SV)
3384 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3389 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3390 return newLOGOP(optype, 0,
3391 mod(scalar(left), optype),
3392 newUNOP(OP_SASSIGN, 0, scalar(right)));
3395 return newBINOP(optype, OPf_STACKED,
3396 mod(scalar(left), optype), scalar(right));
3400 if (list_assignment(left)) {
3404 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3405 left = mod(left, OP_AASSIGN);
3413 curop = list(force_list(left));
3414 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3415 o->op_private = 0 | (flags >> 8);
3416 for (curop = ((LISTOP*)curop)->op_first;
3417 curop; curop = curop->op_sibling)
3419 if (curop->op_type == OP_RV2HV &&
3420 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3421 o->op_private |= OPpASSIGN_HASH;
3425 if (!(left->op_private & OPpLVAL_INTRO)) {
3428 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3429 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3430 if (curop->op_type == OP_GV) {
3431 GV *gv = cGVOPx_gv(curop);
3432 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3434 SvCUR(gv) = PL_generation;
3436 else if (curop->op_type == OP_PADSV ||
3437 curop->op_type == OP_PADAV ||
3438 curop->op_type == OP_PADHV ||
3439 curop->op_type == OP_PADANY) {
3440 SV **svp = AvARRAY(PL_comppad_name);
3441 SV *sv = svp[curop->op_targ];
3442 if (SvCUR(sv) == PL_generation)
3444 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3446 else if (curop->op_type == OP_RV2CV)
3448 else if (curop->op_type == OP_RV2SV ||
3449 curop->op_type == OP_RV2AV ||
3450 curop->op_type == OP_RV2HV ||
3451 curop->op_type == OP_RV2GV) {
3452 if (lastop->op_type != OP_GV) /* funny deref? */
3455 else if (curop->op_type == OP_PUSHRE) {
3456 if (((PMOP*)curop)->op_pmreplroot) {
3458 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3460 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3462 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3464 SvCUR(gv) = PL_generation;
3473 o->op_private |= OPpASSIGN_COMMON;
3475 if (right && right->op_type == OP_SPLIT) {
3477 if ((tmpop = ((LISTOP*)right)->op_first) &&
3478 tmpop->op_type == OP_PUSHRE)
3480 PMOP *pm = (PMOP*)tmpop;
3481 if (left->op_type == OP_RV2AV &&
3482 !(left->op_private & OPpLVAL_INTRO) &&
3483 !(o->op_private & OPpASSIGN_COMMON) )
3485 tmpop = ((UNOP*)left)->op_first;
3486 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3488 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3489 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3491 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3492 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3494 pm->op_pmflags |= PMf_ONCE;
3495 tmpop = cUNOPo->op_first; /* to list (nulled) */
3496 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3497 tmpop->op_sibling = Nullop; /* don't free split */
3498 right->op_next = tmpop->op_next; /* fix starting loc */
3499 op_free(o); /* blow off assign */
3500 right->op_flags &= ~OPf_WANT;
3501 /* "I don't know and I don't care." */
3506 if (PL_modcount < RETVAL_MAX &&
3507 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3509 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3511 sv_setiv(sv, PL_modcount+1);
3519 right = newOP(OP_UNDEF, 0);
3520 if (right->op_type == OP_READLINE) {
3521 right->op_flags |= OPf_STACKED;
3522 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3525 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3526 o = newBINOP(OP_SASSIGN, flags,
3527 scalar(right), mod(scalar(left), OP_SASSIGN) );
3539 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3541 U32 seq = intro_my();
3544 NewOp(1101, cop, 1, COP);
3545 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3546 cop->op_type = OP_DBSTATE;
3547 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3550 cop->op_type = OP_NEXTSTATE;
3551 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3553 cop->op_flags = flags;
3554 cop->op_private = (PL_hints & HINT_BYTE);
3556 cop->op_private |= NATIVE_HINTS;
3558 PL_compiling.op_private = cop->op_private;
3559 cop->op_next = (OP*)cop;
3562 cop->cop_label = label;
3563 PL_hints |= HINT_BLOCK_SCOPE;
3566 cop->cop_arybase = PL_curcop->cop_arybase;
3567 if (specialWARN(PL_curcop->cop_warnings))
3568 cop->cop_warnings = PL_curcop->cop_warnings ;
3570 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3571 if (specialCopIO(PL_curcop->cop_io))
3572 cop->cop_io = PL_curcop->cop_io;
3574 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3577 if (PL_copline == NOLINE)
3578 CopLINE_set(cop, CopLINE(PL_curcop));
3580 CopLINE_set(cop, PL_copline);
3581 PL_copline = NOLINE;
3584 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3586 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3588 CopSTASH_set(cop, PL_curstash);
3590 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3591 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3592 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3593 (void)SvIOK_on(*svp);
3594 SvIVX(*svp) = PTR2IV(cop);
3598 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3601 /* "Introduce" my variables to visible status. */
3609 if (! PL_min_intro_pending)
3610 return PL_cop_seqmax;
3612 svp = AvARRAY(PL_comppad_name);
3613 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3614 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3615 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3616 SvNVX(sv) = (NV)PL_cop_seqmax;
3619 PL_min_intro_pending = 0;
3620 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3621 return PL_cop_seqmax++;
3625 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3627 return new_logop(type, flags, &first, &other);
3631 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3635 OP *first = *firstp;
3636 OP *other = *otherp;
3638 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3639 return newBINOP(type, flags, scalar(first), scalar(other));
3641 scalarboolean(first);
3642 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3643 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3644 if (type == OP_AND || type == OP_OR) {
3650 first = *firstp = cUNOPo->op_first;
3652 first->op_next = o->op_next;
3653 cUNOPo->op_first = Nullop;
3657 if (first->op_type == OP_CONST) {
3658 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3659 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3660 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3671 else if (first->op_type == OP_WANTARRAY) {
3677 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3678 OP *k1 = ((UNOP*)first)->op_first;
3679 OP *k2 = k1->op_sibling;
3681 switch (first->op_type)
3684 if (k2 && k2->op_type == OP_READLINE
3685 && (k2->op_flags & OPf_STACKED)
3686 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3688 warnop = k2->op_type;
3693 if (k1->op_type == OP_READDIR
3694 || k1->op_type == OP_GLOB
3695 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3696 || k1->op_type == OP_EACH)
3698 warnop = ((k1->op_type == OP_NULL)
3699 ? k1->op_targ : k1->op_type);
3704 line_t oldline = CopLINE(PL_curcop);
3705 CopLINE_set(PL_curcop, PL_copline);
3706 Perl_warner(aTHX_ WARN_MISC,
3707 "Value of %s%s can be \"0\"; test with defined()",
3709 ((warnop == OP_READLINE || warnop == OP_GLOB)
3710 ? " construct" : "() operator"));
3711 CopLINE_set(PL_curcop, oldline);
3718 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3719 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3721 NewOp(1101, logop, 1, LOGOP);
3723 logop->op_type = type;
3724 logop->op_ppaddr = PL_ppaddr[type];
3725 logop->op_first = first;
3726 logop->op_flags = flags | OPf_KIDS;
3727 logop->op_other = LINKLIST(other);
3728 logop->op_private = 1 | (flags >> 8);
3730 /* establish postfix order */
3731 logop->op_next = LINKLIST(first);
3732 first->op_next = (OP*)logop;
3733 first->op_sibling = other;
3735 o = newUNOP(OP_NULL, 0, (OP*)logop);
3742 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3749 return newLOGOP(OP_AND, 0, first, trueop);
3751 return newLOGOP(OP_OR, 0, first, falseop);
3753 scalarboolean(first);
3754 if (first->op_type == OP_CONST) {
3755 if (SvTRUE(((SVOP*)first)->op_sv)) {
3766 else if (first->op_type == OP_WANTARRAY) {
3770 NewOp(1101, logop, 1, LOGOP);
3771 logop->op_type = OP_COND_EXPR;
3772 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3773 logop->op_first = first;
3774 logop->op_flags = flags | OPf_KIDS;
3775 logop->op_private = 1 | (flags >> 8);
3776 logop->op_other = LINKLIST(trueop);
3777 logop->op_next = LINKLIST(falseop);
3780 /* establish postfix order */
3781 start = LINKLIST(first);
3782 first->op_next = (OP*)logop;
3784 first->op_sibling = trueop;
3785 trueop->op_sibling = falseop;
3786 o = newUNOP(OP_NULL, 0, (OP*)logop);
3788 trueop->op_next = falseop->op_next = o;
3795 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3803 NewOp(1101, range, 1, LOGOP);
3805 range->op_type = OP_RANGE;
3806 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3807 range->op_first = left;
3808 range->op_flags = OPf_KIDS;
3809 leftstart = LINKLIST(left);
3810 range->op_other = LINKLIST(right);
3811 range->op_private = 1 | (flags >> 8);
3813 left->op_sibling = right;
3815 range->op_next = (OP*)range;
3816 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3817 flop = newUNOP(OP_FLOP, 0, flip);
3818 o = newUNOP(OP_NULL, 0, flop);
3820 range->op_next = leftstart;
3822 left->op_next = flip;
3823 right->op_next = flop;
3825 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3826 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3827 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3828 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3830 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3831 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3834 if (!flip->op_private || !flop->op_private)
3835 linklist(o); /* blow off optimizer unless constant */
3841 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3845 int once = block && block->op_flags & OPf_SPECIAL &&
3846 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3849 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3850 return block; /* do {} while 0 does once */
3851 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3852 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3853 expr = newUNOP(OP_DEFINED, 0,
3854 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3855 } else if (expr->op_flags & OPf_KIDS) {
3856 OP *k1 = ((UNOP*)expr)->op_first;
3857 OP *k2 = (k1) ? k1->op_sibling : NULL;
3858 switch (expr->op_type) {
3860 if (k2 && k2->op_type == OP_READLINE
3861 && (k2->op_flags & OPf_STACKED)
3862 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3863 expr = newUNOP(OP_DEFINED, 0, expr);
3867 if (k1->op_type == OP_READDIR
3868 || k1->op_type == OP_GLOB
3869 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3870 || k1->op_type == OP_EACH)
3871 expr = newUNOP(OP_DEFINED, 0, expr);
3877 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3878 o = new_logop(OP_AND, 0, &expr, &listop);
3881 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3883 if (once && o != listop)
3884 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3887 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3889 o->op_flags |= flags;
3891 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3896 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3905 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3906 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3907 expr = newUNOP(OP_DEFINED, 0,
3908 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3909 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3910 OP *k1 = ((UNOP*)expr)->op_first;
3911 OP *k2 = (k1) ? k1->op_sibling : NULL;
3912 switch (expr->op_type) {
3914 if (k2 && k2->op_type == OP_READLINE
3915 && (k2->op_flags & OPf_STACKED)
3916 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3917 expr = newUNOP(OP_DEFINED, 0, expr);
3921 if (k1->op_type == OP_READDIR
3922 || k1->op_type == OP_GLOB
3923 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3924 || k1->op_type == OP_EACH)
3925 expr = newUNOP(OP_DEFINED, 0, expr);
3931 block = newOP(OP_NULL, 0);
3933 block = scope(block);
3937 next = LINKLIST(cont);
3940 OP *unstack = newOP(OP_UNSTACK, 0);
3943 cont = append_elem(OP_LINESEQ, cont, unstack);
3944 if ((line_t)whileline != NOLINE) {
3945 PL_copline = whileline;
3946 cont = append_elem(OP_LINESEQ, cont,
3947 newSTATEOP(0, Nullch, Nullop));
3951 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3952 redo = LINKLIST(listop);
3955 PL_copline = whileline;
3957 o = new_logop(OP_AND, 0, &expr, &listop);
3958 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3959 op_free(expr); /* oops, it's a while (0) */
3961 return Nullop; /* listop already freed by new_logop */
3964 ((LISTOP*)listop)->op_last->op_next = condop =
3965 (o == listop ? redo : LINKLIST(o));
3971 NewOp(1101,loop,1,LOOP);
3972 loop->op_type = OP_ENTERLOOP;
3973 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3974 loop->op_private = 0;
3975 loop->op_next = (OP*)loop;
3978 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3980 loop->op_redoop = redo;
3981 loop->op_lastop = o;
3982 o->op_private |= loopflags;
3985 loop->op_nextop = next;
3987 loop->op_nextop = o;
3989 o->op_flags |= flags;
3990 o->op_private |= (flags >> 8);
3995 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4003 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4004 sv->op_type = OP_RV2GV;
4005 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4007 else if (sv->op_type == OP_PADSV) { /* private variable */
4008 padoff = sv->op_targ;
4013 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4014 padoff = sv->op_targ;
4016 iterflags |= OPf_SPECIAL;
4021 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4025 padoff = find_threadsv("_");
4026 iterflags |= OPf_SPECIAL;
4028 sv = newGVOP(OP_GV, 0, PL_defgv);
4031 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4032 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4033 iterflags |= OPf_STACKED;
4035 else if (expr->op_type == OP_NULL &&
4036 (expr->op_flags & OPf_KIDS) &&
4037 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4039 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4040 * set the STACKED flag to indicate that these values are to be
4041 * treated as min/max values by 'pp_iterinit'.
4043 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4044 LOGOP* range = (LOGOP*) flip->op_first;
4045 OP* left = range->op_first;
4046 OP* right = left->op_sibling;
4049 range->op_flags &= ~OPf_KIDS;
4050 range->op_first = Nullop;
4052 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4053 listop->op_first->op_next = range->op_next;
4054 left->op_next = range->op_other;
4055 right->op_next = (OP*)listop;
4056 listop->op_next = listop->op_first;
4059 expr = (OP*)(listop);
4061 iterflags |= OPf_STACKED;
4064 expr = mod(force_list(expr), OP_GREPSTART);
4068 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4069 append_elem(OP_LIST, expr, scalar(sv))));
4070 assert(!loop->op_next);
4071 #ifdef PL_OP_SLAB_ALLOC
4074 NewOp(1234,tmp,1,LOOP);
4075 Copy(loop,tmp,1,LOOP);
4079 Renew(loop, 1, LOOP);
4081 loop->op_targ = padoff;
4082 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4083 PL_copline = forline;
4084 return newSTATEOP(0, label, wop);
4088 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4093 if (type != OP_GOTO || label->op_type == OP_CONST) {
4094 /* "last()" means "last" */
4095 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4096 o = newOP(type, OPf_SPECIAL);
4098 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4099 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4105 if (label->op_type == OP_ENTERSUB)
4106 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4107 o = newUNOP(type, OPf_STACKED, label);
4109 PL_hints |= HINT_BLOCK_SCOPE;
4114 Perl_cv_undef(pTHX_ CV *cv)
4118 MUTEX_DESTROY(CvMUTEXP(cv));
4119 Safefree(CvMUTEXP(cv));
4122 #endif /* USE_THREADS */
4124 if (!CvXSUB(cv) && CvROOT(cv)) {
4126 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4127 Perl_croak(aTHX_ "Can't undef active subroutine");
4130 Perl_croak(aTHX_ "Can't undef active subroutine");
4131 #endif /* USE_THREADS */
4134 SAVEVPTR(PL_curpad);
4138 op_free(CvROOT(cv));
4139 CvROOT(cv) = Nullop;
4142 SvPOK_off((SV*)cv); /* forget prototype */
4144 SvREFCNT_dec(CvGV(cv));
4146 SvREFCNT_dec(CvOUTSIDE(cv));
4147 CvOUTSIDE(cv) = Nullcv;
4149 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4152 if (CvPADLIST(cv)) {
4153 /* may be during global destruction */
4154 if (SvREFCNT(CvPADLIST(cv))) {
4155 I32 i = AvFILLp(CvPADLIST(cv));
4157 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4158 SV* sv = svp ? *svp : Nullsv;
4161 if (sv == (SV*)PL_comppad_name)
4162 PL_comppad_name = Nullav;
4163 else if (sv == (SV*)PL_comppad) {
4164 PL_comppad = Nullav;
4165 PL_curpad = Null(SV**);
4169 SvREFCNT_dec((SV*)CvPADLIST(cv));
4171 CvPADLIST(cv) = Nullav;
4176 S_cv_dump(pTHX_ CV *cv)
4179 CV *outside = CvOUTSIDE(cv);
4180 AV* padlist = CvPADLIST(cv);
4187 PerlIO_printf(Perl_debug_log,
4188 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4190 (CvANON(cv) ? "ANON"
4191 : (cv == PL_main_cv) ? "MAIN"
4192 : CvUNIQUE(cv) ? "UNIQUE"
4193 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4196 : CvANON(outside) ? "ANON"
4197 : (outside == PL_main_cv) ? "MAIN"
4198 : CvUNIQUE(outside) ? "UNIQUE"
4199 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4204 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4205 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4206 pname = AvARRAY(pad_name);
4207 ppad = AvARRAY(pad);
4209 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4210 if (SvPOK(pname[ix]))
4211 PerlIO_printf(Perl_debug_log,
4212 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4213 (int)ix, PTR2UV(ppad[ix]),
4214 SvFAKE(pname[ix]) ? "FAKE " : "",
4216 (IV)I_32(SvNVX(pname[ix])),
4219 #endif /* DEBUGGING */
4223 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4227 AV* protopadlist = CvPADLIST(proto);
4228 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4229 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4230 SV** pname = AvARRAY(protopad_name);
4231 SV** ppad = AvARRAY(protopad);
4232 I32 fname = AvFILLp(protopad_name);
4233 I32 fpad = AvFILLp(protopad);
4237 assert(!CvUNIQUE(proto));
4241 SAVESPTR(PL_comppad_name);
4242 SAVESPTR(PL_compcv);
4244 cv = PL_compcv = (CV*)NEWSV(1104,0);
4245 sv_upgrade((SV *)cv, SvTYPE(proto));
4246 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4250 New(666, CvMUTEXP(cv), 1, perl_mutex);
4251 MUTEX_INIT(CvMUTEXP(cv));
4253 #endif /* USE_THREADS */
4254 CvFILE(cv) = CvFILE(proto);
4255 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4256 CvSTASH(cv) = CvSTASH(proto);
4257 CvROOT(cv) = CvROOT(proto);
4258 CvSTART(cv) = CvSTART(proto);
4260 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4263 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4265 PL_comppad_name = newAV();
4266 for (ix = fname; ix >= 0; ix--)
4267 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4269 PL_comppad = newAV();
4271 comppadlist = newAV();
4272 AvREAL_off(comppadlist);
4273 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4274 av_store(comppadlist, 1, (SV*)PL_comppad);
4275 CvPADLIST(cv) = comppadlist;
4276 av_fill(PL_comppad, AvFILLp(protopad));
4277 PL_curpad = AvARRAY(PL_comppad);
4279 av = newAV(); /* will be @_ */
4281 av_store(PL_comppad, 0, (SV*)av);
4282 AvFLAGS(av) = AVf_REIFY;
4284 for (ix = fpad; ix > 0; ix--) {
4285 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4286 if (namesv && namesv != &PL_sv_undef) {
4287 char *name = SvPVX(namesv); /* XXX */
4288 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4289 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4290 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4292 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4294 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4296 else { /* our own lexical */
4299 /* anon code -- we'll come back for it */
4300 sv = SvREFCNT_inc(ppad[ix]);
4302 else if (*name == '@')
4304 else if (*name == '%')
4313 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4314 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4317 SV* sv = NEWSV(0,0);
4323 /* Now that vars are all in place, clone nested closures. */
4325 for (ix = fpad; ix > 0; ix--) {
4326 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4328 && namesv != &PL_sv_undef
4329 && !(SvFLAGS(namesv) & SVf_FAKE)
4330 && *SvPVX(namesv) == '&'
4331 && CvCLONE(ppad[ix]))
4333 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4334 SvREFCNT_dec(ppad[ix]);
4337 PL_curpad[ix] = (SV*)kid;
4341 #ifdef DEBUG_CLOSURES
4342 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4344 PerlIO_printf(Perl_debug_log, " from:\n");
4346 PerlIO_printf(Perl_debug_log, " to:\n");
4353 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4355 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4357 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4364 Perl_cv_clone(pTHX_ CV *proto)
4367 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4368 cv = cv_clone2(proto, CvOUTSIDE(proto));
4369 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4374 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4376 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4377 SV* msg = sv_newmortal();
4381 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4382 sv_setpv(msg, "Prototype mismatch:");
4384 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4386 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4387 sv_catpv(msg, " vs ");
4389 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4391 sv_catpv(msg, "none");
4392 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4396 static void const_sv_xsub(pTHXo_ CV* cv);
4399 =for apidoc cv_const_sv
4401 If C<cv> is a constant sub eligible for inlining. returns the constant
4402 value returned by the sub. Otherwise, returns NULL.
4404 Constant subs can be created with C<newCONSTSUB> or as described in
4405 L<perlsub/"Constant Functions">.
4410 Perl_cv_const_sv(pTHX_ CV *cv)
4412 if (!cv || !CvCONST(cv))
4414 return (SV*)CvXSUBANY(cv).any_ptr;
4418 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4425 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4426 o = cLISTOPo->op_first->op_sibling;
4428 for (; o; o = o->op_next) {
4429 OPCODE type = o->op_type;
4431 if (sv && o->op_next == o)
4433 if (o->op_next != o) {
4434 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4436 if (type == OP_DBSTATE)
4439 if (type == OP_LEAVESUB || type == OP_RETURN)
4443 if (type == OP_CONST && cSVOPo->op_sv)
4445 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4446 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4447 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4451 /* We get here only from cv_clone2() while creating a closure.
4452 Copy the const value here instead of in cv_clone2 so that
4453 SvREADONLY_on doesn't lead to problems when leaving
4458 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4470 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4480 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4484 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4486 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4490 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4496 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4501 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4502 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4503 SV *sv = sv_newmortal();
4504 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4505 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4510 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4511 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4521 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4522 maximum a prototype before. */
4523 if (SvTYPE(gv) > SVt_NULL) {
4524 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4525 && ckWARN_d(WARN_PROTOTYPE))
4527 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4529 cv_ckproto((CV*)gv, NULL, ps);
4532 sv_setpv((SV*)gv, ps);
4534 sv_setiv((SV*)gv, -1);
4535 SvREFCNT_dec(PL_compcv);
4536 cv = PL_compcv = NULL;
4537 PL_sub_generation++;
4541 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4543 if (!block || !ps || *ps || attrs)
4546 const_sv = op_const_sv(block, Nullcv);
4549 bool exists = CvROOT(cv) || CvXSUB(cv);
4550 /* if the subroutine doesn't exist and wasn't pre-declared
4551 * with a prototype, assume it will be AUTOLOADed,
4552 * skipping the prototype check
4554 if (exists || SvPOK(cv))
4555 cv_ckproto(cv, gv, ps);
4556 /* already defined (or promised)? */
4557 if (exists || GvASSUMECV(gv)) {
4558 if (!block && !attrs) {
4559 /* just a "sub foo;" when &foo is already defined */
4560 SAVEFREESV(PL_compcv);
4563 /* ahem, death to those who redefine active sort subs */
4564 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4565 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4567 if (ckWARN(WARN_REDEFINE)
4569 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4571 line_t oldline = CopLINE(PL_curcop);
4572 CopLINE_set(PL_curcop, PL_copline);
4573 Perl_warner(aTHX_ WARN_REDEFINE,
4574 CvCONST(cv) ? "Constant subroutine %s redefined"
4575 : "Subroutine %s redefined", name);
4576 CopLINE_set(PL_curcop, oldline);
4584 SvREFCNT_inc(const_sv);
4586 assert(!CvROOT(cv) && !CvCONST(cv));
4587 sv_setpv((SV*)cv, ""); /* prototype is "" */
4588 CvXSUBANY(cv).any_ptr = const_sv;
4589 CvXSUB(cv) = const_sv_xsub;
4594 cv = newCONSTSUB(NULL, name, const_sv);
4597 SvREFCNT_dec(PL_compcv);
4599 PL_sub_generation++;
4606 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4607 * before we clobber PL_compcv.
4611 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4612 stash = GvSTASH(CvGV(cv));
4613 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4614 stash = CvSTASH(cv);
4616 stash = PL_curstash;
4619 /* possibly about to re-define existing subr -- ignore old cv */
4620 rcv = (SV*)PL_compcv;
4621 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4622 stash = GvSTASH(gv);
4624 stash = PL_curstash;
4626 apply_attrs(stash, rcv, attrs);
4628 if (cv) { /* must reuse cv if autoloaded */
4630 /* got here with just attrs -- work done, so bug out */
4631 SAVEFREESV(PL_compcv);
4635 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4636 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4637 CvOUTSIDE(PL_compcv) = 0;
4638 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4639 CvPADLIST(PL_compcv) = 0;
4640 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4641 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4642 SvREFCNT_dec(PL_compcv);
4649 PL_sub_generation++;
4652 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4653 CvFILE(cv) = CopFILE(PL_curcop);
4654 CvSTASH(cv) = PL_curstash;
4657 if (!CvMUTEXP(cv)) {
4658 New(666, CvMUTEXP(cv), 1, perl_mutex);
4659 MUTEX_INIT(CvMUTEXP(cv));
4661 #endif /* USE_THREADS */
4664 sv_setpv((SV*)cv, ps);
4666 if (PL_error_count) {
4670 char *s = strrchr(name, ':');
4672 if (strEQ(s, "BEGIN")) {
4674 "BEGIN not safe after errors--compilation aborted";
4675 if (PL_in_eval & EVAL_KEEPERR)
4676 Perl_croak(aTHX_ not_safe);
4678 /* force display of errors found but not reported */
4679 sv_catpv(ERRSV, not_safe);
4680 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4688 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4689 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4692 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
4695 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4697 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4698 OpREFCNT_set(CvROOT(cv), 1);
4699 CvSTART(cv) = LINKLIST(CvROOT(cv));
4700 CvROOT(cv)->op_next = 0;
4703 /* now that optimizer has done its work, adjust pad values */
4705 SV **namep = AvARRAY(PL_comppad_name);
4706 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4709 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4712 * The only things that a clonable function needs in its
4713 * pad are references to outer lexicals and anonymous subs.
4714 * The rest are created anew during cloning.
4716 if (!((namesv = namep[ix]) != Nullsv &&
4717 namesv != &PL_sv_undef &&
4719 *SvPVX(namesv) == '&')))
4721 SvREFCNT_dec(PL_curpad[ix]);
4722 PL_curpad[ix] = Nullsv;
4725 assert(!CvCONST(cv));
4726 if (ps && !*ps && op_const_sv(block, cv))
4730 AV *av = newAV(); /* Will be @_ */
4732 av_store(PL_comppad, 0, (SV*)av);
4733 AvFLAGS(av) = AVf_REIFY;
4735 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4736 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4738 if (!SvPADMY(PL_curpad[ix]))
4739 SvPADTMP_on(PL_curpad[ix]);
4743 if (name || aname) {
4745 char *tname = (name ? name : aname);
4747 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4748 SV *sv = NEWSV(0,0);
4749 SV *tmpstr = sv_newmortal();
4750 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4754 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4756 (long)PL_subline, (long)CopLINE(PL_curcop));
4757 gv_efullname3(tmpstr, gv, Nullch);
4758 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4759 hv = GvHVn(db_postponed);
4760 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4761 && (pcv = GvCV(db_postponed)))
4767 call_sv((SV*)pcv, G_DISCARD);
4771 if ((s = strrchr(tname,':')))
4776 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4779 if (strEQ(s, "BEGIN")) {
4780 I32 oldscope = PL_scopestack_ix;
4782 SAVECOPFILE(&PL_compiling);
4783 SAVECOPLINE(&PL_compiling);
4785 sv_setsv(PL_rs, PL_nrs);
4788 PL_beginav = newAV();
4789 DEBUG_x( dump_sub(gv) );
4790 av_push(PL_beginav, (SV*)cv);
4791 GvCV(gv) = 0; /* cv has been hijacked */
4792 call_list(oldscope, PL_beginav);
4794 PL_curcop = &PL_compiling;
4795 PL_compiling.op_private = PL_hints;
4798 else if (strEQ(s, "END") && !PL_error_count) {
4801 DEBUG_x( dump_sub(gv) );
4802 av_unshift(PL_endav, 1);
4803 av_store(PL_endav, 0, (SV*)cv);
4804 GvCV(gv) = 0; /* cv has been hijacked */
4806 else if (strEQ(s, "CHECK") && !PL_error_count) {
4808 PL_checkav = newAV();
4809 DEBUG_x( dump_sub(gv) );
4810 if (PL_main_start && ckWARN(WARN_VOID))
4811 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4812 av_unshift(PL_checkav, 1);
4813 av_store(PL_checkav, 0, (SV*)cv);
4814 GvCV(gv) = 0; /* cv has been hijacked */
4816 else if (strEQ(s, "INIT") && !PL_error_count) {
4818 PL_initav = newAV();
4819 DEBUG_x( dump_sub(gv) );
4820 if (PL_main_start && ckWARN(WARN_VOID))
4821 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4822 av_push(PL_initav, (SV*)cv);
4823 GvCV(gv) = 0; /* cv has been hijacked */
4828 PL_copline = NOLINE;
4833 /* XXX unsafe for threads if eval_owner isn't held */
4835 =for apidoc newCONSTSUB
4837 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4838 eligible for inlining at compile-time.
4844 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4850 SAVECOPLINE(PL_curcop);
4851 CopLINE_set(PL_curcop, PL_copline);
4854 PL_hints &= ~HINT_BLOCK_SCOPE;
4857 SAVESPTR(PL_curstash);
4858 SAVECOPSTASH(PL_curcop);
4859 PL_curstash = stash;
4861 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4863 CopSTASH(PL_curcop) = stash;
4867 cv = newXS(name, const_sv_xsub, __FILE__);
4868 CvXSUBANY(cv).any_ptr = sv;
4870 sv_setpv((SV*)cv, ""); /* prototype is "" */
4878 =for apidoc U||newXS
4880 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4886 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4888 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4891 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4893 /* just a cached method */
4897 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4898 /* already defined (or promised) */
4899 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4900 && HvNAME(GvSTASH(CvGV(cv)))
4901 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4902 line_t oldline = CopLINE(PL_curcop);
4903 if (PL_copline != NOLINE)
4904 CopLINE_set(PL_curcop, PL_copline);
4905 Perl_warner(aTHX_ WARN_REDEFINE,
4906 CvCONST(cv) ? "Constant subroutine %s redefined"
4907 : "Subroutine %s redefined"
4909 CopLINE_set(PL_curcop, oldline);
4916 if (cv) /* must reuse cv if autoloaded */
4919 cv = (CV*)NEWSV(1105,0);
4920 sv_upgrade((SV *)cv, SVt_PVCV);
4924 PL_sub_generation++;
4927 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4929 New(666, CvMUTEXP(cv), 1, perl_mutex);
4930 MUTEX_INIT(CvMUTEXP(cv));
4932 #endif /* USE_THREADS */
4933 (void)gv_fetchfile(filename);
4934 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4935 an external constant string */
4936 CvXSUB(cv) = subaddr;
4939 char *s = strrchr(name,':');
4945 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4948 if (strEQ(s, "BEGIN")) {
4950 PL_beginav = newAV();
4951 av_push(PL_beginav, (SV*)cv);
4952 GvCV(gv) = 0; /* cv has been hijacked */
4954 else if (strEQ(s, "END")) {
4957 av_unshift(PL_endav, 1);
4958 av_store(PL_endav, 0, (SV*)cv);
4959 GvCV(gv) = 0; /* cv has been hijacked */
4961 else if (strEQ(s, "CHECK")) {
4963 PL_checkav = newAV();
4964 if (PL_main_start && ckWARN(WARN_VOID))
4965 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4966 av_unshift(PL_checkav, 1);
4967 av_store(PL_checkav, 0, (SV*)cv);
4968 GvCV(gv) = 0; /* cv has been hijacked */
4970 else if (strEQ(s, "INIT")) {
4972 PL_initav = newAV();
4973 if (PL_main_start && ckWARN(WARN_VOID))
4974 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4975 av_push(PL_initav, (SV*)cv);
4976 GvCV(gv) = 0; /* cv has been hijacked */
4987 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4996 name = SvPVx(cSVOPo->op_sv, n_a);
4999 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5001 if ((cv = GvFORM(gv))) {
5002 if (ckWARN(WARN_REDEFINE)) {
5003 line_t oldline = CopLINE(PL_curcop);
5005 CopLINE_set(PL_curcop, PL_copline);
5006 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5007 CopLINE_set(PL_curcop, oldline);
5013 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
5014 CvFILE(cv) = CopFILE(PL_curcop);
5016 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5017 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5018 SvPADTMP_on(PL_curpad[ix]);
5021 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5022 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5023 OpREFCNT_set(CvROOT(cv), 1);
5024 CvSTART(cv) = LINKLIST(CvROOT(cv));
5025 CvROOT(cv)->op_next = 0;
5028 PL_copline = NOLINE;
5033 Perl_newANONLIST(pTHX_ OP *o)
5035 return newUNOP(OP_REFGEN, 0,
5036 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5040 Perl_newANONHASH(pTHX_ OP *o)
5042 return newUNOP(OP_REFGEN, 0,
5043 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5047 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5049 return newANONATTRSUB(floor, proto, Nullop, block);
5053 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5055 return newUNOP(OP_REFGEN, 0,
5056 newSVOP(OP_ANONCODE, 0,
5057 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5061 Perl_oopsAV(pTHX_ OP *o)
5063 switch (o->op_type) {
5065 o->op_type = OP_PADAV;
5066 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5067 return ref(o, OP_RV2AV);
5070 o->op_type = OP_RV2AV;
5071 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5076 if (ckWARN_d(WARN_INTERNAL))
5077 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5084 Perl_oopsHV(pTHX_ OP *o)
5086 switch (o->op_type) {
5089 o->op_type = OP_PADHV;
5090 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5091 return ref(o, OP_RV2HV);
5095 o->op_type = OP_RV2HV;
5096 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5101 if (ckWARN_d(WARN_INTERNAL))
5102 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5109 Perl_newAVREF(pTHX_ OP *o)
5111 if (o->op_type == OP_PADANY) {
5112 o->op_type = OP_PADAV;
5113 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5116 return newUNOP(OP_RV2AV, 0, scalar(o));
5120 Perl_newGVREF(pTHX_ I32 type, OP *o)
5122 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5123 return newUNOP(OP_NULL, 0, o);
5124 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5128 Perl_newHVREF(pTHX_ OP *o)
5130 if (o->op_type == OP_PADANY) {
5131 o->op_type = OP_PADHV;
5132 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5135 return newUNOP(OP_RV2HV, 0, scalar(o));
5139 Perl_oopsCV(pTHX_ OP *o)
5141 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5147 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5149 return newUNOP(OP_RV2CV, flags, scalar(o));
5153 Perl_newSVREF(pTHX_ OP *o)
5155 if (o->op_type == OP_PADANY) {
5156 o->op_type = OP_PADSV;
5157 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5160 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5161 o->op_flags |= OPpDONE_SVREF;
5164 return newUNOP(OP_RV2SV, 0, scalar(o));
5167 /* Check routines. */
5170 Perl_ck_anoncode(pTHX_ OP *o)
5175 name = NEWSV(1106,0);
5176 sv_upgrade(name, SVt_PVNV);
5177 sv_setpvn(name, "&", 1);
5180 ix = pad_alloc(o->op_type, SVs_PADMY);
5181 av_store(PL_comppad_name, ix, name);
5182 av_store(PL_comppad, ix, cSVOPo->op_sv);
5183 SvPADMY_on(cSVOPo->op_sv);
5184 cSVOPo->op_sv = Nullsv;
5185 cSVOPo->op_targ = ix;
5190 Perl_ck_bitop(pTHX_ OP *o)
5192 o->op_private = PL_hints;
5197 Perl_ck_concat(pTHX_ OP *o)
5199 if (cUNOPo->op_first->op_type == OP_CONCAT)
5200 o->op_flags |= OPf_STACKED;
5205 Perl_ck_spair(pTHX_ OP *o)
5207 if (o->op_flags & OPf_KIDS) {
5210 OPCODE type = o->op_type;
5211 o = modkids(ck_fun(o), type);
5212 kid = cUNOPo->op_first;
5213 newop = kUNOP->op_first->op_sibling;
5215 (newop->op_sibling ||
5216 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5217 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5218 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5222 op_free(kUNOP->op_first);
5223 kUNOP->op_first = newop;
5225 o->op_ppaddr = PL_ppaddr[++o->op_type];
5230 Perl_ck_delete(pTHX_ OP *o)
5234 if (o->op_flags & OPf_KIDS) {
5235 OP *kid = cUNOPo->op_first;
5236 switch (kid->op_type) {
5238 o->op_flags |= OPf_SPECIAL;
5241 o->op_private |= OPpSLICE;
5244 o->op_flags |= OPf_SPECIAL;
5249 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5250 PL_op_desc[o->op_type]);
5258 Perl_ck_eof(pTHX_ OP *o)
5260 I32 type = o->op_type;
5262 if (o->op_flags & OPf_KIDS) {
5263 if (cLISTOPo->op_first->op_type == OP_STUB) {
5265 o = newUNOP(type, OPf_SPECIAL,
5266 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5274 Perl_ck_eval(pTHX_ OP *o)
5276 PL_hints |= HINT_BLOCK_SCOPE;
5277 if (o->op_flags & OPf_KIDS) {
5278 SVOP *kid = (SVOP*)cUNOPo->op_first;
5281 o->op_flags &= ~OPf_KIDS;
5284 else if (kid->op_type == OP_LINESEQ) {
5287 kid->op_next = o->op_next;
5288 cUNOPo->op_first = 0;
5291 NewOp(1101, enter, 1, LOGOP);
5292 enter->op_type = OP_ENTERTRY;
5293 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5294 enter->op_private = 0;
5296 /* establish postfix order */
5297 enter->op_next = (OP*)enter;
5299 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5300 o->op_type = OP_LEAVETRY;
5301 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5302 enter->op_other = o;
5310 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5312 o->op_targ = (PADOFFSET)PL_hints;
5317 Perl_ck_exit(pTHX_ OP *o)
5320 HV *table = GvHV(PL_hintgv);
5322 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5323 if (svp && *svp && SvTRUE(*svp))
5324 o->op_private |= OPpEXIT_VMSISH;
5331 Perl_ck_exec(pTHX_ OP *o)
5334 if (o->op_flags & OPf_STACKED) {
5336 kid = cUNOPo->op_first->op_sibling;
5337 if (kid->op_type == OP_RV2GV)
5346 Perl_ck_exists(pTHX_ OP *o)
5349 if (o->op_flags & OPf_KIDS) {
5350 OP *kid = cUNOPo->op_first;
5351 if (kid->op_type == OP_ENTERSUB) {
5352 (void) ref(kid, o->op_type);
5353 if (kid->op_type != OP_RV2CV && !PL_error_count)
5354 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5355 PL_op_desc[o->op_type]);
5356 o->op_private |= OPpEXISTS_SUB;
5358 else if (kid->op_type == OP_AELEM)
5359 o->op_flags |= OPf_SPECIAL;
5360 else if (kid->op_type != OP_HELEM)
5361 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5362 PL_op_desc[o->op_type]);
5370 Perl_ck_gvconst(pTHX_ register OP *o)
5372 o = fold_constants(o);
5373 if (o->op_type == OP_CONST)
5380 Perl_ck_rvconst(pTHX_ register OP *o)
5382 SVOP *kid = (SVOP*)cUNOPo->op_first;
5384 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5385 if (kid->op_type == OP_CONST) {
5389 SV *kidsv = kid->op_sv;
5392 /* Is it a constant from cv_const_sv()? */
5393 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5394 SV *rsv = SvRV(kidsv);
5395 int svtype = SvTYPE(rsv);
5396 char *badtype = Nullch;
5398 switch (o->op_type) {
5400 if (svtype > SVt_PVMG)
5401 badtype = "a SCALAR";
5404 if (svtype != SVt_PVAV)
5405 badtype = "an ARRAY";
5408 if (svtype != SVt_PVHV) {
5409 if (svtype == SVt_PVAV) { /* pseudohash? */
5410 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5411 if (ksv && SvROK(*ksv)
5412 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5421 if (svtype != SVt_PVCV)
5426 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5429 name = SvPV(kidsv, n_a);
5430 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5431 char *badthing = Nullch;
5432 switch (o->op_type) {
5434 badthing = "a SCALAR";
5437 badthing = "an ARRAY";
5440 badthing = "a HASH";
5445 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5449 * This is a little tricky. We only want to add the symbol if we
5450 * didn't add it in the lexer. Otherwise we get duplicate strict
5451 * warnings. But if we didn't add it in the lexer, we must at
5452 * least pretend like we wanted to add it even if it existed before,
5453 * or we get possible typo warnings. OPpCONST_ENTERED says
5454 * whether the lexer already added THIS instance of this symbol.
5456 iscv = (o->op_type == OP_RV2CV) * 2;
5458 gv = gv_fetchpv(name,
5459 iscv | !(kid->op_private & OPpCONST_ENTERED),
5462 : o->op_type == OP_RV2SV
5464 : o->op_type == OP_RV2AV
5466 : o->op_type == OP_RV2HV
5469 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5471 kid->op_type = OP_GV;
5472 SvREFCNT_dec(kid->op_sv);
5474 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5475 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5476 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5478 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5480 kid->op_sv = SvREFCNT_inc(gv);
5482 kid->op_private = 0;
5483 kid->op_ppaddr = PL_ppaddr[OP_GV];
5490 Perl_ck_ftst(pTHX_ OP *o)
5492 I32 type = o->op_type;
5494 if (o->op_flags & OPf_REF) {
5497 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5498 SVOP *kid = (SVOP*)cUNOPo->op_first;
5500 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5502 OP *newop = newGVOP(type, OPf_REF,
5503 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5510 if (type == OP_FTTTY)
5511 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5514 o = newUNOP(type, 0, newDEFSVOP());
5517 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5519 if (PL_hints & HINT_LOCALE)
5520 o->op_private |= OPpLOCALE;
5527 Perl_ck_fun(pTHX_ OP *o)
5533 int type = o->op_type;
5534 register I32 oa = PL_opargs[type] >> OASHIFT;
5536 if (o->op_flags & OPf_STACKED) {
5537 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5540 return no_fh_allowed(o);
5543 if (o->op_flags & OPf_KIDS) {
5545 tokid = &cLISTOPo->op_first;
5546 kid = cLISTOPo->op_first;
5547 if (kid->op_type == OP_PUSHMARK ||
5548 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5550 tokid = &kid->op_sibling;
5551 kid = kid->op_sibling;
5553 if (!kid && PL_opargs[type] & OA_DEFGV)
5554 *tokid = kid = newDEFSVOP();
5558 sibl = kid->op_sibling;
5561 /* list seen where single (scalar) arg expected? */
5562 if (numargs == 1 && !(oa >> 4)
5563 && kid->op_type == OP_LIST && type != OP_SCALAR)
5565 return too_many_arguments(o,PL_op_desc[type]);
5578 if (kid->op_type == OP_CONST &&
5579 (kid->op_private & OPpCONST_BARE))
5581 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5582 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5583 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5584 if (ckWARN(WARN_DEPRECATED))
5585 Perl_warner(aTHX_ WARN_DEPRECATED,
5586 "Array @%s missing the @ in argument %"IVdf" of %s()",
5587 name, (IV)numargs, PL_op_desc[type]);
5590 kid->op_sibling = sibl;
5593 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5594 bad_type(numargs, "array", PL_op_desc[type], kid);
5598 if (kid->op_type == OP_CONST &&
5599 (kid->op_private & OPpCONST_BARE))
5601 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5602 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5603 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5604 if (ckWARN(WARN_DEPRECATED))
5605 Perl_warner(aTHX_ WARN_DEPRECATED,
5606 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5607 name, (IV)numargs, PL_op_desc[type]);
5610 kid->op_sibling = sibl;
5613 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5614 bad_type(numargs, "hash", PL_op_desc[type], kid);
5619 OP *newop = newUNOP(OP_NULL, 0, kid);
5620 kid->op_sibling = 0;
5622 newop->op_next = newop;
5624 kid->op_sibling = sibl;
5629 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5630 if (kid->op_type == OP_CONST &&
5631 (kid->op_private & OPpCONST_BARE))
5633 OP *newop = newGVOP(OP_GV, 0,
5634 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5639 else if (kid->op_type == OP_READLINE) {
5640 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5641 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5644 I32 flags = OPf_SPECIAL;
5648 /* is this op a FH constructor? */
5649 if (is_handle_constructor(o,numargs)) {
5650 char *name = Nullch;
5654 /* Set a flag to tell rv2gv to vivify
5655 * need to "prove" flag does not mean something
5656 * else already - NI-S 1999/05/07
5659 if (kid->op_type == OP_PADSV) {
5660 SV **namep = av_fetch(PL_comppad_name,
5662 if (namep && *namep)
5663 name = SvPV(*namep, len);
5665 else if (kid->op_type == OP_RV2SV
5666 && kUNOP->op_first->op_type == OP_GV)
5668 GV *gv = cGVOPx_gv(kUNOP->op_first);
5670 len = GvNAMELEN(gv);
5672 else if (kid->op_type == OP_AELEM
5673 || kid->op_type == OP_HELEM)
5675 name = "__ANONIO__";
5681 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5682 namesv = PL_curpad[targ];
5683 (void)SvUPGRADE(namesv, SVt_PV);
5685 sv_setpvn(namesv, "$", 1);
5686 sv_catpvn(namesv, name, len);
5689 kid->op_sibling = 0;
5690 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5691 kid->op_targ = targ;
5692 kid->op_private |= priv;
5694 kid->op_sibling = sibl;
5700 mod(scalar(kid), type);
5704 tokid = &kid->op_sibling;
5705 kid = kid->op_sibling;
5707 o->op_private |= numargs;
5709 return too_many_arguments(o,PL_op_desc[o->op_type]);
5712 else if (PL_opargs[type] & OA_DEFGV) {
5714 return newUNOP(type, 0, newDEFSVOP());
5718 while (oa & OA_OPTIONAL)
5720 if (oa && oa != OA_LIST)
5721 return too_few_arguments(o,PL_op_desc[o->op_type]);
5727 Perl_ck_glob(pTHX_ OP *o)
5732 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5733 append_elem(OP_GLOB, o, newDEFSVOP());
5735 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5736 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5738 #if !defined(PERL_EXTERNAL_GLOB)
5739 /* XXX this can be tightened up and made more failsafe. */
5742 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5743 /* null-terminated import list */
5744 newSVpvn(":globally", 9), Nullsv);
5745 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5748 #endif /* PERL_EXTERNAL_GLOB */
5750 if (gv && GvIMPORTED_CV(gv)) {
5751 append_elem(OP_GLOB, o,
5752 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5753 o->op_type = OP_LIST;
5754 o->op_ppaddr = PL_ppaddr[OP_LIST];
5755 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5756 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5757 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5758 append_elem(OP_LIST, o,
5759 scalar(newUNOP(OP_RV2CV, 0,
5760 newGVOP(OP_GV, 0, gv)))));
5761 o = newUNOP(OP_NULL, 0, ck_subr(o));
5762 o->op_targ = OP_GLOB; /* hint at what it used to be */
5765 gv = newGVgen("main");
5767 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5773 Perl_ck_grep(pTHX_ OP *o)
5777 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5779 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5780 NewOp(1101, gwop, 1, LOGOP);
5782 if (o->op_flags & OPf_STACKED) {
5785 kid = cLISTOPo->op_first->op_sibling;
5786 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5789 kid->op_next = (OP*)gwop;
5790 o->op_flags &= ~OPf_STACKED;
5792 kid = cLISTOPo->op_first->op_sibling;
5793 if (type == OP_MAPWHILE)
5800 kid = cLISTOPo->op_first->op_sibling;
5801 if (kid->op_type != OP_NULL)
5802 Perl_croak(aTHX_ "panic: ck_grep");
5803 kid = kUNOP->op_first;
5805 gwop->op_type = type;
5806 gwop->op_ppaddr = PL_ppaddr[type];
5807 gwop->op_first = listkids(o);
5808 gwop->op_flags |= OPf_KIDS;
5809 gwop->op_private = 1;
5810 gwop->op_other = LINKLIST(kid);
5811 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5812 kid->op_next = (OP*)gwop;
5814 kid = cLISTOPo->op_first->op_sibling;
5815 if (!kid || !kid->op_sibling)
5816 return too_few_arguments(o,PL_op_desc[o->op_type]);
5817 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5818 mod(kid, OP_GREPSTART);
5824 Perl_ck_index(pTHX_ OP *o)
5826 if (o->op_flags & OPf_KIDS) {
5827 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5829 kid = kid->op_sibling; /* get past "big" */
5830 if (kid && kid->op_type == OP_CONST)
5831 fbm_compile(((SVOP*)kid)->op_sv, 0);
5837 Perl_ck_lengthconst(pTHX_ OP *o)
5839 /* XXX length optimization goes here */
5844 Perl_ck_lfun(pTHX_ OP *o)
5846 OPCODE type = o->op_type;
5847 return modkids(ck_fun(o), type);
5851 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5853 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5854 switch (cUNOPo->op_first->op_type) {
5856 /* This is needed for
5857 if (defined %stash::)
5858 to work. Do not break Tk.
5860 break; /* Globals via GV can be undef */
5862 case OP_AASSIGN: /* Is this a good idea? */
5863 Perl_warner(aTHX_ WARN_DEPRECATED,
5864 "defined(@array) is deprecated");
5865 Perl_warner(aTHX_ WARN_DEPRECATED,
5866 "\t(Maybe you should just omit the defined()?)\n");
5869 /* This is needed for
5870 if (defined %stash::)
5871 to work. Do not break Tk.
5873 break; /* Globals via GV can be undef */
5875 Perl_warner(aTHX_ WARN_DEPRECATED,
5876 "defined(%%hash) is deprecated");
5877 Perl_warner(aTHX_ WARN_DEPRECATED,
5878 "\t(Maybe you should just omit the defined()?)\n");
5889 Perl_ck_rfun(pTHX_ OP *o)
5891 OPCODE type = o->op_type;
5892 return refkids(ck_fun(o), type);
5896 Perl_ck_listiob(pTHX_ OP *o)
5900 kid = cLISTOPo->op_first;
5903 kid = cLISTOPo->op_first;
5905 if (kid->op_type == OP_PUSHMARK)
5906 kid = kid->op_sibling;
5907 if (kid && o->op_flags & OPf_STACKED)
5908 kid = kid->op_sibling;
5909 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5910 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5911 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5912 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5913 cLISTOPo->op_first->op_sibling = kid;
5914 cLISTOPo->op_last = kid;
5915 kid = kid->op_sibling;
5920 append_elem(o->op_type, o, newDEFSVOP());
5926 if (PL_hints & HINT_LOCALE)
5927 o->op_private |= OPpLOCALE;
5934 Perl_ck_fun_locale(pTHX_ OP *o)
5940 if (PL_hints & HINT_LOCALE)
5941 o->op_private |= OPpLOCALE;
5948 Perl_ck_sassign(pTHX_ OP *o)
5950 OP *kid = cLISTOPo->op_first;
5951 /* has a disposable target? */
5952 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5953 && !(kid->op_flags & OPf_STACKED)
5954 /* Cannot steal the second time! */
5955 && !(kid->op_private & OPpTARGET_MY))
5957 OP *kkid = kid->op_sibling;
5959 /* Can just relocate the target. */
5960 if (kkid && kkid->op_type == OP_PADSV
5961 && !(kkid->op_private & OPpLVAL_INTRO))
5963 kid->op_targ = kkid->op_targ;
5965 /* Now we do not need PADSV and SASSIGN. */
5966 kid->op_sibling = o->op_sibling; /* NULL */
5967 cLISTOPo->op_first = NULL;
5970 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5978 Perl_ck_scmp(pTHX_ OP *o)
5982 if (PL_hints & HINT_LOCALE)
5983 o->op_private |= OPpLOCALE;
5990 Perl_ck_match(pTHX_ OP *o)
5992 o->op_private |= OPpRUNTIME;
5997 Perl_ck_method(pTHX_ OP *o)
5999 OP *kid = cUNOPo->op_first;
6000 if (kid->op_type == OP_CONST) {
6001 SV* sv = kSVOP->op_sv;
6002 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6004 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6005 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6008 kSVOP->op_sv = Nullsv;
6010 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6019 Perl_ck_null(pTHX_ OP *o)
6025 Perl_ck_open(pTHX_ OP *o)
6027 HV *table = GvHV(PL_hintgv);
6031 svp = hv_fetch(table, "open_IN", 7, FALSE);
6033 mode = mode_from_discipline(*svp);
6034 if (mode & O_BINARY)
6035 o->op_private |= OPpOPEN_IN_RAW;
6036 else if (mode & O_TEXT)
6037 o->op_private |= OPpOPEN_IN_CRLF;
6040 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6042 mode = mode_from_discipline(*svp);
6043 if (mode & O_BINARY)
6044 o->op_private |= OPpOPEN_OUT_RAW;
6045 else if (mode & O_TEXT)
6046 o->op_private |= OPpOPEN_OUT_CRLF;
6049 if (o->op_type == OP_BACKTICK)
6055 Perl_ck_repeat(pTHX_ OP *o)
6057 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6058 o->op_private |= OPpREPEAT_DOLIST;
6059 cBINOPo->op_first = force_list(cBINOPo->op_first);
6067 Perl_ck_require(pTHX_ OP *o)
6069 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6070 SVOP *kid = (SVOP*)cUNOPo->op_first;
6072 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6074 for (s = SvPVX(kid->op_sv); *s; s++) {
6075 if (*s == ':' && s[1] == ':') {
6077 Move(s+2, s+1, strlen(s+2)+1, char);
6078 --SvCUR(kid->op_sv);
6081 if (SvREADONLY(kid->op_sv)) {
6082 SvREADONLY_off(kid->op_sv);
6083 sv_catpvn(kid->op_sv, ".pm", 3);
6084 SvREADONLY_on(kid->op_sv);
6087 sv_catpvn(kid->op_sv, ".pm", 3);
6095 Perl_ck_retarget(pTHX_ OP *o)
6097 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6104 Perl_ck_select(pTHX_ OP *o)
6107 if (o->op_flags & OPf_KIDS) {
6108 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6109 if (kid && kid->op_sibling) {
6110 o->op_type = OP_SSELECT;
6111 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6113 return fold_constants(o);
6117 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6118 if (kid && kid->op_type == OP_RV2GV)
6119 kid->op_private &= ~HINT_STRICT_REFS;
6124 Perl_ck_shift(pTHX_ OP *o)
6126 I32 type = o->op_type;
6128 if (!(o->op_flags & OPf_KIDS)) {
6133 if (!CvUNIQUE(PL_compcv)) {
6134 argop = newOP(OP_PADAV, OPf_REF);
6135 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6138 argop = newUNOP(OP_RV2AV, 0,
6139 scalar(newGVOP(OP_GV, 0,
6140 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6143 argop = newUNOP(OP_RV2AV, 0,
6144 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6145 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6146 #endif /* USE_THREADS */
6147 return newUNOP(type, 0, scalar(argop));
6149 return scalar(modkids(ck_fun(o), type));
6153 Perl_ck_sort(pTHX_ OP *o)
6158 if (PL_hints & HINT_LOCALE)
6159 o->op_private |= OPpLOCALE;
6162 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6164 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6165 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6167 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6169 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6171 if (kid->op_type == OP_SCOPE) {
6175 else if (kid->op_type == OP_LEAVE) {
6176 if (o->op_type == OP_SORT) {
6177 null(kid); /* wipe out leave */
6180 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6181 if (k->op_next == kid)
6183 /* don't descend into loops */
6184 else if (k->op_type == OP_ENTERLOOP
6185 || k->op_type == OP_ENTERITER)
6187 k = cLOOPx(k)->op_lastop;
6192 kid->op_next = 0; /* just disconnect the leave */
6193 k = kLISTOP->op_first;
6198 if (o->op_type == OP_SORT) {
6199 /* provide scalar context for comparison function/block */
6205 o->op_flags |= OPf_SPECIAL;
6207 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6210 firstkid = firstkid->op_sibling;
6213 /* provide list context for arguments */
6214 if (o->op_type == OP_SORT)
6221 S_simplify_sort(pTHX_ OP *o)
6223 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6227 if (!(o->op_flags & OPf_STACKED))
6229 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6230 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6231 kid = kUNOP->op_first; /* get past null */
6232 if (kid->op_type != OP_SCOPE)
6234 kid = kLISTOP->op_last; /* get past scope */
6235 switch(kid->op_type) {
6243 k = kid; /* remember this node*/
6244 if (kBINOP->op_first->op_type != OP_RV2SV)
6246 kid = kBINOP->op_first; /* get past cmp */
6247 if (kUNOP->op_first->op_type != OP_GV)
6249 kid = kUNOP->op_first; /* get past rv2sv */
6251 if (GvSTASH(gv) != PL_curstash)
6253 if (strEQ(GvNAME(gv), "a"))
6255 else if (strEQ(GvNAME(gv), "b"))
6259 kid = k; /* back to cmp */
6260 if (kBINOP->op_last->op_type != OP_RV2SV)
6262 kid = kBINOP->op_last; /* down to 2nd arg */
6263 if (kUNOP->op_first->op_type != OP_GV)
6265 kid = kUNOP->op_first; /* get past rv2sv */
6267 if (GvSTASH(gv) != PL_curstash
6269 ? strNE(GvNAME(gv), "a")
6270 : strNE(GvNAME(gv), "b")))
6272 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6274 o->op_private |= OPpSORT_REVERSE;
6275 if (k->op_type == OP_NCMP)
6276 o->op_private |= OPpSORT_NUMERIC;
6277 if (k->op_type == OP_I_NCMP)
6278 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6279 kid = cLISTOPo->op_first->op_sibling;
6280 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6281 op_free(kid); /* then delete it */
6282 cLISTOPo->op_children--;
6286 Perl_ck_split(pTHX_ OP *o)
6290 if (o->op_flags & OPf_STACKED)
6291 return no_fh_allowed(o);
6293 kid = cLISTOPo->op_first;
6294 if (kid->op_type != OP_NULL)
6295 Perl_croak(aTHX_ "panic: ck_split");
6296 kid = kid->op_sibling;
6297 op_free(cLISTOPo->op_first);
6298 cLISTOPo->op_first = kid;
6300 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6301 cLISTOPo->op_last = kid; /* There was only one element previously */
6304 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6305 OP *sibl = kid->op_sibling;
6306 kid->op_sibling = 0;
6307 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6308 if (cLISTOPo->op_first == cLISTOPo->op_last)
6309 cLISTOPo->op_last = kid;
6310 cLISTOPo->op_first = kid;
6311 kid->op_sibling = sibl;
6314 kid->op_type = OP_PUSHRE;
6315 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6318 if (!kid->op_sibling)
6319 append_elem(OP_SPLIT, o, newDEFSVOP());
6321 kid = kid->op_sibling;
6324 if (!kid->op_sibling)
6325 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6327 kid = kid->op_sibling;
6330 if (kid->op_sibling)
6331 return too_many_arguments(o,PL_op_desc[o->op_type]);
6337 Perl_ck_join(pTHX_ OP *o)
6339 if (ckWARN(WARN_SYNTAX)) {
6340 OP *kid = cLISTOPo->op_first->op_sibling;
6341 if (kid && kid->op_type == OP_MATCH) {
6342 char *pmstr = "STRING";
6343 if (kPMOP->op_pmregexp)
6344 pmstr = kPMOP->op_pmregexp->precomp;
6345 Perl_warner(aTHX_ WARN_SYNTAX,
6346 "/%s/ should probably be written as \"%s\"",
6354 Perl_ck_subr(pTHX_ OP *o)
6356 OP *prev = ((cUNOPo->op_first->op_sibling)
6357 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6358 OP *o2 = prev->op_sibling;
6367 o->op_private |= OPpENTERSUB_HASTARG;
6368 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6369 if (cvop->op_type == OP_RV2CV) {
6371 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6372 null(cvop); /* disable rv2cv */
6373 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6374 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6375 GV *gv = cGVOPx_gv(tmpop);
6378 tmpop->op_private |= OPpEARLY_CV;
6379 else if (SvPOK(cv)) {
6380 namegv = CvANON(cv) ? gv : CvGV(cv);
6381 proto = SvPV((SV*)cv, n_a);
6385 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6386 if (o2->op_type == OP_CONST)
6387 o2->op_private &= ~OPpCONST_STRICT;
6388 else if (o2->op_type == OP_LIST) {
6389 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6390 if (o && o->op_type == OP_CONST)
6391 o->op_private &= ~OPpCONST_STRICT;
6394 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6395 if (PERLDB_SUB && PL_curstash != PL_debstash)
6396 o->op_private |= OPpENTERSUB_DB;
6397 while (o2 != cvop) {
6401 return too_many_arguments(o, gv_ename(namegv));
6419 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6421 arg == 1 ? "block or sub {}" : "sub {}",
6422 gv_ename(namegv), o2);
6425 /* '*' allows any scalar type, including bareword */
6428 if (o2->op_type == OP_RV2GV)
6429 goto wrapref; /* autoconvert GLOB -> GLOBref */
6430 else if (o2->op_type == OP_CONST)
6431 o2->op_private &= ~OPpCONST_STRICT;
6432 else if (o2->op_type == OP_ENTERSUB) {
6433 /* accidental subroutine, revert to bareword */
6434 OP *gvop = ((UNOP*)o2)->op_first;
6435 if (gvop && gvop->op_type == OP_NULL) {
6436 gvop = ((UNOP*)gvop)->op_first;
6438 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6441 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6442 (gvop = ((UNOP*)gvop)->op_first) &&
6443 gvop->op_type == OP_GV)
6445 GV *gv = cGVOPx_gv(gvop);
6446 OP *sibling = o2->op_sibling;
6447 SV *n = newSVpvn("",0);
6449 gv_fullname3(n, gv, "");
6450 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6451 sv_chop(n, SvPVX(n)+6);
6452 o2 = newSVOP(OP_CONST, 0, n);
6453 prev->op_sibling = o2;
6454 o2->op_sibling = sibling;
6466 if (o2->op_type != OP_RV2GV)
6467 bad_type(arg, "symbol", gv_ename(namegv), o2);
6470 if (o2->op_type != OP_ENTERSUB)
6471 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6474 if (o2->op_type != OP_RV2SV
6475 && o2->op_type != OP_PADSV
6476 && o2->op_type != OP_HELEM
6477 && o2->op_type != OP_AELEM
6478 && o2->op_type != OP_THREADSV)
6480 bad_type(arg, "scalar", gv_ename(namegv), o2);
6484 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6485 bad_type(arg, "array", gv_ename(namegv), o2);
6488 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6489 bad_type(arg, "hash", gv_ename(namegv), o2);
6493 OP* sib = kid->op_sibling;
6494 kid->op_sibling = 0;
6495 o2 = newUNOP(OP_REFGEN, 0, kid);
6496 o2->op_sibling = sib;
6497 prev->op_sibling = o2;
6508 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6509 gv_ename(namegv), SvPV((SV*)cv, n_a));
6514 mod(o2, OP_ENTERSUB);
6516 o2 = o2->op_sibling;
6518 if (proto && !optional &&
6519 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6520 return too_few_arguments(o, gv_ename(namegv));
6525 Perl_ck_svconst(pTHX_ OP *o)
6527 SvREADONLY_on(cSVOPo->op_sv);
6532 Perl_ck_trunc(pTHX_ OP *o)
6534 if (o->op_flags & OPf_KIDS) {
6535 SVOP *kid = (SVOP*)cUNOPo->op_first;
6537 if (kid->op_type == OP_NULL)
6538 kid = (SVOP*)kid->op_sibling;
6539 if (kid && kid->op_type == OP_CONST &&
6540 (kid->op_private & OPpCONST_BARE))
6542 o->op_flags |= OPf_SPECIAL;
6543 kid->op_private &= ~OPpCONST_STRICT;
6550 Perl_ck_substr(pTHX_ OP *o)
6553 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6554 OP *kid = cLISTOPo->op_first;
6556 if (kid->op_type == OP_NULL)
6557 kid = kid->op_sibling;
6559 kid->op_flags |= OPf_MOD;
6565 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6568 Perl_peep(pTHX_ register OP *o)
6570 register OP* oldop = 0;
6572 OP *last_composite = Nullop;
6574 if (!o || o->op_seq)
6578 SAVEVPTR(PL_curcop);
6579 for (; o; o = o->op_next) {
6585 switch (o->op_type) {
6589 PL_curcop = ((COP*)o); /* for warnings */
6590 o->op_seq = PL_op_seqmax++;
6591 last_composite = Nullop;
6595 if (cSVOPo->op_private & OPpCONST_STRICT)
6596 no_bareword_allowed(o);
6598 /* Relocate sv to the pad for thread safety.
6599 * Despite being a "constant", the SV is written to,
6600 * for reference counts, sv_upgrade() etc. */
6602 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6603 if (SvPADTMP(cSVOPo->op_sv)) {
6604 /* If op_sv is already a PADTMP then it is being used by
6605 * some pad, so make a copy. */
6606 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6607 SvREADONLY_on(PL_curpad[ix]);
6608 SvREFCNT_dec(cSVOPo->op_sv);
6611 SvREFCNT_dec(PL_curpad[ix]);
6612 SvPADTMP_on(cSVOPo->op_sv);
6613 PL_curpad[ix] = cSVOPo->op_sv;
6614 /* XXX I don't know how this isn't readonly already. */
6615 SvREADONLY_on(PL_curpad[ix]);
6617 cSVOPo->op_sv = Nullsv;
6621 o->op_seq = PL_op_seqmax++;
6625 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6626 if (o->op_next->op_private & OPpTARGET_MY) {
6627 if (o->op_flags & OPf_STACKED) /* chained concats */
6628 goto ignore_optimization;
6630 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6631 o->op_targ = o->op_next->op_targ;
6632 o->op_next->op_targ = 0;
6633 o->op_private |= OPpTARGET_MY;
6638 ignore_optimization:
6639 o->op_seq = PL_op_seqmax++;
6642 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6643 o->op_seq = PL_op_seqmax++;
6644 break; /* Scalar stub must produce undef. List stub is noop */
6648 if (o->op_targ == OP_NEXTSTATE
6649 || o->op_targ == OP_DBSTATE
6650 || o->op_targ == OP_SETSTATE)
6652 PL_curcop = ((COP*)o);
6659 if (oldop && o->op_next) {
6660 oldop->op_next = o->op_next;
6663 o->op_seq = PL_op_seqmax++;
6667 if (o->op_next->op_type == OP_RV2SV) {
6668 if (!(o->op_next->op_private & OPpDEREF)) {
6670 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6672 o->op_next = o->op_next->op_next;
6673 o->op_type = OP_GVSV;
6674 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6677 else if (o->op_next->op_type == OP_RV2AV) {
6678 OP* pop = o->op_next->op_next;
6680 if (pop->op_type == OP_CONST &&
6681 (PL_op = pop->op_next) &&
6682 pop->op_next->op_type == OP_AELEM &&
6683 !(pop->op_next->op_private &
6684 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
6685 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6693 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6694 o->op_next = pop->op_next->op_next;
6695 o->op_type = OP_AELEMFAST;
6696 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6697 o->op_private = (U8)i;
6702 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6704 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6705 /* XXX could check prototype here instead of just carping */
6706 SV *sv = sv_newmortal();
6707 gv_efullname3(sv, gv, Nullch);
6708 Perl_warner(aTHX_ WARN_PROTOTYPE,
6709 "%s() called too early to check prototype",
6714 o->op_seq = PL_op_seqmax++;
6725 o->op_seq = PL_op_seqmax++;
6726 while (cLOGOP->op_other->op_type == OP_NULL)
6727 cLOGOP->op_other = cLOGOP->op_other->op_next;
6728 peep(cLOGOP->op_other);
6732 o->op_seq = PL_op_seqmax++;
6733 while (cLOOP->op_redoop->op_type == OP_NULL)
6734 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6735 peep(cLOOP->op_redoop);
6736 while (cLOOP->op_nextop->op_type == OP_NULL)
6737 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6738 peep(cLOOP->op_nextop);
6739 while (cLOOP->op_lastop->op_type == OP_NULL)
6740 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6741 peep(cLOOP->op_lastop);
6747 o->op_seq = PL_op_seqmax++;
6748 while (cPMOP->op_pmreplstart &&
6749 cPMOP->op_pmreplstart->op_type == OP_NULL)
6750 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6751 peep(cPMOP->op_pmreplstart);
6755 o->op_seq = PL_op_seqmax++;
6756 if (ckWARN(WARN_SYNTAX) && o->op_next
6757 && o->op_next->op_type == OP_NEXTSTATE) {
6758 if (o->op_next->op_sibling &&
6759 o->op_next->op_sibling->op_type != OP_EXIT &&
6760 o->op_next->op_sibling->op_type != OP_WARN &&
6761 o->op_next->op_sibling->op_type != OP_DIE) {
6762 line_t oldline = CopLINE(PL_curcop);
6764 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6765 Perl_warner(aTHX_ WARN_EXEC,
6766 "Statement unlikely to be reached");
6767 Perl_warner(aTHX_ WARN_EXEC,
6768 "\t(Maybe you meant system() when you said exec()?)\n");
6769 CopLINE_set(PL_curcop, oldline);
6778 SV **svp, **indsvp, *sv;
6783 o->op_seq = PL_op_seqmax++;
6785 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6788 /* Make the CONST have a shared SV */
6789 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6790 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6791 key = SvPV(sv, keylen);
6794 lexname = newSVpvn_share(key, keylen, 0);
6799 if ((o->op_private & (OPpLVAL_INTRO)))
6802 rop = (UNOP*)((BINOP*)o)->op_first;
6803 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6805 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6806 if (!SvOBJECT(lexname))
6808 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6809 if (!fields || !GvHV(*fields))
6811 key = SvPV(*svp, keylen);
6814 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6816 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6817 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6819 ind = SvIV(*indsvp);
6821 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6822 rop->op_type = OP_RV2AV;
6823 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6824 o->op_type = OP_AELEM;
6825 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6827 if (SvREADONLY(*svp))
6829 SvFLAGS(sv) |= (SvFLAGS(*svp)
6830 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6840 SV **svp, **indsvp, *sv;
6844 SVOP *first_key_op, *key_op;
6846 o->op_seq = PL_op_seqmax++;
6847 if ((o->op_private & (OPpLVAL_INTRO))
6848 /* I bet there's always a pushmark... */
6849 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6850 /* hmmm, no optimization if list contains only one key. */
6852 rop = (UNOP*)((LISTOP*)o)->op_last;
6853 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6855 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6856 if (!SvOBJECT(lexname))
6858 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6859 if (!fields || !GvHV(*fields))
6861 /* Again guessing that the pushmark can be jumped over.... */
6862 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6863 ->op_first->op_sibling;
6864 /* Check that the key list contains only constants. */
6865 for (key_op = first_key_op; key_op;
6866 key_op = (SVOP*)key_op->op_sibling)
6867 if (key_op->op_type != OP_CONST)
6871 rop->op_type = OP_RV2AV;
6872 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6873 o->op_type = OP_ASLICE;
6874 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6875 for (key_op = first_key_op; key_op;
6876 key_op = (SVOP*)key_op->op_sibling) {
6877 svp = cSVOPx_svp(key_op);
6878 key = SvPV(*svp, keylen);
6881 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6883 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6884 "in variable %s of type %s",
6885 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6887 ind = SvIV(*indsvp);
6889 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6891 if (SvREADONLY(*svp))
6893 SvFLAGS(sv) |= (SvFLAGS(*svp)
6894 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6903 if (!(o->op_flags & OPf_WANT)
6904 || (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
6908 o->op_seq = PL_op_seqmax++;
6912 if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) {
6913 o->op_seq = PL_op_seqmax++;
6919 if (last_composite) {
6920 OP *r = last_composite;
6922 while (r->op_sibling)
6925 || (r->op_next->op_type == OP_LIST
6926 && r->op_next->op_next == o))
6928 if (last_composite->op_type == OP_RV2AV)
6929 yyerror("Lvalue subs returning arrays not implemented yet");
6931 yyerror("Lvalue subs returning hashes not implemented yet");
6938 o->op_seq = PL_op_seqmax++;
6948 /* Efficient sub that returns a constant scalar value. */
6950 const_sv_xsub(pTHXo_ CV* cv)
6954 ST(0) = (SV*)XSANY.any_ptr;