3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 /* #define PL_OP_SLAB_ALLOC */
25 #ifdef PL_OP_SLAB_ALLOC
26 #define SLAB_SIZE 8192
27 static char *PL_OpPtr = NULL;
28 static int PL_OpSpace = 0;
29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
30 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
32 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
36 S_Slab_Alloc(pTHX_ int m, size_t sz)
38 Newz(m,PL_OpPtr,SLAB_SIZE,char);
39 PL_OpSpace = SLAB_SIZE - sz;
40 return PL_OpPtr += PL_OpSpace;
44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
47 * In the following definition, the ", Nullop" is just to make the compiler
48 * think the expression is of the right type: croak actually does a Siglongjmp.
50 #define CHECKOP(type,o) \
51 ((PL_op_mask && PL_op_mask[type]) \
52 ? ( op_free((OP*)o), \
53 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
55 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
57 #define PAD_MAX 999999999
58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
61 S_gv_ename(pTHX_ GV *gv)
64 SV* tmpsv = sv_newmortal();
65 gv_efullname3(tmpsv, gv, Nullch);
66 return SvPV(tmpsv,n_a);
70 S_no_fh_allowed(pTHX_ OP *o)
72 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
73 PL_op_desc[o->op_type]));
78 S_too_few_arguments(pTHX_ OP *o, char *name)
80 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
85 S_too_many_arguments(pTHX_ OP *o, char *name)
87 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
94 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
95 (int)n, name, t, PL_op_desc[kid->op_type]));
99 S_no_bareword_allowed(pTHX_ OP *o)
101 qerror(Perl_mess(aTHX_
102 "Bareword \"%s\" not allowed while \"strict subs\" in use",
103 SvPV_nolen(cSVOPo_sv)));
107 S_trlist_upgrade(pTHX_ U8** sp, U8** ep)
113 Newz(801, d, (e - s) * 2, U8);
117 if (*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 PL_modcount = RETURN_UNLIMITED_NUMBER;
1420 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1421 /* Backward compatibility mode: */
1422 o->op_private |= OPpENTERSUB_INARGS;
1425 else { /* Compile-time error message: */
1426 OP *kid = cUNOPo->op_first;
1430 if (kid->op_type == OP_PUSHMARK)
1432 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1434 "panic: unexpected lvalue entersub "
1435 "args: type/targ %ld:%ld",
1436 (long)kid->op_type,kid->op_targ);
1437 kid = kLISTOP->op_first;
1439 while (kid->op_sibling)
1440 kid = kid->op_sibling;
1441 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1443 if (kid->op_type == OP_METHOD_NAMED
1444 || kid->op_type == OP_METHOD)
1448 if (kid->op_sibling || kid->op_next != kid) {
1449 yyerror("panic: unexpected optree near method call");
1453 NewOp(1101, newop, 1, UNOP);
1454 newop->op_type = OP_RV2CV;
1455 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456 newop->op_first = Nullop;
1457 newop->op_next = (OP*)newop;
1458 kid->op_sibling = (OP*)newop;
1459 newop->op_private |= OPpLVAL_INTRO;
1463 if (kid->op_type != OP_RV2CV)
1465 "panic: unexpected lvalue entersub "
1466 "entry via type/targ %ld:%ld",
1467 (long)kid->op_type,kid->op_targ);
1468 kid->op_private |= OPpLVAL_INTRO;
1469 break; /* Postpone until runtime */
1473 kid = kUNOP->op_first;
1474 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1475 kid = kUNOP->op_first;
1476 if (kid->op_type == OP_NULL)
1478 "Unexpected constant lvalue entersub "
1479 "entry via type/targ %ld:%ld",
1480 (long)kid->op_type,kid->op_targ);
1481 if (kid->op_type != OP_GV) {
1482 /* Restore RV2CV to check lvalueness */
1484 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1485 okid->op_next = kid->op_next;
1486 kid->op_next = okid;
1489 okid->op_next = Nullop;
1490 okid->op_type = OP_RV2CV;
1492 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1493 okid->op_private |= OPpLVAL_INTRO;
1497 cv = GvCV(kGVOP_gv);
1507 /* grep, foreach, subcalls, refgen */
1508 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1510 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1511 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1513 : (o->op_type == OP_ENTERSUB
1514 ? "non-lvalue subroutine call"
1515 : PL_op_desc[o->op_type])),
1516 type ? PL_op_desc[type] : "local"));
1530 case OP_RIGHT_SHIFT:
1539 if (!(o->op_flags & OPf_STACKED))
1545 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1551 if (!type && cUNOPo->op_first->op_type != OP_GV)
1552 Perl_croak(aTHX_ "Can't localize through a reference");
1553 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1554 PL_modcount = RETURN_UNLIMITED_NUMBER;
1555 return o; /* Treat \(@foo) like ordinary list. */
1559 if (scalar_mod_type(o, type))
1561 ref(cUNOPo->op_first, o->op_type);
1565 if (type == OP_LEAVESUBLV)
1566 o->op_private |= OPpMAYBE_LVSUB;
1573 PL_modcount = RETURN_UNLIMITED_NUMBER;
1576 if (!type && cUNOPo->op_first->op_type != OP_GV)
1577 Perl_croak(aTHX_ "Can't localize through a reference");
1578 ref(cUNOPo->op_first, o->op_type);
1582 PL_hints |= HINT_BLOCK_SCOPE;
1592 PL_modcount = RETURN_UNLIMITED_NUMBER;
1593 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1594 return o; /* Treat \(@foo) like ordinary list. */
1595 if (scalar_mod_type(o, type))
1597 if (type == OP_LEAVESUBLV)
1598 o->op_private |= OPpMAYBE_LVSUB;
1603 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1604 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1609 PL_modcount++; /* XXX ??? */
1611 #endif /* USE_THREADS */
1617 if (type != OP_SASSIGN)
1621 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1626 if (type == OP_LEAVESUBLV)
1627 o->op_private |= OPpMAYBE_LVSUB;
1629 pad_free(o->op_targ);
1630 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1631 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1632 if (o->op_flags & OPf_KIDS)
1633 mod(cBINOPo->op_first->op_sibling, type);
1638 ref(cBINOPo->op_first, o->op_type);
1639 if (type == OP_ENTERSUB &&
1640 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1641 o->op_private |= OPpLVAL_DEFER;
1642 if (type == OP_LEAVESUBLV)
1643 o->op_private |= OPpMAYBE_LVSUB;
1651 if (o->op_flags & OPf_KIDS)
1652 mod(cLISTOPo->op_last, type);
1656 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1658 else if (!(o->op_flags & OPf_KIDS))
1660 if (o->op_targ != OP_LIST) {
1661 mod(cBINOPo->op_first, type);
1666 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1671 if (type != OP_LEAVESUBLV)
1673 break; /* mod()ing was handled by ck_return() */
1675 if (type != OP_LEAVESUBLV)
1676 o->op_flags |= OPf_MOD;
1678 if (type == OP_AASSIGN || type == OP_SASSIGN)
1679 o->op_flags |= OPf_SPECIAL|OPf_REF;
1681 o->op_private |= OPpLVAL_INTRO;
1682 o->op_flags &= ~OPf_SPECIAL;
1683 PL_hints |= HINT_BLOCK_SCOPE;
1685 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1686 && type != OP_LEAVESUBLV)
1687 o->op_flags |= OPf_REF;
1692 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1696 if (o->op_type == OP_RV2GV)
1720 case OP_RIGHT_SHIFT:
1739 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1741 switch (o->op_type) {
1749 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1762 Perl_refkids(pTHX_ OP *o, I32 type)
1765 if (o && o->op_flags & OPf_KIDS) {
1766 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1773 Perl_ref(pTHX_ OP *o, I32 type)
1777 if (!o || PL_error_count)
1780 switch (o->op_type) {
1782 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1783 !(o->op_flags & OPf_STACKED)) {
1784 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1785 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1786 assert(cUNOPo->op_first->op_type == OP_NULL);
1787 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1788 o->op_flags |= OPf_SPECIAL;
1793 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1797 if (type == OP_DEFINED)
1798 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1799 ref(cUNOPo->op_first, o->op_type);
1802 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1803 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1804 : type == OP_RV2HV ? OPpDEREF_HV
1806 o->op_flags |= OPf_MOD;
1811 o->op_flags |= OPf_MOD; /* XXX ??? */
1816 o->op_flags |= OPf_REF;
1819 if (type == OP_DEFINED)
1820 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1821 ref(cUNOPo->op_first, o->op_type);
1826 o->op_flags |= OPf_REF;
1831 if (!(o->op_flags & OPf_KIDS))
1833 ref(cBINOPo->op_first, type);
1837 ref(cBINOPo->op_first, o->op_type);
1838 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1839 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1840 : type == OP_RV2HV ? OPpDEREF_HV
1842 o->op_flags |= OPf_MOD;
1850 if (!(o->op_flags & OPf_KIDS))
1852 ref(cLISTOPo->op_last, type);
1862 S_dup_attrlist(pTHX_ OP *o)
1866 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1867 * where the first kid is OP_PUSHMARK and the remaining ones
1868 * are OP_CONST. We need to push the OP_CONST values.
1870 if (o->op_type == OP_CONST)
1871 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1873 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1874 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1875 if (o->op_type == OP_CONST)
1876 rop = append_elem(OP_LIST, rop,
1877 newSVOP(OP_CONST, o->op_flags,
1878 SvREFCNT_inc(cSVOPo->op_sv)));
1885 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1889 /* fake up C<use attributes $pkg,$rv,@attrs> */
1890 ENTER; /* need to protect against side-effects of 'use' */
1892 if (stash && HvNAME(stash))
1893 stashsv = newSVpv(HvNAME(stash), 0);
1895 stashsv = &PL_sv_no;
1897 #define ATTRSMODULE "attributes"
1899 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1900 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1902 prepend_elem(OP_LIST,
1903 newSVOP(OP_CONST, 0, stashsv),
1904 prepend_elem(OP_LIST,
1905 newSVOP(OP_CONST, 0,
1907 dup_attrlist(attrs))));
1912 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1913 char *attrstr, STRLEN len)
1918 len = strlen(attrstr);
1922 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1924 char *sstr = attrstr;
1925 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1926 attrs = append_elem(OP_LIST, attrs,
1927 newSVOP(OP_CONST, 0,
1928 newSVpvn(sstr, attrstr-sstr)));
1932 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1933 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1934 Nullsv, prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1936 prepend_elem(OP_LIST,
1937 newSVOP(OP_CONST, 0,
1943 S_my_kid(pTHX_ OP *o, OP *attrs)
1948 if (!o || PL_error_count)
1952 if (type == OP_LIST) {
1953 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1955 } else if (type == OP_UNDEF) {
1957 } else if (type == OP_RV2SV || /* "our" declaration */
1959 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1960 o->op_private |= OPpOUR_INTRO;
1962 } else if (type != OP_PADSV &&
1965 type != OP_PUSHMARK)
1967 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1968 PL_op_desc[o->op_type],
1969 PL_in_my == KEY_our ? "our" : "my"));
1972 else if (attrs && type != OP_PUSHMARK) {
1978 PL_in_my_stash = Nullhv;
1980 /* check for C<my Dog $spot> when deciding package */
1981 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1982 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1983 stash = SvSTASH(*namesvp);
1985 stash = PL_curstash;
1986 padsv = PAD_SV(o->op_targ);
1987 apply_attrs(stash, padsv, attrs);
1989 o->op_flags |= OPf_MOD;
1990 o->op_private |= OPpLVAL_INTRO;
1995 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1997 if (o->op_flags & OPf_PARENS)
2001 o = my_kid(o, attrs);
2003 PL_in_my_stash = Nullhv;
2008 Perl_my(pTHX_ OP *o)
2010 return my_kid(o, Nullop);
2014 Perl_sawparens(pTHX_ OP *o)
2017 o->op_flags |= OPf_PARENS;
2022 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2026 if (ckWARN(WARN_MISC) &&
2027 (left->op_type == OP_RV2AV ||
2028 left->op_type == OP_RV2HV ||
2029 left->op_type == OP_PADAV ||
2030 left->op_type == OP_PADHV)) {
2031 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2032 right->op_type == OP_TRANS)
2033 ? right->op_type : OP_MATCH];
2034 const char *sample = ((left->op_type == OP_RV2AV ||
2035 left->op_type == OP_PADAV)
2036 ? "@array" : "%hash");
2037 Perl_warner(aTHX_ WARN_MISC,
2038 "Applying %s to %s will act on scalar(%s)",
2039 desc, sample, sample);
2042 if (!(right->op_flags & OPf_STACKED) &&
2043 (right->op_type == OP_MATCH ||
2044 right->op_type == OP_SUBST ||
2045 right->op_type == OP_TRANS)) {
2046 right->op_flags |= OPf_STACKED;
2047 if (right->op_type != OP_MATCH &&
2048 ! (right->op_type == OP_TRANS &&
2049 right->op_private & OPpTRANS_IDENTICAL))
2050 left = mod(left, right->op_type);
2051 if (right->op_type == OP_TRANS)
2052 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2054 o = prepend_elem(right->op_type, scalar(left), right);
2056 return newUNOP(OP_NOT, 0, scalar(o));
2060 return bind_match(type, left,
2061 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2065 Perl_invert(pTHX_ OP *o)
2069 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2070 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2074 Perl_scope(pTHX_ OP *o)
2077 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2078 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2079 o->op_type = OP_LEAVE;
2080 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2083 if (o->op_type == OP_LINESEQ) {
2085 o->op_type = OP_SCOPE;
2086 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2087 kid = ((LISTOP*)o)->op_first;
2088 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2092 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2099 Perl_save_hints(pTHX)
2102 SAVESPTR(GvHV(PL_hintgv));
2103 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2104 SAVEFREESV(GvHV(PL_hintgv));
2108 Perl_block_start(pTHX_ int full)
2110 int retval = PL_savestack_ix;
2112 SAVEI32(PL_comppad_name_floor);
2113 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2115 PL_comppad_name_fill = PL_comppad_name_floor;
2116 if (PL_comppad_name_floor < 0)
2117 PL_comppad_name_floor = 0;
2118 SAVEI32(PL_min_intro_pending);
2119 SAVEI32(PL_max_intro_pending);
2120 PL_min_intro_pending = 0;
2121 SAVEI32(PL_comppad_name_fill);
2122 SAVEI32(PL_padix_floor);
2123 PL_padix_floor = PL_padix;
2124 PL_pad_reset_pending = FALSE;
2126 PL_hints &= ~HINT_BLOCK_SCOPE;
2127 SAVESPTR(PL_compiling.cop_warnings);
2128 if (! specialWARN(PL_compiling.cop_warnings)) {
2129 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2130 SAVEFREESV(PL_compiling.cop_warnings) ;
2132 SAVESPTR(PL_compiling.cop_io);
2133 if (! specialCopIO(PL_compiling.cop_io)) {
2134 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2135 SAVEFREESV(PL_compiling.cop_io) ;
2141 Perl_block_end(pTHX_ I32 floor, OP *seq)
2143 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2144 OP* retval = scalarseq(seq);
2146 PL_pad_reset_pending = FALSE;
2147 PL_compiling.op_private = PL_hints;
2149 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2150 pad_leavemy(PL_comppad_name_fill);
2159 OP *o = newOP(OP_THREADSV, 0);
2160 o->op_targ = find_threadsv("_");
2163 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2164 #endif /* USE_THREADS */
2168 Perl_newPROG(pTHX_ OP *o)
2173 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2174 ((PL_in_eval & EVAL_KEEPERR)
2175 ? OPf_SPECIAL : 0), o);
2176 PL_eval_start = linklist(PL_eval_root);
2177 PL_eval_root->op_private |= OPpREFCOUNTED;
2178 OpREFCNT_set(PL_eval_root, 1);
2179 PL_eval_root->op_next = 0;
2180 peep(PL_eval_start);
2185 PL_main_root = scope(sawparens(scalarvoid(o)));
2186 PL_curcop = &PL_compiling;
2187 PL_main_start = LINKLIST(PL_main_root);
2188 PL_main_root->op_private |= OPpREFCOUNTED;
2189 OpREFCNT_set(PL_main_root, 1);
2190 PL_main_root->op_next = 0;
2191 peep(PL_main_start);
2194 /* Register with debugger */
2196 CV *cv = get_cv("DB::postponed", FALSE);
2200 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2202 call_sv((SV*)cv, G_DISCARD);
2209 Perl_localize(pTHX_ OP *o, I32 lex)
2211 if (o->op_flags & OPf_PARENS)
2214 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2216 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2217 if (*s == ';' || *s == '=')
2218 Perl_warner(aTHX_ WARN_PARENTHESIS,
2219 "Parentheses missing around \"%s\" list",
2220 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2226 o = mod(o, OP_NULL); /* a bit kludgey */
2228 PL_in_my_stash = Nullhv;
2233 Perl_jmaybe(pTHX_ OP *o)
2235 if (o->op_type == OP_LIST) {
2238 o2 = newOP(OP_THREADSV, 0);
2239 o2->op_targ = find_threadsv(";");
2241 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2242 #endif /* USE_THREADS */
2243 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2249 Perl_fold_constants(pTHX_ register OP *o)
2252 I32 type = o->op_type;
2255 if (PL_opargs[type] & OA_RETSCALAR)
2257 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2258 o->op_targ = pad_alloc(type, SVs_PADTMP);
2260 /* integerize op, unless it happens to be C<-foo>.
2261 * XXX should pp_i_negate() do magic string negation instead? */
2262 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2263 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2264 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2266 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2269 if (!(PL_opargs[type] & OA_FOLDCONST))
2274 /* XXX might want a ck_negate() for this */
2275 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2288 if (o->op_private & OPpLOCALE)
2293 goto nope; /* Don't try to run w/ errors */
2295 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2296 if ((curop->op_type != OP_CONST ||
2297 (curop->op_private & OPpCONST_BARE)) &&
2298 curop->op_type != OP_LIST &&
2299 curop->op_type != OP_SCALAR &&
2300 curop->op_type != OP_NULL &&
2301 curop->op_type != OP_PUSHMARK)
2307 curop = LINKLIST(o);
2311 sv = *(PL_stack_sp--);
2312 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2313 pad_swipe(o->op_targ);
2314 else if (SvTEMP(sv)) { /* grab mortal temp? */
2315 (void)SvREFCNT_inc(sv);
2319 if (type == OP_RV2GV)
2320 return newGVOP(OP_GV, 0, (GV*)sv);
2322 /* try to smush double to int, but don't smush -2.0 to -2 */
2323 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2326 #ifdef PERL_PRESERVE_IVUV
2327 /* Only bother to attempt to fold to IV if
2328 most operators will benefit */
2332 return newSVOP(OP_CONST, 0, sv);
2336 if (!(PL_opargs[type] & OA_OTHERINT))
2339 if (!(PL_hints & HINT_INTEGER)) {
2340 if (type == OP_MODULO
2341 || type == OP_DIVIDE
2342 || !(o->op_flags & OPf_KIDS))
2347 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2348 if (curop->op_type == OP_CONST) {
2349 if (SvIOK(((SVOP*)curop)->op_sv))
2353 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2357 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2364 Perl_gen_constant_list(pTHX_ register OP *o)
2367 I32 oldtmps_floor = PL_tmps_floor;
2371 return o; /* Don't attempt to run with errors */
2373 PL_op = curop = LINKLIST(o);
2380 PL_tmps_floor = oldtmps_floor;
2382 o->op_type = OP_RV2AV;
2383 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2384 curop = ((UNOP*)o)->op_first;
2385 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2392 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2397 if (!o || o->op_type != OP_LIST)
2398 o = newLISTOP(OP_LIST, 0, o, Nullop);
2400 o->op_flags &= ~OPf_WANT;
2402 if (!(PL_opargs[type] & OA_MARK))
2403 null(cLISTOPo->op_first);
2406 o->op_ppaddr = PL_ppaddr[type];
2407 o->op_flags |= flags;
2409 o = CHECKOP(type, o);
2410 if (o->op_type != type)
2413 return fold_constants(o);
2416 /* List constructors */
2419 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2427 if (first->op_type != type
2428 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2430 return newLISTOP(type, 0, first, last);
2433 if (first->op_flags & OPf_KIDS)
2434 ((LISTOP*)first)->op_last->op_sibling = last;
2436 first->op_flags |= OPf_KIDS;
2437 ((LISTOP*)first)->op_first = last;
2439 ((LISTOP*)first)->op_last = last;
2444 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2452 if (first->op_type != type)
2453 return prepend_elem(type, (OP*)first, (OP*)last);
2455 if (last->op_type != type)
2456 return append_elem(type, (OP*)first, (OP*)last);
2458 first->op_last->op_sibling = last->op_first;
2459 first->op_last = last->op_last;
2460 first->op_flags |= (last->op_flags & OPf_KIDS);
2462 #ifdef PL_OP_SLAB_ALLOC
2470 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2478 if (last->op_type == type) {
2479 if (type == OP_LIST) { /* already a PUSHMARK there */
2480 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2481 ((LISTOP*)last)->op_first->op_sibling = first;
2482 if (!(first->op_flags & OPf_PARENS))
2483 last->op_flags &= ~OPf_PARENS;
2486 if (!(last->op_flags & OPf_KIDS)) {
2487 ((LISTOP*)last)->op_last = first;
2488 last->op_flags |= OPf_KIDS;
2490 first->op_sibling = ((LISTOP*)last)->op_first;
2491 ((LISTOP*)last)->op_first = first;
2493 last->op_flags |= OPf_KIDS;
2497 return newLISTOP(type, 0, first, last);
2503 Perl_newNULLLIST(pTHX)
2505 return newOP(OP_STUB, 0);
2509 Perl_force_list(pTHX_ OP *o)
2511 if (!o || o->op_type != OP_LIST)
2512 o = newLISTOP(OP_LIST, 0, o, Nullop);
2518 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2522 NewOp(1101, listop, 1, LISTOP);
2524 listop->op_type = type;
2525 listop->op_ppaddr = PL_ppaddr[type];
2528 listop->op_flags = flags;
2532 else if (!first && last)
2535 first->op_sibling = last;
2536 listop->op_first = first;
2537 listop->op_last = last;
2538 if (type == OP_LIST) {
2540 pushop = newOP(OP_PUSHMARK, 0);
2541 pushop->op_sibling = first;
2542 listop->op_first = pushop;
2543 listop->op_flags |= OPf_KIDS;
2545 listop->op_last = pushop;
2552 Perl_newOP(pTHX_ I32 type, I32 flags)
2555 NewOp(1101, o, 1, OP);
2557 o->op_ppaddr = PL_ppaddr[type];
2558 o->op_flags = flags;
2561 o->op_private = 0 + (flags >> 8);
2562 if (PL_opargs[type] & OA_RETSCALAR)
2564 if (PL_opargs[type] & OA_TARGET)
2565 o->op_targ = pad_alloc(type, SVs_PADTMP);
2566 return CHECKOP(type, o);
2570 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2575 first = newOP(OP_STUB, 0);
2576 if (PL_opargs[type] & OA_MARK)
2577 first = force_list(first);
2579 NewOp(1101, unop, 1, UNOP);
2580 unop->op_type = type;
2581 unop->op_ppaddr = PL_ppaddr[type];
2582 unop->op_first = first;
2583 unop->op_flags = flags | OPf_KIDS;
2584 unop->op_private = 1 | (flags >> 8);
2585 unop = (UNOP*) CHECKOP(type, unop);
2589 return fold_constants((OP *) unop);
2593 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2596 NewOp(1101, binop, 1, BINOP);
2599 first = newOP(OP_NULL, 0);
2601 binop->op_type = type;
2602 binop->op_ppaddr = PL_ppaddr[type];
2603 binop->op_first = first;
2604 binop->op_flags = flags | OPf_KIDS;
2607 binop->op_private = 1 | (flags >> 8);
2610 binop->op_private = 2 | (flags >> 8);
2611 first->op_sibling = last;
2614 binop = (BINOP*)CHECKOP(type, binop);
2615 if (binop->op_next || binop->op_type != type)
2618 binop->op_last = binop->op_first->op_sibling;
2620 return fold_constants((OP *)binop);
2624 utf8compare(const void *a, const void *b)
2627 for (i = 0; i < 10; i++) {
2628 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2630 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2637 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2639 SV *tstr = ((SVOP*)expr)->op_sv;
2640 SV *rstr = ((SVOP*)repl)->op_sv;
2643 U8 *t = (U8*)SvPV(tstr, tlen);
2644 U8 *r = (U8*)SvPV(rstr, rlen);
2651 register short *tbl;
2653 complement = o->op_private & OPpTRANS_COMPLEMENT;
2654 del = o->op_private & OPpTRANS_DELETE;
2655 squash = o->op_private & OPpTRANS_SQUASH;
2658 o->op_private |= OPpTRANS_FROM_UTF;
2661 o->op_private |= OPpTRANS_TO_UTF;
2663 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2664 SV* listsv = newSVpvn("# comment\n",10);
2666 U8* tend = t + tlen;
2667 U8* rend = r + rlen;
2681 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2682 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2683 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2684 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2687 U8 tmpbuf[UTF8_MAXLEN+1];
2691 New(1109, cp, tlen, U8*);
2693 transv = newSVpvn("",0);
2702 qsort(cp, i, sizeof(U8*), utf8compare);
2703 for (j = 0; j < i; j++) {
2705 I32 cur = j < i ? cp[j+1] - s : tend - s;
2706 UV val = utf8_to_uv(s, cur, &ulen, 0);
2708 diff = val - nextmin;
2710 t = uv_to_utf8(tmpbuf,nextmin);
2711 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2713 t = uv_to_utf8(tmpbuf, val - 1);
2714 sv_catpvn(transv, "\377", 1);
2715 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2719 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2723 t = uv_to_utf8(tmpbuf,nextmin);
2724 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2725 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2726 sv_catpvn(transv, "\377", 1);
2727 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2728 t = (U8*)SvPVX(transv);
2729 tlen = SvCUR(transv);
2732 else if (!rlen && !del) {
2733 r = t; rlen = tlen; rend = tend;
2737 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2739 o->op_private |= OPpTRANS_IDENTICAL;
2743 while (t < tend || tfirst <= tlast) {
2744 /* see if we need more "t" chars */
2745 if (tfirst > tlast) {
2746 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2748 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2750 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2757 /* now see if we need more "r" chars */
2758 if (rfirst > rlast) {
2760 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2762 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2764 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2773 rfirst = rlast = 0xffffffff;
2777 /* now see which range will peter our first, if either. */
2778 tdiff = tlast - tfirst;
2779 rdiff = rlast - rfirst;
2786 if (rfirst == 0xffffffff) {
2787 diff = tdiff; /* oops, pretend rdiff is infinite */
2789 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2790 (long)tfirst, (long)tlast);
2792 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2796 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2797 (long)tfirst, (long)(tfirst + diff),
2800 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2801 (long)tfirst, (long)rfirst);
2803 if (rfirst + diff > max)
2804 max = rfirst + diff;
2807 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2818 else if (max > 0xff)
2823 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2824 SvREFCNT_dec(listsv);
2826 SvREFCNT_dec(transv);
2828 if (!del && havefinal)
2829 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2830 newSVuv((UV)final), 0);
2833 o->op_private |= OPpTRANS_GROWS;
2845 tbl = (short*)cPVOPo->op_pv;
2847 Zero(tbl, 256, short);
2848 for (i = 0; i < tlen; i++)
2850 for (i = 0, j = 0; i < 256; i++) {
2861 if (i < 128 && r[j] >= 128)
2869 if (!rlen && !del) {
2872 o->op_private |= OPpTRANS_IDENTICAL;
2874 for (i = 0; i < 256; i++)
2876 for (i = 0, j = 0; i < tlen; i++,j++) {
2879 if (tbl[t[i]] == -1)
2885 if (tbl[t[i]] == -1) {
2886 if (t[i] < 128 && r[j] >= 128)
2893 o->op_private |= OPpTRANS_GROWS;
2901 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2905 NewOp(1101, pmop, 1, PMOP);
2906 pmop->op_type = type;
2907 pmop->op_ppaddr = PL_ppaddr[type];
2908 pmop->op_flags = flags;
2909 pmop->op_private = 0 | (flags >> 8);
2911 if (PL_hints & HINT_RE_TAINT)
2912 pmop->op_pmpermflags |= PMf_RETAINT;
2913 if (PL_hints & HINT_LOCALE)
2914 pmop->op_pmpermflags |= PMf_LOCALE;
2915 pmop->op_pmflags = pmop->op_pmpermflags;
2917 /* link into pm list */
2918 if (type != OP_TRANS && PL_curstash) {
2919 pmop->op_pmnext = HvPMROOT(PL_curstash);
2920 HvPMROOT(PL_curstash) = pmop;
2927 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2931 I32 repl_has_vars = 0;
2933 if (o->op_type == OP_TRANS)
2934 return pmtrans(o, expr, repl);
2936 PL_hints |= HINT_BLOCK_SCOPE;
2939 if (expr->op_type == OP_CONST) {
2941 SV *pat = ((SVOP*)expr)->op_sv;
2942 char *p = SvPV(pat, plen);
2943 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2944 sv_setpvn(pat, "\\s+", 3);
2945 p = SvPV(pat, plen);
2946 pm->op_pmflags |= PMf_SKIPWHITE;
2948 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2949 pm->op_pmdynflags |= PMdf_UTF8;
2950 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2951 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2952 pm->op_pmflags |= PMf_WHITE;
2956 if (PL_hints & HINT_UTF8)
2957 pm->op_pmdynflags |= PMdf_UTF8;
2958 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2959 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2961 : OP_REGCMAYBE),0,expr);
2963 NewOp(1101, rcop, 1, LOGOP);
2964 rcop->op_type = OP_REGCOMP;
2965 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2966 rcop->op_first = scalar(expr);
2967 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2968 ? (OPf_SPECIAL | OPf_KIDS)
2970 rcop->op_private = 1;
2973 /* establish postfix order */
2974 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2976 rcop->op_next = expr;
2977 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2980 rcop->op_next = LINKLIST(expr);
2981 expr->op_next = (OP*)rcop;
2984 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2989 if (pm->op_pmflags & PMf_EVAL) {
2991 if (CopLINE(PL_curcop) < PL_multi_end)
2992 CopLINE_set(PL_curcop, PL_multi_end);
2995 else if (repl->op_type == OP_THREADSV
2996 && strchr("&`'123456789+",
2997 PL_threadsv_names[repl->op_targ]))
3001 #endif /* USE_THREADS */
3002 else if (repl->op_type == OP_CONST)
3006 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3007 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3009 if (curop->op_type == OP_THREADSV) {
3011 if (strchr("&`'123456789+", curop->op_private))
3015 if (curop->op_type == OP_GV) {
3016 GV *gv = cGVOPx_gv(curop);
3018 if (strchr("&`'123456789+", *GvENAME(gv)))
3021 #endif /* USE_THREADS */
3022 else if (curop->op_type == OP_RV2CV)
3024 else if (curop->op_type == OP_RV2SV ||
3025 curop->op_type == OP_RV2AV ||
3026 curop->op_type == OP_RV2HV ||
3027 curop->op_type == OP_RV2GV) {
3028 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3031 else if (curop->op_type == OP_PADSV ||
3032 curop->op_type == OP_PADAV ||
3033 curop->op_type == OP_PADHV ||
3034 curop->op_type == OP_PADANY) {
3037 else if (curop->op_type == OP_PUSHRE)
3038 ; /* Okay here, dangerous in newASSIGNOP */
3047 && (!pm->op_pmregexp
3048 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3049 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3050 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3051 prepend_elem(o->op_type, scalar(repl), o);
3054 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3055 pm->op_pmflags |= PMf_MAYBE_CONST;
3056 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3058 NewOp(1101, rcop, 1, LOGOP);
3059 rcop->op_type = OP_SUBSTCONT;
3060 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3061 rcop->op_first = scalar(repl);
3062 rcop->op_flags |= OPf_KIDS;
3063 rcop->op_private = 1;
3066 /* establish postfix order */
3067 rcop->op_next = LINKLIST(repl);
3068 repl->op_next = (OP*)rcop;
3070 pm->op_pmreplroot = scalar((OP*)rcop);
3071 pm->op_pmreplstart = LINKLIST(rcop);
3080 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3083 NewOp(1101, svop, 1, SVOP);
3084 svop->op_type = type;
3085 svop->op_ppaddr = PL_ppaddr[type];
3087 svop->op_next = (OP*)svop;
3088 svop->op_flags = flags;
3089 if (PL_opargs[type] & OA_RETSCALAR)
3091 if (PL_opargs[type] & OA_TARGET)
3092 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3093 return CHECKOP(type, svop);
3097 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3100 NewOp(1101, padop, 1, PADOP);
3101 padop->op_type = type;
3102 padop->op_ppaddr = PL_ppaddr[type];
3103 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3104 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3105 PL_curpad[padop->op_padix] = sv;
3107 padop->op_next = (OP*)padop;
3108 padop->op_flags = flags;
3109 if (PL_opargs[type] & OA_RETSCALAR)
3111 if (PL_opargs[type] & OA_TARGET)
3112 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3113 return CHECKOP(type, padop);
3117 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3121 return newPADOP(type, flags, SvREFCNT_inc(gv));
3123 return newSVOP(type, flags, SvREFCNT_inc(gv));
3128 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3131 NewOp(1101, pvop, 1, PVOP);
3132 pvop->op_type = type;
3133 pvop->op_ppaddr = PL_ppaddr[type];
3135 pvop->op_next = (OP*)pvop;
3136 pvop->op_flags = flags;
3137 if (PL_opargs[type] & OA_RETSCALAR)
3139 if (PL_opargs[type] & OA_TARGET)
3140 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3141 return CHECKOP(type, pvop);
3145 Perl_package(pTHX_ OP *o)
3149 save_hptr(&PL_curstash);
3150 save_item(PL_curstname);
3155 name = SvPV(sv, len);
3156 PL_curstash = gv_stashpvn(name,len,TRUE);
3157 sv_setpvn(PL_curstname, name, len);
3161 sv_setpv(PL_curstname,"<none>");
3162 PL_curstash = Nullhv;
3164 PL_hints |= HINT_BLOCK_SCOPE;
3165 PL_copline = NOLINE;
3170 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3178 if (id->op_type != OP_CONST)
3179 Perl_croak(aTHX_ "Module name must be constant");
3183 if (version != Nullop) {
3184 SV *vesv = ((SVOP*)version)->op_sv;
3186 if (arg == Nullop && !SvNIOKp(vesv)) {
3193 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3194 Perl_croak(aTHX_ "Version number must be constant number");
3196 /* Make copy of id so we don't free it twice */
3197 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3199 /* Fake up a method call to VERSION */
3200 meth = newSVpvn("VERSION",7);
3201 sv_upgrade(meth, SVt_PVIV);
3202 (void)SvIOK_on(meth);
3203 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3204 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3205 append_elem(OP_LIST,
3206 prepend_elem(OP_LIST, pack, list(version)),
3207 newSVOP(OP_METHOD_NAMED, 0, meth)));
3211 /* Fake up an import/unimport */
3212 if (arg && arg->op_type == OP_STUB)
3213 imop = arg; /* no import on explicit () */
3214 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3215 imop = Nullop; /* use 5.0; */
3220 /* Make copy of id so we don't free it twice */
3221 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3223 /* Fake up a method call to import/unimport */
3224 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3225 sv_upgrade(meth, SVt_PVIV);
3226 (void)SvIOK_on(meth);
3227 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3228 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3229 append_elem(OP_LIST,
3230 prepend_elem(OP_LIST, pack, list(arg)),
3231 newSVOP(OP_METHOD_NAMED, 0, meth)));
3234 /* Fake up a require, handle override, if any */
3235 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3236 if (!(gv && GvIMPORTED_CV(gv)))
3237 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3239 if (gv && GvIMPORTED_CV(gv)) {
3240 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3241 append_elem(OP_LIST, id,
3242 scalar(newUNOP(OP_RV2CV, 0,
3247 rqop = newUNOP(OP_REQUIRE, 0, id);
3250 /* Fake up the BEGIN {}, which does its thing immediately. */
3252 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3255 append_elem(OP_LINESEQ,
3256 append_elem(OP_LINESEQ,
3257 newSTATEOP(0, Nullch, rqop),
3258 newSTATEOP(0, Nullch, veop)),
3259 newSTATEOP(0, Nullch, imop) ));
3261 PL_hints |= HINT_BLOCK_SCOPE;
3262 PL_copline = NOLINE;
3267 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3270 va_start(args, ver);
3271 vload_module(flags, name, ver, &args);
3275 #ifdef PERL_IMPLICIT_CONTEXT
3277 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3281 va_start(args, ver);
3282 vload_module(flags, name, ver, &args);
3288 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3290 OP *modname, *veop, *imop;
3292 modname = newSVOP(OP_CONST, 0, name);
3293 modname->op_private |= OPpCONST_BARE;
3295 veop = newSVOP(OP_CONST, 0, ver);
3299 if (flags & PERL_LOADMOD_NOIMPORT) {
3300 imop = sawparens(newNULLLIST());
3302 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3303 imop = va_arg(*args, OP*);
3308 sv = va_arg(*args, SV*);
3310 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3311 sv = va_arg(*args, SV*);
3315 line_t ocopline = PL_copline;
3316 int oexpect = PL_expect;
3318 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3319 veop, modname, imop);
3320 PL_expect = oexpect;
3321 PL_copline = ocopline;
3326 Perl_dofile(pTHX_ OP *term)
3331 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3332 if (!(gv && GvIMPORTED_CV(gv)))
3333 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3335 if (gv && GvIMPORTED_CV(gv)) {
3336 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3337 append_elem(OP_LIST, term,
3338 scalar(newUNOP(OP_RV2CV, 0,
3343 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3349 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3351 return newBINOP(OP_LSLICE, flags,
3352 list(force_list(subscript)),
3353 list(force_list(listval)) );
3357 S_list_assignment(pTHX_ register OP *o)
3362 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3363 o = cUNOPo->op_first;
3365 if (o->op_type == OP_COND_EXPR) {
3366 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3367 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3372 yyerror("Assignment to both a list and a scalar");
3376 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3377 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3378 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3381 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3384 if (o->op_type == OP_RV2SV)
3391 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3396 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3397 return newLOGOP(optype, 0,
3398 mod(scalar(left), optype),
3399 newUNOP(OP_SASSIGN, 0, scalar(right)));
3402 return newBINOP(optype, OPf_STACKED,
3403 mod(scalar(left), optype), scalar(right));
3407 if (list_assignment(left)) {
3411 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3412 left = mod(left, OP_AASSIGN);
3420 curop = list(force_list(left));
3421 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3422 o->op_private = 0 | (flags >> 8);
3423 for (curop = ((LISTOP*)curop)->op_first;
3424 curop; curop = curop->op_sibling)
3426 if (curop->op_type == OP_RV2HV &&
3427 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3428 o->op_private |= OPpASSIGN_HASH;
3432 if (!(left->op_private & OPpLVAL_INTRO)) {
3435 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3436 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3437 if (curop->op_type == OP_GV) {
3438 GV *gv = cGVOPx_gv(curop);
3439 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3441 SvCUR(gv) = PL_generation;
3443 else if (curop->op_type == OP_PADSV ||
3444 curop->op_type == OP_PADAV ||
3445 curop->op_type == OP_PADHV ||
3446 curop->op_type == OP_PADANY) {
3447 SV **svp = AvARRAY(PL_comppad_name);
3448 SV *sv = svp[curop->op_targ];
3449 if (SvCUR(sv) == PL_generation)
3451 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3453 else if (curop->op_type == OP_RV2CV)
3455 else if (curop->op_type == OP_RV2SV ||
3456 curop->op_type == OP_RV2AV ||
3457 curop->op_type == OP_RV2HV ||
3458 curop->op_type == OP_RV2GV) {
3459 if (lastop->op_type != OP_GV) /* funny deref? */
3462 else if (curop->op_type == OP_PUSHRE) {
3463 if (((PMOP*)curop)->op_pmreplroot) {
3465 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3467 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3469 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3471 SvCUR(gv) = PL_generation;
3480 o->op_private |= OPpASSIGN_COMMON;
3482 if (right && right->op_type == OP_SPLIT) {
3484 if ((tmpop = ((LISTOP*)right)->op_first) &&
3485 tmpop->op_type == OP_PUSHRE)
3487 PMOP *pm = (PMOP*)tmpop;
3488 if (left->op_type == OP_RV2AV &&
3489 !(left->op_private & OPpLVAL_INTRO) &&
3490 !(o->op_private & OPpASSIGN_COMMON) )
3492 tmpop = ((UNOP*)left)->op_first;
3493 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3495 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3496 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3498 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3499 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3501 pm->op_pmflags |= PMf_ONCE;
3502 tmpop = cUNOPo->op_first; /* to list (nulled) */
3503 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3504 tmpop->op_sibling = Nullop; /* don't free split */
3505 right->op_next = tmpop->op_next; /* fix starting loc */
3506 op_free(o); /* blow off assign */
3507 right->op_flags &= ~OPf_WANT;
3508 /* "I don't know and I don't care." */
3513 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3514 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3516 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3518 sv_setiv(sv, PL_modcount+1);
3526 right = newOP(OP_UNDEF, 0);
3527 if (right->op_type == OP_READLINE) {
3528 right->op_flags |= OPf_STACKED;
3529 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3532 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3533 o = newBINOP(OP_SASSIGN, flags,
3534 scalar(right), mod(scalar(left), OP_SASSIGN) );
3546 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3548 U32 seq = intro_my();
3551 NewOp(1101, cop, 1, COP);
3552 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3553 cop->op_type = OP_DBSTATE;
3554 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3557 cop->op_type = OP_NEXTSTATE;
3558 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3560 cop->op_flags = flags;
3561 cop->op_private = (PL_hints & HINT_BYTE);
3563 cop->op_private |= NATIVE_HINTS;
3565 PL_compiling.op_private = cop->op_private;
3566 cop->op_next = (OP*)cop;
3569 cop->cop_label = label;
3570 PL_hints |= HINT_BLOCK_SCOPE;
3573 cop->cop_arybase = PL_curcop->cop_arybase;
3574 if (specialWARN(PL_curcop->cop_warnings))
3575 cop->cop_warnings = PL_curcop->cop_warnings ;
3577 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3578 if (specialCopIO(PL_curcop->cop_io))
3579 cop->cop_io = PL_curcop->cop_io;
3581 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3584 if (PL_copline == NOLINE)
3585 CopLINE_set(cop, CopLINE(PL_curcop));
3587 CopLINE_set(cop, PL_copline);
3588 PL_copline = NOLINE;
3591 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3593 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3595 CopSTASH_set(cop, PL_curstash);
3597 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3598 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3599 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3600 (void)SvIOK_on(*svp);
3601 SvIVX(*svp) = PTR2IV(cop);
3605 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3608 /* "Introduce" my variables to visible status. */
3616 if (! PL_min_intro_pending)
3617 return PL_cop_seqmax;
3619 svp = AvARRAY(PL_comppad_name);
3620 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3621 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3622 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3623 SvNVX(sv) = (NV)PL_cop_seqmax;
3626 PL_min_intro_pending = 0;
3627 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3628 return PL_cop_seqmax++;
3632 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3634 return new_logop(type, flags, &first, &other);
3638 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3642 OP *first = *firstp;
3643 OP *other = *otherp;
3645 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3646 return newBINOP(type, flags, scalar(first), scalar(other));
3648 scalarboolean(first);
3649 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3650 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3651 if (type == OP_AND || type == OP_OR) {
3657 first = *firstp = cUNOPo->op_first;
3659 first->op_next = o->op_next;
3660 cUNOPo->op_first = Nullop;
3664 if (first->op_type == OP_CONST) {
3665 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3666 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3667 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3678 else if (first->op_type == OP_WANTARRAY) {
3684 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3685 OP *k1 = ((UNOP*)first)->op_first;
3686 OP *k2 = k1->op_sibling;
3688 switch (first->op_type)
3691 if (k2 && k2->op_type == OP_READLINE
3692 && (k2->op_flags & OPf_STACKED)
3693 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3695 warnop = k2->op_type;
3700 if (k1->op_type == OP_READDIR
3701 || k1->op_type == OP_GLOB
3702 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3703 || k1->op_type == OP_EACH)
3705 warnop = ((k1->op_type == OP_NULL)
3706 ? k1->op_targ : k1->op_type);
3711 line_t oldline = CopLINE(PL_curcop);
3712 CopLINE_set(PL_curcop, PL_copline);
3713 Perl_warner(aTHX_ WARN_MISC,
3714 "Value of %s%s can be \"0\"; test with defined()",
3716 ((warnop == OP_READLINE || warnop == OP_GLOB)
3717 ? " construct" : "() operator"));
3718 CopLINE_set(PL_curcop, oldline);
3725 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3726 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3728 NewOp(1101, logop, 1, LOGOP);
3730 logop->op_type = type;
3731 logop->op_ppaddr = PL_ppaddr[type];
3732 logop->op_first = first;
3733 logop->op_flags = flags | OPf_KIDS;
3734 logop->op_other = LINKLIST(other);
3735 logop->op_private = 1 | (flags >> 8);
3737 /* establish postfix order */
3738 logop->op_next = LINKLIST(first);
3739 first->op_next = (OP*)logop;
3740 first->op_sibling = other;
3742 o = newUNOP(OP_NULL, 0, (OP*)logop);
3749 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3756 return newLOGOP(OP_AND, 0, first, trueop);
3758 return newLOGOP(OP_OR, 0, first, falseop);
3760 scalarboolean(first);
3761 if (first->op_type == OP_CONST) {
3762 if (SvTRUE(((SVOP*)first)->op_sv)) {
3773 else if (first->op_type == OP_WANTARRAY) {
3777 NewOp(1101, logop, 1, LOGOP);
3778 logop->op_type = OP_COND_EXPR;
3779 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3780 logop->op_first = first;
3781 logop->op_flags = flags | OPf_KIDS;
3782 logop->op_private = 1 | (flags >> 8);
3783 logop->op_other = LINKLIST(trueop);
3784 logop->op_next = LINKLIST(falseop);
3787 /* establish postfix order */
3788 start = LINKLIST(first);
3789 first->op_next = (OP*)logop;
3791 first->op_sibling = trueop;
3792 trueop->op_sibling = falseop;
3793 o = newUNOP(OP_NULL, 0, (OP*)logop);
3795 trueop->op_next = falseop->op_next = o;
3802 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3810 NewOp(1101, range, 1, LOGOP);
3812 range->op_type = OP_RANGE;
3813 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3814 range->op_first = left;
3815 range->op_flags = OPf_KIDS;
3816 leftstart = LINKLIST(left);
3817 range->op_other = LINKLIST(right);
3818 range->op_private = 1 | (flags >> 8);
3820 left->op_sibling = right;
3822 range->op_next = (OP*)range;
3823 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3824 flop = newUNOP(OP_FLOP, 0, flip);
3825 o = newUNOP(OP_NULL, 0, flop);
3827 range->op_next = leftstart;
3829 left->op_next = flip;
3830 right->op_next = flop;
3832 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3833 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3834 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3835 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3837 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3838 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3841 if (!flip->op_private || !flop->op_private)
3842 linklist(o); /* blow off optimizer unless constant */
3848 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3852 int once = block && block->op_flags & OPf_SPECIAL &&
3853 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3856 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3857 return block; /* do {} while 0 does once */
3858 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3859 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3860 expr = newUNOP(OP_DEFINED, 0,
3861 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3862 } else if (expr->op_flags & OPf_KIDS) {
3863 OP *k1 = ((UNOP*)expr)->op_first;
3864 OP *k2 = (k1) ? k1->op_sibling : NULL;
3865 switch (expr->op_type) {
3867 if (k2 && k2->op_type == OP_READLINE
3868 && (k2->op_flags & OPf_STACKED)
3869 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3870 expr = newUNOP(OP_DEFINED, 0, expr);
3874 if (k1->op_type == OP_READDIR
3875 || k1->op_type == OP_GLOB
3876 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3877 || k1->op_type == OP_EACH)
3878 expr = newUNOP(OP_DEFINED, 0, expr);
3884 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3885 o = new_logop(OP_AND, 0, &expr, &listop);
3888 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3890 if (once && o != listop)
3891 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3894 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3896 o->op_flags |= flags;
3898 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3903 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3912 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3913 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3914 expr = newUNOP(OP_DEFINED, 0,
3915 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3916 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3917 OP *k1 = ((UNOP*)expr)->op_first;
3918 OP *k2 = (k1) ? k1->op_sibling : NULL;
3919 switch (expr->op_type) {
3921 if (k2 && k2->op_type == OP_READLINE
3922 && (k2->op_flags & OPf_STACKED)
3923 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3924 expr = newUNOP(OP_DEFINED, 0, expr);
3928 if (k1->op_type == OP_READDIR
3929 || k1->op_type == OP_GLOB
3930 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3931 || k1->op_type == OP_EACH)
3932 expr = newUNOP(OP_DEFINED, 0, expr);
3938 block = newOP(OP_NULL, 0);
3940 block = scope(block);
3944 next = LINKLIST(cont);
3947 OP *unstack = newOP(OP_UNSTACK, 0);
3950 cont = append_elem(OP_LINESEQ, cont, unstack);
3951 if ((line_t)whileline != NOLINE) {
3952 PL_copline = whileline;
3953 cont = append_elem(OP_LINESEQ, cont,
3954 newSTATEOP(0, Nullch, Nullop));
3958 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3959 redo = LINKLIST(listop);
3962 PL_copline = whileline;
3964 o = new_logop(OP_AND, 0, &expr, &listop);
3965 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3966 op_free(expr); /* oops, it's a while (0) */
3968 return Nullop; /* listop already freed by new_logop */
3971 ((LISTOP*)listop)->op_last->op_next = condop =
3972 (o == listop ? redo : LINKLIST(o));
3978 NewOp(1101,loop,1,LOOP);
3979 loop->op_type = OP_ENTERLOOP;
3980 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3981 loop->op_private = 0;
3982 loop->op_next = (OP*)loop;
3985 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3987 loop->op_redoop = redo;
3988 loop->op_lastop = o;
3989 o->op_private |= loopflags;
3992 loop->op_nextop = next;
3994 loop->op_nextop = o;
3996 o->op_flags |= flags;
3997 o->op_private |= (flags >> 8);
4002 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4010 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4011 sv->op_type = OP_RV2GV;
4012 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4014 else if (sv->op_type == OP_PADSV) { /* private variable */
4015 padoff = sv->op_targ;
4020 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4021 padoff = sv->op_targ;
4023 iterflags |= OPf_SPECIAL;
4028 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4032 padoff = find_threadsv("_");
4033 iterflags |= OPf_SPECIAL;
4035 sv = newGVOP(OP_GV, 0, PL_defgv);
4038 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4039 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4040 iterflags |= OPf_STACKED;
4042 else if (expr->op_type == OP_NULL &&
4043 (expr->op_flags & OPf_KIDS) &&
4044 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4046 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4047 * set the STACKED flag to indicate that these values are to be
4048 * treated as min/max values by 'pp_iterinit'.
4050 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4051 LOGOP* range = (LOGOP*) flip->op_first;
4052 OP* left = range->op_first;
4053 OP* right = left->op_sibling;
4056 range->op_flags &= ~OPf_KIDS;
4057 range->op_first = Nullop;
4059 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4060 listop->op_first->op_next = range->op_next;
4061 left->op_next = range->op_other;
4062 right->op_next = (OP*)listop;
4063 listop->op_next = listop->op_first;
4066 expr = (OP*)(listop);
4068 iterflags |= OPf_STACKED;
4071 expr = mod(force_list(expr), OP_GREPSTART);
4075 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4076 append_elem(OP_LIST, expr, scalar(sv))));
4077 assert(!loop->op_next);
4078 #ifdef PL_OP_SLAB_ALLOC
4081 NewOp(1234,tmp,1,LOOP);
4082 Copy(loop,tmp,1,LOOP);
4086 Renew(loop, 1, LOOP);
4088 loop->op_targ = padoff;
4089 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4090 PL_copline = forline;
4091 return newSTATEOP(0, label, wop);
4095 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4100 if (type != OP_GOTO || label->op_type == OP_CONST) {
4101 /* "last()" means "last" */
4102 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4103 o = newOP(type, OPf_SPECIAL);
4105 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4106 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4112 if (label->op_type == OP_ENTERSUB)
4113 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4114 o = newUNOP(type, OPf_STACKED, label);
4116 PL_hints |= HINT_BLOCK_SCOPE;
4121 Perl_cv_undef(pTHX_ CV *cv)
4125 MUTEX_DESTROY(CvMUTEXP(cv));
4126 Safefree(CvMUTEXP(cv));
4129 #endif /* USE_THREADS */
4131 if (!CvXSUB(cv) && CvROOT(cv)) {
4133 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4134 Perl_croak(aTHX_ "Can't undef active subroutine");
4137 Perl_croak(aTHX_ "Can't undef active subroutine");
4138 #endif /* USE_THREADS */
4141 SAVEVPTR(PL_curpad);
4145 op_free(CvROOT(cv));
4146 CvROOT(cv) = Nullop;
4149 SvPOK_off((SV*)cv); /* forget prototype */
4151 SvREFCNT_dec(CvGV(cv));
4153 SvREFCNT_dec(CvOUTSIDE(cv));
4154 CvOUTSIDE(cv) = Nullcv;
4156 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4159 if (CvPADLIST(cv)) {
4160 /* may be during global destruction */
4161 if (SvREFCNT(CvPADLIST(cv))) {
4162 I32 i = AvFILLp(CvPADLIST(cv));
4164 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4165 SV* sv = svp ? *svp : Nullsv;
4168 if (sv == (SV*)PL_comppad_name)
4169 PL_comppad_name = Nullav;
4170 else if (sv == (SV*)PL_comppad) {
4171 PL_comppad = Nullav;
4172 PL_curpad = Null(SV**);
4176 SvREFCNT_dec((SV*)CvPADLIST(cv));
4178 CvPADLIST(cv) = Nullav;
4183 S_cv_dump(pTHX_ CV *cv)
4186 CV *outside = CvOUTSIDE(cv);
4187 AV* padlist = CvPADLIST(cv);
4194 PerlIO_printf(Perl_debug_log,
4195 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4197 (CvANON(cv) ? "ANON"
4198 : (cv == PL_main_cv) ? "MAIN"
4199 : CvUNIQUE(cv) ? "UNIQUE"
4200 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4203 : CvANON(outside) ? "ANON"
4204 : (outside == PL_main_cv) ? "MAIN"
4205 : CvUNIQUE(outside) ? "UNIQUE"
4206 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4211 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4212 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4213 pname = AvARRAY(pad_name);
4214 ppad = AvARRAY(pad);
4216 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4217 if (SvPOK(pname[ix]))
4218 PerlIO_printf(Perl_debug_log,
4219 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4220 (int)ix, PTR2UV(ppad[ix]),
4221 SvFAKE(pname[ix]) ? "FAKE " : "",
4223 (IV)I_32(SvNVX(pname[ix])),
4226 #endif /* DEBUGGING */
4230 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4234 AV* protopadlist = CvPADLIST(proto);
4235 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4236 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4237 SV** pname = AvARRAY(protopad_name);
4238 SV** ppad = AvARRAY(protopad);
4239 I32 fname = AvFILLp(protopad_name);
4240 I32 fpad = AvFILLp(protopad);
4244 assert(!CvUNIQUE(proto));
4248 SAVESPTR(PL_comppad_name);
4249 SAVESPTR(PL_compcv);
4251 cv = PL_compcv = (CV*)NEWSV(1104,0);
4252 sv_upgrade((SV *)cv, SvTYPE(proto));
4253 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4257 New(666, CvMUTEXP(cv), 1, perl_mutex);
4258 MUTEX_INIT(CvMUTEXP(cv));
4260 #endif /* USE_THREADS */
4261 CvFILE(cv) = CvFILE(proto);
4262 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4263 CvSTASH(cv) = CvSTASH(proto);
4264 CvROOT(cv) = CvROOT(proto);
4265 CvSTART(cv) = CvSTART(proto);
4267 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4270 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4272 PL_comppad_name = newAV();
4273 for (ix = fname; ix >= 0; ix--)
4274 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4276 PL_comppad = newAV();
4278 comppadlist = newAV();
4279 AvREAL_off(comppadlist);
4280 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4281 av_store(comppadlist, 1, (SV*)PL_comppad);
4282 CvPADLIST(cv) = comppadlist;
4283 av_fill(PL_comppad, AvFILLp(protopad));
4284 PL_curpad = AvARRAY(PL_comppad);
4286 av = newAV(); /* will be @_ */
4288 av_store(PL_comppad, 0, (SV*)av);
4289 AvFLAGS(av) = AVf_REIFY;
4291 for (ix = fpad; ix > 0; ix--) {
4292 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4293 if (namesv && namesv != &PL_sv_undef) {
4294 char *name = SvPVX(namesv); /* XXX */
4295 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4296 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4297 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4299 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4301 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4303 else { /* our own lexical */
4306 /* anon code -- we'll come back for it */
4307 sv = SvREFCNT_inc(ppad[ix]);
4309 else if (*name == '@')
4311 else if (*name == '%')
4320 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4321 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4324 SV* sv = NEWSV(0,0);
4330 /* Now that vars are all in place, clone nested closures. */
4332 for (ix = fpad; ix > 0; ix--) {
4333 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4335 && namesv != &PL_sv_undef
4336 && !(SvFLAGS(namesv) & SVf_FAKE)
4337 && *SvPVX(namesv) == '&'
4338 && CvCLONE(ppad[ix]))
4340 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4341 SvREFCNT_dec(ppad[ix]);
4344 PL_curpad[ix] = (SV*)kid;
4348 #ifdef DEBUG_CLOSURES
4349 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4351 PerlIO_printf(Perl_debug_log, " from:\n");
4353 PerlIO_printf(Perl_debug_log, " to:\n");
4360 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4362 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4364 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4371 Perl_cv_clone(pTHX_ CV *proto)
4374 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4375 cv = cv_clone2(proto, CvOUTSIDE(proto));
4376 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4381 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4383 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4384 SV* msg = sv_newmortal();
4388 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4389 sv_setpv(msg, "Prototype mismatch:");
4391 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4393 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4394 sv_catpv(msg, " vs ");
4396 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4398 sv_catpv(msg, "none");
4399 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4403 static void const_sv_xsub(pTHXo_ CV* cv);
4406 =for apidoc cv_const_sv
4408 If C<cv> is a constant sub eligible for inlining. returns the constant
4409 value returned by the sub. Otherwise, returns NULL.
4411 Constant subs can be created with C<newCONSTSUB> or as described in
4412 L<perlsub/"Constant Functions">.
4417 Perl_cv_const_sv(pTHX_ CV *cv)
4419 if (!cv || !CvCONST(cv))
4421 return (SV*)CvXSUBANY(cv).any_ptr;
4425 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4432 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4433 o = cLISTOPo->op_first->op_sibling;
4435 for (; o; o = o->op_next) {
4436 OPCODE type = o->op_type;
4438 if (sv && o->op_next == o)
4440 if (o->op_next != o) {
4441 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4443 if (type == OP_DBSTATE)
4446 if (type == OP_LEAVESUB || type == OP_RETURN)
4450 if (type == OP_CONST && cSVOPo->op_sv)
4452 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4453 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4454 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4458 /* We get here only from cv_clone2() while creating a closure.
4459 Copy the const value here instead of in cv_clone2 so that
4460 SvREADONLY_on doesn't lead to problems when leaving
4465 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4477 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4487 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4491 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4493 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4497 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4503 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4508 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4509 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4510 SV *sv = sv_newmortal();
4511 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4512 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4517 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4518 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4528 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4529 maximum a prototype before. */
4530 if (SvTYPE(gv) > SVt_NULL) {
4531 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4532 && ckWARN_d(WARN_PROTOTYPE))
4534 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4536 cv_ckproto((CV*)gv, NULL, ps);
4539 sv_setpv((SV*)gv, ps);
4541 sv_setiv((SV*)gv, -1);
4542 SvREFCNT_dec(PL_compcv);
4543 cv = PL_compcv = NULL;
4544 PL_sub_generation++;
4548 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4550 if (!block || !ps || *ps || attrs)
4553 const_sv = op_const_sv(block, Nullcv);
4556 bool exists = CvROOT(cv) || CvXSUB(cv);
4557 /* if the subroutine doesn't exist and wasn't pre-declared
4558 * with a prototype, assume it will be AUTOLOADed,
4559 * skipping the prototype check
4561 if (exists || SvPOK(cv))
4562 cv_ckproto(cv, gv, ps);
4563 /* already defined (or promised)? */
4564 if (exists || GvASSUMECV(gv)) {
4565 if (!block && !attrs) {
4566 /* just a "sub foo;" when &foo is already defined */
4567 SAVEFREESV(PL_compcv);
4570 /* ahem, death to those who redefine active sort subs */
4571 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4572 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4574 if (ckWARN(WARN_REDEFINE)
4576 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4578 line_t oldline = CopLINE(PL_curcop);
4579 CopLINE_set(PL_curcop, PL_copline);
4580 Perl_warner(aTHX_ WARN_REDEFINE,
4581 CvCONST(cv) ? "Constant subroutine %s redefined"
4582 : "Subroutine %s redefined", name);
4583 CopLINE_set(PL_curcop, oldline);
4591 SvREFCNT_inc(const_sv);
4593 assert(!CvROOT(cv) && !CvCONST(cv));
4594 sv_setpv((SV*)cv, ""); /* prototype is "" */
4595 CvXSUBANY(cv).any_ptr = const_sv;
4596 CvXSUB(cv) = const_sv_xsub;
4601 cv = newCONSTSUB(NULL, name, const_sv);
4604 SvREFCNT_dec(PL_compcv);
4606 PL_sub_generation++;
4613 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4614 * before we clobber PL_compcv.
4618 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4619 stash = GvSTASH(CvGV(cv));
4620 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4621 stash = CvSTASH(cv);
4623 stash = PL_curstash;
4626 /* possibly about to re-define existing subr -- ignore old cv */
4627 rcv = (SV*)PL_compcv;
4628 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4629 stash = GvSTASH(gv);
4631 stash = PL_curstash;
4633 apply_attrs(stash, rcv, attrs);
4635 if (cv) { /* must reuse cv if autoloaded */
4637 /* got here with just attrs -- work done, so bug out */
4638 SAVEFREESV(PL_compcv);
4642 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4643 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4644 CvOUTSIDE(PL_compcv) = 0;
4645 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4646 CvPADLIST(PL_compcv) = 0;
4647 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4648 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4649 SvREFCNT_dec(PL_compcv);
4656 PL_sub_generation++;
4659 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4660 CvFILE(cv) = CopFILE(PL_curcop);
4661 CvSTASH(cv) = PL_curstash;
4664 if (!CvMUTEXP(cv)) {
4665 New(666, CvMUTEXP(cv), 1, perl_mutex);
4666 MUTEX_INIT(CvMUTEXP(cv));
4668 #endif /* USE_THREADS */
4671 sv_setpv((SV*)cv, ps);
4673 if (PL_error_count) {
4677 char *s = strrchr(name, ':');
4679 if (strEQ(s, "BEGIN")) {
4681 "BEGIN not safe after errors--compilation aborted";
4682 if (PL_in_eval & EVAL_KEEPERR)
4683 Perl_croak(aTHX_ not_safe);
4685 /* force display of errors found but not reported */
4686 sv_catpv(ERRSV, not_safe);
4687 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4695 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4696 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4699 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4700 mod(scalarseq(block), OP_LEAVESUBLV));
4703 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4705 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4706 OpREFCNT_set(CvROOT(cv), 1);
4707 CvSTART(cv) = LINKLIST(CvROOT(cv));
4708 CvROOT(cv)->op_next = 0;
4711 /* now that optimizer has done its work, adjust pad values */
4713 SV **namep = AvARRAY(PL_comppad_name);
4714 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4717 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4720 * The only things that a clonable function needs in its
4721 * pad are references to outer lexicals and anonymous subs.
4722 * The rest are created anew during cloning.
4724 if (!((namesv = namep[ix]) != Nullsv &&
4725 namesv != &PL_sv_undef &&
4727 *SvPVX(namesv) == '&')))
4729 SvREFCNT_dec(PL_curpad[ix]);
4730 PL_curpad[ix] = Nullsv;
4733 assert(!CvCONST(cv));
4734 if (ps && !*ps && op_const_sv(block, cv))
4738 AV *av = newAV(); /* Will be @_ */
4740 av_store(PL_comppad, 0, (SV*)av);
4741 AvFLAGS(av) = AVf_REIFY;
4743 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4744 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4746 if (!SvPADMY(PL_curpad[ix]))
4747 SvPADTMP_on(PL_curpad[ix]);
4751 if (name || aname) {
4753 char *tname = (name ? name : aname);
4755 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4756 SV *sv = NEWSV(0,0);
4757 SV *tmpstr = sv_newmortal();
4758 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4762 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4764 (long)PL_subline, (long)CopLINE(PL_curcop));
4765 gv_efullname3(tmpstr, gv, Nullch);
4766 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4767 hv = GvHVn(db_postponed);
4768 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4769 && (pcv = GvCV(db_postponed)))
4775 call_sv((SV*)pcv, G_DISCARD);
4779 if ((s = strrchr(tname,':')))
4784 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4787 if (strEQ(s, "BEGIN")) {
4788 I32 oldscope = PL_scopestack_ix;
4790 SAVECOPFILE(&PL_compiling);
4791 SAVECOPLINE(&PL_compiling);
4793 sv_setsv(PL_rs, PL_nrs);
4796 PL_beginav = newAV();
4797 DEBUG_x( dump_sub(gv) );
4798 av_push(PL_beginav, (SV*)cv);
4799 GvCV(gv) = 0; /* cv has been hijacked */
4800 call_list(oldscope, PL_beginav);
4802 PL_curcop = &PL_compiling;
4803 PL_compiling.op_private = PL_hints;
4806 else if (strEQ(s, "END") && !PL_error_count) {
4809 DEBUG_x( dump_sub(gv) );
4810 av_unshift(PL_endav, 1);
4811 av_store(PL_endav, 0, (SV*)cv);
4812 GvCV(gv) = 0; /* cv has been hijacked */
4814 else if (strEQ(s, "CHECK") && !PL_error_count) {
4816 PL_checkav = newAV();
4817 DEBUG_x( dump_sub(gv) );
4818 if (PL_main_start && ckWARN(WARN_VOID))
4819 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4820 av_unshift(PL_checkav, 1);
4821 av_store(PL_checkav, 0, (SV*)cv);
4822 GvCV(gv) = 0; /* cv has been hijacked */
4824 else if (strEQ(s, "INIT") && !PL_error_count) {
4826 PL_initav = newAV();
4827 DEBUG_x( dump_sub(gv) );
4828 if (PL_main_start && ckWARN(WARN_VOID))
4829 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4830 av_push(PL_initav, (SV*)cv);
4831 GvCV(gv) = 0; /* cv has been hijacked */
4836 PL_copline = NOLINE;
4841 /* XXX unsafe for threads if eval_owner isn't held */
4843 =for apidoc newCONSTSUB
4845 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4846 eligible for inlining at compile-time.
4852 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4858 SAVECOPLINE(PL_curcop);
4859 CopLINE_set(PL_curcop, PL_copline);
4862 PL_hints &= ~HINT_BLOCK_SCOPE;
4865 SAVESPTR(PL_curstash);
4866 SAVECOPSTASH(PL_curcop);
4867 PL_curstash = stash;
4869 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4871 CopSTASH(PL_curcop) = stash;
4875 cv = newXS(name, const_sv_xsub, __FILE__);
4876 CvXSUBANY(cv).any_ptr = sv;
4878 sv_setpv((SV*)cv, ""); /* prototype is "" */
4886 =for apidoc U||newXS
4888 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4894 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4896 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4899 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4901 /* just a cached method */
4905 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4906 /* already defined (or promised) */
4907 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4908 && HvNAME(GvSTASH(CvGV(cv)))
4909 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4910 line_t oldline = CopLINE(PL_curcop);
4911 if (PL_copline != NOLINE)
4912 CopLINE_set(PL_curcop, PL_copline);
4913 Perl_warner(aTHX_ WARN_REDEFINE,
4914 CvCONST(cv) ? "Constant subroutine %s redefined"
4915 : "Subroutine %s redefined"
4917 CopLINE_set(PL_curcop, oldline);
4924 if (cv) /* must reuse cv if autoloaded */
4927 cv = (CV*)NEWSV(1105,0);
4928 sv_upgrade((SV *)cv, SVt_PVCV);
4932 PL_sub_generation++;
4935 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4937 New(666, CvMUTEXP(cv), 1, perl_mutex);
4938 MUTEX_INIT(CvMUTEXP(cv));
4940 #endif /* USE_THREADS */
4941 (void)gv_fetchfile(filename);
4942 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4943 an external constant string */
4944 CvXSUB(cv) = subaddr;
4947 char *s = strrchr(name,':');
4953 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4956 if (strEQ(s, "BEGIN")) {
4958 PL_beginav = newAV();
4959 av_push(PL_beginav, (SV*)cv);
4960 GvCV(gv) = 0; /* cv has been hijacked */
4962 else if (strEQ(s, "END")) {
4965 av_unshift(PL_endav, 1);
4966 av_store(PL_endav, 0, (SV*)cv);
4967 GvCV(gv) = 0; /* cv has been hijacked */
4969 else if (strEQ(s, "CHECK")) {
4971 PL_checkav = newAV();
4972 if (PL_main_start && ckWARN(WARN_VOID))
4973 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4974 av_unshift(PL_checkav, 1);
4975 av_store(PL_checkav, 0, (SV*)cv);
4976 GvCV(gv) = 0; /* cv has been hijacked */
4978 else if (strEQ(s, "INIT")) {
4980 PL_initav = newAV();
4981 if (PL_main_start && ckWARN(WARN_VOID))
4982 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4983 av_push(PL_initav, (SV*)cv);
4984 GvCV(gv) = 0; /* cv has been hijacked */
4995 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5004 name = SvPVx(cSVOPo->op_sv, n_a);
5007 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5009 if ((cv = GvFORM(gv))) {
5010 if (ckWARN(WARN_REDEFINE)) {
5011 line_t oldline = CopLINE(PL_curcop);
5013 CopLINE_set(PL_curcop, PL_copline);
5014 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5015 CopLINE_set(PL_curcop, oldline);
5021 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
5022 CvFILE(cv) = CopFILE(PL_curcop);
5024 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5025 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5026 SvPADTMP_on(PL_curpad[ix]);
5029 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5030 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5031 OpREFCNT_set(CvROOT(cv), 1);
5032 CvSTART(cv) = LINKLIST(CvROOT(cv));
5033 CvROOT(cv)->op_next = 0;
5036 PL_copline = NOLINE;
5041 Perl_newANONLIST(pTHX_ OP *o)
5043 return newUNOP(OP_REFGEN, 0,
5044 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5048 Perl_newANONHASH(pTHX_ OP *o)
5050 return newUNOP(OP_REFGEN, 0,
5051 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5055 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5057 return newANONATTRSUB(floor, proto, Nullop, block);
5061 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5063 return newUNOP(OP_REFGEN, 0,
5064 newSVOP(OP_ANONCODE, 0,
5065 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5069 Perl_oopsAV(pTHX_ OP *o)
5071 switch (o->op_type) {
5073 o->op_type = OP_PADAV;
5074 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5075 return ref(o, OP_RV2AV);
5078 o->op_type = OP_RV2AV;
5079 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5084 if (ckWARN_d(WARN_INTERNAL))
5085 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5092 Perl_oopsHV(pTHX_ OP *o)
5094 switch (o->op_type) {
5097 o->op_type = OP_PADHV;
5098 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5099 return ref(o, OP_RV2HV);
5103 o->op_type = OP_RV2HV;
5104 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5109 if (ckWARN_d(WARN_INTERNAL))
5110 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5117 Perl_newAVREF(pTHX_ OP *o)
5119 if (o->op_type == OP_PADANY) {
5120 o->op_type = OP_PADAV;
5121 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5124 return newUNOP(OP_RV2AV, 0, scalar(o));
5128 Perl_newGVREF(pTHX_ I32 type, OP *o)
5130 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5131 return newUNOP(OP_NULL, 0, o);
5132 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5136 Perl_newHVREF(pTHX_ OP *o)
5138 if (o->op_type == OP_PADANY) {
5139 o->op_type = OP_PADHV;
5140 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5143 return newUNOP(OP_RV2HV, 0, scalar(o));
5147 Perl_oopsCV(pTHX_ OP *o)
5149 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5155 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5157 return newUNOP(OP_RV2CV, flags, scalar(o));
5161 Perl_newSVREF(pTHX_ OP *o)
5163 if (o->op_type == OP_PADANY) {
5164 o->op_type = OP_PADSV;
5165 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5168 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5169 o->op_flags |= OPpDONE_SVREF;
5172 return newUNOP(OP_RV2SV, 0, scalar(o));
5175 /* Check routines. */
5178 Perl_ck_anoncode(pTHX_ OP *o)
5183 name = NEWSV(1106,0);
5184 sv_upgrade(name, SVt_PVNV);
5185 sv_setpvn(name, "&", 1);
5188 ix = pad_alloc(o->op_type, SVs_PADMY);
5189 av_store(PL_comppad_name, ix, name);
5190 av_store(PL_comppad, ix, cSVOPo->op_sv);
5191 SvPADMY_on(cSVOPo->op_sv);
5192 cSVOPo->op_sv = Nullsv;
5193 cSVOPo->op_targ = ix;
5198 Perl_ck_bitop(pTHX_ OP *o)
5200 o->op_private = PL_hints;
5205 Perl_ck_concat(pTHX_ OP *o)
5207 if (cUNOPo->op_first->op_type == OP_CONCAT)
5208 o->op_flags |= OPf_STACKED;
5213 Perl_ck_spair(pTHX_ OP *o)
5215 if (o->op_flags & OPf_KIDS) {
5218 OPCODE type = o->op_type;
5219 o = modkids(ck_fun(o), type);
5220 kid = cUNOPo->op_first;
5221 newop = kUNOP->op_first->op_sibling;
5223 (newop->op_sibling ||
5224 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5225 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5226 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5230 op_free(kUNOP->op_first);
5231 kUNOP->op_first = newop;
5233 o->op_ppaddr = PL_ppaddr[++o->op_type];
5238 Perl_ck_delete(pTHX_ OP *o)
5242 if (o->op_flags & OPf_KIDS) {
5243 OP *kid = cUNOPo->op_first;
5244 switch (kid->op_type) {
5246 o->op_flags |= OPf_SPECIAL;
5249 o->op_private |= OPpSLICE;
5252 o->op_flags |= OPf_SPECIAL;
5257 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5258 PL_op_desc[o->op_type]);
5266 Perl_ck_eof(pTHX_ OP *o)
5268 I32 type = o->op_type;
5270 if (o->op_flags & OPf_KIDS) {
5271 if (cLISTOPo->op_first->op_type == OP_STUB) {
5273 o = newUNOP(type, OPf_SPECIAL,
5274 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5282 Perl_ck_eval(pTHX_ OP *o)
5284 PL_hints |= HINT_BLOCK_SCOPE;
5285 if (o->op_flags & OPf_KIDS) {
5286 SVOP *kid = (SVOP*)cUNOPo->op_first;
5289 o->op_flags &= ~OPf_KIDS;
5292 else if (kid->op_type == OP_LINESEQ) {
5295 kid->op_next = o->op_next;
5296 cUNOPo->op_first = 0;
5299 NewOp(1101, enter, 1, LOGOP);
5300 enter->op_type = OP_ENTERTRY;
5301 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5302 enter->op_private = 0;
5304 /* establish postfix order */
5305 enter->op_next = (OP*)enter;
5307 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5308 o->op_type = OP_LEAVETRY;
5309 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5310 enter->op_other = o;
5318 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5320 o->op_targ = (PADOFFSET)PL_hints;
5325 Perl_ck_exit(pTHX_ OP *o)
5328 HV *table = GvHV(PL_hintgv);
5330 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5331 if (svp && *svp && SvTRUE(*svp))
5332 o->op_private |= OPpEXIT_VMSISH;
5339 Perl_ck_exec(pTHX_ OP *o)
5342 if (o->op_flags & OPf_STACKED) {
5344 kid = cUNOPo->op_first->op_sibling;
5345 if (kid->op_type == OP_RV2GV)
5354 Perl_ck_exists(pTHX_ OP *o)
5357 if (o->op_flags & OPf_KIDS) {
5358 OP *kid = cUNOPo->op_first;
5359 if (kid->op_type == OP_ENTERSUB) {
5360 (void) ref(kid, o->op_type);
5361 if (kid->op_type != OP_RV2CV && !PL_error_count)
5362 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5363 PL_op_desc[o->op_type]);
5364 o->op_private |= OPpEXISTS_SUB;
5366 else if (kid->op_type == OP_AELEM)
5367 o->op_flags |= OPf_SPECIAL;
5368 else if (kid->op_type != OP_HELEM)
5369 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5370 PL_op_desc[o->op_type]);
5378 Perl_ck_gvconst(pTHX_ register OP *o)
5380 o = fold_constants(o);
5381 if (o->op_type == OP_CONST)
5388 Perl_ck_rvconst(pTHX_ register OP *o)
5390 SVOP *kid = (SVOP*)cUNOPo->op_first;
5392 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5393 if (kid->op_type == OP_CONST) {
5397 SV *kidsv = kid->op_sv;
5400 /* Is it a constant from cv_const_sv()? */
5401 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5402 SV *rsv = SvRV(kidsv);
5403 int svtype = SvTYPE(rsv);
5404 char *badtype = Nullch;
5406 switch (o->op_type) {
5408 if (svtype > SVt_PVMG)
5409 badtype = "a SCALAR";
5412 if (svtype != SVt_PVAV)
5413 badtype = "an ARRAY";
5416 if (svtype != SVt_PVHV) {
5417 if (svtype == SVt_PVAV) { /* pseudohash? */
5418 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5419 if (ksv && SvROK(*ksv)
5420 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5429 if (svtype != SVt_PVCV)
5434 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5437 name = SvPV(kidsv, n_a);
5438 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5439 char *badthing = Nullch;
5440 switch (o->op_type) {
5442 badthing = "a SCALAR";
5445 badthing = "an ARRAY";
5448 badthing = "a HASH";
5453 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5457 * This is a little tricky. We only want to add the symbol if we
5458 * didn't add it in the lexer. Otherwise we get duplicate strict
5459 * warnings. But if we didn't add it in the lexer, we must at
5460 * least pretend like we wanted to add it even if it existed before,
5461 * or we get possible typo warnings. OPpCONST_ENTERED says
5462 * whether the lexer already added THIS instance of this symbol.
5464 iscv = (o->op_type == OP_RV2CV) * 2;
5466 gv = gv_fetchpv(name,
5467 iscv | !(kid->op_private & OPpCONST_ENTERED),
5470 : o->op_type == OP_RV2SV
5472 : o->op_type == OP_RV2AV
5474 : o->op_type == OP_RV2HV
5477 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5479 kid->op_type = OP_GV;
5480 SvREFCNT_dec(kid->op_sv);
5482 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5483 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5484 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5486 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5488 kid->op_sv = SvREFCNT_inc(gv);
5490 kid->op_private = 0;
5491 kid->op_ppaddr = PL_ppaddr[OP_GV];
5498 Perl_ck_ftst(pTHX_ OP *o)
5500 I32 type = o->op_type;
5502 if (o->op_flags & OPf_REF) {
5505 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5506 SVOP *kid = (SVOP*)cUNOPo->op_first;
5508 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5510 OP *newop = newGVOP(type, OPf_REF,
5511 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5518 if (type == OP_FTTTY)
5519 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5522 o = newUNOP(type, 0, newDEFSVOP());
5525 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5527 if (PL_hints & HINT_LOCALE)
5528 o->op_private |= OPpLOCALE;
5535 Perl_ck_fun(pTHX_ OP *o)
5541 int type = o->op_type;
5542 register I32 oa = PL_opargs[type] >> OASHIFT;
5544 if (o->op_flags & OPf_STACKED) {
5545 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5548 return no_fh_allowed(o);
5551 if (o->op_flags & OPf_KIDS) {
5553 tokid = &cLISTOPo->op_first;
5554 kid = cLISTOPo->op_first;
5555 if (kid->op_type == OP_PUSHMARK ||
5556 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5558 tokid = &kid->op_sibling;
5559 kid = kid->op_sibling;
5561 if (!kid && PL_opargs[type] & OA_DEFGV)
5562 *tokid = kid = newDEFSVOP();
5566 sibl = kid->op_sibling;
5569 /* list seen where single (scalar) arg expected? */
5570 if (numargs == 1 && !(oa >> 4)
5571 && kid->op_type == OP_LIST && type != OP_SCALAR)
5573 return too_many_arguments(o,PL_op_desc[type]);
5586 if (kid->op_type == OP_CONST &&
5587 (kid->op_private & OPpCONST_BARE))
5589 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5590 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5591 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5592 if (ckWARN(WARN_DEPRECATED))
5593 Perl_warner(aTHX_ WARN_DEPRECATED,
5594 "Array @%s missing the @ in argument %"IVdf" of %s()",
5595 name, (IV)numargs, PL_op_desc[type]);
5598 kid->op_sibling = sibl;
5601 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5602 bad_type(numargs, "array", PL_op_desc[type], kid);
5606 if (kid->op_type == OP_CONST &&
5607 (kid->op_private & OPpCONST_BARE))
5609 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5610 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5611 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5612 if (ckWARN(WARN_DEPRECATED))
5613 Perl_warner(aTHX_ WARN_DEPRECATED,
5614 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5615 name, (IV)numargs, PL_op_desc[type]);
5618 kid->op_sibling = sibl;
5621 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5622 bad_type(numargs, "hash", PL_op_desc[type], kid);
5627 OP *newop = newUNOP(OP_NULL, 0, kid);
5628 kid->op_sibling = 0;
5630 newop->op_next = newop;
5632 kid->op_sibling = sibl;
5637 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5638 if (kid->op_type == OP_CONST &&
5639 (kid->op_private & OPpCONST_BARE))
5641 OP *newop = newGVOP(OP_GV, 0,
5642 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5647 else if (kid->op_type == OP_READLINE) {
5648 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5649 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5652 I32 flags = OPf_SPECIAL;
5656 /* is this op a FH constructor? */
5657 if (is_handle_constructor(o,numargs)) {
5658 char *name = Nullch;
5662 /* Set a flag to tell rv2gv to vivify
5663 * need to "prove" flag does not mean something
5664 * else already - NI-S 1999/05/07
5667 if (kid->op_type == OP_PADSV) {
5668 SV **namep = av_fetch(PL_comppad_name,
5670 if (namep && *namep)
5671 name = SvPV(*namep, len);
5673 else if (kid->op_type == OP_RV2SV
5674 && kUNOP->op_first->op_type == OP_GV)
5676 GV *gv = cGVOPx_gv(kUNOP->op_first);
5678 len = GvNAMELEN(gv);
5680 else if (kid->op_type == OP_AELEM
5681 || kid->op_type == OP_HELEM)
5683 name = "__ANONIO__";
5689 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5690 namesv = PL_curpad[targ];
5691 (void)SvUPGRADE(namesv, SVt_PV);
5693 sv_setpvn(namesv, "$", 1);
5694 sv_catpvn(namesv, name, len);
5697 kid->op_sibling = 0;
5698 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5699 kid->op_targ = targ;
5700 kid->op_private |= priv;
5702 kid->op_sibling = sibl;
5708 mod(scalar(kid), type);
5712 tokid = &kid->op_sibling;
5713 kid = kid->op_sibling;
5715 o->op_private |= numargs;
5717 return too_many_arguments(o,PL_op_desc[o->op_type]);
5720 else if (PL_opargs[type] & OA_DEFGV) {
5722 return newUNOP(type, 0, newDEFSVOP());
5726 while (oa & OA_OPTIONAL)
5728 if (oa && oa != OA_LIST)
5729 return too_few_arguments(o,PL_op_desc[o->op_type]);
5735 Perl_ck_glob(pTHX_ OP *o)
5740 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5741 append_elem(OP_GLOB, o, newDEFSVOP());
5743 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5744 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5746 #if !defined(PERL_EXTERNAL_GLOB)
5747 /* XXX this can be tightened up and made more failsafe. */
5750 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5751 /* null-terminated import list */
5752 newSVpvn(":globally", 9), Nullsv);
5753 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5756 #endif /* PERL_EXTERNAL_GLOB */
5758 if (gv && GvIMPORTED_CV(gv)) {
5759 append_elem(OP_GLOB, o,
5760 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5761 o->op_type = OP_LIST;
5762 o->op_ppaddr = PL_ppaddr[OP_LIST];
5763 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5764 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5765 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5766 append_elem(OP_LIST, o,
5767 scalar(newUNOP(OP_RV2CV, 0,
5768 newGVOP(OP_GV, 0, gv)))));
5769 o = newUNOP(OP_NULL, 0, ck_subr(o));
5770 o->op_targ = OP_GLOB; /* hint at what it used to be */
5773 gv = newGVgen("main");
5775 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5781 Perl_ck_grep(pTHX_ OP *o)
5785 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5787 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5788 NewOp(1101, gwop, 1, LOGOP);
5790 if (o->op_flags & OPf_STACKED) {
5793 kid = cLISTOPo->op_first->op_sibling;
5794 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5797 kid->op_next = (OP*)gwop;
5798 o->op_flags &= ~OPf_STACKED;
5800 kid = cLISTOPo->op_first->op_sibling;
5801 if (type == OP_MAPWHILE)
5808 kid = cLISTOPo->op_first->op_sibling;
5809 if (kid->op_type != OP_NULL)
5810 Perl_croak(aTHX_ "panic: ck_grep");
5811 kid = kUNOP->op_first;
5813 gwop->op_type = type;
5814 gwop->op_ppaddr = PL_ppaddr[type];
5815 gwop->op_first = listkids(o);
5816 gwop->op_flags |= OPf_KIDS;
5817 gwop->op_private = 1;
5818 gwop->op_other = LINKLIST(kid);
5819 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5820 kid->op_next = (OP*)gwop;
5822 kid = cLISTOPo->op_first->op_sibling;
5823 if (!kid || !kid->op_sibling)
5824 return too_few_arguments(o,PL_op_desc[o->op_type]);
5825 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5826 mod(kid, OP_GREPSTART);
5832 Perl_ck_index(pTHX_ OP *o)
5834 if (o->op_flags & OPf_KIDS) {
5835 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5837 kid = kid->op_sibling; /* get past "big" */
5838 if (kid && kid->op_type == OP_CONST)
5839 fbm_compile(((SVOP*)kid)->op_sv, 0);
5845 Perl_ck_lengthconst(pTHX_ OP *o)
5847 /* XXX length optimization goes here */
5852 Perl_ck_lfun(pTHX_ OP *o)
5854 OPCODE type = o->op_type;
5855 return modkids(ck_fun(o), type);
5859 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5861 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5862 switch (cUNOPo->op_first->op_type) {
5864 /* This is needed for
5865 if (defined %stash::)
5866 to work. Do not break Tk.
5868 break; /* Globals via GV can be undef */
5870 case OP_AASSIGN: /* Is this a good idea? */
5871 Perl_warner(aTHX_ WARN_DEPRECATED,
5872 "defined(@array) is deprecated");
5873 Perl_warner(aTHX_ WARN_DEPRECATED,
5874 "\t(Maybe you should just omit the defined()?)\n");
5877 /* This is needed for
5878 if (defined %stash::)
5879 to work. Do not break Tk.
5881 break; /* Globals via GV can be undef */
5883 Perl_warner(aTHX_ WARN_DEPRECATED,
5884 "defined(%%hash) is deprecated");
5885 Perl_warner(aTHX_ WARN_DEPRECATED,
5886 "\t(Maybe you should just omit the defined()?)\n");
5897 Perl_ck_rfun(pTHX_ OP *o)
5899 OPCODE type = o->op_type;
5900 return refkids(ck_fun(o), type);
5904 Perl_ck_listiob(pTHX_ OP *o)
5908 kid = cLISTOPo->op_first;
5911 kid = cLISTOPo->op_first;
5913 if (kid->op_type == OP_PUSHMARK)
5914 kid = kid->op_sibling;
5915 if (kid && o->op_flags & OPf_STACKED)
5916 kid = kid->op_sibling;
5917 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5918 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5919 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5920 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5921 cLISTOPo->op_first->op_sibling = kid;
5922 cLISTOPo->op_last = kid;
5923 kid = kid->op_sibling;
5928 append_elem(o->op_type, o, newDEFSVOP());
5934 if (PL_hints & HINT_LOCALE)
5935 o->op_private |= OPpLOCALE;
5942 Perl_ck_fun_locale(pTHX_ OP *o)
5948 if (PL_hints & HINT_LOCALE)
5949 o->op_private |= OPpLOCALE;
5956 Perl_ck_sassign(pTHX_ OP *o)
5958 OP *kid = cLISTOPo->op_first;
5959 /* has a disposable target? */
5960 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5961 && !(kid->op_flags & OPf_STACKED)
5962 /* Cannot steal the second time! */
5963 && !(kid->op_private & OPpTARGET_MY))
5965 OP *kkid = kid->op_sibling;
5967 /* Can just relocate the target. */
5968 if (kkid && kkid->op_type == OP_PADSV
5969 && !(kkid->op_private & OPpLVAL_INTRO))
5971 kid->op_targ = kkid->op_targ;
5973 /* Now we do not need PADSV and SASSIGN. */
5974 kid->op_sibling = o->op_sibling; /* NULL */
5975 cLISTOPo->op_first = NULL;
5978 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5986 Perl_ck_scmp(pTHX_ OP *o)
5990 if (PL_hints & HINT_LOCALE)
5991 o->op_private |= OPpLOCALE;
5998 Perl_ck_match(pTHX_ OP *o)
6000 o->op_private |= OPpRUNTIME;
6005 Perl_ck_method(pTHX_ OP *o)
6007 OP *kid = cUNOPo->op_first;
6008 if (kid->op_type == OP_CONST) {
6009 SV* sv = kSVOP->op_sv;
6010 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6012 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6013 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6016 kSVOP->op_sv = Nullsv;
6018 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6027 Perl_ck_null(pTHX_ OP *o)
6033 Perl_ck_open(pTHX_ OP *o)
6035 HV *table = GvHV(PL_hintgv);
6039 svp = hv_fetch(table, "open_IN", 7, FALSE);
6041 mode = mode_from_discipline(*svp);
6042 if (mode & O_BINARY)
6043 o->op_private |= OPpOPEN_IN_RAW;
6044 else if (mode & O_TEXT)
6045 o->op_private |= OPpOPEN_IN_CRLF;
6048 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6050 mode = mode_from_discipline(*svp);
6051 if (mode & O_BINARY)
6052 o->op_private |= OPpOPEN_OUT_RAW;
6053 else if (mode & O_TEXT)
6054 o->op_private |= OPpOPEN_OUT_CRLF;
6057 if (o->op_type == OP_BACKTICK)
6063 Perl_ck_repeat(pTHX_ OP *o)
6065 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6066 o->op_private |= OPpREPEAT_DOLIST;
6067 cBINOPo->op_first = force_list(cBINOPo->op_first);
6075 Perl_ck_require(pTHX_ OP *o)
6077 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6078 SVOP *kid = (SVOP*)cUNOPo->op_first;
6080 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6082 for (s = SvPVX(kid->op_sv); *s; s++) {
6083 if (*s == ':' && s[1] == ':') {
6085 Move(s+2, s+1, strlen(s+2)+1, char);
6086 --SvCUR(kid->op_sv);
6089 if (SvREADONLY(kid->op_sv)) {
6090 SvREADONLY_off(kid->op_sv);
6091 sv_catpvn(kid->op_sv, ".pm", 3);
6092 SvREADONLY_on(kid->op_sv);
6095 sv_catpvn(kid->op_sv, ".pm", 3);
6102 Perl_ck_return(pTHX_ OP *o)
6105 if (CvLVALUE(PL_compcv)) {
6106 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6107 mod(kid, OP_LEAVESUBLV);
6114 Perl_ck_retarget(pTHX_ OP *o)
6116 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6123 Perl_ck_select(pTHX_ OP *o)
6126 if (o->op_flags & OPf_KIDS) {
6127 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6128 if (kid && kid->op_sibling) {
6129 o->op_type = OP_SSELECT;
6130 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6132 return fold_constants(o);
6136 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6137 if (kid && kid->op_type == OP_RV2GV)
6138 kid->op_private &= ~HINT_STRICT_REFS;
6143 Perl_ck_shift(pTHX_ OP *o)
6145 I32 type = o->op_type;
6147 if (!(o->op_flags & OPf_KIDS)) {
6152 if (!CvUNIQUE(PL_compcv)) {
6153 argop = newOP(OP_PADAV, OPf_REF);
6154 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6157 argop = newUNOP(OP_RV2AV, 0,
6158 scalar(newGVOP(OP_GV, 0,
6159 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6162 argop = newUNOP(OP_RV2AV, 0,
6163 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6164 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6165 #endif /* USE_THREADS */
6166 return newUNOP(type, 0, scalar(argop));
6168 return scalar(modkids(ck_fun(o), type));
6172 Perl_ck_sort(pTHX_ OP *o)
6177 if (PL_hints & HINT_LOCALE)
6178 o->op_private |= OPpLOCALE;
6181 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6183 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6184 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6186 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6188 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6190 if (kid->op_type == OP_SCOPE) {
6194 else if (kid->op_type == OP_LEAVE) {
6195 if (o->op_type == OP_SORT) {
6196 null(kid); /* wipe out leave */
6199 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6200 if (k->op_next == kid)
6202 /* don't descend into loops */
6203 else if (k->op_type == OP_ENTERLOOP
6204 || k->op_type == OP_ENTERITER)
6206 k = cLOOPx(k)->op_lastop;
6211 kid->op_next = 0; /* just disconnect the leave */
6212 k = kLISTOP->op_first;
6217 if (o->op_type == OP_SORT) {
6218 /* provide scalar context for comparison function/block */
6224 o->op_flags |= OPf_SPECIAL;
6226 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6229 firstkid = firstkid->op_sibling;
6232 /* provide list context for arguments */
6233 if (o->op_type == OP_SORT)
6240 S_simplify_sort(pTHX_ OP *o)
6242 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6246 if (!(o->op_flags & OPf_STACKED))
6248 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6249 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6250 kid = kUNOP->op_first; /* get past null */
6251 if (kid->op_type != OP_SCOPE)
6253 kid = kLISTOP->op_last; /* get past scope */
6254 switch(kid->op_type) {
6262 k = kid; /* remember this node*/
6263 if (kBINOP->op_first->op_type != OP_RV2SV)
6265 kid = kBINOP->op_first; /* get past cmp */
6266 if (kUNOP->op_first->op_type != OP_GV)
6268 kid = kUNOP->op_first; /* get past rv2sv */
6270 if (GvSTASH(gv) != PL_curstash)
6272 if (strEQ(GvNAME(gv), "a"))
6274 else if (strEQ(GvNAME(gv), "b"))
6278 kid = k; /* back to cmp */
6279 if (kBINOP->op_last->op_type != OP_RV2SV)
6281 kid = kBINOP->op_last; /* down to 2nd arg */
6282 if (kUNOP->op_first->op_type != OP_GV)
6284 kid = kUNOP->op_first; /* get past rv2sv */
6286 if (GvSTASH(gv) != PL_curstash
6288 ? strNE(GvNAME(gv), "a")
6289 : strNE(GvNAME(gv), "b")))
6291 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6293 o->op_private |= OPpSORT_REVERSE;
6294 if (k->op_type == OP_NCMP)
6295 o->op_private |= OPpSORT_NUMERIC;
6296 if (k->op_type == OP_I_NCMP)
6297 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6298 kid = cLISTOPo->op_first->op_sibling;
6299 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6300 op_free(kid); /* then delete it */
6304 Perl_ck_split(pTHX_ OP *o)
6308 if (o->op_flags & OPf_STACKED)
6309 return no_fh_allowed(o);
6311 kid = cLISTOPo->op_first;
6312 if (kid->op_type != OP_NULL)
6313 Perl_croak(aTHX_ "panic: ck_split");
6314 kid = kid->op_sibling;
6315 op_free(cLISTOPo->op_first);
6316 cLISTOPo->op_first = kid;
6318 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6319 cLISTOPo->op_last = kid; /* There was only one element previously */
6322 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6323 OP *sibl = kid->op_sibling;
6324 kid->op_sibling = 0;
6325 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6326 if (cLISTOPo->op_first == cLISTOPo->op_last)
6327 cLISTOPo->op_last = kid;
6328 cLISTOPo->op_first = kid;
6329 kid->op_sibling = sibl;
6332 kid->op_type = OP_PUSHRE;
6333 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6336 if (!kid->op_sibling)
6337 append_elem(OP_SPLIT, o, newDEFSVOP());
6339 kid = kid->op_sibling;
6342 if (!kid->op_sibling)
6343 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6345 kid = kid->op_sibling;
6348 if (kid->op_sibling)
6349 return too_many_arguments(o,PL_op_desc[o->op_type]);
6355 Perl_ck_join(pTHX_ OP *o)
6357 if (ckWARN(WARN_SYNTAX)) {
6358 OP *kid = cLISTOPo->op_first->op_sibling;
6359 if (kid && kid->op_type == OP_MATCH) {
6360 char *pmstr = "STRING";
6361 if (kPMOP->op_pmregexp)
6362 pmstr = kPMOP->op_pmregexp->precomp;
6363 Perl_warner(aTHX_ WARN_SYNTAX,
6364 "/%s/ should probably be written as \"%s\"",
6372 Perl_ck_subr(pTHX_ OP *o)
6374 OP *prev = ((cUNOPo->op_first->op_sibling)
6375 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6376 OP *o2 = prev->op_sibling;
6385 o->op_private |= OPpENTERSUB_HASTARG;
6386 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6387 if (cvop->op_type == OP_RV2CV) {
6389 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6390 null(cvop); /* disable rv2cv */
6391 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6392 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6393 GV *gv = cGVOPx_gv(tmpop);
6396 tmpop->op_private |= OPpEARLY_CV;
6397 else if (SvPOK(cv)) {
6398 namegv = CvANON(cv) ? gv : CvGV(cv);
6399 proto = SvPV((SV*)cv, n_a);
6403 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6404 if (o2->op_type == OP_CONST)
6405 o2->op_private &= ~OPpCONST_STRICT;
6406 else if (o2->op_type == OP_LIST) {
6407 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6408 if (o && o->op_type == OP_CONST)
6409 o->op_private &= ~OPpCONST_STRICT;
6412 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6413 if (PERLDB_SUB && PL_curstash != PL_debstash)
6414 o->op_private |= OPpENTERSUB_DB;
6415 while (o2 != cvop) {
6419 return too_many_arguments(o, gv_ename(namegv));
6437 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6439 arg == 1 ? "block or sub {}" : "sub {}",
6440 gv_ename(namegv), o2);
6443 /* '*' allows any scalar type, including bareword */
6446 if (o2->op_type == OP_RV2GV)
6447 goto wrapref; /* autoconvert GLOB -> GLOBref */
6448 else if (o2->op_type == OP_CONST)
6449 o2->op_private &= ~OPpCONST_STRICT;
6450 else if (o2->op_type == OP_ENTERSUB) {
6451 /* accidental subroutine, revert to bareword */
6452 OP *gvop = ((UNOP*)o2)->op_first;
6453 if (gvop && gvop->op_type == OP_NULL) {
6454 gvop = ((UNOP*)gvop)->op_first;
6456 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6459 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6460 (gvop = ((UNOP*)gvop)->op_first) &&
6461 gvop->op_type == OP_GV)
6463 GV *gv = cGVOPx_gv(gvop);
6464 OP *sibling = o2->op_sibling;
6465 SV *n = newSVpvn("",0);
6467 gv_fullname3(n, gv, "");
6468 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6469 sv_chop(n, SvPVX(n)+6);
6470 o2 = newSVOP(OP_CONST, 0, n);
6471 prev->op_sibling = o2;
6472 o2->op_sibling = sibling;
6484 if (o2->op_type != OP_RV2GV)
6485 bad_type(arg, "symbol", gv_ename(namegv), o2);
6488 if (o2->op_type != OP_ENTERSUB)
6489 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6492 if (o2->op_type != OP_RV2SV
6493 && o2->op_type != OP_PADSV
6494 && o2->op_type != OP_HELEM
6495 && o2->op_type != OP_AELEM
6496 && o2->op_type != OP_THREADSV)
6498 bad_type(arg, "scalar", gv_ename(namegv), o2);
6502 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6503 bad_type(arg, "array", gv_ename(namegv), o2);
6506 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6507 bad_type(arg, "hash", gv_ename(namegv), o2);
6511 OP* sib = kid->op_sibling;
6512 kid->op_sibling = 0;
6513 o2 = newUNOP(OP_REFGEN, 0, kid);
6514 o2->op_sibling = sib;
6515 prev->op_sibling = o2;
6526 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6527 gv_ename(namegv), SvPV((SV*)cv, n_a));
6532 mod(o2, OP_ENTERSUB);
6534 o2 = o2->op_sibling;
6536 if (proto && !optional &&
6537 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6538 return too_few_arguments(o, gv_ename(namegv));
6543 Perl_ck_svconst(pTHX_ OP *o)
6545 SvREADONLY_on(cSVOPo->op_sv);
6550 Perl_ck_trunc(pTHX_ OP *o)
6552 if (o->op_flags & OPf_KIDS) {
6553 SVOP *kid = (SVOP*)cUNOPo->op_first;
6555 if (kid->op_type == OP_NULL)
6556 kid = (SVOP*)kid->op_sibling;
6557 if (kid && kid->op_type == OP_CONST &&
6558 (kid->op_private & OPpCONST_BARE))
6560 o->op_flags |= OPf_SPECIAL;
6561 kid->op_private &= ~OPpCONST_STRICT;
6568 Perl_ck_substr(pTHX_ OP *o)
6571 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6572 OP *kid = cLISTOPo->op_first;
6574 if (kid->op_type == OP_NULL)
6575 kid = kid->op_sibling;
6577 kid->op_flags |= OPf_MOD;
6583 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6586 Perl_peep(pTHX_ register OP *o)
6588 register OP* oldop = 0;
6591 if (!o || o->op_seq)
6595 SAVEVPTR(PL_curcop);
6596 for (; o; o = o->op_next) {
6602 switch (o->op_type) {
6606 PL_curcop = ((COP*)o); /* for warnings */
6607 o->op_seq = PL_op_seqmax++;
6611 if (cSVOPo->op_private & OPpCONST_STRICT)
6612 no_bareword_allowed(o);
6614 /* Relocate sv to the pad for thread safety.
6615 * Despite being a "constant", the SV is written to,
6616 * for reference counts, sv_upgrade() etc. */
6618 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6619 if (SvPADTMP(cSVOPo->op_sv)) {
6620 /* If op_sv is already a PADTMP then it is being used by
6621 * some pad, so make a copy. */
6622 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6623 SvREADONLY_on(PL_curpad[ix]);
6624 SvREFCNT_dec(cSVOPo->op_sv);
6627 SvREFCNT_dec(PL_curpad[ix]);
6628 SvPADTMP_on(cSVOPo->op_sv);
6629 PL_curpad[ix] = cSVOPo->op_sv;
6630 /* XXX I don't know how this isn't readonly already. */
6631 SvREADONLY_on(PL_curpad[ix]);
6633 cSVOPo->op_sv = Nullsv;
6637 o->op_seq = PL_op_seqmax++;
6641 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6642 if (o->op_next->op_private & OPpTARGET_MY) {
6643 if (o->op_flags & OPf_STACKED) /* chained concats */
6644 goto ignore_optimization;
6646 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6647 o->op_targ = o->op_next->op_targ;
6648 o->op_next->op_targ = 0;
6649 o->op_private |= OPpTARGET_MY;
6654 ignore_optimization:
6655 o->op_seq = PL_op_seqmax++;
6658 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6659 o->op_seq = PL_op_seqmax++;
6660 break; /* Scalar stub must produce undef. List stub is noop */
6664 if (o->op_targ == OP_NEXTSTATE
6665 || o->op_targ == OP_DBSTATE
6666 || o->op_targ == OP_SETSTATE)
6668 PL_curcop = ((COP*)o);
6675 if (oldop && o->op_next) {
6676 oldop->op_next = o->op_next;
6679 o->op_seq = PL_op_seqmax++;
6683 if (o->op_next->op_type == OP_RV2SV) {
6684 if (!(o->op_next->op_private & OPpDEREF)) {
6686 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6688 o->op_next = o->op_next->op_next;
6689 o->op_type = OP_GVSV;
6690 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6693 else if (o->op_next->op_type == OP_RV2AV) {
6694 OP* pop = o->op_next->op_next;
6696 if (pop->op_type == OP_CONST &&
6697 (PL_op = pop->op_next) &&
6698 pop->op_next->op_type == OP_AELEM &&
6699 !(pop->op_next->op_private &
6700 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6701 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6709 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6710 o->op_next = pop->op_next->op_next;
6711 o->op_type = OP_AELEMFAST;
6712 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6713 o->op_private = (U8)i;
6718 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6720 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6721 /* XXX could check prototype here instead of just carping */
6722 SV *sv = sv_newmortal();
6723 gv_efullname3(sv, gv, Nullch);
6724 Perl_warner(aTHX_ WARN_PROTOTYPE,
6725 "%s() called too early to check prototype",
6730 o->op_seq = PL_op_seqmax++;
6741 o->op_seq = PL_op_seqmax++;
6742 while (cLOGOP->op_other->op_type == OP_NULL)
6743 cLOGOP->op_other = cLOGOP->op_other->op_next;
6744 peep(cLOGOP->op_other);
6748 o->op_seq = PL_op_seqmax++;
6749 while (cLOOP->op_redoop->op_type == OP_NULL)
6750 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6751 peep(cLOOP->op_redoop);
6752 while (cLOOP->op_nextop->op_type == OP_NULL)
6753 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6754 peep(cLOOP->op_nextop);
6755 while (cLOOP->op_lastop->op_type == OP_NULL)
6756 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6757 peep(cLOOP->op_lastop);
6763 o->op_seq = PL_op_seqmax++;
6764 while (cPMOP->op_pmreplstart &&
6765 cPMOP->op_pmreplstart->op_type == OP_NULL)
6766 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6767 peep(cPMOP->op_pmreplstart);
6771 o->op_seq = PL_op_seqmax++;
6772 if (ckWARN(WARN_SYNTAX) && o->op_next
6773 && o->op_next->op_type == OP_NEXTSTATE) {
6774 if (o->op_next->op_sibling &&
6775 o->op_next->op_sibling->op_type != OP_EXIT &&
6776 o->op_next->op_sibling->op_type != OP_WARN &&
6777 o->op_next->op_sibling->op_type != OP_DIE) {
6778 line_t oldline = CopLINE(PL_curcop);
6780 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6781 Perl_warner(aTHX_ WARN_EXEC,
6782 "Statement unlikely to be reached");
6783 Perl_warner(aTHX_ WARN_EXEC,
6784 "\t(Maybe you meant system() when you said exec()?)\n");
6785 CopLINE_set(PL_curcop, oldline);
6794 SV **svp, **indsvp, *sv;
6799 o->op_seq = PL_op_seqmax++;
6801 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6804 /* Make the CONST have a shared SV */
6805 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6806 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6807 key = SvPV(sv, keylen);
6810 lexname = newSVpvn_share(key, keylen, 0);
6815 if ((o->op_private & (OPpLVAL_INTRO)))
6818 rop = (UNOP*)((BINOP*)o)->op_first;
6819 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6821 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6822 if (!SvOBJECT(lexname))
6824 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6825 if (!fields || !GvHV(*fields))
6827 key = SvPV(*svp, keylen);
6830 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6832 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6833 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6835 ind = SvIV(*indsvp);
6837 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6838 rop->op_type = OP_RV2AV;
6839 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6840 o->op_type = OP_AELEM;
6841 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6843 if (SvREADONLY(*svp))
6845 SvFLAGS(sv) |= (SvFLAGS(*svp)
6846 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6856 SV **svp, **indsvp, *sv;
6860 SVOP *first_key_op, *key_op;
6862 o->op_seq = PL_op_seqmax++;
6863 if ((o->op_private & (OPpLVAL_INTRO))
6864 /* I bet there's always a pushmark... */
6865 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6866 /* hmmm, no optimization if list contains only one key. */
6868 rop = (UNOP*)((LISTOP*)o)->op_last;
6869 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6871 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6872 if (!SvOBJECT(lexname))
6874 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6875 if (!fields || !GvHV(*fields))
6877 /* Again guessing that the pushmark can be jumped over.... */
6878 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6879 ->op_first->op_sibling;
6880 /* Check that the key list contains only constants. */
6881 for (key_op = first_key_op; key_op;
6882 key_op = (SVOP*)key_op->op_sibling)
6883 if (key_op->op_type != OP_CONST)
6887 rop->op_type = OP_RV2AV;
6888 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6889 o->op_type = OP_ASLICE;
6890 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6891 for (key_op = first_key_op; key_op;
6892 key_op = (SVOP*)key_op->op_sibling) {
6893 svp = cSVOPx_svp(key_op);
6894 key = SvPV(*svp, keylen);
6897 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6899 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6900 "in variable %s of type %s",
6901 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6903 ind = SvIV(*indsvp);
6905 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6907 if (SvREADONLY(*svp))
6909 SvFLAGS(sv) |= (SvFLAGS(*svp)
6910 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6918 o->op_seq = PL_op_seqmax++;
6928 /* Efficient sub that returns a constant scalar value. */
6930 const_sv_xsub(pTHXo_ CV* cv)
6934 ST(0) = (SV*)XSANY.any_ptr;