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);
847 HV *pmstash = PmopSTASH(cPMOPo);
849 PMOP *pmop = HvPMROOT(pmstash);
850 PMOP *lastpmop = NULL;
852 if (cPMOPo == pmop) {
854 lastpmop->op_pmnext = pmop->op_pmnext;
856 HvPMROOT(pmstash) = pmop->op_pmnext;
860 pmop = pmop->op_pmnext;
863 Safefree(PmopSTASHPV(cPMOPo));
865 /* NOTE: PMOP.op_pmstash is not refcounted */
869 cPMOPo->op_pmreplroot = Nullop;
870 ReREFCNT_dec(cPMOPo->op_pmregexp);
871 cPMOPo->op_pmregexp = (REGEXP*)NULL;
875 if (o->op_targ > 0) {
876 pad_free(o->op_targ);
882 S_cop_free(pTHX_ COP* cop)
884 Safefree(cop->cop_label);
886 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
887 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
889 /* NOTE: COP.cop_stash is not refcounted */
890 SvREFCNT_dec(CopFILEGV(cop));
892 if (! specialWARN(cop->cop_warnings))
893 SvREFCNT_dec(cop->cop_warnings);
894 if (! specialCopIO(cop->cop_io))
895 SvREFCNT_dec(cop->cop_io);
901 if (o->op_type == OP_NULL)
904 o->op_targ = o->op_type;
905 o->op_type = OP_NULL;
906 o->op_ppaddr = PL_ppaddr[OP_NULL];
909 /* Contextualizers */
911 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
914 Perl_linklist(pTHX_ OP *o)
921 /* establish postfix order */
922 if (cUNOPo->op_first) {
923 o->op_next = LINKLIST(cUNOPo->op_first);
924 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
926 kid->op_next = LINKLIST(kid->op_sibling);
938 Perl_scalarkids(pTHX_ OP *o)
941 if (o && o->op_flags & OPf_KIDS) {
942 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
949 S_scalarboolean(pTHX_ OP *o)
951 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
952 if (ckWARN(WARN_SYNTAX)) {
953 line_t oldline = CopLINE(PL_curcop);
955 if (PL_copline != NOLINE)
956 CopLINE_set(PL_curcop, PL_copline);
957 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
958 CopLINE_set(PL_curcop, oldline);
965 Perl_scalar(pTHX_ OP *o)
969 /* assumes no premature commitment */
970 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
971 || o->op_type == OP_RETURN)
976 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
978 switch (o->op_type) {
980 if (o->op_private & OPpREPEAT_DOLIST)
981 null(((LISTOP*)cBINOPo->op_first)->op_first);
982 scalar(cBINOPo->op_first);
987 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
991 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
992 if (!kPMOP->op_pmreplroot)
993 deprecate("implicit split to @_");
1001 if (o->op_flags & OPf_KIDS) {
1002 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1008 kid = cLISTOPo->op_first;
1010 while ((kid = kid->op_sibling)) {
1011 if (kid->op_sibling)
1016 WITH_THR(PL_curcop = &PL_compiling);
1021 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1022 if (kid->op_sibling)
1027 WITH_THR(PL_curcop = &PL_compiling);
1034 Perl_scalarvoid(pTHX_ OP *o)
1041 if (o->op_type == OP_NEXTSTATE
1042 || o->op_type == OP_SETSTATE
1043 || o->op_type == OP_DBSTATE
1044 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1045 || o->op_targ == OP_SETSTATE
1046 || o->op_targ == OP_DBSTATE)))
1047 PL_curcop = (COP*)o; /* for warning below */
1049 /* assumes no premature commitment */
1050 want = o->op_flags & OPf_WANT;
1051 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1052 || o->op_type == OP_RETURN)
1057 if ((o->op_private & OPpTARGET_MY)
1058 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1060 return scalar(o); /* As if inside SASSIGN */
1063 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1065 switch (o->op_type) {
1067 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1071 if (o->op_flags & OPf_STACKED)
1075 if (o->op_private == 4)
1117 case OP_GETSOCKNAME:
1118 case OP_GETPEERNAME:
1123 case OP_GETPRIORITY:
1146 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1147 useless = PL_op_desc[o->op_type];
1154 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1155 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1156 useless = "a variable";
1161 if (cSVOPo->op_private & OPpCONST_STRICT)
1162 no_bareword_allowed(o);
1164 if (ckWARN(WARN_VOID)) {
1165 useless = "a constant";
1166 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1168 else if (SvPOK(sv)) {
1169 /* perl4's way of mixing documentation and code
1170 (before the invention of POD) was based on a
1171 trick to mix nroff and perl code. The trick was
1172 built upon these three nroff macros being used in
1173 void context. The pink camel has the details in
1174 the script wrapman near page 319. */
1175 if (strnEQ(SvPVX(sv), "di", 2) ||
1176 strnEQ(SvPVX(sv), "ds", 2) ||
1177 strnEQ(SvPVX(sv), "ig", 2))
1182 null(o); /* don't execute or even remember it */
1186 o->op_type = OP_PREINC; /* pre-increment is faster */
1187 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1191 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1192 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1198 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1203 if (o->op_flags & OPf_STACKED)
1210 if (!(o->op_flags & OPf_KIDS))
1219 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1226 /* all requires must return a boolean value */
1227 o->op_flags &= ~OPf_WANT;
1232 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1233 if (!kPMOP->op_pmreplroot)
1234 deprecate("implicit split to @_");
1238 if (useless && ckWARN(WARN_VOID))
1239 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1244 Perl_listkids(pTHX_ OP *o)
1247 if (o && o->op_flags & OPf_KIDS) {
1248 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1255 Perl_list(pTHX_ OP *o)
1259 /* assumes no premature commitment */
1260 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1261 || o->op_type == OP_RETURN)
1266 if ((o->op_private & OPpTARGET_MY)
1267 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1269 return o; /* As if inside SASSIGN */
1272 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1274 switch (o->op_type) {
1277 list(cBINOPo->op_first);
1282 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1290 if (!(o->op_flags & OPf_KIDS))
1292 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1293 list(cBINOPo->op_first);
1294 return gen_constant_list(o);
1301 kid = cLISTOPo->op_first;
1303 while ((kid = kid->op_sibling)) {
1304 if (kid->op_sibling)
1309 WITH_THR(PL_curcop = &PL_compiling);
1313 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1314 if (kid->op_sibling)
1319 WITH_THR(PL_curcop = &PL_compiling);
1322 /* all requires must return a boolean value */
1323 o->op_flags &= ~OPf_WANT;
1330 Perl_scalarseq(pTHX_ OP *o)
1335 if (o->op_type == OP_LINESEQ ||
1336 o->op_type == OP_SCOPE ||
1337 o->op_type == OP_LEAVE ||
1338 o->op_type == OP_LEAVETRY)
1340 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1341 if (kid->op_sibling) {
1345 PL_curcop = &PL_compiling;
1347 o->op_flags &= ~OPf_PARENS;
1348 if (PL_hints & HINT_BLOCK_SCOPE)
1349 o->op_flags |= OPf_PARENS;
1352 o = newOP(OP_STUB, 0);
1357 S_modkids(pTHX_ OP *o, I32 type)
1360 if (o && o->op_flags & OPf_KIDS) {
1361 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1368 Perl_mod(pTHX_ OP *o, I32 type)
1373 if (!o || PL_error_count)
1376 if ((o->op_private & OPpTARGET_MY)
1377 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1382 switch (o->op_type) {
1387 if (o->op_private & (OPpCONST_BARE) &&
1388 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1389 SV *sv = ((SVOP*)o)->op_sv;
1392 /* Could be a filehandle */
1393 if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1394 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1398 /* OK, it's a sub */
1400 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1402 enter = newUNOP(OP_ENTERSUB,0,
1403 newUNOP(OP_RV2CV, 0,
1404 newGVOP(OP_GV, 0, gv)
1406 enter->op_private |= OPpLVAL_INTRO;
1412 if (!(o->op_private & (OPpCONST_ARYBASE)))
1414 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1415 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1419 SAVEI32(PL_compiling.cop_arybase);
1420 PL_compiling.cop_arybase = 0;
1422 else if (type == OP_REFGEN)
1425 Perl_croak(aTHX_ "That use of $[ is unsupported");
1428 if (o->op_flags & OPf_PARENS)
1432 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1433 !(o->op_flags & OPf_STACKED)) {
1434 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1435 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1436 assert(cUNOPo->op_first->op_type == OP_NULL);
1437 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1440 else { /* lvalue subroutine call */
1441 o->op_private |= OPpLVAL_INTRO;
1442 PL_modcount = RETURN_UNLIMITED_NUMBER;
1443 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1444 /* Backward compatibility mode: */
1445 o->op_private |= OPpENTERSUB_INARGS;
1448 else { /* Compile-time error message: */
1449 OP *kid = cUNOPo->op_first;
1453 if (kid->op_type == OP_PUSHMARK)
1455 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1457 "panic: unexpected lvalue entersub "
1458 "args: type/targ %ld:%ld",
1459 (long)kid->op_type,kid->op_targ);
1460 kid = kLISTOP->op_first;
1462 while (kid->op_sibling)
1463 kid = kid->op_sibling;
1464 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1466 if (kid->op_type == OP_METHOD_NAMED
1467 || kid->op_type == OP_METHOD)
1471 if (kid->op_sibling || kid->op_next != kid) {
1472 yyerror("panic: unexpected optree near method call");
1476 NewOp(1101, newop, 1, UNOP);
1477 newop->op_type = OP_RV2CV;
1478 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1479 newop->op_first = Nullop;
1480 newop->op_next = (OP*)newop;
1481 kid->op_sibling = (OP*)newop;
1482 newop->op_private |= OPpLVAL_INTRO;
1486 if (kid->op_type != OP_RV2CV)
1488 "panic: unexpected lvalue entersub "
1489 "entry via type/targ %ld:%ld",
1490 (long)kid->op_type,kid->op_targ);
1491 kid->op_private |= OPpLVAL_INTRO;
1492 break; /* Postpone until runtime */
1496 kid = kUNOP->op_first;
1497 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1498 kid = kUNOP->op_first;
1499 if (kid->op_type == OP_NULL)
1501 "Unexpected constant lvalue entersub "
1502 "entry via type/targ %ld:%ld",
1503 (long)kid->op_type,kid->op_targ);
1504 if (kid->op_type != OP_GV) {
1505 /* Restore RV2CV to check lvalueness */
1507 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1508 okid->op_next = kid->op_next;
1509 kid->op_next = okid;
1512 okid->op_next = Nullop;
1513 okid->op_type = OP_RV2CV;
1515 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1516 okid->op_private |= OPpLVAL_INTRO;
1520 cv = GvCV(kGVOP_gv);
1530 /* grep, foreach, subcalls, refgen */
1531 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1533 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1534 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1536 : (o->op_type == OP_ENTERSUB
1537 ? "non-lvalue subroutine call"
1538 : PL_op_desc[o->op_type])),
1539 type ? PL_op_desc[type] : "local"));
1553 case OP_RIGHT_SHIFT:
1562 if (!(o->op_flags & OPf_STACKED))
1568 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1574 if (!type && cUNOPo->op_first->op_type != OP_GV)
1575 Perl_croak(aTHX_ "Can't localize through a reference");
1576 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1577 PL_modcount = RETURN_UNLIMITED_NUMBER;
1578 return o; /* Treat \(@foo) like ordinary list. */
1582 if (scalar_mod_type(o, type))
1584 ref(cUNOPo->op_first, o->op_type);
1588 if (type == OP_LEAVESUBLV)
1589 o->op_private |= OPpMAYBE_LVSUB;
1595 PL_modcount = RETURN_UNLIMITED_NUMBER;
1598 if (!type && cUNOPo->op_first->op_type != OP_GV)
1599 Perl_croak(aTHX_ "Can't localize through a reference");
1600 ref(cUNOPo->op_first, o->op_type);
1604 PL_hints |= HINT_BLOCK_SCOPE;
1614 PL_modcount = RETURN_UNLIMITED_NUMBER;
1615 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1616 return o; /* Treat \(@foo) like ordinary list. */
1617 if (scalar_mod_type(o, type))
1619 if (type == OP_LEAVESUBLV)
1620 o->op_private |= OPpMAYBE_LVSUB;
1625 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1626 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1631 PL_modcount++; /* XXX ??? */
1633 #endif /* USE_THREADS */
1639 if (type != OP_SASSIGN)
1643 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1648 if (type == OP_LEAVESUBLV)
1649 o->op_private |= OPpMAYBE_LVSUB;
1651 pad_free(o->op_targ);
1652 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1653 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1654 if (o->op_flags & OPf_KIDS)
1655 mod(cBINOPo->op_first->op_sibling, type);
1660 ref(cBINOPo->op_first, o->op_type);
1661 if (type == OP_ENTERSUB &&
1662 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1663 o->op_private |= OPpLVAL_DEFER;
1664 if (type == OP_LEAVESUBLV)
1665 o->op_private |= OPpMAYBE_LVSUB;
1673 if (o->op_flags & OPf_KIDS)
1674 mod(cLISTOPo->op_last, type);
1678 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1680 else if (!(o->op_flags & OPf_KIDS))
1682 if (o->op_targ != OP_LIST) {
1683 mod(cBINOPo->op_first, type);
1688 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1693 if (type != OP_LEAVESUBLV)
1695 break; /* mod()ing was handled by ck_return() */
1697 if (type != OP_LEAVESUBLV)
1698 o->op_flags |= OPf_MOD;
1700 if (type == OP_AASSIGN || type == OP_SASSIGN)
1701 o->op_flags |= OPf_SPECIAL|OPf_REF;
1703 o->op_private |= OPpLVAL_INTRO;
1704 o->op_flags &= ~OPf_SPECIAL;
1705 PL_hints |= HINT_BLOCK_SCOPE;
1707 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1708 && type != OP_LEAVESUBLV)
1709 o->op_flags |= OPf_REF;
1714 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1718 if (o->op_type == OP_RV2GV)
1742 case OP_RIGHT_SHIFT:
1761 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1763 switch (o->op_type) {
1771 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1784 Perl_refkids(pTHX_ OP *o, I32 type)
1787 if (o && o->op_flags & OPf_KIDS) {
1788 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1795 Perl_ref(pTHX_ OP *o, I32 type)
1799 if (!o || PL_error_count)
1802 switch (o->op_type) {
1804 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1805 !(o->op_flags & OPf_STACKED)) {
1806 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1807 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1808 assert(cUNOPo->op_first->op_type == OP_NULL);
1809 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1810 o->op_flags |= OPf_SPECIAL;
1815 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1819 if (type == OP_DEFINED)
1820 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1821 ref(cUNOPo->op_first, o->op_type);
1824 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1825 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1826 : type == OP_RV2HV ? OPpDEREF_HV
1828 o->op_flags |= OPf_MOD;
1833 o->op_flags |= OPf_MOD; /* XXX ??? */
1838 o->op_flags |= OPf_REF;
1841 if (type == OP_DEFINED)
1842 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1843 ref(cUNOPo->op_first, o->op_type);
1848 o->op_flags |= OPf_REF;
1853 if (!(o->op_flags & OPf_KIDS))
1855 ref(cBINOPo->op_first, type);
1859 ref(cBINOPo->op_first, o->op_type);
1860 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1861 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1862 : type == OP_RV2HV ? OPpDEREF_HV
1864 o->op_flags |= OPf_MOD;
1872 if (!(o->op_flags & OPf_KIDS))
1874 ref(cLISTOPo->op_last, type);
1884 S_dup_attrlist(pTHX_ OP *o)
1888 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1889 * where the first kid is OP_PUSHMARK and the remaining ones
1890 * are OP_CONST. We need to push the OP_CONST values.
1892 if (o->op_type == OP_CONST)
1893 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1895 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1896 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1897 if (o->op_type == OP_CONST)
1898 rop = append_elem(OP_LIST, rop,
1899 newSVOP(OP_CONST, o->op_flags,
1900 SvREFCNT_inc(cSVOPo->op_sv)));
1907 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1911 /* fake up C<use attributes $pkg,$rv,@attrs> */
1912 ENTER; /* need to protect against side-effects of 'use' */
1914 if (stash && HvNAME(stash))
1915 stashsv = newSVpv(HvNAME(stash), 0);
1917 stashsv = &PL_sv_no;
1919 #define ATTRSMODULE "attributes"
1921 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1922 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1924 prepend_elem(OP_LIST,
1925 newSVOP(OP_CONST, 0, stashsv),
1926 prepend_elem(OP_LIST,
1927 newSVOP(OP_CONST, 0,
1929 dup_attrlist(attrs))));
1934 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1935 char *attrstr, STRLEN len)
1940 len = strlen(attrstr);
1944 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1946 char *sstr = attrstr;
1947 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1948 attrs = append_elem(OP_LIST, attrs,
1949 newSVOP(OP_CONST, 0,
1950 newSVpvn(sstr, attrstr-sstr)));
1954 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1955 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1956 Nullsv, prepend_elem(OP_LIST,
1957 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1958 prepend_elem(OP_LIST,
1959 newSVOP(OP_CONST, 0,
1965 S_my_kid(pTHX_ OP *o, OP *attrs)
1970 if (!o || PL_error_count)
1974 if (type == OP_LIST) {
1975 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1977 } else if (type == OP_UNDEF) {
1979 } else if (type == OP_RV2SV || /* "our" declaration */
1981 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1983 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1985 PL_in_my_stash = Nullhv;
1986 apply_attrs(GvSTASH(gv),
1987 (type == OP_RV2SV ? GvSV(gv) :
1988 type == OP_RV2AV ? (SV*)GvAV(gv) :
1989 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1992 o->op_private |= OPpOUR_INTRO;
1994 } else if (type != OP_PADSV &&
1997 type != OP_PUSHMARK)
1999 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2000 PL_op_desc[o->op_type],
2001 PL_in_my == KEY_our ? "our" : "my"));
2004 else if (attrs && type != OP_PUSHMARK) {
2010 PL_in_my_stash = Nullhv;
2012 /* check for C<my Dog $spot> when deciding package */
2013 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2014 if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
2015 stash = SvSTASH(*namesvp);
2017 stash = PL_curstash;
2018 padsv = PAD_SV(o->op_targ);
2019 apply_attrs(stash, padsv, attrs);
2021 o->op_flags |= OPf_MOD;
2022 o->op_private |= OPpLVAL_INTRO;
2027 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2029 if (o->op_flags & OPf_PARENS)
2033 o = my_kid(o, attrs);
2035 PL_in_my_stash = Nullhv;
2040 Perl_my(pTHX_ OP *o)
2042 return my_kid(o, Nullop);
2046 Perl_sawparens(pTHX_ OP *o)
2049 o->op_flags |= OPf_PARENS;
2054 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2058 if (ckWARN(WARN_MISC) &&
2059 (left->op_type == OP_RV2AV ||
2060 left->op_type == OP_RV2HV ||
2061 left->op_type == OP_PADAV ||
2062 left->op_type == OP_PADHV)) {
2063 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2064 right->op_type == OP_TRANS)
2065 ? right->op_type : OP_MATCH];
2066 const char *sample = ((left->op_type == OP_RV2AV ||
2067 left->op_type == OP_PADAV)
2068 ? "@array" : "%hash");
2069 Perl_warner(aTHX_ WARN_MISC,
2070 "Applying %s to %s will act on scalar(%s)",
2071 desc, sample, sample);
2074 if (!(right->op_flags & OPf_STACKED) &&
2075 (right->op_type == OP_MATCH ||
2076 right->op_type == OP_SUBST ||
2077 right->op_type == OP_TRANS)) {
2078 right->op_flags |= OPf_STACKED;
2079 if (right->op_type != OP_MATCH &&
2080 ! (right->op_type == OP_TRANS &&
2081 right->op_private & OPpTRANS_IDENTICAL))
2082 left = mod(left, right->op_type);
2083 if (right->op_type == OP_TRANS)
2084 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2086 o = prepend_elem(right->op_type, scalar(left), right);
2088 return newUNOP(OP_NOT, 0, scalar(o));
2092 return bind_match(type, left,
2093 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2097 Perl_invert(pTHX_ OP *o)
2101 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2102 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2106 Perl_scope(pTHX_ OP *o)
2109 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2110 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2111 o->op_type = OP_LEAVE;
2112 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2115 if (o->op_type == OP_LINESEQ) {
2117 o->op_type = OP_SCOPE;
2118 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2119 kid = ((LISTOP*)o)->op_first;
2120 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2124 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2131 Perl_save_hints(pTHX)
2134 SAVESPTR(GvHV(PL_hintgv));
2135 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2136 SAVEFREESV(GvHV(PL_hintgv));
2140 Perl_block_start(pTHX_ int full)
2142 int retval = PL_savestack_ix;
2144 SAVEI32(PL_comppad_name_floor);
2145 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2147 PL_comppad_name_fill = PL_comppad_name_floor;
2148 if (PL_comppad_name_floor < 0)
2149 PL_comppad_name_floor = 0;
2150 SAVEI32(PL_min_intro_pending);
2151 SAVEI32(PL_max_intro_pending);
2152 PL_min_intro_pending = 0;
2153 SAVEI32(PL_comppad_name_fill);
2154 SAVEI32(PL_padix_floor);
2155 PL_padix_floor = PL_padix;
2156 PL_pad_reset_pending = FALSE;
2158 PL_hints &= ~HINT_BLOCK_SCOPE;
2159 SAVESPTR(PL_compiling.cop_warnings);
2160 if (! specialWARN(PL_compiling.cop_warnings)) {
2161 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2162 SAVEFREESV(PL_compiling.cop_warnings) ;
2164 SAVESPTR(PL_compiling.cop_io);
2165 if (! specialCopIO(PL_compiling.cop_io)) {
2166 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2167 SAVEFREESV(PL_compiling.cop_io) ;
2173 Perl_block_end(pTHX_ I32 floor, OP *seq)
2175 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2176 OP* retval = scalarseq(seq);
2178 PL_pad_reset_pending = FALSE;
2179 PL_compiling.op_private = PL_hints;
2181 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2182 pad_leavemy(PL_comppad_name_fill);
2191 OP *o = newOP(OP_THREADSV, 0);
2192 o->op_targ = find_threadsv("_");
2195 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2196 #endif /* USE_THREADS */
2200 Perl_newPROG(pTHX_ OP *o)
2205 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2206 ((PL_in_eval & EVAL_KEEPERR)
2207 ? OPf_SPECIAL : 0), o);
2208 PL_eval_start = linklist(PL_eval_root);
2209 PL_eval_root->op_private |= OPpREFCOUNTED;
2210 OpREFCNT_set(PL_eval_root, 1);
2211 PL_eval_root->op_next = 0;
2212 peep(PL_eval_start);
2217 PL_main_root = scope(sawparens(scalarvoid(o)));
2218 PL_curcop = &PL_compiling;
2219 PL_main_start = LINKLIST(PL_main_root);
2220 PL_main_root->op_private |= OPpREFCOUNTED;
2221 OpREFCNT_set(PL_main_root, 1);
2222 PL_main_root->op_next = 0;
2223 peep(PL_main_start);
2226 /* Register with debugger */
2228 CV *cv = get_cv("DB::postponed", FALSE);
2232 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2234 call_sv((SV*)cv, G_DISCARD);
2241 Perl_localize(pTHX_ OP *o, I32 lex)
2243 if (o->op_flags & OPf_PARENS)
2246 if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2248 for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2249 if (*s == ';' || *s == '=')
2250 Perl_warner(aTHX_ WARN_PARENTHESIS,
2251 "Parentheses missing around \"%s\" list",
2252 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2258 o = mod(o, OP_NULL); /* a bit kludgey */
2260 PL_in_my_stash = Nullhv;
2265 Perl_jmaybe(pTHX_ OP *o)
2267 if (o->op_type == OP_LIST) {
2270 o2 = newOP(OP_THREADSV, 0);
2271 o2->op_targ = find_threadsv(";");
2273 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2274 #endif /* USE_THREADS */
2275 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2281 Perl_fold_constants(pTHX_ register OP *o)
2284 I32 type = o->op_type;
2287 if (PL_opargs[type] & OA_RETSCALAR)
2289 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2290 o->op_targ = pad_alloc(type, SVs_PADTMP);
2292 /* integerize op, unless it happens to be C<-foo>.
2293 * XXX should pp_i_negate() do magic string negation instead? */
2294 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2295 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2296 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2298 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2301 if (!(PL_opargs[type] & OA_FOLDCONST))
2306 /* XXX might want a ck_negate() for this */
2307 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2320 if (o->op_private & OPpLOCALE)
2325 goto nope; /* Don't try to run w/ errors */
2327 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2328 if ((curop->op_type != OP_CONST ||
2329 (curop->op_private & OPpCONST_BARE)) &&
2330 curop->op_type != OP_LIST &&
2331 curop->op_type != OP_SCALAR &&
2332 curop->op_type != OP_NULL &&
2333 curop->op_type != OP_PUSHMARK)
2339 curop = LINKLIST(o);
2343 sv = *(PL_stack_sp--);
2344 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2345 pad_swipe(o->op_targ);
2346 else if (SvTEMP(sv)) { /* grab mortal temp? */
2347 (void)SvREFCNT_inc(sv);
2351 if (type == OP_RV2GV)
2352 return newGVOP(OP_GV, 0, (GV*)sv);
2354 /* try to smush double to int, but don't smush -2.0 to -2 */
2355 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2358 #ifdef PERL_PRESERVE_IVUV
2359 /* Only bother to attempt to fold to IV if
2360 most operators will benefit */
2364 return newSVOP(OP_CONST, 0, sv);
2368 if (!(PL_opargs[type] & OA_OTHERINT))
2371 if (!(PL_hints & HINT_INTEGER)) {
2372 if (type == OP_MODULO
2373 || type == OP_DIVIDE
2374 || !(o->op_flags & OPf_KIDS))
2379 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2380 if (curop->op_type == OP_CONST) {
2381 if (SvIOK(((SVOP*)curop)->op_sv))
2385 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2389 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2396 Perl_gen_constant_list(pTHX_ register OP *o)
2399 I32 oldtmps_floor = PL_tmps_floor;
2403 return o; /* Don't attempt to run with errors */
2405 PL_op = curop = LINKLIST(o);
2412 PL_tmps_floor = oldtmps_floor;
2414 o->op_type = OP_RV2AV;
2415 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2416 curop = ((UNOP*)o)->op_first;
2417 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2424 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2426 if (!o || o->op_type != OP_LIST)
2427 o = newLISTOP(OP_LIST, 0, o, Nullop);
2429 o->op_flags &= ~OPf_WANT;
2431 if (!(PL_opargs[type] & OA_MARK))
2432 null(cLISTOPo->op_first);
2435 o->op_ppaddr = PL_ppaddr[type];
2436 o->op_flags |= flags;
2438 o = CHECKOP(type, o);
2439 if (o->op_type != type)
2442 return fold_constants(o);
2445 /* List constructors */
2448 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2456 if (first->op_type != type
2457 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2459 return newLISTOP(type, 0, first, last);
2462 if (first->op_flags & OPf_KIDS)
2463 ((LISTOP*)first)->op_last->op_sibling = last;
2465 first->op_flags |= OPf_KIDS;
2466 ((LISTOP*)first)->op_first = last;
2468 ((LISTOP*)first)->op_last = last;
2473 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2481 if (first->op_type != type)
2482 return prepend_elem(type, (OP*)first, (OP*)last);
2484 if (last->op_type != type)
2485 return append_elem(type, (OP*)first, (OP*)last);
2487 first->op_last->op_sibling = last->op_first;
2488 first->op_last = last->op_last;
2489 first->op_flags |= (last->op_flags & OPf_KIDS);
2491 #ifdef PL_OP_SLAB_ALLOC
2499 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2507 if (last->op_type == type) {
2508 if (type == OP_LIST) { /* already a PUSHMARK there */
2509 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2510 ((LISTOP*)last)->op_first->op_sibling = first;
2511 if (!(first->op_flags & OPf_PARENS))
2512 last->op_flags &= ~OPf_PARENS;
2515 if (!(last->op_flags & OPf_KIDS)) {
2516 ((LISTOP*)last)->op_last = first;
2517 last->op_flags |= OPf_KIDS;
2519 first->op_sibling = ((LISTOP*)last)->op_first;
2520 ((LISTOP*)last)->op_first = first;
2522 last->op_flags |= OPf_KIDS;
2526 return newLISTOP(type, 0, first, last);
2532 Perl_newNULLLIST(pTHX)
2534 return newOP(OP_STUB, 0);
2538 Perl_force_list(pTHX_ OP *o)
2540 if (!o || o->op_type != OP_LIST)
2541 o = newLISTOP(OP_LIST, 0, o, Nullop);
2547 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2551 NewOp(1101, listop, 1, LISTOP);
2553 listop->op_type = type;
2554 listop->op_ppaddr = PL_ppaddr[type];
2557 listop->op_flags = flags;
2561 else if (!first && last)
2564 first->op_sibling = last;
2565 listop->op_first = first;
2566 listop->op_last = last;
2567 if (type == OP_LIST) {
2569 pushop = newOP(OP_PUSHMARK, 0);
2570 pushop->op_sibling = first;
2571 listop->op_first = pushop;
2572 listop->op_flags |= OPf_KIDS;
2574 listop->op_last = pushop;
2581 Perl_newOP(pTHX_ I32 type, I32 flags)
2584 NewOp(1101, o, 1, OP);
2586 o->op_ppaddr = PL_ppaddr[type];
2587 o->op_flags = flags;
2590 o->op_private = 0 + (flags >> 8);
2591 if (PL_opargs[type] & OA_RETSCALAR)
2593 if (PL_opargs[type] & OA_TARGET)
2594 o->op_targ = pad_alloc(type, SVs_PADTMP);
2595 return CHECKOP(type, o);
2599 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2604 first = newOP(OP_STUB, 0);
2605 if (PL_opargs[type] & OA_MARK)
2606 first = force_list(first);
2608 NewOp(1101, unop, 1, UNOP);
2609 unop->op_type = type;
2610 unop->op_ppaddr = PL_ppaddr[type];
2611 unop->op_first = first;
2612 unop->op_flags = flags | OPf_KIDS;
2613 unop->op_private = 1 | (flags >> 8);
2614 unop = (UNOP*) CHECKOP(type, unop);
2618 return fold_constants((OP *) unop);
2622 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2625 NewOp(1101, binop, 1, BINOP);
2628 first = newOP(OP_NULL, 0);
2630 binop->op_type = type;
2631 binop->op_ppaddr = PL_ppaddr[type];
2632 binop->op_first = first;
2633 binop->op_flags = flags | OPf_KIDS;
2636 binop->op_private = 1 | (flags >> 8);
2639 binop->op_private = 2 | (flags >> 8);
2640 first->op_sibling = last;
2643 binop = (BINOP*)CHECKOP(type, binop);
2644 if (binop->op_next || binop->op_type != type)
2647 binop->op_last = binop->op_first->op_sibling;
2649 return fold_constants((OP *)binop);
2653 utf8compare(const void *a, const void *b)
2656 for (i = 0; i < 10; i++) {
2657 if ((*(U8**)a)[i] < (*(U8**)b)[i])
2659 if ((*(U8**)a)[i] > (*(U8**)b)[i])
2666 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2668 SV *tstr = ((SVOP*)expr)->op_sv;
2669 SV *rstr = ((SVOP*)repl)->op_sv;
2672 U8 *t = (U8*)SvPV(tstr, tlen);
2673 U8 *r = (U8*)SvPV(rstr, rlen);
2680 register short *tbl;
2682 complement = o->op_private & OPpTRANS_COMPLEMENT;
2683 del = o->op_private & OPpTRANS_DELETE;
2684 squash = o->op_private & OPpTRANS_SQUASH;
2687 o->op_private |= OPpTRANS_FROM_UTF;
2690 o->op_private |= OPpTRANS_TO_UTF;
2692 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2693 SV* listsv = newSVpvn("# comment\n",10);
2695 U8* tend = t + tlen;
2696 U8* rend = r + rlen;
2710 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2711 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2712 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2713 U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend);
2716 U8 tmpbuf[UTF8_MAXLEN+1];
2719 New(1109, cp, tlen, U8*);
2721 transv = newSVpvn("",0);
2725 if (t < tend && *t == 0xff) {
2730 qsort(cp, i, sizeof(U8*), utf8compare);
2731 for (j = 0; j < i; j++) {
2733 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2734 /* CHECKME: Use unicode code points for ranges - needs more thought ... NI-S */
2735 UV val = utf8n_to_uvuni(s, cur, &ulen, 0);
2737 diff = val - nextmin;
2739 t = uvuni_to_utf8(tmpbuf,nextmin);
2740 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2742 t = uvuni_to_utf8(tmpbuf, val - 1);
2743 sv_catpvn(transv, "\377", 1);
2744 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2747 if (s < tend && *s == 0xff)
2748 val = utf8n_to_uvuni(s+1, cur - 1, &ulen, 0);
2752 t = uvuni_to_utf8(tmpbuf,nextmin);
2753 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2754 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2755 sv_catpvn(transv, "\377", 1);
2756 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2757 t = (U8*)SvPVX(transv);
2758 tlen = SvCUR(transv);
2762 else if (!rlen && !del) {
2763 r = t; rlen = tlen; rend = tend;
2767 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2769 o->op_private |= OPpTRANS_IDENTICAL;
2773 while (t < tend || tfirst <= tlast) {
2774 /* see if we need more "t" chars */
2775 if (tfirst > tlast) {
2776 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2778 if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
2780 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2787 /* now see if we need more "r" chars */
2788 if (rfirst > rlast) {
2790 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2792 if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
2794 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2803 rfirst = rlast = 0xffffffff;
2807 /* now see which range will peter our first, if either. */
2808 tdiff = tlast - tfirst;
2809 rdiff = rlast - rfirst;
2816 if (rfirst == 0xffffffff) {
2817 diff = tdiff; /* oops, pretend rdiff is infinite */
2819 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2820 (long)tfirst, (long)tlast);
2822 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2826 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2827 (long)tfirst, (long)(tfirst + diff),
2830 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2831 (long)tfirst, (long)rfirst);
2833 if (rfirst + diff > max)
2834 max = rfirst + diff;
2837 grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2848 else if (max > 0xff)
2853 Safefree(cPVOPo->op_pv);
2854 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2855 SvREFCNT_dec(listsv);
2857 SvREFCNT_dec(transv);
2859 if (!del && havefinal)
2860 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2861 newSVuv((UV)final), 0);
2864 o->op_private |= OPpTRANS_GROWS;
2876 tbl = (short*)cPVOPo->op_pv;
2878 Zero(tbl, 256, short);
2879 for (i = 0; i < tlen; i++)
2881 for (i = 0, j = 0; i < 256; i++) {
2892 if (i < 128 && r[j] >= 128)
2898 if (!del && (rlen > 0xff || tlen > 0xff)) {
2902 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2903 tbl[0x100] = rlen - j;
2904 for (i=0; i < rlen - j; i++)
2905 tbl[0x101+i] = r[j+i];
2909 if (!rlen && !del) {
2912 o->op_private |= OPpTRANS_IDENTICAL;
2914 for (i = 0; i < 256; i++)
2916 for (i = 0, j = 0; i < tlen; i++,j++) {
2919 if (tbl[t[i]] == -1)
2925 if (tbl[t[i]] == -1) {
2926 if (t[i] < 128 && r[j] >= 128)
2933 o->op_private |= OPpTRANS_GROWS;
2941 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2945 NewOp(1101, pmop, 1, PMOP);
2946 pmop->op_type = type;
2947 pmop->op_ppaddr = PL_ppaddr[type];
2948 pmop->op_flags = flags;
2949 pmop->op_private = 0 | (flags >> 8);
2951 if (PL_hints & HINT_RE_TAINT)
2952 pmop->op_pmpermflags |= PMf_RETAINT;
2953 if (PL_hints & HINT_LOCALE)
2954 pmop->op_pmpermflags |= PMf_LOCALE;
2955 pmop->op_pmflags = pmop->op_pmpermflags;
2957 /* link into pm list */
2958 if (type != OP_TRANS && PL_curstash) {
2959 pmop->op_pmnext = HvPMROOT(PL_curstash);
2960 HvPMROOT(PL_curstash) = pmop;
2961 PmopSTASH_set(pmop,PL_curstash);
2968 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2972 I32 repl_has_vars = 0;
2974 if (o->op_type == OP_TRANS)
2975 return pmtrans(o, expr, repl);
2977 PL_hints |= HINT_BLOCK_SCOPE;
2980 if (expr->op_type == OP_CONST) {
2982 SV *pat = ((SVOP*)expr)->op_sv;
2983 char *p = SvPV(pat, plen);
2984 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2985 sv_setpvn(pat, "\\s+", 3);
2986 p = SvPV(pat, plen);
2987 pm->op_pmflags |= PMf_SKIPWHITE;
2989 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2990 pm->op_pmdynflags |= PMdf_UTF8;
2991 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2992 if (strEQ("\\s+", pm->op_pmregexp->precomp))
2993 pm->op_pmflags |= PMf_WHITE;
2997 if (PL_hints & HINT_UTF8)
2998 pm->op_pmdynflags |= PMdf_UTF8;
2999 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3000 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3002 : OP_REGCMAYBE),0,expr);
3004 NewOp(1101, rcop, 1, LOGOP);
3005 rcop->op_type = OP_REGCOMP;
3006 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3007 rcop->op_first = scalar(expr);
3008 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3009 ? (OPf_SPECIAL | OPf_KIDS)
3011 rcop->op_private = 1;
3014 /* establish postfix order */
3015 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3017 rcop->op_next = expr;
3018 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3021 rcop->op_next = LINKLIST(expr);
3022 expr->op_next = (OP*)rcop;
3025 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3030 if (pm->op_pmflags & PMf_EVAL) {
3032 if (CopLINE(PL_curcop) < PL_multi_end)
3033 CopLINE_set(PL_curcop, PL_multi_end);
3036 else if (repl->op_type == OP_THREADSV
3037 && strchr("&`'123456789+",
3038 PL_threadsv_names[repl->op_targ]))
3042 #endif /* USE_THREADS */
3043 else if (repl->op_type == OP_CONST)
3047 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3048 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3050 if (curop->op_type == OP_THREADSV) {
3052 if (strchr("&`'123456789+", curop->op_private))
3056 if (curop->op_type == OP_GV) {
3057 GV *gv = cGVOPx_gv(curop);
3059 if (strchr("&`'123456789+", *GvENAME(gv)))
3062 #endif /* USE_THREADS */
3063 else if (curop->op_type == OP_RV2CV)
3065 else if (curop->op_type == OP_RV2SV ||
3066 curop->op_type == OP_RV2AV ||
3067 curop->op_type == OP_RV2HV ||
3068 curop->op_type == OP_RV2GV) {
3069 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3072 else if (curop->op_type == OP_PADSV ||
3073 curop->op_type == OP_PADAV ||
3074 curop->op_type == OP_PADHV ||
3075 curop->op_type == OP_PADANY) {
3078 else if (curop->op_type == OP_PUSHRE)
3079 ; /* Okay here, dangerous in newASSIGNOP */
3088 && (!pm->op_pmregexp
3089 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3090 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3091 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3092 prepend_elem(o->op_type, scalar(repl), o);
3095 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3096 pm->op_pmflags |= PMf_MAYBE_CONST;
3097 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3099 NewOp(1101, rcop, 1, LOGOP);
3100 rcop->op_type = OP_SUBSTCONT;
3101 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3102 rcop->op_first = scalar(repl);
3103 rcop->op_flags |= OPf_KIDS;
3104 rcop->op_private = 1;
3107 /* establish postfix order */
3108 rcop->op_next = LINKLIST(repl);
3109 repl->op_next = (OP*)rcop;
3111 pm->op_pmreplroot = scalar((OP*)rcop);
3112 pm->op_pmreplstart = LINKLIST(rcop);
3121 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3124 NewOp(1101, svop, 1, SVOP);
3125 svop->op_type = type;
3126 svop->op_ppaddr = PL_ppaddr[type];
3128 svop->op_next = (OP*)svop;
3129 svop->op_flags = flags;
3130 if (PL_opargs[type] & OA_RETSCALAR)
3132 if (PL_opargs[type] & OA_TARGET)
3133 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3134 return CHECKOP(type, svop);
3138 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3141 NewOp(1101, padop, 1, PADOP);
3142 padop->op_type = type;
3143 padop->op_ppaddr = PL_ppaddr[type];
3144 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3145 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3146 PL_curpad[padop->op_padix] = sv;
3148 padop->op_next = (OP*)padop;
3149 padop->op_flags = flags;
3150 if (PL_opargs[type] & OA_RETSCALAR)
3152 if (PL_opargs[type] & OA_TARGET)
3153 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3154 return CHECKOP(type, padop);
3158 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3162 return newPADOP(type, flags, SvREFCNT_inc(gv));
3164 return newSVOP(type, flags, SvREFCNT_inc(gv));
3169 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3172 NewOp(1101, pvop, 1, PVOP);
3173 pvop->op_type = type;
3174 pvop->op_ppaddr = PL_ppaddr[type];
3176 pvop->op_next = (OP*)pvop;
3177 pvop->op_flags = flags;
3178 if (PL_opargs[type] & OA_RETSCALAR)
3180 if (PL_opargs[type] & OA_TARGET)
3181 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3182 return CHECKOP(type, pvop);
3186 Perl_package(pTHX_ OP *o)
3190 save_hptr(&PL_curstash);
3191 save_item(PL_curstname);
3196 name = SvPV(sv, len);
3197 PL_curstash = gv_stashpvn(name,len,TRUE);
3198 sv_setpvn(PL_curstname, name, len);
3202 sv_setpv(PL_curstname,"<none>");
3203 PL_curstash = Nullhv;
3205 PL_hints |= HINT_BLOCK_SCOPE;
3206 PL_copline = NOLINE;
3211 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3219 if (id->op_type != OP_CONST)
3220 Perl_croak(aTHX_ "Module name must be constant");
3224 if (version != Nullop) {
3225 SV *vesv = ((SVOP*)version)->op_sv;
3227 if (arg == Nullop && !SvNIOKp(vesv)) {
3234 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3235 Perl_croak(aTHX_ "Version number must be constant number");
3237 /* Make copy of id so we don't free it twice */
3238 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3240 /* Fake up a method call to VERSION */
3241 meth = newSVpvn("VERSION",7);
3242 sv_upgrade(meth, SVt_PVIV);
3243 (void)SvIOK_on(meth);
3244 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3245 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3246 append_elem(OP_LIST,
3247 prepend_elem(OP_LIST, pack, list(version)),
3248 newSVOP(OP_METHOD_NAMED, 0, meth)));
3252 /* Fake up an import/unimport */
3253 if (arg && arg->op_type == OP_STUB)
3254 imop = arg; /* no import on explicit () */
3255 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3256 imop = Nullop; /* use 5.0; */
3261 /* Make copy of id so we don't free it twice */
3262 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3264 /* Fake up a method call to import/unimport */
3265 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3266 sv_upgrade(meth, SVt_PVIV);
3267 (void)SvIOK_on(meth);
3268 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3269 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3270 append_elem(OP_LIST,
3271 prepend_elem(OP_LIST, pack, list(arg)),
3272 newSVOP(OP_METHOD_NAMED, 0, meth)));
3275 /* Fake up a require, handle override, if any */
3276 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3277 if (!(gv && GvIMPORTED_CV(gv)))
3278 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3280 if (gv && GvIMPORTED_CV(gv)) {
3281 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3282 append_elem(OP_LIST, id,
3283 scalar(newUNOP(OP_RV2CV, 0,
3288 rqop = newUNOP(OP_REQUIRE, 0, id);
3291 /* Fake up the BEGIN {}, which does its thing immediately. */
3293 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3296 append_elem(OP_LINESEQ,
3297 append_elem(OP_LINESEQ,
3298 newSTATEOP(0, Nullch, rqop),
3299 newSTATEOP(0, Nullch, veop)),
3300 newSTATEOP(0, Nullch, imop) ));
3302 PL_hints |= HINT_BLOCK_SCOPE;
3303 PL_copline = NOLINE;
3308 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3311 va_start(args, ver);
3312 vload_module(flags, name, ver, &args);
3316 #ifdef PERL_IMPLICIT_CONTEXT
3318 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3322 va_start(args, ver);
3323 vload_module(flags, name, ver, &args);
3329 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3331 OP *modname, *veop, *imop;
3333 modname = newSVOP(OP_CONST, 0, name);
3334 modname->op_private |= OPpCONST_BARE;
3336 veop = newSVOP(OP_CONST, 0, ver);
3340 if (flags & PERL_LOADMOD_NOIMPORT) {
3341 imop = sawparens(newNULLLIST());
3343 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3344 imop = va_arg(*args, OP*);
3349 sv = va_arg(*args, SV*);
3351 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3352 sv = va_arg(*args, SV*);
3356 line_t ocopline = PL_copline;
3357 int oexpect = PL_expect;
3359 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3360 veop, modname, imop);
3361 PL_expect = oexpect;
3362 PL_copline = ocopline;
3367 Perl_dofile(pTHX_ OP *term)
3372 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3373 if (!(gv && GvIMPORTED_CV(gv)))
3374 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3376 if (gv && GvIMPORTED_CV(gv)) {
3377 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3378 append_elem(OP_LIST, term,
3379 scalar(newUNOP(OP_RV2CV, 0,
3384 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3390 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3392 return newBINOP(OP_LSLICE, flags,
3393 list(force_list(subscript)),
3394 list(force_list(listval)) );
3398 S_list_assignment(pTHX_ register OP *o)
3403 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3404 o = cUNOPo->op_first;
3406 if (o->op_type == OP_COND_EXPR) {
3407 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3408 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3413 yyerror("Assignment to both a list and a scalar");
3417 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3418 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3419 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3422 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3425 if (o->op_type == OP_RV2SV)
3432 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3437 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3438 return newLOGOP(optype, 0,
3439 mod(scalar(left), optype),
3440 newUNOP(OP_SASSIGN, 0, scalar(right)));
3443 return newBINOP(optype, OPf_STACKED,
3444 mod(scalar(left), optype), scalar(right));
3448 if (list_assignment(left)) {
3452 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3453 left = mod(left, OP_AASSIGN);
3461 curop = list(force_list(left));
3462 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3463 o->op_private = 0 | (flags >> 8);
3464 for (curop = ((LISTOP*)curop)->op_first;
3465 curop; curop = curop->op_sibling)
3467 if (curop->op_type == OP_RV2HV &&
3468 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3469 o->op_private |= OPpASSIGN_HASH;
3473 if (!(left->op_private & OPpLVAL_INTRO)) {
3476 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3477 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3478 if (curop->op_type == OP_GV) {
3479 GV *gv = cGVOPx_gv(curop);
3480 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3482 SvCUR(gv) = PL_generation;
3484 else if (curop->op_type == OP_PADSV ||
3485 curop->op_type == OP_PADAV ||
3486 curop->op_type == OP_PADHV ||
3487 curop->op_type == OP_PADANY) {
3488 SV **svp = AvARRAY(PL_comppad_name);
3489 SV *sv = svp[curop->op_targ];
3490 if (SvCUR(sv) == PL_generation)
3492 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3494 else if (curop->op_type == OP_RV2CV)
3496 else if (curop->op_type == OP_RV2SV ||
3497 curop->op_type == OP_RV2AV ||
3498 curop->op_type == OP_RV2HV ||
3499 curop->op_type == OP_RV2GV) {
3500 if (lastop->op_type != OP_GV) /* funny deref? */
3503 else if (curop->op_type == OP_PUSHRE) {
3504 if (((PMOP*)curop)->op_pmreplroot) {
3506 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3508 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3510 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3512 SvCUR(gv) = PL_generation;
3521 o->op_private |= OPpASSIGN_COMMON;
3523 if (right && right->op_type == OP_SPLIT) {
3525 if ((tmpop = ((LISTOP*)right)->op_first) &&
3526 tmpop->op_type == OP_PUSHRE)
3528 PMOP *pm = (PMOP*)tmpop;
3529 if (left->op_type == OP_RV2AV &&
3530 !(left->op_private & OPpLVAL_INTRO) &&
3531 !(o->op_private & OPpASSIGN_COMMON) )
3533 tmpop = ((UNOP*)left)->op_first;
3534 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3536 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3537 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3539 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3540 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3542 pm->op_pmflags |= PMf_ONCE;
3543 tmpop = cUNOPo->op_first; /* to list (nulled) */
3544 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3545 tmpop->op_sibling = Nullop; /* don't free split */
3546 right->op_next = tmpop->op_next; /* fix starting loc */
3547 op_free(o); /* blow off assign */
3548 right->op_flags &= ~OPf_WANT;
3549 /* "I don't know and I don't care." */
3554 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3555 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3557 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3559 sv_setiv(sv, PL_modcount+1);
3567 right = newOP(OP_UNDEF, 0);
3568 if (right->op_type == OP_READLINE) {
3569 right->op_flags |= OPf_STACKED;
3570 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3573 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3574 o = newBINOP(OP_SASSIGN, flags,
3575 scalar(right), mod(scalar(left), OP_SASSIGN) );
3587 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3589 U32 seq = intro_my();
3592 NewOp(1101, cop, 1, COP);
3593 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3594 cop->op_type = OP_DBSTATE;
3595 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3598 cop->op_type = OP_NEXTSTATE;
3599 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3601 cop->op_flags = flags;
3602 cop->op_private = (PL_hints & HINT_BYTE);
3604 cop->op_private |= NATIVE_HINTS;
3606 PL_compiling.op_private = cop->op_private;
3607 cop->op_next = (OP*)cop;
3610 cop->cop_label = label;
3611 PL_hints |= HINT_BLOCK_SCOPE;
3614 cop->cop_arybase = PL_curcop->cop_arybase;
3615 if (specialWARN(PL_curcop->cop_warnings))
3616 cop->cop_warnings = PL_curcop->cop_warnings ;
3618 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3619 if (specialCopIO(PL_curcop->cop_io))
3620 cop->cop_io = PL_curcop->cop_io;
3622 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3625 if (PL_copline == NOLINE)
3626 CopLINE_set(cop, CopLINE(PL_curcop));
3628 CopLINE_set(cop, PL_copline);
3629 PL_copline = NOLINE;
3632 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3634 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3636 CopSTASH_set(cop, PL_curstash);
3638 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3639 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3640 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3641 (void)SvIOK_on(*svp);
3642 SvIVX(*svp) = PTR2IV(cop);
3646 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3649 /* "Introduce" my variables to visible status. */
3657 if (! PL_min_intro_pending)
3658 return PL_cop_seqmax;
3660 svp = AvARRAY(PL_comppad_name);
3661 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3662 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3663 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3664 SvNVX(sv) = (NV)PL_cop_seqmax;
3667 PL_min_intro_pending = 0;
3668 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3669 return PL_cop_seqmax++;
3673 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3675 return new_logop(type, flags, &first, &other);
3679 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3683 OP *first = *firstp;
3684 OP *other = *otherp;
3686 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3687 return newBINOP(type, flags, scalar(first), scalar(other));
3689 scalarboolean(first);
3690 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3691 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3692 if (type == OP_AND || type == OP_OR) {
3698 first = *firstp = cUNOPo->op_first;
3700 first->op_next = o->op_next;
3701 cUNOPo->op_first = Nullop;
3705 if (first->op_type == OP_CONST) {
3706 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3707 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3708 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3719 else if (first->op_type == OP_WANTARRAY) {
3725 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3726 OP *k1 = ((UNOP*)first)->op_first;
3727 OP *k2 = k1->op_sibling;
3729 switch (first->op_type)
3732 if (k2 && k2->op_type == OP_READLINE
3733 && (k2->op_flags & OPf_STACKED)
3734 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3736 warnop = k2->op_type;
3741 if (k1->op_type == OP_READDIR
3742 || k1->op_type == OP_GLOB
3743 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3744 || k1->op_type == OP_EACH)
3746 warnop = ((k1->op_type == OP_NULL)
3747 ? k1->op_targ : k1->op_type);
3752 line_t oldline = CopLINE(PL_curcop);
3753 CopLINE_set(PL_curcop, PL_copline);
3754 Perl_warner(aTHX_ WARN_MISC,
3755 "Value of %s%s can be \"0\"; test with defined()",
3757 ((warnop == OP_READLINE || warnop == OP_GLOB)
3758 ? " construct" : "() operator"));
3759 CopLINE_set(PL_curcop, oldline);
3766 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3767 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3769 NewOp(1101, logop, 1, LOGOP);
3771 logop->op_type = type;
3772 logop->op_ppaddr = PL_ppaddr[type];
3773 logop->op_first = first;
3774 logop->op_flags = flags | OPf_KIDS;
3775 logop->op_other = LINKLIST(other);
3776 logop->op_private = 1 | (flags >> 8);
3778 /* establish postfix order */
3779 logop->op_next = LINKLIST(first);
3780 first->op_next = (OP*)logop;
3781 first->op_sibling = other;
3783 o = newUNOP(OP_NULL, 0, (OP*)logop);
3790 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3797 return newLOGOP(OP_AND, 0, first, trueop);
3799 return newLOGOP(OP_OR, 0, first, falseop);
3801 scalarboolean(first);
3802 if (first->op_type == OP_CONST) {
3803 if (SvTRUE(((SVOP*)first)->op_sv)) {
3814 else if (first->op_type == OP_WANTARRAY) {
3818 NewOp(1101, logop, 1, LOGOP);
3819 logop->op_type = OP_COND_EXPR;
3820 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3821 logop->op_first = first;
3822 logop->op_flags = flags | OPf_KIDS;
3823 logop->op_private = 1 | (flags >> 8);
3824 logop->op_other = LINKLIST(trueop);
3825 logop->op_next = LINKLIST(falseop);
3828 /* establish postfix order */
3829 start = LINKLIST(first);
3830 first->op_next = (OP*)logop;
3832 first->op_sibling = trueop;
3833 trueop->op_sibling = falseop;
3834 o = newUNOP(OP_NULL, 0, (OP*)logop);
3836 trueop->op_next = falseop->op_next = o;
3843 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3851 NewOp(1101, range, 1, LOGOP);
3853 range->op_type = OP_RANGE;
3854 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3855 range->op_first = left;
3856 range->op_flags = OPf_KIDS;
3857 leftstart = LINKLIST(left);
3858 range->op_other = LINKLIST(right);
3859 range->op_private = 1 | (flags >> 8);
3861 left->op_sibling = right;
3863 range->op_next = (OP*)range;
3864 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3865 flop = newUNOP(OP_FLOP, 0, flip);
3866 o = newUNOP(OP_NULL, 0, flop);
3868 range->op_next = leftstart;
3870 left->op_next = flip;
3871 right->op_next = flop;
3873 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3874 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3875 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3876 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3878 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3879 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3882 if (!flip->op_private || !flop->op_private)
3883 linklist(o); /* blow off optimizer unless constant */
3889 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3893 int once = block && block->op_flags & OPf_SPECIAL &&
3894 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3897 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3898 return block; /* do {} while 0 does once */
3899 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3900 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3901 expr = newUNOP(OP_DEFINED, 0,
3902 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3903 } else if (expr->op_flags & OPf_KIDS) {
3904 OP *k1 = ((UNOP*)expr)->op_first;
3905 OP *k2 = (k1) ? k1->op_sibling : NULL;
3906 switch (expr->op_type) {
3908 if (k2 && k2->op_type == OP_READLINE
3909 && (k2->op_flags & OPf_STACKED)
3910 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3911 expr = newUNOP(OP_DEFINED, 0, expr);
3915 if (k1->op_type == OP_READDIR
3916 || k1->op_type == OP_GLOB
3917 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3918 || k1->op_type == OP_EACH)
3919 expr = newUNOP(OP_DEFINED, 0, expr);
3925 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3926 o = new_logop(OP_AND, 0, &expr, &listop);
3929 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3931 if (once && o != listop)
3932 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3935 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3937 o->op_flags |= flags;
3939 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3944 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3953 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3954 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3955 expr = newUNOP(OP_DEFINED, 0,
3956 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3957 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3958 OP *k1 = ((UNOP*)expr)->op_first;
3959 OP *k2 = (k1) ? k1->op_sibling : NULL;
3960 switch (expr->op_type) {
3962 if (k2 && k2->op_type == OP_READLINE
3963 && (k2->op_flags & OPf_STACKED)
3964 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3965 expr = newUNOP(OP_DEFINED, 0, expr);
3969 if (k1->op_type == OP_READDIR
3970 || k1->op_type == OP_GLOB
3971 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3972 || k1->op_type == OP_EACH)
3973 expr = newUNOP(OP_DEFINED, 0, expr);
3979 block = newOP(OP_NULL, 0);
3981 block = scope(block);
3985 next = LINKLIST(cont);
3988 OP *unstack = newOP(OP_UNSTACK, 0);
3991 cont = append_elem(OP_LINESEQ, cont, unstack);
3992 if ((line_t)whileline != NOLINE) {
3993 PL_copline = whileline;
3994 cont = append_elem(OP_LINESEQ, cont,
3995 newSTATEOP(0, Nullch, Nullop));
3999 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4000 redo = LINKLIST(listop);
4003 PL_copline = whileline;
4005 o = new_logop(OP_AND, 0, &expr, &listop);
4006 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4007 op_free(expr); /* oops, it's a while (0) */
4009 return Nullop; /* listop already freed by new_logop */
4012 ((LISTOP*)listop)->op_last->op_next = condop =
4013 (o == listop ? redo : LINKLIST(o));
4019 NewOp(1101,loop,1,LOOP);
4020 loop->op_type = OP_ENTERLOOP;
4021 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4022 loop->op_private = 0;
4023 loop->op_next = (OP*)loop;
4026 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4028 loop->op_redoop = redo;
4029 loop->op_lastop = o;
4030 o->op_private |= loopflags;
4033 loop->op_nextop = next;
4035 loop->op_nextop = o;
4037 o->op_flags |= flags;
4038 o->op_private |= (flags >> 8);
4043 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4051 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4052 sv->op_type = OP_RV2GV;
4053 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4055 else if (sv->op_type == OP_PADSV) { /* private variable */
4056 padoff = sv->op_targ;
4061 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4062 padoff = sv->op_targ;
4064 iterflags |= OPf_SPECIAL;
4069 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4073 padoff = find_threadsv("_");
4074 iterflags |= OPf_SPECIAL;
4076 sv = newGVOP(OP_GV, 0, PL_defgv);
4079 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4080 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4081 iterflags |= OPf_STACKED;
4083 else if (expr->op_type == OP_NULL &&
4084 (expr->op_flags & OPf_KIDS) &&
4085 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4087 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4088 * set the STACKED flag to indicate that these values are to be
4089 * treated as min/max values by 'pp_iterinit'.
4091 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4092 LOGOP* range = (LOGOP*) flip->op_first;
4093 OP* left = range->op_first;
4094 OP* right = left->op_sibling;
4097 range->op_flags &= ~OPf_KIDS;
4098 range->op_first = Nullop;
4100 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4101 listop->op_first->op_next = range->op_next;
4102 left->op_next = range->op_other;
4103 right->op_next = (OP*)listop;
4104 listop->op_next = listop->op_first;
4107 expr = (OP*)(listop);
4109 iterflags |= OPf_STACKED;
4112 expr = mod(force_list(expr), OP_GREPSTART);
4116 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4117 append_elem(OP_LIST, expr, scalar(sv))));
4118 assert(!loop->op_next);
4119 #ifdef PL_OP_SLAB_ALLOC
4122 NewOp(1234,tmp,1,LOOP);
4123 Copy(loop,tmp,1,LOOP);
4127 Renew(loop, 1, LOOP);
4129 loop->op_targ = padoff;
4130 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4131 PL_copline = forline;
4132 return newSTATEOP(0, label, wop);
4136 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4141 if (type != OP_GOTO || label->op_type == OP_CONST) {
4142 /* "last()" means "last" */
4143 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4144 o = newOP(type, OPf_SPECIAL);
4146 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4147 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4153 if (label->op_type == OP_ENTERSUB)
4154 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4155 o = newUNOP(type, OPf_STACKED, label);
4157 PL_hints |= HINT_BLOCK_SCOPE;
4162 Perl_cv_undef(pTHX_ CV *cv)
4166 MUTEX_DESTROY(CvMUTEXP(cv));
4167 Safefree(CvMUTEXP(cv));
4170 #endif /* USE_THREADS */
4172 if (!CvXSUB(cv) && CvROOT(cv)) {
4174 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4175 Perl_croak(aTHX_ "Can't undef active subroutine");
4178 Perl_croak(aTHX_ "Can't undef active subroutine");
4179 #endif /* USE_THREADS */
4182 SAVEVPTR(PL_curpad);
4185 op_free(CvROOT(cv));
4186 CvROOT(cv) = Nullop;
4189 SvPOK_off((SV*)cv); /* forget prototype */
4191 /* Since closure prototypes have the same lifetime as the containing
4192 * CV, they don't hold a refcount on the outside CV. This avoids
4193 * the refcount loop between the outer CV (which keeps a refcount to
4194 * the closure prototype in the pad entry for pp_anoncode()) and the
4195 * closure prototype, and the ensuing memory leak. --GSAR */
4196 if (!CvANON(cv) || CvCLONED(cv))
4197 SvREFCNT_dec(CvOUTSIDE(cv));
4198 CvOUTSIDE(cv) = Nullcv;
4200 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4203 if (CvPADLIST(cv)) {
4204 /* may be during global destruction */
4205 if (SvREFCNT(CvPADLIST(cv))) {
4206 I32 i = AvFILLp(CvPADLIST(cv));
4208 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4209 SV* sv = svp ? *svp : Nullsv;
4212 if (sv == (SV*)PL_comppad_name)
4213 PL_comppad_name = Nullav;
4214 else if (sv == (SV*)PL_comppad) {
4215 PL_comppad = Nullav;
4216 PL_curpad = Null(SV**);
4220 SvREFCNT_dec((SV*)CvPADLIST(cv));
4222 CvPADLIST(cv) = Nullav;
4227 #ifdef DEBUG_CLOSURES
4229 S_cv_dump(pTHX_ CV *cv)
4232 CV *outside = CvOUTSIDE(cv);
4233 AV* padlist = CvPADLIST(cv);
4240 PerlIO_printf(Perl_debug_log,
4241 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4243 (CvANON(cv) ? "ANON"
4244 : (cv == PL_main_cv) ? "MAIN"
4245 : CvUNIQUE(cv) ? "UNIQUE"
4246 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4249 : CvANON(outside) ? "ANON"
4250 : (outside == PL_main_cv) ? "MAIN"
4251 : CvUNIQUE(outside) ? "UNIQUE"
4252 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4257 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4258 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4259 pname = AvARRAY(pad_name);
4260 ppad = AvARRAY(pad);
4262 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4263 if (SvPOK(pname[ix]))
4264 PerlIO_printf(Perl_debug_log,
4265 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4266 (int)ix, PTR2UV(ppad[ix]),
4267 SvFAKE(pname[ix]) ? "FAKE " : "",
4269 (IV)I_32(SvNVX(pname[ix])),
4272 #endif /* DEBUGGING */
4274 #endif /* DEBUG_CLOSURES */
4277 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4281 AV* protopadlist = CvPADLIST(proto);
4282 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4283 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4284 SV** pname = AvARRAY(protopad_name);
4285 SV** ppad = AvARRAY(protopad);
4286 I32 fname = AvFILLp(protopad_name);
4287 I32 fpad = AvFILLp(protopad);
4291 assert(!CvUNIQUE(proto));
4295 SAVESPTR(PL_comppad_name);
4296 SAVESPTR(PL_compcv);
4298 cv = PL_compcv = (CV*)NEWSV(1104,0);
4299 sv_upgrade((SV *)cv, SvTYPE(proto));
4300 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4304 New(666, CvMUTEXP(cv), 1, perl_mutex);
4305 MUTEX_INIT(CvMUTEXP(cv));
4307 #endif /* USE_THREADS */
4308 CvFILE(cv) = CvFILE(proto);
4309 CvGV(cv) = CvGV(proto);
4310 CvSTASH(cv) = CvSTASH(proto);
4311 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4312 CvSTART(cv) = CvSTART(proto);
4314 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4317 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4319 PL_comppad_name = newAV();
4320 for (ix = fname; ix >= 0; ix--)
4321 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4323 PL_comppad = newAV();
4325 comppadlist = newAV();
4326 AvREAL_off(comppadlist);
4327 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4328 av_store(comppadlist, 1, (SV*)PL_comppad);
4329 CvPADLIST(cv) = comppadlist;
4330 av_fill(PL_comppad, AvFILLp(protopad));
4331 PL_curpad = AvARRAY(PL_comppad);
4333 av = newAV(); /* will be @_ */
4335 av_store(PL_comppad, 0, (SV*)av);
4336 AvFLAGS(av) = AVf_REIFY;
4338 for (ix = fpad; ix > 0; ix--) {
4339 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4340 if (namesv && namesv != &PL_sv_undef) {
4341 char *name = SvPVX(namesv); /* XXX */
4342 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4343 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4344 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4346 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4348 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4350 else { /* our own lexical */
4353 /* anon code -- we'll come back for it */
4354 sv = SvREFCNT_inc(ppad[ix]);
4356 else if (*name == '@')
4358 else if (*name == '%')
4367 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4368 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4371 SV* sv = NEWSV(0,0);
4377 /* Now that vars are all in place, clone nested closures. */
4379 for (ix = fpad; ix > 0; ix--) {
4380 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4382 && namesv != &PL_sv_undef
4383 && !(SvFLAGS(namesv) & SVf_FAKE)
4384 && *SvPVX(namesv) == '&'
4385 && CvCLONE(ppad[ix]))
4387 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4388 SvREFCNT_dec(ppad[ix]);
4391 PL_curpad[ix] = (SV*)kid;
4395 #ifdef DEBUG_CLOSURES
4396 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4398 PerlIO_printf(Perl_debug_log, " from:\n");
4400 PerlIO_printf(Perl_debug_log, " to:\n");
4407 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4409 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4411 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4418 Perl_cv_clone(pTHX_ CV *proto)
4421 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4422 cv = cv_clone2(proto, CvOUTSIDE(proto));
4423 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4428 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4430 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4431 SV* msg = sv_newmortal();
4435 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4436 sv_setpv(msg, "Prototype mismatch:");
4438 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4440 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4441 sv_catpv(msg, " vs ");
4443 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4445 sv_catpv(msg, "none");
4446 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4450 static void const_sv_xsub(pTHXo_ CV* cv);
4453 =for apidoc cv_const_sv
4455 If C<cv> is a constant sub eligible for inlining. returns the constant
4456 value returned by the sub. Otherwise, returns NULL.
4458 Constant subs can be created with C<newCONSTSUB> or as described in
4459 L<perlsub/"Constant Functions">.
4464 Perl_cv_const_sv(pTHX_ CV *cv)
4466 if (!cv || !CvCONST(cv))
4468 return (SV*)CvXSUBANY(cv).any_ptr;
4472 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4479 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4480 o = cLISTOPo->op_first->op_sibling;
4482 for (; o; o = o->op_next) {
4483 OPCODE type = o->op_type;
4485 if (sv && o->op_next == o)
4487 if (o->op_next != o) {
4488 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4490 if (type == OP_DBSTATE)
4493 if (type == OP_LEAVESUB || type == OP_RETURN)
4497 if (type == OP_CONST && cSVOPo->op_sv)
4499 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4500 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4501 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4505 /* We get here only from cv_clone2() while creating a closure.
4506 Copy the const value here instead of in cv_clone2 so that
4507 SvREADONLY_on doesn't lead to problems when leaving
4512 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4524 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4534 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4538 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4540 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4544 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4550 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4555 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4556 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4557 SV *sv = sv_newmortal();
4558 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4559 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4564 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4565 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4575 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4576 maximum a prototype before. */
4577 if (SvTYPE(gv) > SVt_NULL) {
4578 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4579 && ckWARN_d(WARN_PROTOTYPE))
4581 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4583 cv_ckproto((CV*)gv, NULL, ps);
4586 sv_setpv((SV*)gv, ps);
4588 sv_setiv((SV*)gv, -1);
4589 SvREFCNT_dec(PL_compcv);
4590 cv = PL_compcv = NULL;
4591 PL_sub_generation++;
4595 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4597 #ifdef GV_SHARED_CHECK
4598 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4599 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4603 if (!block || !ps || *ps || attrs)
4606 const_sv = op_const_sv(block, Nullcv);
4609 bool exists = CvROOT(cv) || CvXSUB(cv);
4611 #ifdef GV_SHARED_CHECK
4612 if (exists && GvSHARED(gv)) {
4613 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4617 /* if the subroutine doesn't exist and wasn't pre-declared
4618 * with a prototype, assume it will be AUTOLOADed,
4619 * skipping the prototype check
4621 if (exists || SvPOK(cv))
4622 cv_ckproto(cv, gv, ps);
4623 /* already defined (or promised)? */
4624 if (exists || GvASSUMECV(gv)) {
4625 if (!block && !attrs) {
4626 /* just a "sub foo;" when &foo is already defined */
4627 SAVEFREESV(PL_compcv);
4630 /* ahem, death to those who redefine active sort subs */
4631 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4632 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4634 if (ckWARN(WARN_REDEFINE)
4636 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4638 line_t oldline = CopLINE(PL_curcop);
4639 CopLINE_set(PL_curcop, PL_copline);
4640 Perl_warner(aTHX_ WARN_REDEFINE,
4641 CvCONST(cv) ? "Constant subroutine %s redefined"
4642 : "Subroutine %s redefined", name);
4643 CopLINE_set(PL_curcop, oldline);
4651 SvREFCNT_inc(const_sv);
4653 assert(!CvROOT(cv) && !CvCONST(cv));
4654 sv_setpv((SV*)cv, ""); /* prototype is "" */
4655 CvXSUBANY(cv).any_ptr = const_sv;
4656 CvXSUB(cv) = const_sv_xsub;
4661 cv = newCONSTSUB(NULL, name, const_sv);
4664 SvREFCNT_dec(PL_compcv);
4666 PL_sub_generation++;
4673 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4674 * before we clobber PL_compcv.
4678 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4679 stash = GvSTASH(CvGV(cv));
4680 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4681 stash = CvSTASH(cv);
4683 stash = PL_curstash;
4686 /* possibly about to re-define existing subr -- ignore old cv */
4687 rcv = (SV*)PL_compcv;
4688 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4689 stash = GvSTASH(gv);
4691 stash = PL_curstash;
4693 apply_attrs(stash, rcv, attrs);
4695 if (cv) { /* must reuse cv if autoloaded */
4697 /* got here with just attrs -- work done, so bug out */
4698 SAVEFREESV(PL_compcv);
4702 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4703 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4704 CvOUTSIDE(PL_compcv) = 0;
4705 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4706 CvPADLIST(PL_compcv) = 0;
4707 /* inner references to PL_compcv must be fixed up ... */
4709 AV *padlist = CvPADLIST(cv);
4710 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4711 AV *comppad = (AV*)AvARRAY(padlist)[1];
4712 SV **namepad = AvARRAY(comppad_name);
4713 SV **curpad = AvARRAY(comppad);
4714 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4715 SV *namesv = namepad[ix];
4716 if (namesv && namesv != &PL_sv_undef
4717 && *SvPVX(namesv) == '&')
4719 CV *innercv = (CV*)curpad[ix];
4720 if (CvOUTSIDE(innercv) == PL_compcv) {
4721 CvOUTSIDE(innercv) = cv;
4722 if (!CvANON(innercv) || CvCLONED(innercv)) {
4723 (void)SvREFCNT_inc(cv);
4724 SvREFCNT_dec(PL_compcv);
4730 /* ... before we throw it away */
4731 SvREFCNT_dec(PL_compcv);
4738 PL_sub_generation++;
4742 CvFILE(cv) = CopFILE(PL_curcop);
4743 CvSTASH(cv) = PL_curstash;
4746 if (!CvMUTEXP(cv)) {
4747 New(666, CvMUTEXP(cv), 1, perl_mutex);
4748 MUTEX_INIT(CvMUTEXP(cv));
4750 #endif /* USE_THREADS */
4753 sv_setpv((SV*)cv, ps);
4755 if (PL_error_count) {
4759 char *s = strrchr(name, ':');
4761 if (strEQ(s, "BEGIN")) {
4763 "BEGIN not safe after errors--compilation aborted";
4764 if (PL_in_eval & EVAL_KEEPERR)
4765 Perl_croak(aTHX_ not_safe);
4767 /* force display of errors found but not reported */
4768 sv_catpv(ERRSV, not_safe);
4769 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4777 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4778 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4781 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4782 mod(scalarseq(block), OP_LEAVESUBLV));
4785 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4787 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4788 OpREFCNT_set(CvROOT(cv), 1);
4789 CvSTART(cv) = LINKLIST(CvROOT(cv));
4790 CvROOT(cv)->op_next = 0;
4793 /* now that optimizer has done its work, adjust pad values */
4795 SV **namep = AvARRAY(PL_comppad_name);
4796 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4799 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4802 * The only things that a clonable function needs in its
4803 * pad are references to outer lexicals and anonymous subs.
4804 * The rest are created anew during cloning.
4806 if (!((namesv = namep[ix]) != Nullsv &&
4807 namesv != &PL_sv_undef &&
4809 *SvPVX(namesv) == '&')))
4811 SvREFCNT_dec(PL_curpad[ix]);
4812 PL_curpad[ix] = Nullsv;
4815 assert(!CvCONST(cv));
4816 if (ps && !*ps && op_const_sv(block, cv))
4820 AV *av = newAV(); /* Will be @_ */
4822 av_store(PL_comppad, 0, (SV*)av);
4823 AvFLAGS(av) = AVf_REIFY;
4825 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4826 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4828 if (!SvPADMY(PL_curpad[ix]))
4829 SvPADTMP_on(PL_curpad[ix]);
4833 /* If a potential closure prototype, don't keep a refcount on outer CV.
4834 * This is okay as the lifetime of the prototype is tied to the
4835 * lifetime of the outer CV. Avoids memory leak due to reference
4838 SvREFCNT_dec(CvOUTSIDE(cv));
4840 if (name || aname) {
4842 char *tname = (name ? name : aname);
4844 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4845 SV *sv = NEWSV(0,0);
4846 SV *tmpstr = sv_newmortal();
4847 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4851 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4853 (long)PL_subline, (long)CopLINE(PL_curcop));
4854 gv_efullname3(tmpstr, gv, Nullch);
4855 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4856 hv = GvHVn(db_postponed);
4857 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4858 && (pcv = GvCV(db_postponed)))
4864 call_sv((SV*)pcv, G_DISCARD);
4868 if ((s = strrchr(tname,':')))
4873 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4876 if (strEQ(s, "BEGIN")) {
4877 I32 oldscope = PL_scopestack_ix;
4879 SAVECOPFILE(&PL_compiling);
4880 SAVECOPLINE(&PL_compiling);
4882 sv_setsv(PL_rs, PL_nrs);
4885 PL_beginav = newAV();
4886 DEBUG_x( dump_sub(gv) );
4887 av_push(PL_beginav, (SV*)cv);
4888 GvCV(gv) = 0; /* cv has been hijacked */
4889 call_list(oldscope, PL_beginav);
4891 PL_curcop = &PL_compiling;
4892 PL_compiling.op_private = PL_hints;
4895 else if (strEQ(s, "END") && !PL_error_count) {
4898 DEBUG_x( dump_sub(gv) );
4899 av_unshift(PL_endav, 1);
4900 av_store(PL_endav, 0, (SV*)cv);
4901 GvCV(gv) = 0; /* cv has been hijacked */
4903 else if (strEQ(s, "CHECK") && !PL_error_count) {
4905 PL_checkav = newAV();
4906 DEBUG_x( dump_sub(gv) );
4907 if (PL_main_start && ckWARN(WARN_VOID))
4908 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4909 av_unshift(PL_checkav, 1);
4910 av_store(PL_checkav, 0, (SV*)cv);
4911 GvCV(gv) = 0; /* cv has been hijacked */
4913 else if (strEQ(s, "INIT") && !PL_error_count) {
4915 PL_initav = newAV();
4916 DEBUG_x( dump_sub(gv) );
4917 if (PL_main_start && ckWARN(WARN_VOID))
4918 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4919 av_push(PL_initav, (SV*)cv);
4920 GvCV(gv) = 0; /* cv has been hijacked */
4925 PL_copline = NOLINE;
4930 /* XXX unsafe for threads if eval_owner isn't held */
4932 =for apidoc newCONSTSUB
4934 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4935 eligible for inlining at compile-time.
4941 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4947 SAVECOPLINE(PL_curcop);
4948 CopLINE_set(PL_curcop, PL_copline);
4951 PL_hints &= ~HINT_BLOCK_SCOPE;
4954 SAVESPTR(PL_curstash);
4955 SAVECOPSTASH(PL_curcop);
4956 PL_curstash = stash;
4958 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4960 CopSTASH(PL_curcop) = stash;
4964 cv = newXS(name, const_sv_xsub, __FILE__);
4965 CvXSUBANY(cv).any_ptr = sv;
4967 sv_setpv((SV*)cv, ""); /* prototype is "" */
4975 =for apidoc U||newXS
4977 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4983 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4985 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4988 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4990 /* just a cached method */
4994 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4995 /* already defined (or promised) */
4996 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4997 && HvNAME(GvSTASH(CvGV(cv)))
4998 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4999 line_t oldline = CopLINE(PL_curcop);
5000 if (PL_copline != NOLINE)
5001 CopLINE_set(PL_curcop, PL_copline);
5002 Perl_warner(aTHX_ WARN_REDEFINE,
5003 CvCONST(cv) ? "Constant subroutine %s redefined"
5004 : "Subroutine %s redefined"
5006 CopLINE_set(PL_curcop, oldline);
5013 if (cv) /* must reuse cv if autoloaded */
5016 cv = (CV*)NEWSV(1105,0);
5017 sv_upgrade((SV *)cv, SVt_PVCV);
5021 PL_sub_generation++;
5026 New(666, CvMUTEXP(cv), 1, perl_mutex);
5027 MUTEX_INIT(CvMUTEXP(cv));
5029 #endif /* USE_THREADS */
5030 (void)gv_fetchfile(filename);
5031 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5032 an external constant string */
5033 CvXSUB(cv) = subaddr;
5036 char *s = strrchr(name,':');
5042 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5045 if (strEQ(s, "BEGIN")) {
5047 PL_beginav = newAV();
5048 av_push(PL_beginav, (SV*)cv);
5049 GvCV(gv) = 0; /* cv has been hijacked */
5051 else if (strEQ(s, "END")) {
5054 av_unshift(PL_endav, 1);
5055 av_store(PL_endav, 0, (SV*)cv);
5056 GvCV(gv) = 0; /* cv has been hijacked */
5058 else if (strEQ(s, "CHECK")) {
5060 PL_checkav = newAV();
5061 if (PL_main_start && ckWARN(WARN_VOID))
5062 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5063 av_unshift(PL_checkav, 1);
5064 av_store(PL_checkav, 0, (SV*)cv);
5065 GvCV(gv) = 0; /* cv has been hijacked */
5067 else if (strEQ(s, "INIT")) {
5069 PL_initav = newAV();
5070 if (PL_main_start && ckWARN(WARN_VOID))
5071 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5072 av_push(PL_initav, (SV*)cv);
5073 GvCV(gv) = 0; /* cv has been hijacked */
5084 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5093 name = SvPVx(cSVOPo->op_sv, n_a);
5096 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5097 #ifdef GV_SHARED_CHECK
5099 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5103 if ((cv = GvFORM(gv))) {
5104 if (ckWARN(WARN_REDEFINE)) {
5105 line_t oldline = CopLINE(PL_curcop);
5107 CopLINE_set(PL_curcop, PL_copline);
5108 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5109 CopLINE_set(PL_curcop, oldline);
5116 CvFILE(cv) = CopFILE(PL_curcop);
5118 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5119 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5120 SvPADTMP_on(PL_curpad[ix]);
5123 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5124 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5125 OpREFCNT_set(CvROOT(cv), 1);
5126 CvSTART(cv) = LINKLIST(CvROOT(cv));
5127 CvROOT(cv)->op_next = 0;
5130 PL_copline = NOLINE;
5135 Perl_newANONLIST(pTHX_ OP *o)
5137 return newUNOP(OP_REFGEN, 0,
5138 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5142 Perl_newANONHASH(pTHX_ OP *o)
5144 return newUNOP(OP_REFGEN, 0,
5145 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5149 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5151 return newANONATTRSUB(floor, proto, Nullop, block);
5155 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5157 return newUNOP(OP_REFGEN, 0,
5158 newSVOP(OP_ANONCODE, 0,
5159 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5163 Perl_oopsAV(pTHX_ OP *o)
5165 switch (o->op_type) {
5167 o->op_type = OP_PADAV;
5168 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5169 return ref(o, OP_RV2AV);
5172 o->op_type = OP_RV2AV;
5173 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5178 if (ckWARN_d(WARN_INTERNAL))
5179 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5186 Perl_oopsHV(pTHX_ OP *o)
5188 switch (o->op_type) {
5191 o->op_type = OP_PADHV;
5192 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5193 return ref(o, OP_RV2HV);
5197 o->op_type = OP_RV2HV;
5198 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5203 if (ckWARN_d(WARN_INTERNAL))
5204 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5211 Perl_newAVREF(pTHX_ OP *o)
5213 if (o->op_type == OP_PADANY) {
5214 o->op_type = OP_PADAV;
5215 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5218 return newUNOP(OP_RV2AV, 0, scalar(o));
5222 Perl_newGVREF(pTHX_ I32 type, OP *o)
5224 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5225 return newUNOP(OP_NULL, 0, o);
5226 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5230 Perl_newHVREF(pTHX_ OP *o)
5232 if (o->op_type == OP_PADANY) {
5233 o->op_type = OP_PADHV;
5234 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5237 return newUNOP(OP_RV2HV, 0, scalar(o));
5241 Perl_oopsCV(pTHX_ OP *o)
5243 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5249 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5251 return newUNOP(OP_RV2CV, flags, scalar(o));
5255 Perl_newSVREF(pTHX_ OP *o)
5257 if (o->op_type == OP_PADANY) {
5258 o->op_type = OP_PADSV;
5259 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5262 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5263 o->op_flags |= OPpDONE_SVREF;
5266 return newUNOP(OP_RV2SV, 0, scalar(o));
5269 /* Check routines. */
5272 Perl_ck_anoncode(pTHX_ OP *o)
5277 name = NEWSV(1106,0);
5278 sv_upgrade(name, SVt_PVNV);
5279 sv_setpvn(name, "&", 1);
5282 ix = pad_alloc(o->op_type, SVs_PADMY);
5283 av_store(PL_comppad_name, ix, name);
5284 av_store(PL_comppad, ix, cSVOPo->op_sv);
5285 SvPADMY_on(cSVOPo->op_sv);
5286 cSVOPo->op_sv = Nullsv;
5287 cSVOPo->op_targ = ix;
5292 Perl_ck_bitop(pTHX_ OP *o)
5294 o->op_private = PL_hints;
5299 Perl_ck_concat(pTHX_ OP *o)
5301 if (cUNOPo->op_first->op_type == OP_CONCAT)
5302 o->op_flags |= OPf_STACKED;
5307 Perl_ck_spair(pTHX_ OP *o)
5309 if (o->op_flags & OPf_KIDS) {
5312 OPCODE type = o->op_type;
5313 o = modkids(ck_fun(o), type);
5314 kid = cUNOPo->op_first;
5315 newop = kUNOP->op_first->op_sibling;
5317 (newop->op_sibling ||
5318 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5319 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5320 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5324 op_free(kUNOP->op_first);
5325 kUNOP->op_first = newop;
5327 o->op_ppaddr = PL_ppaddr[++o->op_type];
5332 Perl_ck_delete(pTHX_ OP *o)
5336 if (o->op_flags & OPf_KIDS) {
5337 OP *kid = cUNOPo->op_first;
5338 switch (kid->op_type) {
5340 o->op_flags |= OPf_SPECIAL;
5343 o->op_private |= OPpSLICE;
5346 o->op_flags |= OPf_SPECIAL;
5351 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5352 PL_op_desc[o->op_type]);
5360 Perl_ck_eof(pTHX_ OP *o)
5362 I32 type = o->op_type;
5364 if (o->op_flags & OPf_KIDS) {
5365 if (cLISTOPo->op_first->op_type == OP_STUB) {
5367 o = newUNOP(type, OPf_SPECIAL,
5368 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5376 Perl_ck_eval(pTHX_ OP *o)
5378 PL_hints |= HINT_BLOCK_SCOPE;
5379 if (o->op_flags & OPf_KIDS) {
5380 SVOP *kid = (SVOP*)cUNOPo->op_first;
5383 o->op_flags &= ~OPf_KIDS;
5386 else if (kid->op_type == OP_LINESEQ) {
5389 kid->op_next = o->op_next;
5390 cUNOPo->op_first = 0;
5393 NewOp(1101, enter, 1, LOGOP);
5394 enter->op_type = OP_ENTERTRY;
5395 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5396 enter->op_private = 0;
5398 /* establish postfix order */
5399 enter->op_next = (OP*)enter;
5401 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5402 o->op_type = OP_LEAVETRY;
5403 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5404 enter->op_other = o;
5412 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5414 o->op_targ = (PADOFFSET)PL_hints;
5419 Perl_ck_exit(pTHX_ OP *o)
5422 HV *table = GvHV(PL_hintgv);
5424 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5425 if (svp && *svp && SvTRUE(*svp))
5426 o->op_private |= OPpEXIT_VMSISH;
5433 Perl_ck_exec(pTHX_ OP *o)
5436 if (o->op_flags & OPf_STACKED) {
5438 kid = cUNOPo->op_first->op_sibling;
5439 if (kid->op_type == OP_RV2GV)
5448 Perl_ck_exists(pTHX_ OP *o)
5451 if (o->op_flags & OPf_KIDS) {
5452 OP *kid = cUNOPo->op_first;
5453 if (kid->op_type == OP_ENTERSUB) {
5454 (void) ref(kid, o->op_type);
5455 if (kid->op_type != OP_RV2CV && !PL_error_count)
5456 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5457 PL_op_desc[o->op_type]);
5458 o->op_private |= OPpEXISTS_SUB;
5460 else if (kid->op_type == OP_AELEM)
5461 o->op_flags |= OPf_SPECIAL;
5462 else if (kid->op_type != OP_HELEM)
5463 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5464 PL_op_desc[o->op_type]);
5472 Perl_ck_gvconst(pTHX_ register OP *o)
5474 o = fold_constants(o);
5475 if (o->op_type == OP_CONST)
5482 Perl_ck_rvconst(pTHX_ register OP *o)
5484 SVOP *kid = (SVOP*)cUNOPo->op_first;
5486 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5487 if (kid->op_type == OP_CONST) {
5491 SV *kidsv = kid->op_sv;
5494 /* Is it a constant from cv_const_sv()? */
5495 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5496 SV *rsv = SvRV(kidsv);
5497 int svtype = SvTYPE(rsv);
5498 char *badtype = Nullch;
5500 switch (o->op_type) {
5502 if (svtype > SVt_PVMG)
5503 badtype = "a SCALAR";
5506 if (svtype != SVt_PVAV)
5507 badtype = "an ARRAY";
5510 if (svtype != SVt_PVHV) {
5511 if (svtype == SVt_PVAV) { /* pseudohash? */
5512 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5513 if (ksv && SvROK(*ksv)
5514 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5523 if (svtype != SVt_PVCV)
5528 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5531 name = SvPV(kidsv, n_a);
5532 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5533 char *badthing = Nullch;
5534 switch (o->op_type) {
5536 badthing = "a SCALAR";
5539 badthing = "an ARRAY";
5542 badthing = "a HASH";
5547 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5551 * This is a little tricky. We only want to add the symbol if we
5552 * didn't add it in the lexer. Otherwise we get duplicate strict
5553 * warnings. But if we didn't add it in the lexer, we must at
5554 * least pretend like we wanted to add it even if it existed before,
5555 * or we get possible typo warnings. OPpCONST_ENTERED says
5556 * whether the lexer already added THIS instance of this symbol.
5558 iscv = (o->op_type == OP_RV2CV) * 2;
5560 gv = gv_fetchpv(name,
5561 iscv | !(kid->op_private & OPpCONST_ENTERED),
5564 : o->op_type == OP_RV2SV
5566 : o->op_type == OP_RV2AV
5568 : o->op_type == OP_RV2HV
5571 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5573 kid->op_type = OP_GV;
5574 SvREFCNT_dec(kid->op_sv);
5576 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5577 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5578 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5580 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5582 kid->op_sv = SvREFCNT_inc(gv);
5584 kid->op_private = 0;
5585 kid->op_ppaddr = PL_ppaddr[OP_GV];
5592 Perl_ck_ftst(pTHX_ OP *o)
5594 I32 type = o->op_type;
5596 if (o->op_flags & OPf_REF) {
5599 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5600 SVOP *kid = (SVOP*)cUNOPo->op_first;
5602 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5604 OP *newop = newGVOP(type, OPf_REF,
5605 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5612 if (type == OP_FTTTY)
5613 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5616 o = newUNOP(type, 0, newDEFSVOP());
5619 if (type == OP_FTTEXT || type == OP_FTBINARY) {
5621 if (PL_hints & HINT_LOCALE)
5622 o->op_private |= OPpLOCALE;
5629 Perl_ck_fun(pTHX_ OP *o)
5635 int type = o->op_type;
5636 register I32 oa = PL_opargs[type] >> OASHIFT;
5638 if (o->op_flags & OPf_STACKED) {
5639 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5642 return no_fh_allowed(o);
5645 if (o->op_flags & OPf_KIDS) {
5647 tokid = &cLISTOPo->op_first;
5648 kid = cLISTOPo->op_first;
5649 if (kid->op_type == OP_PUSHMARK ||
5650 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5652 tokid = &kid->op_sibling;
5653 kid = kid->op_sibling;
5655 if (!kid && PL_opargs[type] & OA_DEFGV)
5656 *tokid = kid = newDEFSVOP();
5660 sibl = kid->op_sibling;
5663 /* list seen where single (scalar) arg expected? */
5664 if (numargs == 1 && !(oa >> 4)
5665 && kid->op_type == OP_LIST && type != OP_SCALAR)
5667 return too_many_arguments(o,PL_op_desc[type]);
5680 if (kid->op_type == OP_CONST &&
5681 (kid->op_private & OPpCONST_BARE))
5683 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5684 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5685 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5686 if (ckWARN(WARN_DEPRECATED))
5687 Perl_warner(aTHX_ WARN_DEPRECATED,
5688 "Array @%s missing the @ in argument %"IVdf" of %s()",
5689 name, (IV)numargs, PL_op_desc[type]);
5692 kid->op_sibling = sibl;
5695 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5696 bad_type(numargs, "array", PL_op_desc[type], kid);
5700 if (kid->op_type == OP_CONST &&
5701 (kid->op_private & OPpCONST_BARE))
5703 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5704 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5705 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5706 if (ckWARN(WARN_DEPRECATED))
5707 Perl_warner(aTHX_ WARN_DEPRECATED,
5708 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5709 name, (IV)numargs, PL_op_desc[type]);
5712 kid->op_sibling = sibl;
5715 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5716 bad_type(numargs, "hash", PL_op_desc[type], kid);
5721 OP *newop = newUNOP(OP_NULL, 0, kid);
5722 kid->op_sibling = 0;
5724 newop->op_next = newop;
5726 kid->op_sibling = sibl;
5731 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5732 if (kid->op_type == OP_CONST &&
5733 (kid->op_private & OPpCONST_BARE))
5735 OP *newop = newGVOP(OP_GV, 0,
5736 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5741 else if (kid->op_type == OP_READLINE) {
5742 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5743 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5746 I32 flags = OPf_SPECIAL;
5750 /* is this op a FH constructor? */
5751 if (is_handle_constructor(o,numargs)) {
5752 char *name = Nullch;
5756 /* Set a flag to tell rv2gv to vivify
5757 * need to "prove" flag does not mean something
5758 * else already - NI-S 1999/05/07
5761 if (kid->op_type == OP_PADSV) {
5762 SV **namep = av_fetch(PL_comppad_name,
5764 if (namep && *namep)
5765 name = SvPV(*namep, len);
5767 else if (kid->op_type == OP_RV2SV
5768 && kUNOP->op_first->op_type == OP_GV)
5770 GV *gv = cGVOPx_gv(kUNOP->op_first);
5772 len = GvNAMELEN(gv);
5774 else if (kid->op_type == OP_AELEM
5775 || kid->op_type == OP_HELEM)
5777 name = "__ANONIO__";
5783 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5784 namesv = PL_curpad[targ];
5785 (void)SvUPGRADE(namesv, SVt_PV);
5787 sv_setpvn(namesv, "$", 1);
5788 sv_catpvn(namesv, name, len);
5791 kid->op_sibling = 0;
5792 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5793 kid->op_targ = targ;
5794 kid->op_private |= priv;
5796 kid->op_sibling = sibl;
5802 mod(scalar(kid), type);
5806 tokid = &kid->op_sibling;
5807 kid = kid->op_sibling;
5809 o->op_private |= numargs;
5811 return too_many_arguments(o,PL_op_desc[o->op_type]);
5814 else if (PL_opargs[type] & OA_DEFGV) {
5816 return newUNOP(type, 0, newDEFSVOP());
5820 while (oa & OA_OPTIONAL)
5822 if (oa && oa != OA_LIST)
5823 return too_few_arguments(o,PL_op_desc[o->op_type]);
5829 Perl_ck_glob(pTHX_ OP *o)
5834 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5835 append_elem(OP_GLOB, o, newDEFSVOP());
5837 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5838 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5840 #if !defined(PERL_EXTERNAL_GLOB)
5841 /* XXX this can be tightened up and made more failsafe. */
5844 Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5845 /* null-terminated import list */
5846 newSVpvn(":globally", 9), Nullsv);
5847 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5850 #endif /* PERL_EXTERNAL_GLOB */
5852 if (gv && GvIMPORTED_CV(gv)) {
5853 append_elem(OP_GLOB, o,
5854 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5855 o->op_type = OP_LIST;
5856 o->op_ppaddr = PL_ppaddr[OP_LIST];
5857 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5858 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5859 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5860 append_elem(OP_LIST, o,
5861 scalar(newUNOP(OP_RV2CV, 0,
5862 newGVOP(OP_GV, 0, gv)))));
5863 o = newUNOP(OP_NULL, 0, ck_subr(o));
5864 o->op_targ = OP_GLOB; /* hint at what it used to be */
5867 gv = newGVgen("main");
5869 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5875 Perl_ck_grep(pTHX_ OP *o)
5879 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5881 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5882 NewOp(1101, gwop, 1, LOGOP);
5884 if (o->op_flags & OPf_STACKED) {
5887 kid = cLISTOPo->op_first->op_sibling;
5888 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5891 kid->op_next = (OP*)gwop;
5892 o->op_flags &= ~OPf_STACKED;
5894 kid = cLISTOPo->op_first->op_sibling;
5895 if (type == OP_MAPWHILE)
5902 kid = cLISTOPo->op_first->op_sibling;
5903 if (kid->op_type != OP_NULL)
5904 Perl_croak(aTHX_ "panic: ck_grep");
5905 kid = kUNOP->op_first;
5907 gwop->op_type = type;
5908 gwop->op_ppaddr = PL_ppaddr[type];
5909 gwop->op_first = listkids(o);
5910 gwop->op_flags |= OPf_KIDS;
5911 gwop->op_private = 1;
5912 gwop->op_other = LINKLIST(kid);
5913 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5914 kid->op_next = (OP*)gwop;
5916 kid = cLISTOPo->op_first->op_sibling;
5917 if (!kid || !kid->op_sibling)
5918 return too_few_arguments(o,PL_op_desc[o->op_type]);
5919 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5920 mod(kid, OP_GREPSTART);
5926 Perl_ck_index(pTHX_ OP *o)
5928 if (o->op_flags & OPf_KIDS) {
5929 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5931 kid = kid->op_sibling; /* get past "big" */
5932 if (kid && kid->op_type == OP_CONST)
5933 fbm_compile(((SVOP*)kid)->op_sv, 0);
5939 Perl_ck_lengthconst(pTHX_ OP *o)
5941 /* XXX length optimization goes here */
5946 Perl_ck_lfun(pTHX_ OP *o)
5948 OPCODE type = o->op_type;
5949 return modkids(ck_fun(o), type);
5953 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5955 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5956 switch (cUNOPo->op_first->op_type) {
5958 /* This is needed for
5959 if (defined %stash::)
5960 to work. Do not break Tk.
5962 break; /* Globals via GV can be undef */
5964 case OP_AASSIGN: /* Is this a good idea? */
5965 Perl_warner(aTHX_ WARN_DEPRECATED,
5966 "defined(@array) is deprecated");
5967 Perl_warner(aTHX_ WARN_DEPRECATED,
5968 "\t(Maybe you should just omit the defined()?)\n");
5971 /* This is needed for
5972 if (defined %stash::)
5973 to work. Do not break Tk.
5975 break; /* Globals via GV can be undef */
5977 Perl_warner(aTHX_ WARN_DEPRECATED,
5978 "defined(%%hash) is deprecated");
5979 Perl_warner(aTHX_ WARN_DEPRECATED,
5980 "\t(Maybe you should just omit the defined()?)\n");
5991 Perl_ck_rfun(pTHX_ OP *o)
5993 OPCODE type = o->op_type;
5994 return refkids(ck_fun(o), type);
5998 Perl_ck_listiob(pTHX_ OP *o)
6002 kid = cLISTOPo->op_first;
6005 kid = cLISTOPo->op_first;
6007 if (kid->op_type == OP_PUSHMARK)
6008 kid = kid->op_sibling;
6009 if (kid && o->op_flags & OPf_STACKED)
6010 kid = kid->op_sibling;
6011 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6012 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6013 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6014 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6015 cLISTOPo->op_first->op_sibling = kid;
6016 cLISTOPo->op_last = kid;
6017 kid = kid->op_sibling;
6022 append_elem(o->op_type, o, newDEFSVOP());
6028 if (PL_hints & HINT_LOCALE)
6029 o->op_private |= OPpLOCALE;
6036 Perl_ck_fun_locale(pTHX_ OP *o)
6042 if (PL_hints & HINT_LOCALE)
6043 o->op_private |= OPpLOCALE;
6050 Perl_ck_sassign(pTHX_ OP *o)
6052 OP *kid = cLISTOPo->op_first;
6053 /* has a disposable target? */
6054 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6055 && !(kid->op_flags & OPf_STACKED)
6056 /* Cannot steal the second time! */
6057 && !(kid->op_private & OPpTARGET_MY))
6059 OP *kkid = kid->op_sibling;
6061 /* Can just relocate the target. */
6062 if (kkid && kkid->op_type == OP_PADSV
6063 && !(kkid->op_private & OPpLVAL_INTRO))
6065 kid->op_targ = kkid->op_targ;
6067 /* Now we do not need PADSV and SASSIGN. */
6068 kid->op_sibling = o->op_sibling; /* NULL */
6069 cLISTOPo->op_first = NULL;
6072 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6080 Perl_ck_scmp(pTHX_ OP *o)
6084 if (PL_hints & HINT_LOCALE)
6085 o->op_private |= OPpLOCALE;
6092 Perl_ck_match(pTHX_ OP *o)
6094 o->op_private |= OPpRUNTIME;
6099 Perl_ck_method(pTHX_ OP *o)
6101 OP *kid = cUNOPo->op_first;
6102 if (kid->op_type == OP_CONST) {
6103 SV* sv = kSVOP->op_sv;
6104 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6106 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6107 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6110 kSVOP->op_sv = Nullsv;
6112 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6121 Perl_ck_null(pTHX_ OP *o)
6127 Perl_ck_open(pTHX_ OP *o)
6129 HV *table = GvHV(PL_hintgv);
6133 svp = hv_fetch(table, "open_IN", 7, FALSE);
6135 mode = mode_from_discipline(*svp);
6136 if (mode & O_BINARY)
6137 o->op_private |= OPpOPEN_IN_RAW;
6138 else if (mode & O_TEXT)
6139 o->op_private |= OPpOPEN_IN_CRLF;
6142 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6144 mode = mode_from_discipline(*svp);
6145 if (mode & O_BINARY)
6146 o->op_private |= OPpOPEN_OUT_RAW;
6147 else if (mode & O_TEXT)
6148 o->op_private |= OPpOPEN_OUT_CRLF;
6151 if (o->op_type == OP_BACKTICK)
6157 Perl_ck_repeat(pTHX_ OP *o)
6159 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6160 o->op_private |= OPpREPEAT_DOLIST;
6161 cBINOPo->op_first = force_list(cBINOPo->op_first);
6169 Perl_ck_require(pTHX_ OP *o)
6171 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6172 SVOP *kid = (SVOP*)cUNOPo->op_first;
6174 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6176 for (s = SvPVX(kid->op_sv); *s; s++) {
6177 if (*s == ':' && s[1] == ':') {
6179 Move(s+2, s+1, strlen(s+2)+1, char);
6180 --SvCUR(kid->op_sv);
6183 if (SvREADONLY(kid->op_sv)) {
6184 SvREADONLY_off(kid->op_sv);
6185 sv_catpvn(kid->op_sv, ".pm", 3);
6186 SvREADONLY_on(kid->op_sv);
6189 sv_catpvn(kid->op_sv, ".pm", 3);
6196 Perl_ck_return(pTHX_ OP *o)
6199 if (CvLVALUE(PL_compcv)) {
6200 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6201 mod(kid, OP_LEAVESUBLV);
6208 Perl_ck_retarget(pTHX_ OP *o)
6210 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6217 Perl_ck_select(pTHX_ OP *o)
6220 if (o->op_flags & OPf_KIDS) {
6221 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6222 if (kid && kid->op_sibling) {
6223 o->op_type = OP_SSELECT;
6224 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6226 return fold_constants(o);
6230 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6231 if (kid && kid->op_type == OP_RV2GV)
6232 kid->op_private &= ~HINT_STRICT_REFS;
6237 Perl_ck_shift(pTHX_ OP *o)
6239 I32 type = o->op_type;
6241 if (!(o->op_flags & OPf_KIDS)) {
6246 if (!CvUNIQUE(PL_compcv)) {
6247 argop = newOP(OP_PADAV, OPf_REF);
6248 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6251 argop = newUNOP(OP_RV2AV, 0,
6252 scalar(newGVOP(OP_GV, 0,
6253 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6256 argop = newUNOP(OP_RV2AV, 0,
6257 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6258 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6259 #endif /* USE_THREADS */
6260 return newUNOP(type, 0, scalar(argop));
6262 return scalar(modkids(ck_fun(o), type));
6266 Perl_ck_sort(pTHX_ OP *o)
6271 if (PL_hints & HINT_LOCALE)
6272 o->op_private |= OPpLOCALE;
6275 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6277 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6278 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6280 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6282 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6284 if (kid->op_type == OP_SCOPE) {
6288 else if (kid->op_type == OP_LEAVE) {
6289 if (o->op_type == OP_SORT) {
6290 null(kid); /* wipe out leave */
6293 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6294 if (k->op_next == kid)
6296 /* don't descend into loops */
6297 else if (k->op_type == OP_ENTERLOOP
6298 || k->op_type == OP_ENTERITER)
6300 k = cLOOPx(k)->op_lastop;
6305 kid->op_next = 0; /* just disconnect the leave */
6306 k = kLISTOP->op_first;
6311 if (o->op_type == OP_SORT) {
6312 /* provide scalar context for comparison function/block */
6318 o->op_flags |= OPf_SPECIAL;
6320 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6323 firstkid = firstkid->op_sibling;
6326 /* provide list context for arguments */
6327 if (o->op_type == OP_SORT)
6334 S_simplify_sort(pTHX_ OP *o)
6336 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6340 if (!(o->op_flags & OPf_STACKED))
6342 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6343 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6344 kid = kUNOP->op_first; /* get past null */
6345 if (kid->op_type != OP_SCOPE)
6347 kid = kLISTOP->op_last; /* get past scope */
6348 switch(kid->op_type) {
6356 k = kid; /* remember this node*/
6357 if (kBINOP->op_first->op_type != OP_RV2SV)
6359 kid = kBINOP->op_first; /* get past cmp */
6360 if (kUNOP->op_first->op_type != OP_GV)
6362 kid = kUNOP->op_first; /* get past rv2sv */
6364 if (GvSTASH(gv) != PL_curstash)
6366 if (strEQ(GvNAME(gv), "a"))
6368 else if (strEQ(GvNAME(gv), "b"))
6372 kid = k; /* back to cmp */
6373 if (kBINOP->op_last->op_type != OP_RV2SV)
6375 kid = kBINOP->op_last; /* down to 2nd arg */
6376 if (kUNOP->op_first->op_type != OP_GV)
6378 kid = kUNOP->op_first; /* get past rv2sv */
6380 if (GvSTASH(gv) != PL_curstash
6382 ? strNE(GvNAME(gv), "a")
6383 : strNE(GvNAME(gv), "b")))
6385 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6387 o->op_private |= OPpSORT_REVERSE;
6388 if (k->op_type == OP_NCMP)
6389 o->op_private |= OPpSORT_NUMERIC;
6390 if (k->op_type == OP_I_NCMP)
6391 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6392 kid = cLISTOPo->op_first->op_sibling;
6393 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6394 op_free(kid); /* then delete it */
6398 Perl_ck_split(pTHX_ OP *o)
6402 if (o->op_flags & OPf_STACKED)
6403 return no_fh_allowed(o);
6405 kid = cLISTOPo->op_first;
6406 if (kid->op_type != OP_NULL)
6407 Perl_croak(aTHX_ "panic: ck_split");
6408 kid = kid->op_sibling;
6409 op_free(cLISTOPo->op_first);
6410 cLISTOPo->op_first = kid;
6412 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6413 cLISTOPo->op_last = kid; /* There was only one element previously */
6416 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6417 OP *sibl = kid->op_sibling;
6418 kid->op_sibling = 0;
6419 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6420 if (cLISTOPo->op_first == cLISTOPo->op_last)
6421 cLISTOPo->op_last = kid;
6422 cLISTOPo->op_first = kid;
6423 kid->op_sibling = sibl;
6426 kid->op_type = OP_PUSHRE;
6427 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6430 if (!kid->op_sibling)
6431 append_elem(OP_SPLIT, o, newDEFSVOP());
6433 kid = kid->op_sibling;
6436 if (!kid->op_sibling)
6437 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6439 kid = kid->op_sibling;
6442 if (kid->op_sibling)
6443 return too_many_arguments(o,PL_op_desc[o->op_type]);
6449 Perl_ck_join(pTHX_ OP *o)
6451 if (ckWARN(WARN_SYNTAX)) {
6452 OP *kid = cLISTOPo->op_first->op_sibling;
6453 if (kid && kid->op_type == OP_MATCH) {
6454 char *pmstr = "STRING";
6455 if (kPMOP->op_pmregexp)
6456 pmstr = kPMOP->op_pmregexp->precomp;
6457 Perl_warner(aTHX_ WARN_SYNTAX,
6458 "/%s/ should probably be written as \"%s\"",
6466 Perl_ck_subr(pTHX_ OP *o)
6468 OP *prev = ((cUNOPo->op_first->op_sibling)
6469 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6470 OP *o2 = prev->op_sibling;
6479 o->op_private |= OPpENTERSUB_HASTARG;
6480 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6481 if (cvop->op_type == OP_RV2CV) {
6483 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6484 null(cvop); /* disable rv2cv */
6485 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6486 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6487 GV *gv = cGVOPx_gv(tmpop);
6490 tmpop->op_private |= OPpEARLY_CV;
6491 else if (SvPOK(cv)) {
6492 namegv = CvANON(cv) ? gv : CvGV(cv);
6493 proto = SvPV((SV*)cv, n_a);
6497 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6498 if (o2->op_type == OP_CONST)
6499 o2->op_private &= ~OPpCONST_STRICT;
6500 else if (o2->op_type == OP_LIST) {
6501 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6502 if (o && o->op_type == OP_CONST)
6503 o->op_private &= ~OPpCONST_STRICT;
6506 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6507 if (PERLDB_SUB && PL_curstash != PL_debstash)
6508 o->op_private |= OPpENTERSUB_DB;
6509 while (o2 != cvop) {
6513 return too_many_arguments(o, gv_ename(namegv));
6531 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6533 arg == 1 ? "block or sub {}" : "sub {}",
6534 gv_ename(namegv), o2);
6537 /* '*' allows any scalar type, including bareword */
6540 if (o2->op_type == OP_RV2GV)
6541 goto wrapref; /* autoconvert GLOB -> GLOBref */
6542 else if (o2->op_type == OP_CONST)
6543 o2->op_private &= ~OPpCONST_STRICT;
6544 else if (o2->op_type == OP_ENTERSUB) {
6545 /* accidental subroutine, revert to bareword */
6546 OP *gvop = ((UNOP*)o2)->op_first;
6547 if (gvop && gvop->op_type == OP_NULL) {
6548 gvop = ((UNOP*)gvop)->op_first;
6550 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6553 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6554 (gvop = ((UNOP*)gvop)->op_first) &&
6555 gvop->op_type == OP_GV)
6557 GV *gv = cGVOPx_gv(gvop);
6558 OP *sibling = o2->op_sibling;
6559 SV *n = newSVpvn("",0);
6561 gv_fullname3(n, gv, "");
6562 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6563 sv_chop(n, SvPVX(n)+6);
6564 o2 = newSVOP(OP_CONST, 0, n);
6565 prev->op_sibling = o2;
6566 o2->op_sibling = sibling;
6578 if (o2->op_type != OP_RV2GV)
6579 bad_type(arg, "symbol", gv_ename(namegv), o2);
6582 if (o2->op_type != OP_ENTERSUB)
6583 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6586 if (o2->op_type != OP_RV2SV
6587 && o2->op_type != OP_PADSV
6588 && o2->op_type != OP_HELEM
6589 && o2->op_type != OP_AELEM
6590 && o2->op_type != OP_THREADSV)
6592 bad_type(arg, "scalar", gv_ename(namegv), o2);
6596 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6597 bad_type(arg, "array", gv_ename(namegv), o2);
6600 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6601 bad_type(arg, "hash", gv_ename(namegv), o2);
6605 OP* sib = kid->op_sibling;
6606 kid->op_sibling = 0;
6607 o2 = newUNOP(OP_REFGEN, 0, kid);
6608 o2->op_sibling = sib;
6609 prev->op_sibling = o2;
6620 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6621 gv_ename(namegv), SvPV((SV*)cv, n_a));
6626 mod(o2, OP_ENTERSUB);
6628 o2 = o2->op_sibling;
6630 if (proto && !optional &&
6631 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6632 return too_few_arguments(o, gv_ename(namegv));
6637 Perl_ck_svconst(pTHX_ OP *o)
6639 SvREADONLY_on(cSVOPo->op_sv);
6644 Perl_ck_trunc(pTHX_ OP *o)
6646 if (o->op_flags & OPf_KIDS) {
6647 SVOP *kid = (SVOP*)cUNOPo->op_first;
6649 if (kid->op_type == OP_NULL)
6650 kid = (SVOP*)kid->op_sibling;
6651 if (kid && kid->op_type == OP_CONST &&
6652 (kid->op_private & OPpCONST_BARE))
6654 o->op_flags |= OPf_SPECIAL;
6655 kid->op_private &= ~OPpCONST_STRICT;
6662 Perl_ck_substr(pTHX_ OP *o)
6665 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6666 OP *kid = cLISTOPo->op_first;
6668 if (kid->op_type == OP_NULL)
6669 kid = kid->op_sibling;
6671 kid->op_flags |= OPf_MOD;
6677 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6680 Perl_peep(pTHX_ register OP *o)
6682 register OP* oldop = 0;
6685 if (!o || o->op_seq)
6689 SAVEVPTR(PL_curcop);
6690 for (; o; o = o->op_next) {
6696 switch (o->op_type) {
6700 PL_curcop = ((COP*)o); /* for warnings */
6701 o->op_seq = PL_op_seqmax++;
6705 if (cSVOPo->op_private & OPpCONST_STRICT)
6706 no_bareword_allowed(o);
6708 /* Relocate sv to the pad for thread safety.
6709 * Despite being a "constant", the SV is written to,
6710 * for reference counts, sv_upgrade() etc. */
6712 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6713 if (SvPADTMP(cSVOPo->op_sv)) {
6714 /* If op_sv is already a PADTMP then it is being used by
6715 * some pad, so make a copy. */
6716 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6717 SvREADONLY_on(PL_curpad[ix]);
6718 SvREFCNT_dec(cSVOPo->op_sv);
6721 SvREFCNT_dec(PL_curpad[ix]);
6722 SvPADTMP_on(cSVOPo->op_sv);
6723 PL_curpad[ix] = cSVOPo->op_sv;
6724 /* XXX I don't know how this isn't readonly already. */
6725 SvREADONLY_on(PL_curpad[ix]);
6727 cSVOPo->op_sv = Nullsv;
6731 o->op_seq = PL_op_seqmax++;
6735 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6736 if (o->op_next->op_private & OPpTARGET_MY) {
6737 if (o->op_flags & OPf_STACKED) /* chained concats */
6738 goto ignore_optimization;
6740 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6741 o->op_targ = o->op_next->op_targ;
6742 o->op_next->op_targ = 0;
6743 o->op_private |= OPpTARGET_MY;
6748 ignore_optimization:
6749 o->op_seq = PL_op_seqmax++;
6752 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6753 o->op_seq = PL_op_seqmax++;
6754 break; /* Scalar stub must produce undef. List stub is noop */
6758 if (o->op_targ == OP_NEXTSTATE
6759 || o->op_targ == OP_DBSTATE
6760 || o->op_targ == OP_SETSTATE)
6762 PL_curcop = ((COP*)o);
6769 if (oldop && o->op_next) {
6770 oldop->op_next = o->op_next;
6773 o->op_seq = PL_op_seqmax++;
6777 if (o->op_next->op_type == OP_RV2SV) {
6778 if (!(o->op_next->op_private & OPpDEREF)) {
6780 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6782 o->op_next = o->op_next->op_next;
6783 o->op_type = OP_GVSV;
6784 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6787 else if (o->op_next->op_type == OP_RV2AV) {
6788 OP* pop = o->op_next->op_next;
6790 if (pop->op_type == OP_CONST &&
6791 (PL_op = pop->op_next) &&
6792 pop->op_next->op_type == OP_AELEM &&
6793 !(pop->op_next->op_private &
6794 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6795 (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6803 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6804 o->op_next = pop->op_next->op_next;
6805 o->op_type = OP_AELEMFAST;
6806 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6807 o->op_private = (U8)i;
6812 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6814 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6815 /* XXX could check prototype here instead of just carping */
6816 SV *sv = sv_newmortal();
6817 gv_efullname3(sv, gv, Nullch);
6818 Perl_warner(aTHX_ WARN_PROTOTYPE,
6819 "%s() called too early to check prototype",
6824 o->op_seq = PL_op_seqmax++;
6835 o->op_seq = PL_op_seqmax++;
6836 while (cLOGOP->op_other->op_type == OP_NULL)
6837 cLOGOP->op_other = cLOGOP->op_other->op_next;
6838 peep(cLOGOP->op_other);
6842 o->op_seq = PL_op_seqmax++;
6843 while (cLOOP->op_redoop->op_type == OP_NULL)
6844 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6845 peep(cLOOP->op_redoop);
6846 while (cLOOP->op_nextop->op_type == OP_NULL)
6847 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6848 peep(cLOOP->op_nextop);
6849 while (cLOOP->op_lastop->op_type == OP_NULL)
6850 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6851 peep(cLOOP->op_lastop);
6857 o->op_seq = PL_op_seqmax++;
6858 while (cPMOP->op_pmreplstart &&
6859 cPMOP->op_pmreplstart->op_type == OP_NULL)
6860 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6861 peep(cPMOP->op_pmreplstart);
6865 o->op_seq = PL_op_seqmax++;
6866 if (ckWARN(WARN_SYNTAX) && o->op_next
6867 && o->op_next->op_type == OP_NEXTSTATE) {
6868 if (o->op_next->op_sibling &&
6869 o->op_next->op_sibling->op_type != OP_EXIT &&
6870 o->op_next->op_sibling->op_type != OP_WARN &&
6871 o->op_next->op_sibling->op_type != OP_DIE) {
6872 line_t oldline = CopLINE(PL_curcop);
6874 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6875 Perl_warner(aTHX_ WARN_EXEC,
6876 "Statement unlikely to be reached");
6877 Perl_warner(aTHX_ WARN_EXEC,
6878 "\t(Maybe you meant system() when you said exec()?)\n");
6879 CopLINE_set(PL_curcop, oldline);
6888 SV **svp, **indsvp, *sv;
6893 o->op_seq = PL_op_seqmax++;
6895 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6898 /* Make the CONST have a shared SV */
6899 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6900 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6901 key = SvPV(sv, keylen);
6904 lexname = newSVpvn_share(key, keylen, 0);
6909 if ((o->op_private & (OPpLVAL_INTRO)))
6912 rop = (UNOP*)((BINOP*)o)->op_first;
6913 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6915 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6916 if (!SvOBJECT(lexname))
6918 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6919 if (!fields || !GvHV(*fields))
6921 key = SvPV(*svp, keylen);
6924 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6926 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6927 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6929 ind = SvIV(*indsvp);
6931 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6932 rop->op_type = OP_RV2AV;
6933 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6934 o->op_type = OP_AELEM;
6935 o->op_ppaddr = PL_ppaddr[OP_AELEM];
6937 if (SvREADONLY(*svp))
6939 SvFLAGS(sv) |= (SvFLAGS(*svp)
6940 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6950 SV **svp, **indsvp, *sv;
6954 SVOP *first_key_op, *key_op;
6956 o->op_seq = PL_op_seqmax++;
6957 if ((o->op_private & (OPpLVAL_INTRO))
6958 /* I bet there's always a pushmark... */
6959 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6960 /* hmmm, no optimization if list contains only one key. */
6962 rop = (UNOP*)((LISTOP*)o)->op_last;
6963 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6965 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6966 if (!SvOBJECT(lexname))
6968 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6969 if (!fields || !GvHV(*fields))
6971 /* Again guessing that the pushmark can be jumped over.... */
6972 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6973 ->op_first->op_sibling;
6974 /* Check that the key list contains only constants. */
6975 for (key_op = first_key_op; key_op;
6976 key_op = (SVOP*)key_op->op_sibling)
6977 if (key_op->op_type != OP_CONST)
6981 rop->op_type = OP_RV2AV;
6982 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6983 o->op_type = OP_ASLICE;
6984 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6985 for (key_op = first_key_op; key_op;
6986 key_op = (SVOP*)key_op->op_sibling) {
6987 svp = cSVOPx_svp(key_op);
6988 key = SvPV(*svp, keylen);
6991 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6993 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6994 "in variable %s of type %s",
6995 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6997 ind = SvIV(*indsvp);
6999 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7001 if (SvREADONLY(*svp))
7003 SvFLAGS(sv) |= (SvFLAGS(*svp)
7004 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7012 o->op_seq = PL_op_seqmax++;
7022 /* Efficient sub that returns a constant scalar value. */
7024 const_sv_xsub(pTHXo_ CV* cv)
7029 Perl_croak(aTHX_ "usage: %s::%s()",
7030 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7034 ST(0) = (SV*)XSANY.any_ptr;