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? */
1959 o->op_private |= OPpOUR_INTRO;
1961 } else if (type != OP_PADSV &&
1964 type != OP_PUSHMARK)
1966 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1967 PL_op_desc[o->op_type],
1968 PL_in_my == KEY_our ? "our" : "my"));
1971 else if (attrs && type != OP_PUSHMARK) {
1977 PL_in_my_stash = Nullhv;
1979 /* check for C<my Dog $spot> when deciding package */
1980 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1981 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1982 stash = SvSTASH(*namesvp);
1984 stash = PL_curstash;
1985 padsv = PAD_SV(o->op_targ);
1986 apply_attrs(stash, padsv, attrs);
1988 o->op_flags |= OPf_MOD;
1989 o->op_private |= OPpLVAL_INTRO;
1994 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1996 if (o->op_flags & OPf_PARENS)
2000 o = my_kid(o, attrs);
2002 PL_in_my_stash = Nullhv;
2007 Perl_my(pTHX_ OP *o)
2009 return my_kid(o, Nullop);
2013 Perl_sawparens(pTHX_ OP *o)
2016 o->op_flags |= OPf_PARENS;
2021 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2025 if (ckWARN(WARN_MISC) &&
2026 (left->op_type == OP_RV2AV ||
2027 left->op_type == OP_RV2HV ||
2028 left->op_type == OP_PADAV ||
2029 left->op_type == OP_PADHV)) {
2030 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2031 right->op_type == OP_TRANS)
2032 ? right->op_type : OP_MATCH];
2033 const char *sample = ((left->op_type == OP_RV2AV ||
2034 left->op_type == OP_PADAV)
2035 ? "@array" : "%hash");
2036 Perl_warner(aTHX_ WARN_MISC,
2037 "Applying %s to %s will act on scalar(%s)",
2038 desc, sample, sample);
2041 if (!(right->op_flags & OPf_STACKED) &&
2042 (right->op_type == OP_MATCH ||
2043 right->op_type == OP_SUBST ||
2044 right->op_type == OP_TRANS)) {
2045 right->op_flags |= OPf_STACKED;
2046 if (right->op_type != OP_MATCH &&
2047 ! (right->op_type == OP_TRANS &&
2048 right->op_private & OPpTRANS_IDENTICAL))
2049 left = mod(left, right->op_type);
2050 if (right->op_type == OP_TRANS)
2051 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2053 o = prepend_elem(right->op_type, scalar(left), right);
2055 return newUNOP(OP_NOT, 0, scalar(o));
2059 return bind_match(type, left,
2060 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2064 Perl_invert(pTHX_ OP *o)
2068 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2069 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2073 Perl_scope(pTHX_ OP *o)
2076 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2077 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2078 o->op_type = OP_LEAVE;
2079 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2082 if (o->op_type == OP_LINESEQ) {
2084 o->op_type = OP_SCOPE;
2085 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2086 kid = ((LISTOP*)o)->op_first;
2087 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2091 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2098 Perl_save_hints(pTHX)
2101 SAVESPTR(GvHV(PL_hintgv));
2102 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2103 SAVEFREESV(GvHV(PL_hintgv));
2107 Perl_block_start(pTHX_ int full)
2109 int retval = PL_savestack_ix;
2111 SAVEI32(PL_comppad_name_floor);
2112 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2114 PL_comppad_name_fill = PL_comppad_name_floor;
2115 if (PL_comppad_name_floor < 0)
2116 PL_comppad_name_floor = 0;
2117 SAVEI32(PL_min_intro_pending);
2118 SAVEI32(PL_max_intro_pending);
2119 PL_min_intro_pending = 0;
2120 SAVEI32(PL_comppad_name_fill);
2121 SAVEI32(PL_padix_floor);
2122 PL_padix_floor = PL_padix;
2123 PL_pad_reset_pending = FALSE;
2125 PL_hints &= ~HINT_BLOCK_SCOPE;
2126 SAVESPTR(PL_compiling.cop_warnings);
2127 if (! specialWARN(PL_compiling.cop_warnings)) {
2128 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2129 SAVEFREESV(PL_compiling.cop_warnings) ;
2131 SAVESPTR(PL_compiling.cop_io);
2132 if (! specialCopIO(PL_compiling.cop_io)) {
2133 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2134 SAVEFREESV(PL_compiling.cop_io) ;
2140 Perl_block_end(pTHX_ I32 floor, OP *seq)
2142 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2143 OP* retval = scalarseq(seq);
2145 PL_pad_reset_pending = FALSE;
2146 PL_compiling.op_private = PL_hints;
2148 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2149 pad_leavemy(PL_comppad_name_fill);
2158 OP *o = newOP(OP_THREADSV, 0);
2159 o->op_targ = find_threadsv("_");
2162 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2163 #endif /* USE_THREADS */
2167 Perl_newPROG(pTHX_ OP *o)
2172 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2173 ((PL_in_eval & EVAL_KEEPERR)
2174 ? OPf_SPECIAL : 0), o);
2175 PL_eval_start = linklist(PL_eval_root);
2176 PL_eval_root->op_private |= OPpREFCOUNTED;
2177 OpREFCNT_set(PL_eval_root, 1);
2178 PL_eval_root->op_next = 0;
2179 peep(PL_eval_start);
2184 PL_main_root = scope(sawparens(scalarvoid(o)));
2185 PL_curcop = &PL_compiling;
2186 PL_main_start = LINKLIST(PL_main_root);
2187 PL_main_root->op_private |= OPpREFCOUNTED;
2188 OpREFCNT_set(PL_main_root, 1);
2189 PL_main_root->op_next = 0;
2190 peep(PL_main_start);
2193 /* Register with debugger */
2195 CV *cv = get_cv("DB::postponed", FALSE);
2199 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2201 call_sv((SV*)cv, G_DISCARD);
2208 Perl_localize(pTHX_ OP *o, I32 lex)
2210 if (o->op_flags & OPf_PARENS)
2213 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2215 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2216 if (*s == ';' || *s == '=')
2217 Perl_warner(aTHX_ WARN_PARENTHESIS,
2218 "Parentheses missing around \"%s\" list",
2219 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2225 o = mod(o, OP_NULL); /* a bit kludgey */
2227 PL_in_my_stash = Nullhv;
2232 Perl_jmaybe(pTHX_ OP *o)
2234 if (o->op_type == OP_LIST) {
2237 o2 = newOP(OP_THREADSV, 0);
2238 o2->op_targ = find_threadsv(";");
2240 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2241 #endif /* USE_THREADS */
2242 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2248 Perl_fold_constants(pTHX_ register OP *o)
2251 I32 type = o->op_type;
2254 if (PL_opargs[type] & OA_RETSCALAR)
2256 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2257 o->op_targ = pad_alloc(type, SVs_PADTMP);
2259 /* integerize op, unless it happens to be C<-foo>.
2260 * XXX should pp_i_negate() do magic string negation instead? */
2261 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2262 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2263 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2265 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2268 if (!(PL_opargs[type] & OA_FOLDCONST))
2273 /* XXX might want a ck_negate() for this */
2274 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2287 if (o->op_private & OPpLOCALE)
2292 goto nope; /* Don't try to run w/ errors */
2294 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2295 if ((curop->op_type != OP_CONST ||
2296 (curop->op_private & OPpCONST_BARE)) &&
2297 curop->op_type != OP_LIST &&
2298 curop->op_type != OP_SCALAR &&
2299 curop->op_type != OP_NULL &&
2300 curop->op_type != OP_PUSHMARK)
2306 curop = LINKLIST(o);
2310 sv = *(PL_stack_sp--);
2311 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2312 pad_swipe(o->op_targ);
2313 else if (SvTEMP(sv)) { /* grab mortal temp? */
2314 (void)SvREFCNT_inc(sv);
2318 if (type == OP_RV2GV)
2319 return newGVOP(OP_GV, 0, (GV*)sv);
2321 /* try to smush double to int, but don't smush -2.0 to -2 */
2322 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2325 #ifdef PERL_PRESERVE_IVUV
2326 /* Only bother to attempt to fold to IV if
2327 most operators will benefit */
2331 return newSVOP(OP_CONST, 0, sv);
2335 if (!(PL_opargs[type] & OA_OTHERINT))
2338 if (!(PL_hints & HINT_INTEGER)) {
2339 if (type == OP_MODULO
2340 || type == OP_DIVIDE
2341 || !(o->op_flags & OPf_KIDS))
2346 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2347 if (curop->op_type == OP_CONST) {
2348 if (SvIOK(((SVOP*)curop)->op_sv))
2352 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2356 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2363 Perl_gen_constant_list(pTHX_ register OP *o)
2366 I32 oldtmps_floor = PL_tmps_floor;
2370 return o; /* Don't attempt to run with errors */
2372 PL_op = curop = LINKLIST(o);
2379 PL_tmps_floor = oldtmps_floor;
2381 o->op_type = OP_RV2AV;
2382 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2383 curop = ((UNOP*)o)->op_first;
2384 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2391 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2396 if (!o || o->op_type != OP_LIST)
2397 o = newLISTOP(OP_LIST, 0, o, Nullop);
2399 o->op_flags &= ~OPf_WANT;
2401 if (!(PL_opargs[type] & OA_MARK))
2402 null(cLISTOPo->op_first);
2405 o->op_ppaddr = PL_ppaddr[type];
2406 o->op_flags |= flags;
2408 o = CHECKOP(type, o);
2409 if (o->op_type != type)
2412 return fold_constants(o);
2415 /* List constructors */
2418 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2426 if (first->op_type != type
2427 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2429 return newLISTOP(type, 0, first, last);
2432 if (first->op_flags & OPf_KIDS)
2433 ((LISTOP*)first)->op_last->op_sibling = last;
2435 first->op_flags |= OPf_KIDS;
2436 ((LISTOP*)first)->op_first = last;
2438 ((LISTOP*)first)->op_last = last;
2443 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2451 if (first->op_type != type)
2452 return prepend_elem(type, (OP*)first, (OP*)last);
2454 if (last->op_type != type)
2455 return append_elem(type, (OP*)first, (OP*)last);
2457 first->op_last->op_sibling = last->op_first;
2458 first->op_last = last->op_last;
2459 first->op_flags |= (last->op_flags & OPf_KIDS);
2461 #ifdef PL_OP_SLAB_ALLOC
2469 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2477 if (last->op_type == type) {
2478 if (type == OP_LIST) { /* already a PUSHMARK there */
2479 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2480 ((LISTOP*)last)->op_first->op_sibling = first;
2481 if (!(first->op_flags & OPf_PARENS))
2482 last->op_flags &= ~OPf_PARENS;
2485 if (!(last->op_flags & OPf_KIDS)) {
2486 ((LISTOP*)last)->op_last = first;
2487 last->op_flags |= OPf_KIDS;
2489 first->op_sibling = ((LISTOP*)last)->op_first;
2490 ((LISTOP*)last)->op_first = first;
2492 last->op_flags |= OPf_KIDS;
2496 return newLISTOP(type, 0, first, last);
2502 Perl_newNULLLIST(pTHX)
2504 return newOP(OP_STUB, 0);
2508 Perl_force_list(pTHX_ OP *o)
2510 if (!o || o->op_type != OP_LIST)
2511 o = newLISTOP(OP_LIST, 0, o, Nullop);
2517 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2521 NewOp(1101, listop, 1, LISTOP);
2523 listop->op_type = type;
2524 listop->op_ppaddr = PL_ppaddr[type];
2527 listop->op_flags = flags;
2531 else if (!first && last)
2534 first->op_sibling = last;
2535 listop->op_first = first;
2536 listop->op_last = last;
2537 if (type == OP_LIST) {
2539 pushop = newOP(OP_PUSHMARK, 0);
2540 pushop->op_sibling = first;
2541 listop->op_first = pushop;
2542 listop->op_flags |= OPf_KIDS;
2544 listop->op_last = pushop;
2551 Perl_newOP(pTHX_ I32 type, I32 flags)
2554 NewOp(1101, o, 1, OP);
2556 o->op_ppaddr = PL_ppaddr[type];
2557 o->op_flags = flags;
2560 o->op_private = 0 + (flags >> 8);
2561 if (PL_opargs[type] & OA_RETSCALAR)
2563 if (PL_opargs[type] & OA_TARGET)
2564 o->op_targ = pad_alloc(type, SVs_PADTMP);
2565 return CHECKOP(type, o);
2569 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2574 first = newOP(OP_STUB, 0);
2575 if (PL_opargs[type] & OA_MARK)
2576 first = force_list(first);
2578 NewOp(1101, unop, 1, UNOP);
2579 unop->op_type = type;
2580 unop->op_ppaddr = PL_ppaddr[type];
2581 unop->op_first = first;
2582 unop->op_flags = flags | OPf_KIDS;
2583 unop->op_private = 1 | (flags >> 8);
2584 unop = (UNOP*) CHECKOP(type, unop);
2588 return fold_constants((OP *) unop);
2592 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2595 NewOp(1101, binop, 1, BINOP);
2598 first = newOP(OP_NULL, 0);
2600 binop->op_type = type;
2601 binop->op_ppaddr = PL_ppaddr[type];
2602 binop->op_first = first;
2603 binop->op_flags = flags | OPf_KIDS;
2606 binop->op_private = 1 | (flags >> 8);
2609 binop->op_private = 2 | (flags >> 8);
2610 first->op_sibling = last;
2613 binop = (BINOP*)CHECKOP(type, binop);
2614 if (binop->op_next || binop->op_type != type)
2617 binop->op_last = binop->op_first->op_sibling;
2619 return fold_constants((OP *)binop);
2623 utf8compare(const void *a, const void *b)
2626 for (i = 0; i < 10; i++) {
2627 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2629 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2636 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2638 SV *tstr = ((SVOP*)expr)->op_sv;
2639 SV *rstr = ((SVOP*)repl)->op_sv;
2642 U8 *t = (U8*)SvPV(tstr, tlen);
2643 U8 *r = (U8*)SvPV(rstr, rlen);
2650 register short *tbl;
2652 complement = o->op_private & OPpTRANS_COMPLEMENT;
2653 del = o->op_private & OPpTRANS_DELETE;
2654 squash = o->op_private & OPpTRANS_SQUASH;
2657 o->op_private |= OPpTRANS_FROM_UTF;
2660 o->op_private |= OPpTRANS_TO_UTF;
2662 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2663 SV* listsv = newSVpvn("# comment\n",10);
2665 U8* tend = t + tlen;
2666 U8* rend = r + rlen;
2680 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2681 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2682 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2683 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2686 U8 tmpbuf[UTF8_MAXLEN+1];
2690 New(1109, cp, tlen, U8*);
2692 transv = newSVpvn("",0);
2696 if (t < tend && *t == 0xff) {
2701 qsort(cp, i, sizeof(U8*), utf8compare);
2702 for (j = 0; j < i; j++) {
2704 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2705 UV val = utf8_to_uv(s, cur, &ulen, 0);
2707 diff = val - nextmin;
2709 t = uv_to_utf8(tmpbuf,nextmin);
2710 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2712 t = uv_to_utf8(tmpbuf, val - 1);
2713 sv_catpvn(transv, "\377", 1);
2714 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2717 if (s < tend && *s == 0xff)
2718 val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2722 t = uv_to_utf8(tmpbuf,nextmin);
2723 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2724 t = uv_to_utf8(tmpbuf, 0x7fffffff);
2725 sv_catpvn(transv, "\377", 1);
2726 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2727 t = (U8*)SvPVX(transv);
2728 tlen = SvCUR(transv);
2732 else if (!rlen && !del) {
2733 r = t; rlen = tlen; rend = tend;
2737 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2739 o->op_private |= OPpTRANS_IDENTICAL;
2743 while (t < tend || tfirst <= tlast) {
2744 /* see if we need more "t" chars */
2745 if (tfirst > tlast) {
2746 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2748 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2750 tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2757 /* now see if we need more "r" chars */
2758 if (rfirst > rlast) {
2760 rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2762 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2764 rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2773 rfirst = rlast = 0xffffffff;
2777 /* now see which range will peter our first, if either. */
2778 tdiff = tlast - tfirst;
2779 rdiff = rlast - rfirst;
2786 if (rfirst == 0xffffffff) {
2787 diff = tdiff; /* oops, pretend rdiff is infinite */
2789 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2790 (long)tfirst, (long)tlast);
2792 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2796 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2797 (long)tfirst, (long)(tfirst + diff),
2800 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2801 (long)tfirst, (long)rfirst);
2803 if (rfirst + diff > max)
2804 max = rfirst + diff;
2807 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2818 else if (max > 0xff)
2823 Safefree(cPVOPo->op_pv);
2824 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2825 SvREFCNT_dec(listsv);
2827 SvREFCNT_dec(transv);
2829 if (!del && havefinal)
2830 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2831 newSVuv((UV)final), 0);
2834 o->op_private |= OPpTRANS_GROWS;
2846 tbl = (short*)cPVOPo->op_pv;
2848 Zero(tbl, 256, short);
2849 for (i = 0; i < tlen; i++)
2851 for (i = 0, j = 0; i < 256; i++) {
2862 if (i < 128 && r[j] >= 128)
2870 if (!rlen && !del) {
2873 o->op_private |= OPpTRANS_IDENTICAL;
2875 for (i = 0; i < 256; i++)
2877 for (i = 0, j = 0; i < tlen; i++,j++) {
2880 if (tbl[t[i]] == -1)
2886 if (tbl[t[i]] == -1) {
2887 if (t[i] < 128 && r[j] >= 128)
2894 o->op_private |= OPpTRANS_GROWS;
2902 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2906 NewOp(1101, pmop, 1, PMOP);
2907 pmop->op_type = type;
2908 pmop->op_ppaddr = PL_ppaddr[type];
2909 pmop->op_flags = flags;
2910 pmop->op_private = 0 | (flags >> 8);
2912 if (PL_hints & HINT_RE_TAINT)
2913 pmop->op_pmpermflags |= PMf_RETAINT;
2914 if (PL_hints & HINT_LOCALE)
2915 pmop->op_pmpermflags |= PMf_LOCALE;
2916 pmop->op_pmflags = pmop->op_pmpermflags;
2918 /* link into pm list */
2919 if (type != OP_TRANS && PL_curstash) {
2920 pmop->op_pmnext = HvPMROOT(PL_curstash);
2921 HvPMROOT(PL_curstash) = pmop;
2928 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2932 I32 repl_has_vars = 0;
2934 if (o->op_type == OP_TRANS)
2935 return pmtrans(o, expr, repl);
2937 PL_hints |= HINT_BLOCK_SCOPE;
2940 if (expr->op_type == OP_CONST) {
2942 SV *pat = ((SVOP*)expr)->op_sv;
2943 char *p = SvPV(pat, plen);
2944 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2945 sv_setpvn(pat, "\\s+", 3);
2946 p = SvPV(pat, plen);
2947 pm->op_pmflags |= PMf_SKIPWHITE;
2949 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2950 pm->op_pmdynflags |= PMdf_UTF8;
2951 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2952 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2953 pm->op_pmflags |= PMf_WHITE;
2957 if (PL_hints & HINT_UTF8)
2958 pm->op_pmdynflags |= PMdf_UTF8;
2959 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2960 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2962 : OP_REGCMAYBE),0,expr);
2964 NewOp(1101, rcop, 1, LOGOP);
2965 rcop->op_type = OP_REGCOMP;
2966 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2967 rcop->op_first = scalar(expr);
2968 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2969 ? (OPf_SPECIAL | OPf_KIDS)
2971 rcop->op_private = 1;
2974 /* establish postfix order */
2975 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2977 rcop->op_next = expr;
2978 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2981 rcop->op_next = LINKLIST(expr);
2982 expr->op_next = (OP*)rcop;
2985 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2990 if (pm->op_pmflags & PMf_EVAL) {
2992 if (CopLINE(PL_curcop) < PL_multi_end)
2993 CopLINE_set(PL_curcop, PL_multi_end);
2996 else if (repl->op_type == OP_THREADSV
2997 && strchr("&`'123456789+",
2998 PL_threadsv_names[repl->op_targ]))
3002 #endif /* USE_THREADS */
3003 else if (repl->op_type == OP_CONST)
3007 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3008 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3010 if (curop->op_type == OP_THREADSV) {
3012 if (strchr("&`'123456789+", curop->op_private))
3016 if (curop->op_type == OP_GV) {
3017 GV *gv = cGVOPx_gv(curop);
3019 if (strchr("&`'123456789+", *GvENAME(gv)))
3022 #endif /* USE_THREADS */
3023 else if (curop->op_type == OP_RV2CV)
3025 else if (curop->op_type == OP_RV2SV ||
3026 curop->op_type == OP_RV2AV ||
3027 curop->op_type == OP_RV2HV ||
3028 curop->op_type == OP_RV2GV) {
3029 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3032 else if (curop->op_type == OP_PADSV ||
3033 curop->op_type == OP_PADAV ||
3034 curop->op_type == OP_PADHV ||
3035 curop->op_type == OP_PADANY) {
3038 else if (curop->op_type == OP_PUSHRE)
3039 ; /* Okay here, dangerous in newASSIGNOP */
3048 && (!pm->op_pmregexp
3049 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3050 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3051 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3052 prepend_elem(o->op_type, scalar(repl), o);
3055 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3056 pm->op_pmflags |= PMf_MAYBE_CONST;
3057 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3059 NewOp(1101, rcop, 1, LOGOP);
3060 rcop->op_type = OP_SUBSTCONT;
3061 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3062 rcop->op_first = scalar(repl);
3063 rcop->op_flags |= OPf_KIDS;
3064 rcop->op_private = 1;
3067 /* establish postfix order */
3068 rcop->op_next = LINKLIST(repl);
3069 repl->op_next = (OP*)rcop;
3071 pm->op_pmreplroot = scalar((OP*)rcop);
3072 pm->op_pmreplstart = LINKLIST(rcop);
3081 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3084 NewOp(1101, svop, 1, SVOP);
3085 svop->op_type = type;
3086 svop->op_ppaddr = PL_ppaddr[type];
3088 svop->op_next = (OP*)svop;
3089 svop->op_flags = flags;
3090 if (PL_opargs[type] & OA_RETSCALAR)
3092 if (PL_opargs[type] & OA_TARGET)
3093 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3094 return CHECKOP(type, svop);
3098 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3101 NewOp(1101, padop, 1, PADOP);
3102 padop->op_type = type;
3103 padop->op_ppaddr = PL_ppaddr[type];
3104 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3105 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3106 PL_curpad[padop->op_padix] = sv;
3108 padop->op_next = (OP*)padop;
3109 padop->op_flags = flags;
3110 if (PL_opargs[type] & OA_RETSCALAR)
3112 if (PL_opargs[type] & OA_TARGET)
3113 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3114 return CHECKOP(type, padop);
3118 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3122 return newPADOP(type, flags, SvREFCNT_inc(gv));
3124 return newSVOP(type, flags, SvREFCNT_inc(gv));
3129 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3132 NewOp(1101, pvop, 1, PVOP);
3133 pvop->op_type = type;
3134 pvop->op_ppaddr = PL_ppaddr[type];
3136 pvop->op_next = (OP*)pvop;
3137 pvop->op_flags = flags;
3138 if (PL_opargs[type] & OA_RETSCALAR)
3140 if (PL_opargs[type] & OA_TARGET)
3141 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3142 return CHECKOP(type, pvop);
3146 Perl_package(pTHX_ OP *o)
3150 save_hptr(&PL_curstash);
3151 save_item(PL_curstname);
3156 name = SvPV(sv, len);
3157 PL_curstash = gv_stashpvn(name,len,TRUE);
3158 sv_setpvn(PL_curstname, name, len);
3162 sv_setpv(PL_curstname,"<none>");
3163 PL_curstash = Nullhv;
3165 PL_hints |= HINT_BLOCK_SCOPE;
3166 PL_copline = NOLINE;
3171 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3179 if (id->op_type != OP_CONST)
3180 Perl_croak(aTHX_ "Module name must be constant");
3184 if (version != Nullop) {
3185 SV *vesv = ((SVOP*)version)->op_sv;
3187 if (arg == Nullop && !SvNIOKp(vesv)) {
3194 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3195 Perl_croak(aTHX_ "Version number must be constant number");
3197 /* Make copy of id so we don't free it twice */
3198 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3200 /* Fake up a method call to VERSION */
3201 meth = newSVpvn("VERSION",7);
3202 sv_upgrade(meth, SVt_PVIV);
3203 (void)SvIOK_on(meth);
3204 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3205 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3206 append_elem(OP_LIST,
3207 prepend_elem(OP_LIST, pack, list(version)),
3208 newSVOP(OP_METHOD_NAMED, 0, meth)));
3212 /* Fake up an import/unimport */
3213 if (arg && arg->op_type == OP_STUB)
3214 imop = arg; /* no import on explicit () */
3215 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3216 imop = Nullop; /* use 5.0; */
3221 /* Make copy of id so we don't free it twice */
3222 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3224 /* Fake up a method call to import/unimport */
3225 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3226 sv_upgrade(meth, SVt_PVIV);
3227 (void)SvIOK_on(meth);
3228 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3229 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3230 append_elem(OP_LIST,
3231 prepend_elem(OP_LIST, pack, list(arg)),
3232 newSVOP(OP_METHOD_NAMED, 0, meth)));
3235 /* Fake up a require, handle override, if any */
3236 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3237 if (!(gv && GvIMPORTED_CV(gv)))
3238 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3240 if (gv && GvIMPORTED_CV(gv)) {
3241 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3242 append_elem(OP_LIST, id,
3243 scalar(newUNOP(OP_RV2CV, 0,
3248 rqop = newUNOP(OP_REQUIRE, 0, id);
3251 /* Fake up the BEGIN {}, which does its thing immediately. */
3253 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3256 append_elem(OP_LINESEQ,
3257 append_elem(OP_LINESEQ,
3258 newSTATEOP(0, Nullch, rqop),
3259 newSTATEOP(0, Nullch, veop)),
3260 newSTATEOP(0, Nullch, imop) ));
3262 PL_hints |= HINT_BLOCK_SCOPE;
3263 PL_copline = NOLINE;
3268 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3271 va_start(args, ver);
3272 vload_module(flags, name, ver, &args);
3276 #ifdef PERL_IMPLICIT_CONTEXT
3278 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3282 va_start(args, ver);
3283 vload_module(flags, name, ver, &args);
3289 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3291 OP *modname, *veop, *imop;
3293 modname = newSVOP(OP_CONST, 0, name);
3294 modname->op_private |= OPpCONST_BARE;
3296 veop = newSVOP(OP_CONST, 0, ver);
3300 if (flags & PERL_LOADMOD_NOIMPORT) {
3301 imop = sawparens(newNULLLIST());
3303 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3304 imop = va_arg(*args, OP*);
3309 sv = va_arg(*args, SV*);
3311 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3312 sv = va_arg(*args, SV*);
3316 line_t ocopline = PL_copline;
3317 int oexpect = PL_expect;
3319 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3320 veop, modname, imop);
3321 PL_expect = oexpect;
3322 PL_copline = ocopline;
3327 Perl_dofile(pTHX_ OP *term)
3332 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3333 if (!(gv && GvIMPORTED_CV(gv)))
3334 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3336 if (gv && GvIMPORTED_CV(gv)) {
3337 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3338 append_elem(OP_LIST, term,
3339 scalar(newUNOP(OP_RV2CV, 0,
3344 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3350 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3352 return newBINOP(OP_LSLICE, flags,
3353 list(force_list(subscript)),
3354 list(force_list(listval)) );
3358 S_list_assignment(pTHX_ register OP *o)
3363 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3364 o = cUNOPo->op_first;
3366 if (o->op_type == OP_COND_EXPR) {
3367 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3368 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3373 yyerror("Assignment to both a list and a scalar");
3377 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3378 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3379 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3382 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3385 if (o->op_type == OP_RV2SV)
3392 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3397 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3398 return newLOGOP(optype, 0,
3399 mod(scalar(left), optype),
3400 newUNOP(OP_SASSIGN, 0, scalar(right)));
3403 return newBINOP(optype, OPf_STACKED,
3404 mod(scalar(left), optype), scalar(right));
3408 if (list_assignment(left)) {
3412 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3413 left = mod(left, OP_AASSIGN);
3421 curop = list(force_list(left));
3422 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3423 o->op_private = 0 | (flags >> 8);
3424 for (curop = ((LISTOP*)curop)->op_first;
3425 curop; curop = curop->op_sibling)
3427 if (curop->op_type == OP_RV2HV &&
3428 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3429 o->op_private |= OPpASSIGN_HASH;
3433 if (!(left->op_private & OPpLVAL_INTRO)) {
3436 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3437 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3438 if (curop->op_type == OP_GV) {
3439 GV *gv = cGVOPx_gv(curop);
3440 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3442 SvCUR(gv) = PL_generation;
3444 else if (curop->op_type == OP_PADSV ||
3445 curop->op_type == OP_PADAV ||
3446 curop->op_type == OP_PADHV ||
3447 curop->op_type == OP_PADANY) {
3448 SV **svp = AvARRAY(PL_comppad_name);
3449 SV *sv = svp[curop->op_targ];
3450 if (SvCUR(sv) == PL_generation)
3452 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3454 else if (curop->op_type == OP_RV2CV)
3456 else if (curop->op_type == OP_RV2SV ||
3457 curop->op_type == OP_RV2AV ||
3458 curop->op_type == OP_RV2HV ||
3459 curop->op_type == OP_RV2GV) {
3460 if (lastop->op_type != OP_GV) /* funny deref? */
3463 else if (curop->op_type == OP_PUSHRE) {
3464 if (((PMOP*)curop)->op_pmreplroot) {
3466 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3468 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3470 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3472 SvCUR(gv) = PL_generation;
3481 o->op_private |= OPpASSIGN_COMMON;
3483 if (right && right->op_type == OP_SPLIT) {
3485 if ((tmpop = ((LISTOP*)right)->op_first) &&
3486 tmpop->op_type == OP_PUSHRE)
3488 PMOP *pm = (PMOP*)tmpop;
3489 if (left->op_type == OP_RV2AV &&
3490 !(left->op_private & OPpLVAL_INTRO) &&
3491 !(o->op_private & OPpASSIGN_COMMON) )
3493 tmpop = ((UNOP*)left)->op_first;
3494 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3496 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3497 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3499 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3500 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3502 pm->op_pmflags |= PMf_ONCE;
3503 tmpop = cUNOPo->op_first; /* to list (nulled) */
3504 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3505 tmpop->op_sibling = Nullop; /* don't free split */
3506 right->op_next = tmpop->op_next; /* fix starting loc */
3507 op_free(o); /* blow off assign */
3508 right->op_flags &= ~OPf_WANT;
3509 /* "I don't know and I don't care." */
3514 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3515 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3517 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3519 sv_setiv(sv, PL_modcount+1);
3527 right = newOP(OP_UNDEF, 0);
3528 if (right->op_type == OP_READLINE) {
3529 right->op_flags |= OPf_STACKED;
3530 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3533 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3534 o = newBINOP(OP_SASSIGN, flags,
3535 scalar(right), mod(scalar(left), OP_SASSIGN) );
3547 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3549 U32 seq = intro_my();
3552 NewOp(1101, cop, 1, COP);
3553 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3554 cop->op_type = OP_DBSTATE;
3555 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3558 cop->op_type = OP_NEXTSTATE;
3559 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3561 cop->op_flags = flags;
3562 cop->op_private = (PL_hints & HINT_BYTE);
3564 cop->op_private |= NATIVE_HINTS;
3566 PL_compiling.op_private = cop->op_private;
3567 cop->op_next = (OP*)cop;
3570 cop->cop_label = label;
3571 PL_hints |= HINT_BLOCK_SCOPE;
3574 cop->cop_arybase = PL_curcop->cop_arybase;
3575 if (specialWARN(PL_curcop->cop_warnings))
3576 cop->cop_warnings = PL_curcop->cop_warnings ;
3578 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3579 if (specialCopIO(PL_curcop->cop_io))
3580 cop->cop_io = PL_curcop->cop_io;
3582 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3585 if (PL_copline == NOLINE)
3586 CopLINE_set(cop, CopLINE(PL_curcop));
3588 CopLINE_set(cop, PL_copline);
3589 PL_copline = NOLINE;
3592 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3594 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3596 CopSTASH_set(cop, PL_curstash);
3598 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3599 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3600 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3601 (void)SvIOK_on(*svp);
3602 SvIVX(*svp) = PTR2IV(cop);
3606 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3609 /* "Introduce" my variables to visible status. */
3617 if (! PL_min_intro_pending)
3618 return PL_cop_seqmax;
3620 svp = AvARRAY(PL_comppad_name);
3621 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3622 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3623 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3624 SvNVX(sv) = (NV)PL_cop_seqmax;
3627 PL_min_intro_pending = 0;
3628 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3629 return PL_cop_seqmax++;
3633 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3635 return new_logop(type, flags, &first, &other);
3639 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3643 OP *first = *firstp;
3644 OP *other = *otherp;
3646 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3647 return newBINOP(type, flags, scalar(first), scalar(other));
3649 scalarboolean(first);
3650 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3651 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3652 if (type == OP_AND || type == OP_OR) {
3658 first = *firstp = cUNOPo->op_first;
3660 first->op_next = o->op_next;
3661 cUNOPo->op_first = Nullop;
3665 if (first->op_type == OP_CONST) {
3666 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3667 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3668 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3679 else if (first->op_type == OP_WANTARRAY) {
3685 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3686 OP *k1 = ((UNOP*)first)->op_first;
3687 OP *k2 = k1->op_sibling;
3689 switch (first->op_type)
3692 if (k2 && k2->op_type == OP_READLINE
3693 && (k2->op_flags & OPf_STACKED)
3694 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3696 warnop = k2->op_type;
3701 if (k1->op_type == OP_READDIR
3702 || k1->op_type == OP_GLOB
3703 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3704 || k1->op_type == OP_EACH)
3706 warnop = ((k1->op_type == OP_NULL)
3707 ? k1->op_targ : k1->op_type);
3712 line_t oldline = CopLINE(PL_curcop);
3713 CopLINE_set(PL_curcop, PL_copline);
3714 Perl_warner(aTHX_ WARN_MISC,
3715 "Value of %s%s can be \"0\"; test with defined()",
3717 ((warnop == OP_READLINE || warnop == OP_GLOB)
3718 ? " construct" : "() operator"));
3719 CopLINE_set(PL_curcop, oldline);
3726 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3727 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3729 NewOp(1101, logop, 1, LOGOP);
3731 logop->op_type = type;
3732 logop->op_ppaddr = PL_ppaddr[type];
3733 logop->op_first = first;
3734 logop->op_flags = flags | OPf_KIDS;
3735 logop->op_other = LINKLIST(other);
3736 logop->op_private = 1 | (flags >> 8);
3738 /* establish postfix order */
3739 logop->op_next = LINKLIST(first);
3740 first->op_next = (OP*)logop;
3741 first->op_sibling = other;
3743 o = newUNOP(OP_NULL, 0, (OP*)logop);
3750 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3757 return newLOGOP(OP_AND, 0, first, trueop);
3759 return newLOGOP(OP_OR, 0, first, falseop);
3761 scalarboolean(first);
3762 if (first->op_type == OP_CONST) {
3763 if (SvTRUE(((SVOP*)first)->op_sv)) {
3774 else if (first->op_type == OP_WANTARRAY) {
3778 NewOp(1101, logop, 1, LOGOP);
3779 logop->op_type = OP_COND_EXPR;
3780 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3781 logop->op_first = first;
3782 logop->op_flags = flags | OPf_KIDS;
3783 logop->op_private = 1 | (flags >> 8);
3784 logop->op_other = LINKLIST(trueop);
3785 logop->op_next = LINKLIST(falseop);
3788 /* establish postfix order */
3789 start = LINKLIST(first);
3790 first->op_next = (OP*)logop;
3792 first->op_sibling = trueop;
3793 trueop->op_sibling = falseop;
3794 o = newUNOP(OP_NULL, 0, (OP*)logop);
3796 trueop->op_next = falseop->op_next = o;
3803 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3811 NewOp(1101, range, 1, LOGOP);
3813 range->op_type = OP_RANGE;
3814 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3815 range->op_first = left;
3816 range->op_flags = OPf_KIDS;
3817 leftstart = LINKLIST(left);
3818 range->op_other = LINKLIST(right);
3819 range->op_private = 1 | (flags >> 8);
3821 left->op_sibling = right;
3823 range->op_next = (OP*)range;
3824 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3825 flop = newUNOP(OP_FLOP, 0, flip);
3826 o = newUNOP(OP_NULL, 0, flop);
3828 range->op_next = leftstart;
3830 left->op_next = flip;
3831 right->op_next = flop;
3833 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3834 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3835 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3836 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3838 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3839 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3842 if (!flip->op_private || !flop->op_private)
3843 linklist(o); /* blow off optimizer unless constant */
3849 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3853 int once = block && block->op_flags & OPf_SPECIAL &&
3854 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3857 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3858 return block; /* do {} while 0 does once */
3859 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3860 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3861 expr = newUNOP(OP_DEFINED, 0,
3862 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3863 } else if (expr->op_flags & OPf_KIDS) {
3864 OP *k1 = ((UNOP*)expr)->op_first;
3865 OP *k2 = (k1) ? k1->op_sibling : NULL;
3866 switch (expr->op_type) {
3868 if (k2 && k2->op_type == OP_READLINE
3869 && (k2->op_flags & OPf_STACKED)
3870 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3871 expr = newUNOP(OP_DEFINED, 0, expr);
3875 if (k1->op_type == OP_READDIR
3876 || k1->op_type == OP_GLOB
3877 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3878 || k1->op_type == OP_EACH)
3879 expr = newUNOP(OP_DEFINED, 0, expr);
3885 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3886 o = new_logop(OP_AND, 0, &expr, &listop);
3889 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3891 if (once && o != listop)
3892 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3895 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3897 o->op_flags |= flags;
3899 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3904 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3913 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3914 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3915 expr = newUNOP(OP_DEFINED, 0,
3916 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3917 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3918 OP *k1 = ((UNOP*)expr)->op_first;
3919 OP *k2 = (k1) ? k1->op_sibling : NULL;
3920 switch (expr->op_type) {
3922 if (k2 && k2->op_type == OP_READLINE
3923 && (k2->op_flags & OPf_STACKED)
3924 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3925 expr = newUNOP(OP_DEFINED, 0, expr);
3929 if (k1->op_type == OP_READDIR
3930 || k1->op_type == OP_GLOB
3931 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3932 || k1->op_type == OP_EACH)
3933 expr = newUNOP(OP_DEFINED, 0, expr);
3939 block = newOP(OP_NULL, 0);
3941 block = scope(block);
3945 next = LINKLIST(cont);
3948 OP *unstack = newOP(OP_UNSTACK, 0);
3951 cont = append_elem(OP_LINESEQ, cont, unstack);
3952 if ((line_t)whileline != NOLINE) {
3953 PL_copline = whileline;
3954 cont = append_elem(OP_LINESEQ, cont,
3955 newSTATEOP(0, Nullch, Nullop));
3959 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3960 redo = LINKLIST(listop);
3963 PL_copline = whileline;
3965 o = new_logop(OP_AND, 0, &expr, &listop);
3966 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3967 op_free(expr); /* oops, it's a while (0) */
3969 return Nullop; /* listop already freed by new_logop */
3972 ((LISTOP*)listop)->op_last->op_next = condop =
3973 (o == listop ? redo : LINKLIST(o));
3979 NewOp(1101,loop,1,LOOP);
3980 loop->op_type = OP_ENTERLOOP;
3981 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3982 loop->op_private = 0;
3983 loop->op_next = (OP*)loop;
3986 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3988 loop->op_redoop = redo;
3989 loop->op_lastop = o;
3990 o->op_private |= loopflags;
3993 loop->op_nextop = next;
3995 loop->op_nextop = o;
3997 o->op_flags |= flags;
3998 o->op_private |= (flags >> 8);
4003 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4011 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4012 sv->op_type = OP_RV2GV;
4013 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4015 else if (sv->op_type == OP_PADSV) { /* private variable */
4016 padoff = sv->op_targ;
4021 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4022 padoff = sv->op_targ;
4024 iterflags |= OPf_SPECIAL;
4029 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4033 padoff = find_threadsv("_");
4034 iterflags |= OPf_SPECIAL;
4036 sv = newGVOP(OP_GV, 0, PL_defgv);
4039 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4040 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4041 iterflags |= OPf_STACKED;
4043 else if (expr->op_type == OP_NULL &&
4044 (expr->op_flags & OPf_KIDS) &&
4045 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4047 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4048 * set the STACKED flag to indicate that these values are to be
4049 * treated as min/max values by 'pp_iterinit'.
4051 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4052 LOGOP* range = (LOGOP*) flip->op_first;
4053 OP* left = range->op_first;
4054 OP* right = left->op_sibling;
4057 range->op_flags &= ~OPf_KIDS;
4058 range->op_first = Nullop;
4060 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4061 listop->op_first->op_next = range->op_next;
4062 left->op_next = range->op_other;
4063 right->op_next = (OP*)listop;
4064 listop->op_next = listop->op_first;
4067 expr = (OP*)(listop);
4069 iterflags |= OPf_STACKED;
4072 expr = mod(force_list(expr), OP_GREPSTART);
4076 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4077 append_elem(OP_LIST, expr, scalar(sv))));
4078 assert(!loop->op_next);
4079 #ifdef PL_OP_SLAB_ALLOC
4082 NewOp(1234,tmp,1,LOOP);
4083 Copy(loop,tmp,1,LOOP);
4087 Renew(loop, 1, LOOP);
4089 loop->op_targ = padoff;
4090 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4091 PL_copline = forline;
4092 return newSTATEOP(0, label, wop);
4096 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4101 if (type != OP_GOTO || label->op_type == OP_CONST) {
4102 /* "last()" means "last" */
4103 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4104 o = newOP(type, OPf_SPECIAL);
4106 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4107 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4113 if (label->op_type == OP_ENTERSUB)
4114 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4115 o = newUNOP(type, OPf_STACKED, label);
4117 PL_hints |= HINT_BLOCK_SCOPE;
4122 Perl_cv_undef(pTHX_ CV *cv)
4126 MUTEX_DESTROY(CvMUTEXP(cv));
4127 Safefree(CvMUTEXP(cv));
4130 #endif /* USE_THREADS */
4132 if (!CvXSUB(cv) && CvROOT(cv)) {
4134 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4135 Perl_croak(aTHX_ "Can't undef active subroutine");
4138 Perl_croak(aTHX_ "Can't undef active subroutine");
4139 #endif /* USE_THREADS */
4142 SAVEVPTR(PL_curpad);
4146 op_free(CvROOT(cv));
4147 CvROOT(cv) = Nullop;
4150 SvPOK_off((SV*)cv); /* forget prototype */
4152 SvREFCNT_dec(CvGV(cv));
4154 SvREFCNT_dec(CvOUTSIDE(cv));
4155 CvOUTSIDE(cv) = Nullcv;
4157 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4160 if (CvPADLIST(cv)) {
4161 /* may be during global destruction */
4162 if (SvREFCNT(CvPADLIST(cv))) {
4163 I32 i = AvFILLp(CvPADLIST(cv));
4165 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4166 SV* sv = svp ? *svp : Nullsv;
4169 if (sv == (SV*)PL_comppad_name)
4170 PL_comppad_name = Nullav;
4171 else if (sv == (SV*)PL_comppad) {
4172 PL_comppad = Nullav;
4173 PL_curpad = Null(SV**);
4177 SvREFCNT_dec((SV*)CvPADLIST(cv));
4179 CvPADLIST(cv) = Nullav;
4184 S_cv_dump(pTHX_ CV *cv)
4187 CV *outside = CvOUTSIDE(cv);
4188 AV* padlist = CvPADLIST(cv);
4195 PerlIO_printf(Perl_debug_log,
4196 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4198 (CvANON(cv) ? "ANON"
4199 : (cv == PL_main_cv) ? "MAIN"
4200 : CvUNIQUE(cv) ? "UNIQUE"
4201 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4204 : CvANON(outside) ? "ANON"
4205 : (outside == PL_main_cv) ? "MAIN"
4206 : CvUNIQUE(outside) ? "UNIQUE"
4207 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4212 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4213 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4214 pname = AvARRAY(pad_name);
4215 ppad = AvARRAY(pad);
4217 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4218 if (SvPOK(pname[ix]))
4219 PerlIO_printf(Perl_debug_log,
4220 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4221 (int)ix, PTR2UV(ppad[ix]),
4222 SvFAKE(pname[ix]) ? "FAKE " : "",
4224 (IV)I_32(SvNVX(pname[ix])),
4227 #endif /* DEBUGGING */
4231 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4235 AV* protopadlist = CvPADLIST(proto);
4236 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4237 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4238 SV** pname = AvARRAY(protopad_name);
4239 SV** ppad = AvARRAY(protopad);
4240 I32 fname = AvFILLp(protopad_name);
4241 I32 fpad = AvFILLp(protopad);
4245 assert(!CvUNIQUE(proto));
4249 SAVESPTR(PL_comppad_name);
4250 SAVESPTR(PL_compcv);
4252 cv = PL_compcv = (CV*)NEWSV(1104,0);
4253 sv_upgrade((SV *)cv, SvTYPE(proto));
4254 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4258 New(666, CvMUTEXP(cv), 1, perl_mutex);
4259 MUTEX_INIT(CvMUTEXP(cv));
4261 #endif /* USE_THREADS */
4262 CvFILE(cv) = CvFILE(proto);
4263 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4264 CvSTASH(cv) = CvSTASH(proto);
4265 CvROOT(cv) = CvROOT(proto);
4266 CvSTART(cv) = CvSTART(proto);
4268 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4271 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4273 PL_comppad_name = newAV();
4274 for (ix = fname; ix >= 0; ix--)
4275 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4277 PL_comppad = newAV();
4279 comppadlist = newAV();
4280 AvREAL_off(comppadlist);
4281 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4282 av_store(comppadlist, 1, (SV*)PL_comppad);
4283 CvPADLIST(cv) = comppadlist;
4284 av_fill(PL_comppad, AvFILLp(protopad));
4285 PL_curpad = AvARRAY(PL_comppad);
4287 av = newAV(); /* will be @_ */
4289 av_store(PL_comppad, 0, (SV*)av);
4290 AvFLAGS(av) = AVf_REIFY;
4292 for (ix = fpad; ix > 0; ix--) {
4293 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4294 if (namesv && namesv != &PL_sv_undef) {
4295 char *name = SvPVX(namesv); /* XXX */
4296 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4297 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4298 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4300 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4302 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4304 else { /* our own lexical */
4307 /* anon code -- we'll come back for it */
4308 sv = SvREFCNT_inc(ppad[ix]);
4310 else if (*name == '@')
4312 else if (*name == '%')
4321 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4322 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4325 SV* sv = NEWSV(0,0);
4331 /* Now that vars are all in place, clone nested closures. */
4333 for (ix = fpad; ix > 0; ix--) {
4334 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4336 && namesv != &PL_sv_undef
4337 && !(SvFLAGS(namesv) & SVf_FAKE)
4338 && *SvPVX(namesv) == '&'
4339 && CvCLONE(ppad[ix]))
4341 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4342 SvREFCNT_dec(ppad[ix]);
4345 PL_curpad[ix] = (SV*)kid;
4349 #ifdef DEBUG_CLOSURES
4350 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4352 PerlIO_printf(Perl_debug_log, " from:\n");
4354 PerlIO_printf(Perl_debug_log, " to:\n");
4361 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4363 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4365 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4372 Perl_cv_clone(pTHX_ CV *proto)
4375 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4376 cv = cv_clone2(proto, CvOUTSIDE(proto));
4377 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4382 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4384 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4385 SV* msg = sv_newmortal();
4389 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4390 sv_setpv(msg, "Prototype mismatch:");
4392 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4394 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4395 sv_catpv(msg, " vs ");
4397 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4399 sv_catpv(msg, "none");
4400 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4404 static void const_sv_xsub(pTHXo_ CV* cv);
4407 =for apidoc cv_const_sv
4409 If C<cv> is a constant sub eligible for inlining. returns the constant
4410 value returned by the sub. Otherwise, returns NULL.
4412 Constant subs can be created with C<newCONSTSUB> or as described in
4413 L<perlsub/"Constant Functions">.
4418 Perl_cv_const_sv(pTHX_ CV *cv)
4420 if (!cv || !CvCONST(cv))
4422 return (SV*)CvXSUBANY(cv).any_ptr;
4426 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4433 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4434 o = cLISTOPo->op_first->op_sibling;
4436 for (; o; o = o->op_next) {
4437 OPCODE type = o->op_type;
4439 if (sv && o->op_next == o)
4441 if (o->op_next != o) {
4442 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4444 if (type == OP_DBSTATE)
4447 if (type == OP_LEAVESUB || type == OP_RETURN)
4451 if (type == OP_CONST && cSVOPo->op_sv)
4453 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4454 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4455 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4459 /* We get here only from cv_clone2() while creating a closure.
4460 Copy the const value here instead of in cv_clone2 so that
4461 SvREADONLY_on doesn't lead to problems when leaving
4466 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4478 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4488 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4492 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4494 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4498 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4504 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4509 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4510 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4511 SV *sv = sv_newmortal();
4512 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4513 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4518 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4519 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4529 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4530 maximum a prototype before. */
4531 if (SvTYPE(gv) > SVt_NULL) {
4532 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4533 && ckWARN_d(WARN_PROTOTYPE))
4535 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4537 cv_ckproto((CV*)gv, NULL, ps);
4540 sv_setpv((SV*)gv, ps);
4542 sv_setiv((SV*)gv, -1);
4543 SvREFCNT_dec(PL_compcv);
4544 cv = PL_compcv = NULL;
4545 PL_sub_generation++;
4549 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4551 if (!block || !ps || *ps || attrs)
4554 const_sv = op_const_sv(block, Nullcv);
4557 bool exists = CvROOT(cv) || CvXSUB(cv);
4558 /* if the subroutine doesn't exist and wasn't pre-declared
4559 * with a prototype, assume it will be AUTOLOADed,
4560 * skipping the prototype check
4562 if (exists || SvPOK(cv))
4563 cv_ckproto(cv, gv, ps);
4564 /* already defined (or promised)? */
4565 if (exists || GvASSUMECV(gv)) {
4566 if (!block && !attrs) {
4567 /* just a "sub foo;" when &foo is already defined */
4568 SAVEFREESV(PL_compcv);
4571 /* ahem, death to those who redefine active sort subs */
4572 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4573 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4575 if (ckWARN(WARN_REDEFINE)
4577 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4579 line_t oldline = CopLINE(PL_curcop);
4580 CopLINE_set(PL_curcop, PL_copline);
4581 Perl_warner(aTHX_ WARN_REDEFINE,
4582 CvCONST(cv) ? "Constant subroutine %s redefined"
4583 : "Subroutine %s redefined", name);
4584 CopLINE_set(PL_curcop, oldline);
4592 SvREFCNT_inc(const_sv);
4594 assert(!CvROOT(cv) && !CvCONST(cv));
4595 sv_setpv((SV*)cv, ""); /* prototype is "" */
4596 CvXSUBANY(cv).any_ptr = const_sv;
4597 CvXSUB(cv) = const_sv_xsub;
4602 cv = newCONSTSUB(NULL, name, const_sv);
4605 SvREFCNT_dec(PL_compcv);
4607 PL_sub_generation++;
4614 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4615 * before we clobber PL_compcv.
4619 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4620 stash = GvSTASH(CvGV(cv));
4621 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4622 stash = CvSTASH(cv);
4624 stash = PL_curstash;
4627 /* possibly about to re-define existing subr -- ignore old cv */
4628 rcv = (SV*)PL_compcv;
4629 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4630 stash = GvSTASH(gv);
4632 stash = PL_curstash;
4634 apply_attrs(stash, rcv, attrs);
4636 if (cv) { /* must reuse cv if autoloaded */
4638 /* got here with just attrs -- work done, so bug out */
4639 SAVEFREESV(PL_compcv);
4643 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4644 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4645 CvOUTSIDE(PL_compcv) = 0;
4646 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4647 CvPADLIST(PL_compcv) = 0;
4648 if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4649 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4650 SvREFCNT_dec(PL_compcv);
4657 PL_sub_generation++;
4660 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4661 CvFILE(cv) = CopFILE(PL_curcop);
4662 CvSTASH(cv) = PL_curstash;
4665 if (!CvMUTEXP(cv)) {
4666 New(666, CvMUTEXP(cv), 1, perl_mutex);
4667 MUTEX_INIT(CvMUTEXP(cv));
4669 #endif /* USE_THREADS */
4672 sv_setpv((SV*)cv, ps);
4674 if (PL_error_count) {
4678 char *s = strrchr(name, ':');
4680 if (strEQ(s, "BEGIN")) {
4682 "BEGIN not safe after errors--compilation aborted";
4683 if (PL_in_eval & EVAL_KEEPERR)
4684 Perl_croak(aTHX_ not_safe);
4686 /* force display of errors found but not reported */
4687 sv_catpv(ERRSV, not_safe);
4688 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4696 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4697 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4700 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4701 mod(scalarseq(block), OP_LEAVESUBLV));
4704 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4706 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4707 OpREFCNT_set(CvROOT(cv), 1);
4708 CvSTART(cv) = LINKLIST(CvROOT(cv));
4709 CvROOT(cv)->op_next = 0;
4712 /* now that optimizer has done its work, adjust pad values */
4714 SV **namep = AvARRAY(PL_comppad_name);
4715 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4718 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4721 * The only things that a clonable function needs in its
4722 * pad are references to outer lexicals and anonymous subs.
4723 * The rest are created anew during cloning.
4725 if (!((namesv = namep[ix]) != Nullsv &&
4726 namesv != &PL_sv_undef &&
4728 *SvPVX(namesv) == '&')))
4730 SvREFCNT_dec(PL_curpad[ix]);
4731 PL_curpad[ix] = Nullsv;
4734 assert(!CvCONST(cv));
4735 if (ps && !*ps && op_const_sv(block, cv))
4739 AV *av = newAV(); /* Will be @_ */
4741 av_store(PL_comppad, 0, (SV*)av);
4742 AvFLAGS(av) = AVf_REIFY;
4744 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4745 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4747 if (!SvPADMY(PL_curpad[ix]))
4748 SvPADTMP_on(PL_curpad[ix]);
4752 if (name || aname) {
4754 char *tname = (name ? name : aname);
4756 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4757 SV *sv = NEWSV(0,0);
4758 SV *tmpstr = sv_newmortal();
4759 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4763 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4765 (long)PL_subline, (long)CopLINE(PL_curcop));
4766 gv_efullname3(tmpstr, gv, Nullch);
4767 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4768 hv = GvHVn(db_postponed);
4769 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4770 && (pcv = GvCV(db_postponed)))
4776 call_sv((SV*)pcv, G_DISCARD);
4780 if ((s = strrchr(tname,':')))
4785 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4788 if (strEQ(s, "BEGIN")) {
4789 I32 oldscope = PL_scopestack_ix;
4791 SAVECOPFILE(&PL_compiling);
4792 SAVECOPLINE(&PL_compiling);
4794 sv_setsv(PL_rs, PL_nrs);
4797 PL_beginav = newAV();
4798 DEBUG_x( dump_sub(gv) );
4799 av_push(PL_beginav, (SV*)cv);
4800 GvCV(gv) = 0; /* cv has been hijacked */
4801 call_list(oldscope, PL_beginav);
4803 PL_curcop = &PL_compiling;
4804 PL_compiling.op_private = PL_hints;
4807 else if (strEQ(s, "END") && !PL_error_count) {
4810 DEBUG_x( dump_sub(gv) );
4811 av_unshift(PL_endav, 1);
4812 av_store(PL_endav, 0, (SV*)cv);
4813 GvCV(gv) = 0; /* cv has been hijacked */
4815 else if (strEQ(s, "CHECK") && !PL_error_count) {
4817 PL_checkav = newAV();
4818 DEBUG_x( dump_sub(gv) );
4819 if (PL_main_start && ckWARN(WARN_VOID))
4820 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4821 av_unshift(PL_checkav, 1);
4822 av_store(PL_checkav, 0, (SV*)cv);
4823 GvCV(gv) = 0; /* cv has been hijacked */
4825 else if (strEQ(s, "INIT") && !PL_error_count) {
4827 PL_initav = newAV();
4828 DEBUG_x( dump_sub(gv) );
4829 if (PL_main_start && ckWARN(WARN_VOID))
4830 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4831 av_push(PL_initav, (SV*)cv);
4832 GvCV(gv) = 0; /* cv has been hijacked */
4837 PL_copline = NOLINE;
4842 /* XXX unsafe for threads if eval_owner isn't held */
4844 =for apidoc newCONSTSUB
4846 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4847 eligible for inlining at compile-time.
4853 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4859 SAVECOPLINE(PL_curcop);
4860 CopLINE_set(PL_curcop, PL_copline);
4863 PL_hints &= ~HINT_BLOCK_SCOPE;
4866 SAVESPTR(PL_curstash);
4867 SAVECOPSTASH(PL_curcop);
4868 PL_curstash = stash;
4870 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4872 CopSTASH(PL_curcop) = stash;
4876 cv = newXS(name, const_sv_xsub, __FILE__);
4877 CvXSUBANY(cv).any_ptr = sv;
4879 sv_setpv((SV*)cv, ""); /* prototype is "" */
4887 =for apidoc U||newXS
4889 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4895 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4897 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4900 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4902 /* just a cached method */
4906 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4907 /* already defined (or promised) */
4908 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4909 && HvNAME(GvSTASH(CvGV(cv)))
4910 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4911 line_t oldline = CopLINE(PL_curcop);
4912 if (PL_copline != NOLINE)
4913 CopLINE_set(PL_curcop, PL_copline);
4914 Perl_warner(aTHX_ WARN_REDEFINE,
4915 CvCONST(cv) ? "Constant subroutine %s redefined"
4916 : "Subroutine %s redefined"
4918 CopLINE_set(PL_curcop, oldline);
4925 if (cv) /* must reuse cv if autoloaded */
4928 cv = (CV*)NEWSV(1105,0);
4929 sv_upgrade((SV *)cv, SVt_PVCV);
4933 PL_sub_generation++;
4936 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4938 New(666, CvMUTEXP(cv), 1, perl_mutex);
4939 MUTEX_INIT(CvMUTEXP(cv));
4941 #endif /* USE_THREADS */
4942 (void)gv_fetchfile(filename);
4943 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4944 an external constant string */
4945 CvXSUB(cv) = subaddr;
4948 char *s = strrchr(name,':');
4954 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4957 if (strEQ(s, "BEGIN")) {
4959 PL_beginav = newAV();
4960 av_push(PL_beginav, (SV*)cv);
4961 GvCV(gv) = 0; /* cv has been hijacked */
4963 else if (strEQ(s, "END")) {
4966 av_unshift(PL_endav, 1);
4967 av_store(PL_endav, 0, (SV*)cv);
4968 GvCV(gv) = 0; /* cv has been hijacked */
4970 else if (strEQ(s, "CHECK")) {
4972 PL_checkav = newAV();
4973 if (PL_main_start && ckWARN(WARN_VOID))
4974 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4975 av_unshift(PL_checkav, 1);
4976 av_store(PL_checkav, 0, (SV*)cv);
4977 GvCV(gv) = 0; /* cv has been hijacked */
4979 else if (strEQ(s, "INIT")) {
4981 PL_initav = newAV();
4982 if (PL_main_start && ckWARN(WARN_VOID))
4983 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4984 av_push(PL_initav, (SV*)cv);
4985 GvCV(gv) = 0; /* cv has been hijacked */
4996 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5005 name = SvPVx(cSVOPo->op_sv, n_a);
5008 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5010 if ((cv = GvFORM(gv))) {
5011 if (ckWARN(WARN_REDEFINE)) {
5012 line_t oldline = CopLINE(PL_curcop);
5014 CopLINE_set(PL_curcop, PL_copline);
5015 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5016 CopLINE_set(PL_curcop, oldline);
5022 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
5023 CvFILE(cv) = CopFILE(PL_curcop);
5025 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5026 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5027 SvPADTMP_on(PL_curpad[ix]);
5030 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5031 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5032 OpREFCNT_set(CvROOT(cv), 1);
5033 CvSTART(cv) = LINKLIST(CvROOT(cv));
5034 CvROOT(cv)->op_next = 0;
5037 PL_copline = NOLINE;
5042 Perl_newANONLIST(pTHX_ OP *o)
5044 return newUNOP(OP_REFGEN, 0,
5045 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5049 Perl_newANONHASH(pTHX_ OP *o)
5051 return newUNOP(OP_REFGEN, 0,
5052 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5056 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5058 return newANONATTRSUB(floor, proto, Nullop, block);
5062 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5064 return newUNOP(OP_REFGEN, 0,
5065 newSVOP(OP_ANONCODE, 0,
5066 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5070 Perl_oopsAV(pTHX_ OP *o)
5072 switch (o->op_type) {
5074 o->op_type = OP_PADAV;
5075 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5076 return ref(o, OP_RV2AV);
5079 o->op_type = OP_RV2AV;
5080 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5085 if (ckWARN_d(WARN_INTERNAL))
5086 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5093 Perl_oopsHV(pTHX_ OP *o)
5095 switch (o->op_type) {
5098 o->op_type = OP_PADHV;
5099 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5100 return ref(o, OP_RV2HV);
5104 o->op_type = OP_RV2HV;
5105 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5110 if (ckWARN_d(WARN_INTERNAL))
5111 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5118 Perl_newAVREF(pTHX_ OP *o)
5120 if (o->op_type == OP_PADANY) {
5121 o->op_type = OP_PADAV;
5122 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5125 return newUNOP(OP_RV2AV, 0, scalar(o));
5129 Perl_newGVREF(pTHX_ I32 type, OP *o)
5131 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5132 return newUNOP(OP_NULL, 0, o);
5133 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5137 Perl_newHVREF(pTHX_ OP *o)
5139 if (o->op_type == OP_PADANY) {
5140 o->op_type = OP_PADHV;
5141 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5144 return newUNOP(OP_RV2HV, 0, scalar(o));
5148 Perl_oopsCV(pTHX_ OP *o)
5150 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5156 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5158 return newUNOP(OP_RV2CV, flags, scalar(o));
5162 Perl_newSVREF(pTHX_ OP *o)
5164 if (o->op_type == OP_PADANY) {
5165 o->op_type = OP_PADSV;
5166 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5169 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5170 o->op_flags |= OPpDONE_SVREF;
5173 return newUNOP(OP_RV2SV, 0, scalar(o));
5176 /* Check routines. */
5179 Perl_ck_anoncode(pTHX_ OP *o)
5184 name = NEWSV(1106,0);
5185 sv_upgrade(name, SVt_PVNV);
5186 sv_setpvn(name, "&", 1);
5189 ix = pad_alloc(o->op_type, SVs_PADMY);
5190 av_store(PL_comppad_name, ix, name);
5191 av_store(PL_comppad, ix, cSVOPo->op_sv);
5192 SvPADMY_on(cSVOPo->op_sv);
5193 cSVOPo->op_sv = Nullsv;
5194 cSVOPo->op_targ = ix;
5199 Perl_ck_bitop(pTHX_ OP *o)
5201 o->op_private = PL_hints;
5206 Perl_ck_concat(pTHX_ OP *o)
5208 if (cUNOPo->op_first->op_type == OP_CONCAT)
5209 o->op_flags |= OPf_STACKED;
5214 Perl_ck_spair(pTHX_ OP *o)
5216 if (o->op_flags & OPf_KIDS) {
5219 OPCODE type = o->op_type;
5220 o = modkids(ck_fun(o), type);
5221 kid = cUNOPo->op_first;
5222 newop = kUNOP->op_first->op_sibling;
5224 (newop->op_sibling ||
5225 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5226 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5227 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5231 op_free(kUNOP->op_first);
5232 kUNOP->op_first = newop;
5234 o->op_ppaddr = PL_ppaddr[++o->op_type];
5239 Perl_ck_delete(pTHX_ OP *o)
5243 if (o->op_flags & OPf_KIDS) {
5244 OP *kid = cUNOPo->op_first;
5245 switch (kid->op_type) {
5247 o->op_flags |= OPf_SPECIAL;
5250 o->op_private |= OPpSLICE;
5253 o->op_flags |= OPf_SPECIAL;
5258 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5259 PL_op_desc[o->op_type]);
5267 Perl_ck_eof(pTHX_ OP *o)
5269 I32 type = o->op_type;
5271 if (o->op_flags & OPf_KIDS) {
5272 if (cLISTOPo->op_first->op_type == OP_STUB) {
5274 o = newUNOP(type, OPf_SPECIAL,
5275 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5283 Perl_ck_eval(pTHX_ OP *o)
5285 PL_hints |= HINT_BLOCK_SCOPE;
5286 if (o->op_flags & OPf_KIDS) {
5287 SVOP *kid = (SVOP*)cUNOPo->op_first;
5290 o->op_flags &= ~OPf_KIDS;
5293 else if (kid->op_type == OP_LINESEQ) {
5296 kid->op_next = o->op_next;
5297 cUNOPo->op_first = 0;
5300 NewOp(1101, enter, 1, LOGOP);
5301 enter->op_type = OP_ENTERTRY;
5302 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5303 enter->op_private = 0;
5305 /* establish postfix order */
5306 enter->op_next = (OP*)enter;
5308 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5309 o->op_type = OP_LEAVETRY;
5310 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5311 enter->op_other = o;
5319 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5321 o->op_targ = (PADOFFSET)PL_hints;
5326 Perl_ck_exit(pTHX_ OP *o)
5329 HV *table = GvHV(PL_hintgv);
5331 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5332 if (svp && *svp && SvTRUE(*svp))
5333 o->op_private |= OPpEXIT_VMSISH;
5340 Perl_ck_exec(pTHX_ OP *o)
5343 if (o->op_flags & OPf_STACKED) {
5345 kid = cUNOPo->op_first->op_sibling;
5346 if (kid->op_type == OP_RV2GV)
5355 Perl_ck_exists(pTHX_ OP *o)
5358 if (o->op_flags & OPf_KIDS) {
5359 OP *kid = cUNOPo->op_first;
5360 if (kid->op_type == OP_ENTERSUB) {
5361 (void) ref(kid, o->op_type);
5362 if (kid->op_type != OP_RV2CV && !PL_error_count)
5363 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5364 PL_op_desc[o->op_type]);
5365 o->op_private |= OPpEXISTS_SUB;
5367 else if (kid->op_type == OP_AELEM)
5368 o->op_flags |= OPf_SPECIAL;
5369 else if (kid->op_type != OP_HELEM)
5370 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5371 PL_op_desc[o->op_type]);
5379 Perl_ck_gvconst(pTHX_ register OP *o)
5381 o = fold_constants(o);
5382 if (o->op_type == OP_CONST)
5389 Perl_ck_rvconst(pTHX_ register OP *o)
5391 SVOP *kid = (SVOP*)cUNOPo->op_first;
5393 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5394 if (kid->op_type == OP_CONST) {
5398 SV *kidsv = kid->op_sv;
5401 /* Is it a constant from cv_const_sv()? */
5402 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5403 SV *rsv = SvRV(kidsv);
5404 int svtype = SvTYPE(rsv);
5405 char *badtype = Nullch;
5407 switch (o->op_type) {
5409 if (svtype > SVt_PVMG)
5410 badtype = "a SCALAR";
5413 if (svtype != SVt_PVAV)
5414 badtype = "an ARRAY";
5417 if (svtype != SVt_PVHV) {
5418 if (svtype == SVt_PVAV) { /* pseudohash? */
5419 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5420 if (ksv && SvROK(*ksv)
5421 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5430 if (svtype != SVt_PVCV)
5435 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5438 name = SvPV(kidsv, n_a);
5439 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5440 char *badthing = Nullch;
5441 switch (o->op_type) {
5443 badthing = "a SCALAR";
5446 badthing = "an ARRAY";
5449 badthing = "a HASH";
5454 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5458 * This is a little tricky. We only want to add the symbol if we
5459 * didn't add it in the lexer. Otherwise we get duplicate strict
5460 * warnings. But if we didn't add it in the lexer, we must at
5461 * least pretend like we wanted to add it even if it existed before,
5462 * or we get possible typo warnings. OPpCONST_ENTERED says
5463 * whether the lexer already added THIS instance of this symbol.
5465 iscv = (o->op_type == OP_RV2CV) * 2;
5467 gv = gv_fetchpv(name,
5468 iscv | !(kid->op_private & OPpCONST_ENTERED),
5471 : o->op_type == OP_RV2SV
5473 : o->op_type == OP_RV2AV
5475 : o->op_type == OP_RV2HV
5478 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5480 kid->op_type = OP_GV;
5481 SvREFCNT_dec(kid->op_sv);
5483 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5484 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5485 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5487 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5489 kid->op_sv = SvREFCNT_inc(gv);
5491 kid->op_private = 0;
5492 kid->op_ppaddr = PL_ppaddr[OP_GV];
5499 Perl_ck_ftst(pTHX_ OP *o)
5501 I32 type = o->op_type;
5503 if (o->op_flags & OPf_REF) {
5506 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5507 SVOP *kid = (SVOP*)cUNOPo->op_first;
5509 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5511 OP *newop = newGVOP(type, OPf_REF,
5512 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5519 if (type == OP_FTTTY)
5520 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5523 o = newUNOP(type, 0, newDEFSVOP());
5526 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5528 if (PL_hints & HINT_LOCALE)
5529 o->op_private |= OPpLOCALE;
5536 Perl_ck_fun(pTHX_ OP *o)
5542 int type = o->op_type;
5543 register I32 oa = PL_opargs[type] >> OASHIFT;
5545 if (o->op_flags & OPf_STACKED) {
5546 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5549 return no_fh_allowed(o);
5552 if (o->op_flags & OPf_KIDS) {
5554 tokid = &cLISTOPo->op_first;
5555 kid = cLISTOPo->op_first;
5556 if (kid->op_type == OP_PUSHMARK ||
5557 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5559 tokid = &kid->op_sibling;
5560 kid = kid->op_sibling;
5562 if (!kid && PL_opargs[type] & OA_DEFGV)
5563 *tokid = kid = newDEFSVOP();
5567 sibl = kid->op_sibling;
5570 /* list seen where single (scalar) arg expected? */
5571 if (numargs == 1 && !(oa >> 4)
5572 && kid->op_type == OP_LIST && type != OP_SCALAR)
5574 return too_many_arguments(o,PL_op_desc[type]);
5587 if (kid->op_type == OP_CONST &&
5588 (kid->op_private & OPpCONST_BARE))
5590 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5591 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5592 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5593 if (ckWARN(WARN_DEPRECATED))
5594 Perl_warner(aTHX_ WARN_DEPRECATED,
5595 "Array @%s missing the @ in argument %"IVdf" of %s()",
5596 name, (IV)numargs, PL_op_desc[type]);
5599 kid->op_sibling = sibl;
5602 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5603 bad_type(numargs, "array", PL_op_desc[type], kid);
5607 if (kid->op_type == OP_CONST &&
5608 (kid->op_private & OPpCONST_BARE))
5610 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5611 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5612 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5613 if (ckWARN(WARN_DEPRECATED))
5614 Perl_warner(aTHX_ WARN_DEPRECATED,
5615 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5616 name, (IV)numargs, PL_op_desc[type]);
5619 kid->op_sibling = sibl;
5622 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5623 bad_type(numargs, "hash", PL_op_desc[type], kid);
5628 OP *newop = newUNOP(OP_NULL, 0, kid);
5629 kid->op_sibling = 0;
5631 newop->op_next = newop;
5633 kid->op_sibling = sibl;
5638 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5639 if (kid->op_type == OP_CONST &&
5640 (kid->op_private & OPpCONST_BARE))
5642 OP *newop = newGVOP(OP_GV, 0,
5643 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5648 else if (kid->op_type == OP_READLINE) {
5649 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5650 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5653 I32 flags = OPf_SPECIAL;
5657 /* is this op a FH constructor? */
5658 if (is_handle_constructor(o,numargs)) {
5659 char *name = Nullch;
5663 /* Set a flag to tell rv2gv to vivify
5664 * need to "prove" flag does not mean something
5665 * else already - NI-S 1999/05/07
5668 if (kid->op_type == OP_PADSV) {
5669 SV **namep = av_fetch(PL_comppad_name,
5671 if (namep && *namep)
5672 name = SvPV(*namep, len);
5674 else if (kid->op_type == OP_RV2SV
5675 && kUNOP->op_first->op_type == OP_GV)
5677 GV *gv = cGVOPx_gv(kUNOP->op_first);
5679 len = GvNAMELEN(gv);
5681 else if (kid->op_type == OP_AELEM
5682 || kid->op_type == OP_HELEM)
5684 name = "__ANONIO__";
5690 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5691 namesv = PL_curpad[targ];
5692 (void)SvUPGRADE(namesv, SVt_PV);
5694 sv_setpvn(namesv, "$", 1);
5695 sv_catpvn(namesv, name, len);
5698 kid->op_sibling = 0;
5699 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5700 kid->op_targ = targ;
5701 kid->op_private |= priv;
5703 kid->op_sibling = sibl;
5709 mod(scalar(kid), type);
5713 tokid = &kid->op_sibling;
5714 kid = kid->op_sibling;
5716 o->op_private |= numargs;
5718 return too_many_arguments(o,PL_op_desc[o->op_type]);
5721 else if (PL_opargs[type] & OA_DEFGV) {
5723 return newUNOP(type, 0, newDEFSVOP());
5727 while (oa & OA_OPTIONAL)
5729 if (oa && oa != OA_LIST)
5730 return too_few_arguments(o,PL_op_desc[o->op_type]);
5736 Perl_ck_glob(pTHX_ OP *o)
5741 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5742 append_elem(OP_GLOB, o, newDEFSVOP());
5744 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5745 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5747 #if !defined(PERL_EXTERNAL_GLOB)
5748 /* XXX this can be tightened up and made more failsafe. */
5751 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5752 /* null-terminated import list */
5753 newSVpvn(":globally", 9), Nullsv);
5754 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5757 #endif /* PERL_EXTERNAL_GLOB */
5759 if (gv && GvIMPORTED_CV(gv)) {
5760 append_elem(OP_GLOB, o,
5761 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5762 o->op_type = OP_LIST;
5763 o->op_ppaddr = PL_ppaddr[OP_LIST];
5764 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5765 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5766 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5767 append_elem(OP_LIST, o,
5768 scalar(newUNOP(OP_RV2CV, 0,
5769 newGVOP(OP_GV, 0, gv)))));
5770 o = newUNOP(OP_NULL, 0, ck_subr(o));
5771 o->op_targ = OP_GLOB; /* hint at what it used to be */
5774 gv = newGVgen("main");
5776 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5782 Perl_ck_grep(pTHX_ OP *o)
5786 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5788 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5789 NewOp(1101, gwop, 1, LOGOP);
5791 if (o->op_flags & OPf_STACKED) {
5794 kid = cLISTOPo->op_first->op_sibling;
5795 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5798 kid->op_next = (OP*)gwop;
5799 o->op_flags &= ~OPf_STACKED;
5801 kid = cLISTOPo->op_first->op_sibling;
5802 if (type == OP_MAPWHILE)
5809 kid = cLISTOPo->op_first->op_sibling;
5810 if (kid->op_type != OP_NULL)
5811 Perl_croak(aTHX_ "panic: ck_grep");
5812 kid = kUNOP->op_first;
5814 gwop->op_type = type;
5815 gwop->op_ppaddr = PL_ppaddr[type];
5816 gwop->op_first = listkids(o);
5817 gwop->op_flags |= OPf_KIDS;
5818 gwop->op_private = 1;
5819 gwop->op_other = LINKLIST(kid);
5820 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5821 kid->op_next = (OP*)gwop;
5823 kid = cLISTOPo->op_first->op_sibling;
5824 if (!kid || !kid->op_sibling)
5825 return too_few_arguments(o,PL_op_desc[o->op_type]);
5826 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5827 mod(kid, OP_GREPSTART);
5833 Perl_ck_index(pTHX_ OP *o)
5835 if (o->op_flags & OPf_KIDS) {
5836 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5838 kid = kid->op_sibling; /* get past "big" */
5839 if (kid && kid->op_type == OP_CONST)
5840 fbm_compile(((SVOP*)kid)->op_sv, 0);
5846 Perl_ck_lengthconst(pTHX_ OP *o)
5848 /* XXX length optimization goes here */
5853 Perl_ck_lfun(pTHX_ OP *o)
5855 OPCODE type = o->op_type;
5856 return modkids(ck_fun(o), type);
5860 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5862 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5863 switch (cUNOPo->op_first->op_type) {
5865 /* This is needed for
5866 if (defined %stash::)
5867 to work. Do not break Tk.
5869 break; /* Globals via GV can be undef */
5871 case OP_AASSIGN: /* Is this a good idea? */
5872 Perl_warner(aTHX_ WARN_DEPRECATED,
5873 "defined(@array) is deprecated");
5874 Perl_warner(aTHX_ WARN_DEPRECATED,
5875 "\t(Maybe you should just omit the defined()?)\n");
5878 /* This is needed for
5879 if (defined %stash::)
5880 to work. Do not break Tk.
5882 break; /* Globals via GV can be undef */
5884 Perl_warner(aTHX_ WARN_DEPRECATED,
5885 "defined(%%hash) is deprecated");
5886 Perl_warner(aTHX_ WARN_DEPRECATED,
5887 "\t(Maybe you should just omit the defined()?)\n");
5898 Perl_ck_rfun(pTHX_ OP *o)
5900 OPCODE type = o->op_type;
5901 return refkids(ck_fun(o), type);
5905 Perl_ck_listiob(pTHX_ OP *o)
5909 kid = cLISTOPo->op_first;
5912 kid = cLISTOPo->op_first;
5914 if (kid->op_type == OP_PUSHMARK)
5915 kid = kid->op_sibling;
5916 if (kid && o->op_flags & OPf_STACKED)
5917 kid = kid->op_sibling;
5918 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5919 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5920 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5921 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5922 cLISTOPo->op_first->op_sibling = kid;
5923 cLISTOPo->op_last = kid;
5924 kid = kid->op_sibling;
5929 append_elem(o->op_type, o, newDEFSVOP());
5935 if (PL_hints & HINT_LOCALE)
5936 o->op_private |= OPpLOCALE;
5943 Perl_ck_fun_locale(pTHX_ OP *o)
5949 if (PL_hints & HINT_LOCALE)
5950 o->op_private |= OPpLOCALE;
5957 Perl_ck_sassign(pTHX_ OP *o)
5959 OP *kid = cLISTOPo->op_first;
5960 /* has a disposable target? */
5961 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5962 && !(kid->op_flags & OPf_STACKED)
5963 /* Cannot steal the second time! */
5964 && !(kid->op_private & OPpTARGET_MY))
5966 OP *kkid = kid->op_sibling;
5968 /* Can just relocate the target. */
5969 if (kkid && kkid->op_type == OP_PADSV
5970 && !(kkid->op_private & OPpLVAL_INTRO))
5972 kid->op_targ = kkid->op_targ;
5974 /* Now we do not need PADSV and SASSIGN. */
5975 kid->op_sibling = o->op_sibling; /* NULL */
5976 cLISTOPo->op_first = NULL;
5979 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5987 Perl_ck_scmp(pTHX_ OP *o)
5991 if (PL_hints & HINT_LOCALE)
5992 o->op_private |= OPpLOCALE;
5999 Perl_ck_match(pTHX_ OP *o)
6001 o->op_private |= OPpRUNTIME;
6006 Perl_ck_method(pTHX_ OP *o)
6008 OP *kid = cUNOPo->op_first;
6009 if (kid->op_type == OP_CONST) {
6010 SV* sv = kSVOP->op_sv;
6011 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6013 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6014 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6017 kSVOP->op_sv = Nullsv;
6019 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6028 Perl_ck_null(pTHX_ OP *o)
6034 Perl_ck_open(pTHX_ OP *o)
6036 HV *table = GvHV(PL_hintgv);
6040 svp = hv_fetch(table, "open_IN", 7, FALSE);
6042 mode = mode_from_discipline(*svp);
6043 if (mode & O_BINARY)
6044 o->op_private |= OPpOPEN_IN_RAW;
6045 else if (mode & O_TEXT)
6046 o->op_private |= OPpOPEN_IN_CRLF;
6049 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6051 mode = mode_from_discipline(*svp);
6052 if (mode & O_BINARY)
6053 o->op_private |= OPpOPEN_OUT_RAW;
6054 else if (mode & O_TEXT)
6055 o->op_private |= OPpOPEN_OUT_CRLF;
6058 if (o->op_type == OP_BACKTICK)
6064 Perl_ck_repeat(pTHX_ OP *o)
6066 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6067 o->op_private |= OPpREPEAT_DOLIST;
6068 cBINOPo->op_first = force_list(cBINOPo->op_first);
6076 Perl_ck_require(pTHX_ OP *o)
6078 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6079 SVOP *kid = (SVOP*)cUNOPo->op_first;
6081 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6083 for (s = SvPVX(kid->op_sv); *s; s++) {
6084 if (*s == ':' && s[1] == ':') {
6086 Move(s+2, s+1, strlen(s+2)+1, char);
6087 --SvCUR(kid->op_sv);
6090 if (SvREADONLY(kid->op_sv)) {
6091 SvREADONLY_off(kid->op_sv);
6092 sv_catpvn(kid->op_sv, ".pm", 3);
6093 SvREADONLY_on(kid->op_sv);
6096 sv_catpvn(kid->op_sv, ".pm", 3);
6103 Perl_ck_return(pTHX_ OP *o)
6106 if (CvLVALUE(PL_compcv)) {
6107 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6108 mod(kid, OP_LEAVESUBLV);
6115 Perl_ck_retarget(pTHX_ OP *o)
6117 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6124 Perl_ck_select(pTHX_ OP *o)
6127 if (o->op_flags & OPf_KIDS) {
6128 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6129 if (kid && kid->op_sibling) {
6130 o->op_type = OP_SSELECT;
6131 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6133 return fold_constants(o);
6137 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6138 if (kid && kid->op_type == OP_RV2GV)
6139 kid->op_private &= ~HINT_STRICT_REFS;
6144 Perl_ck_shift(pTHX_ OP *o)
6146 I32 type = o->op_type;
6148 if (!(o->op_flags & OPf_KIDS)) {
6153 if (!CvUNIQUE(PL_compcv)) {
6154 argop = newOP(OP_PADAV, OPf_REF);
6155 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6158 argop = newUNOP(OP_RV2AV, 0,
6159 scalar(newGVOP(OP_GV, 0,
6160 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6163 argop = newUNOP(OP_RV2AV, 0,
6164 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6165 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6166 #endif /* USE_THREADS */
6167 return newUNOP(type, 0, scalar(argop));
6169 return scalar(modkids(ck_fun(o), type));
6173 Perl_ck_sort(pTHX_ OP *o)
6178 if (PL_hints & HINT_LOCALE)
6179 o->op_private |= OPpLOCALE;
6182 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6184 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6185 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6187 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6189 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6191 if (kid->op_type == OP_SCOPE) {
6195 else if (kid->op_type == OP_LEAVE) {
6196 if (o->op_type == OP_SORT) {
6197 null(kid); /* wipe out leave */
6200 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6201 if (k->op_next == kid)
6203 /* don't descend into loops */
6204 else if (k->op_type == OP_ENTERLOOP
6205 || k->op_type == OP_ENTERITER)
6207 k = cLOOPx(k)->op_lastop;
6212 kid->op_next = 0; /* just disconnect the leave */
6213 k = kLISTOP->op_first;
6218 if (o->op_type == OP_SORT) {
6219 /* provide scalar context for comparison function/block */
6225 o->op_flags |= OPf_SPECIAL;
6227 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6230 firstkid = firstkid->op_sibling;
6233 /* provide list context for arguments */
6234 if (o->op_type == OP_SORT)
6241 S_simplify_sort(pTHX_ OP *o)
6243 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6247 if (!(o->op_flags & OPf_STACKED))
6249 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6250 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6251 kid = kUNOP->op_first; /* get past null */
6252 if (kid->op_type != OP_SCOPE)
6254 kid = kLISTOP->op_last; /* get past scope */
6255 switch(kid->op_type) {
6263 k = kid; /* remember this node*/
6264 if (kBINOP->op_first->op_type != OP_RV2SV)
6266 kid = kBINOP->op_first; /* get past cmp */
6267 if (kUNOP->op_first->op_type != OP_GV)
6269 kid = kUNOP->op_first; /* get past rv2sv */
6271 if (GvSTASH(gv) != PL_curstash)
6273 if (strEQ(GvNAME(gv), "a"))
6275 else if (strEQ(GvNAME(gv), "b"))
6279 kid = k; /* back to cmp */
6280 if (kBINOP->op_last->op_type != OP_RV2SV)
6282 kid = kBINOP->op_last; /* down to 2nd arg */
6283 if (kUNOP->op_first->op_type != OP_GV)
6285 kid = kUNOP->op_first; /* get past rv2sv */
6287 if (GvSTASH(gv) != PL_curstash
6289 ? strNE(GvNAME(gv), "a")
6290 : strNE(GvNAME(gv), "b")))
6292 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6294 o->op_private |= OPpSORT_REVERSE;
6295 if (k->op_type == OP_NCMP)
6296 o->op_private |= OPpSORT_NUMERIC;
6297 if (k->op_type == OP_I_NCMP)
6298 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6299 kid = cLISTOPo->op_first->op_sibling;
6300 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6301 op_free(kid); /* then delete it */
6305 Perl_ck_split(pTHX_ OP *o)
6309 if (o->op_flags & OPf_STACKED)
6310 return no_fh_allowed(o);
6312 kid = cLISTOPo->op_first;
6313 if (kid->op_type != OP_NULL)
6314 Perl_croak(aTHX_ "panic: ck_split");
6315 kid = kid->op_sibling;
6316 op_free(cLISTOPo->op_first);
6317 cLISTOPo->op_first = kid;
6319 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6320 cLISTOPo->op_last = kid; /* There was only one element previously */
6323 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6324 OP *sibl = kid->op_sibling;
6325 kid->op_sibling = 0;
6326 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6327 if (cLISTOPo->op_first == cLISTOPo->op_last)
6328 cLISTOPo->op_last = kid;
6329 cLISTOPo->op_first = kid;
6330 kid->op_sibling = sibl;
6333 kid->op_type = OP_PUSHRE;
6334 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6337 if (!kid->op_sibling)
6338 append_elem(OP_SPLIT, o, newDEFSVOP());
6340 kid = kid->op_sibling;
6343 if (!kid->op_sibling)
6344 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6346 kid = kid->op_sibling;
6349 if (kid->op_sibling)
6350 return too_many_arguments(o,PL_op_desc[o->op_type]);
6356 Perl_ck_join(pTHX_ OP *o)
6358 if (ckWARN(WARN_SYNTAX)) {
6359 OP *kid = cLISTOPo->op_first->op_sibling;
6360 if (kid && kid->op_type == OP_MATCH) {
6361 char *pmstr = "STRING";
6362 if (kPMOP->op_pmregexp)
6363 pmstr = kPMOP->op_pmregexp->precomp;
6364 Perl_warner(aTHX_ WARN_SYNTAX,
6365 "/%s/ should probably be written as \"%s\"",
6373 Perl_ck_subr(pTHX_ OP *o)
6375 OP *prev = ((cUNOPo->op_first->op_sibling)
6376 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6377 OP *o2 = prev->op_sibling;
6386 o->op_private |= OPpENTERSUB_HASTARG;
6387 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6388 if (cvop->op_type == OP_RV2CV) {
6390 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6391 null(cvop); /* disable rv2cv */
6392 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6393 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6394 GV *gv = cGVOPx_gv(tmpop);
6397 tmpop->op_private |= OPpEARLY_CV;
6398 else if (SvPOK(cv)) {
6399 namegv = CvANON(cv) ? gv : CvGV(cv);
6400 proto = SvPV((SV*)cv, n_a);
6404 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6405 if (o2->op_type == OP_CONST)
6406 o2->op_private &= ~OPpCONST_STRICT;
6407 else if (o2->op_type == OP_LIST) {
6408 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6409 if (o && o->op_type == OP_CONST)
6410 o->op_private &= ~OPpCONST_STRICT;
6413 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6414 if (PERLDB_SUB && PL_curstash != PL_debstash)
6415 o->op_private |= OPpENTERSUB_DB;
6416 while (o2 != cvop) {
6420 return too_many_arguments(o, gv_ename(namegv));
6438 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6440 arg == 1 ? "block or sub {}" : "sub {}",
6441 gv_ename(namegv), o2);
6444 /* '*' allows any scalar type, including bareword */
6447 if (o2->op_type == OP_RV2GV)
6448 goto wrapref; /* autoconvert GLOB -> GLOBref */
6449 else if (o2->op_type == OP_CONST)
6450 o2->op_private &= ~OPpCONST_STRICT;
6451 else if (o2->op_type == OP_ENTERSUB) {
6452 /* accidental subroutine, revert to bareword */
6453 OP *gvop = ((UNOP*)o2)->op_first;
6454 if (gvop && gvop->op_type == OP_NULL) {
6455 gvop = ((UNOP*)gvop)->op_first;
6457 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6460 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6461 (gvop = ((UNOP*)gvop)->op_first) &&
6462 gvop->op_type == OP_GV)
6464 GV *gv = cGVOPx_gv(gvop);
6465 OP *sibling = o2->op_sibling;
6466 SV *n = newSVpvn("",0);
6468 gv_fullname3(n, gv, "");
6469 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6470 sv_chop(n, SvPVX(n)+6);
6471 o2 = newSVOP(OP_CONST, 0, n);
6472 prev->op_sibling = o2;
6473 o2->op_sibling = sibling;
6485 if (o2->op_type != OP_RV2GV)
6486 bad_type(arg, "symbol", gv_ename(namegv), o2);
6489 if (o2->op_type != OP_ENTERSUB)
6490 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6493 if (o2->op_type != OP_RV2SV
6494 && o2->op_type != OP_PADSV
6495 && o2->op_type != OP_HELEM
6496 && o2->op_type != OP_AELEM
6497 && o2->op_type != OP_THREADSV)
6499 bad_type(arg, "scalar", gv_ename(namegv), o2);
6503 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6504 bad_type(arg, "array", gv_ename(namegv), o2);
6507 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6508 bad_type(arg, "hash", gv_ename(namegv), o2);
6512 OP* sib = kid->op_sibling;
6513 kid->op_sibling = 0;
6514 o2 = newUNOP(OP_REFGEN, 0, kid);
6515 o2->op_sibling = sib;
6516 prev->op_sibling = o2;
6527 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6528 gv_ename(namegv), SvPV((SV*)cv, n_a));
6533 mod(o2, OP_ENTERSUB);
6535 o2 = o2->op_sibling;
6537 if (proto && !optional &&
6538 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6539 return too_few_arguments(o, gv_ename(namegv));
6544 Perl_ck_svconst(pTHX_ OP *o)
6546 SvREADONLY_on(cSVOPo->op_sv);
6551 Perl_ck_trunc(pTHX_ OP *o)
6553 if (o->op_flags & OPf_KIDS) {
6554 SVOP *kid = (SVOP*)cUNOPo->op_first;
6556 if (kid->op_type == OP_NULL)
6557 kid = (SVOP*)kid->op_sibling;
6558 if (kid && kid->op_type == OP_CONST &&
6559 (kid->op_private & OPpCONST_BARE))
6561 o->op_flags |= OPf_SPECIAL;
6562 kid->op_private &= ~OPpCONST_STRICT;
6569 Perl_ck_substr(pTHX_ OP *o)
6572 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6573 OP *kid = cLISTOPo->op_first;
6575 if (kid->op_type == OP_NULL)
6576 kid = kid->op_sibling;
6578 kid->op_flags |= OPf_MOD;
6584 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6587 Perl_peep(pTHX_ register OP *o)
6589 register OP* oldop = 0;
6592 if (!o || o->op_seq)
6596 SAVEVPTR(PL_curcop);
6597 for (; o; o = o->op_next) {
6603 switch (o->op_type) {
6607 PL_curcop = ((COP*)o); /* for warnings */
6608 o->op_seq = PL_op_seqmax++;
6612 if (cSVOPo->op_private & OPpCONST_STRICT)
6613 no_bareword_allowed(o);
6615 /* Relocate sv to the pad for thread safety.
6616 * Despite being a "constant", the SV is written to,
6617 * for reference counts, sv_upgrade() etc. */
6619 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6620 if (SvPADTMP(cSVOPo->op_sv)) {
6621 /* If op_sv is already a PADTMP then it is being used by
6622 * some pad, so make a copy. */
6623 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6624 SvREADONLY_on(PL_curpad[ix]);
6625 SvREFCNT_dec(cSVOPo->op_sv);
6628 SvREFCNT_dec(PL_curpad[ix]);
6629 SvPADTMP_on(cSVOPo->op_sv);
6630 PL_curpad[ix] = cSVOPo->op_sv;
6631 /* XXX I don't know how this isn't readonly already. */
6632 SvREADONLY_on(PL_curpad[ix]);
6634 cSVOPo->op_sv = Nullsv;
6638 o->op_seq = PL_op_seqmax++;
6642 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6643 if (o->op_next->op_private & OPpTARGET_MY) {
6644 if (o->op_flags & OPf_STACKED) /* chained concats */
6645 goto ignore_optimization;
6647 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6648 o->op_targ = o->op_next->op_targ;
6649 o->op_next->op_targ = 0;
6650 o->op_private |= OPpTARGET_MY;
6655 ignore_optimization:
6656 o->op_seq = PL_op_seqmax++;
6659 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6660 o->op_seq = PL_op_seqmax++;
6661 break; /* Scalar stub must produce undef. List stub is noop */
6665 if (o->op_targ == OP_NEXTSTATE
6666 || o->op_targ == OP_DBSTATE
6667 || o->op_targ == OP_SETSTATE)
6669 PL_curcop = ((COP*)o);
6676 if (oldop && o->op_next) {
6677 oldop->op_next = o->op_next;
6680 o->op_seq = PL_op_seqmax++;
6684 if (o->op_next->op_type == OP_RV2SV) {
6685 if (!(o->op_next->op_private & OPpDEREF)) {
6687 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6689 o->op_next = o->op_next->op_next;
6690 o->op_type = OP_GVSV;
6691 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6694 else if (o->op_next->op_type == OP_RV2AV) {
6695 OP* pop = o->op_next->op_next;
6697 if (pop->op_type == OP_CONST &&
6698 (PL_op = pop->op_next) &&
6699 pop->op_next->op_type == OP_AELEM &&
6700 !(pop->op_next->op_private &
6701 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6702 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6710 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6711 o->op_next = pop->op_next->op_next;
6712 o->op_type = OP_AELEMFAST;
6713 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6714 o->op_private = (U8)i;
6719 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6721 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6722 /* XXX could check prototype here instead of just carping */
6723 SV *sv = sv_newmortal();
6724 gv_efullname3(sv, gv, Nullch);
6725 Perl_warner(aTHX_ WARN_PROTOTYPE,
6726 "%s() called too early to check prototype",
6731 o->op_seq = PL_op_seqmax++;
6742 o->op_seq = PL_op_seqmax++;
6743 while (cLOGOP->op_other->op_type == OP_NULL)
6744 cLOGOP->op_other = cLOGOP->op_other->op_next;
6745 peep(cLOGOP->op_other);
6749 o->op_seq = PL_op_seqmax++;
6750 while (cLOOP->op_redoop->op_type == OP_NULL)
6751 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6752 peep(cLOOP->op_redoop);
6753 while (cLOOP->op_nextop->op_type == OP_NULL)
6754 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6755 peep(cLOOP->op_nextop);
6756 while (cLOOP->op_lastop->op_type == OP_NULL)
6757 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6758 peep(cLOOP->op_lastop);
6764 o->op_seq = PL_op_seqmax++;
6765 while (cPMOP->op_pmreplstart &&
6766 cPMOP->op_pmreplstart->op_type == OP_NULL)
6767 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6768 peep(cPMOP->op_pmreplstart);
6772 o->op_seq = PL_op_seqmax++;
6773 if (ckWARN(WARN_SYNTAX) && o->op_next
6774 && o->op_next->op_type == OP_NEXTSTATE) {
6775 if (o->op_next->op_sibling &&
6776 o->op_next->op_sibling->op_type != OP_EXIT &&
6777 o->op_next->op_sibling->op_type != OP_WARN &&
6778 o->op_next->op_sibling->op_type != OP_DIE) {
6779 line_t oldline = CopLINE(PL_curcop);
6781 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6782 Perl_warner(aTHX_ WARN_EXEC,
6783 "Statement unlikely to be reached");
6784 Perl_warner(aTHX_ WARN_EXEC,
6785 "\t(Maybe you meant system() when you said exec()?)\n");
6786 CopLINE_set(PL_curcop, oldline);
6795 SV **svp, **indsvp, *sv;
6800 o->op_seq = PL_op_seqmax++;
6802 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6805 /* Make the CONST have a shared SV */
6806 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6807 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6808 key = SvPV(sv, keylen);
6811 lexname = newSVpvn_share(key, keylen, 0);
6816 if ((o->op_private & (OPpLVAL_INTRO)))
6819 rop = (UNOP*)((BINOP*)o)->op_first;
6820 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6822 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6823 if (!SvOBJECT(lexname))
6825 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6826 if (!fields || !GvHV(*fields))
6828 key = SvPV(*svp, keylen);
6831 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6833 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6834 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6836 ind = SvIV(*indsvp);
6838 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6839 rop->op_type = OP_RV2AV;
6840 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6841 o->op_type = OP_AELEM;
6842 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6844 if (SvREADONLY(*svp))
6846 SvFLAGS(sv) |= (SvFLAGS(*svp)
6847 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6857 SV **svp, **indsvp, *sv;
6861 SVOP *first_key_op, *key_op;
6863 o->op_seq = PL_op_seqmax++;
6864 if ((o->op_private & (OPpLVAL_INTRO))
6865 /* I bet there's always a pushmark... */
6866 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6867 /* hmmm, no optimization if list contains only one key. */
6869 rop = (UNOP*)((LISTOP*)o)->op_last;
6870 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6872 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6873 if (!SvOBJECT(lexname))
6875 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6876 if (!fields || !GvHV(*fields))
6878 /* Again guessing that the pushmark can be jumped over.... */
6879 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6880 ->op_first->op_sibling;
6881 /* Check that the key list contains only constants. */
6882 for (key_op = first_key_op; key_op;
6883 key_op = (SVOP*)key_op->op_sibling)
6884 if (key_op->op_type != OP_CONST)
6888 rop->op_type = OP_RV2AV;
6889 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6890 o->op_type = OP_ASLICE;
6891 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6892 for (key_op = first_key_op; key_op;
6893 key_op = (SVOP*)key_op->op_sibling) {
6894 svp = cSVOPx_svp(key_op);
6895 key = SvPV(*svp, keylen);
6898 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6900 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6901 "in variable %s of type %s",
6902 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6904 ind = SvIV(*indsvp);
6906 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6908 if (SvREADONLY(*svp))
6910 SvFLAGS(sv) |= (SvFLAGS(*svp)
6911 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6919 o->op_seq = PL_op_seqmax++;
6929 /* Efficient sub that returns a constant scalar value. */
6931 const_sv_xsub(pTHXo_ CV* cv)
6935 ST(0) = (SV*)XSANY.any_ptr;