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);
2505 Perl_gen_constant_list(pTHX_ register OP *o)
2508 I32 oldtmps_floor = PL_tmps_floor;
2512 return o; /* Don't attempt to run with errors */
2514 PL_op = curop = LINKLIST(o);
2521 PL_tmps_floor = oldtmps_floor;
2523 o->op_type = OP_RV2AV;
2524 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2525 o->op_seq = 0; /* needs to be revisited in peep() */
2526 curop = ((UNOP*)o)->op_first;
2527 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2534 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2536 if (!o || o->op_type != OP_LIST)
2537 o = newLISTOP(OP_LIST, 0, o, Nullop);
2539 o->op_flags &= ~OPf_WANT;
2541 if (!(PL_opargs[type] & OA_MARK))
2542 op_null(cLISTOPo->op_first);
2545 o->op_ppaddr = PL_ppaddr[type];
2546 o->op_flags |= flags;
2548 o = CHECKOP(type, o);
2549 if (o->op_type != type)
2552 return fold_constants(o);
2555 /* List constructors */
2558 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2566 if (first->op_type != type
2567 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2569 return newLISTOP(type, 0, first, last);
2572 if (first->op_flags & OPf_KIDS)
2573 ((LISTOP*)first)->op_last->op_sibling = last;
2575 first->op_flags |= OPf_KIDS;
2576 ((LISTOP*)first)->op_first = last;
2578 ((LISTOP*)first)->op_last = last;
2583 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2591 if (first->op_type != type)
2592 return prepend_elem(type, (OP*)first, (OP*)last);
2594 if (last->op_type != type)
2595 return append_elem(type, (OP*)first, (OP*)last);
2597 first->op_last->op_sibling = last->op_first;
2598 first->op_last = last->op_last;
2599 first->op_flags |= (last->op_flags & OPf_KIDS);
2607 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2615 if (last->op_type == type) {
2616 if (type == OP_LIST) { /* already a PUSHMARK there */
2617 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2618 ((LISTOP*)last)->op_first->op_sibling = first;
2619 if (!(first->op_flags & OPf_PARENS))
2620 last->op_flags &= ~OPf_PARENS;
2623 if (!(last->op_flags & OPf_KIDS)) {
2624 ((LISTOP*)last)->op_last = first;
2625 last->op_flags |= OPf_KIDS;
2627 first->op_sibling = ((LISTOP*)last)->op_first;
2628 ((LISTOP*)last)->op_first = first;
2630 last->op_flags |= OPf_KIDS;
2634 return newLISTOP(type, 0, first, last);
2640 Perl_newNULLLIST(pTHX)
2642 return newOP(OP_STUB, 0);
2646 Perl_force_list(pTHX_ OP *o)
2648 if (!o || o->op_type != OP_LIST)
2649 o = newLISTOP(OP_LIST, 0, o, Nullop);
2655 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2659 NewOp(1101, listop, 1, LISTOP);
2661 listop->op_type = type;
2662 listop->op_ppaddr = PL_ppaddr[type];
2665 listop->op_flags = flags;
2669 else if (!first && last)
2672 first->op_sibling = last;
2673 listop->op_first = first;
2674 listop->op_last = last;
2675 if (type == OP_LIST) {
2677 pushop = newOP(OP_PUSHMARK, 0);
2678 pushop->op_sibling = first;
2679 listop->op_first = pushop;
2680 listop->op_flags |= OPf_KIDS;
2682 listop->op_last = pushop;
2689 Perl_newOP(pTHX_ I32 type, I32 flags)
2692 NewOp(1101, o, 1, OP);
2694 o->op_ppaddr = PL_ppaddr[type];
2695 o->op_flags = flags;
2698 o->op_private = 0 + (flags >> 8);
2699 if (PL_opargs[type] & OA_RETSCALAR)
2701 if (PL_opargs[type] & OA_TARGET)
2702 o->op_targ = pad_alloc(type, SVs_PADTMP);
2703 return CHECKOP(type, o);
2707 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2712 first = newOP(OP_STUB, 0);
2713 if (PL_opargs[type] & OA_MARK)
2714 first = force_list(first);
2716 NewOp(1101, unop, 1, UNOP);
2717 unop->op_type = type;
2718 unop->op_ppaddr = PL_ppaddr[type];
2719 unop->op_first = first;
2720 unop->op_flags = flags | OPf_KIDS;
2721 unop->op_private = 1 | (flags >> 8);
2722 unop = (UNOP*) CHECKOP(type, unop);
2726 return fold_constants((OP *) unop);
2730 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2733 NewOp(1101, binop, 1, BINOP);
2736 first = newOP(OP_NULL, 0);
2738 binop->op_type = type;
2739 binop->op_ppaddr = PL_ppaddr[type];
2740 binop->op_first = first;
2741 binop->op_flags = flags | OPf_KIDS;
2744 binop->op_private = 1 | (flags >> 8);
2747 binop->op_private = 2 | (flags >> 8);
2748 first->op_sibling = last;
2751 binop = (BINOP*)CHECKOP(type, binop);
2752 if (binop->op_next || binop->op_type != type)
2755 binop->op_last = binop->op_first->op_sibling;
2757 return fold_constants((OP *)binop);
2761 uvcompare(const void *a, const void *b)
2763 if (*((UV *)a) < (*(UV *)b))
2765 if (*((UV *)a) > (*(UV *)b))
2767 if (*((UV *)a+1) < (*(UV *)b+1))
2769 if (*((UV *)a+1) > (*(UV *)b+1))
2775 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2777 SV *tstr = ((SVOP*)expr)->op_sv;
2778 SV *rstr = ((SVOP*)repl)->op_sv;
2781 U8 *t = (U8*)SvPV(tstr, tlen);
2782 U8 *r = (U8*)SvPV(rstr, rlen);
2789 register short *tbl;
2791 PL_hints |= HINT_BLOCK_SCOPE;
2792 complement = o->op_private & OPpTRANS_COMPLEMENT;
2793 del = o->op_private & OPpTRANS_DELETE;
2794 squash = o->op_private & OPpTRANS_SQUASH;
2797 o->op_private |= OPpTRANS_FROM_UTF;
2800 o->op_private |= OPpTRANS_TO_UTF;
2802 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2803 SV* listsv = newSVpvn("# comment\n",10);
2805 U8* tend = t + tlen;
2806 U8* rend = r + rlen;
2820 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2821 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2827 tsave = t = bytes_to_utf8(t, &len);
2830 if (!to_utf && rlen) {
2832 rsave = r = bytes_to_utf8(r, &len);
2836 /* There are several snags with this code on EBCDIC:
2837 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2838 2. scan_const() in toke.c has encoded chars in native encoding which makes
2839 ranges at least in EBCDIC 0..255 range the bottom odd.
2843 U8 tmpbuf[UTF8_MAXLEN+1];
2846 New(1109, cp, 2*tlen, UV);
2848 transv = newSVpvn("",0);
2850 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2852 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2854 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2858 cp[2*i+1] = cp[2*i];
2862 qsort(cp, i, 2*sizeof(UV), uvcompare);
2863 for (j = 0; j < i; j++) {
2865 diff = val - nextmin;
2867 t = uvuni_to_utf8(tmpbuf,nextmin);
2868 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2870 U8 range_mark = UTF_TO_NATIVE(0xff);
2871 t = uvuni_to_utf8(tmpbuf, val - 1);
2872 sv_catpvn(transv, (char *)&range_mark, 1);
2873 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2880 t = uvuni_to_utf8(tmpbuf,nextmin);
2881 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2883 U8 range_mark = UTF_TO_NATIVE(0xff);
2884 sv_catpvn(transv, (char *)&range_mark, 1);
2886 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2887 UNICODE_ALLOW_SUPER);
2888 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2889 t = (U8*)SvPVX(transv);
2890 tlen = SvCUR(transv);
2894 else if (!rlen && !del) {
2895 r = t; rlen = tlen; rend = tend;
2898 if ((!rlen && !del) || t == r ||
2899 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2901 o->op_private |= OPpTRANS_IDENTICAL;
2905 while (t < tend || tfirst <= tlast) {
2906 /* see if we need more "t" chars */
2907 if (tfirst > tlast) {
2908 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2910 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2912 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2919 /* now see if we need more "r" chars */
2920 if (rfirst > rlast) {
2922 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2924 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2926 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2935 rfirst = rlast = 0xffffffff;
2939 /* now see which range will peter our first, if either. */
2940 tdiff = tlast - tfirst;
2941 rdiff = rlast - rfirst;
2948 if (rfirst == 0xffffffff) {
2949 diff = tdiff; /* oops, pretend rdiff is infinite */
2951 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2952 (long)tfirst, (long)tlast);
2954 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2958 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2959 (long)tfirst, (long)(tfirst + diff),
2962 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2963 (long)tfirst, (long)rfirst);
2965 if (rfirst + diff > max)
2966 max = rfirst + diff;
2968 grows = (tfirst < rfirst &&
2969 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2981 else if (max > 0xff)
2986 Safefree(cPVOPo->op_pv);
2987 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2988 SvREFCNT_dec(listsv);
2990 SvREFCNT_dec(transv);
2992 if (!del && havefinal && rlen)
2993 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2994 newSVuv((UV)final), 0);
2997 o->op_private |= OPpTRANS_GROWS;
3009 tbl = (short*)cPVOPo->op_pv;
3011 Zero(tbl, 256, short);
3012 for (i = 0; i < tlen; i++)
3014 for (i = 0, j = 0; i < 256; i++) {
3025 if (i < 128 && r[j] >= 128)
3035 o->op_private |= OPpTRANS_IDENTICAL;
3040 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3041 tbl[0x100] = rlen - j;
3042 for (i=0; i < rlen - j; i++)
3043 tbl[0x101+i] = r[j+i];
3047 if (!rlen && !del) {
3050 o->op_private |= OPpTRANS_IDENTICAL;
3052 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3053 o->op_private |= OPpTRANS_IDENTICAL;
3055 for (i = 0; i < 256; i++)
3057 for (i = 0, j = 0; i < tlen; i++,j++) {
3060 if (tbl[t[i]] == -1)
3066 if (tbl[t[i]] == -1) {
3067 if (t[i] < 128 && r[j] >= 128)
3074 o->op_private |= OPpTRANS_GROWS;
3082 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3086 NewOp(1101, pmop, 1, PMOP);
3087 pmop->op_type = type;
3088 pmop->op_ppaddr = PL_ppaddr[type];
3089 pmop->op_flags = flags;
3090 pmop->op_private = 0 | (flags >> 8);
3092 if (PL_hints & HINT_RE_TAINT)
3093 pmop->op_pmpermflags |= PMf_RETAINT;
3094 if (PL_hints & HINT_LOCALE)
3095 pmop->op_pmpermflags |= PMf_LOCALE;
3096 pmop->op_pmflags = pmop->op_pmpermflags;
3101 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3102 repointer = av_pop((AV*)PL_regex_pad[0]);
3103 pmop->op_pmoffset = SvIV(repointer);
3104 SvREPADTMP_off(repointer);
3105 sv_setiv(repointer,0);
3107 repointer = newSViv(0);
3108 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3109 pmop->op_pmoffset = av_len(PL_regex_padav);
3110 PL_regex_pad = AvARRAY(PL_regex_padav);
3115 /* link into pm list */
3116 if (type != OP_TRANS && PL_curstash) {
3117 pmop->op_pmnext = HvPMROOT(PL_curstash);
3118 HvPMROOT(PL_curstash) = pmop;
3119 PmopSTASH_set(pmop,PL_curstash);
3126 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3130 I32 repl_has_vars = 0;
3132 if (o->op_type == OP_TRANS)
3133 return pmtrans(o, expr, repl);
3135 PL_hints |= HINT_BLOCK_SCOPE;
3138 if (expr->op_type == OP_CONST) {
3140 SV *pat = ((SVOP*)expr)->op_sv;
3141 char *p = SvPV(pat, plen);
3142 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3143 sv_setpvn(pat, "\\s+", 3);
3144 p = SvPV(pat, plen);
3145 pm->op_pmflags |= PMf_SKIPWHITE;
3148 pm->op_pmdynflags |= PMdf_UTF8;
3149 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3150 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3151 pm->op_pmflags |= PMf_WHITE;
3155 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3156 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3158 : OP_REGCMAYBE),0,expr);
3160 NewOp(1101, rcop, 1, LOGOP);
3161 rcop->op_type = OP_REGCOMP;
3162 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3163 rcop->op_first = scalar(expr);
3164 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3165 ? (OPf_SPECIAL | OPf_KIDS)
3167 rcop->op_private = 1;
3170 /* establish postfix order */
3171 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3173 rcop->op_next = expr;
3174 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3177 rcop->op_next = LINKLIST(expr);
3178 expr->op_next = (OP*)rcop;
3181 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3186 if (pm->op_pmflags & PMf_EVAL) {
3188 if (CopLINE(PL_curcop) < PL_multi_end)
3189 CopLINE_set(PL_curcop, PL_multi_end);
3191 #ifdef USE_5005THREADS
3192 else if (repl->op_type == OP_THREADSV
3193 && strchr("&`'123456789+",
3194 PL_threadsv_names[repl->op_targ]))
3198 #endif /* USE_5005THREADS */
3199 else if (repl->op_type == OP_CONST)
3203 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3204 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3205 #ifdef USE_5005THREADS
3206 if (curop->op_type == OP_THREADSV) {
3208 if (strchr("&`'123456789+", curop->op_private))
3212 if (curop->op_type == OP_GV) {
3213 GV *gv = cGVOPx_gv(curop);
3215 if (strchr("&`'123456789+", *GvENAME(gv)))
3218 #endif /* USE_5005THREADS */
3219 else if (curop->op_type == OP_RV2CV)
3221 else if (curop->op_type == OP_RV2SV ||
3222 curop->op_type == OP_RV2AV ||
3223 curop->op_type == OP_RV2HV ||
3224 curop->op_type == OP_RV2GV) {
3225 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3228 else if (curop->op_type == OP_PADSV ||
3229 curop->op_type == OP_PADAV ||
3230 curop->op_type == OP_PADHV ||
3231 curop->op_type == OP_PADANY) {
3234 else if (curop->op_type == OP_PUSHRE)
3235 ; /* Okay here, dangerous in newASSIGNOP */
3245 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3246 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3247 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3248 prepend_elem(o->op_type, scalar(repl), o);
3251 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3252 pm->op_pmflags |= PMf_MAYBE_CONST;
3253 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3255 NewOp(1101, rcop, 1, LOGOP);
3256 rcop->op_type = OP_SUBSTCONT;
3257 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3258 rcop->op_first = scalar(repl);
3259 rcop->op_flags |= OPf_KIDS;
3260 rcop->op_private = 1;
3263 /* establish postfix order */
3264 rcop->op_next = LINKLIST(repl);
3265 repl->op_next = (OP*)rcop;
3267 pm->op_pmreplroot = scalar((OP*)rcop);
3268 pm->op_pmreplstart = LINKLIST(rcop);
3277 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3280 NewOp(1101, svop, 1, SVOP);
3281 svop->op_type = type;
3282 svop->op_ppaddr = PL_ppaddr[type];
3284 svop->op_next = (OP*)svop;
3285 svop->op_flags = flags;
3286 if (PL_opargs[type] & OA_RETSCALAR)
3288 if (PL_opargs[type] & OA_TARGET)
3289 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3290 return CHECKOP(type, svop);
3294 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3297 NewOp(1101, padop, 1, PADOP);
3298 padop->op_type = type;
3299 padop->op_ppaddr = PL_ppaddr[type];
3300 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3301 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3302 PL_curpad[padop->op_padix] = sv;
3304 padop->op_next = (OP*)padop;
3305 padop->op_flags = flags;
3306 if (PL_opargs[type] & OA_RETSCALAR)
3308 if (PL_opargs[type] & OA_TARGET)
3309 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3310 return CHECKOP(type, padop);
3314 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3318 return newPADOP(type, flags, SvREFCNT_inc(gv));
3320 return newSVOP(type, flags, SvREFCNT_inc(gv));
3325 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3328 NewOp(1101, pvop, 1, PVOP);
3329 pvop->op_type = type;
3330 pvop->op_ppaddr = PL_ppaddr[type];
3332 pvop->op_next = (OP*)pvop;
3333 pvop->op_flags = flags;
3334 if (PL_opargs[type] & OA_RETSCALAR)
3336 if (PL_opargs[type] & OA_TARGET)
3337 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3338 return CHECKOP(type, pvop);
3342 Perl_package(pTHX_ OP *o)
3346 save_hptr(&PL_curstash);
3347 save_item(PL_curstname);
3352 name = SvPV(sv, len);
3353 PL_curstash = gv_stashpvn(name,len,TRUE);
3354 sv_setpvn(PL_curstname, name, len);
3358 deprecate("\"package\" with no arguments");
3359 sv_setpv(PL_curstname,"<none>");
3360 PL_curstash = Nullhv;
3362 PL_hints |= HINT_BLOCK_SCOPE;
3363 PL_copline = NOLINE;
3368 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3373 char *packname = Nullch;
3377 if (id->op_type != OP_CONST)
3378 Perl_croak(aTHX_ "Module name must be constant");
3382 if (version != Nullop) {
3383 SV *vesv = ((SVOP*)version)->op_sv;
3385 if (arg == Nullop && !SvNIOKp(vesv)) {
3392 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3393 Perl_croak(aTHX_ "Version number must be constant number");
3395 /* Make copy of id so we don't free it twice */
3396 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3398 /* Fake up a method call to VERSION */
3399 meth = newSVpvn("VERSION",7);
3400 sv_upgrade(meth, SVt_PVIV);
3401 (void)SvIOK_on(meth);
3402 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3403 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3404 append_elem(OP_LIST,
3405 prepend_elem(OP_LIST, pack, list(version)),
3406 newSVOP(OP_METHOD_NAMED, 0, meth)));
3410 /* Fake up an import/unimport */
3411 if (arg && arg->op_type == OP_STUB)
3412 imop = arg; /* no import on explicit () */
3413 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3414 imop = Nullop; /* use 5.0; */
3419 /* Make copy of id so we don't free it twice */
3420 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3422 /* Fake up a method call to import/unimport */
3423 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3424 (void)SvUPGRADE(meth, SVt_PVIV);
3425 (void)SvIOK_on(meth);
3426 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3427 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3428 append_elem(OP_LIST,
3429 prepend_elem(OP_LIST, pack, list(arg)),
3430 newSVOP(OP_METHOD_NAMED, 0, meth)));
3433 if (ckWARN(WARN_MISC) &&
3434 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3435 SvPOK(packsv = ((SVOP*)id)->op_sv))
3437 /* BEGIN will free the ops, so we need to make a copy */
3438 packlen = SvCUR(packsv);
3439 packname = savepvn(SvPVX(packsv), packlen);
3442 /* Fake up the BEGIN {}, which does its thing immediately. */
3444 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3447 append_elem(OP_LINESEQ,
3448 append_elem(OP_LINESEQ,
3449 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3450 newSTATEOP(0, Nullch, veop)),
3451 newSTATEOP(0, Nullch, imop) ));
3454 /* The "did you use incorrect case?" warning used to be here.
3455 * The problem is that on case-insensitive filesystems one
3456 * might get false positives for "use" (and "require"):
3457 * "use Strict" or "require CARP" will work. This causes
3458 * portability problems for the script: in case-strict
3459 * filesystems the script will stop working.
3461 * The "incorrect case" warning checked whether "use Foo"
3462 * imported "Foo" to your namespace, but that is wrong, too:
3463 * there is no requirement nor promise in the language that
3464 * a Foo.pm should or would contain anything in package "Foo".
3466 * There is very little Configure-wise that can be done, either:
3467 * the case-sensitivity of the build filesystem of Perl does not
3468 * help in guessing the case-sensitivity of the runtime environment.
3473 PL_hints |= HINT_BLOCK_SCOPE;
3474 PL_copline = NOLINE;
3479 =head1 Embedding Functions
3481 =for apidoc load_module
3483 Loads the module whose name is pointed to by the string part of name.
3484 Note that the actual module name, not its filename, should be given.
3485 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3486 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3487 (or 0 for no flags). ver, if specified, provides version semantics
3488 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3489 arguments can be used to specify arguments to the module's import()
3490 method, similar to C<use Foo::Bar VERSION LIST>.
3495 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3498 va_start(args, ver);
3499 vload_module(flags, name, ver, &args);
3503 #ifdef PERL_IMPLICIT_CONTEXT
3505 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3509 va_start(args, ver);
3510 vload_module(flags, name, ver, &args);
3516 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3518 OP *modname, *veop, *imop;
3520 modname = newSVOP(OP_CONST, 0, name);
3521 modname->op_private |= OPpCONST_BARE;
3523 veop = newSVOP(OP_CONST, 0, ver);
3527 if (flags & PERL_LOADMOD_NOIMPORT) {
3528 imop = sawparens(newNULLLIST());
3530 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3531 imop = va_arg(*args, OP*);
3536 sv = va_arg(*args, SV*);
3538 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3539 sv = va_arg(*args, SV*);
3543 line_t ocopline = PL_copline;
3544 int oexpect = PL_expect;
3546 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3547 veop, modname, imop);
3548 PL_expect = oexpect;
3549 PL_copline = ocopline;
3554 Perl_dofile(pTHX_ OP *term)
3559 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3560 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3561 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3563 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3564 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3565 append_elem(OP_LIST, term,
3566 scalar(newUNOP(OP_RV2CV, 0,
3571 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3577 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3579 return newBINOP(OP_LSLICE, flags,
3580 list(force_list(subscript)),
3581 list(force_list(listval)) );
3585 S_list_assignment(pTHX_ register OP *o)
3590 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3591 o = cUNOPo->op_first;
3593 if (o->op_type == OP_COND_EXPR) {
3594 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3595 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3600 yyerror("Assignment to both a list and a scalar");
3604 if (o->op_type == OP_LIST &&
3605 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3606 o->op_private & OPpLVAL_INTRO)
3609 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3610 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3611 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3614 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3617 if (o->op_type == OP_RV2SV)
3624 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3629 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3630 return newLOGOP(optype, 0,
3631 mod(scalar(left), optype),
3632 newUNOP(OP_SASSIGN, 0, scalar(right)));
3635 return newBINOP(optype, OPf_STACKED,
3636 mod(scalar(left), optype), scalar(right));
3640 if (list_assignment(left)) {
3644 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3645 left = mod(left, OP_AASSIGN);
3653 curop = list(force_list(left));
3654 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3655 o->op_private = 0 | (flags >> 8);
3656 for (curop = ((LISTOP*)curop)->op_first;
3657 curop; curop = curop->op_sibling)
3659 if (curop->op_type == OP_RV2HV &&
3660 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3661 o->op_private |= OPpASSIGN_HASH;
3665 if (!(left->op_private & OPpLVAL_INTRO)) {
3668 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3669 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3670 if (curop->op_type == OP_GV) {
3671 GV *gv = cGVOPx_gv(curop);
3672 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3674 SvCUR(gv) = PL_generation;
3676 else if (curop->op_type == OP_PADSV ||
3677 curop->op_type == OP_PADAV ||
3678 curop->op_type == OP_PADHV ||
3679 curop->op_type == OP_PADANY) {
3680 SV **svp = AvARRAY(PL_comppad_name);
3681 SV *sv = svp[curop->op_targ];
3682 if (SvCUR(sv) == PL_generation)
3684 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3686 else if (curop->op_type == OP_RV2CV)
3688 else if (curop->op_type == OP_RV2SV ||
3689 curop->op_type == OP_RV2AV ||
3690 curop->op_type == OP_RV2HV ||
3691 curop->op_type == OP_RV2GV) {
3692 if (lastop->op_type != OP_GV) /* funny deref? */
3695 else if (curop->op_type == OP_PUSHRE) {
3696 if (((PMOP*)curop)->op_pmreplroot) {
3698 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3700 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3702 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3704 SvCUR(gv) = PL_generation;
3713 o->op_private |= OPpASSIGN_COMMON;
3715 if (right && right->op_type == OP_SPLIT) {
3717 if ((tmpop = ((LISTOP*)right)->op_first) &&
3718 tmpop->op_type == OP_PUSHRE)
3720 PMOP *pm = (PMOP*)tmpop;
3721 if (left->op_type == OP_RV2AV &&
3722 !(left->op_private & OPpLVAL_INTRO) &&
3723 !(o->op_private & OPpASSIGN_COMMON) )
3725 tmpop = ((UNOP*)left)->op_first;
3726 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3728 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3729 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3731 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3732 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3734 pm->op_pmflags |= PMf_ONCE;
3735 tmpop = cUNOPo->op_first; /* to list (nulled) */
3736 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3737 tmpop->op_sibling = Nullop; /* don't free split */
3738 right->op_next = tmpop->op_next; /* fix starting loc */
3739 op_free(o); /* blow off assign */
3740 right->op_flags &= ~OPf_WANT;
3741 /* "I don't know and I don't care." */
3746 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3747 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3749 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3751 sv_setiv(sv, PL_modcount+1);
3759 right = newOP(OP_UNDEF, 0);
3760 if (right->op_type == OP_READLINE) {
3761 right->op_flags |= OPf_STACKED;
3762 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3765 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3766 o = newBINOP(OP_SASSIGN, flags,
3767 scalar(right), mod(scalar(left), OP_SASSIGN) );
3779 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3781 U32 seq = intro_my();
3784 NewOp(1101, cop, 1, COP);
3785 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3786 cop->op_type = OP_DBSTATE;
3787 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3790 cop->op_type = OP_NEXTSTATE;
3791 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3793 cop->op_flags = flags;
3794 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3796 cop->op_private |= NATIVE_HINTS;
3798 PL_compiling.op_private = cop->op_private;
3799 cop->op_next = (OP*)cop;
3802 cop->cop_label = label;
3803 PL_hints |= HINT_BLOCK_SCOPE;
3806 cop->cop_arybase = PL_curcop->cop_arybase;
3807 if (specialWARN(PL_curcop->cop_warnings))
3808 cop->cop_warnings = PL_curcop->cop_warnings ;
3810 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3811 if (specialCopIO(PL_curcop->cop_io))
3812 cop->cop_io = PL_curcop->cop_io;
3814 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3817 if (PL_copline == NOLINE)
3818 CopLINE_set(cop, CopLINE(PL_curcop));
3820 CopLINE_set(cop, PL_copline);
3821 PL_copline = NOLINE;
3824 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3826 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3828 CopSTASH_set(cop, PL_curstash);
3830 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3831 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3832 if (svp && *svp != &PL_sv_undef ) {
3833 (void)SvIOK_on(*svp);
3834 SvIVX(*svp) = PTR2IV(cop);
3838 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3841 /* "Introduce" my variables to visible status. */
3849 if (! PL_min_intro_pending)
3850 return PL_cop_seqmax;
3852 svp = AvARRAY(PL_comppad_name);
3853 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3854 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3855 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3856 SvNVX(sv) = (NV)PL_cop_seqmax;
3859 PL_min_intro_pending = 0;
3860 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3861 return PL_cop_seqmax++;
3865 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3867 return new_logop(type, flags, &first, &other);
3871 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3875 OP *first = *firstp;
3876 OP *other = *otherp;
3878 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3879 return newBINOP(type, flags, scalar(first), scalar(other));
3881 scalarboolean(first);
3882 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3883 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3884 if (type == OP_AND || type == OP_OR) {
3890 first = *firstp = cUNOPo->op_first;
3892 first->op_next = o->op_next;
3893 cUNOPo->op_first = Nullop;
3897 if (first->op_type == OP_CONST) {
3898 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3899 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3900 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3911 else if (first->op_type == OP_WANTARRAY) {
3917 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3918 OP *k1 = ((UNOP*)first)->op_first;
3919 OP *k2 = k1->op_sibling;
3921 switch (first->op_type)
3924 if (k2 && k2->op_type == OP_READLINE
3925 && (k2->op_flags & OPf_STACKED)
3926 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3928 warnop = k2->op_type;
3933 if (k1->op_type == OP_READDIR
3934 || k1->op_type == OP_GLOB
3935 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3936 || k1->op_type == OP_EACH)
3938 warnop = ((k1->op_type == OP_NULL)
3939 ? k1->op_targ : k1->op_type);
3944 line_t oldline = CopLINE(PL_curcop);
3945 CopLINE_set(PL_curcop, PL_copline);
3946 Perl_warner(aTHX_ WARN_MISC,
3947 "Value of %s%s can be \"0\"; test with defined()",
3949 ((warnop == OP_READLINE || warnop == OP_GLOB)
3950 ? " construct" : "() operator"));
3951 CopLINE_set(PL_curcop, oldline);
3958 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3959 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3961 NewOp(1101, logop, 1, LOGOP);
3963 logop->op_type = type;
3964 logop->op_ppaddr = PL_ppaddr[type];
3965 logop->op_first = first;
3966 logop->op_flags = flags | OPf_KIDS;
3967 logop->op_other = LINKLIST(other);
3968 logop->op_private = 1 | (flags >> 8);
3970 /* establish postfix order */
3971 logop->op_next = LINKLIST(first);
3972 first->op_next = (OP*)logop;
3973 first->op_sibling = other;
3975 o = newUNOP(OP_NULL, 0, (OP*)logop);
3982 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3989 return newLOGOP(OP_AND, 0, first, trueop);
3991 return newLOGOP(OP_OR, 0, first, falseop);
3993 scalarboolean(first);
3994 if (first->op_type == OP_CONST) {
3995 if (SvTRUE(((SVOP*)first)->op_sv)) {
4006 else if (first->op_type == OP_WANTARRAY) {
4010 NewOp(1101, logop, 1, LOGOP);
4011 logop->op_type = OP_COND_EXPR;
4012 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4013 logop->op_first = first;
4014 logop->op_flags = flags | OPf_KIDS;
4015 logop->op_private = 1 | (flags >> 8);
4016 logop->op_other = LINKLIST(trueop);
4017 logop->op_next = LINKLIST(falseop);
4020 /* establish postfix order */
4021 start = LINKLIST(first);
4022 first->op_next = (OP*)logop;
4024 first->op_sibling = trueop;
4025 trueop->op_sibling = falseop;
4026 o = newUNOP(OP_NULL, 0, (OP*)logop);
4028 trueop->op_next = falseop->op_next = o;
4035 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4043 NewOp(1101, range, 1, LOGOP);
4045 range->op_type = OP_RANGE;
4046 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4047 range->op_first = left;
4048 range->op_flags = OPf_KIDS;
4049 leftstart = LINKLIST(left);
4050 range->op_other = LINKLIST(right);
4051 range->op_private = 1 | (flags >> 8);
4053 left->op_sibling = right;
4055 range->op_next = (OP*)range;
4056 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4057 flop = newUNOP(OP_FLOP, 0, flip);
4058 o = newUNOP(OP_NULL, 0, flop);
4060 range->op_next = leftstart;
4062 left->op_next = flip;
4063 right->op_next = flop;
4065 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4066 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4067 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4068 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4070 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4071 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4074 if (!flip->op_private || !flop->op_private)
4075 linklist(o); /* blow off optimizer unless constant */
4081 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4085 int once = block && block->op_flags & OPf_SPECIAL &&
4086 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4089 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4090 return block; /* do {} while 0 does once */
4091 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4092 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4093 expr = newUNOP(OP_DEFINED, 0,
4094 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4095 } else if (expr->op_flags & OPf_KIDS) {
4096 OP *k1 = ((UNOP*)expr)->op_first;
4097 OP *k2 = (k1) ? k1->op_sibling : NULL;
4098 switch (expr->op_type) {
4100 if (k2 && k2->op_type == OP_READLINE
4101 && (k2->op_flags & OPf_STACKED)
4102 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4103 expr = newUNOP(OP_DEFINED, 0, expr);
4107 if (k1->op_type == OP_READDIR
4108 || k1->op_type == OP_GLOB
4109 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4110 || k1->op_type == OP_EACH)
4111 expr = newUNOP(OP_DEFINED, 0, expr);
4117 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4118 o = new_logop(OP_AND, 0, &expr, &listop);
4121 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4123 if (once && o != listop)
4124 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4127 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4129 o->op_flags |= flags;
4131 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4136 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4144 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4145 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4146 expr = newUNOP(OP_DEFINED, 0,
4147 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4148 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4149 OP *k1 = ((UNOP*)expr)->op_first;
4150 OP *k2 = (k1) ? k1->op_sibling : NULL;
4151 switch (expr->op_type) {
4153 if (k2 && k2->op_type == OP_READLINE
4154 && (k2->op_flags & OPf_STACKED)
4155 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4156 expr = newUNOP(OP_DEFINED, 0, expr);
4160 if (k1->op_type == OP_READDIR
4161 || k1->op_type == OP_GLOB
4162 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4163 || k1->op_type == OP_EACH)
4164 expr = newUNOP(OP_DEFINED, 0, expr);
4170 block = newOP(OP_NULL, 0);
4172 block = scope(block);
4176 next = LINKLIST(cont);
4179 OP *unstack = newOP(OP_UNSTACK, 0);
4182 cont = append_elem(OP_LINESEQ, cont, unstack);
4183 if ((line_t)whileline != NOLINE) {
4184 PL_copline = whileline;
4185 cont = append_elem(OP_LINESEQ, cont,
4186 newSTATEOP(0, Nullch, Nullop));
4190 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4191 redo = LINKLIST(listop);
4194 PL_copline = whileline;
4196 o = new_logop(OP_AND, 0, &expr, &listop);
4197 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4198 op_free(expr); /* oops, it's a while (0) */
4200 return Nullop; /* listop already freed by new_logop */
4203 ((LISTOP*)listop)->op_last->op_next =
4204 (o == listop ? redo : LINKLIST(o));
4210 NewOp(1101,loop,1,LOOP);
4211 loop->op_type = OP_ENTERLOOP;
4212 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4213 loop->op_private = 0;
4214 loop->op_next = (OP*)loop;
4217 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4219 loop->op_redoop = redo;
4220 loop->op_lastop = o;
4221 o->op_private |= loopflags;
4224 loop->op_nextop = next;
4226 loop->op_nextop = o;
4228 o->op_flags |= flags;
4229 o->op_private |= (flags >> 8);
4234 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4242 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4243 sv->op_type = OP_RV2GV;
4244 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4246 else if (sv->op_type == OP_PADSV) { /* private variable */
4247 padoff = sv->op_targ;
4252 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4253 padoff = sv->op_targ;
4255 iterflags |= OPf_SPECIAL;
4260 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4263 #ifdef USE_5005THREADS
4264 padoff = find_threadsv("_");
4265 iterflags |= OPf_SPECIAL;
4267 sv = newGVOP(OP_GV, 0, PL_defgv);
4270 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4271 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4272 iterflags |= OPf_STACKED;
4274 else if (expr->op_type == OP_NULL &&
4275 (expr->op_flags & OPf_KIDS) &&
4276 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4278 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4279 * set the STACKED flag to indicate that these values are to be
4280 * treated as min/max values by 'pp_iterinit'.
4282 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4283 LOGOP* range = (LOGOP*) flip->op_first;
4284 OP* left = range->op_first;
4285 OP* right = left->op_sibling;
4288 range->op_flags &= ~OPf_KIDS;
4289 range->op_first = Nullop;
4291 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4292 listop->op_first->op_next = range->op_next;
4293 left->op_next = range->op_other;
4294 right->op_next = (OP*)listop;
4295 listop->op_next = listop->op_first;
4298 expr = (OP*)(listop);
4300 iterflags |= OPf_STACKED;
4303 expr = mod(force_list(expr), OP_GREPSTART);
4307 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4308 append_elem(OP_LIST, expr, scalar(sv))));
4309 assert(!loop->op_next);
4310 #ifdef PL_OP_SLAB_ALLOC
4313 NewOp(1234,tmp,1,LOOP);
4314 Copy(loop,tmp,1,LOOP);
4319 Renew(loop, 1, LOOP);
4321 loop->op_targ = padoff;
4322 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4323 PL_copline = forline;
4324 return newSTATEOP(0, label, wop);
4328 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4333 if (type != OP_GOTO || label->op_type == OP_CONST) {
4334 /* "last()" means "last" */
4335 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4336 o = newOP(type, OPf_SPECIAL);
4338 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4339 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4345 if (label->op_type == OP_ENTERSUB)
4346 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4347 o = newUNOP(type, OPf_STACKED, label);
4349 PL_hints |= HINT_BLOCK_SCOPE;
4354 Perl_cv_undef(pTHX_ CV *cv)
4356 #ifdef USE_5005THREADS
4358 MUTEX_DESTROY(CvMUTEXP(cv));
4359 Safefree(CvMUTEXP(cv));
4362 #endif /* USE_5005THREADS */
4365 if (CvFILE(cv) && !CvXSUB(cv)) {
4366 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4367 Safefree(CvFILE(cv));
4372 if (!CvXSUB(cv) && CvROOT(cv)) {
4373 #ifdef USE_5005THREADS
4374 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4375 Perl_croak(aTHX_ "Can't undef active subroutine");
4378 Perl_croak(aTHX_ "Can't undef active subroutine");
4379 #endif /* USE_5005THREADS */
4382 SAVEVPTR(PL_curpad);
4385 op_free(CvROOT(cv));
4386 CvROOT(cv) = Nullop;
4389 SvPOK_off((SV*)cv); /* forget prototype */
4391 /* Since closure prototypes have the same lifetime as the containing
4392 * CV, they don't hold a refcount on the outside CV. This avoids
4393 * the refcount loop between the outer CV (which keeps a refcount to
4394 * the closure prototype in the pad entry for pp_anoncode()) and the
4395 * closure prototype, and the ensuing memory leak. --GSAR */
4396 if (!CvANON(cv) || CvCLONED(cv))
4397 SvREFCNT_dec(CvOUTSIDE(cv));
4398 CvOUTSIDE(cv) = Nullcv;
4400 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4403 if (CvPADLIST(cv)) {
4404 /* may be during global destruction */
4405 if (SvREFCNT(CvPADLIST(cv))) {
4406 I32 i = AvFILLp(CvPADLIST(cv));
4408 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4409 SV* sv = svp ? *svp : Nullsv;
4412 if (sv == (SV*)PL_comppad_name)
4413 PL_comppad_name = Nullav;
4414 else if (sv == (SV*)PL_comppad) {
4415 PL_comppad = Nullav;
4416 PL_curpad = Null(SV**);
4420 SvREFCNT_dec((SV*)CvPADLIST(cv));
4422 CvPADLIST(cv) = Nullav;
4430 #ifdef DEBUG_CLOSURES
4432 S_cv_dump(pTHX_ CV *cv)
4435 CV *outside = CvOUTSIDE(cv);
4436 AV* padlist = CvPADLIST(cv);
4443 PerlIO_printf(Perl_debug_log,
4444 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4446 (CvANON(cv) ? "ANON"
4447 : (cv == PL_main_cv) ? "MAIN"
4448 : CvUNIQUE(cv) ? "UNIQUE"
4449 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4452 : CvANON(outside) ? "ANON"
4453 : (outside == PL_main_cv) ? "MAIN"
4454 : CvUNIQUE(outside) ? "UNIQUE"
4455 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4460 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4461 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4462 pname = AvARRAY(pad_name);
4463 ppad = AvARRAY(pad);
4465 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4466 if (SvPOK(pname[ix]))
4467 PerlIO_printf(Perl_debug_log,
4468 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4469 (int)ix, PTR2UV(ppad[ix]),
4470 SvFAKE(pname[ix]) ? "FAKE " : "",
4472 (IV)I_32(SvNVX(pname[ix])),
4475 #endif /* DEBUGGING */
4477 #endif /* DEBUG_CLOSURES */
4480 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4484 AV* protopadlist = CvPADLIST(proto);
4485 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4486 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4487 SV** pname = AvARRAY(protopad_name);
4488 SV** ppad = AvARRAY(protopad);
4489 I32 fname = AvFILLp(protopad_name);
4490 I32 fpad = AvFILLp(protopad);
4494 assert(!CvUNIQUE(proto));
4498 SAVESPTR(PL_comppad_name);
4499 SAVESPTR(PL_compcv);
4501 cv = PL_compcv = (CV*)NEWSV(1104,0);
4502 sv_upgrade((SV *)cv, SvTYPE(proto));
4503 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4506 #ifdef USE_5005THREADS
4507 New(666, CvMUTEXP(cv), 1, perl_mutex);
4508 MUTEX_INIT(CvMUTEXP(cv));
4510 #endif /* USE_5005THREADS */
4512 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4513 : savepv(CvFILE(proto));
4515 CvFILE(cv) = CvFILE(proto);
4517 CvGV(cv) = CvGV(proto);
4518 CvSTASH(cv) = CvSTASH(proto);
4519 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4520 CvSTART(cv) = CvSTART(proto);
4522 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4525 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4527 PL_comppad_name = newAV();
4528 for (ix = fname; ix >= 0; ix--)
4529 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4531 PL_comppad = newAV();
4533 comppadlist = newAV();
4534 AvREAL_off(comppadlist);
4535 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4536 av_store(comppadlist, 1, (SV*)PL_comppad);
4537 CvPADLIST(cv) = comppadlist;
4538 av_fill(PL_comppad, AvFILLp(protopad));
4539 PL_curpad = AvARRAY(PL_comppad);
4541 av = newAV(); /* will be @_ */
4543 av_store(PL_comppad, 0, (SV*)av);
4544 AvFLAGS(av) = AVf_REIFY;
4546 for (ix = fpad; ix > 0; ix--) {
4547 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4548 if (namesv && namesv != &PL_sv_undef) {
4549 char *name = SvPVX(namesv); /* XXX */
4550 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4551 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4552 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4554 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4556 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4558 else { /* our own lexical */
4561 /* anon code -- we'll come back for it */
4562 sv = SvREFCNT_inc(ppad[ix]);
4564 else if (*name == '@')
4566 else if (*name == '%')
4575 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4576 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4579 SV* sv = NEWSV(0,0);
4585 /* Now that vars are all in place, clone nested closures. */
4587 for (ix = fpad; ix > 0; ix--) {
4588 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4590 && namesv != &PL_sv_undef
4591 && !(SvFLAGS(namesv) & SVf_FAKE)
4592 && *SvPVX(namesv) == '&'
4593 && CvCLONE(ppad[ix]))
4595 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4596 SvREFCNT_dec(ppad[ix]);
4599 PL_curpad[ix] = (SV*)kid;
4603 #ifdef DEBUG_CLOSURES
4604 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4606 PerlIO_printf(Perl_debug_log, " from:\n");
4608 PerlIO_printf(Perl_debug_log, " to:\n");
4615 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4617 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4619 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4626 Perl_cv_clone(pTHX_ CV *proto)
4629 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4630 cv = cv_clone2(proto, CvOUTSIDE(proto));
4631 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4636 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4638 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4639 SV* msg = sv_newmortal();
4643 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4644 sv_setpv(msg, "Prototype mismatch:");
4646 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4648 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4649 sv_catpv(msg, " vs ");
4651 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4653 sv_catpv(msg, "none");
4654 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4658 static void const_sv_xsub(pTHX_ CV* cv);
4662 =head1 Optree Manipulation Functions
4664 =for apidoc cv_const_sv
4666 If C<cv> is a constant sub eligible for inlining. returns the constant
4667 value returned by the sub. Otherwise, returns NULL.
4669 Constant subs can be created with C<newCONSTSUB> or as described in
4670 L<perlsub/"Constant Functions">.
4675 Perl_cv_const_sv(pTHX_ CV *cv)
4677 if (!cv || !CvCONST(cv))
4679 return (SV*)CvXSUBANY(cv).any_ptr;
4683 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4690 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4691 o = cLISTOPo->op_first->op_sibling;
4693 for (; o; o = o->op_next) {
4694 OPCODE type = o->op_type;
4696 if (sv && o->op_next == o)
4698 if (o->op_next != o) {
4699 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4701 if (type == OP_DBSTATE)
4704 if (type == OP_LEAVESUB || type == OP_RETURN)
4708 if (type == OP_CONST && cSVOPo->op_sv)
4710 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4711 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4712 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4716 /* We get here only from cv_clone2() while creating a closure.
4717 Copy the const value here instead of in cv_clone2 so that
4718 SvREADONLY_on doesn't lead to problems when leaving
4723 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4735 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4745 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4749 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4751 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4755 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4761 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4766 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4767 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4768 SV *sv = sv_newmortal();
4769 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4770 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4771 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4776 gv = gv_fetchpv(name ? name : (aname ? aname :
4777 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4778 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4788 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4789 maximum a prototype before. */
4790 if (SvTYPE(gv) > SVt_NULL) {
4791 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4792 && ckWARN_d(WARN_PROTOTYPE))
4794 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4796 cv_ckproto((CV*)gv, NULL, ps);
4799 sv_setpv((SV*)gv, ps);
4801 sv_setiv((SV*)gv, -1);
4802 SvREFCNT_dec(PL_compcv);
4803 cv = PL_compcv = NULL;
4804 PL_sub_generation++;
4808 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4810 #ifdef GV_UNIQUE_CHECK
4811 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4812 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4816 if (!block || !ps || *ps || attrs)
4819 const_sv = op_const_sv(block, Nullcv);
4822 bool exists = CvROOT(cv) || CvXSUB(cv);
4824 #ifdef GV_UNIQUE_CHECK
4825 if (exists && GvUNIQUE(gv)) {
4826 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4830 /* if the subroutine doesn't exist and wasn't pre-declared
4831 * with a prototype, assume it will be AUTOLOADed,
4832 * skipping the prototype check
4834 if (exists || SvPOK(cv))
4835 cv_ckproto(cv, gv, ps);
4836 /* already defined (or promised)? */
4837 if (exists || GvASSUMECV(gv)) {
4838 if (!block && !attrs) {
4839 /* just a "sub foo;" when &foo is already defined */
4840 SAVEFREESV(PL_compcv);
4843 /* ahem, death to those who redefine active sort subs */
4844 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4845 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4847 if (ckWARN(WARN_REDEFINE)
4849 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4851 line_t oldline = CopLINE(PL_curcop);
4852 if (PL_copline != NOLINE)
4853 CopLINE_set(PL_curcop, PL_copline);
4854 Perl_warner(aTHX_ WARN_REDEFINE,
4855 CvCONST(cv) ? "Constant subroutine %s redefined"
4856 : "Subroutine %s redefined", name);
4857 CopLINE_set(PL_curcop, oldline);
4865 SvREFCNT_inc(const_sv);
4867 assert(!CvROOT(cv) && !CvCONST(cv));
4868 sv_setpv((SV*)cv, ""); /* prototype is "" */
4869 CvXSUBANY(cv).any_ptr = const_sv;
4870 CvXSUB(cv) = const_sv_xsub;
4875 cv = newCONSTSUB(NULL, name, const_sv);
4878 SvREFCNT_dec(PL_compcv);
4880 PL_sub_generation++;
4887 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4888 * before we clobber PL_compcv.
4892 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4893 stash = GvSTASH(CvGV(cv));
4894 else if (CvSTASH(cv))
4895 stash = CvSTASH(cv);
4897 stash = PL_curstash;
4900 /* possibly about to re-define existing subr -- ignore old cv */
4901 rcv = (SV*)PL_compcv;
4902 if (name && GvSTASH(gv))
4903 stash = GvSTASH(gv);
4905 stash = PL_curstash;
4907 apply_attrs(stash, rcv, attrs, FALSE);
4909 if (cv) { /* must reuse cv if autoloaded */
4911 /* got here with just attrs -- work done, so bug out */
4912 SAVEFREESV(PL_compcv);
4916 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4917 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4918 CvOUTSIDE(PL_compcv) = 0;
4919 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4920 CvPADLIST(PL_compcv) = 0;
4921 /* inner references to PL_compcv must be fixed up ... */
4923 AV *padlist = CvPADLIST(cv);
4924 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4925 AV *comppad = (AV*)AvARRAY(padlist)[1];
4926 SV **namepad = AvARRAY(comppad_name);
4927 SV **curpad = AvARRAY(comppad);
4928 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4929 SV *namesv = namepad[ix];
4930 if (namesv && namesv != &PL_sv_undef
4931 && *SvPVX(namesv) == '&')
4933 CV *innercv = (CV*)curpad[ix];
4934 if (CvOUTSIDE(innercv) == PL_compcv) {
4935 CvOUTSIDE(innercv) = cv;
4936 if (!CvANON(innercv) || CvCLONED(innercv)) {
4937 (void)SvREFCNT_inc(cv);
4938 SvREFCNT_dec(PL_compcv);
4944 /* ... before we throw it away */
4945 SvREFCNT_dec(PL_compcv);
4946 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4947 ++PL_sub_generation;
4954 PL_sub_generation++;
4958 CvFILE_set_from_cop(cv, PL_curcop);
4959 CvSTASH(cv) = PL_curstash;
4960 #ifdef USE_5005THREADS
4962 if (!CvMUTEXP(cv)) {
4963 New(666, CvMUTEXP(cv), 1, perl_mutex);
4964 MUTEX_INIT(CvMUTEXP(cv));
4966 #endif /* USE_5005THREADS */
4969 sv_setpv((SV*)cv, ps);
4971 if (PL_error_count) {
4975 char *s = strrchr(name, ':');
4977 if (strEQ(s, "BEGIN")) {
4979 "BEGIN not safe after errors--compilation aborted";
4980 if (PL_in_eval & EVAL_KEEPERR)
4981 Perl_croak(aTHX_ not_safe);
4983 /* force display of errors found but not reported */
4984 sv_catpv(ERRSV, not_safe);
4985 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4993 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4994 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4997 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4998 mod(scalarseq(block), OP_LEAVESUBLV));
5001 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5003 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5004 OpREFCNT_set(CvROOT(cv), 1);
5005 CvSTART(cv) = LINKLIST(CvROOT(cv));
5006 CvROOT(cv)->op_next = 0;
5007 CALL_PEEP(CvSTART(cv));
5009 /* now that optimizer has done its work, adjust pad values */
5011 SV **namep = AvARRAY(PL_comppad_name);
5012 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5015 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5018 * The only things that a clonable function needs in its
5019 * pad are references to outer lexicals and anonymous subs.
5020 * The rest are created anew during cloning.
5022 if (!((namesv = namep[ix]) != Nullsv &&
5023 namesv != &PL_sv_undef &&
5025 *SvPVX(namesv) == '&')))
5027 SvREFCNT_dec(PL_curpad[ix]);
5028 PL_curpad[ix] = Nullsv;
5031 assert(!CvCONST(cv));
5032 if (ps && !*ps && op_const_sv(block, cv))
5036 AV *av = newAV(); /* Will be @_ */
5038 av_store(PL_comppad, 0, (SV*)av);
5039 AvFLAGS(av) = AVf_REIFY;
5041 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5042 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5044 if (!SvPADMY(PL_curpad[ix]))
5045 SvPADTMP_on(PL_curpad[ix]);
5049 /* If a potential closure prototype, don't keep a refcount on outer CV.
5050 * This is okay as the lifetime of the prototype is tied to the
5051 * lifetime of the outer CV. Avoids memory leak due to reference
5054 SvREFCNT_dec(CvOUTSIDE(cv));
5056 if (name || aname) {
5058 char *tname = (name ? name : aname);
5060 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5061 SV *sv = NEWSV(0,0);
5062 SV *tmpstr = sv_newmortal();
5063 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5067 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5069 (long)PL_subline, (long)CopLINE(PL_curcop));
5070 gv_efullname3(tmpstr, gv, Nullch);
5071 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5072 hv = GvHVn(db_postponed);
5073 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5074 && (pcv = GvCV(db_postponed)))
5080 call_sv((SV*)pcv, G_DISCARD);
5084 if ((s = strrchr(tname,':')))
5089 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5092 if (strEQ(s, "BEGIN")) {
5093 I32 oldscope = PL_scopestack_ix;
5095 SAVECOPFILE(&PL_compiling);
5096 SAVECOPLINE(&PL_compiling);
5099 PL_beginav = newAV();
5100 DEBUG_x( dump_sub(gv) );
5101 av_push(PL_beginav, (SV*)cv);
5102 GvCV(gv) = 0; /* cv has been hijacked */
5103 call_list(oldscope, PL_beginav);
5105 PL_curcop = &PL_compiling;
5106 PL_compiling.op_private = PL_hints;
5109 else if (strEQ(s, "END") && !PL_error_count) {
5112 DEBUG_x( dump_sub(gv) );
5113 av_unshift(PL_endav, 1);
5114 av_store(PL_endav, 0, (SV*)cv);
5115 GvCV(gv) = 0; /* cv has been hijacked */
5117 else if (strEQ(s, "CHECK") && !PL_error_count) {
5119 PL_checkav = newAV();
5120 DEBUG_x( dump_sub(gv) );
5121 if (PL_main_start && ckWARN(WARN_VOID))
5122 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5123 av_unshift(PL_checkav, 1);
5124 av_store(PL_checkav, 0, (SV*)cv);
5125 GvCV(gv) = 0; /* cv has been hijacked */
5127 else if (strEQ(s, "INIT") && !PL_error_count) {
5129 PL_initav = newAV();
5130 DEBUG_x( dump_sub(gv) );
5131 if (PL_main_start && ckWARN(WARN_VOID))
5132 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5133 av_push(PL_initav, (SV*)cv);
5134 GvCV(gv) = 0; /* cv has been hijacked */
5139 PL_copline = NOLINE;
5144 /* XXX unsafe for threads if eval_owner isn't held */
5146 =for apidoc newCONSTSUB
5148 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5149 eligible for inlining at compile-time.
5155 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5161 SAVECOPLINE(PL_curcop);
5162 CopLINE_set(PL_curcop, PL_copline);
5165 PL_hints &= ~HINT_BLOCK_SCOPE;
5168 SAVESPTR(PL_curstash);
5169 SAVECOPSTASH(PL_curcop);
5170 PL_curstash = stash;
5171 CopSTASH_set(PL_curcop,stash);
5174 cv = newXS(name, const_sv_xsub, __FILE__);
5175 CvXSUBANY(cv).any_ptr = sv;
5177 sv_setpv((SV*)cv, ""); /* prototype is "" */
5185 =for apidoc U||newXS
5187 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5193 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5195 GV *gv = gv_fetchpv(name ? name :
5196 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5197 GV_ADDMULTI, SVt_PVCV);
5200 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5202 /* just a cached method */
5206 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5207 /* already defined (or promised) */
5208 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5209 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5210 line_t oldline = CopLINE(PL_curcop);
5211 if (PL_copline != NOLINE)
5212 CopLINE_set(PL_curcop, PL_copline);
5213 Perl_warner(aTHX_ WARN_REDEFINE,
5214 CvCONST(cv) ? "Constant subroutine %s redefined"
5215 : "Subroutine %s redefined"
5217 CopLINE_set(PL_curcop, oldline);
5224 if (cv) /* must reuse cv if autoloaded */
5227 cv = (CV*)NEWSV(1105,0);
5228 sv_upgrade((SV *)cv, SVt_PVCV);
5232 PL_sub_generation++;
5236 #ifdef USE_5005THREADS
5237 New(666, CvMUTEXP(cv), 1, perl_mutex);
5238 MUTEX_INIT(CvMUTEXP(cv));
5240 #endif /* USE_5005THREADS */
5241 (void)gv_fetchfile(filename);
5242 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5243 an external constant string */
5244 CvXSUB(cv) = subaddr;
5247 char *s = strrchr(name,':');
5253 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5256 if (strEQ(s, "BEGIN")) {
5258 PL_beginav = newAV();
5259 av_push(PL_beginav, (SV*)cv);
5260 GvCV(gv) = 0; /* cv has been hijacked */
5262 else if (strEQ(s, "END")) {
5265 av_unshift(PL_endav, 1);
5266 av_store(PL_endav, 0, (SV*)cv);
5267 GvCV(gv) = 0; /* cv has been hijacked */
5269 else if (strEQ(s, "CHECK")) {
5271 PL_checkav = newAV();
5272 if (PL_main_start && ckWARN(WARN_VOID))
5273 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5274 av_unshift(PL_checkav, 1);
5275 av_store(PL_checkav, 0, (SV*)cv);
5276 GvCV(gv) = 0; /* cv has been hijacked */
5278 else if (strEQ(s, "INIT")) {
5280 PL_initav = newAV();
5281 if (PL_main_start && ckWARN(WARN_VOID))
5282 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5283 av_push(PL_initav, (SV*)cv);
5284 GvCV(gv) = 0; /* cv has been hijacked */
5295 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5304 name = SvPVx(cSVOPo->op_sv, n_a);
5307 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5308 #ifdef GV_UNIQUE_CHECK
5310 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5314 if ((cv = GvFORM(gv))) {
5315 if (ckWARN(WARN_REDEFINE)) {
5316 line_t oldline = CopLINE(PL_curcop);
5317 if (PL_copline != NOLINE)
5318 CopLINE_set(PL_curcop, PL_copline);
5319 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5320 CopLINE_set(PL_curcop, oldline);
5327 CvFILE_set_from_cop(cv, PL_curcop);
5329 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5330 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5331 SvPADTMP_on(PL_curpad[ix]);
5334 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5335 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5336 OpREFCNT_set(CvROOT(cv), 1);
5337 CvSTART(cv) = LINKLIST(CvROOT(cv));
5338 CvROOT(cv)->op_next = 0;
5339 CALL_PEEP(CvSTART(cv));
5341 PL_copline = NOLINE;
5346 Perl_newANONLIST(pTHX_ OP *o)
5348 return newUNOP(OP_REFGEN, 0,
5349 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5353 Perl_newANONHASH(pTHX_ OP *o)
5355 return newUNOP(OP_REFGEN, 0,
5356 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5360 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5362 return newANONATTRSUB(floor, proto, Nullop, block);
5366 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5368 return newUNOP(OP_REFGEN, 0,
5369 newSVOP(OP_ANONCODE, 0,
5370 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5374 Perl_oopsAV(pTHX_ OP *o)
5376 switch (o->op_type) {
5378 o->op_type = OP_PADAV;
5379 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5380 return ref(o, OP_RV2AV);
5383 o->op_type = OP_RV2AV;
5384 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5389 if (ckWARN_d(WARN_INTERNAL))
5390 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5397 Perl_oopsHV(pTHX_ OP *o)
5399 switch (o->op_type) {
5402 o->op_type = OP_PADHV;
5403 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5404 return ref(o, OP_RV2HV);
5408 o->op_type = OP_RV2HV;
5409 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5414 if (ckWARN_d(WARN_INTERNAL))
5415 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5422 Perl_newAVREF(pTHX_ OP *o)
5424 if (o->op_type == OP_PADANY) {
5425 o->op_type = OP_PADAV;
5426 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5429 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5430 && ckWARN(WARN_DEPRECATED)) {
5431 Perl_warner(aTHX_ WARN_DEPRECATED,
5432 "Using an array as a reference is deprecated");
5434 return newUNOP(OP_RV2AV, 0, scalar(o));
5438 Perl_newGVREF(pTHX_ I32 type, OP *o)
5440 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5441 return newUNOP(OP_NULL, 0, o);
5442 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5446 Perl_newHVREF(pTHX_ OP *o)
5448 if (o->op_type == OP_PADANY) {
5449 o->op_type = OP_PADHV;
5450 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5453 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5454 && ckWARN(WARN_DEPRECATED)) {
5455 Perl_warner(aTHX_ WARN_DEPRECATED,
5456 "Using a hash as a reference is deprecated");
5458 return newUNOP(OP_RV2HV, 0, scalar(o));
5462 Perl_oopsCV(pTHX_ OP *o)
5464 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5470 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5472 return newUNOP(OP_RV2CV, flags, scalar(o));
5476 Perl_newSVREF(pTHX_ OP *o)
5478 if (o->op_type == OP_PADANY) {
5479 o->op_type = OP_PADSV;
5480 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5483 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5484 o->op_flags |= OPpDONE_SVREF;
5487 return newUNOP(OP_RV2SV, 0, scalar(o));
5490 /* Check routines. */
5493 Perl_ck_anoncode(pTHX_ OP *o)
5498 name = NEWSV(1106,0);
5499 sv_upgrade(name, SVt_PVNV);
5500 sv_setpvn(name, "&", 1);
5503 ix = pad_alloc(o->op_type, SVs_PADMY);
5504 av_store(PL_comppad_name, ix, name);
5505 av_store(PL_comppad, ix, cSVOPo->op_sv);
5506 SvPADMY_on(cSVOPo->op_sv);
5507 cSVOPo->op_sv = Nullsv;
5508 cSVOPo->op_targ = ix;
5513 Perl_ck_bitop(pTHX_ OP *o)
5515 o->op_private = PL_hints;
5520 Perl_ck_concat(pTHX_ OP *o)
5522 if (cUNOPo->op_first->op_type == OP_CONCAT)
5523 o->op_flags |= OPf_STACKED;
5528 Perl_ck_spair(pTHX_ OP *o)
5530 if (o->op_flags & OPf_KIDS) {
5533 OPCODE type = o->op_type;
5534 o = modkids(ck_fun(o), type);
5535 kid = cUNOPo->op_first;
5536 newop = kUNOP->op_first->op_sibling;
5538 (newop->op_sibling ||
5539 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5540 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5541 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5545 op_free(kUNOP->op_first);
5546 kUNOP->op_first = newop;
5548 o->op_ppaddr = PL_ppaddr[++o->op_type];
5553 Perl_ck_delete(pTHX_ OP *o)
5557 if (o->op_flags & OPf_KIDS) {
5558 OP *kid = cUNOPo->op_first;
5559 switch (kid->op_type) {
5561 o->op_flags |= OPf_SPECIAL;
5564 o->op_private |= OPpSLICE;
5567 o->op_flags |= OPf_SPECIAL;
5572 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5581 Perl_ck_die(pTHX_ OP *o)
5584 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5590 Perl_ck_eof(pTHX_ OP *o)
5592 I32 type = o->op_type;
5594 if (o->op_flags & OPf_KIDS) {
5595 if (cLISTOPo->op_first->op_type == OP_STUB) {
5597 o = newUNOP(type, OPf_SPECIAL,
5598 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5606 Perl_ck_eval(pTHX_ OP *o)
5608 PL_hints |= HINT_BLOCK_SCOPE;
5609 if (o->op_flags & OPf_KIDS) {
5610 SVOP *kid = (SVOP*)cUNOPo->op_first;
5613 o->op_flags &= ~OPf_KIDS;
5616 else if (kid->op_type == OP_LINESEQ) {
5619 kid->op_next = o->op_next;
5620 cUNOPo->op_first = 0;
5623 NewOp(1101, enter, 1, LOGOP);
5624 enter->op_type = OP_ENTERTRY;
5625 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5626 enter->op_private = 0;
5628 /* establish postfix order */
5629 enter->op_next = (OP*)enter;
5631 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5632 o->op_type = OP_LEAVETRY;
5633 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5634 enter->op_other = o;
5642 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5644 o->op_targ = (PADOFFSET)PL_hints;
5649 Perl_ck_exit(pTHX_ OP *o)
5652 HV *table = GvHV(PL_hintgv);
5654 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5655 if (svp && *svp && SvTRUE(*svp))
5656 o->op_private |= OPpEXIT_VMSISH;
5658 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5664 Perl_ck_exec(pTHX_ OP *o)
5667 if (o->op_flags & OPf_STACKED) {
5669 kid = cUNOPo->op_first->op_sibling;
5670 if (kid->op_type == OP_RV2GV)
5679 Perl_ck_exists(pTHX_ OP *o)
5682 if (o->op_flags & OPf_KIDS) {
5683 OP *kid = cUNOPo->op_first;
5684 if (kid->op_type == OP_ENTERSUB) {
5685 (void) ref(kid, o->op_type);
5686 if (kid->op_type != OP_RV2CV && !PL_error_count)
5687 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5689 o->op_private |= OPpEXISTS_SUB;
5691 else if (kid->op_type == OP_AELEM)
5692 o->op_flags |= OPf_SPECIAL;
5693 else if (kid->op_type != OP_HELEM)
5694 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5703 Perl_ck_gvconst(pTHX_ register OP *o)
5705 o = fold_constants(o);
5706 if (o->op_type == OP_CONST)
5713 Perl_ck_rvconst(pTHX_ register OP *o)
5715 SVOP *kid = (SVOP*)cUNOPo->op_first;
5717 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5718 if (kid->op_type == OP_CONST) {
5722 SV *kidsv = kid->op_sv;
5725 /* Is it a constant from cv_const_sv()? */
5726 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5727 SV *rsv = SvRV(kidsv);
5728 int svtype = SvTYPE(rsv);
5729 char *badtype = Nullch;
5731 switch (o->op_type) {
5733 if (svtype > SVt_PVMG)
5734 badtype = "a SCALAR";
5737 if (svtype != SVt_PVAV)
5738 badtype = "an ARRAY";
5741 if (svtype != SVt_PVHV) {
5742 if (svtype == SVt_PVAV) { /* pseudohash? */
5743 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5744 if (ksv && SvROK(*ksv)
5745 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5754 if (svtype != SVt_PVCV)
5759 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5762 name = SvPV(kidsv, n_a);
5763 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5764 char *badthing = Nullch;
5765 switch (o->op_type) {
5767 badthing = "a SCALAR";
5770 badthing = "an ARRAY";
5773 badthing = "a HASH";
5778 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5782 * This is a little tricky. We only want to add the symbol if we
5783 * didn't add it in the lexer. Otherwise we get duplicate strict
5784 * warnings. But if we didn't add it in the lexer, we must at
5785 * least pretend like we wanted to add it even if it existed before,
5786 * or we get possible typo warnings. OPpCONST_ENTERED says
5787 * whether the lexer already added THIS instance of this symbol.
5789 iscv = (o->op_type == OP_RV2CV) * 2;
5791 gv = gv_fetchpv(name,
5792 iscv | !(kid->op_private & OPpCONST_ENTERED),
5795 : o->op_type == OP_RV2SV
5797 : o->op_type == OP_RV2AV
5799 : o->op_type == OP_RV2HV
5802 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5804 kid->op_type = OP_GV;
5805 SvREFCNT_dec(kid->op_sv);
5807 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5808 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5809 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5811 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5813 kid->op_sv = SvREFCNT_inc(gv);
5815 kid->op_private = 0;
5816 kid->op_ppaddr = PL_ppaddr[OP_GV];
5823 Perl_ck_ftst(pTHX_ OP *o)
5825 I32 type = o->op_type;
5827 if (o->op_flags & OPf_REF) {
5830 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5831 SVOP *kid = (SVOP*)cUNOPo->op_first;
5833 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5835 OP *newop = newGVOP(type, OPf_REF,
5836 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5843 if (type == OP_FTTTY)
5844 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5847 o = newUNOP(type, 0, newDEFSVOP());
5853 Perl_ck_fun(pTHX_ OP *o)
5859 int type = o->op_type;
5860 register I32 oa = PL_opargs[type] >> OASHIFT;
5862 if (o->op_flags & OPf_STACKED) {
5863 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5866 return no_fh_allowed(o);
5869 if (o->op_flags & OPf_KIDS) {
5871 tokid = &cLISTOPo->op_first;
5872 kid = cLISTOPo->op_first;
5873 if (kid->op_type == OP_PUSHMARK ||
5874 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5876 tokid = &kid->op_sibling;
5877 kid = kid->op_sibling;
5879 if (!kid && PL_opargs[type] & OA_DEFGV)
5880 *tokid = kid = newDEFSVOP();
5884 sibl = kid->op_sibling;
5887 /* list seen where single (scalar) arg expected? */
5888 if (numargs == 1 && !(oa >> 4)
5889 && kid->op_type == OP_LIST && type != OP_SCALAR)
5891 return too_many_arguments(o,PL_op_desc[type]);
5904 if ((type == OP_PUSH || type == OP_UNSHIFT)
5905 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5906 Perl_warner(aTHX_ WARN_SYNTAX,
5907 "Useless use of %s with no values",
5910 if (kid->op_type == OP_CONST &&
5911 (kid->op_private & OPpCONST_BARE))
5913 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5914 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5915 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5916 if (ckWARN(WARN_DEPRECATED))
5917 Perl_warner(aTHX_ WARN_DEPRECATED,
5918 "Array @%s missing the @ in argument %"IVdf" of %s()",
5919 name, (IV)numargs, PL_op_desc[type]);
5922 kid->op_sibling = sibl;
5925 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5926 bad_type(numargs, "array", PL_op_desc[type], kid);
5930 if (kid->op_type == OP_CONST &&
5931 (kid->op_private & OPpCONST_BARE))
5933 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5934 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5935 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5936 if (ckWARN(WARN_DEPRECATED))
5937 Perl_warner(aTHX_ WARN_DEPRECATED,
5938 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5939 name, (IV)numargs, PL_op_desc[type]);
5942 kid->op_sibling = sibl;
5945 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5946 bad_type(numargs, "hash", PL_op_desc[type], kid);
5951 OP *newop = newUNOP(OP_NULL, 0, kid);
5952 kid->op_sibling = 0;
5954 newop->op_next = newop;
5956 kid->op_sibling = sibl;
5961 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5962 if (kid->op_type == OP_CONST &&
5963 (kid->op_private & OPpCONST_BARE))
5965 OP *newop = newGVOP(OP_GV, 0,
5966 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5968 if (kid == cLISTOPo->op_last)
5969 cLISTOPo->op_last = newop;
5973 else if (kid->op_type == OP_READLINE) {
5974 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5975 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5978 I32 flags = OPf_SPECIAL;
5982 /* is this op a FH constructor? */
5983 if (is_handle_constructor(o,numargs)) {
5984 char *name = Nullch;
5988 /* Set a flag to tell rv2gv to vivify
5989 * need to "prove" flag does not mean something
5990 * else already - NI-S 1999/05/07
5993 if (kid->op_type == OP_PADSV) {
5994 SV **namep = av_fetch(PL_comppad_name,
5996 if (namep && *namep)
5997 name = SvPV(*namep, len);
5999 else if (kid->op_type == OP_RV2SV
6000 && kUNOP->op_first->op_type == OP_GV)
6002 GV *gv = cGVOPx_gv(kUNOP->op_first);
6004 len = GvNAMELEN(gv);
6006 else if (kid->op_type == OP_AELEM
6007 || kid->op_type == OP_HELEM)
6009 name = "__ANONIO__";
6015 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6016 namesv = PL_curpad[targ];
6017 (void)SvUPGRADE(namesv, SVt_PV);
6019 sv_setpvn(namesv, "$", 1);
6020 sv_catpvn(namesv, name, len);
6023 kid->op_sibling = 0;
6024 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6025 kid->op_targ = targ;
6026 kid->op_private |= priv;
6028 kid->op_sibling = sibl;
6034 mod(scalar(kid), type);
6038 tokid = &kid->op_sibling;
6039 kid = kid->op_sibling;
6041 o->op_private |= numargs;
6043 return too_many_arguments(o,OP_DESC(o));
6046 else if (PL_opargs[type] & OA_DEFGV) {
6048 return newUNOP(type, 0, newDEFSVOP());
6052 while (oa & OA_OPTIONAL)
6054 if (oa && oa != OA_LIST)
6055 return too_few_arguments(o,OP_DESC(o));
6061 Perl_ck_glob(pTHX_ OP *o)
6066 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6067 append_elem(OP_GLOB, o, newDEFSVOP());
6069 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6070 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6072 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6075 #if !defined(PERL_EXTERNAL_GLOB)
6076 /* XXX this can be tightened up and made more failsafe. */
6080 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6081 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6082 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6083 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6084 GvCV(gv) = GvCV(glob_gv);
6085 SvREFCNT_inc((SV*)GvCV(gv));
6086 GvIMPORTED_CV_on(gv);
6089 #endif /* PERL_EXTERNAL_GLOB */
6091 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6092 append_elem(OP_GLOB, o,
6093 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6094 o->op_type = OP_LIST;
6095 o->op_ppaddr = PL_ppaddr[OP_LIST];
6096 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6097 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6098 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6099 append_elem(OP_LIST, o,
6100 scalar(newUNOP(OP_RV2CV, 0,
6101 newGVOP(OP_GV, 0, gv)))));
6102 o = newUNOP(OP_NULL, 0, ck_subr(o));
6103 o->op_targ = OP_GLOB; /* hint at what it used to be */
6106 gv = newGVgen("main");
6108 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6114 Perl_ck_grep(pTHX_ OP *o)
6118 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6120 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6121 NewOp(1101, gwop, 1, LOGOP);
6123 if (o->op_flags & OPf_STACKED) {
6126 kid = cLISTOPo->op_first->op_sibling;
6127 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6130 kid->op_next = (OP*)gwop;
6131 o->op_flags &= ~OPf_STACKED;
6133 kid = cLISTOPo->op_first->op_sibling;
6134 if (type == OP_MAPWHILE)
6141 kid = cLISTOPo->op_first->op_sibling;
6142 if (kid->op_type != OP_NULL)
6143 Perl_croak(aTHX_ "panic: ck_grep");
6144 kid = kUNOP->op_first;
6146 gwop->op_type = type;
6147 gwop->op_ppaddr = PL_ppaddr[type];
6148 gwop->op_first = listkids(o);
6149 gwop->op_flags |= OPf_KIDS;
6150 gwop->op_private = 1;
6151 gwop->op_other = LINKLIST(kid);
6152 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6153 kid->op_next = (OP*)gwop;
6155 kid = cLISTOPo->op_first->op_sibling;
6156 if (!kid || !kid->op_sibling)
6157 return too_few_arguments(o,OP_DESC(o));
6158 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6159 mod(kid, OP_GREPSTART);
6165 Perl_ck_index(pTHX_ OP *o)
6167 if (o->op_flags & OPf_KIDS) {
6168 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6170 kid = kid->op_sibling; /* get past "big" */
6171 if (kid && kid->op_type == OP_CONST)
6172 fbm_compile(((SVOP*)kid)->op_sv, 0);
6178 Perl_ck_lengthconst(pTHX_ OP *o)
6180 /* XXX length optimization goes here */
6185 Perl_ck_lfun(pTHX_ OP *o)
6187 OPCODE type = o->op_type;
6188 return modkids(ck_fun(o), type);
6192 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6194 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6195 switch (cUNOPo->op_first->op_type) {
6197 /* This is needed for
6198 if (defined %stash::)
6199 to work. Do not break Tk.
6201 break; /* Globals via GV can be undef */
6203 case OP_AASSIGN: /* Is this a good idea? */
6204 Perl_warner(aTHX_ WARN_DEPRECATED,
6205 "defined(@array) is deprecated");
6206 Perl_warner(aTHX_ WARN_DEPRECATED,
6207 "\t(Maybe you should just omit the defined()?)\n");
6210 /* This is needed for
6211 if (defined %stash::)
6212 to work. Do not break Tk.
6214 break; /* Globals via GV can be undef */
6216 Perl_warner(aTHX_ WARN_DEPRECATED,
6217 "defined(%%hash) is deprecated");
6218 Perl_warner(aTHX_ WARN_DEPRECATED,
6219 "\t(Maybe you should just omit the defined()?)\n");
6230 Perl_ck_rfun(pTHX_ OP *o)
6232 OPCODE type = o->op_type;
6233 return refkids(ck_fun(o), type);
6237 Perl_ck_listiob(pTHX_ OP *o)
6241 kid = cLISTOPo->op_first;
6244 kid = cLISTOPo->op_first;
6246 if (kid->op_type == OP_PUSHMARK)
6247 kid = kid->op_sibling;
6248 if (kid && o->op_flags & OPf_STACKED)
6249 kid = kid->op_sibling;
6250 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6251 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6252 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6253 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6254 cLISTOPo->op_first->op_sibling = kid;
6255 cLISTOPo->op_last = kid;
6256 kid = kid->op_sibling;
6261 append_elem(o->op_type, o, newDEFSVOP());
6267 Perl_ck_sassign(pTHX_ OP *o)
6269 OP *kid = cLISTOPo->op_first;
6270 /* has a disposable target? */
6271 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6272 && !(kid->op_flags & OPf_STACKED)
6273 /* Cannot steal the second time! */
6274 && !(kid->op_private & OPpTARGET_MY))
6276 OP *kkid = kid->op_sibling;
6278 /* Can just relocate the target. */
6279 if (kkid && kkid->op_type == OP_PADSV
6280 && !(kkid->op_private & OPpLVAL_INTRO))
6282 kid->op_targ = kkid->op_targ;
6284 /* Now we do not need PADSV and SASSIGN. */
6285 kid->op_sibling = o->op_sibling; /* NULL */
6286 cLISTOPo->op_first = NULL;
6289 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6297 Perl_ck_match(pTHX_ OP *o)
6299 o->op_private |= OPpRUNTIME;
6304 Perl_ck_method(pTHX_ OP *o)
6306 OP *kid = cUNOPo->op_first;
6307 if (kid->op_type == OP_CONST) {
6308 SV* sv = kSVOP->op_sv;
6309 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6311 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6312 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6315 kSVOP->op_sv = Nullsv;
6317 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6326 Perl_ck_null(pTHX_ OP *o)
6332 Perl_ck_open(pTHX_ OP *o)
6334 HV *table = GvHV(PL_hintgv);
6338 svp = hv_fetch(table, "open_IN", 7, FALSE);
6340 mode = mode_from_discipline(*svp);
6341 if (mode & O_BINARY)
6342 o->op_private |= OPpOPEN_IN_RAW;
6343 else if (mode & O_TEXT)
6344 o->op_private |= OPpOPEN_IN_CRLF;
6347 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6349 mode = mode_from_discipline(*svp);
6350 if (mode & O_BINARY)
6351 o->op_private |= OPpOPEN_OUT_RAW;
6352 else if (mode & O_TEXT)
6353 o->op_private |= OPpOPEN_OUT_CRLF;
6356 if (o->op_type == OP_BACKTICK)
6362 Perl_ck_repeat(pTHX_ OP *o)
6364 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6365 o->op_private |= OPpREPEAT_DOLIST;
6366 cBINOPo->op_first = force_list(cBINOPo->op_first);
6374 Perl_ck_require(pTHX_ OP *o)
6378 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6379 SVOP *kid = (SVOP*)cUNOPo->op_first;
6381 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6383 for (s = SvPVX(kid->op_sv); *s; s++) {
6384 if (*s == ':' && s[1] == ':') {
6386 Move(s+2, s+1, strlen(s+2)+1, char);
6387 --SvCUR(kid->op_sv);
6390 if (SvREADONLY(kid->op_sv)) {
6391 SvREADONLY_off(kid->op_sv);
6392 sv_catpvn(kid->op_sv, ".pm", 3);
6393 SvREADONLY_on(kid->op_sv);
6396 sv_catpvn(kid->op_sv, ".pm", 3);
6400 /* handle override, if any */
6401 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6402 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6403 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6405 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6406 OP *kid = cUNOPo->op_first;
6407 cUNOPo->op_first = 0;
6409 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6410 append_elem(OP_LIST, kid,
6411 scalar(newUNOP(OP_RV2CV, 0,
6420 Perl_ck_return(pTHX_ OP *o)
6423 if (CvLVALUE(PL_compcv)) {
6424 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6425 mod(kid, OP_LEAVESUBLV);
6432 Perl_ck_retarget(pTHX_ OP *o)
6434 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6441 Perl_ck_select(pTHX_ OP *o)
6444 if (o->op_flags & OPf_KIDS) {
6445 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6446 if (kid && kid->op_sibling) {
6447 o->op_type = OP_SSELECT;
6448 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6450 return fold_constants(o);
6454 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6455 if (kid && kid->op_type == OP_RV2GV)
6456 kid->op_private &= ~HINT_STRICT_REFS;
6461 Perl_ck_shift(pTHX_ OP *o)
6463 I32 type = o->op_type;
6465 if (!(o->op_flags & OPf_KIDS)) {
6469 #ifdef USE_5005THREADS
6470 if (!CvUNIQUE(PL_compcv)) {
6471 argop = newOP(OP_PADAV, OPf_REF);
6472 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6475 argop = newUNOP(OP_RV2AV, 0,
6476 scalar(newGVOP(OP_GV, 0,
6477 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6480 argop = newUNOP(OP_RV2AV, 0,
6481 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6482 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6483 #endif /* USE_5005THREADS */
6484 return newUNOP(type, 0, scalar(argop));
6486 return scalar(modkids(ck_fun(o), type));
6490 Perl_ck_sort(pTHX_ OP *o)
6494 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6496 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6497 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6499 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6501 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6503 if (kid->op_type == OP_SCOPE) {
6507 else if (kid->op_type == OP_LEAVE) {
6508 if (o->op_type == OP_SORT) {
6509 op_null(kid); /* wipe out leave */
6512 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6513 if (k->op_next == kid)
6515 /* don't descend into loops */
6516 else if (k->op_type == OP_ENTERLOOP
6517 || k->op_type == OP_ENTERITER)
6519 k = cLOOPx(k)->op_lastop;
6524 kid->op_next = 0; /* just disconnect the leave */
6525 k = kLISTOP->op_first;
6530 if (o->op_type == OP_SORT) {
6531 /* provide scalar context for comparison function/block */
6537 o->op_flags |= OPf_SPECIAL;
6539 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6542 firstkid = firstkid->op_sibling;
6545 /* provide list context for arguments */
6546 if (o->op_type == OP_SORT)
6553 S_simplify_sort(pTHX_ OP *o)
6555 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6559 if (!(o->op_flags & OPf_STACKED))
6561 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6562 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6563 kid = kUNOP->op_first; /* get past null */
6564 if (kid->op_type != OP_SCOPE)
6566 kid = kLISTOP->op_last; /* get past scope */
6567 switch(kid->op_type) {
6575 k = kid; /* remember this node*/
6576 if (kBINOP->op_first->op_type != OP_RV2SV)
6578 kid = kBINOP->op_first; /* get past cmp */
6579 if (kUNOP->op_first->op_type != OP_GV)
6581 kid = kUNOP->op_first; /* get past rv2sv */
6583 if (GvSTASH(gv) != PL_curstash)
6585 if (strEQ(GvNAME(gv), "a"))
6587 else if (strEQ(GvNAME(gv), "b"))
6591 kid = k; /* back to cmp */
6592 if (kBINOP->op_last->op_type != OP_RV2SV)
6594 kid = kBINOP->op_last; /* down to 2nd arg */
6595 if (kUNOP->op_first->op_type != OP_GV)
6597 kid = kUNOP->op_first; /* get past rv2sv */
6599 if (GvSTASH(gv) != PL_curstash
6601 ? strNE(GvNAME(gv), "a")
6602 : strNE(GvNAME(gv), "b")))
6604 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6606 o->op_private |= OPpSORT_REVERSE;
6607 if (k->op_type == OP_NCMP)
6608 o->op_private |= OPpSORT_NUMERIC;
6609 if (k->op_type == OP_I_NCMP)
6610 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6611 kid = cLISTOPo->op_first->op_sibling;
6612 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6613 op_free(kid); /* then delete it */
6617 Perl_ck_split(pTHX_ OP *o)
6621 if (o->op_flags & OPf_STACKED)
6622 return no_fh_allowed(o);
6624 kid = cLISTOPo->op_first;
6625 if (kid->op_type != OP_NULL)
6626 Perl_croak(aTHX_ "panic: ck_split");
6627 kid = kid->op_sibling;
6628 op_free(cLISTOPo->op_first);
6629 cLISTOPo->op_first = kid;
6631 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6632 cLISTOPo->op_last = kid; /* There was only one element previously */
6635 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6636 OP *sibl = kid->op_sibling;
6637 kid->op_sibling = 0;
6638 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6639 if (cLISTOPo->op_first == cLISTOPo->op_last)
6640 cLISTOPo->op_last = kid;
6641 cLISTOPo->op_first = kid;
6642 kid->op_sibling = sibl;
6645 kid->op_type = OP_PUSHRE;
6646 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6649 if (!kid->op_sibling)
6650 append_elem(OP_SPLIT, o, newDEFSVOP());
6652 kid = kid->op_sibling;
6655 if (!kid->op_sibling)
6656 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6658 kid = kid->op_sibling;
6661 if (kid->op_sibling)
6662 return too_many_arguments(o,OP_DESC(o));
6668 Perl_ck_join(pTHX_ OP *o)
6670 if (ckWARN(WARN_SYNTAX)) {
6671 OP *kid = cLISTOPo->op_first->op_sibling;
6672 if (kid && kid->op_type == OP_MATCH) {
6673 char *pmstr = "STRING";
6674 if (PM_GETRE(kPMOP))
6675 pmstr = PM_GETRE(kPMOP)->precomp;
6676 Perl_warner(aTHX_ WARN_SYNTAX,
6677 "/%s/ should probably be written as \"%s\"",
6685 Perl_ck_subr(pTHX_ OP *o)
6687 OP *prev = ((cUNOPo->op_first->op_sibling)
6688 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6689 OP *o2 = prev->op_sibling;
6696 I32 contextclass = 0;
6700 o->op_private |= OPpENTERSUB_HASTARG;
6701 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6702 if (cvop->op_type == OP_RV2CV) {
6704 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6705 op_null(cvop); /* disable rv2cv */
6706 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6707 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6708 GV *gv = cGVOPx_gv(tmpop);
6711 tmpop->op_private |= OPpEARLY_CV;
6712 else if (SvPOK(cv)) {
6713 namegv = CvANON(cv) ? gv : CvGV(cv);
6714 proto = SvPV((SV*)cv, n_a);
6718 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6719 if (o2->op_type == OP_CONST)
6720 o2->op_private &= ~OPpCONST_STRICT;
6721 else if (o2->op_type == OP_LIST) {
6722 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6723 if (o && o->op_type == OP_CONST)
6724 o->op_private &= ~OPpCONST_STRICT;
6727 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6728 if (PERLDB_SUB && PL_curstash != PL_debstash)
6729 o->op_private |= OPpENTERSUB_DB;
6730 while (o2 != cvop) {
6734 return too_many_arguments(o, gv_ename(namegv));
6752 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6754 arg == 1 ? "block or sub {}" : "sub {}",
6755 gv_ename(namegv), o2);
6758 /* '*' allows any scalar type, including bareword */
6761 if (o2->op_type == OP_RV2GV)
6762 goto wrapref; /* autoconvert GLOB -> GLOBref */
6763 else if (o2->op_type == OP_CONST)
6764 o2->op_private &= ~OPpCONST_STRICT;
6765 else if (o2->op_type == OP_ENTERSUB) {
6766 /* accidental subroutine, revert to bareword */
6767 OP *gvop = ((UNOP*)o2)->op_first;
6768 if (gvop && gvop->op_type == OP_NULL) {
6769 gvop = ((UNOP*)gvop)->op_first;
6771 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6774 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6775 (gvop = ((UNOP*)gvop)->op_first) &&
6776 gvop->op_type == OP_GV)
6778 GV *gv = cGVOPx_gv(gvop);
6779 OP *sibling = o2->op_sibling;
6780 SV *n = newSVpvn("",0);
6782 gv_fullname3(n, gv, "");
6783 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6784 sv_chop(n, SvPVX(n)+6);
6785 o2 = newSVOP(OP_CONST, 0, n);
6786 prev->op_sibling = o2;
6787 o2->op_sibling = sibling;
6803 if (contextclass++ == 0) {
6804 e = strchr(proto, ']');
6805 if (!e || e == proto)
6818 while (*--p != '[');
6819 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6820 gv_ename(namegv), o2);
6826 if (o2->op_type == OP_RV2GV)
6829 bad_type(arg, "symbol", gv_ename(namegv), o2);
6832 if (o2->op_type == OP_ENTERSUB)
6835 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6838 if (o2->op_type == OP_RV2SV ||
6839 o2->op_type == OP_PADSV ||
6840 o2->op_type == OP_HELEM ||
6841 o2->op_type == OP_AELEM ||
6842 o2->op_type == OP_THREADSV)
6845 bad_type(arg, "scalar", gv_ename(namegv), o2);
6848 if (o2->op_type == OP_RV2AV ||
6849 o2->op_type == OP_PADAV)
6852 bad_type(arg, "array", gv_ename(namegv), o2);
6855 if (o2->op_type == OP_RV2HV ||
6856 o2->op_type == OP_PADHV)
6859 bad_type(arg, "hash", gv_ename(namegv), o2);
6864 OP* sib = kid->op_sibling;
6865 kid->op_sibling = 0;
6866 o2 = newUNOP(OP_REFGEN, 0, kid);
6867 o2->op_sibling = sib;
6868 prev->op_sibling = o2;
6870 if (contextclass && e) {
6885 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6886 gv_ename(namegv), SvPV((SV*)cv, n_a));
6891 mod(o2, OP_ENTERSUB);
6893 o2 = o2->op_sibling;
6895 if (proto && !optional &&
6896 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6897 return too_few_arguments(o, gv_ename(namegv));
6902 Perl_ck_svconst(pTHX_ OP *o)
6904 SvREADONLY_on(cSVOPo->op_sv);
6909 Perl_ck_trunc(pTHX_ OP *o)
6911 if (o->op_flags & OPf_KIDS) {
6912 SVOP *kid = (SVOP*)cUNOPo->op_first;
6914 if (kid->op_type == OP_NULL)
6915 kid = (SVOP*)kid->op_sibling;
6916 if (kid && kid->op_type == OP_CONST &&
6917 (kid->op_private & OPpCONST_BARE))
6919 o->op_flags |= OPf_SPECIAL;
6920 kid->op_private &= ~OPpCONST_STRICT;
6927 Perl_ck_substr(pTHX_ OP *o)
6930 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6931 OP *kid = cLISTOPo->op_first;
6933 if (kid->op_type == OP_NULL)
6934 kid = kid->op_sibling;
6936 kid->op_flags |= OPf_MOD;
6942 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6945 Perl_peep(pTHX_ register OP *o)
6947 register OP* oldop = 0;
6950 if (!o || o->op_seq)
6954 SAVEVPTR(PL_curcop);
6955 for (; o; o = o->op_next) {
6961 switch (o->op_type) {
6965 PL_curcop = ((COP*)o); /* for warnings */
6966 o->op_seq = PL_op_seqmax++;
6970 if (cSVOPo->op_private & OPpCONST_STRICT)
6971 no_bareword_allowed(o);
6973 /* Relocate sv to the pad for thread safety.
6974 * Despite being a "constant", the SV is written to,
6975 * for reference counts, sv_upgrade() etc. */
6977 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6978 if (SvPADTMP(cSVOPo->op_sv)) {
6979 /* If op_sv is already a PADTMP then it is being used by
6980 * some pad, so make a copy. */
6981 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6982 SvREADONLY_on(PL_curpad[ix]);
6983 SvREFCNT_dec(cSVOPo->op_sv);
6986 SvREFCNT_dec(PL_curpad[ix]);
6987 SvPADTMP_on(cSVOPo->op_sv);
6988 PL_curpad[ix] = cSVOPo->op_sv;
6989 /* XXX I don't know how this isn't readonly already. */
6990 SvREADONLY_on(PL_curpad[ix]);
6992 cSVOPo->op_sv = Nullsv;
6996 o->op_seq = PL_op_seqmax++;
7000 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7001 if (o->op_next->op_private & OPpTARGET_MY) {
7002 if (o->op_flags & OPf_STACKED) /* chained concats */
7003 goto ignore_optimization;
7005 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7006 o->op_targ = o->op_next->op_targ;
7007 o->op_next->op_targ = 0;
7008 o->op_private |= OPpTARGET_MY;
7011 op_null(o->op_next);
7013 ignore_optimization:
7014 o->op_seq = PL_op_seqmax++;
7017 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7018 o->op_seq = PL_op_seqmax++;
7019 break; /* Scalar stub must produce undef. List stub is noop */
7023 if (o->op_targ == OP_NEXTSTATE
7024 || o->op_targ == OP_DBSTATE
7025 || o->op_targ == OP_SETSTATE)
7027 PL_curcop = ((COP*)o);
7029 /* XXX: We avoid setting op_seq here to prevent later calls
7030 to peep() from mistakenly concluding that optimisation
7031 has already occurred. This doesn't fix the real problem,
7032 though (See 20010220.007). AMS 20010719 */
7033 if (oldop && o->op_next) {
7034 oldop->op_next = o->op_next;
7042 if (oldop && o->op_next) {
7043 oldop->op_next = o->op_next;
7046 o->op_seq = PL_op_seqmax++;
7050 if (o->op_next->op_type == OP_RV2SV) {
7051 if (!(o->op_next->op_private & OPpDEREF)) {
7052 op_null(o->op_next);
7053 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7055 o->op_next = o->op_next->op_next;
7056 o->op_type = OP_GVSV;
7057 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7060 else if (o->op_next->op_type == OP_RV2AV) {
7061 OP* pop = o->op_next->op_next;
7063 if (pop && pop->op_type == OP_CONST &&
7064 (PL_op = pop->op_next) &&
7065 pop->op_next->op_type == OP_AELEM &&
7066 !(pop->op_next->op_private &
7067 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7068 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7073 op_null(o->op_next);
7074 op_null(pop->op_next);
7076 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7077 o->op_next = pop->op_next->op_next;
7078 o->op_type = OP_AELEMFAST;
7079 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7080 o->op_private = (U8)i;
7085 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7087 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7088 /* XXX could check prototype here instead of just carping */
7089 SV *sv = sv_newmortal();
7090 gv_efullname3(sv, gv, Nullch);
7091 Perl_warner(aTHX_ WARN_PROTOTYPE,
7092 "%s() called too early to check prototype",
7096 else if (o->op_next->op_type == OP_READLINE
7097 && o->op_next->op_next->op_type == OP_CONCAT
7098 && (o->op_next->op_next->op_flags & OPf_STACKED))
7100 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7101 o->op_type = OP_RCATLINE;
7102 o->op_flags |= OPf_STACKED;
7103 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7104 op_null(o->op_next->op_next);
7105 op_null(o->op_next);
7108 o->op_seq = PL_op_seqmax++;
7119 o->op_seq = PL_op_seqmax++;
7120 while (cLOGOP->op_other->op_type == OP_NULL)
7121 cLOGOP->op_other = cLOGOP->op_other->op_next;
7122 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7127 o->op_seq = PL_op_seqmax++;
7128 while (cLOOP->op_redoop->op_type == OP_NULL)
7129 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7130 peep(cLOOP->op_redoop);
7131 while (cLOOP->op_nextop->op_type == OP_NULL)
7132 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7133 peep(cLOOP->op_nextop);
7134 while (cLOOP->op_lastop->op_type == OP_NULL)
7135 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7136 peep(cLOOP->op_lastop);
7142 o->op_seq = PL_op_seqmax++;
7143 while (cPMOP->op_pmreplstart &&
7144 cPMOP->op_pmreplstart->op_type == OP_NULL)
7145 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7146 peep(cPMOP->op_pmreplstart);
7150 o->op_seq = PL_op_seqmax++;
7151 if (ckWARN(WARN_SYNTAX) && o->op_next
7152 && o->op_next->op_type == OP_NEXTSTATE) {
7153 if (o->op_next->op_sibling &&
7154 o->op_next->op_sibling->op_type != OP_EXIT &&
7155 o->op_next->op_sibling->op_type != OP_WARN &&
7156 o->op_next->op_sibling->op_type != OP_DIE) {
7157 line_t oldline = CopLINE(PL_curcop);
7159 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7160 Perl_warner(aTHX_ WARN_EXEC,
7161 "Statement unlikely to be reached");
7162 Perl_warner(aTHX_ WARN_EXEC,
7163 "\t(Maybe you meant system() when you said exec()?)\n");
7164 CopLINE_set(PL_curcop, oldline);
7173 SV **svp, **indsvp, *sv;
7178 o->op_seq = PL_op_seqmax++;
7180 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7183 /* Make the CONST have a shared SV */
7184 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7185 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7186 key = SvPV(sv, keylen);
7187 lexname = newSVpvn_share(key,
7188 SvUTF8(sv) ? -(I32)keylen : keylen,
7194 if ((o->op_private & (OPpLVAL_INTRO)))
7197 rop = (UNOP*)((BINOP*)o)->op_first;
7198 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7200 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7201 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7203 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7204 if (!fields || !GvHV(*fields))
7206 key = SvPV(*svp, keylen);
7207 indsvp = hv_fetch(GvHV(*fields), key,
7208 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7210 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7211 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7213 ind = SvIV(*indsvp);
7215 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7216 rop->op_type = OP_RV2AV;
7217 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7218 o->op_type = OP_AELEM;
7219 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7221 if (SvREADONLY(*svp))
7223 SvFLAGS(sv) |= (SvFLAGS(*svp)
7224 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7234 SV **svp, **indsvp, *sv;
7238 SVOP *first_key_op, *key_op;
7240 o->op_seq = PL_op_seqmax++;
7241 if ((o->op_private & (OPpLVAL_INTRO))
7242 /* I bet there's always a pushmark... */
7243 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7244 /* hmmm, no optimization if list contains only one key. */
7246 rop = (UNOP*)((LISTOP*)o)->op_last;
7247 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7249 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7250 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7252 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7253 if (!fields || !GvHV(*fields))
7255 /* Again guessing that the pushmark can be jumped over.... */
7256 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7257 ->op_first->op_sibling;
7258 /* Check that the key list contains only constants. */
7259 for (key_op = first_key_op; key_op;
7260 key_op = (SVOP*)key_op->op_sibling)
7261 if (key_op->op_type != OP_CONST)
7265 rop->op_type = OP_RV2AV;
7266 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7267 o->op_type = OP_ASLICE;
7268 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7269 for (key_op = first_key_op; key_op;
7270 key_op = (SVOP*)key_op->op_sibling) {
7271 svp = cSVOPx_svp(key_op);
7272 key = SvPV(*svp, keylen);
7273 indsvp = hv_fetch(GvHV(*fields), key,
7274 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7276 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7277 "in variable %s of type %s",
7278 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7280 ind = SvIV(*indsvp);
7282 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7284 if (SvREADONLY(*svp))
7286 SvFLAGS(sv) |= (SvFLAGS(*svp)
7287 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7295 o->op_seq = PL_op_seqmax++;
7305 char* Perl_custom_op_name(pTHX_ OP* o)
7307 IV index = PTR2IV(o->op_ppaddr);
7311 if (!PL_custom_op_names) /* This probably shouldn't happen */
7312 return PL_op_name[OP_CUSTOM];
7314 keysv = sv_2mortal(newSViv(index));
7316 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7318 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7320 return SvPV_nolen(HeVAL(he));
7323 char* Perl_custom_op_desc(pTHX_ OP* o)
7325 IV index = PTR2IV(o->op_ppaddr);
7329 if (!PL_custom_op_descs)
7330 return PL_op_desc[OP_CUSTOM];
7332 keysv = sv_2mortal(newSViv(index));
7334 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7336 return PL_op_desc[OP_CUSTOM];
7338 return SvPV_nolen(HeVAL(he));
7344 /* Efficient sub that returns a constant scalar value. */
7346 const_sv_xsub(pTHX_ CV* cv)
7351 Perl_croak(aTHX_ "usage: %s::%s()",
7352 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7356 ST(0) = (SV*)XSANY.any_ptr;