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;
1572 PL_modcount = RETURN_UNLIMITED_NUMBER;
1575 if (!type && cUNOPo->op_first->op_type != OP_GV)
1576 Perl_croak(aTHX_ "Can't localize through a reference");
1577 ref(cUNOPo->op_first, o->op_type);
1581 PL_hints |= HINT_BLOCK_SCOPE;
1591 PL_modcount = RETURN_UNLIMITED_NUMBER;
1592 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1593 return o; /* Treat \(@foo) like ordinary list. */
1594 if (scalar_mod_type(o, type))
1596 if (type == OP_LEAVESUBLV)
1597 o->op_private |= OPpMAYBE_LVSUB;
1602 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1603 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1608 PL_modcount++; /* XXX ??? */
1610 #endif /* USE_THREADS */
1616 if (type != OP_SASSIGN)
1620 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1628 pad_free(o->op_targ);
1629 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1630 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1631 if (o->op_flags & OPf_KIDS)
1632 mod(cBINOPo->op_first->op_sibling, type);
1637 ref(cBINOPo->op_first, o->op_type);
1638 if (type == OP_ENTERSUB &&
1639 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1640 o->op_private |= OPpLVAL_DEFER;
1641 if (type == OP_LEAVESUBLV)
1642 o->op_private |= OPpMAYBE_LVSUB;
1650 if (o->op_flags & OPf_KIDS)
1651 mod(cLISTOPo->op_last, type);
1655 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1657 else if (!(o->op_flags & OPf_KIDS))
1659 if (o->op_targ != OP_LIST) {
1660 mod(cBINOPo->op_first, type);
1665 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1670 if (type != OP_LEAVESUBLV)
1672 break; /* mod()ing was handled by ck_return() */
1674 if (type != OP_LEAVESUBLV)
1675 o->op_flags |= OPf_MOD;
1677 if (type == OP_AASSIGN || type == OP_SASSIGN)
1678 o->op_flags |= OPf_SPECIAL|OPf_REF;
1680 o->op_private |= OPpLVAL_INTRO;
1681 o->op_flags &= ~OPf_SPECIAL;
1682 PL_hints |= HINT_BLOCK_SCOPE;
1684 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1685 && type != OP_LEAVESUBLV)
1686 o->op_flags |= OPf_REF;
1691 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1695 if (o->op_type == OP_RV2GV)
1719 case OP_RIGHT_SHIFT:
1738 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1740 switch (o->op_type) {
1748 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1761 Perl_refkids(pTHX_ OP *o, I32 type)
1764 if (o && o->op_flags & OPf_KIDS) {
1765 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1772 Perl_ref(pTHX_ OP *o, I32 type)
1776 if (!o || PL_error_count)
1779 switch (o->op_type) {
1781 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1782 !(o->op_flags & OPf_STACKED)) {
1783 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1784 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1785 assert(cUNOPo->op_first->op_type == OP_NULL);
1786 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1787 o->op_flags |= OPf_SPECIAL;
1792 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1796 if (type == OP_DEFINED)
1797 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1798 ref(cUNOPo->op_first, o->op_type);
1801 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1802 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1803 : type == OP_RV2HV ? OPpDEREF_HV
1805 o->op_flags |= OPf_MOD;
1810 o->op_flags |= OPf_MOD; /* XXX ??? */
1815 o->op_flags |= OPf_REF;
1818 if (type == OP_DEFINED)
1819 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1820 ref(cUNOPo->op_first, o->op_type);
1825 o->op_flags |= OPf_REF;
1830 if (!(o->op_flags & OPf_KIDS))
1832 ref(cBINOPo->op_first, type);
1836 ref(cBINOPo->op_first, o->op_type);
1837 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1838 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1839 : type == OP_RV2HV ? OPpDEREF_HV
1841 o->op_flags |= OPf_MOD;
1849 if (!(o->op_flags & OPf_KIDS))
1851 ref(cLISTOPo->op_last, type);
1861 S_dup_attrlist(pTHX_ OP *o)
1865 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1866 * where the first kid is OP_PUSHMARK and the remaining ones
1867 * are OP_CONST. We need to push the OP_CONST values.
1869 if (o->op_type == OP_CONST)
1870 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1872 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1873 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1874 if (o->op_type == OP_CONST)
1875 rop = append_elem(OP_LIST, rop,
1876 newSVOP(OP_CONST, o->op_flags,
1877 SvREFCNT_inc(cSVOPo->op_sv)));
1884 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1888 /* fake up C<use attributes $pkg,$rv,@attrs> */
1889 ENTER; /* need to protect against side-effects of 'use' */
1891 if (stash && HvNAME(stash))
1892 stashsv = newSVpv(HvNAME(stash), 0);
1894 stashsv = &PL_sv_no;
1896 #define ATTRSMODULE "attributes"
1898 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1899 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1901 prepend_elem(OP_LIST,
1902 newSVOP(OP_CONST, 0, stashsv),
1903 prepend_elem(OP_LIST,
1904 newSVOP(OP_CONST, 0,
1906 dup_attrlist(attrs))));
1911 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1912 char *attrstr, STRLEN len)
1917 len = strlen(attrstr);
1921 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1923 char *sstr = attrstr;
1924 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1925 attrs = append_elem(OP_LIST, attrs,
1926 newSVOP(OP_CONST, 0,
1927 newSVpvn(sstr, attrstr-sstr)));
1931 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1932 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1933 Nullsv, prepend_elem(OP_LIST,
1934 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1935 prepend_elem(OP_LIST,
1936 newSVOP(OP_CONST, 0,
1942 S_my_kid(pTHX_ OP *o, OP *attrs)
1947 if (!o || PL_error_count)
1951 if (type == OP_LIST) {
1952 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1954 } else if (type == OP_UNDEF) {
1956 } else if (type == OP_RV2SV || /* "our" declaration */
1958 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1960 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1962 PL_in_my_stash = Nullhv;
1963 apply_attrs(GvSTASH(gv),
1964 (type == OP_RV2SV ? GvSV(gv) :
1965 type == OP_RV2AV ? (SV*)GvAV(gv) :
1966 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1969 o->op_private |= OPpOUR_INTRO;
1971 } else if (type != OP_PADSV &&
1974 type != OP_PUSHMARK)
1976 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1977 PL_op_desc[o->op_type],
1978 PL_in_my == KEY_our ? "our" : "my"));
1981 else if (attrs && type != OP_PUSHMARK) {
1987 PL_in_my_stash = Nullhv;
1989 /* check for C<my Dog $spot> when deciding package */
1990 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1991 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1992 stash = SvSTASH(*namesvp);
1994 stash = PL_curstash;
1995 padsv = PAD_SV(o->op_targ);
1996 apply_attrs(stash, padsv, attrs);
1998 o->op_flags |= OPf_MOD;
1999 o->op_private |= OPpLVAL_INTRO;
2004 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2006 if (o->op_flags & OPf_PARENS)
2010 o = my_kid(o, attrs);
2012 PL_in_my_stash = Nullhv;
2017 Perl_my(pTHX_ OP *o)
2019 return my_kid(o, Nullop);
2023 Perl_sawparens(pTHX_ OP *o)
2026 o->op_flags |= OPf_PARENS;
2031 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2035 if (ckWARN(WARN_MISC) &&
2036 (left->op_type == OP_RV2AV ||
2037 left->op_type == OP_RV2HV ||
2038 left->op_type == OP_PADAV ||
2039 left->op_type == OP_PADHV)) {
2040 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2041 right->op_type == OP_TRANS)
2042 ? right->op_type : OP_MATCH];
2043 const char *sample = ((left->op_type == OP_RV2AV ||
2044 left->op_type == OP_PADAV)
2045 ? "@array" : "%hash");
2046 Perl_warner(aTHX_ WARN_MISC,
2047 "Applying %s to %s will act on scalar(%s)",
2048 desc, sample, sample);
2051 if (!(right->op_flags & OPf_STACKED) &&
2052 (right->op_type == OP_MATCH ||
2053 right->op_type == OP_SUBST ||
2054 right->op_type == OP_TRANS)) {
2055 right->op_flags |= OPf_STACKED;
2056 if (right->op_type != OP_MATCH &&
2057 ! (right->op_type == OP_TRANS &&
2058 right->op_private & OPpTRANS_IDENTICAL))
2059 left = mod(left, right->op_type);
2060 if (right->op_type == OP_TRANS)
2061 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2063 o = prepend_elem(right->op_type, scalar(left), right);
2065 return newUNOP(OP_NOT, 0, scalar(o));
2069 return bind_match(type, left,
2070 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2074 Perl_invert(pTHX_ OP *o)
2078 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2079 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2083 Perl_scope(pTHX_ OP *o)
2086 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2087 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2088 o->op_type = OP_LEAVE;
2089 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2092 if (o->op_type == OP_LINESEQ) {
2094 o->op_type = OP_SCOPE;
2095 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2096 kid = ((LISTOP*)o)->op_first;
2097 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2101 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2108 Perl_save_hints(pTHX)
2111 SAVESPTR(GvHV(PL_hintgv));
2112 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2113 SAVEFREESV(GvHV(PL_hintgv));
2117 Perl_block_start(pTHX_ int full)
2119 int retval = PL_savestack_ix;
2121 SAVEI32(PL_comppad_name_floor);
2122 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2124 PL_comppad_name_fill = PL_comppad_name_floor;
2125 if (PL_comppad_name_floor < 0)
2126 PL_comppad_name_floor = 0;
2127 SAVEI32(PL_min_intro_pending);
2128 SAVEI32(PL_max_intro_pending);
2129 PL_min_intro_pending = 0;
2130 SAVEI32(PL_comppad_name_fill);
2131 SAVEI32(PL_padix_floor);
2132 PL_padix_floor = PL_padix;
2133 PL_pad_reset_pending = FALSE;
2135 PL_hints &= ~HINT_BLOCK_SCOPE;
2136 SAVESPTR(PL_compiling.cop_warnings);
2137 if (! specialWARN(PL_compiling.cop_warnings)) {
2138 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2139 SAVEFREESV(PL_compiling.cop_warnings) ;
2141 SAVESPTR(PL_compiling.cop_io);
2142 if (! specialCopIO(PL_compiling.cop_io)) {
2143 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2144 SAVEFREESV(PL_compiling.cop_io) ;
2150 Perl_block_end(pTHX_ I32 floor, OP *seq)
2152 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2153 OP* retval = scalarseq(seq);
2155 PL_pad_reset_pending = FALSE;
2156 PL_compiling.op_private = PL_hints;
2158 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2159 pad_leavemy(PL_comppad_name_fill);
2168 OP *o = newOP(OP_THREADSV, 0);
2169 o->op_targ = find_threadsv("_");
2172 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2173 #endif /* USE_THREADS */
2177 Perl_newPROG(pTHX_ OP *o)
2182 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2183 ((PL_in_eval & EVAL_KEEPERR)
2184 ? OPf_SPECIAL : 0), o);
2185 PL_eval_start = linklist(PL_eval_root);
2186 PL_eval_root->op_private |= OPpREFCOUNTED;
2187 OpREFCNT_set(PL_eval_root, 1);
2188 PL_eval_root->op_next = 0;
2189 peep(PL_eval_start);
2194 PL_main_root = scope(sawparens(scalarvoid(o)));
2195 PL_curcop = &PL_compiling;
2196 PL_main_start = LINKLIST(PL_main_root);
2197 PL_main_root->op_private |= OPpREFCOUNTED;
2198 OpREFCNT_set(PL_main_root, 1);
2199 PL_main_root->op_next = 0;
2200 peep(PL_main_start);
2203 /* Register with debugger */
2205 CV *cv = get_cv("DB::postponed", FALSE);
2209 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2211 call_sv((SV*)cv, G_DISCARD);
2218 Perl_localize(pTHX_ OP *o, I32 lex)
2220 if (o->op_flags & OPf_PARENS)
2223 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2225 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2226 if (*s == ';' || *s == '=')
2227 Perl_warner(aTHX_ WARN_PARENTHESIS,
2228 "Parentheses missing around \"%s\" list",
2229 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2235 o = mod(o, OP_NULL); /* a bit kludgey */
2237 PL_in_my_stash = Nullhv;
2242 Perl_jmaybe(pTHX_ OP *o)
2244 if (o->op_type == OP_LIST) {
2247 o2 = newOP(OP_THREADSV, 0);
2248 o2->op_targ = find_threadsv(";");
2250 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2251 #endif /* USE_THREADS */
2252 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2258 Perl_fold_constants(pTHX_ register OP *o)
2261 I32 type = o->op_type;
2264 if (PL_opargs[type] & OA_RETSCALAR)
2266 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2267 o->op_targ = pad_alloc(type, SVs_PADTMP);
2269 /* integerize op, unless it happens to be C<-foo>.
2270 * XXX should pp_i_negate() do magic string negation instead? */
2271 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2272 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2273 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2275 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2278 if (!(PL_opargs[type] & OA_FOLDCONST))
2283 /* XXX might want a ck_negate() for this */
2284 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2297 if (o->op_private & OPpLOCALE)
2302 goto nope; /* Don't try to run w/ errors */
2304 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2305 if ((curop->op_type != OP_CONST ||
2306 (curop->op_private & OPpCONST_BARE)) &&
2307 curop->op_type != OP_LIST &&
2308 curop->op_type != OP_SCALAR &&
2309 curop->op_type != OP_NULL &&
2310 curop->op_type != OP_PUSHMARK)
2316 curop = LINKLIST(o);
2320 sv = *(PL_stack_sp--);
2321 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2322 pad_swipe(o->op_targ);
2323 else if (SvTEMP(sv)) { /* grab mortal temp? */
2324 (void)SvREFCNT_inc(sv);
2328 if (type == OP_RV2GV)
2329 return newGVOP(OP_GV, 0, (GV*)sv);
2331 /* try to smush double to int, but don't smush -2.0 to -2 */
2332 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2335 #ifdef PERL_PRESERVE_IVUV
2336 /* Only bother to attempt to fold to IV if
2337 most operators will benefit */
2341 return newSVOP(OP_CONST, 0, sv);
2345 if (!(PL_opargs[type] & OA_OTHERINT))
2348 if (!(PL_hints & HINT_INTEGER)) {
2349 if (type == OP_MODULO
2350 || type == OP_DIVIDE
2351 || !(o->op_flags & OPf_KIDS))
2356 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2357 if (curop->op_type == OP_CONST) {
2358 if (SvIOK(((SVOP*)curop)->op_sv))
2362 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2366 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2373 Perl_gen_constant_list(pTHX_ register OP *o)
2376 I32 oldtmps_floor = PL_tmps_floor;
2380 return o; /* Don't attempt to run with errors */
2382 PL_op = curop = LINKLIST(o);
2389 PL_tmps_floor = oldtmps_floor;
2391 o->op_type = OP_RV2AV;
2392 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2393 curop = ((UNOP*)o)->op_first;
2394 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2401 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2403 if (!o || o->op_type != OP_LIST)
2404 o = newLISTOP(OP_LIST, 0, o, Nullop);
2406 o->op_flags &= ~OPf_WANT;
2408 if (!(PL_opargs[type] & OA_MARK))
2409 null(cLISTOPo->op_first);
2412 o->op_ppaddr = PL_ppaddr[type];
2413 o->op_flags |= flags;
2415 o = CHECKOP(type, o);
2416 if (o->op_type != type)
2419 return fold_constants(o);
2422 /* List constructors */
2425 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2433 if (first->op_type != type
2434 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2436 return newLISTOP(type, 0, first, last);
2439 if (first->op_flags & OPf_KIDS)
2440 ((LISTOP*)first)->op_last->op_sibling = last;
2442 first->op_flags |= OPf_KIDS;
2443 ((LISTOP*)first)->op_first = last;
2445 ((LISTOP*)first)->op_last = last;
2450 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2458 if (first->op_type != type)
2459 return prepend_elem(type, (OP*)first, (OP*)last);
2461 if (last->op_type != type)
2462 return append_elem(type, (OP*)first, (OP*)last);
2464 first->op_last->op_sibling = last->op_first;
2465 first->op_last = last->op_last;
2466 first->op_flags |= (last->op_flags & OPf_KIDS);
2468 #ifdef PL_OP_SLAB_ALLOC
2476 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2484 if (last->op_type == type) {
2485 if (type == OP_LIST) { /* already a PUSHMARK there */
2486 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2487 ((LISTOP*)last)->op_first->op_sibling = first;
2488 if (!(first->op_flags & OPf_PARENS))
2489 last->op_flags &= ~OPf_PARENS;
2492 if (!(last->op_flags & OPf_KIDS)) {
2493 ((LISTOP*)last)->op_last = first;
2494 last->op_flags |= OPf_KIDS;
2496 first->op_sibling = ((LISTOP*)last)->op_first;
2497 ((LISTOP*)last)->op_first = first;
2499 last->op_flags |= OPf_KIDS;
2503 return newLISTOP(type, 0, first, last);
2509 Perl_newNULLLIST(pTHX)
2511 return newOP(OP_STUB, 0);
2515 Perl_force_list(pTHX_ OP *o)
2517 if (!o || o->op_type != OP_LIST)
2518 o = newLISTOP(OP_LIST, 0, o, Nullop);
2524 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2528 NewOp(1101, listop, 1, LISTOP);
2530 listop->op_type = type;
2531 listop->op_ppaddr = PL_ppaddr[type];
2534 listop->op_flags = flags;
2538 else if (!first && last)
2541 first->op_sibling = last;
2542 listop->op_first = first;
2543 listop->op_last = last;
2544 if (type == OP_LIST) {
2546 pushop = newOP(OP_PUSHMARK, 0);
2547 pushop->op_sibling = first;
2548 listop->op_first = pushop;
2549 listop->op_flags |= OPf_KIDS;
2551 listop->op_last = pushop;
2558 Perl_newOP(pTHX_ I32 type, I32 flags)
2561 NewOp(1101, o, 1, OP);
2563 o->op_ppaddr = PL_ppaddr[type];
2564 o->op_flags = flags;
2567 o->op_private = 0 + (flags >> 8);
2568 if (PL_opargs[type] & OA_RETSCALAR)
2570 if (PL_opargs[type] & OA_TARGET)
2571 o->op_targ = pad_alloc(type, SVs_PADTMP);
2572 return CHECKOP(type, o);
2576 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2581 first = newOP(OP_STUB, 0);
2582 if (PL_opargs[type] & OA_MARK)
2583 first = force_list(first);
2585 NewOp(1101, unop, 1, UNOP);
2586 unop->op_type = type;
2587 unop->op_ppaddr = PL_ppaddr[type];
2588 unop->op_first = first;
2589 unop->op_flags = flags | OPf_KIDS;
2590 unop->op_private = 1 | (flags >> 8);
2591 unop = (UNOP*) CHECKOP(type, unop);
2595 return fold_constants((OP *) unop);
2599 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2602 NewOp(1101, binop, 1, BINOP);
2605 first = newOP(OP_NULL, 0);
2607 binop->op_type = type;
2608 binop->op_ppaddr = PL_ppaddr[type];
2609 binop->op_first = first;
2610 binop->op_flags = flags | OPf_KIDS;
2613 binop->op_private = 1 | (flags >> 8);
2616 binop->op_private = 2 | (flags >> 8);
2617 first->op_sibling = last;
2620 binop = (BINOP*)CHECKOP(type, binop);
2621 if (binop->op_next || binop->op_type != type)
2624 binop->op_last = binop->op_first->op_sibling;
2626 return fold_constants((OP *)binop);
2630 utf8compare(const void *a, const void *b)
2633 for (i = 0; i < 10; i++) {
2634 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2636 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2643 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2645 SV *tstr = ((SVOP*)expr)->op_sv;
2646 SV *rstr = ((SVOP*)repl)->op_sv;
2649 U8 *t = (U8*)SvPV(tstr, tlen);
2650 U8 *r = (U8*)SvPV(rstr, rlen);
2657 register short *tbl;
2659 complement = o->op_private & OPpTRANS_COMPLEMENT;
2660 del = o->op_private & OPpTRANS_DELETE;
2661 squash = o->op_private & OPpTRANS_SQUASH;
2664 o->op_private |= OPpTRANS_FROM_UTF;
2667 o->op_private |= OPpTRANS_TO_UTF;
2669 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2670 SV* listsv = newSVpvn("# comment\n",10);
2672 U8* tend = t + tlen;
2673 U8* rend = r + rlen;
2687 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2688 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2689 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2690 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2693 U8 tmpbuf[UTF8_MAXLEN+1];
2696 New(1109, cp, tlen, U8*);
2698 transv = newSVpvn("",0);
2702 if (t < tend && *t == 0xff) {
2707 qsort(cp, i, sizeof(U8*), utf8compare);
2708 for (j = 0; j < i; j++) {
2710 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2711 UV val = utf8_to_uv(s, cur, &ulen, 0);
2713 diff = val - nextmin;
2715 t = uv_to_utf8(tmpbuf,nextmin);
2716 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2718 t = uv_to_utf8(tmpbuf, val - 1);
2719 sv_catpvn(transv, "\377", 1);
2720 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2723 if (s < tend && *s == 0xff)
2724 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2728 t = uv_to_utf8(tmpbuf,nextmin);
2729 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2730 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2731 sv_catpvn(transv, "\377", 1);
2732 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2733 t = (U8*)SvPVX(transv);
2734 tlen = SvCUR(transv);
2738 else if (!rlen && !del) {
2739 r = t; rlen = tlen; rend = tend;
2743 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2745 o->op_private |= OPpTRANS_IDENTICAL;
2749 while (t < tend || tfirst <= tlast) {
2750 /* see if we need more "t" chars */
2751 if (tfirst > tlast) {
2752 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2754 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2756 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2763 /* now see if we need more "r" chars */
2764 if (rfirst > rlast) {
2766 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2768 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2770 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2779 rfirst = rlast = 0xffffffff;
2783 /* now see which range will peter our first, if either. */
2784 tdiff = tlast - tfirst;
2785 rdiff = rlast - rfirst;
2792 if (rfirst == 0xffffffff) {
2793 diff = tdiff; /* oops, pretend rdiff is infinite */
2795 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2796 (long)tfirst, (long)tlast);
2798 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2802 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2803 (long)tfirst, (long)(tfirst + diff),
2806 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2807 (long)tfirst, (long)rfirst);
2809 if (rfirst + diff > max)
2810 max = rfirst + diff;
2813 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2824 else if (max > 0xff)
2829 Safefree(cPVOPo->op_pv);
2830 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2831 SvREFCNT_dec(listsv);
2833 SvREFCNT_dec(transv);
2835 if (!del && havefinal)
2836 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2837 newSVuv((UV)final), 0);
2840 o->op_private |= OPpTRANS_GROWS;
2852 tbl = (short*)cPVOPo->op_pv;
2854 Zero(tbl, 256, short);
2855 for (i = 0; i < tlen; i++)
2857 for (i = 0, j = 0; i < 256; i++) {
2868 if (i < 128 && r[j] >= 128)
2878 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2879 tbl[0x100] = rlen - j;
2880 for (i=0; i < rlen - j; i++)
2881 tbl[0x101+i] = r[j+i];
2885 if (!rlen && !del) {
2888 o->op_private |= OPpTRANS_IDENTICAL;
2890 for (i = 0; i < 256; i++)
2892 for (i = 0, j = 0; i < tlen; i++,j++) {
2895 if (tbl[t[i]] == -1)
2901 if (tbl[t[i]] == -1) {
2902 if (t[i] < 128 && r[j] >= 128)
2909 o->op_private |= OPpTRANS_GROWS;
2917 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2921 NewOp(1101, pmop, 1, PMOP);
2922 pmop->op_type = type;
2923 pmop->op_ppaddr = PL_ppaddr[type];
2924 pmop->op_flags = flags;
2925 pmop->op_private = 0 | (flags >> 8);
2927 if (PL_hints & HINT_RE_TAINT)
2928 pmop->op_pmpermflags |= PMf_RETAINT;
2929 if (PL_hints & HINT_LOCALE)
2930 pmop->op_pmpermflags |= PMf_LOCALE;
2931 pmop->op_pmflags = pmop->op_pmpermflags;
2933 /* link into pm list */
2934 if (type != OP_TRANS && PL_curstash) {
2935 pmop->op_pmnext = HvPMROOT(PL_curstash);
2936 HvPMROOT(PL_curstash) = pmop;
2943 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2947 I32 repl_has_vars = 0;
2949 if (o->op_type == OP_TRANS)
2950 return pmtrans(o, expr, repl);
2952 PL_hints |= HINT_BLOCK_SCOPE;
2955 if (expr->op_type == OP_CONST) {
2957 SV *pat = ((SVOP*)expr)->op_sv;
2958 char *p = SvPV(pat, plen);
2959 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2960 sv_setpvn(pat, "\\s+", 3);
2961 p = SvPV(pat, plen);
2962 pm->op_pmflags |= PMf_SKIPWHITE;
2964 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2965 pm->op_pmdynflags |= PMdf_UTF8;
2966 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2967 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2968 pm->op_pmflags |= PMf_WHITE;
2972 if (PL_hints & HINT_UTF8)
2973 pm->op_pmdynflags |= PMdf_UTF8;
2974 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2975 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2977 : OP_REGCMAYBE),0,expr);
2979 NewOp(1101, rcop, 1, LOGOP);
2980 rcop->op_type = OP_REGCOMP;
2981 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2982 rcop->op_first = scalar(expr);
2983 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2984 ? (OPf_SPECIAL | OPf_KIDS)
2986 rcop->op_private = 1;
2989 /* establish postfix order */
2990 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2992 rcop->op_next = expr;
2993 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2996 rcop->op_next = LINKLIST(expr);
2997 expr->op_next = (OP*)rcop;
3000 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3005 if (pm->op_pmflags & PMf_EVAL) {
3007 if (CopLINE(PL_curcop) < PL_multi_end)
3008 CopLINE_set(PL_curcop, PL_multi_end);
3011 else if (repl->op_type == OP_THREADSV
3012 && strchr("&`'123456789+",
3013 PL_threadsv_names[repl->op_targ]))
3017 #endif /* USE_THREADS */
3018 else if (repl->op_type == OP_CONST)
3022 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3023 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3025 if (curop->op_type == OP_THREADSV) {
3027 if (strchr("&`'123456789+", curop->op_private))
3031 if (curop->op_type == OP_GV) {
3032 GV *gv = cGVOPx_gv(curop);
3034 if (strchr("&`'123456789+", *GvENAME(gv)))
3037 #endif /* USE_THREADS */
3038 else if (curop->op_type == OP_RV2CV)
3040 else if (curop->op_type == OP_RV2SV ||
3041 curop->op_type == OP_RV2AV ||
3042 curop->op_type == OP_RV2HV ||
3043 curop->op_type == OP_RV2GV) {
3044 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3047 else if (curop->op_type == OP_PADSV ||
3048 curop->op_type == OP_PADAV ||
3049 curop->op_type == OP_PADHV ||
3050 curop->op_type == OP_PADANY) {
3053 else if (curop->op_type == OP_PUSHRE)
3054 ; /* Okay here, dangerous in newASSIGNOP */
3063 && (!pm->op_pmregexp
3064 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3065 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3066 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3067 prepend_elem(o->op_type, scalar(repl), o);
3070 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3071 pm->op_pmflags |= PMf_MAYBE_CONST;
3072 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3074 NewOp(1101, rcop, 1, LOGOP);
3075 rcop->op_type = OP_SUBSTCONT;
3076 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3077 rcop->op_first = scalar(repl);
3078 rcop->op_flags |= OPf_KIDS;
3079 rcop->op_private = 1;
3082 /* establish postfix order */
3083 rcop->op_next = LINKLIST(repl);
3084 repl->op_next = (OP*)rcop;
3086 pm->op_pmreplroot = scalar((OP*)rcop);
3087 pm->op_pmreplstart = LINKLIST(rcop);
3096 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3099 NewOp(1101, svop, 1, SVOP);
3100 svop->op_type = type;
3101 svop->op_ppaddr = PL_ppaddr[type];
3103 svop->op_next = (OP*)svop;
3104 svop->op_flags = flags;
3105 if (PL_opargs[type] & OA_RETSCALAR)
3107 if (PL_opargs[type] & OA_TARGET)
3108 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3109 return CHECKOP(type, svop);
3113 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3116 NewOp(1101, padop, 1, PADOP);
3117 padop->op_type = type;
3118 padop->op_ppaddr = PL_ppaddr[type];
3119 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3120 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3121 PL_curpad[padop->op_padix] = sv;
3123 padop->op_next = (OP*)padop;
3124 padop->op_flags = flags;
3125 if (PL_opargs[type] & OA_RETSCALAR)
3127 if (PL_opargs[type] & OA_TARGET)
3128 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3129 return CHECKOP(type, padop);
3133 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3137 return newPADOP(type, flags, SvREFCNT_inc(gv));
3139 return newSVOP(type, flags, SvREFCNT_inc(gv));
3144 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3147 NewOp(1101, pvop, 1, PVOP);
3148 pvop->op_type = type;
3149 pvop->op_ppaddr = PL_ppaddr[type];
3151 pvop->op_next = (OP*)pvop;
3152 pvop->op_flags = flags;
3153 if (PL_opargs[type] & OA_RETSCALAR)
3155 if (PL_opargs[type] & OA_TARGET)
3156 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3157 return CHECKOP(type, pvop);
3161 Perl_package(pTHX_ OP *o)
3165 save_hptr(&PL_curstash);
3166 save_item(PL_curstname);
3171 name = SvPV(sv, len);
3172 PL_curstash = gv_stashpvn(name,len,TRUE);
3173 sv_setpvn(PL_curstname, name, len);
3177 sv_setpv(PL_curstname,"<none>");
3178 PL_curstash = Nullhv;
3180 PL_hints |= HINT_BLOCK_SCOPE;
3181 PL_copline = NOLINE;
3186 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3194 if (id->op_type != OP_CONST)
3195 Perl_croak(aTHX_ "Module name must be constant");
3199 if (version != Nullop) {
3200 SV *vesv = ((SVOP*)version)->op_sv;
3202 if (arg == Nullop && !SvNIOKp(vesv)) {
3209 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3210 Perl_croak(aTHX_ "Version number must be constant number");
3212 /* Make copy of id so we don't free it twice */
3213 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3215 /* Fake up a method call to VERSION */
3216 meth = newSVpvn("VERSION",7);
3217 sv_upgrade(meth, SVt_PVIV);
3218 (void)SvIOK_on(meth);
3219 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3220 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3221 append_elem(OP_LIST,
3222 prepend_elem(OP_LIST, pack, list(version)),
3223 newSVOP(OP_METHOD_NAMED, 0, meth)));
3227 /* Fake up an import/unimport */
3228 if (arg && arg->op_type == OP_STUB)
3229 imop = arg; /* no import on explicit () */
3230 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3231 imop = Nullop; /* use 5.0; */
3236 /* Make copy of id so we don't free it twice */
3237 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3239 /* Fake up a method call to import/unimport */
3240 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3241 sv_upgrade(meth, SVt_PVIV);
3242 (void)SvIOK_on(meth);
3243 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3244 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3245 append_elem(OP_LIST,
3246 prepend_elem(OP_LIST, pack, list(arg)),
3247 newSVOP(OP_METHOD_NAMED, 0, meth)));
3250 /* Fake up a require, handle override, if any */
3251 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3252 if (!(gv && GvIMPORTED_CV(gv)))
3253 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3255 if (gv && GvIMPORTED_CV(gv)) {
3256 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3257 append_elem(OP_LIST, id,
3258 scalar(newUNOP(OP_RV2CV, 0,
3263 rqop = newUNOP(OP_REQUIRE, 0, id);
3266 /* Fake up the BEGIN {}, which does its thing immediately. */
3268 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3271 append_elem(OP_LINESEQ,
3272 append_elem(OP_LINESEQ,
3273 newSTATEOP(0, Nullch, rqop),
3274 newSTATEOP(0, Nullch, veop)),
3275 newSTATEOP(0, Nullch, imop) ));
3277 PL_hints |= HINT_BLOCK_SCOPE;
3278 PL_copline = NOLINE;
3283 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3286 va_start(args, ver);
3287 vload_module(flags, name, ver, &args);
3291 #ifdef PERL_IMPLICIT_CONTEXT
3293 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3297 va_start(args, ver);
3298 vload_module(flags, name, ver, &args);
3304 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3306 OP *modname, *veop, *imop;
3308 modname = newSVOP(OP_CONST, 0, name);
3309 modname->op_private |= OPpCONST_BARE;
3311 veop = newSVOP(OP_CONST, 0, ver);
3315 if (flags & PERL_LOADMOD_NOIMPORT) {
3316 imop = sawparens(newNULLLIST());
3318 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3319 imop = va_arg(*args, OP*);
3324 sv = va_arg(*args, SV*);
3326 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3327 sv = va_arg(*args, SV*);
3331 line_t ocopline = PL_copline;
3332 int oexpect = PL_expect;
3334 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3335 veop, modname, imop);
3336 PL_expect = oexpect;
3337 PL_copline = ocopline;
3342 Perl_dofile(pTHX_ OP *term)
3347 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3348 if (!(gv && GvIMPORTED_CV(gv)))
3349 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3351 if (gv && GvIMPORTED_CV(gv)) {
3352 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3353 append_elem(OP_LIST, term,
3354 scalar(newUNOP(OP_RV2CV, 0,
3359 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3365 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3367 return newBINOP(OP_LSLICE, flags,
3368 list(force_list(subscript)),
3369 list(force_list(listval)) );
3373 S_list_assignment(pTHX_ register OP *o)
3378 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3379 o = cUNOPo->op_first;
3381 if (o->op_type == OP_COND_EXPR) {
3382 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3383 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3388 yyerror("Assignment to both a list and a scalar");
3392 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3393 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3394 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3397 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3400 if (o->op_type == OP_RV2SV)
3407 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3412 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3413 return newLOGOP(optype, 0,
3414 mod(scalar(left), optype),
3415 newUNOP(OP_SASSIGN, 0, scalar(right)));
3418 return newBINOP(optype, OPf_STACKED,
3419 mod(scalar(left), optype), scalar(right));
3423 if (list_assignment(left)) {
3427 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3428 left = mod(left, OP_AASSIGN);
3436 curop = list(force_list(left));
3437 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3438 o->op_private = 0 | (flags >> 8);
3439 for (curop = ((LISTOP*)curop)->op_first;
3440 curop; curop = curop->op_sibling)
3442 if (curop->op_type == OP_RV2HV &&
3443 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3444 o->op_private |= OPpASSIGN_HASH;
3448 if (!(left->op_private & OPpLVAL_INTRO)) {
3451 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3452 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3453 if (curop->op_type == OP_GV) {
3454 GV *gv = cGVOPx_gv(curop);
3455 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3457 SvCUR(gv) = PL_generation;
3459 else if (curop->op_type == OP_PADSV ||
3460 curop->op_type == OP_PADAV ||
3461 curop->op_type == OP_PADHV ||
3462 curop->op_type == OP_PADANY) {
3463 SV **svp = AvARRAY(PL_comppad_name);
3464 SV *sv = svp[curop->op_targ];
3465 if (SvCUR(sv) == PL_generation)
3467 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3469 else if (curop->op_type == OP_RV2CV)
3471 else if (curop->op_type == OP_RV2SV ||
3472 curop->op_type == OP_RV2AV ||
3473 curop->op_type == OP_RV2HV ||
3474 curop->op_type == OP_RV2GV) {
3475 if (lastop->op_type != OP_GV) /* funny deref? */
3478 else if (curop->op_type == OP_PUSHRE) {
3479 if (((PMOP*)curop)->op_pmreplroot) {
3481 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3483 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3485 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3487 SvCUR(gv) = PL_generation;
3496 o->op_private |= OPpASSIGN_COMMON;
3498 if (right && right->op_type == OP_SPLIT) {
3500 if ((tmpop = ((LISTOP*)right)->op_first) &&
3501 tmpop->op_type == OP_PUSHRE)
3503 PMOP *pm = (PMOP*)tmpop;
3504 if (left->op_type == OP_RV2AV &&
3505 !(left->op_private & OPpLVAL_INTRO) &&
3506 !(o->op_private & OPpASSIGN_COMMON) )
3508 tmpop = ((UNOP*)left)->op_first;
3509 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3511 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3512 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3514 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3515 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3517 pm->op_pmflags |= PMf_ONCE;
3518 tmpop = cUNOPo->op_first; /* to list (nulled) */
3519 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3520 tmpop->op_sibling = Nullop; /* don't free split */
3521 right->op_next = tmpop->op_next; /* fix starting loc */
3522 op_free(o); /* blow off assign */
3523 right->op_flags &= ~OPf_WANT;
3524 /* "I don't know and I don't care." */
3529 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3530 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3532 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3534 sv_setiv(sv, PL_modcount+1);
3542 right = newOP(OP_UNDEF, 0);
3543 if (right->op_type == OP_READLINE) {
3544 right->op_flags |= OPf_STACKED;
3545 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3548 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3549 o = newBINOP(OP_SASSIGN, flags,
3550 scalar(right), mod(scalar(left), OP_SASSIGN) );
3562 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3564 U32 seq = intro_my();
3567 NewOp(1101, cop, 1, COP);
3568 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3569 cop->op_type = OP_DBSTATE;
3570 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3573 cop->op_type = OP_NEXTSTATE;
3574 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3576 cop->op_flags = flags;
3577 cop->op_private = (PL_hints & HINT_BYTE);
3579 cop->op_private |= NATIVE_HINTS;
3581 PL_compiling.op_private = cop->op_private;
3582 cop->op_next = (OP*)cop;
3585 cop->cop_label = label;
3586 PL_hints |= HINT_BLOCK_SCOPE;
3589 cop->cop_arybase = PL_curcop->cop_arybase;
3590 if (specialWARN(PL_curcop->cop_warnings))
3591 cop->cop_warnings = PL_curcop->cop_warnings ;
3593 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3594 if (specialCopIO(PL_curcop->cop_io))
3595 cop->cop_io = PL_curcop->cop_io;
3597 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3600 if (PL_copline == NOLINE)
3601 CopLINE_set(cop, CopLINE(PL_curcop));
3603 CopLINE_set(cop, PL_copline);
3604 PL_copline = NOLINE;
3607 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3609 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3611 CopSTASH_set(cop, PL_curstash);
3613 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3614 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3615 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3616 (void)SvIOK_on(*svp);
3617 SvIVX(*svp) = PTR2IV(cop);
3621 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3624 /* "Introduce" my variables to visible status. */
3632 if (! PL_min_intro_pending)
3633 return PL_cop_seqmax;
3635 svp = AvARRAY(PL_comppad_name);
3636 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3637 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3638 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3639 SvNVX(sv) = (NV)PL_cop_seqmax;
3642 PL_min_intro_pending = 0;
3643 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3644 return PL_cop_seqmax++;
3648 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3650 return new_logop(type, flags, &first, &other);
3654 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3658 OP *first = *firstp;
3659 OP *other = *otherp;
3661 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3662 return newBINOP(type, flags, scalar(first), scalar(other));
3664 scalarboolean(first);
3665 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3666 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3667 if (type == OP_AND || type == OP_OR) {
3673 first = *firstp = cUNOPo->op_first;
3675 first->op_next = o->op_next;
3676 cUNOPo->op_first = Nullop;
3680 if (first->op_type == OP_CONST) {
3681 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3682 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3683 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3694 else if (first->op_type == OP_WANTARRAY) {
3700 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3701 OP *k1 = ((UNOP*)first)->op_first;
3702 OP *k2 = k1->op_sibling;
3704 switch (first->op_type)
3707 if (k2 && k2->op_type == OP_READLINE
3708 && (k2->op_flags & OPf_STACKED)
3709 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3711 warnop = k2->op_type;
3716 if (k1->op_type == OP_READDIR
3717 || k1->op_type == OP_GLOB
3718 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3719 || k1->op_type == OP_EACH)
3721 warnop = ((k1->op_type == OP_NULL)
3722 ? k1->op_targ : k1->op_type);
3727 line_t oldline = CopLINE(PL_curcop);
3728 CopLINE_set(PL_curcop, PL_copline);
3729 Perl_warner(aTHX_ WARN_MISC,
3730 "Value of %s%s can be \"0\"; test with defined()",
3732 ((warnop == OP_READLINE || warnop == OP_GLOB)
3733 ? " construct" : "() operator"));
3734 CopLINE_set(PL_curcop, oldline);
3741 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3742 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3744 NewOp(1101, logop, 1, LOGOP);
3746 logop->op_type = type;
3747 logop->op_ppaddr = PL_ppaddr[type];
3748 logop->op_first = first;
3749 logop->op_flags = flags | OPf_KIDS;
3750 logop->op_other = LINKLIST(other);
3751 logop->op_private = 1 | (flags >> 8);
3753 /* establish postfix order */
3754 logop->op_next = LINKLIST(first);
3755 first->op_next = (OP*)logop;
3756 first->op_sibling = other;
3758 o = newUNOP(OP_NULL, 0, (OP*)logop);
3765 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3772 return newLOGOP(OP_AND, 0, first, trueop);
3774 return newLOGOP(OP_OR, 0, first, falseop);
3776 scalarboolean(first);
3777 if (first->op_type == OP_CONST) {
3778 if (SvTRUE(((SVOP*)first)->op_sv)) {
3789 else if (first->op_type == OP_WANTARRAY) {
3793 NewOp(1101, logop, 1, LOGOP);
3794 logop->op_type = OP_COND_EXPR;
3795 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3796 logop->op_first = first;
3797 logop->op_flags = flags | OPf_KIDS;
3798 logop->op_private = 1 | (flags >> 8);
3799 logop->op_other = LINKLIST(trueop);
3800 logop->op_next = LINKLIST(falseop);
3803 /* establish postfix order */
3804 start = LINKLIST(first);
3805 first->op_next = (OP*)logop;
3807 first->op_sibling = trueop;
3808 trueop->op_sibling = falseop;
3809 o = newUNOP(OP_NULL, 0, (OP*)logop);
3811 trueop->op_next = falseop->op_next = o;
3818 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3826 NewOp(1101, range, 1, LOGOP);
3828 range->op_type = OP_RANGE;
3829 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3830 range->op_first = left;
3831 range->op_flags = OPf_KIDS;
3832 leftstart = LINKLIST(left);
3833 range->op_other = LINKLIST(right);
3834 range->op_private = 1 | (flags >> 8);
3836 left->op_sibling = right;
3838 range->op_next = (OP*)range;
3839 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3840 flop = newUNOP(OP_FLOP, 0, flip);
3841 o = newUNOP(OP_NULL, 0, flop);
3843 range->op_next = leftstart;
3845 left->op_next = flip;
3846 right->op_next = flop;
3848 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3849 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3850 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3851 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3853 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3854 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3857 if (!flip->op_private || !flop->op_private)
3858 linklist(o); /* blow off optimizer unless constant */
3864 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3868 int once = block && block->op_flags & OPf_SPECIAL &&
3869 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3872 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3873 return block; /* do {} while 0 does once */
3874 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3875 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3876 expr = newUNOP(OP_DEFINED, 0,
3877 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3878 } else if (expr->op_flags & OPf_KIDS) {
3879 OP *k1 = ((UNOP*)expr)->op_first;
3880 OP *k2 = (k1) ? k1->op_sibling : NULL;
3881 switch (expr->op_type) {
3883 if (k2 && k2->op_type == OP_READLINE
3884 && (k2->op_flags & OPf_STACKED)
3885 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3886 expr = newUNOP(OP_DEFINED, 0, expr);
3890 if (k1->op_type == OP_READDIR
3891 || k1->op_type == OP_GLOB
3892 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3893 || k1->op_type == OP_EACH)
3894 expr = newUNOP(OP_DEFINED, 0, expr);
3900 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3901 o = new_logop(OP_AND, 0, &expr, &listop);
3904 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3906 if (once && o != listop)
3907 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3910 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3912 o->op_flags |= flags;
3914 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3919 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3928 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3929 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3930 expr = newUNOP(OP_DEFINED, 0,
3931 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3932 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3933 OP *k1 = ((UNOP*)expr)->op_first;
3934 OP *k2 = (k1) ? k1->op_sibling : NULL;
3935 switch (expr->op_type) {
3937 if (k2 && k2->op_type == OP_READLINE
3938 && (k2->op_flags & OPf_STACKED)
3939 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3940 expr = newUNOP(OP_DEFINED, 0, expr);
3944 if (k1->op_type == OP_READDIR
3945 || k1->op_type == OP_GLOB
3946 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3947 || k1->op_type == OP_EACH)
3948 expr = newUNOP(OP_DEFINED, 0, expr);
3954 block = newOP(OP_NULL, 0);
3956 block = scope(block);
3960 next = LINKLIST(cont);
3963 OP *unstack = newOP(OP_UNSTACK, 0);
3966 cont = append_elem(OP_LINESEQ, cont, unstack);
3967 if ((line_t)whileline != NOLINE) {
3968 PL_copline = whileline;
3969 cont = append_elem(OP_LINESEQ, cont,
3970 newSTATEOP(0, Nullch, Nullop));
3974 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3975 redo = LINKLIST(listop);
3978 PL_copline = whileline;
3980 o = new_logop(OP_AND, 0, &expr, &listop);
3981 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3982 op_free(expr); /* oops, it's a while (0) */
3984 return Nullop; /* listop already freed by new_logop */
3987 ((LISTOP*)listop)->op_last->op_next = condop =
3988 (o == listop ? redo : LINKLIST(o));
3994 NewOp(1101,loop,1,LOOP);
3995 loop->op_type = OP_ENTERLOOP;
3996 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3997 loop->op_private = 0;
3998 loop->op_next = (OP*)loop;
4001 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4003 loop->op_redoop = redo;
4004 loop->op_lastop = o;
4005 o->op_private |= loopflags;
4008 loop->op_nextop = next;
4010 loop->op_nextop = o;
4012 o->op_flags |= flags;
4013 o->op_private |= (flags >> 8);
4018 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4026 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4027 sv->op_type = OP_RV2GV;
4028 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4030 else if (sv->op_type == OP_PADSV) { /* private variable */
4031 padoff = sv->op_targ;
4036 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4037 padoff = sv->op_targ;
4039 iterflags |= OPf_SPECIAL;
4044 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4048 padoff = find_threadsv("_");
4049 iterflags |= OPf_SPECIAL;
4051 sv = newGVOP(OP_GV, 0, PL_defgv);
4054 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4055 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4056 iterflags |= OPf_STACKED;
4058 else if (expr->op_type == OP_NULL &&
4059 (expr->op_flags & OPf_KIDS) &&
4060 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4062 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4063 * set the STACKED flag to indicate that these values are to be
4064 * treated as min/max values by 'pp_iterinit'.
4066 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4067 LOGOP* range = (LOGOP*) flip->op_first;
4068 OP* left = range->op_first;
4069 OP* right = left->op_sibling;
4072 range->op_flags &= ~OPf_KIDS;
4073 range->op_first = Nullop;
4075 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4076 listop->op_first->op_next = range->op_next;
4077 left->op_next = range->op_other;
4078 right->op_next = (OP*)listop;
4079 listop->op_next = listop->op_first;
4082 expr = (OP*)(listop);
4084 iterflags |= OPf_STACKED;
4087 expr = mod(force_list(expr), OP_GREPSTART);
4091 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4092 append_elem(OP_LIST, expr, scalar(sv))));
4093 assert(!loop->op_next);
4094 #ifdef PL_OP_SLAB_ALLOC
4097 NewOp(1234,tmp,1,LOOP);
4098 Copy(loop,tmp,1,LOOP);
4102 Renew(loop, 1, LOOP);
4104 loop->op_targ = padoff;
4105 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4106 PL_copline = forline;
4107 return newSTATEOP(0, label, wop);
4111 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4116 if (type != OP_GOTO || label->op_type == OP_CONST) {
4117 /* "last()" means "last" */
4118 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4119 o = newOP(type, OPf_SPECIAL);
4121 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4122 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4128 if (label->op_type == OP_ENTERSUB)
4129 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4130 o = newUNOP(type, OPf_STACKED, label);
4132 PL_hints |= HINT_BLOCK_SCOPE;
4137 Perl_cv_undef(pTHX_ CV *cv)
4141 MUTEX_DESTROY(CvMUTEXP(cv));
4142 Safefree(CvMUTEXP(cv));
4145 #endif /* USE_THREADS */
4147 if (!CvXSUB(cv) && CvROOT(cv)) {
4149 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4150 Perl_croak(aTHX_ "Can't undef active subroutine");
4153 Perl_croak(aTHX_ "Can't undef active subroutine");
4154 #endif /* USE_THREADS */
4157 SAVEVPTR(PL_curpad);
4161 op_free(CvROOT(cv));
4162 CvROOT(cv) = Nullop;
4165 SvPOK_off((SV*)cv); /* forget prototype */
4167 SvREFCNT_dec(CvOUTSIDE(cv));
4168 CvOUTSIDE(cv) = Nullcv;
4170 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4173 if (CvPADLIST(cv)) {
4174 /* may be during global destruction */
4175 if (SvREFCNT(CvPADLIST(cv))) {
4176 I32 i = AvFILLp(CvPADLIST(cv));
4178 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4179 SV* sv = svp ? *svp : Nullsv;
4182 if (sv == (SV*)PL_comppad_name)
4183 PL_comppad_name = Nullav;
4184 else if (sv == (SV*)PL_comppad) {
4185 PL_comppad = Nullav;
4186 PL_curpad = Null(SV**);
4190 SvREFCNT_dec((SV*)CvPADLIST(cv));
4192 CvPADLIST(cv) = Nullav;
4197 #ifdef DEBUG_CLOSURES
4199 S_cv_dump(pTHX_ CV *cv)
4202 CV *outside = CvOUTSIDE(cv);
4203 AV* padlist = CvPADLIST(cv);
4210 PerlIO_printf(Perl_debug_log,
4211 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4213 (CvANON(cv) ? "ANON"
4214 : (cv == PL_main_cv) ? "MAIN"
4215 : CvUNIQUE(cv) ? "UNIQUE"
4216 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4219 : CvANON(outside) ? "ANON"
4220 : (outside == PL_main_cv) ? "MAIN"
4221 : CvUNIQUE(outside) ? "UNIQUE"
4222 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4227 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4228 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4229 pname = AvARRAY(pad_name);
4230 ppad = AvARRAY(pad);
4232 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4233 if (SvPOK(pname[ix]))
4234 PerlIO_printf(Perl_debug_log,
4235 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4236 (int)ix, PTR2UV(ppad[ix]),
4237 SvFAKE(pname[ix]) ? "FAKE " : "",
4239 (IV)I_32(SvNVX(pname[ix])),
4242 #endif /* DEBUGGING */
4244 #endif /* DEBUG_CLOSURES */
4247 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4251 AV* protopadlist = CvPADLIST(proto);
4252 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4253 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4254 SV** pname = AvARRAY(protopad_name);
4255 SV** ppad = AvARRAY(protopad);
4256 I32 fname = AvFILLp(protopad_name);
4257 I32 fpad = AvFILLp(protopad);
4261 assert(!CvUNIQUE(proto));
4265 SAVESPTR(PL_comppad_name);
4266 SAVESPTR(PL_compcv);
4268 cv = PL_compcv = (CV*)NEWSV(1104,0);
4269 sv_upgrade((SV *)cv, SvTYPE(proto));
4270 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4274 New(666, CvMUTEXP(cv), 1, perl_mutex);
4275 MUTEX_INIT(CvMUTEXP(cv));
4277 #endif /* USE_THREADS */
4278 CvFILE(cv) = CvFILE(proto);
4279 CvGV(cv) = CvGV(proto);
4280 CvSTASH(cv) = CvSTASH(proto);
4281 CvROOT(cv) = CvROOT(proto);
4282 CvSTART(cv) = CvSTART(proto);
4284 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4287 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4289 PL_comppad_name = newAV();
4290 for (ix = fname; ix >= 0; ix--)
4291 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4293 PL_comppad = newAV();
4295 comppadlist = newAV();
4296 AvREAL_off(comppadlist);
4297 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4298 av_store(comppadlist, 1, (SV*)PL_comppad);
4299 CvPADLIST(cv) = comppadlist;
4300 av_fill(PL_comppad, AvFILLp(protopad));
4301 PL_curpad = AvARRAY(PL_comppad);
4303 av = newAV(); /* will be @_ */
4305 av_store(PL_comppad, 0, (SV*)av);
4306 AvFLAGS(av) = AVf_REIFY;
4308 for (ix = fpad; ix > 0; ix--) {
4309 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4310 if (namesv && namesv != &PL_sv_undef) {
4311 char *name = SvPVX(namesv); /* XXX */
4312 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4313 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4314 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4316 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4318 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4320 else { /* our own lexical */
4323 /* anon code -- we'll come back for it */
4324 sv = SvREFCNT_inc(ppad[ix]);
4326 else if (*name == '@')
4328 else if (*name == '%')
4337 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4338 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4341 SV* sv = NEWSV(0,0);
4347 /* Now that vars are all in place, clone nested closures. */
4349 for (ix = fpad; ix > 0; ix--) {
4350 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4352 && namesv != &PL_sv_undef
4353 && !(SvFLAGS(namesv) & SVf_FAKE)
4354 && *SvPVX(namesv) == '&'
4355 && CvCLONE(ppad[ix]))
4357 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4358 SvREFCNT_dec(ppad[ix]);
4361 PL_curpad[ix] = (SV*)kid;
4365 #ifdef DEBUG_CLOSURES
4366 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4368 PerlIO_printf(Perl_debug_log, " from:\n");
4370 PerlIO_printf(Perl_debug_log, " to:\n");
4377 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4379 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4381 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4388 Perl_cv_clone(pTHX_ CV *proto)
4391 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4392 cv = cv_clone2(proto, CvOUTSIDE(proto));
4393 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4398 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4400 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4401 SV* msg = sv_newmortal();
4405 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4406 sv_setpv(msg, "Prototype mismatch:");
4408 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4410 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4411 sv_catpv(msg, " vs ");
4413 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4415 sv_catpv(msg, "none");
4416 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4420 static void const_sv_xsub(pTHXo_ CV* cv);
4423 =for apidoc cv_const_sv
4425 If C<cv> is a constant sub eligible for inlining. returns the constant
4426 value returned by the sub. Otherwise, returns NULL.
4428 Constant subs can be created with C<newCONSTSUB> or as described in
4429 L<perlsub/"Constant Functions">.
4434 Perl_cv_const_sv(pTHX_ CV *cv)
4436 if (!cv || !CvCONST(cv))
4438 return (SV*)CvXSUBANY(cv).any_ptr;
4442 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4449 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4450 o = cLISTOPo->op_first->op_sibling;
4452 for (; o; o = o->op_next) {
4453 OPCODE type = o->op_type;
4455 if (sv && o->op_next == o)
4457 if (o->op_next != o) {
4458 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4460 if (type == OP_DBSTATE)
4463 if (type == OP_LEAVESUB || type == OP_RETURN)
4467 if (type == OP_CONST && cSVOPo->op_sv)
4469 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4470 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4471 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4475 /* We get here only from cv_clone2() while creating a closure.
4476 Copy the const value here instead of in cv_clone2 so that
4477 SvREADONLY_on doesn't lead to problems when leaving
4482 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4494 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4504 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4508 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4510 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4514 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4520 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4525 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4526 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4527 SV *sv = sv_newmortal();
4528 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4529 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4534 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4535 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4545 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4546 maximum a prototype before. */
4547 if (SvTYPE(gv) > SVt_NULL) {
4548 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4549 && ckWARN_d(WARN_PROTOTYPE))
4551 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4553 cv_ckproto((CV*)gv, NULL, ps);
4556 sv_setpv((SV*)gv, ps);
4558 sv_setiv((SV*)gv, -1);
4559 SvREFCNT_dec(PL_compcv);
4560 cv = PL_compcv = NULL;
4561 PL_sub_generation++;
4565 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4567 #ifdef GV_SHARED_CHECK
4568 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4569 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4573 if (!block || !ps || *ps || attrs)
4576 const_sv = op_const_sv(block, Nullcv);
4579 bool exists = CvROOT(cv) || CvXSUB(cv);
4581 #ifdef GV_SHARED_CHECK
4582 if (exists && GvSHARED(gv)) {
4583 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4587 /* if the subroutine doesn't exist and wasn't pre-declared
4588 * with a prototype, assume it will be AUTOLOADed,
4589 * skipping the prototype check
4591 if (exists || SvPOK(cv))
4592 cv_ckproto(cv, gv, ps);
4593 /* already defined (or promised)? */
4594 if (exists || GvASSUMECV(gv)) {
4595 if (!block && !attrs) {
4596 /* just a "sub foo;" when &foo is already defined */
4597 SAVEFREESV(PL_compcv);
4600 /* ahem, death to those who redefine active sort subs */
4601 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4602 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4604 if (ckWARN(WARN_REDEFINE)
4606 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4608 line_t oldline = CopLINE(PL_curcop);
4609 CopLINE_set(PL_curcop, PL_copline);
4610 Perl_warner(aTHX_ WARN_REDEFINE,
4611 CvCONST(cv) ? "Constant subroutine %s redefined"
4612 : "Subroutine %s redefined", name);
4613 CopLINE_set(PL_curcop, oldline);
4621 SvREFCNT_inc(const_sv);
4623 assert(!CvROOT(cv) && !CvCONST(cv));
4624 sv_setpv((SV*)cv, ""); /* prototype is "" */
4625 CvXSUBANY(cv).any_ptr = const_sv;
4626 CvXSUB(cv) = const_sv_xsub;
4631 cv = newCONSTSUB(NULL, name, const_sv);
4634 SvREFCNT_dec(PL_compcv);
4636 PL_sub_generation++;
4643 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4644 * before we clobber PL_compcv.
4648 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4649 stash = GvSTASH(CvGV(cv));
4650 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4651 stash = CvSTASH(cv);
4653 stash = PL_curstash;
4656 /* possibly about to re-define existing subr -- ignore old cv */
4657 rcv = (SV*)PL_compcv;
4658 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4659 stash = GvSTASH(gv);
4661 stash = PL_curstash;
4663 apply_attrs(stash, rcv, attrs);
4665 if (cv) { /* must reuse cv if autoloaded */
4667 /* got here with just attrs -- work done, so bug out */
4668 SAVEFREESV(PL_compcv);
4672 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4673 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4674 CvOUTSIDE(PL_compcv) = 0;
4675 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4676 CvPADLIST(PL_compcv) = 0;
4677 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4678 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4679 SvREFCNT_dec(PL_compcv);
4686 PL_sub_generation++;
4690 CvFILE(cv) = CopFILE(PL_curcop);
4691 CvSTASH(cv) = PL_curstash;
4694 if (!CvMUTEXP(cv)) {
4695 New(666, CvMUTEXP(cv), 1, perl_mutex);
4696 MUTEX_INIT(CvMUTEXP(cv));
4698 #endif /* USE_THREADS */
4701 sv_setpv((SV*)cv, ps);
4703 if (PL_error_count) {
4707 char *s = strrchr(name, ':');
4709 if (strEQ(s, "BEGIN")) {
4711 "BEGIN not safe after errors--compilation aborted";
4712 if (PL_in_eval & EVAL_KEEPERR)
4713 Perl_croak(aTHX_ not_safe);
4715 /* force display of errors found but not reported */
4716 sv_catpv(ERRSV, not_safe);
4717 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4725 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4726 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4729 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4730 mod(scalarseq(block), OP_LEAVESUBLV));
4733 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4735 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4736 OpREFCNT_set(CvROOT(cv), 1);
4737 CvSTART(cv) = LINKLIST(CvROOT(cv));
4738 CvROOT(cv)->op_next = 0;
4741 /* now that optimizer has done its work, adjust pad values */
4743 SV **namep = AvARRAY(PL_comppad_name);
4744 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4747 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4750 * The only things that a clonable function needs in its
4751 * pad are references to outer lexicals and anonymous subs.
4752 * The rest are created anew during cloning.
4754 if (!((namesv = namep[ix]) != Nullsv &&
4755 namesv != &PL_sv_undef &&
4757 *SvPVX(namesv) == '&')))
4759 SvREFCNT_dec(PL_curpad[ix]);
4760 PL_curpad[ix] = Nullsv;
4763 assert(!CvCONST(cv));
4764 if (ps && !*ps && op_const_sv(block, cv))
4768 AV *av = newAV(); /* Will be @_ */
4770 av_store(PL_comppad, 0, (SV*)av);
4771 AvFLAGS(av) = AVf_REIFY;
4773 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4774 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4776 if (!SvPADMY(PL_curpad[ix]))
4777 SvPADTMP_on(PL_curpad[ix]);
4781 if (name || aname) {
4783 char *tname = (name ? name : aname);
4785 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4786 SV *sv = NEWSV(0,0);
4787 SV *tmpstr = sv_newmortal();
4788 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4792 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4794 (long)PL_subline, (long)CopLINE(PL_curcop));
4795 gv_efullname3(tmpstr, gv, Nullch);
4796 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4797 hv = GvHVn(db_postponed);
4798 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4799 && (pcv = GvCV(db_postponed)))
4805 call_sv((SV*)pcv, G_DISCARD);
4809 if ((s = strrchr(tname,':')))
4814 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4817 if (strEQ(s, "BEGIN")) {
4818 I32 oldscope = PL_scopestack_ix;
4820 SAVECOPFILE(&PL_compiling);
4821 SAVECOPLINE(&PL_compiling);
4823 sv_setsv(PL_rs, PL_nrs);
4826 PL_beginav = newAV();
4827 DEBUG_x( dump_sub(gv) );
4828 av_push(PL_beginav, (SV*)cv);
4829 GvCV(gv) = 0; /* cv has been hijacked */
4830 call_list(oldscope, PL_beginav);
4832 PL_curcop = &PL_compiling;
4833 PL_compiling.op_private = PL_hints;
4836 else if (strEQ(s, "END") && !PL_error_count) {
4839 DEBUG_x( dump_sub(gv) );
4840 av_unshift(PL_endav, 1);
4841 av_store(PL_endav, 0, (SV*)cv);
4842 GvCV(gv) = 0; /* cv has been hijacked */
4844 else if (strEQ(s, "CHECK") && !PL_error_count) {
4846 PL_checkav = newAV();
4847 DEBUG_x( dump_sub(gv) );
4848 if (PL_main_start && ckWARN(WARN_VOID))
4849 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4850 av_unshift(PL_checkav, 1);
4851 av_store(PL_checkav, 0, (SV*)cv);
4852 GvCV(gv) = 0; /* cv has been hijacked */
4854 else if (strEQ(s, "INIT") && !PL_error_count) {
4856 PL_initav = newAV();
4857 DEBUG_x( dump_sub(gv) );
4858 if (PL_main_start && ckWARN(WARN_VOID))
4859 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4860 av_push(PL_initav, (SV*)cv);
4861 GvCV(gv) = 0; /* cv has been hijacked */
4866 PL_copline = NOLINE;
4871 /* XXX unsafe for threads if eval_owner isn't held */
4873 =for apidoc newCONSTSUB
4875 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4876 eligible for inlining at compile-time.
4882 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4888 SAVECOPLINE(PL_curcop);
4889 CopLINE_set(PL_curcop, PL_copline);
4892 PL_hints &= ~HINT_BLOCK_SCOPE;
4895 SAVESPTR(PL_curstash);
4896 SAVECOPSTASH(PL_curcop);
4897 PL_curstash = stash;
4899 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4901 CopSTASH(PL_curcop) = stash;
4905 cv = newXS(name, const_sv_xsub, __FILE__);
4906 CvXSUBANY(cv).any_ptr = sv;
4908 sv_setpv((SV*)cv, ""); /* prototype is "" */
4916 =for apidoc U||newXS
4918 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4924 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4926 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4929 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4931 /* just a cached method */
4935 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4936 /* already defined (or promised) */
4937 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4938 && HvNAME(GvSTASH(CvGV(cv)))
4939 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4940 line_t oldline = CopLINE(PL_curcop);
4941 if (PL_copline != NOLINE)
4942 CopLINE_set(PL_curcop, PL_copline);
4943 Perl_warner(aTHX_ WARN_REDEFINE,
4944 CvCONST(cv) ? "Constant subroutine %s redefined"
4945 : "Subroutine %s redefined"
4947 CopLINE_set(PL_curcop, oldline);
4954 if (cv) /* must reuse cv if autoloaded */
4957 cv = (CV*)NEWSV(1105,0);
4958 sv_upgrade((SV *)cv, SVt_PVCV);
4962 PL_sub_generation++;
4967 New(666, CvMUTEXP(cv), 1, perl_mutex);
4968 MUTEX_INIT(CvMUTEXP(cv));
4970 #endif /* USE_THREADS */
4971 (void)gv_fetchfile(filename);
4972 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4973 an external constant string */
4974 CvXSUB(cv) = subaddr;
4977 char *s = strrchr(name,':');
4983 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4986 if (strEQ(s, "BEGIN")) {
4988 PL_beginav = newAV();
4989 av_push(PL_beginav, (SV*)cv);
4990 GvCV(gv) = 0; /* cv has been hijacked */
4992 else if (strEQ(s, "END")) {
4995 av_unshift(PL_endav, 1);
4996 av_store(PL_endav, 0, (SV*)cv);
4997 GvCV(gv) = 0; /* cv has been hijacked */
4999 else if (strEQ(s, "CHECK")) {
5001 PL_checkav = newAV();
5002 if (PL_main_start && ckWARN(WARN_VOID))
5003 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5004 av_unshift(PL_checkav, 1);
5005 av_store(PL_checkav, 0, (SV*)cv);
5006 GvCV(gv) = 0; /* cv has been hijacked */
5008 else if (strEQ(s, "INIT")) {
5010 PL_initav = newAV();
5011 if (PL_main_start && ckWARN(WARN_VOID))
5012 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5013 av_push(PL_initav, (SV*)cv);
5014 GvCV(gv) = 0; /* cv has been hijacked */
5025 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5034 name = SvPVx(cSVOPo->op_sv, n_a);
5037 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5038 #ifdef GV_SHARED_CHECK
5040 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5044 if ((cv = GvFORM(gv))) {
5045 if (ckWARN(WARN_REDEFINE)) {
5046 line_t oldline = CopLINE(PL_curcop);
5048 CopLINE_set(PL_curcop, PL_copline);
5049 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5050 CopLINE_set(PL_curcop, oldline);
5057 CvFILE(cv) = CopFILE(PL_curcop);
5059 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5060 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5061 SvPADTMP_on(PL_curpad[ix]);
5064 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5065 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5066 OpREFCNT_set(CvROOT(cv), 1);
5067 CvSTART(cv) = LINKLIST(CvROOT(cv));
5068 CvROOT(cv)->op_next = 0;
5071 PL_copline = NOLINE;
5076 Perl_newANONLIST(pTHX_ OP *o)
5078 return newUNOP(OP_REFGEN, 0,
5079 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5083 Perl_newANONHASH(pTHX_ OP *o)
5085 return newUNOP(OP_REFGEN, 0,
5086 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5090 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5092 return newANONATTRSUB(floor, proto, Nullop, block);
5096 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5098 return newUNOP(OP_REFGEN, 0,
5099 newSVOP(OP_ANONCODE, 0,
5100 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5104 Perl_oopsAV(pTHX_ OP *o)
5106 switch (o->op_type) {
5108 o->op_type = OP_PADAV;
5109 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5110 return ref(o, OP_RV2AV);
5113 o->op_type = OP_RV2AV;
5114 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5119 if (ckWARN_d(WARN_INTERNAL))
5120 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5127 Perl_oopsHV(pTHX_ OP *o)
5129 switch (o->op_type) {
5132 o->op_type = OP_PADHV;
5133 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5134 return ref(o, OP_RV2HV);
5138 o->op_type = OP_RV2HV;
5139 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5144 if (ckWARN_d(WARN_INTERNAL))
5145 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5152 Perl_newAVREF(pTHX_ OP *o)
5154 if (o->op_type == OP_PADANY) {
5155 o->op_type = OP_PADAV;
5156 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5159 return newUNOP(OP_RV2AV, 0, scalar(o));
5163 Perl_newGVREF(pTHX_ I32 type, OP *o)
5165 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5166 return newUNOP(OP_NULL, 0, o);
5167 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5171 Perl_newHVREF(pTHX_ OP *o)
5173 if (o->op_type == OP_PADANY) {
5174 o->op_type = OP_PADHV;
5175 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5178 return newUNOP(OP_RV2HV, 0, scalar(o));
5182 Perl_oopsCV(pTHX_ OP *o)
5184 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5190 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5192 return newUNOP(OP_RV2CV, flags, scalar(o));
5196 Perl_newSVREF(pTHX_ OP *o)
5198 if (o->op_type == OP_PADANY) {
5199 o->op_type = OP_PADSV;
5200 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5203 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5204 o->op_flags |= OPpDONE_SVREF;
5207 return newUNOP(OP_RV2SV, 0, scalar(o));
5210 /* Check routines. */
5213 Perl_ck_anoncode(pTHX_ OP *o)
5218 name = NEWSV(1106,0);
5219 sv_upgrade(name, SVt_PVNV);
5220 sv_setpvn(name, "&", 1);
5223 ix = pad_alloc(o->op_type, SVs_PADMY);
5224 av_store(PL_comppad_name, ix, name);
5225 av_store(PL_comppad, ix, cSVOPo->op_sv);
5226 SvPADMY_on(cSVOPo->op_sv);
5227 cSVOPo->op_sv = Nullsv;
5228 cSVOPo->op_targ = ix;
5233 Perl_ck_bitop(pTHX_ OP *o)
5235 o->op_private = PL_hints;
5240 Perl_ck_concat(pTHX_ OP *o)
5242 if (cUNOPo->op_first->op_type == OP_CONCAT)
5243 o->op_flags |= OPf_STACKED;
5248 Perl_ck_spair(pTHX_ OP *o)
5250 if (o->op_flags & OPf_KIDS) {
5253 OPCODE type = o->op_type;
5254 o = modkids(ck_fun(o), type);
5255 kid = cUNOPo->op_first;
5256 newop = kUNOP->op_first->op_sibling;
5258 (newop->op_sibling ||
5259 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5260 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5261 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5265 op_free(kUNOP->op_first);
5266 kUNOP->op_first = newop;
5268 o->op_ppaddr = PL_ppaddr[++o->op_type];
5273 Perl_ck_delete(pTHX_ OP *o)
5277 if (o->op_flags & OPf_KIDS) {
5278 OP *kid = cUNOPo->op_first;
5279 switch (kid->op_type) {
5281 o->op_flags |= OPf_SPECIAL;
5284 o->op_private |= OPpSLICE;
5287 o->op_flags |= OPf_SPECIAL;
5292 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5293 PL_op_desc[o->op_type]);
5301 Perl_ck_eof(pTHX_ OP *o)
5303 I32 type = o->op_type;
5305 if (o->op_flags & OPf_KIDS) {
5306 if (cLISTOPo->op_first->op_type == OP_STUB) {
5308 o = newUNOP(type, OPf_SPECIAL,
5309 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5317 Perl_ck_eval(pTHX_ OP *o)
5319 PL_hints |= HINT_BLOCK_SCOPE;
5320 if (o->op_flags & OPf_KIDS) {
5321 SVOP *kid = (SVOP*)cUNOPo->op_first;
5324 o->op_flags &= ~OPf_KIDS;
5327 else if (kid->op_type == OP_LINESEQ) {
5330 kid->op_next = o->op_next;
5331 cUNOPo->op_first = 0;
5334 NewOp(1101, enter, 1, LOGOP);
5335 enter->op_type = OP_ENTERTRY;
5336 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5337 enter->op_private = 0;
5339 /* establish postfix order */
5340 enter->op_next = (OP*)enter;
5342 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5343 o->op_type = OP_LEAVETRY;
5344 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5345 enter->op_other = o;
5353 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5355 o->op_targ = (PADOFFSET)PL_hints;
5360 Perl_ck_exit(pTHX_ OP *o)
5363 HV *table = GvHV(PL_hintgv);
5365 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5366 if (svp && *svp && SvTRUE(*svp))
5367 o->op_private |= OPpEXIT_VMSISH;
5374 Perl_ck_exec(pTHX_ OP *o)
5377 if (o->op_flags & OPf_STACKED) {
5379 kid = cUNOPo->op_first->op_sibling;
5380 if (kid->op_type == OP_RV2GV)
5389 Perl_ck_exists(pTHX_ OP *o)
5392 if (o->op_flags & OPf_KIDS) {
5393 OP *kid = cUNOPo->op_first;
5394 if (kid->op_type == OP_ENTERSUB) {
5395 (void) ref(kid, o->op_type);
5396 if (kid->op_type != OP_RV2CV && !PL_error_count)
5397 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5398 PL_op_desc[o->op_type]);
5399 o->op_private |= OPpEXISTS_SUB;
5401 else if (kid->op_type == OP_AELEM)
5402 o->op_flags |= OPf_SPECIAL;
5403 else if (kid->op_type != OP_HELEM)
5404 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5405 PL_op_desc[o->op_type]);
5413 Perl_ck_gvconst(pTHX_ register OP *o)
5415 o = fold_constants(o);
5416 if (o->op_type == OP_CONST)
5423 Perl_ck_rvconst(pTHX_ register OP *o)
5425 SVOP *kid = (SVOP*)cUNOPo->op_first;
5427 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5428 if (kid->op_type == OP_CONST) {
5432 SV *kidsv = kid->op_sv;
5435 /* Is it a constant from cv_const_sv()? */
5436 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5437 SV *rsv = SvRV(kidsv);
5438 int svtype = SvTYPE(rsv);
5439 char *badtype = Nullch;
5441 switch (o->op_type) {
5443 if (svtype > SVt_PVMG)
5444 badtype = "a SCALAR";
5447 if (svtype != SVt_PVAV)
5448 badtype = "an ARRAY";
5451 if (svtype != SVt_PVHV) {
5452 if (svtype == SVt_PVAV) { /* pseudohash? */
5453 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5454 if (ksv && SvROK(*ksv)
5455 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5464 if (svtype != SVt_PVCV)
5469 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5472 name = SvPV(kidsv, n_a);
5473 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5474 char *badthing = Nullch;
5475 switch (o->op_type) {
5477 badthing = "a SCALAR";
5480 badthing = "an ARRAY";
5483 badthing = "a HASH";
5488 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5492 * This is a little tricky. We only want to add the symbol if we
5493 * didn't add it in the lexer. Otherwise we get duplicate strict
5494 * warnings. But if we didn't add it in the lexer, we must at
5495 * least pretend like we wanted to add it even if it existed before,
5496 * or we get possible typo warnings. OPpCONST_ENTERED says
5497 * whether the lexer already added THIS instance of this symbol.
5499 iscv = (o->op_type == OP_RV2CV) * 2;
5501 gv = gv_fetchpv(name,
5502 iscv | !(kid->op_private & OPpCONST_ENTERED),
5505 : o->op_type == OP_RV2SV
5507 : o->op_type == OP_RV2AV
5509 : o->op_type == OP_RV2HV
5512 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5514 kid->op_type = OP_GV;
5515 SvREFCNT_dec(kid->op_sv);
5517 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5518 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5519 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5521 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5523 kid->op_sv = SvREFCNT_inc(gv);
5525 kid->op_private = 0;
5526 kid->op_ppaddr = PL_ppaddr[OP_GV];
5533 Perl_ck_ftst(pTHX_ OP *o)
5535 I32 type = o->op_type;
5537 if (o->op_flags & OPf_REF) {
5540 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5541 SVOP *kid = (SVOP*)cUNOPo->op_first;
5543 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5545 OP *newop = newGVOP(type, OPf_REF,
5546 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5553 if (type == OP_FTTTY)
5554 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5557 o = newUNOP(type, 0, newDEFSVOP());
5560 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5562 if (PL_hints & HINT_LOCALE)
5563 o->op_private |= OPpLOCALE;
5570 Perl_ck_fun(pTHX_ OP *o)
5576 int type = o->op_type;
5577 register I32 oa = PL_opargs[type] >> OASHIFT;
5579 if (o->op_flags & OPf_STACKED) {
5580 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5583 return no_fh_allowed(o);
5586 if (o->op_flags & OPf_KIDS) {
5588 tokid = &cLISTOPo->op_first;
5589 kid = cLISTOPo->op_first;
5590 if (kid->op_type == OP_PUSHMARK ||
5591 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5593 tokid = &kid->op_sibling;
5594 kid = kid->op_sibling;
5596 if (!kid && PL_opargs[type] & OA_DEFGV)
5597 *tokid = kid = newDEFSVOP();
5601 sibl = kid->op_sibling;
5604 /* list seen where single (scalar) arg expected? */
5605 if (numargs == 1 && !(oa >> 4)
5606 && kid->op_type == OP_LIST && type != OP_SCALAR)
5608 return too_many_arguments(o,PL_op_desc[type]);
5621 if (kid->op_type == OP_CONST &&
5622 (kid->op_private & OPpCONST_BARE))
5624 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5625 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5626 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5627 if (ckWARN(WARN_DEPRECATED))
5628 Perl_warner(aTHX_ WARN_DEPRECATED,
5629 "Array @%s missing the @ in argument %"IVdf" of %s()",
5630 name, (IV)numargs, PL_op_desc[type]);
5633 kid->op_sibling = sibl;
5636 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5637 bad_type(numargs, "array", PL_op_desc[type], kid);
5641 if (kid->op_type == OP_CONST &&
5642 (kid->op_private & OPpCONST_BARE))
5644 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5645 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5646 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5647 if (ckWARN(WARN_DEPRECATED))
5648 Perl_warner(aTHX_ WARN_DEPRECATED,
5649 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5650 name, (IV)numargs, PL_op_desc[type]);
5653 kid->op_sibling = sibl;
5656 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5657 bad_type(numargs, "hash", PL_op_desc[type], kid);
5662 OP *newop = newUNOP(OP_NULL, 0, kid);
5663 kid->op_sibling = 0;
5665 newop->op_next = newop;
5667 kid->op_sibling = sibl;
5672 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5673 if (kid->op_type == OP_CONST &&
5674 (kid->op_private & OPpCONST_BARE))
5676 OP *newop = newGVOP(OP_GV, 0,
5677 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5682 else if (kid->op_type == OP_READLINE) {
5683 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5684 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5687 I32 flags = OPf_SPECIAL;
5691 /* is this op a FH constructor? */
5692 if (is_handle_constructor(o,numargs)) {
5693 char *name = Nullch;
5697 /* Set a flag to tell rv2gv to vivify
5698 * need to "prove" flag does not mean something
5699 * else already - NI-S 1999/05/07
5702 if (kid->op_type == OP_PADSV) {
5703 SV **namep = av_fetch(PL_comppad_name,
5705 if (namep && *namep)
5706 name = SvPV(*namep, len);
5708 else if (kid->op_type == OP_RV2SV
5709 && kUNOP->op_first->op_type == OP_GV)
5711 GV *gv = cGVOPx_gv(kUNOP->op_first);
5713 len = GvNAMELEN(gv);
5715 else if (kid->op_type == OP_AELEM
5716 || kid->op_type == OP_HELEM)
5718 name = "__ANONIO__";
5724 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5725 namesv = PL_curpad[targ];
5726 (void)SvUPGRADE(namesv, SVt_PV);
5728 sv_setpvn(namesv, "$", 1);
5729 sv_catpvn(namesv, name, len);
5732 kid->op_sibling = 0;
5733 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5734 kid->op_targ = targ;
5735 kid->op_private |= priv;
5737 kid->op_sibling = sibl;
5743 mod(scalar(kid), type);
5747 tokid = &kid->op_sibling;
5748 kid = kid->op_sibling;
5750 o->op_private |= numargs;
5752 return too_many_arguments(o,PL_op_desc[o->op_type]);
5755 else if (PL_opargs[type] & OA_DEFGV) {
5757 return newUNOP(type, 0, newDEFSVOP());
5761 while (oa & OA_OPTIONAL)
5763 if (oa && oa != OA_LIST)
5764 return too_few_arguments(o,PL_op_desc[o->op_type]);
5770 Perl_ck_glob(pTHX_ OP *o)
5775 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5776 append_elem(OP_GLOB, o, newDEFSVOP());
5778 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5779 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5781 #if !defined(PERL_EXTERNAL_GLOB)
5782 /* XXX this can be tightened up and made more failsafe. */
5785 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5786 /* null-terminated import list */
5787 newSVpvn(":globally", 9), Nullsv);
5788 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5791 #endif /* PERL_EXTERNAL_GLOB */
5793 if (gv && GvIMPORTED_CV(gv)) {
5794 append_elem(OP_GLOB, o,
5795 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5796 o->op_type = OP_LIST;
5797 o->op_ppaddr = PL_ppaddr[OP_LIST];
5798 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5799 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5800 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5801 append_elem(OP_LIST, o,
5802 scalar(newUNOP(OP_RV2CV, 0,
5803 newGVOP(OP_GV, 0, gv)))));
5804 o = newUNOP(OP_NULL, 0, ck_subr(o));
5805 o->op_targ = OP_GLOB; /* hint at what it used to be */
5808 gv = newGVgen("main");
5810 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5816 Perl_ck_grep(pTHX_ OP *o)
5820 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5822 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5823 NewOp(1101, gwop, 1, LOGOP);
5825 if (o->op_flags & OPf_STACKED) {
5828 kid = cLISTOPo->op_first->op_sibling;
5829 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5832 kid->op_next = (OP*)gwop;
5833 o->op_flags &= ~OPf_STACKED;
5835 kid = cLISTOPo->op_first->op_sibling;
5836 if (type == OP_MAPWHILE)
5843 kid = cLISTOPo->op_first->op_sibling;
5844 if (kid->op_type != OP_NULL)
5845 Perl_croak(aTHX_ "panic: ck_grep");
5846 kid = kUNOP->op_first;
5848 gwop->op_type = type;
5849 gwop->op_ppaddr = PL_ppaddr[type];
5850 gwop->op_first = listkids(o);
5851 gwop->op_flags |= OPf_KIDS;
5852 gwop->op_private = 1;
5853 gwop->op_other = LINKLIST(kid);
5854 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5855 kid->op_next = (OP*)gwop;
5857 kid = cLISTOPo->op_first->op_sibling;
5858 if (!kid || !kid->op_sibling)
5859 return too_few_arguments(o,PL_op_desc[o->op_type]);
5860 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5861 mod(kid, OP_GREPSTART);
5867 Perl_ck_index(pTHX_ OP *o)
5869 if (o->op_flags & OPf_KIDS) {
5870 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5872 kid = kid->op_sibling; /* get past "big" */
5873 if (kid && kid->op_type == OP_CONST)
5874 fbm_compile(((SVOP*)kid)->op_sv, 0);
5880 Perl_ck_lengthconst(pTHX_ OP *o)
5882 /* XXX length optimization goes here */
5887 Perl_ck_lfun(pTHX_ OP *o)
5889 OPCODE type = o->op_type;
5890 return modkids(ck_fun(o), type);
5894 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5896 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5897 switch (cUNOPo->op_first->op_type) {
5899 /* This is needed for
5900 if (defined %stash::)
5901 to work. Do not break Tk.
5903 break; /* Globals via GV can be undef */
5905 case OP_AASSIGN: /* Is this a good idea? */
5906 Perl_warner(aTHX_ WARN_DEPRECATED,
5907 "defined(@array) is deprecated");
5908 Perl_warner(aTHX_ WARN_DEPRECATED,
5909 "\t(Maybe you should just omit the defined()?)\n");
5912 /* This is needed for
5913 if (defined %stash::)
5914 to work. Do not break Tk.
5916 break; /* Globals via GV can be undef */
5918 Perl_warner(aTHX_ WARN_DEPRECATED,
5919 "defined(%%hash) is deprecated");
5920 Perl_warner(aTHX_ WARN_DEPRECATED,
5921 "\t(Maybe you should just omit the defined()?)\n");
5932 Perl_ck_rfun(pTHX_ OP *o)
5934 OPCODE type = o->op_type;
5935 return refkids(ck_fun(o), type);
5939 Perl_ck_listiob(pTHX_ OP *o)
5943 kid = cLISTOPo->op_first;
5946 kid = cLISTOPo->op_first;
5948 if (kid->op_type == OP_PUSHMARK)
5949 kid = kid->op_sibling;
5950 if (kid && o->op_flags & OPf_STACKED)
5951 kid = kid->op_sibling;
5952 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5953 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5954 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5955 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5956 cLISTOPo->op_first->op_sibling = kid;
5957 cLISTOPo->op_last = kid;
5958 kid = kid->op_sibling;
5963 append_elem(o->op_type, o, newDEFSVOP());
5969 if (PL_hints & HINT_LOCALE)
5970 o->op_private |= OPpLOCALE;
5977 Perl_ck_fun_locale(pTHX_ OP *o)
5983 if (PL_hints & HINT_LOCALE)
5984 o->op_private |= OPpLOCALE;
5991 Perl_ck_sassign(pTHX_ OP *o)
5993 OP *kid = cLISTOPo->op_first;
5994 /* has a disposable target? */
5995 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5996 && !(kid->op_flags & OPf_STACKED)
5997 /* Cannot steal the second time! */
5998 && !(kid->op_private & OPpTARGET_MY))
6000 OP *kkid = kid->op_sibling;
6002 /* Can just relocate the target. */
6003 if (kkid && kkid->op_type == OP_PADSV
6004 && !(kkid->op_private & OPpLVAL_INTRO))
6006 kid->op_targ = kkid->op_targ;
6008 /* Now we do not need PADSV and SASSIGN. */
6009 kid->op_sibling = o->op_sibling; /* NULL */
6010 cLISTOPo->op_first = NULL;
6013 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6021 Perl_ck_scmp(pTHX_ OP *o)
6025 if (PL_hints & HINT_LOCALE)
6026 o->op_private |= OPpLOCALE;
6033 Perl_ck_match(pTHX_ OP *o)
6035 o->op_private |= OPpRUNTIME;
6040 Perl_ck_method(pTHX_ OP *o)
6042 OP *kid = cUNOPo->op_first;
6043 if (kid->op_type == OP_CONST) {
6044 SV* sv = kSVOP->op_sv;
6045 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6047 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6048 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6051 kSVOP->op_sv = Nullsv;
6053 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6062 Perl_ck_null(pTHX_ OP *o)
6068 Perl_ck_open(pTHX_ OP *o)
6070 HV *table = GvHV(PL_hintgv);
6074 svp = hv_fetch(table, "open_IN", 7, FALSE);
6076 mode = mode_from_discipline(*svp);
6077 if (mode & O_BINARY)
6078 o->op_private |= OPpOPEN_IN_RAW;
6079 else if (mode & O_TEXT)
6080 o->op_private |= OPpOPEN_IN_CRLF;
6083 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6085 mode = mode_from_discipline(*svp);
6086 if (mode & O_BINARY)
6087 o->op_private |= OPpOPEN_OUT_RAW;
6088 else if (mode & O_TEXT)
6089 o->op_private |= OPpOPEN_OUT_CRLF;
6092 if (o->op_type == OP_BACKTICK)
6098 Perl_ck_repeat(pTHX_ OP *o)
6100 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6101 o->op_private |= OPpREPEAT_DOLIST;
6102 cBINOPo->op_first = force_list(cBINOPo->op_first);
6110 Perl_ck_require(pTHX_ OP *o)
6112 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6113 SVOP *kid = (SVOP*)cUNOPo->op_first;
6115 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6117 for (s = SvPVX(kid->op_sv); *s; s++) {
6118 if (*s == ':' && s[1] == ':') {
6120 Move(s+2, s+1, strlen(s+2)+1, char);
6121 --SvCUR(kid->op_sv);
6124 if (SvREADONLY(kid->op_sv)) {
6125 SvREADONLY_off(kid->op_sv);
6126 sv_catpvn(kid->op_sv, ".pm", 3);
6127 SvREADONLY_on(kid->op_sv);
6130 sv_catpvn(kid->op_sv, ".pm", 3);
6137 Perl_ck_return(pTHX_ OP *o)
6140 if (CvLVALUE(PL_compcv)) {
6141 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6142 mod(kid, OP_LEAVESUBLV);
6149 Perl_ck_retarget(pTHX_ OP *o)
6151 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6158 Perl_ck_select(pTHX_ OP *o)
6161 if (o->op_flags & OPf_KIDS) {
6162 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6163 if (kid && kid->op_sibling) {
6164 o->op_type = OP_SSELECT;
6165 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6167 return fold_constants(o);
6171 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6172 if (kid && kid->op_type == OP_RV2GV)
6173 kid->op_private &= ~HINT_STRICT_REFS;
6178 Perl_ck_shift(pTHX_ OP *o)
6180 I32 type = o->op_type;
6182 if (!(o->op_flags & OPf_KIDS)) {
6187 if (!CvUNIQUE(PL_compcv)) {
6188 argop = newOP(OP_PADAV, OPf_REF);
6189 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6192 argop = newUNOP(OP_RV2AV, 0,
6193 scalar(newGVOP(OP_GV, 0,
6194 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6197 argop = newUNOP(OP_RV2AV, 0,
6198 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6199 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6200 #endif /* USE_THREADS */
6201 return newUNOP(type, 0, scalar(argop));
6203 return scalar(modkids(ck_fun(o), type));
6207 Perl_ck_sort(pTHX_ OP *o)
6212 if (PL_hints & HINT_LOCALE)
6213 o->op_private |= OPpLOCALE;
6216 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6218 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6219 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6221 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6223 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6225 if (kid->op_type == OP_SCOPE) {
6229 else if (kid->op_type == OP_LEAVE) {
6230 if (o->op_type == OP_SORT) {
6231 null(kid); /* wipe out leave */
6234 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6235 if (k->op_next == kid)
6237 /* don't descend into loops */
6238 else if (k->op_type == OP_ENTERLOOP
6239 || k->op_type == OP_ENTERITER)
6241 k = cLOOPx(k)->op_lastop;
6246 kid->op_next = 0; /* just disconnect the leave */
6247 k = kLISTOP->op_first;
6252 if (o->op_type == OP_SORT) {
6253 /* provide scalar context for comparison function/block */
6259 o->op_flags |= OPf_SPECIAL;
6261 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6264 firstkid = firstkid->op_sibling;
6267 /* provide list context for arguments */
6268 if (o->op_type == OP_SORT)
6275 S_simplify_sort(pTHX_ OP *o)
6277 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6281 if (!(o->op_flags & OPf_STACKED))
6283 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6284 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6285 kid = kUNOP->op_first; /* get past null */
6286 if (kid->op_type != OP_SCOPE)
6288 kid = kLISTOP->op_last; /* get past scope */
6289 switch(kid->op_type) {
6297 k = kid; /* remember this node*/
6298 if (kBINOP->op_first->op_type != OP_RV2SV)
6300 kid = kBINOP->op_first; /* get past cmp */
6301 if (kUNOP->op_first->op_type != OP_GV)
6303 kid = kUNOP->op_first; /* get past rv2sv */
6305 if (GvSTASH(gv) != PL_curstash)
6307 if (strEQ(GvNAME(gv), "a"))
6309 else if (strEQ(GvNAME(gv), "b"))
6313 kid = k; /* back to cmp */
6314 if (kBINOP->op_last->op_type != OP_RV2SV)
6316 kid = kBINOP->op_last; /* down to 2nd arg */
6317 if (kUNOP->op_first->op_type != OP_GV)
6319 kid = kUNOP->op_first; /* get past rv2sv */
6321 if (GvSTASH(gv) != PL_curstash
6323 ? strNE(GvNAME(gv), "a")
6324 : strNE(GvNAME(gv), "b")))
6326 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6328 o->op_private |= OPpSORT_REVERSE;
6329 if (k->op_type == OP_NCMP)
6330 o->op_private |= OPpSORT_NUMERIC;
6331 if (k->op_type == OP_I_NCMP)
6332 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6333 kid = cLISTOPo->op_first->op_sibling;
6334 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6335 op_free(kid); /* then delete it */
6339 Perl_ck_split(pTHX_ OP *o)
6343 if (o->op_flags & OPf_STACKED)
6344 return no_fh_allowed(o);
6346 kid = cLISTOPo->op_first;
6347 if (kid->op_type != OP_NULL)
6348 Perl_croak(aTHX_ "panic: ck_split");
6349 kid = kid->op_sibling;
6350 op_free(cLISTOPo->op_first);
6351 cLISTOPo->op_first = kid;
6353 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6354 cLISTOPo->op_last = kid; /* There was only one element previously */
6357 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6358 OP *sibl = kid->op_sibling;
6359 kid->op_sibling = 0;
6360 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6361 if (cLISTOPo->op_first == cLISTOPo->op_last)
6362 cLISTOPo->op_last = kid;
6363 cLISTOPo->op_first = kid;
6364 kid->op_sibling = sibl;
6367 kid->op_type = OP_PUSHRE;
6368 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6371 if (!kid->op_sibling)
6372 append_elem(OP_SPLIT, o, newDEFSVOP());
6374 kid = kid->op_sibling;
6377 if (!kid->op_sibling)
6378 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6380 kid = kid->op_sibling;
6383 if (kid->op_sibling)
6384 return too_many_arguments(o,PL_op_desc[o->op_type]);
6390 Perl_ck_join(pTHX_ OP *o)
6392 if (ckWARN(WARN_SYNTAX)) {
6393 OP *kid = cLISTOPo->op_first->op_sibling;
6394 if (kid && kid->op_type == OP_MATCH) {
6395 char *pmstr = "STRING";
6396 if (kPMOP->op_pmregexp)
6397 pmstr = kPMOP->op_pmregexp->precomp;
6398 Perl_warner(aTHX_ WARN_SYNTAX,
6399 "/%s/ should probably be written as \"%s\"",
6407 Perl_ck_subr(pTHX_ OP *o)
6409 OP *prev = ((cUNOPo->op_first->op_sibling)
6410 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6411 OP *o2 = prev->op_sibling;
6420 o->op_private |= OPpENTERSUB_HASTARG;
6421 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6422 if (cvop->op_type == OP_RV2CV) {
6424 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6425 null(cvop); /* disable rv2cv */
6426 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6427 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6428 GV *gv = cGVOPx_gv(tmpop);
6431 tmpop->op_private |= OPpEARLY_CV;
6432 else if (SvPOK(cv)) {
6433 namegv = CvANON(cv) ? gv : CvGV(cv);
6434 proto = SvPV((SV*)cv, n_a);
6438 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6439 if (o2->op_type == OP_CONST)
6440 o2->op_private &= ~OPpCONST_STRICT;
6441 else if (o2->op_type == OP_LIST) {
6442 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6443 if (o && o->op_type == OP_CONST)
6444 o->op_private &= ~OPpCONST_STRICT;
6447 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6448 if (PERLDB_SUB && PL_curstash != PL_debstash)
6449 o->op_private |= OPpENTERSUB_DB;
6450 while (o2 != cvop) {
6454 return too_many_arguments(o, gv_ename(namegv));
6472 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6474 arg == 1 ? "block or sub {}" : "sub {}",
6475 gv_ename(namegv), o2);
6478 /* '*' allows any scalar type, including bareword */
6481 if (o2->op_type == OP_RV2GV)
6482 goto wrapref; /* autoconvert GLOB -> GLOBref */
6483 else if (o2->op_type == OP_CONST)
6484 o2->op_private &= ~OPpCONST_STRICT;
6485 else if (o2->op_type == OP_ENTERSUB) {
6486 /* accidental subroutine, revert to bareword */
6487 OP *gvop = ((UNOP*)o2)->op_first;
6488 if (gvop && gvop->op_type == OP_NULL) {
6489 gvop = ((UNOP*)gvop)->op_first;
6491 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6494 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6495 (gvop = ((UNOP*)gvop)->op_first) &&
6496 gvop->op_type == OP_GV)
6498 GV *gv = cGVOPx_gv(gvop);
6499 OP *sibling = o2->op_sibling;
6500 SV *n = newSVpvn("",0);
6502 gv_fullname3(n, gv, "");
6503 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6504 sv_chop(n, SvPVX(n)+6);
6505 o2 = newSVOP(OP_CONST, 0, n);
6506 prev->op_sibling = o2;
6507 o2->op_sibling = sibling;
6519 if (o2->op_type != OP_RV2GV)
6520 bad_type(arg, "symbol", gv_ename(namegv), o2);
6523 if (o2->op_type != OP_ENTERSUB)
6524 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6527 if (o2->op_type != OP_RV2SV
6528 && o2->op_type != OP_PADSV
6529 && o2->op_type != OP_HELEM
6530 && o2->op_type != OP_AELEM
6531 && o2->op_type != OP_THREADSV)
6533 bad_type(arg, "scalar", gv_ename(namegv), o2);
6537 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6538 bad_type(arg, "array", gv_ename(namegv), o2);
6541 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6542 bad_type(arg, "hash", gv_ename(namegv), o2);
6546 OP* sib = kid->op_sibling;
6547 kid->op_sibling = 0;
6548 o2 = newUNOP(OP_REFGEN, 0, kid);
6549 o2->op_sibling = sib;
6550 prev->op_sibling = o2;
6561 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6562 gv_ename(namegv), SvPV((SV*)cv, n_a));
6567 mod(o2, OP_ENTERSUB);
6569 o2 = o2->op_sibling;
6571 if (proto && !optional &&
6572 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6573 return too_few_arguments(o, gv_ename(namegv));
6578 Perl_ck_svconst(pTHX_ OP *o)
6580 SvREADONLY_on(cSVOPo->op_sv);
6585 Perl_ck_trunc(pTHX_ OP *o)
6587 if (o->op_flags & OPf_KIDS) {
6588 SVOP *kid = (SVOP*)cUNOPo->op_first;
6590 if (kid->op_type == OP_NULL)
6591 kid = (SVOP*)kid->op_sibling;
6592 if (kid && kid->op_type == OP_CONST &&
6593 (kid->op_private & OPpCONST_BARE))
6595 o->op_flags |= OPf_SPECIAL;
6596 kid->op_private &= ~OPpCONST_STRICT;
6603 Perl_ck_substr(pTHX_ OP *o)
6606 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6607 OP *kid = cLISTOPo->op_first;
6609 if (kid->op_type == OP_NULL)
6610 kid = kid->op_sibling;
6612 kid->op_flags |= OPf_MOD;
6618 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6621 Perl_peep(pTHX_ register OP *o)
6623 register OP* oldop = 0;
6626 if (!o || o->op_seq)
6630 SAVEVPTR(PL_curcop);
6631 for (; o; o = o->op_next) {
6637 switch (o->op_type) {
6641 PL_curcop = ((COP*)o); /* for warnings */
6642 o->op_seq = PL_op_seqmax++;
6646 if (cSVOPo->op_private & OPpCONST_STRICT)
6647 no_bareword_allowed(o);
6649 /* Relocate sv to the pad for thread safety.
6650 * Despite being a "constant", the SV is written to,
6651 * for reference counts, sv_upgrade() etc. */
6653 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6654 if (SvPADTMP(cSVOPo->op_sv)) {
6655 /* If op_sv is already a PADTMP then it is being used by
6656 * some pad, so make a copy. */
6657 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6658 SvREADONLY_on(PL_curpad[ix]);
6659 SvREFCNT_dec(cSVOPo->op_sv);
6662 SvREFCNT_dec(PL_curpad[ix]);
6663 SvPADTMP_on(cSVOPo->op_sv);
6664 PL_curpad[ix] = cSVOPo->op_sv;
6665 /* XXX I don't know how this isn't readonly already. */
6666 SvREADONLY_on(PL_curpad[ix]);
6668 cSVOPo->op_sv = Nullsv;
6672 o->op_seq = PL_op_seqmax++;
6676 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6677 if (o->op_next->op_private & OPpTARGET_MY) {
6678 if (o->op_flags & OPf_STACKED) /* chained concats */
6679 goto ignore_optimization;
6681 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6682 o->op_targ = o->op_next->op_targ;
6683 o->op_next->op_targ = 0;
6684 o->op_private |= OPpTARGET_MY;
6689 ignore_optimization:
6690 o->op_seq = PL_op_seqmax++;
6693 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6694 o->op_seq = PL_op_seqmax++;
6695 break; /* Scalar stub must produce undef. List stub is noop */
6699 if (o->op_targ == OP_NEXTSTATE
6700 || o->op_targ == OP_DBSTATE
6701 || o->op_targ == OP_SETSTATE)
6703 PL_curcop = ((COP*)o);
6710 if (oldop && o->op_next) {
6711 oldop->op_next = o->op_next;
6714 o->op_seq = PL_op_seqmax++;
6718 if (o->op_next->op_type == OP_RV2SV) {
6719 if (!(o->op_next->op_private & OPpDEREF)) {
6721 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6723 o->op_next = o->op_next->op_next;
6724 o->op_type = OP_GVSV;
6725 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6728 else if (o->op_next->op_type == OP_RV2AV) {
6729 OP* pop = o->op_next->op_next;
6731 if (pop->op_type == OP_CONST &&
6732 (PL_op = pop->op_next) &&
6733 pop->op_next->op_type == OP_AELEM &&
6734 !(pop->op_next->op_private &
6735 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6736 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6744 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6745 o->op_next = pop->op_next->op_next;
6746 o->op_type = OP_AELEMFAST;
6747 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6748 o->op_private = (U8)i;
6753 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6755 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6756 /* XXX could check prototype here instead of just carping */
6757 SV *sv = sv_newmortal();
6758 gv_efullname3(sv, gv, Nullch);
6759 Perl_warner(aTHX_ WARN_PROTOTYPE,
6760 "%s() called too early to check prototype",
6765 o->op_seq = PL_op_seqmax++;
6776 o->op_seq = PL_op_seqmax++;
6777 while (cLOGOP->op_other->op_type == OP_NULL)
6778 cLOGOP->op_other = cLOGOP->op_other->op_next;
6779 peep(cLOGOP->op_other);
6783 o->op_seq = PL_op_seqmax++;
6784 while (cLOOP->op_redoop->op_type == OP_NULL)
6785 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6786 peep(cLOOP->op_redoop);
6787 while (cLOOP->op_nextop->op_type == OP_NULL)
6788 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6789 peep(cLOOP->op_nextop);
6790 while (cLOOP->op_lastop->op_type == OP_NULL)
6791 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6792 peep(cLOOP->op_lastop);
6798 o->op_seq = PL_op_seqmax++;
6799 while (cPMOP->op_pmreplstart &&
6800 cPMOP->op_pmreplstart->op_type == OP_NULL)
6801 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6802 peep(cPMOP->op_pmreplstart);
6806 o->op_seq = PL_op_seqmax++;
6807 if (ckWARN(WARN_SYNTAX) && o->op_next
6808 && o->op_next->op_type == OP_NEXTSTATE) {
6809 if (o->op_next->op_sibling &&
6810 o->op_next->op_sibling->op_type != OP_EXIT &&
6811 o->op_next->op_sibling->op_type != OP_WARN &&
6812 o->op_next->op_sibling->op_type != OP_DIE) {
6813 line_t oldline = CopLINE(PL_curcop);
6815 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6816 Perl_warner(aTHX_ WARN_EXEC,
6817 "Statement unlikely to be reached");
6818 Perl_warner(aTHX_ WARN_EXEC,
6819 "\t(Maybe you meant system() when you said exec()?)\n");
6820 CopLINE_set(PL_curcop, oldline);
6829 SV **svp, **indsvp, *sv;
6834 o->op_seq = PL_op_seqmax++;
6836 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6839 /* Make the CONST have a shared SV */
6840 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6841 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6842 key = SvPV(sv, keylen);
6845 lexname = newSVpvn_share(key, keylen, 0);
6850 if ((o->op_private & (OPpLVAL_INTRO)))
6853 rop = (UNOP*)((BINOP*)o)->op_first;
6854 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6856 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6857 if (!SvOBJECT(lexname))
6859 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6860 if (!fields || !GvHV(*fields))
6862 key = SvPV(*svp, keylen);
6865 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6867 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6868 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6870 ind = SvIV(*indsvp);
6872 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6873 rop->op_type = OP_RV2AV;
6874 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6875 o->op_type = OP_AELEM;
6876 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6878 if (SvREADONLY(*svp))
6880 SvFLAGS(sv) |= (SvFLAGS(*svp)
6881 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6891 SV **svp, **indsvp, *sv;
6895 SVOP *first_key_op, *key_op;
6897 o->op_seq = PL_op_seqmax++;
6898 if ((o->op_private & (OPpLVAL_INTRO))
6899 /* I bet there's always a pushmark... */
6900 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6901 /* hmmm, no optimization if list contains only one key. */
6903 rop = (UNOP*)((LISTOP*)o)->op_last;
6904 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6906 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6907 if (!SvOBJECT(lexname))
6909 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6910 if (!fields || !GvHV(*fields))
6912 /* Again guessing that the pushmark can be jumped over.... */
6913 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6914 ->op_first->op_sibling;
6915 /* Check that the key list contains only constants. */
6916 for (key_op = first_key_op; key_op;
6917 key_op = (SVOP*)key_op->op_sibling)
6918 if (key_op->op_type != OP_CONST)
6922 rop->op_type = OP_RV2AV;
6923 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6924 o->op_type = OP_ASLICE;
6925 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6926 for (key_op = first_key_op; key_op;
6927 key_op = (SVOP*)key_op->op_sibling) {
6928 svp = cSVOPx_svp(key_op);
6929 key = SvPV(*svp, keylen);
6932 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6934 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6935 "in variable %s of type %s",
6936 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6938 ind = SvIV(*indsvp);
6940 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6942 if (SvREADONLY(*svp))
6944 SvFLAGS(sv) |= (SvFLAGS(*svp)
6945 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6953 o->op_seq = PL_op_seqmax++;
6963 /* Efficient sub that returns a constant scalar value. */
6965 const_sv_xsub(pTHXo_ CV* cv)
6970 Perl_croak(aTHX_ "usage: %s::%s()",
6971 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6975 ST(0) = (SV*)XSANY.any_ptr;