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 /* CHECKME: Use unicode code points for ranges - needs more thought ... NI-S */
2712 UV val = utf8n_to_uvuni(s, cur, &ulen, 0);
2714 diff = val - nextmin;
2716 t = uvuni_to_utf8(tmpbuf,nextmin);
2717 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2719 t = uvuni_to_utf8(tmpbuf, val - 1);
2720 sv_catpvn(transv, "\377", 1);
2721 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2724 if (s < tend && *s == 0xff)
2725 val = utf8n_to_uvuni(s+1, cur - 1, &ulen, 0);
2729 t = uvuni_to_utf8(tmpbuf,nextmin);
2730 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2731 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2732 sv_catpvn(transv, "\377", 1);
2733 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2734 t = (U8*)SvPVX(transv);
2735 tlen = SvCUR(transv);
2739 else if (!rlen && !del) {
2740 r = t; rlen = tlen; rend = tend;
2744 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2746 o->op_private |= OPpTRANS_IDENTICAL;
2750 while (t < tend || tfirst <= tlast) {
2751 /* see if we need more "t" chars */
2752 if (tfirst > tlast) {
2753 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2755 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2757 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2764 /* now see if we need more "r" chars */
2765 if (rfirst > rlast) {
2767 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2769 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2771 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2780 rfirst = rlast = 0xffffffff;
2784 /* now see which range will peter our first, if either. */
2785 tdiff = tlast - tfirst;
2786 rdiff = rlast - rfirst;
2793 if (rfirst == 0xffffffff) {
2794 diff = tdiff; /* oops, pretend rdiff is infinite */
2796 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2797 (long)tfirst, (long)tlast);
2799 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2803 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2804 (long)tfirst, (long)(tfirst + diff),
2807 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2808 (long)tfirst, (long)rfirst);
2810 if (rfirst + diff > max)
2811 max = rfirst + diff;
2814 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2825 else if (max > 0xff)
2830 Safefree(cPVOPo->op_pv);
2831 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2832 SvREFCNT_dec(listsv);
2834 SvREFCNT_dec(transv);
2836 if (!del && havefinal)
2837 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2838 newSVuv((UV)final), 0);
2841 o->op_private |= OPpTRANS_GROWS;
2853 tbl = (short*)cPVOPo->op_pv;
2855 Zero(tbl, 256, short);
2856 for (i = 0; i < tlen; i++)
2858 for (i = 0, j = 0; i < 256; i++) {
2869 if (i < 128 && r[j] >= 128)
2879 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2880 tbl[0x100] = rlen - j;
2881 for (i=0; i < rlen - j; i++)
2882 tbl[0x101+i] = r[j+i];
2886 if (!rlen && !del) {
2889 o->op_private |= OPpTRANS_IDENTICAL;
2891 for (i = 0; i < 256; i++)
2893 for (i = 0, j = 0; i < tlen; i++,j++) {
2896 if (tbl[t[i]] == -1)
2902 if (tbl[t[i]] == -1) {
2903 if (t[i] < 128 && r[j] >= 128)
2910 o->op_private |= OPpTRANS_GROWS;
2918 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2922 NewOp(1101, pmop, 1, PMOP);
2923 pmop->op_type = type;
2924 pmop->op_ppaddr = PL_ppaddr[type];
2925 pmop->op_flags = flags;
2926 pmop->op_private = 0 | (flags >> 8);
2928 if (PL_hints & HINT_RE_TAINT)
2929 pmop->op_pmpermflags |= PMf_RETAINT;
2930 if (PL_hints & HINT_LOCALE)
2931 pmop->op_pmpermflags |= PMf_LOCALE;
2932 pmop->op_pmflags = pmop->op_pmpermflags;
2934 /* link into pm list */
2935 if (type != OP_TRANS && PL_curstash) {
2936 pmop->op_pmnext = HvPMROOT(PL_curstash);
2937 HvPMROOT(PL_curstash) = pmop;
2944 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2948 I32 repl_has_vars = 0;
2950 if (o->op_type == OP_TRANS)
2951 return pmtrans(o, expr, repl);
2953 PL_hints |= HINT_BLOCK_SCOPE;
2956 if (expr->op_type == OP_CONST) {
2958 SV *pat = ((SVOP*)expr)->op_sv;
2959 char *p = SvPV(pat, plen);
2960 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2961 sv_setpvn(pat, "\\s+", 3);
2962 p = SvPV(pat, plen);
2963 pm->op_pmflags |= PMf_SKIPWHITE;
2965 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2966 pm->op_pmdynflags |= PMdf_UTF8;
2967 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2968 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2969 pm->op_pmflags |= PMf_WHITE;
2973 if (PL_hints & HINT_UTF8)
2974 pm->op_pmdynflags |= PMdf_UTF8;
2975 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2976 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2978 : OP_REGCMAYBE),0,expr);
2980 NewOp(1101, rcop, 1, LOGOP);
2981 rcop->op_type = OP_REGCOMP;
2982 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2983 rcop->op_first = scalar(expr);
2984 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2985 ? (OPf_SPECIAL | OPf_KIDS)
2987 rcop->op_private = 1;
2990 /* establish postfix order */
2991 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2993 rcop->op_next = expr;
2994 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2997 rcop->op_next = LINKLIST(expr);
2998 expr->op_next = (OP*)rcop;
3001 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3006 if (pm->op_pmflags & PMf_EVAL) {
3008 if (CopLINE(PL_curcop) < PL_multi_end)
3009 CopLINE_set(PL_curcop, PL_multi_end);
3012 else if (repl->op_type == OP_THREADSV
3013 && strchr("&`'123456789+",
3014 PL_threadsv_names[repl->op_targ]))
3018 #endif /* USE_THREADS */
3019 else if (repl->op_type == OP_CONST)
3023 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3024 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3026 if (curop->op_type == OP_THREADSV) {
3028 if (strchr("&`'123456789+", curop->op_private))
3032 if (curop->op_type == OP_GV) {
3033 GV *gv = cGVOPx_gv(curop);
3035 if (strchr("&`'123456789+", *GvENAME(gv)))
3038 #endif /* USE_THREADS */
3039 else if (curop->op_type == OP_RV2CV)
3041 else if (curop->op_type == OP_RV2SV ||
3042 curop->op_type == OP_RV2AV ||
3043 curop->op_type == OP_RV2HV ||
3044 curop->op_type == OP_RV2GV) {
3045 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3048 else if (curop->op_type == OP_PADSV ||
3049 curop->op_type == OP_PADAV ||
3050 curop->op_type == OP_PADHV ||
3051 curop->op_type == OP_PADANY) {
3054 else if (curop->op_type == OP_PUSHRE)
3055 ; /* Okay here, dangerous in newASSIGNOP */
3064 && (!pm->op_pmregexp
3065 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3066 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3067 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3068 prepend_elem(o->op_type, scalar(repl), o);
3071 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3072 pm->op_pmflags |= PMf_MAYBE_CONST;
3073 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3075 NewOp(1101, rcop, 1, LOGOP);
3076 rcop->op_type = OP_SUBSTCONT;
3077 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3078 rcop->op_first = scalar(repl);
3079 rcop->op_flags |= OPf_KIDS;
3080 rcop->op_private = 1;
3083 /* establish postfix order */
3084 rcop->op_next = LINKLIST(repl);
3085 repl->op_next = (OP*)rcop;
3087 pm->op_pmreplroot = scalar((OP*)rcop);
3088 pm->op_pmreplstart = LINKLIST(rcop);
3097 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3100 NewOp(1101, svop, 1, SVOP);
3101 svop->op_type = type;
3102 svop->op_ppaddr = PL_ppaddr[type];
3104 svop->op_next = (OP*)svop;
3105 svop->op_flags = flags;
3106 if (PL_opargs[type] & OA_RETSCALAR)
3108 if (PL_opargs[type] & OA_TARGET)
3109 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3110 return CHECKOP(type, svop);
3114 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3117 NewOp(1101, padop, 1, PADOP);
3118 padop->op_type = type;
3119 padop->op_ppaddr = PL_ppaddr[type];
3120 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3121 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3122 PL_curpad[padop->op_padix] = sv;
3124 padop->op_next = (OP*)padop;
3125 padop->op_flags = flags;
3126 if (PL_opargs[type] & OA_RETSCALAR)
3128 if (PL_opargs[type] & OA_TARGET)
3129 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3130 return CHECKOP(type, padop);
3134 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3138 return newPADOP(type, flags, SvREFCNT_inc(gv));
3140 return newSVOP(type, flags, SvREFCNT_inc(gv));
3145 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3148 NewOp(1101, pvop, 1, PVOP);
3149 pvop->op_type = type;
3150 pvop->op_ppaddr = PL_ppaddr[type];
3152 pvop->op_next = (OP*)pvop;
3153 pvop->op_flags = flags;
3154 if (PL_opargs[type] & OA_RETSCALAR)
3156 if (PL_opargs[type] & OA_TARGET)
3157 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3158 return CHECKOP(type, pvop);
3162 Perl_package(pTHX_ OP *o)
3166 save_hptr(&PL_curstash);
3167 save_item(PL_curstname);
3172 name = SvPV(sv, len);
3173 PL_curstash = gv_stashpvn(name,len,TRUE);
3174 sv_setpvn(PL_curstname, name, len);
3178 sv_setpv(PL_curstname,"<none>");
3179 PL_curstash = Nullhv;
3181 PL_hints |= HINT_BLOCK_SCOPE;
3182 PL_copline = NOLINE;
3187 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3195 if (id->op_type != OP_CONST)
3196 Perl_croak(aTHX_ "Module name must be constant");
3200 if (version != Nullop) {
3201 SV *vesv = ((SVOP*)version)->op_sv;
3203 if (arg == Nullop && !SvNIOKp(vesv)) {
3210 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3211 Perl_croak(aTHX_ "Version number must be constant number");
3213 /* Make copy of id so we don't free it twice */
3214 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3216 /* Fake up a method call to VERSION */
3217 meth = newSVpvn("VERSION",7);
3218 sv_upgrade(meth, SVt_PVIV);
3219 (void)SvIOK_on(meth);
3220 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3221 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3222 append_elem(OP_LIST,
3223 prepend_elem(OP_LIST, pack, list(version)),
3224 newSVOP(OP_METHOD_NAMED, 0, meth)));
3228 /* Fake up an import/unimport */
3229 if (arg && arg->op_type == OP_STUB)
3230 imop = arg; /* no import on explicit () */
3231 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3232 imop = Nullop; /* use 5.0; */
3237 /* Make copy of id so we don't free it twice */
3238 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3240 /* Fake up a method call to import/unimport */
3241 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3242 sv_upgrade(meth, SVt_PVIV);
3243 (void)SvIOK_on(meth);
3244 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3245 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3246 append_elem(OP_LIST,
3247 prepend_elem(OP_LIST, pack, list(arg)),
3248 newSVOP(OP_METHOD_NAMED, 0, meth)));
3251 /* Fake up a require, handle override, if any */
3252 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3253 if (!(gv && GvIMPORTED_CV(gv)))
3254 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3256 if (gv && GvIMPORTED_CV(gv)) {
3257 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3258 append_elem(OP_LIST, id,
3259 scalar(newUNOP(OP_RV2CV, 0,
3264 rqop = newUNOP(OP_REQUIRE, 0, id);
3267 /* Fake up the BEGIN {}, which does its thing immediately. */
3269 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3272 append_elem(OP_LINESEQ,
3273 append_elem(OP_LINESEQ,
3274 newSTATEOP(0, Nullch, rqop),
3275 newSTATEOP(0, Nullch, veop)),
3276 newSTATEOP(0, Nullch, imop) ));
3278 PL_hints |= HINT_BLOCK_SCOPE;
3279 PL_copline = NOLINE;
3284 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3287 va_start(args, ver);
3288 vload_module(flags, name, ver, &args);
3292 #ifdef PERL_IMPLICIT_CONTEXT
3294 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3298 va_start(args, ver);
3299 vload_module(flags, name, ver, &args);
3305 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3307 OP *modname, *veop, *imop;
3309 modname = newSVOP(OP_CONST, 0, name);
3310 modname->op_private |= OPpCONST_BARE;
3312 veop = newSVOP(OP_CONST, 0, ver);
3316 if (flags & PERL_LOADMOD_NOIMPORT) {
3317 imop = sawparens(newNULLLIST());
3319 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3320 imop = va_arg(*args, OP*);
3325 sv = va_arg(*args, SV*);
3327 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3328 sv = va_arg(*args, SV*);
3332 line_t ocopline = PL_copline;
3333 int oexpect = PL_expect;
3335 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3336 veop, modname, imop);
3337 PL_expect = oexpect;
3338 PL_copline = ocopline;
3343 Perl_dofile(pTHX_ OP *term)
3348 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3349 if (!(gv && GvIMPORTED_CV(gv)))
3350 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3352 if (gv && GvIMPORTED_CV(gv)) {
3353 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3354 append_elem(OP_LIST, term,
3355 scalar(newUNOP(OP_RV2CV, 0,
3360 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3366 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3368 return newBINOP(OP_LSLICE, flags,
3369 list(force_list(subscript)),
3370 list(force_list(listval)) );
3374 S_list_assignment(pTHX_ register OP *o)
3379 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3380 o = cUNOPo->op_first;
3382 if (o->op_type == OP_COND_EXPR) {
3383 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3384 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3389 yyerror("Assignment to both a list and a scalar");
3393 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3394 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3395 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3398 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3401 if (o->op_type == OP_RV2SV)
3408 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3413 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3414 return newLOGOP(optype, 0,
3415 mod(scalar(left), optype),
3416 newUNOP(OP_SASSIGN, 0, scalar(right)));
3419 return newBINOP(optype, OPf_STACKED,
3420 mod(scalar(left), optype), scalar(right));
3424 if (list_assignment(left)) {
3428 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3429 left = mod(left, OP_AASSIGN);
3437 curop = list(force_list(left));
3438 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3439 o->op_private = 0 | (flags >> 8);
3440 for (curop = ((LISTOP*)curop)->op_first;
3441 curop; curop = curop->op_sibling)
3443 if (curop->op_type == OP_RV2HV &&
3444 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3445 o->op_private |= OPpASSIGN_HASH;
3449 if (!(left->op_private & OPpLVAL_INTRO)) {
3452 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3453 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3454 if (curop->op_type == OP_GV) {
3455 GV *gv = cGVOPx_gv(curop);
3456 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3458 SvCUR(gv) = PL_generation;
3460 else if (curop->op_type == OP_PADSV ||
3461 curop->op_type == OP_PADAV ||
3462 curop->op_type == OP_PADHV ||
3463 curop->op_type == OP_PADANY) {
3464 SV **svp = AvARRAY(PL_comppad_name);
3465 SV *sv = svp[curop->op_targ];
3466 if (SvCUR(sv) == PL_generation)
3468 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3470 else if (curop->op_type == OP_RV2CV)
3472 else if (curop->op_type == OP_RV2SV ||
3473 curop->op_type == OP_RV2AV ||
3474 curop->op_type == OP_RV2HV ||
3475 curop->op_type == OP_RV2GV) {
3476 if (lastop->op_type != OP_GV) /* funny deref? */
3479 else if (curop->op_type == OP_PUSHRE) {
3480 if (((PMOP*)curop)->op_pmreplroot) {
3482 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3484 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3486 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3488 SvCUR(gv) = PL_generation;
3497 o->op_private |= OPpASSIGN_COMMON;
3499 if (right && right->op_type == OP_SPLIT) {
3501 if ((tmpop = ((LISTOP*)right)->op_first) &&
3502 tmpop->op_type == OP_PUSHRE)
3504 PMOP *pm = (PMOP*)tmpop;
3505 if (left->op_type == OP_RV2AV &&
3506 !(left->op_private & OPpLVAL_INTRO) &&
3507 !(o->op_private & OPpASSIGN_COMMON) )
3509 tmpop = ((UNOP*)left)->op_first;
3510 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3512 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3513 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3515 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3516 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3518 pm->op_pmflags |= PMf_ONCE;
3519 tmpop = cUNOPo->op_first; /* to list (nulled) */
3520 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3521 tmpop->op_sibling = Nullop; /* don't free split */
3522 right->op_next = tmpop->op_next; /* fix starting loc */
3523 op_free(o); /* blow off assign */
3524 right->op_flags &= ~OPf_WANT;
3525 /* "I don't know and I don't care." */
3530 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3531 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3533 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3535 sv_setiv(sv, PL_modcount+1);
3543 right = newOP(OP_UNDEF, 0);
3544 if (right->op_type == OP_READLINE) {
3545 right->op_flags |= OPf_STACKED;
3546 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3549 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3550 o = newBINOP(OP_SASSIGN, flags,
3551 scalar(right), mod(scalar(left), OP_SASSIGN) );
3563 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3565 U32 seq = intro_my();
3568 NewOp(1101, cop, 1, COP);
3569 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3570 cop->op_type = OP_DBSTATE;
3571 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3574 cop->op_type = OP_NEXTSTATE;
3575 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3577 cop->op_flags = flags;
3578 cop->op_private = (PL_hints & HINT_BYTE);
3580 cop->op_private |= NATIVE_HINTS;
3582 PL_compiling.op_private = cop->op_private;
3583 cop->op_next = (OP*)cop;
3586 cop->cop_label = label;
3587 PL_hints |= HINT_BLOCK_SCOPE;
3590 cop->cop_arybase = PL_curcop->cop_arybase;
3591 if (specialWARN(PL_curcop->cop_warnings))
3592 cop->cop_warnings = PL_curcop->cop_warnings ;
3594 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3595 if (specialCopIO(PL_curcop->cop_io))
3596 cop->cop_io = PL_curcop->cop_io;
3598 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3601 if (PL_copline == NOLINE)
3602 CopLINE_set(cop, CopLINE(PL_curcop));
3604 CopLINE_set(cop, PL_copline);
3605 PL_copline = NOLINE;
3608 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3610 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3612 CopSTASH_set(cop, PL_curstash);
3614 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3615 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3616 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3617 (void)SvIOK_on(*svp);
3618 SvIVX(*svp) = PTR2IV(cop);
3622 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3625 /* "Introduce" my variables to visible status. */
3633 if (! PL_min_intro_pending)
3634 return PL_cop_seqmax;
3636 svp = AvARRAY(PL_comppad_name);
3637 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3638 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3639 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3640 SvNVX(sv) = (NV)PL_cop_seqmax;
3643 PL_min_intro_pending = 0;
3644 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3645 return PL_cop_seqmax++;
3649 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3651 return new_logop(type, flags, &first, &other);
3655 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3659 OP *first = *firstp;
3660 OP *other = *otherp;
3662 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3663 return newBINOP(type, flags, scalar(first), scalar(other));
3665 scalarboolean(first);
3666 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3667 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3668 if (type == OP_AND || type == OP_OR) {
3674 first = *firstp = cUNOPo->op_first;
3676 first->op_next = o->op_next;
3677 cUNOPo->op_first = Nullop;
3681 if (first->op_type == OP_CONST) {
3682 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3683 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3684 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3695 else if (first->op_type == OP_WANTARRAY) {
3701 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3702 OP *k1 = ((UNOP*)first)->op_first;
3703 OP *k2 = k1->op_sibling;
3705 switch (first->op_type)
3708 if (k2 && k2->op_type == OP_READLINE
3709 && (k2->op_flags & OPf_STACKED)
3710 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3712 warnop = k2->op_type;
3717 if (k1->op_type == OP_READDIR
3718 || k1->op_type == OP_GLOB
3719 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3720 || k1->op_type == OP_EACH)
3722 warnop = ((k1->op_type == OP_NULL)
3723 ? k1->op_targ : k1->op_type);
3728 line_t oldline = CopLINE(PL_curcop);
3729 CopLINE_set(PL_curcop, PL_copline);
3730 Perl_warner(aTHX_ WARN_MISC,
3731 "Value of %s%s can be \"0\"; test with defined()",
3733 ((warnop == OP_READLINE || warnop == OP_GLOB)
3734 ? " construct" : "() operator"));
3735 CopLINE_set(PL_curcop, oldline);
3742 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3743 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3745 NewOp(1101, logop, 1, LOGOP);
3747 logop->op_type = type;
3748 logop->op_ppaddr = PL_ppaddr[type];
3749 logop->op_first = first;
3750 logop->op_flags = flags | OPf_KIDS;
3751 logop->op_other = LINKLIST(other);
3752 logop->op_private = 1 | (flags >> 8);
3754 /* establish postfix order */
3755 logop->op_next = LINKLIST(first);
3756 first->op_next = (OP*)logop;
3757 first->op_sibling = other;
3759 o = newUNOP(OP_NULL, 0, (OP*)logop);
3766 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3773 return newLOGOP(OP_AND, 0, first, trueop);
3775 return newLOGOP(OP_OR, 0, first, falseop);
3777 scalarboolean(first);
3778 if (first->op_type == OP_CONST) {
3779 if (SvTRUE(((SVOP*)first)->op_sv)) {
3790 else if (first->op_type == OP_WANTARRAY) {
3794 NewOp(1101, logop, 1, LOGOP);
3795 logop->op_type = OP_COND_EXPR;
3796 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3797 logop->op_first = first;
3798 logop->op_flags = flags | OPf_KIDS;
3799 logop->op_private = 1 | (flags >> 8);
3800 logop->op_other = LINKLIST(trueop);
3801 logop->op_next = LINKLIST(falseop);
3804 /* establish postfix order */
3805 start = LINKLIST(first);
3806 first->op_next = (OP*)logop;
3808 first->op_sibling = trueop;
3809 trueop->op_sibling = falseop;
3810 o = newUNOP(OP_NULL, 0, (OP*)logop);
3812 trueop->op_next = falseop->op_next = o;
3819 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3827 NewOp(1101, range, 1, LOGOP);
3829 range->op_type = OP_RANGE;
3830 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3831 range->op_first = left;
3832 range->op_flags = OPf_KIDS;
3833 leftstart = LINKLIST(left);
3834 range->op_other = LINKLIST(right);
3835 range->op_private = 1 | (flags >> 8);
3837 left->op_sibling = right;
3839 range->op_next = (OP*)range;
3840 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3841 flop = newUNOP(OP_FLOP, 0, flip);
3842 o = newUNOP(OP_NULL, 0, flop);
3844 range->op_next = leftstart;
3846 left->op_next = flip;
3847 right->op_next = flop;
3849 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3850 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3851 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3852 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3854 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3855 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3858 if (!flip->op_private || !flop->op_private)
3859 linklist(o); /* blow off optimizer unless constant */
3865 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3869 int once = block && block->op_flags & OPf_SPECIAL &&
3870 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3873 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3874 return block; /* do {} while 0 does once */
3875 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3876 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3877 expr = newUNOP(OP_DEFINED, 0,
3878 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3879 } else if (expr->op_flags & OPf_KIDS) {
3880 OP *k1 = ((UNOP*)expr)->op_first;
3881 OP *k2 = (k1) ? k1->op_sibling : NULL;
3882 switch (expr->op_type) {
3884 if (k2 && k2->op_type == OP_READLINE
3885 && (k2->op_flags & OPf_STACKED)
3886 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3887 expr = newUNOP(OP_DEFINED, 0, expr);
3891 if (k1->op_type == OP_READDIR
3892 || k1->op_type == OP_GLOB
3893 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3894 || k1->op_type == OP_EACH)
3895 expr = newUNOP(OP_DEFINED, 0, expr);
3901 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3902 o = new_logop(OP_AND, 0, &expr, &listop);
3905 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3907 if (once && o != listop)
3908 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3911 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3913 o->op_flags |= flags;
3915 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3920 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3929 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3930 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3931 expr = newUNOP(OP_DEFINED, 0,
3932 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3933 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3934 OP *k1 = ((UNOP*)expr)->op_first;
3935 OP *k2 = (k1) ? k1->op_sibling : NULL;
3936 switch (expr->op_type) {
3938 if (k2 && k2->op_type == OP_READLINE
3939 && (k2->op_flags & OPf_STACKED)
3940 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3941 expr = newUNOP(OP_DEFINED, 0, expr);
3945 if (k1->op_type == OP_READDIR
3946 || k1->op_type == OP_GLOB
3947 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3948 || k1->op_type == OP_EACH)
3949 expr = newUNOP(OP_DEFINED, 0, expr);
3955 block = newOP(OP_NULL, 0);
3957 block = scope(block);
3961 next = LINKLIST(cont);
3964 OP *unstack = newOP(OP_UNSTACK, 0);
3967 cont = append_elem(OP_LINESEQ, cont, unstack);
3968 if ((line_t)whileline != NOLINE) {
3969 PL_copline = whileline;
3970 cont = append_elem(OP_LINESEQ, cont,
3971 newSTATEOP(0, Nullch, Nullop));
3975 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3976 redo = LINKLIST(listop);
3979 PL_copline = whileline;
3981 o = new_logop(OP_AND, 0, &expr, &listop);
3982 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3983 op_free(expr); /* oops, it's a while (0) */
3985 return Nullop; /* listop already freed by new_logop */
3988 ((LISTOP*)listop)->op_last->op_next = condop =
3989 (o == listop ? redo : LINKLIST(o));
3995 NewOp(1101,loop,1,LOOP);
3996 loop->op_type = OP_ENTERLOOP;
3997 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3998 loop->op_private = 0;
3999 loop->op_next = (OP*)loop;
4002 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4004 loop->op_redoop = redo;
4005 loop->op_lastop = o;
4006 o->op_private |= loopflags;
4009 loop->op_nextop = next;
4011 loop->op_nextop = o;
4013 o->op_flags |= flags;
4014 o->op_private |= (flags >> 8);
4019 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4027 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4028 sv->op_type = OP_RV2GV;
4029 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4031 else if (sv->op_type == OP_PADSV) { /* private variable */
4032 padoff = sv->op_targ;
4037 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4038 padoff = sv->op_targ;
4040 iterflags |= OPf_SPECIAL;
4045 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4049 padoff = find_threadsv("_");
4050 iterflags |= OPf_SPECIAL;
4052 sv = newGVOP(OP_GV, 0, PL_defgv);
4055 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4056 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4057 iterflags |= OPf_STACKED;
4059 else if (expr->op_type == OP_NULL &&
4060 (expr->op_flags & OPf_KIDS) &&
4061 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4063 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4064 * set the STACKED flag to indicate that these values are to be
4065 * treated as min/max values by 'pp_iterinit'.
4067 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4068 LOGOP* range = (LOGOP*) flip->op_first;
4069 OP* left = range->op_first;
4070 OP* right = left->op_sibling;
4073 range->op_flags &= ~OPf_KIDS;
4074 range->op_first = Nullop;
4076 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4077 listop->op_first->op_next = range->op_next;
4078 left->op_next = range->op_other;
4079 right->op_next = (OP*)listop;
4080 listop->op_next = listop->op_first;
4083 expr = (OP*)(listop);
4085 iterflags |= OPf_STACKED;
4088 expr = mod(force_list(expr), OP_GREPSTART);
4092 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4093 append_elem(OP_LIST, expr, scalar(sv))));
4094 assert(!loop->op_next);
4095 #ifdef PL_OP_SLAB_ALLOC
4098 NewOp(1234,tmp,1,LOOP);
4099 Copy(loop,tmp,1,LOOP);
4103 Renew(loop, 1, LOOP);
4105 loop->op_targ = padoff;
4106 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4107 PL_copline = forline;
4108 return newSTATEOP(0, label, wop);
4112 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4117 if (type != OP_GOTO || label->op_type == OP_CONST) {
4118 /* "last()" means "last" */
4119 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4120 o = newOP(type, OPf_SPECIAL);
4122 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4123 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4129 if (label->op_type == OP_ENTERSUB)
4130 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4131 o = newUNOP(type, OPf_STACKED, label);
4133 PL_hints |= HINT_BLOCK_SCOPE;
4138 Perl_cv_undef(pTHX_ CV *cv)
4142 MUTEX_DESTROY(CvMUTEXP(cv));
4143 Safefree(CvMUTEXP(cv));
4146 #endif /* USE_THREADS */
4148 if (!CvXSUB(cv) && CvROOT(cv)) {
4150 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4151 Perl_croak(aTHX_ "Can't undef active subroutine");
4154 Perl_croak(aTHX_ "Can't undef active subroutine");
4155 #endif /* USE_THREADS */
4158 SAVEVPTR(PL_curpad);
4161 op_free(CvROOT(cv));
4162 CvROOT(cv) = Nullop;
4165 SvPOK_off((SV*)cv); /* forget prototype */
4167 /* Since closure prototypes have the same lifetime as the containing
4168 * CV, they don't hold a refcount on the outside CV. This avoids
4169 * the refcount loop between the outer CV (which keeps a refcount to
4170 * the closure prototype in the pad entry for pp_anoncode()) and the
4171 * closure prototype, and the ensuing memory leak. --GSAR */
4172 if (!CvANON(cv) || CvCLONED(cv))
4173 SvREFCNT_dec(CvOUTSIDE(cv));
4174 CvOUTSIDE(cv) = Nullcv;
4176 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4179 if (CvPADLIST(cv)) {
4180 /* may be during global destruction */
4181 if (SvREFCNT(CvPADLIST(cv))) {
4182 I32 i = AvFILLp(CvPADLIST(cv));
4184 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4185 SV* sv = svp ? *svp : Nullsv;
4188 if (sv == (SV*)PL_comppad_name)
4189 PL_comppad_name = Nullav;
4190 else if (sv == (SV*)PL_comppad) {
4191 PL_comppad = Nullav;
4192 PL_curpad = Null(SV**);
4196 SvREFCNT_dec((SV*)CvPADLIST(cv));
4198 CvPADLIST(cv) = Nullav;
4203 #ifdef DEBUG_CLOSURES
4205 S_cv_dump(pTHX_ CV *cv)
4208 CV *outside = CvOUTSIDE(cv);
4209 AV* padlist = CvPADLIST(cv);
4216 PerlIO_printf(Perl_debug_log,
4217 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4219 (CvANON(cv) ? "ANON"
4220 : (cv == PL_main_cv) ? "MAIN"
4221 : CvUNIQUE(cv) ? "UNIQUE"
4222 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4225 : CvANON(outside) ? "ANON"
4226 : (outside == PL_main_cv) ? "MAIN"
4227 : CvUNIQUE(outside) ? "UNIQUE"
4228 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4233 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4234 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4235 pname = AvARRAY(pad_name);
4236 ppad = AvARRAY(pad);
4238 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4239 if (SvPOK(pname[ix]))
4240 PerlIO_printf(Perl_debug_log,
4241 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4242 (int)ix, PTR2UV(ppad[ix]),
4243 SvFAKE(pname[ix]) ? "FAKE " : "",
4245 (IV)I_32(SvNVX(pname[ix])),
4248 #endif /* DEBUGGING */
4250 #endif /* DEBUG_CLOSURES */
4253 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4257 AV* protopadlist = CvPADLIST(proto);
4258 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4259 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4260 SV** pname = AvARRAY(protopad_name);
4261 SV** ppad = AvARRAY(protopad);
4262 I32 fname = AvFILLp(protopad_name);
4263 I32 fpad = AvFILLp(protopad);
4267 assert(!CvUNIQUE(proto));
4271 SAVESPTR(PL_comppad_name);
4272 SAVESPTR(PL_compcv);
4274 cv = PL_compcv = (CV*)NEWSV(1104,0);
4275 sv_upgrade((SV *)cv, SvTYPE(proto));
4276 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4280 New(666, CvMUTEXP(cv), 1, perl_mutex);
4281 MUTEX_INIT(CvMUTEXP(cv));
4283 #endif /* USE_THREADS */
4284 CvFILE(cv) = CvFILE(proto);
4285 CvGV(cv) = CvGV(proto);
4286 CvSTASH(cv) = CvSTASH(proto);
4287 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4288 CvSTART(cv) = CvSTART(proto);
4290 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4293 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4295 PL_comppad_name = newAV();
4296 for (ix = fname; ix >= 0; ix--)
4297 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4299 PL_comppad = newAV();
4301 comppadlist = newAV();
4302 AvREAL_off(comppadlist);
4303 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4304 av_store(comppadlist, 1, (SV*)PL_comppad);
4305 CvPADLIST(cv) = comppadlist;
4306 av_fill(PL_comppad, AvFILLp(protopad));
4307 PL_curpad = AvARRAY(PL_comppad);
4309 av = newAV(); /* will be @_ */
4311 av_store(PL_comppad, 0, (SV*)av);
4312 AvFLAGS(av) = AVf_REIFY;
4314 for (ix = fpad; ix > 0; ix--) {
4315 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4316 if (namesv && namesv != &PL_sv_undef) {
4317 char *name = SvPVX(namesv); /* XXX */
4318 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4319 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4320 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4322 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4324 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4326 else { /* our own lexical */
4329 /* anon code -- we'll come back for it */
4330 sv = SvREFCNT_inc(ppad[ix]);
4332 else if (*name == '@')
4334 else if (*name == '%')
4343 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4344 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4347 SV* sv = NEWSV(0,0);
4353 /* Now that vars are all in place, clone nested closures. */
4355 for (ix = fpad; ix > 0; ix--) {
4356 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4358 && namesv != &PL_sv_undef
4359 && !(SvFLAGS(namesv) & SVf_FAKE)
4360 && *SvPVX(namesv) == '&'
4361 && CvCLONE(ppad[ix]))
4363 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4364 SvREFCNT_dec(ppad[ix]);
4367 PL_curpad[ix] = (SV*)kid;
4371 #ifdef DEBUG_CLOSURES
4372 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4374 PerlIO_printf(Perl_debug_log, " from:\n");
4376 PerlIO_printf(Perl_debug_log, " to:\n");
4383 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4385 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4387 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4394 Perl_cv_clone(pTHX_ CV *proto)
4397 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4398 cv = cv_clone2(proto, CvOUTSIDE(proto));
4399 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4404 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4406 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4407 SV* msg = sv_newmortal();
4411 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4412 sv_setpv(msg, "Prototype mismatch:");
4414 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4416 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4417 sv_catpv(msg, " vs ");
4419 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4421 sv_catpv(msg, "none");
4422 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4426 static void const_sv_xsub(pTHXo_ CV* cv);
4429 =for apidoc cv_const_sv
4431 If C<cv> is a constant sub eligible for inlining. returns the constant
4432 value returned by the sub. Otherwise, returns NULL.
4434 Constant subs can be created with C<newCONSTSUB> or as described in
4435 L<perlsub/"Constant Functions">.
4440 Perl_cv_const_sv(pTHX_ CV *cv)
4442 if (!cv || !CvCONST(cv))
4444 return (SV*)CvXSUBANY(cv).any_ptr;
4448 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4455 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4456 o = cLISTOPo->op_first->op_sibling;
4458 for (; o; o = o->op_next) {
4459 OPCODE type = o->op_type;
4461 if (sv && o->op_next == o)
4463 if (o->op_next != o) {
4464 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4466 if (type == OP_DBSTATE)
4469 if (type == OP_LEAVESUB || type == OP_RETURN)
4473 if (type == OP_CONST && cSVOPo->op_sv)
4475 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4476 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4477 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4481 /* We get here only from cv_clone2() while creating a closure.
4482 Copy the const value here instead of in cv_clone2 so that
4483 SvREADONLY_on doesn't lead to problems when leaving
4488 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4500 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4510 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4514 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4516 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4520 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4526 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4531 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4532 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4533 SV *sv = sv_newmortal();
4534 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4535 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4540 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4541 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4551 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4552 maximum a prototype before. */
4553 if (SvTYPE(gv) > SVt_NULL) {
4554 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4555 && ckWARN_d(WARN_PROTOTYPE))
4557 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4559 cv_ckproto((CV*)gv, NULL, ps);
4562 sv_setpv((SV*)gv, ps);
4564 sv_setiv((SV*)gv, -1);
4565 SvREFCNT_dec(PL_compcv);
4566 cv = PL_compcv = NULL;
4567 PL_sub_generation++;
4571 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4573 #ifdef GV_SHARED_CHECK
4574 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4575 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4579 if (!block || !ps || *ps || attrs)
4582 const_sv = op_const_sv(block, Nullcv);
4585 bool exists = CvROOT(cv) || CvXSUB(cv);
4587 #ifdef GV_SHARED_CHECK
4588 if (exists && GvSHARED(gv)) {
4589 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4593 /* if the subroutine doesn't exist and wasn't pre-declared
4594 * with a prototype, assume it will be AUTOLOADed,
4595 * skipping the prototype check
4597 if (exists || SvPOK(cv))
4598 cv_ckproto(cv, gv, ps);
4599 /* already defined (or promised)? */
4600 if (exists || GvASSUMECV(gv)) {
4601 if (!block && !attrs) {
4602 /* just a "sub foo;" when &foo is already defined */
4603 SAVEFREESV(PL_compcv);
4606 /* ahem, death to those who redefine active sort subs */
4607 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4608 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4610 if (ckWARN(WARN_REDEFINE)
4612 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4614 line_t oldline = CopLINE(PL_curcop);
4615 CopLINE_set(PL_curcop, PL_copline);
4616 Perl_warner(aTHX_ WARN_REDEFINE,
4617 CvCONST(cv) ? "Constant subroutine %s redefined"
4618 : "Subroutine %s redefined", name);
4619 CopLINE_set(PL_curcop, oldline);
4627 SvREFCNT_inc(const_sv);
4629 assert(!CvROOT(cv) && !CvCONST(cv));
4630 sv_setpv((SV*)cv, ""); /* prototype is "" */
4631 CvXSUBANY(cv).any_ptr = const_sv;
4632 CvXSUB(cv) = const_sv_xsub;
4637 cv = newCONSTSUB(NULL, name, const_sv);
4640 SvREFCNT_dec(PL_compcv);
4642 PL_sub_generation++;
4649 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4650 * before we clobber PL_compcv.
4654 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4655 stash = GvSTASH(CvGV(cv));
4656 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4657 stash = CvSTASH(cv);
4659 stash = PL_curstash;
4662 /* possibly about to re-define existing subr -- ignore old cv */
4663 rcv = (SV*)PL_compcv;
4664 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4665 stash = GvSTASH(gv);
4667 stash = PL_curstash;
4669 apply_attrs(stash, rcv, attrs);
4671 if (cv) { /* must reuse cv if autoloaded */
4673 /* got here with just attrs -- work done, so bug out */
4674 SAVEFREESV(PL_compcv);
4678 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4679 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4680 CvOUTSIDE(PL_compcv) = 0;
4681 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4682 CvPADLIST(PL_compcv) = 0;
4683 /* inner references to PL_compcv must be fixed up ... */
4685 AV *padlist = CvPADLIST(cv);
4686 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4687 AV *comppad = (AV*)AvARRAY(padlist)[1];
4688 SV **namepad = AvARRAY(comppad_name);
4689 SV **curpad = AvARRAY(comppad);
4690 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4691 SV *namesv = namepad[ix];
4692 if (namesv && namesv != &PL_sv_undef
4693 && *SvPVX(namesv) == '&')
4695 CV *innercv = (CV*)curpad[ix];
4696 if (CvOUTSIDE(innercv) == PL_compcv) {
4697 CvOUTSIDE(innercv) = cv;
4698 if (!CvANON(innercv) || CvCLONED(innercv)) {
4699 (void)SvREFCNT_inc(cv);
4700 SvREFCNT_dec(PL_compcv);
4706 /* ... before we throw it away */
4707 SvREFCNT_dec(PL_compcv);
4714 PL_sub_generation++;
4718 CvFILE(cv) = CopFILE(PL_curcop);
4719 CvSTASH(cv) = PL_curstash;
4722 if (!CvMUTEXP(cv)) {
4723 New(666, CvMUTEXP(cv), 1, perl_mutex);
4724 MUTEX_INIT(CvMUTEXP(cv));
4726 #endif /* USE_THREADS */
4729 sv_setpv((SV*)cv, ps);
4731 if (PL_error_count) {
4735 char *s = strrchr(name, ':');
4737 if (strEQ(s, "BEGIN")) {
4739 "BEGIN not safe after errors--compilation aborted";
4740 if (PL_in_eval & EVAL_KEEPERR)
4741 Perl_croak(aTHX_ not_safe);
4743 /* force display of errors found but not reported */
4744 sv_catpv(ERRSV, not_safe);
4745 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4753 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4754 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4757 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4758 mod(scalarseq(block), OP_LEAVESUBLV));
4761 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4763 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4764 OpREFCNT_set(CvROOT(cv), 1);
4765 CvSTART(cv) = LINKLIST(CvROOT(cv));
4766 CvROOT(cv)->op_next = 0;
4769 /* now that optimizer has done its work, adjust pad values */
4771 SV **namep = AvARRAY(PL_comppad_name);
4772 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4775 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4778 * The only things that a clonable function needs in its
4779 * pad are references to outer lexicals and anonymous subs.
4780 * The rest are created anew during cloning.
4782 if (!((namesv = namep[ix]) != Nullsv &&
4783 namesv != &PL_sv_undef &&
4785 *SvPVX(namesv) == '&')))
4787 SvREFCNT_dec(PL_curpad[ix]);
4788 PL_curpad[ix] = Nullsv;
4791 assert(!CvCONST(cv));
4792 if (ps && !*ps && op_const_sv(block, cv))
4796 AV *av = newAV(); /* Will be @_ */
4798 av_store(PL_comppad, 0, (SV*)av);
4799 AvFLAGS(av) = AVf_REIFY;
4801 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4802 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4804 if (!SvPADMY(PL_curpad[ix]))
4805 SvPADTMP_on(PL_curpad[ix]);
4809 /* If a potential closure prototype, don't keep a refcount on outer CV.
4810 * This is okay as the lifetime of the prototype is tied to the
4811 * lifetime of the outer CV. Avoids memory leak due to reference
4814 SvREFCNT_dec(CvOUTSIDE(cv));
4816 if (name || aname) {
4818 char *tname = (name ? name : aname);
4820 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4821 SV *sv = NEWSV(0,0);
4822 SV *tmpstr = sv_newmortal();
4823 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4827 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4829 (long)PL_subline, (long)CopLINE(PL_curcop));
4830 gv_efullname3(tmpstr, gv, Nullch);
4831 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4832 hv = GvHVn(db_postponed);
4833 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4834 && (pcv = GvCV(db_postponed)))
4840 call_sv((SV*)pcv, G_DISCARD);
4844 if ((s = strrchr(tname,':')))
4849 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4852 if (strEQ(s, "BEGIN")) {
4853 I32 oldscope = PL_scopestack_ix;
4855 SAVECOPFILE(&PL_compiling);
4856 SAVECOPLINE(&PL_compiling);
4858 sv_setsv(PL_rs, PL_nrs);
4861 PL_beginav = newAV();
4862 DEBUG_x( dump_sub(gv) );
4863 av_push(PL_beginav, (SV*)cv);
4864 GvCV(gv) = 0; /* cv has been hijacked */
4865 call_list(oldscope, PL_beginav);
4867 PL_curcop = &PL_compiling;
4868 PL_compiling.op_private = PL_hints;
4871 else if (strEQ(s, "END") && !PL_error_count) {
4874 DEBUG_x( dump_sub(gv) );
4875 av_unshift(PL_endav, 1);
4876 av_store(PL_endav, 0, (SV*)cv);
4877 GvCV(gv) = 0; /* cv has been hijacked */
4879 else if (strEQ(s, "CHECK") && !PL_error_count) {
4881 PL_checkav = newAV();
4882 DEBUG_x( dump_sub(gv) );
4883 if (PL_main_start && ckWARN(WARN_VOID))
4884 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4885 av_unshift(PL_checkav, 1);
4886 av_store(PL_checkav, 0, (SV*)cv);
4887 GvCV(gv) = 0; /* cv has been hijacked */
4889 else if (strEQ(s, "INIT") && !PL_error_count) {
4891 PL_initav = newAV();
4892 DEBUG_x( dump_sub(gv) );
4893 if (PL_main_start && ckWARN(WARN_VOID))
4894 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4895 av_push(PL_initav, (SV*)cv);
4896 GvCV(gv) = 0; /* cv has been hijacked */
4901 PL_copline = NOLINE;
4906 /* XXX unsafe for threads if eval_owner isn't held */
4908 =for apidoc newCONSTSUB
4910 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4911 eligible for inlining at compile-time.
4917 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4923 SAVECOPLINE(PL_curcop);
4924 CopLINE_set(PL_curcop, PL_copline);
4927 PL_hints &= ~HINT_BLOCK_SCOPE;
4930 SAVESPTR(PL_curstash);
4931 SAVECOPSTASH(PL_curcop);
4932 PL_curstash = stash;
4934 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4936 CopSTASH(PL_curcop) = stash;
4940 cv = newXS(name, const_sv_xsub, __FILE__);
4941 CvXSUBANY(cv).any_ptr = sv;
4943 sv_setpv((SV*)cv, ""); /* prototype is "" */
4951 =for apidoc U||newXS
4953 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4959 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4961 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4964 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4966 /* just a cached method */
4970 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4971 /* already defined (or promised) */
4972 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4973 && HvNAME(GvSTASH(CvGV(cv)))
4974 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4975 line_t oldline = CopLINE(PL_curcop);
4976 if (PL_copline != NOLINE)
4977 CopLINE_set(PL_curcop, PL_copline);
4978 Perl_warner(aTHX_ WARN_REDEFINE,
4979 CvCONST(cv) ? "Constant subroutine %s redefined"
4980 : "Subroutine %s redefined"
4982 CopLINE_set(PL_curcop, oldline);
4989 if (cv) /* must reuse cv if autoloaded */
4992 cv = (CV*)NEWSV(1105,0);
4993 sv_upgrade((SV *)cv, SVt_PVCV);
4997 PL_sub_generation++;
5002 New(666, CvMUTEXP(cv), 1, perl_mutex);
5003 MUTEX_INIT(CvMUTEXP(cv));
5005 #endif /* USE_THREADS */
5006 (void)gv_fetchfile(filename);
5007 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5008 an external constant string */
5009 CvXSUB(cv) = subaddr;
5012 char *s = strrchr(name,':');
5018 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5021 if (strEQ(s, "BEGIN")) {
5023 PL_beginav = newAV();
5024 av_push(PL_beginav, (SV*)cv);
5025 GvCV(gv) = 0; /* cv has been hijacked */
5027 else if (strEQ(s, "END")) {
5030 av_unshift(PL_endav, 1);
5031 av_store(PL_endav, 0, (SV*)cv);
5032 GvCV(gv) = 0; /* cv has been hijacked */
5034 else if (strEQ(s, "CHECK")) {
5036 PL_checkav = newAV();
5037 if (PL_main_start && ckWARN(WARN_VOID))
5038 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5039 av_unshift(PL_checkav, 1);
5040 av_store(PL_checkav, 0, (SV*)cv);
5041 GvCV(gv) = 0; /* cv has been hijacked */
5043 else if (strEQ(s, "INIT")) {
5045 PL_initav = newAV();
5046 if (PL_main_start && ckWARN(WARN_VOID))
5047 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5048 av_push(PL_initav, (SV*)cv);
5049 GvCV(gv) = 0; /* cv has been hijacked */
5060 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5069 name = SvPVx(cSVOPo->op_sv, n_a);
5072 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5073 #ifdef GV_SHARED_CHECK
5075 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5079 if ((cv = GvFORM(gv))) {
5080 if (ckWARN(WARN_REDEFINE)) {
5081 line_t oldline = CopLINE(PL_curcop);
5083 CopLINE_set(PL_curcop, PL_copline);
5084 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5085 CopLINE_set(PL_curcop, oldline);
5092 CvFILE(cv) = CopFILE(PL_curcop);
5094 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5095 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5096 SvPADTMP_on(PL_curpad[ix]);
5099 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5100 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5101 OpREFCNT_set(CvROOT(cv), 1);
5102 CvSTART(cv) = LINKLIST(CvROOT(cv));
5103 CvROOT(cv)->op_next = 0;
5106 PL_copline = NOLINE;
5111 Perl_newANONLIST(pTHX_ OP *o)
5113 return newUNOP(OP_REFGEN, 0,
5114 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5118 Perl_newANONHASH(pTHX_ OP *o)
5120 return newUNOP(OP_REFGEN, 0,
5121 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5125 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5127 return newANONATTRSUB(floor, proto, Nullop, block);
5131 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5133 return newUNOP(OP_REFGEN, 0,
5134 newSVOP(OP_ANONCODE, 0,
5135 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5139 Perl_oopsAV(pTHX_ OP *o)
5141 switch (o->op_type) {
5143 o->op_type = OP_PADAV;
5144 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5145 return ref(o, OP_RV2AV);
5148 o->op_type = OP_RV2AV;
5149 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5154 if (ckWARN_d(WARN_INTERNAL))
5155 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5162 Perl_oopsHV(pTHX_ OP *o)
5164 switch (o->op_type) {
5167 o->op_type = OP_PADHV;
5168 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5169 return ref(o, OP_RV2HV);
5173 o->op_type = OP_RV2HV;
5174 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5179 if (ckWARN_d(WARN_INTERNAL))
5180 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5187 Perl_newAVREF(pTHX_ OP *o)
5189 if (o->op_type == OP_PADANY) {
5190 o->op_type = OP_PADAV;
5191 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5194 return newUNOP(OP_RV2AV, 0, scalar(o));
5198 Perl_newGVREF(pTHX_ I32 type, OP *o)
5200 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5201 return newUNOP(OP_NULL, 0, o);
5202 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5206 Perl_newHVREF(pTHX_ OP *o)
5208 if (o->op_type == OP_PADANY) {
5209 o->op_type = OP_PADHV;
5210 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5213 return newUNOP(OP_RV2HV, 0, scalar(o));
5217 Perl_oopsCV(pTHX_ OP *o)
5219 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5225 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5227 return newUNOP(OP_RV2CV, flags, scalar(o));
5231 Perl_newSVREF(pTHX_ OP *o)
5233 if (o->op_type == OP_PADANY) {
5234 o->op_type = OP_PADSV;
5235 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5238 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5239 o->op_flags |= OPpDONE_SVREF;
5242 return newUNOP(OP_RV2SV, 0, scalar(o));
5245 /* Check routines. */
5248 Perl_ck_anoncode(pTHX_ OP *o)
5253 name = NEWSV(1106,0);
5254 sv_upgrade(name, SVt_PVNV);
5255 sv_setpvn(name, "&", 1);
5258 ix = pad_alloc(o->op_type, SVs_PADMY);
5259 av_store(PL_comppad_name, ix, name);
5260 av_store(PL_comppad, ix, cSVOPo->op_sv);
5261 SvPADMY_on(cSVOPo->op_sv);
5262 cSVOPo->op_sv = Nullsv;
5263 cSVOPo->op_targ = ix;
5268 Perl_ck_bitop(pTHX_ OP *o)
5270 o->op_private = PL_hints;
5275 Perl_ck_concat(pTHX_ OP *o)
5277 if (cUNOPo->op_first->op_type == OP_CONCAT)
5278 o->op_flags |= OPf_STACKED;
5283 Perl_ck_spair(pTHX_ OP *o)
5285 if (o->op_flags & OPf_KIDS) {
5288 OPCODE type = o->op_type;
5289 o = modkids(ck_fun(o), type);
5290 kid = cUNOPo->op_first;
5291 newop = kUNOP->op_first->op_sibling;
5293 (newop->op_sibling ||
5294 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5295 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5296 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5300 op_free(kUNOP->op_first);
5301 kUNOP->op_first = newop;
5303 o->op_ppaddr = PL_ppaddr[++o->op_type];
5308 Perl_ck_delete(pTHX_ OP *o)
5312 if (o->op_flags & OPf_KIDS) {
5313 OP *kid = cUNOPo->op_first;
5314 switch (kid->op_type) {
5316 o->op_flags |= OPf_SPECIAL;
5319 o->op_private |= OPpSLICE;
5322 o->op_flags |= OPf_SPECIAL;
5327 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5328 PL_op_desc[o->op_type]);
5336 Perl_ck_eof(pTHX_ OP *o)
5338 I32 type = o->op_type;
5340 if (o->op_flags & OPf_KIDS) {
5341 if (cLISTOPo->op_first->op_type == OP_STUB) {
5343 o = newUNOP(type, OPf_SPECIAL,
5344 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5352 Perl_ck_eval(pTHX_ OP *o)
5354 PL_hints |= HINT_BLOCK_SCOPE;
5355 if (o->op_flags & OPf_KIDS) {
5356 SVOP *kid = (SVOP*)cUNOPo->op_first;
5359 o->op_flags &= ~OPf_KIDS;
5362 else if (kid->op_type == OP_LINESEQ) {
5365 kid->op_next = o->op_next;
5366 cUNOPo->op_first = 0;
5369 NewOp(1101, enter, 1, LOGOP);
5370 enter->op_type = OP_ENTERTRY;
5371 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5372 enter->op_private = 0;
5374 /* establish postfix order */
5375 enter->op_next = (OP*)enter;
5377 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5378 o->op_type = OP_LEAVETRY;
5379 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5380 enter->op_other = o;
5388 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5390 o->op_targ = (PADOFFSET)PL_hints;
5395 Perl_ck_exit(pTHX_ OP *o)
5398 HV *table = GvHV(PL_hintgv);
5400 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5401 if (svp && *svp && SvTRUE(*svp))
5402 o->op_private |= OPpEXIT_VMSISH;
5409 Perl_ck_exec(pTHX_ OP *o)
5412 if (o->op_flags & OPf_STACKED) {
5414 kid = cUNOPo->op_first->op_sibling;
5415 if (kid->op_type == OP_RV2GV)
5424 Perl_ck_exists(pTHX_ OP *o)
5427 if (o->op_flags & OPf_KIDS) {
5428 OP *kid = cUNOPo->op_first;
5429 if (kid->op_type == OP_ENTERSUB) {
5430 (void) ref(kid, o->op_type);
5431 if (kid->op_type != OP_RV2CV && !PL_error_count)
5432 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5433 PL_op_desc[o->op_type]);
5434 o->op_private |= OPpEXISTS_SUB;
5436 else if (kid->op_type == OP_AELEM)
5437 o->op_flags |= OPf_SPECIAL;
5438 else if (kid->op_type != OP_HELEM)
5439 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5440 PL_op_desc[o->op_type]);
5448 Perl_ck_gvconst(pTHX_ register OP *o)
5450 o = fold_constants(o);
5451 if (o->op_type == OP_CONST)
5458 Perl_ck_rvconst(pTHX_ register OP *o)
5460 SVOP *kid = (SVOP*)cUNOPo->op_first;
5462 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5463 if (kid->op_type == OP_CONST) {
5467 SV *kidsv = kid->op_sv;
5470 /* Is it a constant from cv_const_sv()? */
5471 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5472 SV *rsv = SvRV(kidsv);
5473 int svtype = SvTYPE(rsv);
5474 char *badtype = Nullch;
5476 switch (o->op_type) {
5478 if (svtype > SVt_PVMG)
5479 badtype = "a SCALAR";
5482 if (svtype != SVt_PVAV)
5483 badtype = "an ARRAY";
5486 if (svtype != SVt_PVHV) {
5487 if (svtype == SVt_PVAV) { /* pseudohash? */
5488 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5489 if (ksv && SvROK(*ksv)
5490 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5499 if (svtype != SVt_PVCV)
5504 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5507 name = SvPV(kidsv, n_a);
5508 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5509 char *badthing = Nullch;
5510 switch (o->op_type) {
5512 badthing = "a SCALAR";
5515 badthing = "an ARRAY";
5518 badthing = "a HASH";
5523 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5527 * This is a little tricky. We only want to add the symbol if we
5528 * didn't add it in the lexer. Otherwise we get duplicate strict
5529 * warnings. But if we didn't add it in the lexer, we must at
5530 * least pretend like we wanted to add it even if it existed before,
5531 * or we get possible typo warnings. OPpCONST_ENTERED says
5532 * whether the lexer already added THIS instance of this symbol.
5534 iscv = (o->op_type == OP_RV2CV) * 2;
5536 gv = gv_fetchpv(name,
5537 iscv | !(kid->op_private & OPpCONST_ENTERED),
5540 : o->op_type == OP_RV2SV
5542 : o->op_type == OP_RV2AV
5544 : o->op_type == OP_RV2HV
5547 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5549 kid->op_type = OP_GV;
5550 SvREFCNT_dec(kid->op_sv);
5552 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5553 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5554 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5556 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5558 kid->op_sv = SvREFCNT_inc(gv);
5560 kid->op_private = 0;
5561 kid->op_ppaddr = PL_ppaddr[OP_GV];
5568 Perl_ck_ftst(pTHX_ OP *o)
5570 I32 type = o->op_type;
5572 if (o->op_flags & OPf_REF) {
5575 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5576 SVOP *kid = (SVOP*)cUNOPo->op_first;
5578 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5580 OP *newop = newGVOP(type, OPf_REF,
5581 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5588 if (type == OP_FTTTY)
5589 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5592 o = newUNOP(type, 0, newDEFSVOP());
5595 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5597 if (PL_hints & HINT_LOCALE)
5598 o->op_private |= OPpLOCALE;
5605 Perl_ck_fun(pTHX_ OP *o)
5611 int type = o->op_type;
5612 register I32 oa = PL_opargs[type] >> OASHIFT;
5614 if (o->op_flags & OPf_STACKED) {
5615 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5618 return no_fh_allowed(o);
5621 if (o->op_flags & OPf_KIDS) {
5623 tokid = &cLISTOPo->op_first;
5624 kid = cLISTOPo->op_first;
5625 if (kid->op_type == OP_PUSHMARK ||
5626 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5628 tokid = &kid->op_sibling;
5629 kid = kid->op_sibling;
5631 if (!kid && PL_opargs[type] & OA_DEFGV)
5632 *tokid = kid = newDEFSVOP();
5636 sibl = kid->op_sibling;
5639 /* list seen where single (scalar) arg expected? */
5640 if (numargs == 1 && !(oa >> 4)
5641 && kid->op_type == OP_LIST && type != OP_SCALAR)
5643 return too_many_arguments(o,PL_op_desc[type]);
5656 if (kid->op_type == OP_CONST &&
5657 (kid->op_private & OPpCONST_BARE))
5659 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5660 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5661 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5662 if (ckWARN(WARN_DEPRECATED))
5663 Perl_warner(aTHX_ WARN_DEPRECATED,
5664 "Array @%s missing the @ in argument %"IVdf" of %s()",
5665 name, (IV)numargs, PL_op_desc[type]);
5668 kid->op_sibling = sibl;
5671 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5672 bad_type(numargs, "array", PL_op_desc[type], kid);
5676 if (kid->op_type == OP_CONST &&
5677 (kid->op_private & OPpCONST_BARE))
5679 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5680 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5681 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5682 if (ckWARN(WARN_DEPRECATED))
5683 Perl_warner(aTHX_ WARN_DEPRECATED,
5684 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5685 name, (IV)numargs, PL_op_desc[type]);
5688 kid->op_sibling = sibl;
5691 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5692 bad_type(numargs, "hash", PL_op_desc[type], kid);
5697 OP *newop = newUNOP(OP_NULL, 0, kid);
5698 kid->op_sibling = 0;
5700 newop->op_next = newop;
5702 kid->op_sibling = sibl;
5707 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5708 if (kid->op_type == OP_CONST &&
5709 (kid->op_private & OPpCONST_BARE))
5711 OP *newop = newGVOP(OP_GV, 0,
5712 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5717 else if (kid->op_type == OP_READLINE) {
5718 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5719 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5722 I32 flags = OPf_SPECIAL;
5726 /* is this op a FH constructor? */
5727 if (is_handle_constructor(o,numargs)) {
5728 char *name = Nullch;
5732 /* Set a flag to tell rv2gv to vivify
5733 * need to "prove" flag does not mean something
5734 * else already - NI-S 1999/05/07
5737 if (kid->op_type == OP_PADSV) {
5738 SV **namep = av_fetch(PL_comppad_name,
5740 if (namep && *namep)
5741 name = SvPV(*namep, len);
5743 else if (kid->op_type == OP_RV2SV
5744 && kUNOP->op_first->op_type == OP_GV)
5746 GV *gv = cGVOPx_gv(kUNOP->op_first);
5748 len = GvNAMELEN(gv);
5750 else if (kid->op_type == OP_AELEM
5751 || kid->op_type == OP_HELEM)
5753 name = "__ANONIO__";
5759 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5760 namesv = PL_curpad[targ];
5761 (void)SvUPGRADE(namesv, SVt_PV);
5763 sv_setpvn(namesv, "$", 1);
5764 sv_catpvn(namesv, name, len);
5767 kid->op_sibling = 0;
5768 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5769 kid->op_targ = targ;
5770 kid->op_private |= priv;
5772 kid->op_sibling = sibl;
5778 mod(scalar(kid), type);
5782 tokid = &kid->op_sibling;
5783 kid = kid->op_sibling;
5785 o->op_private |= numargs;
5787 return too_many_arguments(o,PL_op_desc[o->op_type]);
5790 else if (PL_opargs[type] & OA_DEFGV) {
5792 return newUNOP(type, 0, newDEFSVOP());
5796 while (oa & OA_OPTIONAL)
5798 if (oa && oa != OA_LIST)
5799 return too_few_arguments(o,PL_op_desc[o->op_type]);
5805 Perl_ck_glob(pTHX_ OP *o)
5810 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5811 append_elem(OP_GLOB, o, newDEFSVOP());
5813 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5814 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5816 #if !defined(PERL_EXTERNAL_GLOB)
5817 /* XXX this can be tightened up and made more failsafe. */
5820 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5821 /* null-terminated import list */
5822 newSVpvn(":globally", 9), Nullsv);
5823 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5826 #endif /* PERL_EXTERNAL_GLOB */
5828 if (gv && GvIMPORTED_CV(gv)) {
5829 append_elem(OP_GLOB, o,
5830 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5831 o->op_type = OP_LIST;
5832 o->op_ppaddr = PL_ppaddr[OP_LIST];
5833 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5834 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5835 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5836 append_elem(OP_LIST, o,
5837 scalar(newUNOP(OP_RV2CV, 0,
5838 newGVOP(OP_GV, 0, gv)))));
5839 o = newUNOP(OP_NULL, 0, ck_subr(o));
5840 o->op_targ = OP_GLOB; /* hint at what it used to be */
5843 gv = newGVgen("main");
5845 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5851 Perl_ck_grep(pTHX_ OP *o)
5855 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5857 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5858 NewOp(1101, gwop, 1, LOGOP);
5860 if (o->op_flags & OPf_STACKED) {
5863 kid = cLISTOPo->op_first->op_sibling;
5864 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5867 kid->op_next = (OP*)gwop;
5868 o->op_flags &= ~OPf_STACKED;
5870 kid = cLISTOPo->op_first->op_sibling;
5871 if (type == OP_MAPWHILE)
5878 kid = cLISTOPo->op_first->op_sibling;
5879 if (kid->op_type != OP_NULL)
5880 Perl_croak(aTHX_ "panic: ck_grep");
5881 kid = kUNOP->op_first;
5883 gwop->op_type = type;
5884 gwop->op_ppaddr = PL_ppaddr[type];
5885 gwop->op_first = listkids(o);
5886 gwop->op_flags |= OPf_KIDS;
5887 gwop->op_private = 1;
5888 gwop->op_other = LINKLIST(kid);
5889 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5890 kid->op_next = (OP*)gwop;
5892 kid = cLISTOPo->op_first->op_sibling;
5893 if (!kid || !kid->op_sibling)
5894 return too_few_arguments(o,PL_op_desc[o->op_type]);
5895 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5896 mod(kid, OP_GREPSTART);
5902 Perl_ck_index(pTHX_ OP *o)
5904 if (o->op_flags & OPf_KIDS) {
5905 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5907 kid = kid->op_sibling; /* get past "big" */
5908 if (kid && kid->op_type == OP_CONST)
5909 fbm_compile(((SVOP*)kid)->op_sv, 0);
5915 Perl_ck_lengthconst(pTHX_ OP *o)
5917 /* XXX length optimization goes here */
5922 Perl_ck_lfun(pTHX_ OP *o)
5924 OPCODE type = o->op_type;
5925 return modkids(ck_fun(o), type);
5929 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5931 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5932 switch (cUNOPo->op_first->op_type) {
5934 /* This is needed for
5935 if (defined %stash::)
5936 to work. Do not break Tk.
5938 break; /* Globals via GV can be undef */
5940 case OP_AASSIGN: /* Is this a good idea? */
5941 Perl_warner(aTHX_ WARN_DEPRECATED,
5942 "defined(@array) is deprecated");
5943 Perl_warner(aTHX_ WARN_DEPRECATED,
5944 "\t(Maybe you should just omit the defined()?)\n");
5947 /* This is needed for
5948 if (defined %stash::)
5949 to work. Do not break Tk.
5951 break; /* Globals via GV can be undef */
5953 Perl_warner(aTHX_ WARN_DEPRECATED,
5954 "defined(%%hash) is deprecated");
5955 Perl_warner(aTHX_ WARN_DEPRECATED,
5956 "\t(Maybe you should just omit the defined()?)\n");
5967 Perl_ck_rfun(pTHX_ OP *o)
5969 OPCODE type = o->op_type;
5970 return refkids(ck_fun(o), type);
5974 Perl_ck_listiob(pTHX_ OP *o)
5978 kid = cLISTOPo->op_first;
5981 kid = cLISTOPo->op_first;
5983 if (kid->op_type == OP_PUSHMARK)
5984 kid = kid->op_sibling;
5985 if (kid && o->op_flags & OPf_STACKED)
5986 kid = kid->op_sibling;
5987 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5988 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5989 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5990 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5991 cLISTOPo->op_first->op_sibling = kid;
5992 cLISTOPo->op_last = kid;
5993 kid = kid->op_sibling;
5998 append_elem(o->op_type, o, newDEFSVOP());
6004 if (PL_hints & HINT_LOCALE)
6005 o->op_private |= OPpLOCALE;
6012 Perl_ck_fun_locale(pTHX_ OP *o)
6018 if (PL_hints & HINT_LOCALE)
6019 o->op_private |= OPpLOCALE;
6026 Perl_ck_sassign(pTHX_ OP *o)
6028 OP *kid = cLISTOPo->op_first;
6029 /* has a disposable target? */
6030 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6031 && !(kid->op_flags & OPf_STACKED)
6032 /* Cannot steal the second time! */
6033 && !(kid->op_private & OPpTARGET_MY))
6035 OP *kkid = kid->op_sibling;
6037 /* Can just relocate the target. */
6038 if (kkid && kkid->op_type == OP_PADSV
6039 && !(kkid->op_private & OPpLVAL_INTRO))
6041 kid->op_targ = kkid->op_targ;
6043 /* Now we do not need PADSV and SASSIGN. */
6044 kid->op_sibling = o->op_sibling; /* NULL */
6045 cLISTOPo->op_first = NULL;
6048 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6056 Perl_ck_scmp(pTHX_ OP *o)
6060 if (PL_hints & HINT_LOCALE)
6061 o->op_private |= OPpLOCALE;
6068 Perl_ck_match(pTHX_ OP *o)
6070 o->op_private |= OPpRUNTIME;
6075 Perl_ck_method(pTHX_ OP *o)
6077 OP *kid = cUNOPo->op_first;
6078 if (kid->op_type == OP_CONST) {
6079 SV* sv = kSVOP->op_sv;
6080 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6082 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6083 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6086 kSVOP->op_sv = Nullsv;
6088 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6097 Perl_ck_null(pTHX_ OP *o)
6103 Perl_ck_open(pTHX_ OP *o)
6105 HV *table = GvHV(PL_hintgv);
6109 svp = hv_fetch(table, "open_IN", 7, FALSE);
6111 mode = mode_from_discipline(*svp);
6112 if (mode & O_BINARY)
6113 o->op_private |= OPpOPEN_IN_RAW;
6114 else if (mode & O_TEXT)
6115 o->op_private |= OPpOPEN_IN_CRLF;
6118 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6120 mode = mode_from_discipline(*svp);
6121 if (mode & O_BINARY)
6122 o->op_private |= OPpOPEN_OUT_RAW;
6123 else if (mode & O_TEXT)
6124 o->op_private |= OPpOPEN_OUT_CRLF;
6127 if (o->op_type == OP_BACKTICK)
6133 Perl_ck_repeat(pTHX_ OP *o)
6135 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6136 o->op_private |= OPpREPEAT_DOLIST;
6137 cBINOPo->op_first = force_list(cBINOPo->op_first);
6145 Perl_ck_require(pTHX_ OP *o)
6147 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6148 SVOP *kid = (SVOP*)cUNOPo->op_first;
6150 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6152 for (s = SvPVX(kid->op_sv); *s; s++) {
6153 if (*s == ':' && s[1] == ':') {
6155 Move(s+2, s+1, strlen(s+2)+1, char);
6156 --SvCUR(kid->op_sv);
6159 if (SvREADONLY(kid->op_sv)) {
6160 SvREADONLY_off(kid->op_sv);
6161 sv_catpvn(kid->op_sv, ".pm", 3);
6162 SvREADONLY_on(kid->op_sv);
6165 sv_catpvn(kid->op_sv, ".pm", 3);
6172 Perl_ck_return(pTHX_ OP *o)
6175 if (CvLVALUE(PL_compcv)) {
6176 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6177 mod(kid, OP_LEAVESUBLV);
6184 Perl_ck_retarget(pTHX_ OP *o)
6186 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6193 Perl_ck_select(pTHX_ OP *o)
6196 if (o->op_flags & OPf_KIDS) {
6197 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6198 if (kid && kid->op_sibling) {
6199 o->op_type = OP_SSELECT;
6200 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6202 return fold_constants(o);
6206 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6207 if (kid && kid->op_type == OP_RV2GV)
6208 kid->op_private &= ~HINT_STRICT_REFS;
6213 Perl_ck_shift(pTHX_ OP *o)
6215 I32 type = o->op_type;
6217 if (!(o->op_flags & OPf_KIDS)) {
6222 if (!CvUNIQUE(PL_compcv)) {
6223 argop = newOP(OP_PADAV, OPf_REF);
6224 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6227 argop = newUNOP(OP_RV2AV, 0,
6228 scalar(newGVOP(OP_GV, 0,
6229 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6232 argop = newUNOP(OP_RV2AV, 0,
6233 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6234 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6235 #endif /* USE_THREADS */
6236 return newUNOP(type, 0, scalar(argop));
6238 return scalar(modkids(ck_fun(o), type));
6242 Perl_ck_sort(pTHX_ OP *o)
6247 if (PL_hints & HINT_LOCALE)
6248 o->op_private |= OPpLOCALE;
6251 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6253 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6254 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6256 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6258 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6260 if (kid->op_type == OP_SCOPE) {
6264 else if (kid->op_type == OP_LEAVE) {
6265 if (o->op_type == OP_SORT) {
6266 null(kid); /* wipe out leave */
6269 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6270 if (k->op_next == kid)
6272 /* don't descend into loops */
6273 else if (k->op_type == OP_ENTERLOOP
6274 || k->op_type == OP_ENTERITER)
6276 k = cLOOPx(k)->op_lastop;
6281 kid->op_next = 0; /* just disconnect the leave */
6282 k = kLISTOP->op_first;
6287 if (o->op_type == OP_SORT) {
6288 /* provide scalar context for comparison function/block */
6294 o->op_flags |= OPf_SPECIAL;
6296 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6299 firstkid = firstkid->op_sibling;
6302 /* provide list context for arguments */
6303 if (o->op_type == OP_SORT)
6310 S_simplify_sort(pTHX_ OP *o)
6312 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6316 if (!(o->op_flags & OPf_STACKED))
6318 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6319 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6320 kid = kUNOP->op_first; /* get past null */
6321 if (kid->op_type != OP_SCOPE)
6323 kid = kLISTOP->op_last; /* get past scope */
6324 switch(kid->op_type) {
6332 k = kid; /* remember this node*/
6333 if (kBINOP->op_first->op_type != OP_RV2SV)
6335 kid = kBINOP->op_first; /* get past cmp */
6336 if (kUNOP->op_first->op_type != OP_GV)
6338 kid = kUNOP->op_first; /* get past rv2sv */
6340 if (GvSTASH(gv) != PL_curstash)
6342 if (strEQ(GvNAME(gv), "a"))
6344 else if (strEQ(GvNAME(gv), "b"))
6348 kid = k; /* back to cmp */
6349 if (kBINOP->op_last->op_type != OP_RV2SV)
6351 kid = kBINOP->op_last; /* down to 2nd arg */
6352 if (kUNOP->op_first->op_type != OP_GV)
6354 kid = kUNOP->op_first; /* get past rv2sv */
6356 if (GvSTASH(gv) != PL_curstash
6358 ? strNE(GvNAME(gv), "a")
6359 : strNE(GvNAME(gv), "b")))
6361 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6363 o->op_private |= OPpSORT_REVERSE;
6364 if (k->op_type == OP_NCMP)
6365 o->op_private |= OPpSORT_NUMERIC;
6366 if (k->op_type == OP_I_NCMP)
6367 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6368 kid = cLISTOPo->op_first->op_sibling;
6369 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6370 op_free(kid); /* then delete it */
6374 Perl_ck_split(pTHX_ OP *o)
6378 if (o->op_flags & OPf_STACKED)
6379 return no_fh_allowed(o);
6381 kid = cLISTOPo->op_first;
6382 if (kid->op_type != OP_NULL)
6383 Perl_croak(aTHX_ "panic: ck_split");
6384 kid = kid->op_sibling;
6385 op_free(cLISTOPo->op_first);
6386 cLISTOPo->op_first = kid;
6388 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6389 cLISTOPo->op_last = kid; /* There was only one element previously */
6392 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6393 OP *sibl = kid->op_sibling;
6394 kid->op_sibling = 0;
6395 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6396 if (cLISTOPo->op_first == cLISTOPo->op_last)
6397 cLISTOPo->op_last = kid;
6398 cLISTOPo->op_first = kid;
6399 kid->op_sibling = sibl;
6402 kid->op_type = OP_PUSHRE;
6403 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6406 if (!kid->op_sibling)
6407 append_elem(OP_SPLIT, o, newDEFSVOP());
6409 kid = kid->op_sibling;
6412 if (!kid->op_sibling)
6413 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6415 kid = kid->op_sibling;
6418 if (kid->op_sibling)
6419 return too_many_arguments(o,PL_op_desc[o->op_type]);
6425 Perl_ck_join(pTHX_ OP *o)
6427 if (ckWARN(WARN_SYNTAX)) {
6428 OP *kid = cLISTOPo->op_first->op_sibling;
6429 if (kid && kid->op_type == OP_MATCH) {
6430 char *pmstr = "STRING";
6431 if (kPMOP->op_pmregexp)
6432 pmstr = kPMOP->op_pmregexp->precomp;
6433 Perl_warner(aTHX_ WARN_SYNTAX,
6434 "/%s/ should probably be written as \"%s\"",
6442 Perl_ck_subr(pTHX_ OP *o)
6444 OP *prev = ((cUNOPo->op_first->op_sibling)
6445 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6446 OP *o2 = prev->op_sibling;
6455 o->op_private |= OPpENTERSUB_HASTARG;
6456 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6457 if (cvop->op_type == OP_RV2CV) {
6459 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6460 null(cvop); /* disable rv2cv */
6461 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6462 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6463 GV *gv = cGVOPx_gv(tmpop);
6466 tmpop->op_private |= OPpEARLY_CV;
6467 else if (SvPOK(cv)) {
6468 namegv = CvANON(cv) ? gv : CvGV(cv);
6469 proto = SvPV((SV*)cv, n_a);
6473 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6474 if (o2->op_type == OP_CONST)
6475 o2->op_private &= ~OPpCONST_STRICT;
6476 else if (o2->op_type == OP_LIST) {
6477 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6478 if (o && o->op_type == OP_CONST)
6479 o->op_private &= ~OPpCONST_STRICT;
6482 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6483 if (PERLDB_SUB && PL_curstash != PL_debstash)
6484 o->op_private |= OPpENTERSUB_DB;
6485 while (o2 != cvop) {
6489 return too_many_arguments(o, gv_ename(namegv));
6507 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6509 arg == 1 ? "block or sub {}" : "sub {}",
6510 gv_ename(namegv), o2);
6513 /* '*' allows any scalar type, including bareword */
6516 if (o2->op_type == OP_RV2GV)
6517 goto wrapref; /* autoconvert GLOB -> GLOBref */
6518 else if (o2->op_type == OP_CONST)
6519 o2->op_private &= ~OPpCONST_STRICT;
6520 else if (o2->op_type == OP_ENTERSUB) {
6521 /* accidental subroutine, revert to bareword */
6522 OP *gvop = ((UNOP*)o2)->op_first;
6523 if (gvop && gvop->op_type == OP_NULL) {
6524 gvop = ((UNOP*)gvop)->op_first;
6526 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6529 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6530 (gvop = ((UNOP*)gvop)->op_first) &&
6531 gvop->op_type == OP_GV)
6533 GV *gv = cGVOPx_gv(gvop);
6534 OP *sibling = o2->op_sibling;
6535 SV *n = newSVpvn("",0);
6537 gv_fullname3(n, gv, "");
6538 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6539 sv_chop(n, SvPVX(n)+6);
6540 o2 = newSVOP(OP_CONST, 0, n);
6541 prev->op_sibling = o2;
6542 o2->op_sibling = sibling;
6554 if (o2->op_type != OP_RV2GV)
6555 bad_type(arg, "symbol", gv_ename(namegv), o2);
6558 if (o2->op_type != OP_ENTERSUB)
6559 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6562 if (o2->op_type != OP_RV2SV
6563 && o2->op_type != OP_PADSV
6564 && o2->op_type != OP_HELEM
6565 && o2->op_type != OP_AELEM
6566 && o2->op_type != OP_THREADSV)
6568 bad_type(arg, "scalar", gv_ename(namegv), o2);
6572 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6573 bad_type(arg, "array", gv_ename(namegv), o2);
6576 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6577 bad_type(arg, "hash", gv_ename(namegv), o2);
6581 OP* sib = kid->op_sibling;
6582 kid->op_sibling = 0;
6583 o2 = newUNOP(OP_REFGEN, 0, kid);
6584 o2->op_sibling = sib;
6585 prev->op_sibling = o2;
6596 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6597 gv_ename(namegv), SvPV((SV*)cv, n_a));
6602 mod(o2, OP_ENTERSUB);
6604 o2 = o2->op_sibling;
6606 if (proto && !optional &&
6607 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6608 return too_few_arguments(o, gv_ename(namegv));
6613 Perl_ck_svconst(pTHX_ OP *o)
6615 SvREADONLY_on(cSVOPo->op_sv);
6620 Perl_ck_trunc(pTHX_ OP *o)
6622 if (o->op_flags & OPf_KIDS) {
6623 SVOP *kid = (SVOP*)cUNOPo->op_first;
6625 if (kid->op_type == OP_NULL)
6626 kid = (SVOP*)kid->op_sibling;
6627 if (kid && kid->op_type == OP_CONST &&
6628 (kid->op_private & OPpCONST_BARE))
6630 o->op_flags |= OPf_SPECIAL;
6631 kid->op_private &= ~OPpCONST_STRICT;
6638 Perl_ck_substr(pTHX_ OP *o)
6641 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6642 OP *kid = cLISTOPo->op_first;
6644 if (kid->op_type == OP_NULL)
6645 kid = kid->op_sibling;
6647 kid->op_flags |= OPf_MOD;
6653 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6656 Perl_peep(pTHX_ register OP *o)
6658 register OP* oldop = 0;
6661 if (!o || o->op_seq)
6665 SAVEVPTR(PL_curcop);
6666 for (; o; o = o->op_next) {
6672 switch (o->op_type) {
6676 PL_curcop = ((COP*)o); /* for warnings */
6677 o->op_seq = PL_op_seqmax++;
6681 if (cSVOPo->op_private & OPpCONST_STRICT)
6682 no_bareword_allowed(o);
6684 /* Relocate sv to the pad for thread safety.
6685 * Despite being a "constant", the SV is written to,
6686 * for reference counts, sv_upgrade() etc. */
6688 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6689 if (SvPADTMP(cSVOPo->op_sv)) {
6690 /* If op_sv is already a PADTMP then it is being used by
6691 * some pad, so make a copy. */
6692 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6693 SvREADONLY_on(PL_curpad[ix]);
6694 SvREFCNT_dec(cSVOPo->op_sv);
6697 SvREFCNT_dec(PL_curpad[ix]);
6698 SvPADTMP_on(cSVOPo->op_sv);
6699 PL_curpad[ix] = cSVOPo->op_sv;
6700 /* XXX I don't know how this isn't readonly already. */
6701 SvREADONLY_on(PL_curpad[ix]);
6703 cSVOPo->op_sv = Nullsv;
6707 o->op_seq = PL_op_seqmax++;
6711 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6712 if (o->op_next->op_private & OPpTARGET_MY) {
6713 if (o->op_flags & OPf_STACKED) /* chained concats */
6714 goto ignore_optimization;
6716 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6717 o->op_targ = o->op_next->op_targ;
6718 o->op_next->op_targ = 0;
6719 o->op_private |= OPpTARGET_MY;
6724 ignore_optimization:
6725 o->op_seq = PL_op_seqmax++;
6728 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6729 o->op_seq = PL_op_seqmax++;
6730 break; /* Scalar stub must produce undef. List stub is noop */
6734 if (o->op_targ == OP_NEXTSTATE
6735 || o->op_targ == OP_DBSTATE
6736 || o->op_targ == OP_SETSTATE)
6738 PL_curcop = ((COP*)o);
6745 if (oldop && o->op_next) {
6746 oldop->op_next = o->op_next;
6749 o->op_seq = PL_op_seqmax++;
6753 if (o->op_next->op_type == OP_RV2SV) {
6754 if (!(o->op_next->op_private & OPpDEREF)) {
6756 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6758 o->op_next = o->op_next->op_next;
6759 o->op_type = OP_GVSV;
6760 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6763 else if (o->op_next->op_type == OP_RV2AV) {
6764 OP* pop = o->op_next->op_next;
6766 if (pop->op_type == OP_CONST &&
6767 (PL_op = pop->op_next) &&
6768 pop->op_next->op_type == OP_AELEM &&
6769 !(pop->op_next->op_private &
6770 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6771 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6779 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6780 o->op_next = pop->op_next->op_next;
6781 o->op_type = OP_AELEMFAST;
6782 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6783 o->op_private = (U8)i;
6788 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6790 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6791 /* XXX could check prototype here instead of just carping */
6792 SV *sv = sv_newmortal();
6793 gv_efullname3(sv, gv, Nullch);
6794 Perl_warner(aTHX_ WARN_PROTOTYPE,
6795 "%s() called too early to check prototype",
6800 o->op_seq = PL_op_seqmax++;
6811 o->op_seq = PL_op_seqmax++;
6812 while (cLOGOP->op_other->op_type == OP_NULL)
6813 cLOGOP->op_other = cLOGOP->op_other->op_next;
6814 peep(cLOGOP->op_other);
6818 o->op_seq = PL_op_seqmax++;
6819 while (cLOOP->op_redoop->op_type == OP_NULL)
6820 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6821 peep(cLOOP->op_redoop);
6822 while (cLOOP->op_nextop->op_type == OP_NULL)
6823 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6824 peep(cLOOP->op_nextop);
6825 while (cLOOP->op_lastop->op_type == OP_NULL)
6826 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6827 peep(cLOOP->op_lastop);
6833 o->op_seq = PL_op_seqmax++;
6834 while (cPMOP->op_pmreplstart &&
6835 cPMOP->op_pmreplstart->op_type == OP_NULL)
6836 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6837 peep(cPMOP->op_pmreplstart);
6841 o->op_seq = PL_op_seqmax++;
6842 if (ckWARN(WARN_SYNTAX) && o->op_next
6843 && o->op_next->op_type == OP_NEXTSTATE) {
6844 if (o->op_next->op_sibling &&
6845 o->op_next->op_sibling->op_type != OP_EXIT &&
6846 o->op_next->op_sibling->op_type != OP_WARN &&
6847 o->op_next->op_sibling->op_type != OP_DIE) {
6848 line_t oldline = CopLINE(PL_curcop);
6850 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6851 Perl_warner(aTHX_ WARN_EXEC,
6852 "Statement unlikely to be reached");
6853 Perl_warner(aTHX_ WARN_EXEC,
6854 "\t(Maybe you meant system() when you said exec()?)\n");
6855 CopLINE_set(PL_curcop, oldline);
6864 SV **svp, **indsvp, *sv;
6869 o->op_seq = PL_op_seqmax++;
6871 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6874 /* Make the CONST have a shared SV */
6875 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6876 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6877 key = SvPV(sv, keylen);
6880 lexname = newSVpvn_share(key, keylen, 0);
6885 if ((o->op_private & (OPpLVAL_INTRO)))
6888 rop = (UNOP*)((BINOP*)o)->op_first;
6889 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6891 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6892 if (!SvOBJECT(lexname))
6894 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6895 if (!fields || !GvHV(*fields))
6897 key = SvPV(*svp, keylen);
6900 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6902 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6903 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6905 ind = SvIV(*indsvp);
6907 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6908 rop->op_type = OP_RV2AV;
6909 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6910 o->op_type = OP_AELEM;
6911 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6913 if (SvREADONLY(*svp))
6915 SvFLAGS(sv) |= (SvFLAGS(*svp)
6916 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6926 SV **svp, **indsvp, *sv;
6930 SVOP *first_key_op, *key_op;
6932 o->op_seq = PL_op_seqmax++;
6933 if ((o->op_private & (OPpLVAL_INTRO))
6934 /* I bet there's always a pushmark... */
6935 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6936 /* hmmm, no optimization if list contains only one key. */
6938 rop = (UNOP*)((LISTOP*)o)->op_last;
6939 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6941 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6942 if (!SvOBJECT(lexname))
6944 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6945 if (!fields || !GvHV(*fields))
6947 /* Again guessing that the pushmark can be jumped over.... */
6948 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6949 ->op_first->op_sibling;
6950 /* Check that the key list contains only constants. */
6951 for (key_op = first_key_op; key_op;
6952 key_op = (SVOP*)key_op->op_sibling)
6953 if (key_op->op_type != OP_CONST)
6957 rop->op_type = OP_RV2AV;
6958 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6959 o->op_type = OP_ASLICE;
6960 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6961 for (key_op = first_key_op; key_op;
6962 key_op = (SVOP*)key_op->op_sibling) {
6963 svp = cSVOPx_svp(key_op);
6964 key = SvPV(*svp, keylen);
6967 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6969 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6970 "in variable %s of type %s",
6971 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6973 ind = SvIV(*indsvp);
6975 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6977 if (SvREADONLY(*svp))
6979 SvFLAGS(sv) |= (SvFLAGS(*svp)
6980 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6988 o->op_seq = PL_op_seqmax++;
6998 /* Efficient sub that returns a constant scalar value. */
7000 const_sv_xsub(pTHXo_ CV* cv)
7005 Perl_croak(aTHX_ "usage: %s::%s()",
7006 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7010 ST(0) = (SV*)XSANY.any_ptr;