3 * Copyright (c) 1991-2002, 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
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
47 if ((PL_OpSpace -= sz) < 0) {
48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
63 PL_OpPtr += PERL_SLAB_SIZE;
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
77 S_Slab_Free(pTHX_ void *op)
79 I32 **ptr = (I32 **) op;
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
85 PerlMemShared_free(slab);
86 if (slab == PL_OpSlab) {
93 #define NewOp(m, var, c, type) Newz(m, var, c, type)
94 #define FreeOp(p) Safefree(p)
97 * In the following definition, the ", Nullop" is just to make the compiler
98 * think the expression is of the right type: croak actually does a Siglongjmp.
100 #define CHECKOP(type,o) \
101 ((PL_op_mask && PL_op_mask[type]) \
102 ? ( op_free((OP*)o), \
103 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
105 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
107 #define PAD_MAX 999999999
108 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
111 S_gv_ename(pTHX_ GV *gv)
114 SV* tmpsv = sv_newmortal();
115 gv_efullname3(tmpsv, gv, Nullch);
116 return SvPV(tmpsv,n_a);
120 S_no_fh_allowed(pTHX_ OP *o)
122 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
128 S_too_few_arguments(pTHX_ OP *o, char *name)
130 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
135 S_too_many_arguments(pTHX_ OP *o, char *name)
137 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
142 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
144 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
145 (int)n, name, t, OP_DESC(kid)));
149 S_no_bareword_allowed(pTHX_ OP *o)
151 qerror(Perl_mess(aTHX_
152 "Bareword \"%s\" not allowed while \"strict subs\" in use",
153 SvPV_nolen(cSVOPo_sv)));
156 /* "register" allocation */
159 Perl_pad_allocmy(pTHX_ char *name)
164 if (!(PL_in_my == KEY_our ||
166 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
167 (name[1] == '_' && (int)strlen(name) > 2)))
169 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
170 /* 1999-02-27 mjd@plover.com */
172 p = strchr(name, '\0');
173 /* The next block assumes the buffer is at least 205 chars
174 long. At present, it's always at least 256 chars. */
176 strcpy(name+200, "...");
182 /* Move everything else down one character */
183 for (; p-name > 2; p--)
185 name[2] = toCTRL(name[1]);
188 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
190 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
191 SV **svp = AvARRAY(PL_comppad_name);
192 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
193 PADOFFSET top = AvFILLp(PL_comppad_name);
194 for (off = top; off > PL_comppad_name_floor; off--) {
196 && sv != &PL_sv_undef
197 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
198 && (PL_in_my != KEY_our
199 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
200 && strEQ(name, SvPVX(sv)))
202 Perl_warner(aTHX_ WARN_MISC,
203 "\"%s\" variable %s masks earlier declaration in same %s",
204 (PL_in_my == KEY_our ? "our" : "my"),
206 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
211 if (PL_in_my == KEY_our) {
214 && sv != &PL_sv_undef
215 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
216 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
217 && strEQ(name, SvPVX(sv)))
219 Perl_warner(aTHX_ WARN_MISC,
220 "\"our\" variable %s redeclared", name);
221 Perl_warner(aTHX_ WARN_MISC,
222 "\t(Did you mean \"local\" instead of \"our\"?)\n");
225 } while ( off-- > 0 );
228 off = pad_alloc(OP_PADSV, SVs_PADMY);
230 sv_upgrade(sv, SVt_PVNV);
232 if (PL_in_my_stash) {
234 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
235 name, PL_in_my == KEY_our ? "our" : "my"));
236 SvFLAGS(sv) |= SVpad_TYPED;
237 (void)SvUPGRADE(sv, SVt_PVMG);
238 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
240 if (PL_in_my == KEY_our) {
241 (void)SvUPGRADE(sv, SVt_PVGV);
242 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
243 SvFLAGS(sv) |= SVpad_OUR;
245 av_store(PL_comppad_name, off, sv);
246 SvNVX(sv) = (NV)PAD_MAX;
247 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
248 if (!PL_min_intro_pending)
249 PL_min_intro_pending = off;
250 PL_max_intro_pending = off;
252 av_store(PL_comppad, off, (SV*)newAV());
253 else if (*name == '%')
254 av_store(PL_comppad, off, (SV*)newHV());
255 SvPADMY_on(PL_curpad[off]);
260 S_pad_addlex(pTHX_ SV *proto_namesv)
262 SV *namesv = NEWSV(1103,0);
263 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
264 sv_upgrade(namesv, SVt_PVNV);
265 sv_setpv(namesv, SvPVX(proto_namesv));
266 av_store(PL_comppad_name, newoff, namesv);
267 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
268 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
269 SvFAKE_on(namesv); /* A ref, not a real var */
270 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
271 SvFLAGS(namesv) |= SVpad_OUR;
272 (void)SvUPGRADE(namesv, SVt_PVGV);
273 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
275 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
276 SvFLAGS(namesv) |= SVpad_TYPED;
277 (void)SvUPGRADE(namesv, SVt_PVMG);
278 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
283 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
286 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
287 I32 cx_ix, I32 saweval, U32 flags)
293 register PERL_CONTEXT *cx;
295 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
296 AV *curlist = CvPADLIST(cv);
297 SV **svp = av_fetch(curlist, 0, FALSE);
300 if (!svp || *svp == &PL_sv_undef)
303 svp = AvARRAY(curname);
304 for (off = AvFILLp(curname); off > 0; off--) {
305 if ((sv = svp[off]) &&
306 sv != &PL_sv_undef &&
308 seq > I_32(SvNVX(sv)) &&
309 strEQ(SvPVX(sv), name))
320 return 0; /* don't clone from inactive stack frame */
324 oldpad = (AV*)AvARRAY(curlist)[depth];
325 oldsv = *av_fetch(oldpad, off, TRUE);
326 if (!newoff) { /* Not a mere clone operation. */
327 newoff = pad_addlex(sv);
328 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
329 /* "It's closures all the way down." */
330 CvCLONE_on(PL_compcv);
332 if (CvANON(PL_compcv))
333 oldsv = Nullsv; /* no need to keep ref */
338 bcv && bcv != cv && !CvCLONE(bcv);
339 bcv = CvOUTSIDE(bcv))
342 /* install the missing pad entry in intervening
343 * nested subs and mark them cloneable.
344 * XXX fix pad_foo() to not use globals */
345 AV *ocomppad_name = PL_comppad_name;
346 AV *ocomppad = PL_comppad;
347 SV **ocurpad = PL_curpad;
348 AV *padlist = CvPADLIST(bcv);
349 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
350 PL_comppad = (AV*)AvARRAY(padlist)[1];
351 PL_curpad = AvARRAY(PL_comppad);
353 PL_comppad_name = ocomppad_name;
354 PL_comppad = ocomppad;
359 if (ckWARN(WARN_CLOSURE)
360 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
362 Perl_warner(aTHX_ WARN_CLOSURE,
363 "Variable \"%s\" may be unavailable",
371 else if (!CvUNIQUE(PL_compcv)) {
372 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
373 && !(SvFLAGS(sv) & SVpad_OUR))
375 Perl_warner(aTHX_ WARN_CLOSURE,
376 "Variable \"%s\" will not stay shared", name);
380 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
386 if (flags & FINDLEX_NOSEARCH)
389 /* Nothing in current lexical context--try eval's context, if any.
390 * This is necessary to let the perldb get at lexically scoped variables.
391 * XXX This will also probably interact badly with eval tree caching.
394 for (i = cx_ix; i >= 0; i--) {
396 switch (CxTYPE(cx)) {
398 if (i == 0 && saweval) {
399 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
403 switch (cx->blk_eval.old_op_type) {
405 if (CxREALEVAL(cx)) {
408 seq = cxstack[i].blk_oldcop->cop_seq;
409 startcv = cxstack[i].blk_eval.cv;
410 if (startcv && CvOUTSIDE(startcv)) {
411 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
413 if (off) /* continue looking if not found here */
420 /* require/do must have their own scope */
429 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
430 saweval = i; /* so we know where we were called from */
431 seq = cxstack[i].blk_oldcop->cop_seq;
434 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
442 Perl_pad_findmy(pTHX_ char *name)
447 SV **svp = AvARRAY(PL_comppad_name);
448 U32 seq = PL_cop_seqmax;
452 #ifdef USE_5005THREADS
454 * Special case to get lexical (and hence per-thread) @_.
455 * XXX I need to find out how to tell at parse-time whether use
456 * of @_ should refer to a lexical (from a sub) or defgv (global
457 * scope and maybe weird sub-ish things like formats). See
458 * startsub in perly.y. It's possible that @_ could be lexical
459 * (at least from subs) even in non-threaded perl.
461 if (strEQ(name, "@_"))
462 return 0; /* success. (NOT_IN_PAD indicates failure) */
463 #endif /* USE_5005THREADS */
465 /* The one we're looking for is probably just before comppad_name_fill. */
466 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
467 if ((sv = svp[off]) &&
468 sv != &PL_sv_undef &&
471 seq > I_32(SvNVX(sv)))) &&
472 strEQ(SvPVX(sv), name))
474 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
475 return (PADOFFSET)off;
476 pendoff = off; /* this pending def. will override import */
480 outside = CvOUTSIDE(PL_compcv);
482 /* Check if if we're compiling an eval'', and adjust seq to be the
483 * eval's seq number. This depends on eval'' having a non-null
484 * CvOUTSIDE() while it is being compiled. The eval'' itself is
485 * identified by CvEVAL being true and CvGV being null. */
486 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
487 cx = &cxstack[cxstack_ix];
489 seq = cx->blk_oldcop->cop_seq;
492 /* See if it's in a nested scope */
493 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
495 /* If there is a pending local definition, this new alias must die */
497 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
498 return off; /* pad_findlex returns 0 for failure...*/
500 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
504 Perl_pad_leavemy(pTHX_ I32 fill)
507 SV **svp = AvARRAY(PL_comppad_name);
509 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
510 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
511 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
512 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
515 /* "Deintroduce" my variables that are leaving with this scope. */
516 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
517 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
518 SvIVX(sv) = PL_cop_seqmax;
523 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
528 if (AvARRAY(PL_comppad) != PL_curpad)
529 Perl_croak(aTHX_ "panic: pad_alloc");
530 if (PL_pad_reset_pending)
532 if (tmptype & SVs_PADMY) {
534 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
535 } while (SvPADBUSY(sv)); /* need a fresh one */
536 retval = AvFILLp(PL_comppad);
539 SV **names = AvARRAY(PL_comppad_name);
540 SSize_t names_fill = AvFILLp(PL_comppad_name);
543 * "foreach" index vars temporarily become aliases to non-"my"
544 * values. Thus we must skip, not just pad values that are
545 * marked as current pad values, but also those with names.
547 if (++PL_padix <= names_fill &&
548 (sv = names[PL_padix]) && sv != &PL_sv_undef)
550 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
551 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
552 !IS_PADGV(sv) && !IS_PADCONST(sv))
557 SvFLAGS(sv) |= tmptype;
558 PL_curpad = AvARRAY(PL_comppad);
559 #ifdef USE_5005THREADS
560 DEBUG_X(PerlIO_printf(Perl_debug_log,
561 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
562 PTR2UV(thr), PTR2UV(PL_curpad),
563 (long) retval, PL_op_name[optype]));
565 DEBUG_X(PerlIO_printf(Perl_debug_log,
566 "Pad 0x%"UVxf" alloc %ld for %s\n",
568 (long) retval, PL_op_name[optype]));
569 #endif /* USE_5005THREADS */
570 return (PADOFFSET)retval;
574 Perl_pad_sv(pTHX_ PADOFFSET po)
576 #ifdef USE_5005THREADS
577 DEBUG_X(PerlIO_printf(Perl_debug_log,
578 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
579 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
582 Perl_croak(aTHX_ "panic: pad_sv po");
583 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
584 PTR2UV(PL_curpad), (IV)po));
585 #endif /* USE_5005THREADS */
586 return PL_curpad[po]; /* eventually we'll turn this into a macro */
590 Perl_pad_free(pTHX_ PADOFFSET po)
594 if (AvARRAY(PL_comppad) != PL_curpad)
595 Perl_croak(aTHX_ "panic: pad_free curpad");
597 Perl_croak(aTHX_ "panic: pad_free po");
598 #ifdef USE_5005THREADS
599 DEBUG_X(PerlIO_printf(Perl_debug_log,
600 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
601 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
603 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
604 PTR2UV(PL_curpad), (IV)po));
605 #endif /* USE_5005THREADS */
606 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
607 SvPADTMP_off(PL_curpad[po]);
609 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
612 if ((I32)po < PL_padix)
617 Perl_pad_swipe(pTHX_ PADOFFSET po)
619 if (AvARRAY(PL_comppad) != PL_curpad)
620 Perl_croak(aTHX_ "panic: pad_swipe curpad");
622 Perl_croak(aTHX_ "panic: pad_swipe po");
623 #ifdef USE_5005THREADS
624 DEBUG_X(PerlIO_printf(Perl_debug_log,
625 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
626 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
628 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
629 PTR2UV(PL_curpad), (IV)po));
630 #endif /* USE_5005THREADS */
631 SvPADTMP_off(PL_curpad[po]);
632 PL_curpad[po] = NEWSV(1107,0);
633 SvPADTMP_on(PL_curpad[po]);
634 if ((I32)po < PL_padix)
638 /* XXX pad_reset() is currently disabled because it results in serious bugs.
639 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
640 * on the stack by OPs that use them, there are several ways to get an alias
641 * to a shared TARG. Such an alias will change randomly and unpredictably.
642 * We avoid doing this until we can think of a Better Way.
647 #ifdef USE_BROKEN_PAD_RESET
650 if (AvARRAY(PL_comppad) != PL_curpad)
651 Perl_croak(aTHX_ "panic: pad_reset curpad");
652 #ifdef USE_5005THREADS
653 DEBUG_X(PerlIO_printf(Perl_debug_log,
654 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
655 PTR2UV(thr), PTR2UV(PL_curpad)));
657 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
659 #endif /* USE_5005THREADS */
660 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
661 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
662 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
663 SvPADTMP_off(PL_curpad[po]);
665 PL_padix = PL_padix_floor;
668 PL_pad_reset_pending = FALSE;
671 #ifdef USE_5005THREADS
672 /* find_threadsv is not reentrant */
674 Perl_find_threadsv(pTHX_ const char *name)
679 /* We currently only handle names of a single character */
680 p = strchr(PL_threadsv_names, *name);
683 key = p - PL_threadsv_names;
684 MUTEX_LOCK(&thr->mutex);
685 svp = av_fetch(thr->threadsv, key, FALSE);
687 MUTEX_UNLOCK(&thr->mutex);
689 SV *sv = NEWSV(0, 0);
690 av_store(thr->threadsv, key, sv);
691 thr->threadsvp = AvARRAY(thr->threadsv);
692 MUTEX_UNLOCK(&thr->mutex);
694 * Some magic variables used to be automagically initialised
695 * in gv_fetchpv. Those which are now per-thread magicals get
696 * initialised here instead.
702 sv_setpv(sv, "\034");
703 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
708 PL_sawampersand = TRUE;
722 /* XXX %! tied to Errno.pm needs to be added here.
723 * See gv_fetchpv(). */
727 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
729 DEBUG_S(PerlIO_printf(Perl_error_log,
730 "find_threadsv: new SV %p for $%s%c\n",
731 sv, (*name < 32) ? "^" : "",
732 (*name < 32) ? toCTRL(*name) : *name));
736 #endif /* USE_5005THREADS */
741 Perl_op_free(pTHX_ OP *o)
743 register OP *kid, *nextkid;
746 if (!o || o->op_seq == (U16)-1)
749 if (o->op_private & OPpREFCOUNTED) {
750 switch (o->op_type) {
758 if (OpREFCNT_dec(o)) {
769 if (o->op_flags & OPf_KIDS) {
770 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
771 nextkid = kid->op_sibling; /* Get before next freeing kid */
779 /* COP* is not cleared by op_clear() so that we may track line
780 * numbers etc even after null() */
781 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
789 Perl_op_clear(pTHX_ OP *o)
792 switch (o->op_type) {
793 case OP_NULL: /* Was holding old type, if any. */
794 case OP_ENTEREVAL: /* Was holding hints. */
795 #ifdef USE_5005THREADS
796 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
800 #ifdef USE_5005THREADS
802 if (!(o->op_flags & OPf_SPECIAL))
805 #endif /* USE_5005THREADS */
807 if (!(o->op_flags & OPf_REF)
808 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
815 if (cPADOPo->op_padix > 0) {
818 pad_swipe(cPADOPo->op_padix);
819 /* No GvIN_PAD_off(gv) here, because other references may still
820 * exist on the pad */
823 cPADOPo->op_padix = 0;
826 SvREFCNT_dec(cSVOPo->op_sv);
827 cSVOPo->op_sv = Nullsv;
830 case OP_METHOD_NAMED:
832 SvREFCNT_dec(cSVOPo->op_sv);
833 cSVOPo->op_sv = Nullsv;
839 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
843 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
844 SvREFCNT_dec(cSVOPo->op_sv);
845 cSVOPo->op_sv = Nullsv;
848 Safefree(cPVOPo->op_pv);
849 cPVOPo->op_pv = Nullch;
853 op_free(cPMOPo->op_pmreplroot);
857 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
859 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
860 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
861 /* No GvIN_PAD_off(gv) here, because other references may still
862 * exist on the pad */
867 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
874 HV *pmstash = PmopSTASH(cPMOPo);
875 if (pmstash && SvREFCNT(pmstash)) {
876 PMOP *pmop = HvPMROOT(pmstash);
877 PMOP *lastpmop = NULL;
879 if (cPMOPo == pmop) {
881 lastpmop->op_pmnext = pmop->op_pmnext;
883 HvPMROOT(pmstash) = pmop->op_pmnext;
887 pmop = pmop->op_pmnext;
890 PmopSTASH_free(cPMOPo);
892 cPMOPo->op_pmreplroot = Nullop;
893 /* we use the "SAFE" version of the PM_ macros here
894 * since sv_clean_all might release some PMOPs
895 * after PL_regex_padav has been cleared
896 * and the clearing of PL_regex_padav needs to
897 * happen before sv_clean_all
899 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
900 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
902 if(PL_regex_pad) { /* We could be in destruction */
903 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
904 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
905 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
912 if (o->op_targ > 0) {
913 pad_free(o->op_targ);
919 S_cop_free(pTHX_ COP* cop)
921 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
924 if (! specialWARN(cop->cop_warnings))
925 SvREFCNT_dec(cop->cop_warnings);
926 if (! specialCopIO(cop->cop_io)) {
929 char *s = SvPV(cop->cop_io,len);
930 Perl_warn(aTHX_ "io='%.*s'",(int) len,s);
932 SvREFCNT_dec(cop->cop_io);
938 Perl_op_null(pTHX_ OP *o)
940 if (o->op_type == OP_NULL)
943 o->op_targ = o->op_type;
944 o->op_type = OP_NULL;
945 o->op_ppaddr = PL_ppaddr[OP_NULL];
948 /* Contextualizers */
950 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
953 Perl_linklist(pTHX_ OP *o)
960 /* establish postfix order */
961 if (cUNOPo->op_first) {
962 o->op_next = LINKLIST(cUNOPo->op_first);
963 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
965 kid->op_next = LINKLIST(kid->op_sibling);
977 Perl_scalarkids(pTHX_ OP *o)
980 if (o && o->op_flags & OPf_KIDS) {
981 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
988 S_scalarboolean(pTHX_ OP *o)
990 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
991 if (ckWARN(WARN_SYNTAX)) {
992 line_t oldline = CopLINE(PL_curcop);
994 if (PL_copline != NOLINE)
995 CopLINE_set(PL_curcop, PL_copline);
996 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
997 CopLINE_set(PL_curcop, oldline);
1004 Perl_scalar(pTHX_ OP *o)
1008 /* assumes no premature commitment */
1009 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1010 || o->op_type == OP_RETURN)
1015 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1017 switch (o->op_type) {
1019 scalar(cBINOPo->op_first);
1024 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1028 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1029 if (!kPMOP->op_pmreplroot)
1030 deprecate("implicit split to @_");
1038 if (o->op_flags & OPf_KIDS) {
1039 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1045 kid = cLISTOPo->op_first;
1047 while ((kid = kid->op_sibling)) {
1048 if (kid->op_sibling)
1053 WITH_THR(PL_curcop = &PL_compiling);
1058 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1059 if (kid->op_sibling)
1064 WITH_THR(PL_curcop = &PL_compiling);
1067 if (ckWARN(WARN_VOID))
1068 Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
1074 Perl_scalarvoid(pTHX_ OP *o)
1081 if (o->op_type == OP_NEXTSTATE
1082 || o->op_type == OP_SETSTATE
1083 || o->op_type == OP_DBSTATE
1084 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1085 || o->op_targ == OP_SETSTATE
1086 || o->op_targ == OP_DBSTATE)))
1087 PL_curcop = (COP*)o; /* for warning below */
1089 /* assumes no premature commitment */
1090 want = o->op_flags & OPf_WANT;
1091 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1092 || o->op_type == OP_RETURN)
1097 if ((o->op_private & OPpTARGET_MY)
1098 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1100 return scalar(o); /* As if inside SASSIGN */
1103 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1105 switch (o->op_type) {
1107 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1111 if (o->op_flags & OPf_STACKED)
1115 if (o->op_private == 4)
1157 case OP_GETSOCKNAME:
1158 case OP_GETPEERNAME:
1163 case OP_GETPRIORITY:
1186 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1187 useless = OP_DESC(o);
1194 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1195 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1196 useless = "a variable";
1201 if (cSVOPo->op_private & OPpCONST_STRICT)
1202 no_bareword_allowed(o);
1204 if (ckWARN(WARN_VOID)) {
1205 useless = "a constant";
1206 /* the constants 0 and 1 are permitted as they are
1207 conventionally used as dummies in constructs like
1208 1 while some_condition_with_side_effects; */
1209 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1211 else if (SvPOK(sv)) {
1212 /* perl4's way of mixing documentation and code
1213 (before the invention of POD) was based on a
1214 trick to mix nroff and perl code. The trick was
1215 built upon these three nroff macros being used in
1216 void context. The pink camel has the details in
1217 the script wrapman near page 319. */
1218 if (strnEQ(SvPVX(sv), "di", 2) ||
1219 strnEQ(SvPVX(sv), "ds", 2) ||
1220 strnEQ(SvPVX(sv), "ig", 2))
1225 op_null(o); /* don't execute or even remember it */
1229 o->op_type = OP_PREINC; /* pre-increment is faster */
1230 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1234 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1235 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1241 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1246 if (o->op_flags & OPf_STACKED)
1253 if (!(o->op_flags & OPf_KIDS))
1262 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1269 /* all requires must return a boolean value */
1270 o->op_flags &= ~OPf_WANT;
1275 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1276 if (!kPMOP->op_pmreplroot)
1277 deprecate("implicit split to @_");
1281 if (useless && ckWARN(WARN_VOID))
1282 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1287 Perl_listkids(pTHX_ OP *o)
1290 if (o && o->op_flags & OPf_KIDS) {
1291 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1298 Perl_list(pTHX_ OP *o)
1302 /* assumes no premature commitment */
1303 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1304 || o->op_type == OP_RETURN)
1309 if ((o->op_private & OPpTARGET_MY)
1310 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1312 return o; /* As if inside SASSIGN */
1315 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1317 switch (o->op_type) {
1320 list(cBINOPo->op_first);
1325 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1333 if (!(o->op_flags & OPf_KIDS))
1335 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1336 list(cBINOPo->op_first);
1337 return gen_constant_list(o);
1344 kid = cLISTOPo->op_first;
1346 while ((kid = kid->op_sibling)) {
1347 if (kid->op_sibling)
1352 WITH_THR(PL_curcop = &PL_compiling);
1356 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1357 if (kid->op_sibling)
1362 WITH_THR(PL_curcop = &PL_compiling);
1365 /* all requires must return a boolean value */
1366 o->op_flags &= ~OPf_WANT;
1373 Perl_scalarseq(pTHX_ OP *o)
1378 if (o->op_type == OP_LINESEQ ||
1379 o->op_type == OP_SCOPE ||
1380 o->op_type == OP_LEAVE ||
1381 o->op_type == OP_LEAVETRY)
1383 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1384 if (kid->op_sibling) {
1388 PL_curcop = &PL_compiling;
1390 o->op_flags &= ~OPf_PARENS;
1391 if (PL_hints & HINT_BLOCK_SCOPE)
1392 o->op_flags |= OPf_PARENS;
1395 o = newOP(OP_STUB, 0);
1400 S_modkids(pTHX_ OP *o, I32 type)
1403 if (o && o->op_flags & OPf_KIDS) {
1404 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1411 Perl_mod(pTHX_ OP *o, I32 type)
1416 if (!o || PL_error_count)
1419 if ((o->op_private & OPpTARGET_MY)
1420 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1425 switch (o->op_type) {
1430 if (!(o->op_private & (OPpCONST_ARYBASE)))
1432 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1433 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1437 SAVEI32(PL_compiling.cop_arybase);
1438 PL_compiling.cop_arybase = 0;
1440 else if (type == OP_REFGEN)
1443 Perl_croak(aTHX_ "That use of $[ is unsupported");
1446 if (o->op_flags & OPf_PARENS)
1450 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1451 !(o->op_flags & OPf_STACKED)) {
1452 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1453 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1454 assert(cUNOPo->op_first->op_type == OP_NULL);
1455 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1458 else if (o->op_private & OPpENTERSUB_NOMOD)
1460 else { /* lvalue subroutine call */
1461 o->op_private |= OPpLVAL_INTRO;
1462 PL_modcount = RETURN_UNLIMITED_NUMBER;
1463 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1464 /* Backward compatibility mode: */
1465 o->op_private |= OPpENTERSUB_INARGS;
1468 else { /* Compile-time error message: */
1469 OP *kid = cUNOPo->op_first;
1473 if (kid->op_type == OP_PUSHMARK)
1475 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1477 "panic: unexpected lvalue entersub "
1478 "args: type/targ %ld:%"UVuf,
1479 (long)kid->op_type, (UV)kid->op_targ);
1480 kid = kLISTOP->op_first;
1482 while (kid->op_sibling)
1483 kid = kid->op_sibling;
1484 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1486 if (kid->op_type == OP_METHOD_NAMED
1487 || kid->op_type == OP_METHOD)
1491 NewOp(1101, newop, 1, UNOP);
1492 newop->op_type = OP_RV2CV;
1493 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1494 newop->op_first = Nullop;
1495 newop->op_next = (OP*)newop;
1496 kid->op_sibling = (OP*)newop;
1497 newop->op_private |= OPpLVAL_INTRO;
1501 if (kid->op_type != OP_RV2CV)
1503 "panic: unexpected lvalue entersub "
1504 "entry via type/targ %ld:%"UVuf,
1505 (long)kid->op_type, (UV)kid->op_targ);
1506 kid->op_private |= OPpLVAL_INTRO;
1507 break; /* Postpone until runtime */
1511 kid = kUNOP->op_first;
1512 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1513 kid = kUNOP->op_first;
1514 if (kid->op_type == OP_NULL)
1516 "Unexpected constant lvalue entersub "
1517 "entry via type/targ %ld:%"UVuf,
1518 (long)kid->op_type, (UV)kid->op_targ);
1519 if (kid->op_type != OP_GV) {
1520 /* Restore RV2CV to check lvalueness */
1522 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1523 okid->op_next = kid->op_next;
1524 kid->op_next = okid;
1527 okid->op_next = Nullop;
1528 okid->op_type = OP_RV2CV;
1530 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1531 okid->op_private |= OPpLVAL_INTRO;
1535 cv = GvCV(kGVOP_gv);
1545 /* grep, foreach, subcalls, refgen */
1546 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1548 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1549 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1551 : (o->op_type == OP_ENTERSUB
1552 ? "non-lvalue subroutine call"
1554 type ? PL_op_desc[type] : "local"));
1568 case OP_RIGHT_SHIFT:
1577 if (!(o->op_flags & OPf_STACKED))
1583 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1589 if (!type && cUNOPo->op_first->op_type != OP_GV)
1590 Perl_croak(aTHX_ "Can't localize through a reference");
1591 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1592 PL_modcount = RETURN_UNLIMITED_NUMBER;
1593 return o; /* Treat \(@foo) like ordinary list. */
1597 if (scalar_mod_type(o, type))
1599 ref(cUNOPo->op_first, o->op_type);
1603 if (type == OP_LEAVESUBLV)
1604 o->op_private |= OPpMAYBE_LVSUB;
1610 PL_modcount = RETURN_UNLIMITED_NUMBER;
1613 if (!type && cUNOPo->op_first->op_type != OP_GV)
1614 Perl_croak(aTHX_ "Can't localize through a reference");
1615 ref(cUNOPo->op_first, o->op_type);
1619 PL_hints |= HINT_BLOCK_SCOPE;
1629 PL_modcount = RETURN_UNLIMITED_NUMBER;
1630 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1631 return o; /* Treat \(@foo) like ordinary list. */
1632 if (scalar_mod_type(o, type))
1634 if (type == OP_LEAVESUBLV)
1635 o->op_private |= OPpMAYBE_LVSUB;
1640 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1641 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1644 #ifdef USE_5005THREADS
1646 PL_modcount++; /* XXX ??? */
1648 #endif /* USE_5005THREADS */
1654 if (type != OP_SASSIGN)
1658 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1663 if (type == OP_LEAVESUBLV)
1664 o->op_private |= OPpMAYBE_LVSUB;
1666 pad_free(o->op_targ);
1667 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1668 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1669 if (o->op_flags & OPf_KIDS)
1670 mod(cBINOPo->op_first->op_sibling, type);
1675 ref(cBINOPo->op_first, o->op_type);
1676 if (type == OP_ENTERSUB &&
1677 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1678 o->op_private |= OPpLVAL_DEFER;
1679 if (type == OP_LEAVESUBLV)
1680 o->op_private |= OPpMAYBE_LVSUB;
1688 if (o->op_flags & OPf_KIDS)
1689 mod(cLISTOPo->op_last, type);
1693 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1695 else if (!(o->op_flags & OPf_KIDS))
1697 if (o->op_targ != OP_LIST) {
1698 mod(cBINOPo->op_first, type);
1703 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1708 if (type != OP_LEAVESUBLV)
1710 break; /* mod()ing was handled by ck_return() */
1713 /* [20011101.069] File test operators interpret OPf_REF to mean that
1714 their argument is a filehandle; thus \stat(".") should not set
1716 if (type == OP_REFGEN &&
1717 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1720 if (type != OP_LEAVESUBLV)
1721 o->op_flags |= OPf_MOD;
1723 if (type == OP_AASSIGN || type == OP_SASSIGN)
1724 o->op_flags |= OPf_SPECIAL|OPf_REF;
1726 o->op_private |= OPpLVAL_INTRO;
1727 o->op_flags &= ~OPf_SPECIAL;
1728 PL_hints |= HINT_BLOCK_SCOPE;
1730 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1731 && type != OP_LEAVESUBLV)
1732 o->op_flags |= OPf_REF;
1737 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1741 if (o->op_type == OP_RV2GV)
1765 case OP_RIGHT_SHIFT:
1784 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1786 switch (o->op_type) {
1794 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1807 Perl_refkids(pTHX_ OP *o, I32 type)
1810 if (o && o->op_flags & OPf_KIDS) {
1811 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1818 Perl_ref(pTHX_ OP *o, I32 type)
1822 if (!o || PL_error_count)
1825 switch (o->op_type) {
1827 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1828 !(o->op_flags & OPf_STACKED)) {
1829 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1830 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1831 assert(cUNOPo->op_first->op_type == OP_NULL);
1832 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1833 o->op_flags |= OPf_SPECIAL;
1838 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1842 if (type == OP_DEFINED)
1843 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1844 ref(cUNOPo->op_first, o->op_type);
1847 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1848 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1849 : type == OP_RV2HV ? OPpDEREF_HV
1851 o->op_flags |= OPf_MOD;
1856 o->op_flags |= OPf_MOD; /* XXX ??? */
1861 o->op_flags |= OPf_REF;
1864 if (type == OP_DEFINED)
1865 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1866 ref(cUNOPo->op_first, o->op_type);
1871 o->op_flags |= OPf_REF;
1876 if (!(o->op_flags & OPf_KIDS))
1878 ref(cBINOPo->op_first, type);
1882 ref(cBINOPo->op_first, o->op_type);
1883 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1884 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1885 : type == OP_RV2HV ? OPpDEREF_HV
1887 o->op_flags |= OPf_MOD;
1895 if (!(o->op_flags & OPf_KIDS))
1897 ref(cLISTOPo->op_last, type);
1907 S_dup_attrlist(pTHX_ OP *o)
1911 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1912 * where the first kid is OP_PUSHMARK and the remaining ones
1913 * are OP_CONST. We need to push the OP_CONST values.
1915 if (o->op_type == OP_CONST)
1916 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1918 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1919 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1920 if (o->op_type == OP_CONST)
1921 rop = append_elem(OP_LIST, rop,
1922 newSVOP(OP_CONST, o->op_flags,
1923 SvREFCNT_inc(cSVOPo->op_sv)));
1930 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1934 /* fake up C<use attributes $pkg,$rv,@attrs> */
1935 ENTER; /* need to protect against side-effects of 'use' */
1938 stashsv = newSVpv(HvNAME(stash), 0);
1940 stashsv = &PL_sv_no;
1942 #define ATTRSMODULE "attributes"
1943 #define ATTRSMODULE_PM "attributes.pm"
1947 /* Don't force the C<use> if we don't need it. */
1948 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1949 sizeof(ATTRSMODULE_PM)-1, 0);
1950 if (svp && *svp != &PL_sv_undef)
1951 ; /* already in %INC */
1953 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1954 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1958 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1959 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1961 prepend_elem(OP_LIST,
1962 newSVOP(OP_CONST, 0, stashsv),
1963 prepend_elem(OP_LIST,
1964 newSVOP(OP_CONST, 0,
1966 dup_attrlist(attrs))));
1972 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1974 OP *pack, *imop, *arg;
1980 assert(target->op_type == OP_PADSV ||
1981 target->op_type == OP_PADHV ||
1982 target->op_type == OP_PADAV);
1984 /* Ensure that attributes.pm is loaded. */
1985 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1987 /* Need package name for method call. */
1988 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1990 /* Build up the real arg-list. */
1992 stashsv = newSVpv(HvNAME(stash), 0);
1994 stashsv = &PL_sv_no;
1995 arg = newOP(OP_PADSV, 0);
1996 arg->op_targ = target->op_targ;
1997 arg = prepend_elem(OP_LIST,
1998 newSVOP(OP_CONST, 0, stashsv),
1999 prepend_elem(OP_LIST,
2000 newUNOP(OP_REFGEN, 0,
2001 mod(arg, OP_REFGEN)),
2002 dup_attrlist(attrs)));
2004 /* Fake up a method call to import */
2005 meth = newSVpvn("import", 6);
2006 (void)SvUPGRADE(meth, SVt_PVIV);
2007 (void)SvIOK_on(meth);
2008 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2009 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2010 append_elem(OP_LIST,
2011 prepend_elem(OP_LIST, pack, list(arg)),
2012 newSVOP(OP_METHOD_NAMED, 0, meth)));
2013 imop->op_private |= OPpENTERSUB_NOMOD;
2015 /* Combine the ops. */
2016 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2020 =notfor apidoc apply_attrs_string
2022 Attempts to apply a list of attributes specified by the C<attrstr> and
2023 C<len> arguments to the subroutine identified by the C<cv> argument which
2024 is expected to be associated with the package identified by the C<stashpv>
2025 argument (see L<attributes>). It gets this wrong, though, in that it
2026 does not correctly identify the boundaries of the individual attribute
2027 specifications within C<attrstr>. This is not really intended for the
2028 public API, but has to be listed here for systems such as AIX which
2029 need an explicit export list for symbols. (It's called from XS code
2030 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2031 to respect attribute syntax properly would be welcome.
2037 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2038 char *attrstr, STRLEN len)
2043 len = strlen(attrstr);
2047 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2049 char *sstr = attrstr;
2050 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2051 attrs = append_elem(OP_LIST, attrs,
2052 newSVOP(OP_CONST, 0,
2053 newSVpvn(sstr, attrstr-sstr)));
2057 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2058 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2059 Nullsv, prepend_elem(OP_LIST,
2060 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2061 prepend_elem(OP_LIST,
2062 newSVOP(OP_CONST, 0,
2068 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2073 if (!o || PL_error_count)
2077 if (type == OP_LIST) {
2078 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2079 my_kid(kid, attrs, imopsp);
2080 } else if (type == OP_UNDEF) {
2082 } else if (type == OP_RV2SV || /* "our" declaration */
2084 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2085 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2086 yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
2089 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2091 PL_in_my_stash = Nullhv;
2092 apply_attrs(GvSTASH(gv),
2093 (type == OP_RV2SV ? GvSV(gv) :
2094 type == OP_RV2AV ? (SV*)GvAV(gv) :
2095 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2098 o->op_private |= OPpOUR_INTRO;
2101 else if (type != OP_PADSV &&
2104 type != OP_PUSHMARK)
2106 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2108 PL_in_my == KEY_our ? "our" : "my"));
2111 else if (attrs && type != OP_PUSHMARK) {
2116 PL_in_my_stash = Nullhv;
2118 /* check for C<my Dog $spot> when deciding package */
2119 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2120 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2121 stash = SvSTASH(*namesvp);
2123 stash = PL_curstash;
2124 apply_attrs_my(stash, o, attrs, imopsp);
2126 o->op_flags |= OPf_MOD;
2127 o->op_private |= OPpLVAL_INTRO;
2132 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2135 int maybe_scalar = 0;
2137 if (o->op_flags & OPf_PARENS)
2143 o = my_kid(o, attrs, &rops);
2145 if (maybe_scalar && o->op_type == OP_PADSV) {
2146 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2147 o->op_private |= OPpLVAL_INTRO;
2150 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2153 PL_in_my_stash = Nullhv;
2158 Perl_my(pTHX_ OP *o)
2160 return my_attrs(o, Nullop);
2164 Perl_sawparens(pTHX_ OP *o)
2167 o->op_flags |= OPf_PARENS;
2172 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2176 if (ckWARN(WARN_MISC) &&
2177 (left->op_type == OP_RV2AV ||
2178 left->op_type == OP_RV2HV ||
2179 left->op_type == OP_PADAV ||
2180 left->op_type == OP_PADHV)) {
2181 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2182 right->op_type == OP_TRANS)
2183 ? right->op_type : OP_MATCH];
2184 const char *sample = ((left->op_type == OP_RV2AV ||
2185 left->op_type == OP_PADAV)
2186 ? "@array" : "%hash");
2187 Perl_warner(aTHX_ WARN_MISC,
2188 "Applying %s to %s will act on scalar(%s)",
2189 desc, sample, sample);
2192 if (right->op_type == OP_CONST &&
2193 cSVOPx(right)->op_private & OPpCONST_BARE &&
2194 cSVOPx(right)->op_private & OPpCONST_STRICT)
2196 no_bareword_allowed(right);
2199 if (!(right->op_flags & OPf_STACKED) &&
2200 (right->op_type == OP_MATCH ||
2201 right->op_type == OP_SUBST ||
2202 right->op_type == OP_TRANS)) {
2203 right->op_flags |= OPf_STACKED;
2204 if (right->op_type != OP_MATCH &&
2205 ! (right->op_type == OP_TRANS &&
2206 right->op_private & OPpTRANS_IDENTICAL))
2207 left = mod(left, right->op_type);
2208 if (right->op_type == OP_TRANS)
2209 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2211 o = prepend_elem(right->op_type, scalar(left), right);
2213 return newUNOP(OP_NOT, 0, scalar(o));
2217 return bind_match(type, left,
2218 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2222 Perl_invert(pTHX_ OP *o)
2226 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2227 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2231 Perl_scope(pTHX_ OP *o)
2234 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2235 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2236 o->op_type = OP_LEAVE;
2237 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2240 if (o->op_type == OP_LINESEQ) {
2242 o->op_type = OP_SCOPE;
2243 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2244 kid = ((LISTOP*)o)->op_first;
2245 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2249 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2256 Perl_save_hints(pTHX)
2259 SAVESPTR(GvHV(PL_hintgv));
2260 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2261 SAVEFREESV(GvHV(PL_hintgv));
2265 Perl_block_start(pTHX_ int full)
2267 int retval = PL_savestack_ix;
2269 SAVEI32(PL_comppad_name_floor);
2270 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2272 PL_comppad_name_fill = PL_comppad_name_floor;
2273 if (PL_comppad_name_floor < 0)
2274 PL_comppad_name_floor = 0;
2275 SAVEI32(PL_min_intro_pending);
2276 SAVEI32(PL_max_intro_pending);
2277 PL_min_intro_pending = 0;
2278 SAVEI32(PL_comppad_name_fill);
2279 SAVEI32(PL_padix_floor);
2280 PL_padix_floor = PL_padix;
2281 PL_pad_reset_pending = FALSE;
2283 PL_hints &= ~HINT_BLOCK_SCOPE;
2284 SAVESPTR(PL_compiling.cop_warnings);
2285 if (! specialWARN(PL_compiling.cop_warnings)) {
2286 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2287 SAVEFREESV(PL_compiling.cop_warnings) ;
2289 SAVESPTR(PL_compiling.cop_io);
2290 if (! specialCopIO(PL_compiling.cop_io)) {
2291 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2292 SAVEFREESV(PL_compiling.cop_io) ;
2298 Perl_block_end(pTHX_ I32 floor, OP *seq)
2300 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2301 line_t copline = PL_copline;
2302 /* there should be a nextstate in every block */
2303 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2304 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2306 PL_pad_reset_pending = FALSE;
2307 PL_compiling.op_private = PL_hints;
2309 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2310 pad_leavemy(PL_comppad_name_fill);
2318 #ifdef USE_5005THREADS
2319 OP *o = newOP(OP_THREADSV, 0);
2320 o->op_targ = find_threadsv("_");
2323 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2324 #endif /* USE_5005THREADS */
2328 Perl_newPROG(pTHX_ OP *o)
2333 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2334 ((PL_in_eval & EVAL_KEEPERR)
2335 ? OPf_SPECIAL : 0), o);
2336 PL_eval_start = linklist(PL_eval_root);
2337 PL_eval_root->op_private |= OPpREFCOUNTED;
2338 OpREFCNT_set(PL_eval_root, 1);
2339 PL_eval_root->op_next = 0;
2340 CALL_PEEP(PL_eval_start);
2345 PL_main_root = scope(sawparens(scalarvoid(o)));
2346 PL_curcop = &PL_compiling;
2347 PL_main_start = LINKLIST(PL_main_root);
2348 PL_main_root->op_private |= OPpREFCOUNTED;
2349 OpREFCNT_set(PL_main_root, 1);
2350 PL_main_root->op_next = 0;
2351 CALL_PEEP(PL_main_start);
2354 /* Register with debugger */
2356 CV *cv = get_cv("DB::postponed", FALSE);
2360 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2362 call_sv((SV*)cv, G_DISCARD);
2369 Perl_localize(pTHX_ OP *o, I32 lex)
2371 if (o->op_flags & OPf_PARENS)
2374 if (ckWARN(WARN_PARENTHESIS)
2375 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2377 char *s = PL_bufptr;
2379 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2382 if (*s == ';' || *s == '=')
2383 Perl_warner(aTHX_ WARN_PARENTHESIS,
2384 "Parentheses missing around \"%s\" list",
2385 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2391 o = mod(o, OP_NULL); /* a bit kludgey */
2393 PL_in_my_stash = Nullhv;
2398 Perl_jmaybe(pTHX_ OP *o)
2400 if (o->op_type == OP_LIST) {
2402 #ifdef USE_5005THREADS
2403 o2 = newOP(OP_THREADSV, 0);
2404 o2->op_targ = find_threadsv(";");
2406 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2407 #endif /* USE_5005THREADS */
2408 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2414 Perl_fold_constants(pTHX_ register OP *o)
2417 I32 type = o->op_type;
2420 if (PL_opargs[type] & OA_RETSCALAR)
2422 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2423 o->op_targ = pad_alloc(type, SVs_PADTMP);
2425 /* integerize op, unless it happens to be C<-foo>.
2426 * XXX should pp_i_negate() do magic string negation instead? */
2427 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2428 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2429 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2431 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2434 if (!(PL_opargs[type] & OA_FOLDCONST))
2439 /* XXX might want a ck_negate() for this */
2440 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2452 /* XXX what about the numeric ops? */
2453 if (PL_hints & HINT_LOCALE)
2458 goto nope; /* Don't try to run w/ errors */
2460 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2461 if ((curop->op_type != OP_CONST ||
2462 (curop->op_private & OPpCONST_BARE)) &&
2463 curop->op_type != OP_LIST &&
2464 curop->op_type != OP_SCALAR &&
2465 curop->op_type != OP_NULL &&
2466 curop->op_type != OP_PUSHMARK)
2472 curop = LINKLIST(o);
2476 sv = *(PL_stack_sp--);
2477 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2478 pad_swipe(o->op_targ);
2479 else if (SvTEMP(sv)) { /* grab mortal temp? */
2480 (void)SvREFCNT_inc(sv);
2484 if (type == OP_RV2GV)
2485 return newGVOP(OP_GV, 0, (GV*)sv);
2487 /* try to smush double to int, but don't smush -2.0 to -2 */
2488 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2491 #ifdef PERL_PRESERVE_IVUV
2492 /* Only bother to attempt to fold to IV if
2493 most operators will benefit */
2497 return newSVOP(OP_CONST, 0, sv);
2501 if (!(PL_opargs[type] & OA_OTHERINT))
2504 if (!(PL_hints & HINT_INTEGER)) {
2505 if (type == OP_MODULO
2506 || type == OP_DIVIDE
2507 || !(o->op_flags & OPf_KIDS))
2512 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2513 if (curop->op_type == OP_CONST) {
2514 if (SvIOK(((SVOP*)curop)->op_sv))
2518 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2522 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2529 Perl_gen_constant_list(pTHX_ register OP *o)
2532 I32 oldtmps_floor = PL_tmps_floor;
2536 return o; /* Don't attempt to run with errors */
2538 PL_op = curop = LINKLIST(o);
2545 PL_tmps_floor = oldtmps_floor;
2547 o->op_type = OP_RV2AV;
2548 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2549 curop = ((UNOP*)o)->op_first;
2550 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2557 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2559 if (!o || o->op_type != OP_LIST)
2560 o = newLISTOP(OP_LIST, 0, o, Nullop);
2562 o->op_flags &= ~OPf_WANT;
2564 if (!(PL_opargs[type] & OA_MARK))
2565 op_null(cLISTOPo->op_first);
2568 o->op_ppaddr = PL_ppaddr[type];
2569 o->op_flags |= flags;
2571 o = CHECKOP(type, o);
2572 if (o->op_type != type)
2575 return fold_constants(o);
2578 /* List constructors */
2581 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2589 if (first->op_type != type
2590 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2592 return newLISTOP(type, 0, first, last);
2595 if (first->op_flags & OPf_KIDS)
2596 ((LISTOP*)first)->op_last->op_sibling = last;
2598 first->op_flags |= OPf_KIDS;
2599 ((LISTOP*)first)->op_first = last;
2601 ((LISTOP*)first)->op_last = last;
2606 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2614 if (first->op_type != type)
2615 return prepend_elem(type, (OP*)first, (OP*)last);
2617 if (last->op_type != type)
2618 return append_elem(type, (OP*)first, (OP*)last);
2620 first->op_last->op_sibling = last->op_first;
2621 first->op_last = last->op_last;
2622 first->op_flags |= (last->op_flags & OPf_KIDS);
2630 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2638 if (last->op_type == type) {
2639 if (type == OP_LIST) { /* already a PUSHMARK there */
2640 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2641 ((LISTOP*)last)->op_first->op_sibling = first;
2642 if (!(first->op_flags & OPf_PARENS))
2643 last->op_flags &= ~OPf_PARENS;
2646 if (!(last->op_flags & OPf_KIDS)) {
2647 ((LISTOP*)last)->op_last = first;
2648 last->op_flags |= OPf_KIDS;
2650 first->op_sibling = ((LISTOP*)last)->op_first;
2651 ((LISTOP*)last)->op_first = first;
2653 last->op_flags |= OPf_KIDS;
2657 return newLISTOP(type, 0, first, last);
2663 Perl_newNULLLIST(pTHX)
2665 return newOP(OP_STUB, 0);
2669 Perl_force_list(pTHX_ OP *o)
2671 if (!o || o->op_type != OP_LIST)
2672 o = newLISTOP(OP_LIST, 0, o, Nullop);
2678 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2682 NewOp(1101, listop, 1, LISTOP);
2684 listop->op_type = type;
2685 listop->op_ppaddr = PL_ppaddr[type];
2688 listop->op_flags = flags;
2692 else if (!first && last)
2695 first->op_sibling = last;
2696 listop->op_first = first;
2697 listop->op_last = last;
2698 if (type == OP_LIST) {
2700 pushop = newOP(OP_PUSHMARK, 0);
2701 pushop->op_sibling = first;
2702 listop->op_first = pushop;
2703 listop->op_flags |= OPf_KIDS;
2705 listop->op_last = pushop;
2712 Perl_newOP(pTHX_ I32 type, I32 flags)
2715 NewOp(1101, o, 1, OP);
2717 o->op_ppaddr = PL_ppaddr[type];
2718 o->op_flags = flags;
2721 o->op_private = 0 + (flags >> 8);
2722 if (PL_opargs[type] & OA_RETSCALAR)
2724 if (PL_opargs[type] & OA_TARGET)
2725 o->op_targ = pad_alloc(type, SVs_PADTMP);
2726 return CHECKOP(type, o);
2730 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2735 first = newOP(OP_STUB, 0);
2736 if (PL_opargs[type] & OA_MARK)
2737 first = force_list(first);
2739 NewOp(1101, unop, 1, UNOP);
2740 unop->op_type = type;
2741 unop->op_ppaddr = PL_ppaddr[type];
2742 unop->op_first = first;
2743 unop->op_flags = flags | OPf_KIDS;
2744 unop->op_private = 1 | (flags >> 8);
2745 unop = (UNOP*) CHECKOP(type, unop);
2749 return fold_constants((OP *) unop);
2753 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2756 NewOp(1101, binop, 1, BINOP);
2759 first = newOP(OP_NULL, 0);
2761 binop->op_type = type;
2762 binop->op_ppaddr = PL_ppaddr[type];
2763 binop->op_first = first;
2764 binop->op_flags = flags | OPf_KIDS;
2767 binop->op_private = 1 | (flags >> 8);
2770 binop->op_private = 2 | (flags >> 8);
2771 first->op_sibling = last;
2774 binop = (BINOP*)CHECKOP(type, binop);
2775 if (binop->op_next || binop->op_type != type)
2778 binop->op_last = binop->op_first->op_sibling;
2780 return fold_constants((OP *)binop);
2784 uvcompare(const void *a, const void *b)
2786 if (*((UV *)a) < (*(UV *)b))
2788 if (*((UV *)a) > (*(UV *)b))
2790 if (*((UV *)a+1) < (*(UV *)b+1))
2792 if (*((UV *)a+1) > (*(UV *)b+1))
2798 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2800 SV *tstr = ((SVOP*)expr)->op_sv;
2801 SV *rstr = ((SVOP*)repl)->op_sv;
2804 U8 *t = (U8*)SvPV(tstr, tlen);
2805 U8 *r = (U8*)SvPV(rstr, rlen);
2812 register short *tbl;
2814 PL_hints |= HINT_BLOCK_SCOPE;
2815 complement = o->op_private & OPpTRANS_COMPLEMENT;
2816 del = o->op_private & OPpTRANS_DELETE;
2817 squash = o->op_private & OPpTRANS_SQUASH;
2820 o->op_private |= OPpTRANS_FROM_UTF;
2823 o->op_private |= OPpTRANS_TO_UTF;
2825 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2826 SV* listsv = newSVpvn("# comment\n",10);
2828 U8* tend = t + tlen;
2829 U8* rend = r + rlen;
2843 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2844 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2850 tsave = t = bytes_to_utf8(t, &len);
2853 if (!to_utf && rlen) {
2855 rsave = r = bytes_to_utf8(r, &len);
2859 /* There are several snags with this code on EBCDIC:
2860 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2861 2. scan_const() in toke.c has encoded chars in native encoding which makes
2862 ranges at least in EBCDIC 0..255 range the bottom odd.
2866 U8 tmpbuf[UTF8_MAXLEN+1];
2869 New(1109, cp, 2*tlen, UV);
2871 transv = newSVpvn("",0);
2873 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2875 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2877 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2881 cp[2*i+1] = cp[2*i];
2885 qsort(cp, i, 2*sizeof(UV), uvcompare);
2886 for (j = 0; j < i; j++) {
2888 diff = val - nextmin;
2890 t = uvuni_to_utf8(tmpbuf,nextmin);
2891 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2893 U8 range_mark = UTF_TO_NATIVE(0xff);
2894 t = uvuni_to_utf8(tmpbuf, val - 1);
2895 sv_catpvn(transv, (char *)&range_mark, 1);
2896 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2903 t = uvuni_to_utf8(tmpbuf,nextmin);
2904 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2906 U8 range_mark = UTF_TO_NATIVE(0xff);
2907 sv_catpvn(transv, (char *)&range_mark, 1);
2909 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2910 UNICODE_ALLOW_SUPER);
2911 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2912 t = (U8*)SvPVX(transv);
2913 tlen = SvCUR(transv);
2917 else if (!rlen && !del) {
2918 r = t; rlen = tlen; rend = tend;
2921 if ((!rlen && !del) || t == r ||
2922 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2924 o->op_private |= OPpTRANS_IDENTICAL;
2928 while (t < tend || tfirst <= tlast) {
2929 /* see if we need more "t" chars */
2930 if (tfirst > tlast) {
2931 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2933 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2935 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2942 /* now see if we need more "r" chars */
2943 if (rfirst > rlast) {
2945 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2947 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2949 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2958 rfirst = rlast = 0xffffffff;
2962 /* now see which range will peter our first, if either. */
2963 tdiff = tlast - tfirst;
2964 rdiff = rlast - rfirst;
2971 if (rfirst == 0xffffffff) {
2972 diff = tdiff; /* oops, pretend rdiff is infinite */
2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2975 (long)tfirst, (long)tlast);
2977 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2981 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2982 (long)tfirst, (long)(tfirst + diff),
2985 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2986 (long)tfirst, (long)rfirst);
2988 if (rfirst + diff > max)
2989 max = rfirst + diff;
2991 grows = (tfirst < rfirst &&
2992 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3004 else if (max > 0xff)
3009 Safefree(cPVOPo->op_pv);
3010 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3011 SvREFCNT_dec(listsv);
3013 SvREFCNT_dec(transv);
3015 if (!del && havefinal && rlen)
3016 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3017 newSVuv((UV)final), 0);
3020 o->op_private |= OPpTRANS_GROWS;
3032 tbl = (short*)cPVOPo->op_pv;
3034 Zero(tbl, 256, short);
3035 for (i = 0; i < tlen; i++)
3037 for (i = 0, j = 0; i < 256; i++) {
3048 if (i < 128 && r[j] >= 128)
3058 o->op_private |= OPpTRANS_IDENTICAL;
3063 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3064 tbl[0x100] = rlen - j;
3065 for (i=0; i < rlen - j; i++)
3066 tbl[0x101+i] = r[j+i];
3070 if (!rlen && !del) {
3073 o->op_private |= OPpTRANS_IDENTICAL;
3075 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3076 o->op_private |= OPpTRANS_IDENTICAL;
3078 for (i = 0; i < 256; i++)
3080 for (i = 0, j = 0; i < tlen; i++,j++) {
3083 if (tbl[t[i]] == -1)
3089 if (tbl[t[i]] == -1) {
3090 if (t[i] < 128 && r[j] >= 128)
3097 o->op_private |= OPpTRANS_GROWS;
3105 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3109 NewOp(1101, pmop, 1, PMOP);
3110 pmop->op_type = type;
3111 pmop->op_ppaddr = PL_ppaddr[type];
3112 pmop->op_flags = flags;
3113 pmop->op_private = 0 | (flags >> 8);
3115 if (PL_hints & HINT_RE_TAINT)
3116 pmop->op_pmpermflags |= PMf_RETAINT;
3117 if (PL_hints & HINT_LOCALE)
3118 pmop->op_pmpermflags |= PMf_LOCALE;
3119 pmop->op_pmflags = pmop->op_pmpermflags;
3124 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3125 repointer = av_pop((AV*)PL_regex_pad[0]);
3126 pmop->op_pmoffset = SvIV(repointer);
3127 SvREPADTMP_off(repointer);
3128 sv_setiv(repointer,0);
3130 repointer = newSViv(0);
3131 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3132 pmop->op_pmoffset = av_len(PL_regex_padav);
3133 PL_regex_pad = AvARRAY(PL_regex_padav);
3138 /* link into pm list */
3139 if (type != OP_TRANS && PL_curstash) {
3140 pmop->op_pmnext = HvPMROOT(PL_curstash);
3141 HvPMROOT(PL_curstash) = pmop;
3142 PmopSTASH_set(pmop,PL_curstash);
3149 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3153 I32 repl_has_vars = 0;
3155 if (o->op_type == OP_TRANS)
3156 return pmtrans(o, expr, repl);
3158 PL_hints |= HINT_BLOCK_SCOPE;
3161 if (expr->op_type == OP_CONST) {
3163 SV *pat = ((SVOP*)expr)->op_sv;
3164 char *p = SvPV(pat, plen);
3165 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3166 sv_setpvn(pat, "\\s+", 3);
3167 p = SvPV(pat, plen);
3168 pm->op_pmflags |= PMf_SKIPWHITE;
3171 pm->op_pmdynflags |= PMdf_UTF8;
3172 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3173 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3174 pm->op_pmflags |= PMf_WHITE;
3178 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3179 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3181 : OP_REGCMAYBE),0,expr);
3183 NewOp(1101, rcop, 1, LOGOP);
3184 rcop->op_type = OP_REGCOMP;
3185 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3186 rcop->op_first = scalar(expr);
3187 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3188 ? (OPf_SPECIAL | OPf_KIDS)
3190 rcop->op_private = 1;
3193 /* establish postfix order */
3194 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3196 rcop->op_next = expr;
3197 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3200 rcop->op_next = LINKLIST(expr);
3201 expr->op_next = (OP*)rcop;
3204 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3209 if (pm->op_pmflags & PMf_EVAL) {
3211 if (CopLINE(PL_curcop) < PL_multi_end)
3212 CopLINE_set(PL_curcop, PL_multi_end);
3214 #ifdef USE_5005THREADS
3215 else if (repl->op_type == OP_THREADSV
3216 && strchr("&`'123456789+",
3217 PL_threadsv_names[repl->op_targ]))
3221 #endif /* USE_5005THREADS */
3222 else if (repl->op_type == OP_CONST)
3226 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3227 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3228 #ifdef USE_5005THREADS
3229 if (curop->op_type == OP_THREADSV) {
3231 if (strchr("&`'123456789+", curop->op_private))
3235 if (curop->op_type == OP_GV) {
3236 GV *gv = cGVOPx_gv(curop);
3238 if (strchr("&`'123456789+", *GvENAME(gv)))
3241 #endif /* USE_5005THREADS */
3242 else if (curop->op_type == OP_RV2CV)
3244 else if (curop->op_type == OP_RV2SV ||
3245 curop->op_type == OP_RV2AV ||
3246 curop->op_type == OP_RV2HV ||
3247 curop->op_type == OP_RV2GV) {
3248 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3251 else if (curop->op_type == OP_PADSV ||
3252 curop->op_type == OP_PADAV ||
3253 curop->op_type == OP_PADHV ||
3254 curop->op_type == OP_PADANY) {
3257 else if (curop->op_type == OP_PUSHRE)
3258 ; /* Okay here, dangerous in newASSIGNOP */
3268 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3269 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3270 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3271 prepend_elem(o->op_type, scalar(repl), o);
3274 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3275 pm->op_pmflags |= PMf_MAYBE_CONST;
3276 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3278 NewOp(1101, rcop, 1, LOGOP);
3279 rcop->op_type = OP_SUBSTCONT;
3280 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3281 rcop->op_first = scalar(repl);
3282 rcop->op_flags |= OPf_KIDS;
3283 rcop->op_private = 1;
3286 /* establish postfix order */
3287 rcop->op_next = LINKLIST(repl);
3288 repl->op_next = (OP*)rcop;
3290 pm->op_pmreplroot = scalar((OP*)rcop);
3291 pm->op_pmreplstart = LINKLIST(rcop);
3300 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3303 NewOp(1101, svop, 1, SVOP);
3304 svop->op_type = type;
3305 svop->op_ppaddr = PL_ppaddr[type];
3307 svop->op_next = (OP*)svop;
3308 svop->op_flags = flags;
3309 if (PL_opargs[type] & OA_RETSCALAR)
3311 if (PL_opargs[type] & OA_TARGET)
3312 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3313 return CHECKOP(type, svop);
3317 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3320 NewOp(1101, padop, 1, PADOP);
3321 padop->op_type = type;
3322 padop->op_ppaddr = PL_ppaddr[type];
3323 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3324 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3325 PL_curpad[padop->op_padix] = sv;
3327 padop->op_next = (OP*)padop;
3328 padop->op_flags = flags;
3329 if (PL_opargs[type] & OA_RETSCALAR)
3331 if (PL_opargs[type] & OA_TARGET)
3332 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3333 return CHECKOP(type, padop);
3337 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3341 return newPADOP(type, flags, SvREFCNT_inc(gv));
3343 return newSVOP(type, flags, SvREFCNT_inc(gv));
3348 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3351 NewOp(1101, pvop, 1, PVOP);
3352 pvop->op_type = type;
3353 pvop->op_ppaddr = PL_ppaddr[type];
3355 pvop->op_next = (OP*)pvop;
3356 pvop->op_flags = flags;
3357 if (PL_opargs[type] & OA_RETSCALAR)
3359 if (PL_opargs[type] & OA_TARGET)
3360 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3361 return CHECKOP(type, pvop);
3365 Perl_package(pTHX_ OP *o)
3369 save_hptr(&PL_curstash);
3370 save_item(PL_curstname);
3375 name = SvPV(sv, len);
3376 PL_curstash = gv_stashpvn(name,len,TRUE);
3377 sv_setpvn(PL_curstname, name, len);
3381 deprecate("\"package\" with no arguments");
3382 sv_setpv(PL_curstname,"<none>");
3383 PL_curstash = Nullhv;
3385 PL_hints |= HINT_BLOCK_SCOPE;
3386 PL_copline = NOLINE;
3391 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3396 char *packname = Nullch;
3400 if (id->op_type != OP_CONST)
3401 Perl_croak(aTHX_ "Module name must be constant");
3405 if (version != Nullop) {
3406 SV *vesv = ((SVOP*)version)->op_sv;
3408 if (arg == Nullop && !SvNIOKp(vesv)) {
3415 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3416 Perl_croak(aTHX_ "Version number must be constant number");
3418 /* Make copy of id so we don't free it twice */
3419 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3421 /* Fake up a method call to VERSION */
3422 meth = newSVpvn("VERSION",7);
3423 sv_upgrade(meth, SVt_PVIV);
3424 (void)SvIOK_on(meth);
3425 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3426 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3427 append_elem(OP_LIST,
3428 prepend_elem(OP_LIST, pack, list(version)),
3429 newSVOP(OP_METHOD_NAMED, 0, meth)));
3433 /* Fake up an import/unimport */
3434 if (arg && arg->op_type == OP_STUB)
3435 imop = arg; /* no import on explicit () */
3436 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3437 imop = Nullop; /* use 5.0; */
3442 /* Make copy of id so we don't free it twice */
3443 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3445 /* Fake up a method call to import/unimport */
3446 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3447 (void)SvUPGRADE(meth, SVt_PVIV);
3448 (void)SvIOK_on(meth);
3449 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3450 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3451 append_elem(OP_LIST,
3452 prepend_elem(OP_LIST, pack, list(arg)),
3453 newSVOP(OP_METHOD_NAMED, 0, meth)));
3456 if (ckWARN(WARN_MISC) &&
3457 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3458 SvPOK(packsv = ((SVOP*)id)->op_sv))
3460 /* BEGIN will free the ops, so we need to make a copy */
3461 packlen = SvCUR(packsv);
3462 packname = savepvn(SvPVX(packsv), packlen);
3465 /* Fake up the BEGIN {}, which does its thing immediately. */
3467 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3470 append_elem(OP_LINESEQ,
3471 append_elem(OP_LINESEQ,
3472 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3473 newSTATEOP(0, Nullch, veop)),
3474 newSTATEOP(0, Nullch, imop) ));
3477 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3478 Perl_warner(aTHX_ WARN_MISC,
3479 "Package `%s' not found "
3480 "(did you use the incorrect case?)", packname);
3485 PL_hints |= HINT_BLOCK_SCOPE;
3486 PL_copline = NOLINE;
3491 =head1 Embedding Functions
3493 =for apidoc load_module
3495 Loads the module whose name is pointed to by the string part of name.
3496 Note that the actual module name, not its filename, should be given.
3497 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3498 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3499 (or 0 for no flags). ver, if specified, provides version semantics
3500 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3501 arguments can be used to specify arguments to the module's import()
3502 method, similar to C<use Foo::Bar VERSION LIST>.
3507 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3510 va_start(args, ver);
3511 vload_module(flags, name, ver, &args);
3515 #ifdef PERL_IMPLICIT_CONTEXT
3517 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3521 va_start(args, ver);
3522 vload_module(flags, name, ver, &args);
3528 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3530 OP *modname, *veop, *imop;
3532 modname = newSVOP(OP_CONST, 0, name);
3533 modname->op_private |= OPpCONST_BARE;
3535 veop = newSVOP(OP_CONST, 0, ver);
3539 if (flags & PERL_LOADMOD_NOIMPORT) {
3540 imop = sawparens(newNULLLIST());
3542 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3543 imop = va_arg(*args, OP*);
3548 sv = va_arg(*args, SV*);
3550 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3551 sv = va_arg(*args, SV*);
3555 line_t ocopline = PL_copline;
3556 int oexpect = PL_expect;
3558 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3559 veop, modname, imop);
3560 PL_expect = oexpect;
3561 PL_copline = ocopline;
3566 Perl_dofile(pTHX_ OP *term)
3571 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3572 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3573 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3575 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3576 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3577 append_elem(OP_LIST, term,
3578 scalar(newUNOP(OP_RV2CV, 0,
3583 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3589 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3591 return newBINOP(OP_LSLICE, flags,
3592 list(force_list(subscript)),
3593 list(force_list(listval)) );
3597 S_list_assignment(pTHX_ register OP *o)
3602 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3603 o = cUNOPo->op_first;
3605 if (o->op_type == OP_COND_EXPR) {
3606 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3607 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3612 yyerror("Assignment to both a list and a scalar");
3616 if (o->op_type == OP_LIST &&
3617 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3618 o->op_private & OPpLVAL_INTRO)
3621 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3622 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3623 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3626 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3629 if (o->op_type == OP_RV2SV)
3636 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3641 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3642 return newLOGOP(optype, 0,
3643 mod(scalar(left), optype),
3644 newUNOP(OP_SASSIGN, 0, scalar(right)));
3647 return newBINOP(optype, OPf_STACKED,
3648 mod(scalar(left), optype), scalar(right));
3652 if (list_assignment(left)) {
3656 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3657 left = mod(left, OP_AASSIGN);
3665 curop = list(force_list(left));
3666 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3667 o->op_private = 0 | (flags >> 8);
3668 for (curop = ((LISTOP*)curop)->op_first;
3669 curop; curop = curop->op_sibling)
3671 if (curop->op_type == OP_RV2HV &&
3672 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3673 o->op_private |= OPpASSIGN_HASH;
3677 if (!(left->op_private & OPpLVAL_INTRO)) {
3680 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3681 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3682 if (curop->op_type == OP_GV) {
3683 GV *gv = cGVOPx_gv(curop);
3684 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3686 SvCUR(gv) = PL_generation;
3688 else if (curop->op_type == OP_PADSV ||
3689 curop->op_type == OP_PADAV ||
3690 curop->op_type == OP_PADHV ||
3691 curop->op_type == OP_PADANY) {
3692 SV **svp = AvARRAY(PL_comppad_name);
3693 SV *sv = svp[curop->op_targ];
3694 if (SvCUR(sv) == PL_generation)
3696 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3698 else if (curop->op_type == OP_RV2CV)
3700 else if (curop->op_type == OP_RV2SV ||
3701 curop->op_type == OP_RV2AV ||
3702 curop->op_type == OP_RV2HV ||
3703 curop->op_type == OP_RV2GV) {
3704 if (lastop->op_type != OP_GV) /* funny deref? */
3707 else if (curop->op_type == OP_PUSHRE) {
3708 if (((PMOP*)curop)->op_pmreplroot) {
3710 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3712 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3714 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3716 SvCUR(gv) = PL_generation;
3725 o->op_private |= OPpASSIGN_COMMON;
3727 if (right && right->op_type == OP_SPLIT) {
3729 if ((tmpop = ((LISTOP*)right)->op_first) &&
3730 tmpop->op_type == OP_PUSHRE)
3732 PMOP *pm = (PMOP*)tmpop;
3733 if (left->op_type == OP_RV2AV &&
3734 !(left->op_private & OPpLVAL_INTRO) &&
3735 !(o->op_private & OPpASSIGN_COMMON) )
3737 tmpop = ((UNOP*)left)->op_first;
3738 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3740 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3741 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3743 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3744 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3746 pm->op_pmflags |= PMf_ONCE;
3747 tmpop = cUNOPo->op_first; /* to list (nulled) */
3748 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3749 tmpop->op_sibling = Nullop; /* don't free split */
3750 right->op_next = tmpop->op_next; /* fix starting loc */
3751 op_free(o); /* blow off assign */
3752 right->op_flags &= ~OPf_WANT;
3753 /* "I don't know and I don't care." */
3758 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3759 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3761 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3763 sv_setiv(sv, PL_modcount+1);
3771 right = newOP(OP_UNDEF, 0);
3772 if (right->op_type == OP_READLINE) {
3773 right->op_flags |= OPf_STACKED;
3774 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3777 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3778 o = newBINOP(OP_SASSIGN, flags,
3779 scalar(right), mod(scalar(left), OP_SASSIGN) );
3791 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3793 U32 seq = intro_my();
3796 NewOp(1101, cop, 1, COP);
3797 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3798 cop->op_type = OP_DBSTATE;
3799 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3802 cop->op_type = OP_NEXTSTATE;
3803 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3805 cop->op_flags = flags;
3806 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3808 cop->op_private |= NATIVE_HINTS;
3810 PL_compiling.op_private = cop->op_private;
3811 cop->op_next = (OP*)cop;
3814 cop->cop_label = label;
3815 PL_hints |= HINT_BLOCK_SCOPE;
3818 cop->cop_arybase = PL_curcop->cop_arybase;
3819 if (specialWARN(PL_curcop->cop_warnings))
3820 cop->cop_warnings = PL_curcop->cop_warnings ;
3822 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3823 if (specialCopIO(PL_curcop->cop_io))
3824 cop->cop_io = PL_curcop->cop_io;
3826 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3829 if (PL_copline == NOLINE)
3830 CopLINE_set(cop, CopLINE(PL_curcop));
3832 CopLINE_set(cop, PL_copline);
3833 PL_copline = NOLINE;
3836 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3838 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3840 CopSTASH_set(cop, PL_curstash);
3842 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3843 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3844 if (svp && *svp != &PL_sv_undef ) {
3845 (void)SvIOK_on(*svp);
3846 SvIVX(*svp) = PTR2IV(cop);
3850 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3853 /* "Introduce" my variables to visible status. */
3861 if (! PL_min_intro_pending)
3862 return PL_cop_seqmax;
3864 svp = AvARRAY(PL_comppad_name);
3865 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3866 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3867 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3868 SvNVX(sv) = (NV)PL_cop_seqmax;
3871 PL_min_intro_pending = 0;
3872 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3873 return PL_cop_seqmax++;
3877 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3879 return new_logop(type, flags, &first, &other);
3883 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3887 OP *first = *firstp;
3888 OP *other = *otherp;
3890 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3891 return newBINOP(type, flags, scalar(first), scalar(other));
3893 scalarboolean(first);
3894 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3895 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3896 if (type == OP_AND || type == OP_OR) {
3902 first = *firstp = cUNOPo->op_first;
3904 first->op_next = o->op_next;
3905 cUNOPo->op_first = Nullop;
3909 if (first->op_type == OP_CONST) {
3910 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3911 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3912 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3923 else if (first->op_type == OP_WANTARRAY) {
3929 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3930 OP *k1 = ((UNOP*)first)->op_first;
3931 OP *k2 = k1->op_sibling;
3933 switch (first->op_type)
3936 if (k2 && k2->op_type == OP_READLINE
3937 && (k2->op_flags & OPf_STACKED)
3938 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3940 warnop = k2->op_type;
3945 if (k1->op_type == OP_READDIR
3946 || k1->op_type == OP_GLOB
3947 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3948 || k1->op_type == OP_EACH)
3950 warnop = ((k1->op_type == OP_NULL)
3951 ? k1->op_targ : k1->op_type);
3956 line_t oldline = CopLINE(PL_curcop);
3957 CopLINE_set(PL_curcop, PL_copline);
3958 Perl_warner(aTHX_ WARN_MISC,
3959 "Value of %s%s can be \"0\"; test with defined()",
3961 ((warnop == OP_READLINE || warnop == OP_GLOB)
3962 ? " construct" : "() operator"));
3963 CopLINE_set(PL_curcop, oldline);
3970 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3971 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3973 NewOp(1101, logop, 1, LOGOP);
3975 logop->op_type = type;
3976 logop->op_ppaddr = PL_ppaddr[type];
3977 logop->op_first = first;
3978 logop->op_flags = flags | OPf_KIDS;
3979 logop->op_other = LINKLIST(other);
3980 logop->op_private = 1 | (flags >> 8);
3982 /* establish postfix order */
3983 logop->op_next = LINKLIST(first);
3984 first->op_next = (OP*)logop;
3985 first->op_sibling = other;
3987 o = newUNOP(OP_NULL, 0, (OP*)logop);
3994 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4001 return newLOGOP(OP_AND, 0, first, trueop);
4003 return newLOGOP(OP_OR, 0, first, falseop);
4005 scalarboolean(first);
4006 if (first->op_type == OP_CONST) {
4007 if (SvTRUE(((SVOP*)first)->op_sv)) {
4018 else if (first->op_type == OP_WANTARRAY) {
4022 NewOp(1101, logop, 1, LOGOP);
4023 logop->op_type = OP_COND_EXPR;
4024 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4025 logop->op_first = first;
4026 logop->op_flags = flags | OPf_KIDS;
4027 logop->op_private = 1 | (flags >> 8);
4028 logop->op_other = LINKLIST(trueop);
4029 logop->op_next = LINKLIST(falseop);
4032 /* establish postfix order */
4033 start = LINKLIST(first);
4034 first->op_next = (OP*)logop;
4036 first->op_sibling = trueop;
4037 trueop->op_sibling = falseop;
4038 o = newUNOP(OP_NULL, 0, (OP*)logop);
4040 trueop->op_next = falseop->op_next = o;
4047 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4055 NewOp(1101, range, 1, LOGOP);
4057 range->op_type = OP_RANGE;
4058 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4059 range->op_first = left;
4060 range->op_flags = OPf_KIDS;
4061 leftstart = LINKLIST(left);
4062 range->op_other = LINKLIST(right);
4063 range->op_private = 1 | (flags >> 8);
4065 left->op_sibling = right;
4067 range->op_next = (OP*)range;
4068 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4069 flop = newUNOP(OP_FLOP, 0, flip);
4070 o = newUNOP(OP_NULL, 0, flop);
4072 range->op_next = leftstart;
4074 left->op_next = flip;
4075 right->op_next = flop;
4077 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4078 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4079 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4080 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4082 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4083 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4086 if (!flip->op_private || !flop->op_private)
4087 linklist(o); /* blow off optimizer unless constant */
4093 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4097 int once = block && block->op_flags & OPf_SPECIAL &&
4098 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4101 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4102 return block; /* do {} while 0 does once */
4103 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4104 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4105 expr = newUNOP(OP_DEFINED, 0,
4106 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4107 } else if (expr->op_flags & OPf_KIDS) {
4108 OP *k1 = ((UNOP*)expr)->op_first;
4109 OP *k2 = (k1) ? k1->op_sibling : NULL;
4110 switch (expr->op_type) {
4112 if (k2 && k2->op_type == OP_READLINE
4113 && (k2->op_flags & OPf_STACKED)
4114 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4115 expr = newUNOP(OP_DEFINED, 0, expr);
4119 if (k1->op_type == OP_READDIR
4120 || k1->op_type == OP_GLOB
4121 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4122 || k1->op_type == OP_EACH)
4123 expr = newUNOP(OP_DEFINED, 0, expr);
4129 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4130 o = new_logop(OP_AND, 0, &expr, &listop);
4133 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4135 if (once && o != listop)
4136 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4139 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4141 o->op_flags |= flags;
4143 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4148 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4156 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4157 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4158 expr = newUNOP(OP_DEFINED, 0,
4159 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4160 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4161 OP *k1 = ((UNOP*)expr)->op_first;
4162 OP *k2 = (k1) ? k1->op_sibling : NULL;
4163 switch (expr->op_type) {
4165 if (k2 && k2->op_type == OP_READLINE
4166 && (k2->op_flags & OPf_STACKED)
4167 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4168 expr = newUNOP(OP_DEFINED, 0, expr);
4172 if (k1->op_type == OP_READDIR
4173 || k1->op_type == OP_GLOB
4174 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4175 || k1->op_type == OP_EACH)
4176 expr = newUNOP(OP_DEFINED, 0, expr);
4182 block = newOP(OP_NULL, 0);
4184 block = scope(block);
4188 next = LINKLIST(cont);
4191 OP *unstack = newOP(OP_UNSTACK, 0);
4194 cont = append_elem(OP_LINESEQ, cont, unstack);
4195 if ((line_t)whileline != NOLINE) {
4196 PL_copline = whileline;
4197 cont = append_elem(OP_LINESEQ, cont,
4198 newSTATEOP(0, Nullch, Nullop));
4202 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4203 redo = LINKLIST(listop);
4206 PL_copline = whileline;
4208 o = new_logop(OP_AND, 0, &expr, &listop);
4209 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4210 op_free(expr); /* oops, it's a while (0) */
4212 return Nullop; /* listop already freed by new_logop */
4215 ((LISTOP*)listop)->op_last->op_next =
4216 (o == listop ? redo : LINKLIST(o));
4222 NewOp(1101,loop,1,LOOP);
4223 loop->op_type = OP_ENTERLOOP;
4224 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4225 loop->op_private = 0;
4226 loop->op_next = (OP*)loop;
4229 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4231 loop->op_redoop = redo;
4232 loop->op_lastop = o;
4233 o->op_private |= loopflags;
4236 loop->op_nextop = next;
4238 loop->op_nextop = o;
4240 o->op_flags |= flags;
4241 o->op_private |= (flags >> 8);
4246 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4254 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4255 sv->op_type = OP_RV2GV;
4256 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4258 else if (sv->op_type == OP_PADSV) { /* private variable */
4259 padoff = sv->op_targ;
4264 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4265 padoff = sv->op_targ;
4267 iterflags |= OPf_SPECIAL;
4272 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4275 #ifdef USE_5005THREADS
4276 padoff = find_threadsv("_");
4277 iterflags |= OPf_SPECIAL;
4279 sv = newGVOP(OP_GV, 0, PL_defgv);
4282 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4283 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4284 iterflags |= OPf_STACKED;
4286 else if (expr->op_type == OP_NULL &&
4287 (expr->op_flags & OPf_KIDS) &&
4288 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4290 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4291 * set the STACKED flag to indicate that these values are to be
4292 * treated as min/max values by 'pp_iterinit'.
4294 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4295 LOGOP* range = (LOGOP*) flip->op_first;
4296 OP* left = range->op_first;
4297 OP* right = left->op_sibling;
4300 range->op_flags &= ~OPf_KIDS;
4301 range->op_first = Nullop;
4303 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4304 listop->op_first->op_next = range->op_next;
4305 left->op_next = range->op_other;
4306 right->op_next = (OP*)listop;
4307 listop->op_next = listop->op_first;
4310 expr = (OP*)(listop);
4312 iterflags |= OPf_STACKED;
4315 expr = mod(force_list(expr), OP_GREPSTART);
4319 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4320 append_elem(OP_LIST, expr, scalar(sv))));
4321 assert(!loop->op_next);
4322 #ifdef PL_OP_SLAB_ALLOC
4325 NewOp(1234,tmp,1,LOOP);
4326 Copy(loop,tmp,1,LOOP);
4331 Renew(loop, 1, LOOP);
4333 loop->op_targ = padoff;
4334 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4335 PL_copline = forline;
4336 return newSTATEOP(0, label, wop);
4340 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4345 if (type != OP_GOTO || label->op_type == OP_CONST) {
4346 /* "last()" means "last" */
4347 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4348 o = newOP(type, OPf_SPECIAL);
4350 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4351 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4357 if (label->op_type == OP_ENTERSUB)
4358 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4359 o = newUNOP(type, OPf_STACKED, label);
4361 PL_hints |= HINT_BLOCK_SCOPE;
4366 Perl_cv_undef(pTHX_ CV *cv)
4369 CV *freecv = Nullcv;
4370 bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */
4372 #ifdef USE_5005THREADS
4374 MUTEX_DESTROY(CvMUTEXP(cv));
4375 Safefree(CvMUTEXP(cv));
4378 #endif /* USE_5005THREADS */
4381 if (CvFILE(cv) && !CvXSUB(cv)) {
4382 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4383 Safefree(CvFILE(cv));
4388 if (!CvXSUB(cv) && CvROOT(cv)) {
4389 #ifdef USE_5005THREADS
4390 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4391 Perl_croak(aTHX_ "Can't undef active subroutine");
4394 Perl_croak(aTHX_ "Can't undef active subroutine");
4395 #endif /* USE_5005THREADS */
4398 SAVEVPTR(PL_curpad);
4401 op_free(CvROOT(cv));
4402 CvROOT(cv) = Nullop;
4405 SvPOK_off((SV*)cv); /* forget prototype */
4407 outsidecv = CvOUTSIDE(cv);
4408 /* Since closure prototypes have the same lifetime as the containing
4409 * CV, they don't hold a refcount on the outside CV. This avoids
4410 * the refcount loop between the outer CV (which keeps a refcount to
4411 * the closure prototype in the pad entry for pp_anoncode()) and the
4412 * closure prototype, and the ensuing memory leak. --GSAR */
4413 if (!CvANON(cv) || CvCLONED(cv))
4415 CvOUTSIDE(cv) = Nullcv;
4417 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4420 if (CvPADLIST(cv)) {
4421 /* may be during global destruction */
4422 if (SvREFCNT(CvPADLIST(cv))) {
4423 AV *padlist = CvPADLIST(cv);
4426 /* inner references to eval's cv must be fixed up */
4427 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4428 AV *comppad = (AV*)AvARRAY(padlist)[1];
4429 SV **namepad = AvARRAY(comppad_name);
4430 SV **curpad = AvARRAY(comppad);
4431 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4432 SV *namesv = namepad[ix];
4433 if (namesv && namesv != &PL_sv_undef
4434 && *SvPVX(namesv) == '&'
4435 && ix <= AvFILLp(comppad))
4437 CV *innercv = (CV*)curpad[ix];
4438 if (innercv && SvTYPE(innercv) == SVt_PVCV
4439 && CvOUTSIDE(innercv) == cv)
4441 CvOUTSIDE(innercv) = outsidecv;
4442 if (!CvANON(innercv) || CvCLONED(innercv)) {
4443 (void)SvREFCNT_inc(outsidecv);
4452 SvREFCNT_dec(freecv);
4453 ix = AvFILLp(padlist);
4455 SV* sv = AvARRAY(padlist)[ix--];
4458 if (sv == (SV*)PL_comppad_name)
4459 PL_comppad_name = Nullav;
4460 else if (sv == (SV*)PL_comppad) {
4461 PL_comppad = Nullav;
4462 PL_curpad = Null(SV**);
4466 SvREFCNT_dec((SV*)CvPADLIST(cv));
4468 CvPADLIST(cv) = Nullav;
4471 SvREFCNT_dec(freecv);
4478 #ifdef DEBUG_CLOSURES
4480 S_cv_dump(pTHX_ CV *cv)
4483 CV *outside = CvOUTSIDE(cv);
4484 AV* padlist = CvPADLIST(cv);
4491 PerlIO_printf(Perl_debug_log,
4492 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4494 (CvANON(cv) ? "ANON"
4495 : (cv == PL_main_cv) ? "MAIN"
4496 : CvUNIQUE(cv) ? "UNIQUE"
4497 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4500 : CvANON(outside) ? "ANON"
4501 : (outside == PL_main_cv) ? "MAIN"
4502 : CvUNIQUE(outside) ? "UNIQUE"
4503 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4508 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4509 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4510 pname = AvARRAY(pad_name);
4511 ppad = AvARRAY(pad);
4513 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4514 if (SvPOK(pname[ix]))
4515 PerlIO_printf(Perl_debug_log,
4516 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4517 (int)ix, PTR2UV(ppad[ix]),
4518 SvFAKE(pname[ix]) ? "FAKE " : "",
4520 (IV)I_32(SvNVX(pname[ix])),
4523 #endif /* DEBUGGING */
4525 #endif /* DEBUG_CLOSURES */
4528 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4532 AV* protopadlist = CvPADLIST(proto);
4533 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4534 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4535 SV** pname = AvARRAY(protopad_name);
4536 SV** ppad = AvARRAY(protopad);
4537 I32 fname = AvFILLp(protopad_name);
4538 I32 fpad = AvFILLp(protopad);
4542 assert(!CvUNIQUE(proto));
4546 SAVESPTR(PL_comppad_name);
4547 SAVESPTR(PL_compcv);
4549 cv = PL_compcv = (CV*)NEWSV(1104,0);
4550 sv_upgrade((SV *)cv, SvTYPE(proto));
4551 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4554 #ifdef USE_5005THREADS
4555 New(666, CvMUTEXP(cv), 1, perl_mutex);
4556 MUTEX_INIT(CvMUTEXP(cv));
4558 #endif /* USE_5005THREADS */
4560 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4561 : savepv(CvFILE(proto));
4563 CvFILE(cv) = CvFILE(proto);
4565 CvGV(cv) = CvGV(proto);
4566 CvSTASH(cv) = CvSTASH(proto);
4567 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4568 CvSTART(cv) = CvSTART(proto);
4570 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4573 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4575 PL_comppad_name = newAV();
4576 for (ix = fname; ix >= 0; ix--)
4577 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4579 PL_comppad = newAV();
4581 comppadlist = newAV();
4582 AvREAL_off(comppadlist);
4583 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4584 av_store(comppadlist, 1, (SV*)PL_comppad);
4585 CvPADLIST(cv) = comppadlist;
4586 av_fill(PL_comppad, AvFILLp(protopad));
4587 PL_curpad = AvARRAY(PL_comppad);
4589 av = newAV(); /* will be @_ */
4591 av_store(PL_comppad, 0, (SV*)av);
4592 AvFLAGS(av) = AVf_REIFY;
4594 for (ix = fpad; ix > 0; ix--) {
4595 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4596 if (namesv && namesv != &PL_sv_undef) {
4597 char *name = SvPVX(namesv); /* XXX */
4598 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4599 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4600 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4602 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4604 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4606 else { /* our own lexical */
4609 /* anon code -- we'll come back for it */
4610 sv = SvREFCNT_inc(ppad[ix]);
4612 else if (*name == '@')
4614 else if (*name == '%')
4623 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4624 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4627 SV* sv = NEWSV(0,0);
4633 /* Now that vars are all in place, clone nested closures. */
4635 for (ix = fpad; ix > 0; ix--) {
4636 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4638 && namesv != &PL_sv_undef
4639 && !(SvFLAGS(namesv) & SVf_FAKE)
4640 && *SvPVX(namesv) == '&'
4641 && CvCLONE(ppad[ix]))
4643 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4644 SvREFCNT_dec(ppad[ix]);
4647 PL_curpad[ix] = (SV*)kid;
4651 #ifdef DEBUG_CLOSURES
4652 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4654 PerlIO_printf(Perl_debug_log, " from:\n");
4656 PerlIO_printf(Perl_debug_log, " to:\n");
4663 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4665 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4667 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4674 Perl_cv_clone(pTHX_ CV *proto)
4677 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4678 cv = cv_clone2(proto, CvOUTSIDE(proto));
4679 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4684 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4686 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4687 SV* msg = sv_newmortal();
4691 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4692 sv_setpv(msg, "Prototype mismatch:");
4694 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4696 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4697 sv_catpv(msg, " vs ");
4699 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4701 sv_catpv(msg, "none");
4702 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4706 static void const_sv_xsub(pTHX_ CV* cv);
4710 =head1 Optree Manipulation Functions
4712 =for apidoc cv_const_sv
4714 If C<cv> is a constant sub eligible for inlining. returns the constant
4715 value returned by the sub. Otherwise, returns NULL.
4717 Constant subs can be created with C<newCONSTSUB> or as described in
4718 L<perlsub/"Constant Functions">.
4723 Perl_cv_const_sv(pTHX_ CV *cv)
4725 if (!cv || !CvCONST(cv))
4727 return (SV*)CvXSUBANY(cv).any_ptr;
4731 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4738 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4739 o = cLISTOPo->op_first->op_sibling;
4741 for (; o; o = o->op_next) {
4742 OPCODE type = o->op_type;
4744 if (sv && o->op_next == o)
4746 if (o->op_next != o) {
4747 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4749 if (type == OP_DBSTATE)
4752 if (type == OP_LEAVESUB || type == OP_RETURN)
4756 if (type == OP_CONST && cSVOPo->op_sv)
4758 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4759 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4760 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4764 /* We get here only from cv_clone2() while creating a closure.
4765 Copy the const value here instead of in cv_clone2 so that
4766 SvREADONLY_on doesn't lead to problems when leaving
4771 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4783 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4793 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4797 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4799 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4803 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4809 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4814 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4815 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4816 SV *sv = sv_newmortal();
4817 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4818 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4823 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4824 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4834 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4835 maximum a prototype before. */
4836 if (SvTYPE(gv) > SVt_NULL) {
4837 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4838 && ckWARN_d(WARN_PROTOTYPE))
4840 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4842 cv_ckproto((CV*)gv, NULL, ps);
4845 sv_setpv((SV*)gv, ps);
4847 sv_setiv((SV*)gv, -1);
4848 SvREFCNT_dec(PL_compcv);
4849 cv = PL_compcv = NULL;
4850 PL_sub_generation++;
4854 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4856 #ifdef GV_UNIQUE_CHECK
4857 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4858 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4862 if (!block || !ps || *ps || attrs)
4865 const_sv = op_const_sv(block, Nullcv);
4868 bool exists = CvROOT(cv) || CvXSUB(cv);
4870 #ifdef GV_UNIQUE_CHECK
4871 if (exists && GvUNIQUE(gv)) {
4872 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4876 /* if the subroutine doesn't exist and wasn't pre-declared
4877 * with a prototype, assume it will be AUTOLOADed,
4878 * skipping the prototype check
4880 if (exists || SvPOK(cv))
4881 cv_ckproto(cv, gv, ps);
4882 /* already defined (or promised)? */
4883 if (exists || GvASSUMECV(gv)) {
4884 if (!block && !attrs) {
4885 /* just a "sub foo;" when &foo is already defined */
4886 SAVEFREESV(PL_compcv);
4889 /* ahem, death to those who redefine active sort subs */
4890 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4891 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4893 if (ckWARN(WARN_REDEFINE)
4895 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4897 line_t oldline = CopLINE(PL_curcop);
4898 if (PL_copline != NOLINE)
4899 CopLINE_set(PL_curcop, PL_copline);
4900 Perl_warner(aTHX_ WARN_REDEFINE,
4901 CvCONST(cv) ? "Constant subroutine %s redefined"
4902 : "Subroutine %s redefined", name);
4903 CopLINE_set(PL_curcop, oldline);
4911 SvREFCNT_inc(const_sv);
4913 assert(!CvROOT(cv) && !CvCONST(cv));
4914 sv_setpv((SV*)cv, ""); /* prototype is "" */
4915 CvXSUBANY(cv).any_ptr = const_sv;
4916 CvXSUB(cv) = const_sv_xsub;
4921 cv = newCONSTSUB(NULL, name, const_sv);
4924 SvREFCNT_dec(PL_compcv);
4926 PL_sub_generation++;
4933 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4934 * before we clobber PL_compcv.
4938 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4939 stash = GvSTASH(CvGV(cv));
4940 else if (CvSTASH(cv))
4941 stash = CvSTASH(cv);
4943 stash = PL_curstash;
4946 /* possibly about to re-define existing subr -- ignore old cv */
4947 rcv = (SV*)PL_compcv;
4948 if (name && GvSTASH(gv))
4949 stash = GvSTASH(gv);
4951 stash = PL_curstash;
4953 apply_attrs(stash, rcv, attrs, FALSE);
4955 if (cv) { /* must reuse cv if autoloaded */
4957 /* got here with just attrs -- work done, so bug out */
4958 SAVEFREESV(PL_compcv);
4962 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4963 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4964 CvOUTSIDE(PL_compcv) = 0;
4965 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4966 CvPADLIST(PL_compcv) = 0;
4967 /* inner references to PL_compcv must be fixed up ... */
4969 AV *padlist = CvPADLIST(cv);
4970 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4971 AV *comppad = (AV*)AvARRAY(padlist)[1];
4972 SV **namepad = AvARRAY(comppad_name);
4973 SV **curpad = AvARRAY(comppad);
4974 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4975 SV *namesv = namepad[ix];
4976 if (namesv && namesv != &PL_sv_undef
4977 && *SvPVX(namesv) == '&')
4979 CV *innercv = (CV*)curpad[ix];
4980 if (CvOUTSIDE(innercv) == PL_compcv) {
4981 CvOUTSIDE(innercv) = cv;
4982 if (!CvANON(innercv) || CvCLONED(innercv)) {
4983 (void)SvREFCNT_inc(cv);
4984 SvREFCNT_dec(PL_compcv);
4990 /* ... before we throw it away */
4991 SvREFCNT_dec(PL_compcv);
4992 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4993 ++PL_sub_generation;
5000 PL_sub_generation++;
5004 CvFILE_set_from_cop(cv, PL_curcop);
5005 CvSTASH(cv) = PL_curstash;
5006 #ifdef USE_5005THREADS
5008 if (!CvMUTEXP(cv)) {
5009 New(666, CvMUTEXP(cv), 1, perl_mutex);
5010 MUTEX_INIT(CvMUTEXP(cv));
5012 #endif /* USE_5005THREADS */
5015 sv_setpv((SV*)cv, ps);
5017 if (PL_error_count) {
5021 char *s = strrchr(name, ':');
5023 if (strEQ(s, "BEGIN")) {
5025 "BEGIN not safe after errors--compilation aborted";
5026 if (PL_in_eval & EVAL_KEEPERR)
5027 Perl_croak(aTHX_ not_safe);
5029 /* force display of errors found but not reported */
5030 sv_catpv(ERRSV, not_safe);
5031 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
5039 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5040 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5043 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5044 mod(scalarseq(block), OP_LEAVESUBLV));
5047 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5049 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5050 OpREFCNT_set(CvROOT(cv), 1);
5051 CvSTART(cv) = LINKLIST(CvROOT(cv));
5052 CvROOT(cv)->op_next = 0;
5053 CALL_PEEP(CvSTART(cv));
5055 /* now that optimizer has done its work, adjust pad values */
5057 SV **namep = AvARRAY(PL_comppad_name);
5058 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5061 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5064 * The only things that a clonable function needs in its
5065 * pad are references to outer lexicals and anonymous subs.
5066 * The rest are created anew during cloning.
5068 if (!((namesv = namep[ix]) != Nullsv &&
5069 namesv != &PL_sv_undef &&
5071 *SvPVX(namesv) == '&')))
5073 SvREFCNT_dec(PL_curpad[ix]);
5074 PL_curpad[ix] = Nullsv;
5077 assert(!CvCONST(cv));
5078 if (ps && !*ps && op_const_sv(block, cv))
5082 AV *av = newAV(); /* Will be @_ */
5084 av_store(PL_comppad, 0, (SV*)av);
5085 AvFLAGS(av) = AVf_REIFY;
5087 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5088 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5090 if (!SvPADMY(PL_curpad[ix]))
5091 SvPADTMP_on(PL_curpad[ix]);
5095 /* If a potential closure prototype, don't keep a refcount on outer CV.
5096 * This is okay as the lifetime of the prototype is tied to the
5097 * lifetime of the outer CV. Avoids memory leak due to reference
5100 SvREFCNT_dec(CvOUTSIDE(cv));
5102 if (name || aname) {
5104 char *tname = (name ? name : aname);
5106 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5107 SV *sv = NEWSV(0,0);
5108 SV *tmpstr = sv_newmortal();
5109 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5113 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5115 (long)PL_subline, (long)CopLINE(PL_curcop));
5116 gv_efullname3(tmpstr, gv, Nullch);
5117 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5118 hv = GvHVn(db_postponed);
5119 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5120 && (pcv = GvCV(db_postponed)))
5126 call_sv((SV*)pcv, G_DISCARD);
5130 if ((s = strrchr(tname,':')))
5135 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5138 if (strEQ(s, "BEGIN")) {
5139 I32 oldscope = PL_scopestack_ix;
5141 SAVECOPFILE(&PL_compiling);
5142 SAVECOPLINE(&PL_compiling);
5145 PL_beginav = newAV();
5146 DEBUG_x( dump_sub(gv) );
5147 av_push(PL_beginav, (SV*)cv);
5148 GvCV(gv) = 0; /* cv has been hijacked */
5149 call_list(oldscope, PL_beginav);
5151 PL_curcop = &PL_compiling;
5152 PL_compiling.op_private = PL_hints;
5155 else if (strEQ(s, "END") && !PL_error_count) {
5158 DEBUG_x( dump_sub(gv) );
5159 av_unshift(PL_endav, 1);
5160 av_store(PL_endav, 0, (SV*)cv);
5161 GvCV(gv) = 0; /* cv has been hijacked */
5163 else if (strEQ(s, "CHECK") && !PL_error_count) {
5165 PL_checkav = newAV();
5166 DEBUG_x( dump_sub(gv) );
5167 if (PL_main_start && ckWARN(WARN_VOID))
5168 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5169 av_unshift(PL_checkav, 1);
5170 av_store(PL_checkav, 0, (SV*)cv);
5171 GvCV(gv) = 0; /* cv has been hijacked */
5173 else if (strEQ(s, "INIT") && !PL_error_count) {
5175 PL_initav = newAV();
5176 DEBUG_x( dump_sub(gv) );
5177 if (PL_main_start && ckWARN(WARN_VOID))
5178 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5179 av_push(PL_initav, (SV*)cv);
5180 GvCV(gv) = 0; /* cv has been hijacked */
5185 PL_copline = NOLINE;
5190 /* XXX unsafe for threads if eval_owner isn't held */
5192 =for apidoc newCONSTSUB
5194 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5195 eligible for inlining at compile-time.
5201 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5207 SAVECOPLINE(PL_curcop);
5208 CopLINE_set(PL_curcop, PL_copline);
5211 PL_hints &= ~HINT_BLOCK_SCOPE;
5214 SAVESPTR(PL_curstash);
5215 SAVECOPSTASH(PL_curcop);
5216 PL_curstash = stash;
5217 CopSTASH_set(PL_curcop,stash);
5220 cv = newXS(name, const_sv_xsub, __FILE__);
5221 CvXSUBANY(cv).any_ptr = sv;
5223 sv_setpv((SV*)cv, ""); /* prototype is "" */
5231 =for apidoc U||newXS
5233 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5239 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5241 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5244 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5246 /* just a cached method */
5250 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5251 /* already defined (or promised) */
5252 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5253 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5254 line_t oldline = CopLINE(PL_curcop);
5255 if (PL_copline != NOLINE)
5256 CopLINE_set(PL_curcop, PL_copline);
5257 Perl_warner(aTHX_ WARN_REDEFINE,
5258 CvCONST(cv) ? "Constant subroutine %s redefined"
5259 : "Subroutine %s redefined"
5261 CopLINE_set(PL_curcop, oldline);
5268 if (cv) /* must reuse cv if autoloaded */
5271 cv = (CV*)NEWSV(1105,0);
5272 sv_upgrade((SV *)cv, SVt_PVCV);
5276 PL_sub_generation++;
5280 #ifdef USE_5005THREADS
5281 New(666, CvMUTEXP(cv), 1, perl_mutex);
5282 MUTEX_INIT(CvMUTEXP(cv));
5284 #endif /* USE_5005THREADS */
5285 (void)gv_fetchfile(filename);
5286 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5287 an external constant string */
5288 CvXSUB(cv) = subaddr;
5291 char *s = strrchr(name,':');
5297 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5300 if (strEQ(s, "BEGIN")) {
5302 PL_beginav = newAV();
5303 av_push(PL_beginav, (SV*)cv);
5304 GvCV(gv) = 0; /* cv has been hijacked */
5306 else if (strEQ(s, "END")) {
5309 av_unshift(PL_endav, 1);
5310 av_store(PL_endav, 0, (SV*)cv);
5311 GvCV(gv) = 0; /* cv has been hijacked */
5313 else if (strEQ(s, "CHECK")) {
5315 PL_checkav = newAV();
5316 if (PL_main_start && ckWARN(WARN_VOID))
5317 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5318 av_unshift(PL_checkav, 1);
5319 av_store(PL_checkav, 0, (SV*)cv);
5320 GvCV(gv) = 0; /* cv has been hijacked */
5322 else if (strEQ(s, "INIT")) {
5324 PL_initav = newAV();
5325 if (PL_main_start && ckWARN(WARN_VOID))
5326 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5327 av_push(PL_initav, (SV*)cv);
5328 GvCV(gv) = 0; /* cv has been hijacked */
5339 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5348 name = SvPVx(cSVOPo->op_sv, n_a);
5351 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5352 #ifdef GV_UNIQUE_CHECK
5354 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5358 if ((cv = GvFORM(gv))) {
5359 if (ckWARN(WARN_REDEFINE)) {
5360 line_t oldline = CopLINE(PL_curcop);
5361 if (PL_copline != NOLINE)
5362 CopLINE_set(PL_curcop, PL_copline);
5363 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5364 CopLINE_set(PL_curcop, oldline);
5371 CvFILE_set_from_cop(cv, PL_curcop);
5373 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5374 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5375 SvPADTMP_on(PL_curpad[ix]);
5378 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5379 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5380 OpREFCNT_set(CvROOT(cv), 1);
5381 CvSTART(cv) = LINKLIST(CvROOT(cv));
5382 CvROOT(cv)->op_next = 0;
5383 CALL_PEEP(CvSTART(cv));
5385 PL_copline = NOLINE;
5390 Perl_newANONLIST(pTHX_ OP *o)
5392 return newUNOP(OP_REFGEN, 0,
5393 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5397 Perl_newANONHASH(pTHX_ OP *o)
5399 return newUNOP(OP_REFGEN, 0,
5400 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5404 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5406 return newANONATTRSUB(floor, proto, Nullop, block);
5410 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5412 return newUNOP(OP_REFGEN, 0,
5413 newSVOP(OP_ANONCODE, 0,
5414 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5418 Perl_oopsAV(pTHX_ OP *o)
5420 switch (o->op_type) {
5422 o->op_type = OP_PADAV;
5423 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5424 return ref(o, OP_RV2AV);
5427 o->op_type = OP_RV2AV;
5428 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5433 if (ckWARN_d(WARN_INTERNAL))
5434 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5441 Perl_oopsHV(pTHX_ OP *o)
5443 switch (o->op_type) {
5446 o->op_type = OP_PADHV;
5447 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5448 return ref(o, OP_RV2HV);
5452 o->op_type = OP_RV2HV;
5453 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5458 if (ckWARN_d(WARN_INTERNAL))
5459 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5466 Perl_newAVREF(pTHX_ OP *o)
5468 if (o->op_type == OP_PADANY) {
5469 o->op_type = OP_PADAV;
5470 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5473 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5474 && ckWARN(WARN_DEPRECATED)) {
5475 Perl_warner(aTHX_ WARN_DEPRECATED,
5476 "Using an array as a reference is deprecated");
5478 return newUNOP(OP_RV2AV, 0, scalar(o));
5482 Perl_newGVREF(pTHX_ I32 type, OP *o)
5484 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5485 return newUNOP(OP_NULL, 0, o);
5486 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5490 Perl_newHVREF(pTHX_ OP *o)
5492 if (o->op_type == OP_PADANY) {
5493 o->op_type = OP_PADHV;
5494 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5497 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5498 && ckWARN(WARN_DEPRECATED)) {
5499 Perl_warner(aTHX_ WARN_DEPRECATED,
5500 "Using a hash as a reference is deprecated");
5502 return newUNOP(OP_RV2HV, 0, scalar(o));
5506 Perl_oopsCV(pTHX_ OP *o)
5508 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5514 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5516 return newUNOP(OP_RV2CV, flags, scalar(o));
5520 Perl_newSVREF(pTHX_ OP *o)
5522 if (o->op_type == OP_PADANY) {
5523 o->op_type = OP_PADSV;
5524 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5527 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5528 o->op_flags |= OPpDONE_SVREF;
5531 return newUNOP(OP_RV2SV, 0, scalar(o));
5534 /* Check routines. */
5537 Perl_ck_anoncode(pTHX_ OP *o)
5542 name = NEWSV(1106,0);
5543 sv_upgrade(name, SVt_PVNV);
5544 sv_setpvn(name, "&", 1);
5547 ix = pad_alloc(o->op_type, SVs_PADMY);
5548 av_store(PL_comppad_name, ix, name);
5549 av_store(PL_comppad, ix, cSVOPo->op_sv);
5550 SvPADMY_on(cSVOPo->op_sv);
5551 cSVOPo->op_sv = Nullsv;
5552 cSVOPo->op_targ = ix;
5557 Perl_ck_bitop(pTHX_ OP *o)
5559 o->op_private = PL_hints;
5564 Perl_ck_concat(pTHX_ OP *o)
5566 if (cUNOPo->op_first->op_type == OP_CONCAT)
5567 o->op_flags |= OPf_STACKED;
5572 Perl_ck_spair(pTHX_ OP *o)
5574 if (o->op_flags & OPf_KIDS) {
5577 OPCODE type = o->op_type;
5578 o = modkids(ck_fun(o), type);
5579 kid = cUNOPo->op_first;
5580 newop = kUNOP->op_first->op_sibling;
5582 (newop->op_sibling ||
5583 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5584 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5585 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5589 op_free(kUNOP->op_first);
5590 kUNOP->op_first = newop;
5592 o->op_ppaddr = PL_ppaddr[++o->op_type];
5597 Perl_ck_delete(pTHX_ OP *o)
5601 if (o->op_flags & OPf_KIDS) {
5602 OP *kid = cUNOPo->op_first;
5603 switch (kid->op_type) {
5605 o->op_flags |= OPf_SPECIAL;
5608 o->op_private |= OPpSLICE;
5611 o->op_flags |= OPf_SPECIAL;
5616 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5625 Perl_ck_die(pTHX_ OP *o)
5628 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5634 Perl_ck_eof(pTHX_ OP *o)
5636 I32 type = o->op_type;
5638 if (o->op_flags & OPf_KIDS) {
5639 if (cLISTOPo->op_first->op_type == OP_STUB) {
5641 o = newUNOP(type, OPf_SPECIAL,
5642 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5650 Perl_ck_eval(pTHX_ OP *o)
5652 PL_hints |= HINT_BLOCK_SCOPE;
5653 if (o->op_flags & OPf_KIDS) {
5654 SVOP *kid = (SVOP*)cUNOPo->op_first;
5657 o->op_flags &= ~OPf_KIDS;
5660 else if (kid->op_type == OP_LINESEQ) {
5663 kid->op_next = o->op_next;
5664 cUNOPo->op_first = 0;
5667 NewOp(1101, enter, 1, LOGOP);
5668 enter->op_type = OP_ENTERTRY;
5669 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5670 enter->op_private = 0;
5672 /* establish postfix order */
5673 enter->op_next = (OP*)enter;
5675 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5676 o->op_type = OP_LEAVETRY;
5677 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5678 enter->op_other = o;
5686 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5688 o->op_targ = (PADOFFSET)PL_hints;
5693 Perl_ck_exit(pTHX_ OP *o)
5696 HV *table = GvHV(PL_hintgv);
5698 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5699 if (svp && *svp && SvTRUE(*svp))
5700 o->op_private |= OPpEXIT_VMSISH;
5702 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5708 Perl_ck_exec(pTHX_ OP *o)
5711 if (o->op_flags & OPf_STACKED) {
5713 kid = cUNOPo->op_first->op_sibling;
5714 if (kid->op_type == OP_RV2GV)
5723 Perl_ck_exists(pTHX_ OP *o)
5726 if (o->op_flags & OPf_KIDS) {
5727 OP *kid = cUNOPo->op_first;
5728 if (kid->op_type == OP_ENTERSUB) {
5729 (void) ref(kid, o->op_type);
5730 if (kid->op_type != OP_RV2CV && !PL_error_count)
5731 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5733 o->op_private |= OPpEXISTS_SUB;
5735 else if (kid->op_type == OP_AELEM)
5736 o->op_flags |= OPf_SPECIAL;
5737 else if (kid->op_type != OP_HELEM)
5738 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5747 Perl_ck_gvconst(pTHX_ register OP *o)
5749 o = fold_constants(o);
5750 if (o->op_type == OP_CONST)
5757 Perl_ck_rvconst(pTHX_ register OP *o)
5759 SVOP *kid = (SVOP*)cUNOPo->op_first;
5761 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5762 if (kid->op_type == OP_CONST) {
5766 SV *kidsv = kid->op_sv;
5769 /* Is it a constant from cv_const_sv()? */
5770 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5771 SV *rsv = SvRV(kidsv);
5772 int svtype = SvTYPE(rsv);
5773 char *badtype = Nullch;
5775 switch (o->op_type) {
5777 if (svtype > SVt_PVMG)
5778 badtype = "a SCALAR";
5781 if (svtype != SVt_PVAV)
5782 badtype = "an ARRAY";
5785 if (svtype != SVt_PVHV) {
5786 if (svtype == SVt_PVAV) { /* pseudohash? */
5787 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5788 if (ksv && SvROK(*ksv)
5789 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5798 if (svtype != SVt_PVCV)
5803 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5806 name = SvPV(kidsv, n_a);
5807 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5808 char *badthing = Nullch;
5809 switch (o->op_type) {
5811 badthing = "a SCALAR";
5814 badthing = "an ARRAY";
5817 badthing = "a HASH";
5822 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5826 * This is a little tricky. We only want to add the symbol if we
5827 * didn't add it in the lexer. Otherwise we get duplicate strict
5828 * warnings. But if we didn't add it in the lexer, we must at
5829 * least pretend like we wanted to add it even if it existed before,
5830 * or we get possible typo warnings. OPpCONST_ENTERED says
5831 * whether the lexer already added THIS instance of this symbol.
5833 iscv = (o->op_type == OP_RV2CV) * 2;
5835 gv = gv_fetchpv(name,
5836 iscv | !(kid->op_private & OPpCONST_ENTERED),
5839 : o->op_type == OP_RV2SV
5841 : o->op_type == OP_RV2AV
5843 : o->op_type == OP_RV2HV
5846 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5848 kid->op_type = OP_GV;
5849 SvREFCNT_dec(kid->op_sv);
5851 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5852 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5853 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5855 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5857 kid->op_sv = SvREFCNT_inc(gv);
5859 kid->op_private = 0;
5860 kid->op_ppaddr = PL_ppaddr[OP_GV];
5867 Perl_ck_ftst(pTHX_ OP *o)
5869 I32 type = o->op_type;
5871 if (o->op_flags & OPf_REF) {
5874 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5875 SVOP *kid = (SVOP*)cUNOPo->op_first;
5877 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5879 OP *newop = newGVOP(type, OPf_REF,
5880 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5887 if (type == OP_FTTTY)
5888 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5891 o = newUNOP(type, 0, newDEFSVOP());
5897 Perl_ck_fun(pTHX_ OP *o)
5903 int type = o->op_type;
5904 register I32 oa = PL_opargs[type] >> OASHIFT;
5906 if (o->op_flags & OPf_STACKED) {
5907 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5910 return no_fh_allowed(o);
5913 if (o->op_flags & OPf_KIDS) {
5915 tokid = &cLISTOPo->op_first;
5916 kid = cLISTOPo->op_first;
5917 if (kid->op_type == OP_PUSHMARK ||
5918 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5920 tokid = &kid->op_sibling;
5921 kid = kid->op_sibling;
5923 if (!kid && PL_opargs[type] & OA_DEFGV)
5924 *tokid = kid = newDEFSVOP();
5928 sibl = kid->op_sibling;
5931 /* list seen where single (scalar) arg expected? */
5932 if (numargs == 1 && !(oa >> 4)
5933 && kid->op_type == OP_LIST && type != OP_SCALAR)
5935 return too_many_arguments(o,PL_op_desc[type]);
5948 if ((type == OP_PUSH || type == OP_UNSHIFT)
5949 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5950 Perl_warner(aTHX_ WARN_SYNTAX,
5951 "Useless use of %s with no values",
5954 if (kid->op_type == OP_CONST &&
5955 (kid->op_private & OPpCONST_BARE))
5957 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5958 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5959 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5960 if (ckWARN(WARN_DEPRECATED))
5961 Perl_warner(aTHX_ WARN_DEPRECATED,
5962 "Array @%s missing the @ in argument %"IVdf" of %s()",
5963 name, (IV)numargs, PL_op_desc[type]);
5966 kid->op_sibling = sibl;
5969 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5970 bad_type(numargs, "array", PL_op_desc[type], kid);
5974 if (kid->op_type == OP_CONST &&
5975 (kid->op_private & OPpCONST_BARE))
5977 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5978 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5979 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5980 if (ckWARN(WARN_DEPRECATED))
5981 Perl_warner(aTHX_ WARN_DEPRECATED,
5982 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5983 name, (IV)numargs, PL_op_desc[type]);
5986 kid->op_sibling = sibl;
5989 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5990 bad_type(numargs, "hash", PL_op_desc[type], kid);
5995 OP *newop = newUNOP(OP_NULL, 0, kid);
5996 kid->op_sibling = 0;
5998 newop->op_next = newop;
6000 kid->op_sibling = sibl;
6005 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6006 if (kid->op_type == OP_CONST &&
6007 (kid->op_private & OPpCONST_BARE))
6009 OP *newop = newGVOP(OP_GV, 0,
6010 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
6012 if (kid == cLISTOPo->op_last)
6013 cLISTOPo->op_last = newop;
6017 else if (kid->op_type == OP_READLINE) {
6018 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6019 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6022 I32 flags = OPf_SPECIAL;
6026 /* is this op a FH constructor? */
6027 if (is_handle_constructor(o,numargs)) {
6028 char *name = Nullch;
6032 /* Set a flag to tell rv2gv to vivify
6033 * need to "prove" flag does not mean something
6034 * else already - NI-S 1999/05/07
6037 if (kid->op_type == OP_PADSV) {
6038 SV **namep = av_fetch(PL_comppad_name,
6040 if (namep && *namep)
6041 name = SvPV(*namep, len);
6043 else if (kid->op_type == OP_RV2SV
6044 && kUNOP->op_first->op_type == OP_GV)
6046 GV *gv = cGVOPx_gv(kUNOP->op_first);
6048 len = GvNAMELEN(gv);
6050 else if (kid->op_type == OP_AELEM
6051 || kid->op_type == OP_HELEM)
6053 name = "__ANONIO__";
6059 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6060 namesv = PL_curpad[targ];
6061 (void)SvUPGRADE(namesv, SVt_PV);
6063 sv_setpvn(namesv, "$", 1);
6064 sv_catpvn(namesv, name, len);
6067 kid->op_sibling = 0;
6068 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6069 kid->op_targ = targ;
6070 kid->op_private |= priv;
6072 kid->op_sibling = sibl;
6078 mod(scalar(kid), type);
6082 tokid = &kid->op_sibling;
6083 kid = kid->op_sibling;
6085 o->op_private |= numargs;
6087 return too_many_arguments(o,OP_DESC(o));
6090 else if (PL_opargs[type] & OA_DEFGV) {
6092 return newUNOP(type, 0, newDEFSVOP());
6096 while (oa & OA_OPTIONAL)
6098 if (oa && oa != OA_LIST)
6099 return too_few_arguments(o,OP_DESC(o));
6105 Perl_ck_glob(pTHX_ OP *o)
6110 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6111 append_elem(OP_GLOB, o, newDEFSVOP());
6113 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6114 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6116 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6119 #if !defined(PERL_EXTERNAL_GLOB)
6120 /* XXX this can be tightened up and made more failsafe. */
6124 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6125 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6126 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6127 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6128 GvCV(gv) = GvCV(glob_gv);
6129 SvREFCNT_inc((SV*)GvCV(gv));
6130 GvIMPORTED_CV_on(gv);
6133 #endif /* PERL_EXTERNAL_GLOB */
6135 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6136 append_elem(OP_GLOB, o,
6137 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6138 o->op_type = OP_LIST;
6139 o->op_ppaddr = PL_ppaddr[OP_LIST];
6140 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6141 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6142 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6143 append_elem(OP_LIST, o,
6144 scalar(newUNOP(OP_RV2CV, 0,
6145 newGVOP(OP_GV, 0, gv)))));
6146 o = newUNOP(OP_NULL, 0, ck_subr(o));
6147 o->op_targ = OP_GLOB; /* hint at what it used to be */
6150 gv = newGVgen("main");
6152 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6158 Perl_ck_grep(pTHX_ OP *o)
6162 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6164 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6165 NewOp(1101, gwop, 1, LOGOP);
6167 if (o->op_flags & OPf_STACKED) {
6170 kid = cLISTOPo->op_first->op_sibling;
6171 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6174 kid->op_next = (OP*)gwop;
6175 o->op_flags &= ~OPf_STACKED;
6177 kid = cLISTOPo->op_first->op_sibling;
6178 if (type == OP_MAPWHILE)
6185 kid = cLISTOPo->op_first->op_sibling;
6186 if (kid->op_type != OP_NULL)
6187 Perl_croak(aTHX_ "panic: ck_grep");
6188 kid = kUNOP->op_first;
6190 gwop->op_type = type;
6191 gwop->op_ppaddr = PL_ppaddr[type];
6192 gwop->op_first = listkids(o);
6193 gwop->op_flags |= OPf_KIDS;
6194 gwop->op_private = 1;
6195 gwop->op_other = LINKLIST(kid);
6196 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6197 kid->op_next = (OP*)gwop;
6199 kid = cLISTOPo->op_first->op_sibling;
6200 if (!kid || !kid->op_sibling)
6201 return too_few_arguments(o,OP_DESC(o));
6202 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6203 mod(kid, OP_GREPSTART);
6209 Perl_ck_index(pTHX_ OP *o)
6211 if (o->op_flags & OPf_KIDS) {
6212 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6214 kid = kid->op_sibling; /* get past "big" */
6215 if (kid && kid->op_type == OP_CONST)
6216 fbm_compile(((SVOP*)kid)->op_sv, 0);
6222 Perl_ck_lengthconst(pTHX_ OP *o)
6224 /* XXX length optimization goes here */
6229 Perl_ck_lfun(pTHX_ OP *o)
6231 OPCODE type = o->op_type;
6232 return modkids(ck_fun(o), type);
6236 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6238 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6239 switch (cUNOPo->op_first->op_type) {
6241 /* This is needed for
6242 if (defined %stash::)
6243 to work. Do not break Tk.
6245 break; /* Globals via GV can be undef */
6247 case OP_AASSIGN: /* Is this a good idea? */
6248 Perl_warner(aTHX_ WARN_DEPRECATED,
6249 "defined(@array) is deprecated");
6250 Perl_warner(aTHX_ WARN_DEPRECATED,
6251 "\t(Maybe you should just omit the defined()?)\n");
6254 /* This is needed for
6255 if (defined %stash::)
6256 to work. Do not break Tk.
6258 break; /* Globals via GV can be undef */
6260 Perl_warner(aTHX_ WARN_DEPRECATED,
6261 "defined(%%hash) is deprecated");
6262 Perl_warner(aTHX_ WARN_DEPRECATED,
6263 "\t(Maybe you should just omit the defined()?)\n");
6274 Perl_ck_rfun(pTHX_ OP *o)
6276 OPCODE type = o->op_type;
6277 return refkids(ck_fun(o), type);
6281 Perl_ck_listiob(pTHX_ OP *o)
6285 kid = cLISTOPo->op_first;
6288 kid = cLISTOPo->op_first;
6290 if (kid->op_type == OP_PUSHMARK)
6291 kid = kid->op_sibling;
6292 if (kid && o->op_flags & OPf_STACKED)
6293 kid = kid->op_sibling;
6294 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6295 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6296 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6297 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6298 cLISTOPo->op_first->op_sibling = kid;
6299 cLISTOPo->op_last = kid;
6300 kid = kid->op_sibling;
6305 append_elem(o->op_type, o, newDEFSVOP());
6311 Perl_ck_sassign(pTHX_ OP *o)
6313 OP *kid = cLISTOPo->op_first;
6314 /* has a disposable target? */
6315 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6316 && !(kid->op_flags & OPf_STACKED)
6317 /* Cannot steal the second time! */
6318 && !(kid->op_private & OPpTARGET_MY))
6320 OP *kkid = kid->op_sibling;
6322 /* Can just relocate the target. */
6323 if (kkid && kkid->op_type == OP_PADSV
6324 && !(kkid->op_private & OPpLVAL_INTRO))
6326 kid->op_targ = kkid->op_targ;
6328 /* Now we do not need PADSV and SASSIGN. */
6329 kid->op_sibling = o->op_sibling; /* NULL */
6330 cLISTOPo->op_first = NULL;
6333 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6341 Perl_ck_match(pTHX_ OP *o)
6343 o->op_private |= OPpRUNTIME;
6348 Perl_ck_method(pTHX_ OP *o)
6350 OP *kid = cUNOPo->op_first;
6351 if (kid->op_type == OP_CONST) {
6352 SV* sv = kSVOP->op_sv;
6353 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6355 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6356 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6359 kSVOP->op_sv = Nullsv;
6361 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6370 Perl_ck_null(pTHX_ OP *o)
6376 Perl_ck_open(pTHX_ OP *o)
6378 HV *table = GvHV(PL_hintgv);
6382 svp = hv_fetch(table, "open_IN", 7, FALSE);
6384 mode = mode_from_discipline(*svp);
6385 if (mode & O_BINARY)
6386 o->op_private |= OPpOPEN_IN_RAW;
6387 else if (mode & O_TEXT)
6388 o->op_private |= OPpOPEN_IN_CRLF;
6391 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6393 mode = mode_from_discipline(*svp);
6394 if (mode & O_BINARY)
6395 o->op_private |= OPpOPEN_OUT_RAW;
6396 else if (mode & O_TEXT)
6397 o->op_private |= OPpOPEN_OUT_CRLF;
6400 if (o->op_type == OP_BACKTICK)
6406 Perl_ck_repeat(pTHX_ OP *o)
6408 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6409 o->op_private |= OPpREPEAT_DOLIST;
6410 cBINOPo->op_first = force_list(cBINOPo->op_first);
6418 Perl_ck_require(pTHX_ OP *o)
6422 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6423 SVOP *kid = (SVOP*)cUNOPo->op_first;
6425 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6427 for (s = SvPVX(kid->op_sv); *s; s++) {
6428 if (*s == ':' && s[1] == ':') {
6430 Move(s+2, s+1, strlen(s+2)+1, char);
6431 --SvCUR(kid->op_sv);
6434 if (SvREADONLY(kid->op_sv)) {
6435 SvREADONLY_off(kid->op_sv);
6436 sv_catpvn(kid->op_sv, ".pm", 3);
6437 SvREADONLY_on(kid->op_sv);
6440 sv_catpvn(kid->op_sv, ".pm", 3);
6444 /* handle override, if any */
6445 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6446 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6447 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6449 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6450 OP *kid = cUNOPo->op_first;
6451 cUNOPo->op_first = 0;
6453 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6454 append_elem(OP_LIST, kid,
6455 scalar(newUNOP(OP_RV2CV, 0,
6464 Perl_ck_return(pTHX_ OP *o)
6467 if (CvLVALUE(PL_compcv)) {
6468 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6469 mod(kid, OP_LEAVESUBLV);
6476 Perl_ck_retarget(pTHX_ OP *o)
6478 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6485 Perl_ck_select(pTHX_ OP *o)
6488 if (o->op_flags & OPf_KIDS) {
6489 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6490 if (kid && kid->op_sibling) {
6491 o->op_type = OP_SSELECT;
6492 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6494 return fold_constants(o);
6498 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6499 if (kid && kid->op_type == OP_RV2GV)
6500 kid->op_private &= ~HINT_STRICT_REFS;
6505 Perl_ck_shift(pTHX_ OP *o)
6507 I32 type = o->op_type;
6509 if (!(o->op_flags & OPf_KIDS)) {
6513 #ifdef USE_5005THREADS
6514 if (!CvUNIQUE(PL_compcv)) {
6515 argop = newOP(OP_PADAV, OPf_REF);
6516 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6519 argop = newUNOP(OP_RV2AV, 0,
6520 scalar(newGVOP(OP_GV, 0,
6521 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6524 argop = newUNOP(OP_RV2AV, 0,
6525 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6526 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6527 #endif /* USE_5005THREADS */
6528 return newUNOP(type, 0, scalar(argop));
6530 return scalar(modkids(ck_fun(o), type));
6534 Perl_ck_sort(pTHX_ OP *o)
6538 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6540 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6541 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6543 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6545 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6547 if (kid->op_type == OP_SCOPE) {
6551 else if (kid->op_type == OP_LEAVE) {
6552 if (o->op_type == OP_SORT) {
6553 op_null(kid); /* wipe out leave */
6556 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6557 if (k->op_next == kid)
6559 /* don't descend into loops */
6560 else if (k->op_type == OP_ENTERLOOP
6561 || k->op_type == OP_ENTERITER)
6563 k = cLOOPx(k)->op_lastop;
6568 kid->op_next = 0; /* just disconnect the leave */
6569 k = kLISTOP->op_first;
6574 if (o->op_type == OP_SORT) {
6575 /* provide scalar context for comparison function/block */
6581 o->op_flags |= OPf_SPECIAL;
6583 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6586 firstkid = firstkid->op_sibling;
6589 /* provide list context for arguments */
6590 if (o->op_type == OP_SORT)
6597 S_simplify_sort(pTHX_ OP *o)
6599 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6603 if (!(o->op_flags & OPf_STACKED))
6605 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6606 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6607 kid = kUNOP->op_first; /* get past null */
6608 if (kid->op_type != OP_SCOPE)
6610 kid = kLISTOP->op_last; /* get past scope */
6611 switch(kid->op_type) {
6619 k = kid; /* remember this node*/
6620 if (kBINOP->op_first->op_type != OP_RV2SV)
6622 kid = kBINOP->op_first; /* get past cmp */
6623 if (kUNOP->op_first->op_type != OP_GV)
6625 kid = kUNOP->op_first; /* get past rv2sv */
6627 if (GvSTASH(gv) != PL_curstash)
6629 if (strEQ(GvNAME(gv), "a"))
6631 else if (strEQ(GvNAME(gv), "b"))
6635 kid = k; /* back to cmp */
6636 if (kBINOP->op_last->op_type != OP_RV2SV)
6638 kid = kBINOP->op_last; /* down to 2nd arg */
6639 if (kUNOP->op_first->op_type != OP_GV)
6641 kid = kUNOP->op_first; /* get past rv2sv */
6643 if (GvSTASH(gv) != PL_curstash
6645 ? strNE(GvNAME(gv), "a")
6646 : strNE(GvNAME(gv), "b")))
6648 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6650 o->op_private |= OPpSORT_REVERSE;
6651 if (k->op_type == OP_NCMP)
6652 o->op_private |= OPpSORT_NUMERIC;
6653 if (k->op_type == OP_I_NCMP)
6654 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6655 kid = cLISTOPo->op_first->op_sibling;
6656 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6657 op_free(kid); /* then delete it */
6661 Perl_ck_split(pTHX_ OP *o)
6665 if (o->op_flags & OPf_STACKED)
6666 return no_fh_allowed(o);
6668 kid = cLISTOPo->op_first;
6669 if (kid->op_type != OP_NULL)
6670 Perl_croak(aTHX_ "panic: ck_split");
6671 kid = kid->op_sibling;
6672 op_free(cLISTOPo->op_first);
6673 cLISTOPo->op_first = kid;
6675 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6676 cLISTOPo->op_last = kid; /* There was only one element previously */
6679 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6680 OP *sibl = kid->op_sibling;
6681 kid->op_sibling = 0;
6682 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6683 if (cLISTOPo->op_first == cLISTOPo->op_last)
6684 cLISTOPo->op_last = kid;
6685 cLISTOPo->op_first = kid;
6686 kid->op_sibling = sibl;
6689 kid->op_type = OP_PUSHRE;
6690 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6693 if (!kid->op_sibling)
6694 append_elem(OP_SPLIT, o, newDEFSVOP());
6696 kid = kid->op_sibling;
6699 if (!kid->op_sibling)
6700 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6702 kid = kid->op_sibling;
6705 if (kid->op_sibling)
6706 return too_many_arguments(o,OP_DESC(o));
6712 Perl_ck_join(pTHX_ OP *o)
6714 if (ckWARN(WARN_SYNTAX)) {
6715 OP *kid = cLISTOPo->op_first->op_sibling;
6716 if (kid && kid->op_type == OP_MATCH) {
6717 char *pmstr = "STRING";
6718 if (PM_GETRE(kPMOP))
6719 pmstr = PM_GETRE(kPMOP)->precomp;
6720 Perl_warner(aTHX_ WARN_SYNTAX,
6721 "/%s/ should probably be written as \"%s\"",
6729 Perl_ck_subr(pTHX_ OP *o)
6731 OP *prev = ((cUNOPo->op_first->op_sibling)
6732 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6733 OP *o2 = prev->op_sibling;
6740 I32 contextclass = 0;
6744 o->op_private |= OPpENTERSUB_HASTARG;
6745 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6746 if (cvop->op_type == OP_RV2CV) {
6748 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6749 op_null(cvop); /* disable rv2cv */
6750 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6751 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6752 GV *gv = cGVOPx_gv(tmpop);
6755 tmpop->op_private |= OPpEARLY_CV;
6756 else if (SvPOK(cv)) {
6757 namegv = CvANON(cv) ? gv : CvGV(cv);
6758 proto = SvPV((SV*)cv, n_a);
6762 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6763 if (o2->op_type == OP_CONST)
6764 o2->op_private &= ~OPpCONST_STRICT;
6765 else if (o2->op_type == OP_LIST) {
6766 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6767 if (o && o->op_type == OP_CONST)
6768 o->op_private &= ~OPpCONST_STRICT;
6771 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6772 if (PERLDB_SUB && PL_curstash != PL_debstash)
6773 o->op_private |= OPpENTERSUB_DB;
6774 while (o2 != cvop) {
6778 return too_many_arguments(o, gv_ename(namegv));
6796 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6798 arg == 1 ? "block or sub {}" : "sub {}",
6799 gv_ename(namegv), o2);
6802 /* '*' allows any scalar type, including bareword */
6805 if (o2->op_type == OP_RV2GV)
6806 goto wrapref; /* autoconvert GLOB -> GLOBref */
6807 else if (o2->op_type == OP_CONST)
6808 o2->op_private &= ~OPpCONST_STRICT;
6809 else if (o2->op_type == OP_ENTERSUB) {
6810 /* accidental subroutine, revert to bareword */
6811 OP *gvop = ((UNOP*)o2)->op_first;
6812 if (gvop && gvop->op_type == OP_NULL) {
6813 gvop = ((UNOP*)gvop)->op_first;
6815 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6818 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6819 (gvop = ((UNOP*)gvop)->op_first) &&
6820 gvop->op_type == OP_GV)
6822 GV *gv = cGVOPx_gv(gvop);
6823 OP *sibling = o2->op_sibling;
6824 SV *n = newSVpvn("",0);
6826 gv_fullname3(n, gv, "");
6827 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6828 sv_chop(n, SvPVX(n)+6);
6829 o2 = newSVOP(OP_CONST, 0, n);
6830 prev->op_sibling = o2;
6831 o2->op_sibling = sibling;
6847 if (contextclass++ == 0) {
6848 e = strchr(proto, ']');
6849 if (!e || e == proto)
6862 while (*--p != '[');
6863 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6864 gv_ename(namegv), o2);
6870 if (o2->op_type == OP_RV2GV)
6873 bad_type(arg, "symbol", gv_ename(namegv), o2);
6876 if (o2->op_type == OP_ENTERSUB)
6879 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6882 if (o2->op_type == OP_RV2SV ||
6883 o2->op_type == OP_PADSV ||
6884 o2->op_type == OP_HELEM ||
6885 o2->op_type == OP_AELEM ||
6886 o2->op_type == OP_THREADSV)
6889 bad_type(arg, "scalar", gv_ename(namegv), o2);
6892 if (o2->op_type == OP_RV2AV ||
6893 o2->op_type == OP_PADAV)
6896 bad_type(arg, "array", gv_ename(namegv), o2);
6899 if (o2->op_type == OP_RV2HV ||
6900 o2->op_type == OP_PADHV)
6903 bad_type(arg, "hash", gv_ename(namegv), o2);
6908 OP* sib = kid->op_sibling;
6909 kid->op_sibling = 0;
6910 o2 = newUNOP(OP_REFGEN, 0, kid);
6911 o2->op_sibling = sib;
6912 prev->op_sibling = o2;
6914 if (contextclass && e) {
6929 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6930 gv_ename(namegv), SvPV((SV*)cv, n_a));
6935 mod(o2, OP_ENTERSUB);
6937 o2 = o2->op_sibling;
6939 if (proto && !optional &&
6940 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6941 return too_few_arguments(o, gv_ename(namegv));
6946 Perl_ck_svconst(pTHX_ OP *o)
6948 SvREADONLY_on(cSVOPo->op_sv);
6953 Perl_ck_trunc(pTHX_ OP *o)
6955 if (o->op_flags & OPf_KIDS) {
6956 SVOP *kid = (SVOP*)cUNOPo->op_first;
6958 if (kid->op_type == OP_NULL)
6959 kid = (SVOP*)kid->op_sibling;
6960 if (kid && kid->op_type == OP_CONST &&
6961 (kid->op_private & OPpCONST_BARE))
6963 o->op_flags |= OPf_SPECIAL;
6964 kid->op_private &= ~OPpCONST_STRICT;
6971 Perl_ck_substr(pTHX_ OP *o)
6974 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6975 OP *kid = cLISTOPo->op_first;
6977 if (kid->op_type == OP_NULL)
6978 kid = kid->op_sibling;
6980 kid->op_flags |= OPf_MOD;
6986 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6989 Perl_peep(pTHX_ register OP *o)
6991 register OP* oldop = 0;
6994 if (!o || o->op_seq)
6998 SAVEVPTR(PL_curcop);
6999 for (; o; o = o->op_next) {
7005 switch (o->op_type) {
7009 PL_curcop = ((COP*)o); /* for warnings */
7010 o->op_seq = PL_op_seqmax++;
7014 if (cSVOPo->op_private & OPpCONST_STRICT)
7015 no_bareword_allowed(o);
7017 /* Relocate sv to the pad for thread safety.
7018 * Despite being a "constant", the SV is written to,
7019 * for reference counts, sv_upgrade() etc. */
7021 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7022 if (SvPADTMP(cSVOPo->op_sv)) {
7023 /* If op_sv is already a PADTMP then it is being used by
7024 * some pad, so make a copy. */
7025 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
7026 SvREADONLY_on(PL_curpad[ix]);
7027 SvREFCNT_dec(cSVOPo->op_sv);
7030 SvREFCNT_dec(PL_curpad[ix]);
7031 SvPADTMP_on(cSVOPo->op_sv);
7032 PL_curpad[ix] = cSVOPo->op_sv;
7033 /* XXX I don't know how this isn't readonly already. */
7034 SvREADONLY_on(PL_curpad[ix]);
7036 cSVOPo->op_sv = Nullsv;
7040 o->op_seq = PL_op_seqmax++;
7044 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7045 if (o->op_next->op_private & OPpTARGET_MY) {
7046 if (o->op_flags & OPf_STACKED) /* chained concats */
7047 goto ignore_optimization;
7049 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7050 o->op_targ = o->op_next->op_targ;
7051 o->op_next->op_targ = 0;
7052 o->op_private |= OPpTARGET_MY;
7055 op_null(o->op_next);
7057 ignore_optimization:
7058 o->op_seq = PL_op_seqmax++;
7061 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7062 o->op_seq = PL_op_seqmax++;
7063 break; /* Scalar stub must produce undef. List stub is noop */
7067 if (o->op_targ == OP_NEXTSTATE
7068 || o->op_targ == OP_DBSTATE
7069 || o->op_targ == OP_SETSTATE)
7071 PL_curcop = ((COP*)o);
7073 /* XXX: We avoid setting op_seq here to prevent later calls
7074 to peep() from mistakenly concluding that optimisation
7075 has already occurred. This doesn't fix the real problem,
7076 though (See 20010220.007). AMS 20010719 */
7077 if (oldop && o->op_next) {
7078 oldop->op_next = o->op_next;
7086 if (oldop && o->op_next) {
7087 oldop->op_next = o->op_next;
7090 o->op_seq = PL_op_seqmax++;
7094 if (o->op_next->op_type == OP_RV2SV) {
7095 if (!(o->op_next->op_private & OPpDEREF)) {
7096 op_null(o->op_next);
7097 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7099 o->op_next = o->op_next->op_next;
7100 o->op_type = OP_GVSV;
7101 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7104 else if (o->op_next->op_type == OP_RV2AV) {
7105 OP* pop = o->op_next->op_next;
7107 if (pop && pop->op_type == OP_CONST &&
7108 (PL_op = pop->op_next) &&
7109 pop->op_next->op_type == OP_AELEM &&
7110 !(pop->op_next->op_private &
7111 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7112 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7117 op_null(o->op_next);
7118 op_null(pop->op_next);
7120 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7121 o->op_next = pop->op_next->op_next;
7122 o->op_type = OP_AELEMFAST;
7123 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7124 o->op_private = (U8)i;
7129 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7131 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7132 /* XXX could check prototype here instead of just carping */
7133 SV *sv = sv_newmortal();
7134 gv_efullname3(sv, gv, Nullch);
7135 Perl_warner(aTHX_ WARN_PROTOTYPE,
7136 "%s() called too early to check prototype",
7140 else if (o->op_next->op_type == OP_READLINE
7141 && o->op_next->op_next->op_type == OP_CONCAT
7142 && (o->op_next->op_next->op_flags & OPf_STACKED))
7144 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7145 o->op_type = OP_RCATLINE;
7146 o->op_flags |= OPf_STACKED;
7147 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7148 op_null(o->op_next->op_next);
7149 op_null(o->op_next);
7152 o->op_seq = PL_op_seqmax++;
7163 o->op_seq = PL_op_seqmax++;
7164 while (cLOGOP->op_other->op_type == OP_NULL)
7165 cLOGOP->op_other = cLOGOP->op_other->op_next;
7166 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7171 o->op_seq = PL_op_seqmax++;
7172 while (cLOOP->op_redoop->op_type == OP_NULL)
7173 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7174 peep(cLOOP->op_redoop);
7175 while (cLOOP->op_nextop->op_type == OP_NULL)
7176 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7177 peep(cLOOP->op_nextop);
7178 while (cLOOP->op_lastop->op_type == OP_NULL)
7179 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7180 peep(cLOOP->op_lastop);
7186 o->op_seq = PL_op_seqmax++;
7187 while (cPMOP->op_pmreplstart &&
7188 cPMOP->op_pmreplstart->op_type == OP_NULL)
7189 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7190 peep(cPMOP->op_pmreplstart);
7194 o->op_seq = PL_op_seqmax++;
7195 if (ckWARN(WARN_SYNTAX) && o->op_next
7196 && o->op_next->op_type == OP_NEXTSTATE) {
7197 if (o->op_next->op_sibling &&
7198 o->op_next->op_sibling->op_type != OP_EXIT &&
7199 o->op_next->op_sibling->op_type != OP_WARN &&
7200 o->op_next->op_sibling->op_type != OP_DIE) {
7201 line_t oldline = CopLINE(PL_curcop);
7203 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7204 Perl_warner(aTHX_ WARN_EXEC,
7205 "Statement unlikely to be reached");
7206 Perl_warner(aTHX_ WARN_EXEC,
7207 "\t(Maybe you meant system() when you said exec()?)\n");
7208 CopLINE_set(PL_curcop, oldline);
7217 SV **svp, **indsvp, *sv;
7222 o->op_seq = PL_op_seqmax++;
7224 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7227 /* Make the CONST have a shared SV */
7228 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7229 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7230 key = SvPV(sv, keylen);
7231 lexname = newSVpvn_share(key,
7232 SvUTF8(sv) ? -(I32)keylen : keylen,
7238 if ((o->op_private & (OPpLVAL_INTRO)))
7241 rop = (UNOP*)((BINOP*)o)->op_first;
7242 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7244 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7245 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7247 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7248 if (!fields || !GvHV(*fields))
7250 key = SvPV(*svp, keylen);
7251 indsvp = hv_fetch(GvHV(*fields), key,
7252 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7254 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7255 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7257 ind = SvIV(*indsvp);
7259 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7260 rop->op_type = OP_RV2AV;
7261 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7262 o->op_type = OP_AELEM;
7263 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7265 if (SvREADONLY(*svp))
7267 SvFLAGS(sv) |= (SvFLAGS(*svp)
7268 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7278 SV **svp, **indsvp, *sv;
7282 SVOP *first_key_op, *key_op;
7284 o->op_seq = PL_op_seqmax++;
7285 if ((o->op_private & (OPpLVAL_INTRO))
7286 /* I bet there's always a pushmark... */
7287 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7288 /* hmmm, no optimization if list contains only one key. */
7290 rop = (UNOP*)((LISTOP*)o)->op_last;
7291 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7293 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7294 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7296 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7297 if (!fields || !GvHV(*fields))
7299 /* Again guessing that the pushmark can be jumped over.... */
7300 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7301 ->op_first->op_sibling;
7302 /* Check that the key list contains only constants. */
7303 for (key_op = first_key_op; key_op;
7304 key_op = (SVOP*)key_op->op_sibling)
7305 if (key_op->op_type != OP_CONST)
7309 rop->op_type = OP_RV2AV;
7310 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7311 o->op_type = OP_ASLICE;
7312 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7313 for (key_op = first_key_op; key_op;
7314 key_op = (SVOP*)key_op->op_sibling) {
7315 svp = cSVOPx_svp(key_op);
7316 key = SvPV(*svp, keylen);
7317 indsvp = hv_fetch(GvHV(*fields), key,
7318 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7320 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7321 "in variable %s of type %s",
7322 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7324 ind = SvIV(*indsvp);
7326 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7328 if (SvREADONLY(*svp))
7330 SvFLAGS(sv) |= (SvFLAGS(*svp)
7331 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7339 o->op_seq = PL_op_seqmax++;
7349 char* Perl_custom_op_name(pTHX_ OP* o)
7351 IV index = PTR2IV(o->op_ppaddr);
7355 if (!PL_custom_op_names) /* This probably shouldn't happen */
7356 return PL_op_name[OP_CUSTOM];
7358 keysv = sv_2mortal(newSViv(index));
7360 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7362 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7364 return SvPV_nolen(HeVAL(he));
7367 char* Perl_custom_op_desc(pTHX_ OP* o)
7369 IV index = PTR2IV(o->op_ppaddr);
7373 if (!PL_custom_op_descs)
7374 return PL_op_desc[OP_CUSTOM];
7376 keysv = sv_2mortal(newSViv(index));
7378 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7380 return PL_op_desc[OP_CUSTOM];
7382 return SvPV_nolen(HeVAL(he));
7388 /* Efficient sub that returns a constant scalar value. */
7390 const_sv_xsub(pTHX_ CV* cv)
7395 Perl_croak(aTHX_ "usage: %s::%s()",
7396 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7400 ST(0) = (SV*)XSANY.any_ptr;