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 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3455 Perl_warner(aTHX_ WARN_MISC,
3456 "Package `%s' not found "
3457 "(did you use the incorrect case?)", packname);
3462 PL_hints |= HINT_BLOCK_SCOPE;
3463 PL_copline = NOLINE;
3468 =head1 Embedding Functions
3470 =for apidoc load_module
3472 Loads the module whose name is pointed to by the string part of name.
3473 Note that the actual module name, not its filename, should be given.
3474 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3475 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3476 (or 0 for no flags). ver, if specified, provides version semantics
3477 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3478 arguments can be used to specify arguments to the module's import()
3479 method, similar to C<use Foo::Bar VERSION LIST>.
3484 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3487 va_start(args, ver);
3488 vload_module(flags, name, ver, &args);
3492 #ifdef PERL_IMPLICIT_CONTEXT
3494 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3498 va_start(args, ver);
3499 vload_module(flags, name, ver, &args);
3505 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3507 OP *modname, *veop, *imop;
3509 modname = newSVOP(OP_CONST, 0, name);
3510 modname->op_private |= OPpCONST_BARE;
3512 veop = newSVOP(OP_CONST, 0, ver);
3516 if (flags & PERL_LOADMOD_NOIMPORT) {
3517 imop = sawparens(newNULLLIST());
3519 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3520 imop = va_arg(*args, OP*);
3525 sv = va_arg(*args, SV*);
3527 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3528 sv = va_arg(*args, SV*);
3532 line_t ocopline = PL_copline;
3533 int oexpect = PL_expect;
3535 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3536 veop, modname, imop);
3537 PL_expect = oexpect;
3538 PL_copline = ocopline;
3543 Perl_dofile(pTHX_ OP *term)
3548 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3549 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3550 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3552 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3553 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3554 append_elem(OP_LIST, term,
3555 scalar(newUNOP(OP_RV2CV, 0,
3560 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3566 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3568 return newBINOP(OP_LSLICE, flags,
3569 list(force_list(subscript)),
3570 list(force_list(listval)) );
3574 S_list_assignment(pTHX_ register OP *o)
3579 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3580 o = cUNOPo->op_first;
3582 if (o->op_type == OP_COND_EXPR) {
3583 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3584 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3589 yyerror("Assignment to both a list and a scalar");
3593 if (o->op_type == OP_LIST &&
3594 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3595 o->op_private & OPpLVAL_INTRO)
3598 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3599 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3600 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3603 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3606 if (o->op_type == OP_RV2SV)
3613 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3618 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3619 return newLOGOP(optype, 0,
3620 mod(scalar(left), optype),
3621 newUNOP(OP_SASSIGN, 0, scalar(right)));
3624 return newBINOP(optype, OPf_STACKED,
3625 mod(scalar(left), optype), scalar(right));
3629 if (list_assignment(left)) {
3633 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3634 left = mod(left, OP_AASSIGN);
3642 curop = list(force_list(left));
3643 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3644 o->op_private = 0 | (flags >> 8);
3645 for (curop = ((LISTOP*)curop)->op_first;
3646 curop; curop = curop->op_sibling)
3648 if (curop->op_type == OP_RV2HV &&
3649 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3650 o->op_private |= OPpASSIGN_HASH;
3654 if (!(left->op_private & OPpLVAL_INTRO)) {
3657 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3658 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3659 if (curop->op_type == OP_GV) {
3660 GV *gv = cGVOPx_gv(curop);
3661 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3663 SvCUR(gv) = PL_generation;
3665 else if (curop->op_type == OP_PADSV ||
3666 curop->op_type == OP_PADAV ||
3667 curop->op_type == OP_PADHV ||
3668 curop->op_type == OP_PADANY) {
3669 SV **svp = AvARRAY(PL_comppad_name);
3670 SV *sv = svp[curop->op_targ];
3671 if (SvCUR(sv) == PL_generation)
3673 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3675 else if (curop->op_type == OP_RV2CV)
3677 else if (curop->op_type == OP_RV2SV ||
3678 curop->op_type == OP_RV2AV ||
3679 curop->op_type == OP_RV2HV ||
3680 curop->op_type == OP_RV2GV) {
3681 if (lastop->op_type != OP_GV) /* funny deref? */
3684 else if (curop->op_type == OP_PUSHRE) {
3685 if (((PMOP*)curop)->op_pmreplroot) {
3687 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3689 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3691 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3693 SvCUR(gv) = PL_generation;
3702 o->op_private |= OPpASSIGN_COMMON;
3704 if (right && right->op_type == OP_SPLIT) {
3706 if ((tmpop = ((LISTOP*)right)->op_first) &&
3707 tmpop->op_type == OP_PUSHRE)
3709 PMOP *pm = (PMOP*)tmpop;
3710 if (left->op_type == OP_RV2AV &&
3711 !(left->op_private & OPpLVAL_INTRO) &&
3712 !(o->op_private & OPpASSIGN_COMMON) )
3714 tmpop = ((UNOP*)left)->op_first;
3715 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3717 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3718 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3720 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3721 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3723 pm->op_pmflags |= PMf_ONCE;
3724 tmpop = cUNOPo->op_first; /* to list (nulled) */
3725 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3726 tmpop->op_sibling = Nullop; /* don't free split */
3727 right->op_next = tmpop->op_next; /* fix starting loc */
3728 op_free(o); /* blow off assign */
3729 right->op_flags &= ~OPf_WANT;
3730 /* "I don't know and I don't care." */
3735 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3736 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3738 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3740 sv_setiv(sv, PL_modcount+1);
3748 right = newOP(OP_UNDEF, 0);
3749 if (right->op_type == OP_READLINE) {
3750 right->op_flags |= OPf_STACKED;
3751 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3754 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3755 o = newBINOP(OP_SASSIGN, flags,
3756 scalar(right), mod(scalar(left), OP_SASSIGN) );
3768 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3770 U32 seq = intro_my();
3773 NewOp(1101, cop, 1, COP);
3774 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3775 cop->op_type = OP_DBSTATE;
3776 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3779 cop->op_type = OP_NEXTSTATE;
3780 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3782 cop->op_flags = flags;
3783 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3785 cop->op_private |= NATIVE_HINTS;
3787 PL_compiling.op_private = cop->op_private;
3788 cop->op_next = (OP*)cop;
3791 cop->cop_label = label;
3792 PL_hints |= HINT_BLOCK_SCOPE;
3795 cop->cop_arybase = PL_curcop->cop_arybase;
3796 if (specialWARN(PL_curcop->cop_warnings))
3797 cop->cop_warnings = PL_curcop->cop_warnings ;
3799 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3800 if (specialCopIO(PL_curcop->cop_io))
3801 cop->cop_io = PL_curcop->cop_io;
3803 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3806 if (PL_copline == NOLINE)
3807 CopLINE_set(cop, CopLINE(PL_curcop));
3809 CopLINE_set(cop, PL_copline);
3810 PL_copline = NOLINE;
3813 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3815 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3817 CopSTASH_set(cop, PL_curstash);
3819 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3820 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3821 if (svp && *svp != &PL_sv_undef ) {
3822 (void)SvIOK_on(*svp);
3823 SvIVX(*svp) = PTR2IV(cop);
3827 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3830 /* "Introduce" my variables to visible status. */
3838 if (! PL_min_intro_pending)
3839 return PL_cop_seqmax;
3841 svp = AvARRAY(PL_comppad_name);
3842 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3843 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3844 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3845 SvNVX(sv) = (NV)PL_cop_seqmax;
3848 PL_min_intro_pending = 0;
3849 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3850 return PL_cop_seqmax++;
3854 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3856 return new_logop(type, flags, &first, &other);
3860 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3864 OP *first = *firstp;
3865 OP *other = *otherp;
3867 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3868 return newBINOP(type, flags, scalar(first), scalar(other));
3870 scalarboolean(first);
3871 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3872 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3873 if (type == OP_AND || type == OP_OR) {
3879 first = *firstp = cUNOPo->op_first;
3881 first->op_next = o->op_next;
3882 cUNOPo->op_first = Nullop;
3886 if (first->op_type == OP_CONST) {
3887 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3888 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3889 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3900 else if (first->op_type == OP_WANTARRAY) {
3906 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3907 OP *k1 = ((UNOP*)first)->op_first;
3908 OP *k2 = k1->op_sibling;
3910 switch (first->op_type)
3913 if (k2 && k2->op_type == OP_READLINE
3914 && (k2->op_flags & OPf_STACKED)
3915 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3917 warnop = k2->op_type;
3922 if (k1->op_type == OP_READDIR
3923 || k1->op_type == OP_GLOB
3924 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3925 || k1->op_type == OP_EACH)
3927 warnop = ((k1->op_type == OP_NULL)
3928 ? k1->op_targ : k1->op_type);
3933 line_t oldline = CopLINE(PL_curcop);
3934 CopLINE_set(PL_curcop, PL_copline);
3935 Perl_warner(aTHX_ WARN_MISC,
3936 "Value of %s%s can be \"0\"; test with defined()",
3938 ((warnop == OP_READLINE || warnop == OP_GLOB)
3939 ? " construct" : "() operator"));
3940 CopLINE_set(PL_curcop, oldline);
3947 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3948 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3950 NewOp(1101, logop, 1, LOGOP);
3952 logop->op_type = type;
3953 logop->op_ppaddr = PL_ppaddr[type];
3954 logop->op_first = first;
3955 logop->op_flags = flags | OPf_KIDS;
3956 logop->op_other = LINKLIST(other);
3957 logop->op_private = 1 | (flags >> 8);
3959 /* establish postfix order */
3960 logop->op_next = LINKLIST(first);
3961 first->op_next = (OP*)logop;
3962 first->op_sibling = other;
3964 o = newUNOP(OP_NULL, 0, (OP*)logop);
3971 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3978 return newLOGOP(OP_AND, 0, first, trueop);
3980 return newLOGOP(OP_OR, 0, first, falseop);
3982 scalarboolean(first);
3983 if (first->op_type == OP_CONST) {
3984 if (SvTRUE(((SVOP*)first)->op_sv)) {
3995 else if (first->op_type == OP_WANTARRAY) {
3999 NewOp(1101, logop, 1, LOGOP);
4000 logop->op_type = OP_COND_EXPR;
4001 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4002 logop->op_first = first;
4003 logop->op_flags = flags | OPf_KIDS;
4004 logop->op_private = 1 | (flags >> 8);
4005 logop->op_other = LINKLIST(trueop);
4006 logop->op_next = LINKLIST(falseop);
4009 /* establish postfix order */
4010 start = LINKLIST(first);
4011 first->op_next = (OP*)logop;
4013 first->op_sibling = trueop;
4014 trueop->op_sibling = falseop;
4015 o = newUNOP(OP_NULL, 0, (OP*)logop);
4017 trueop->op_next = falseop->op_next = o;
4024 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4032 NewOp(1101, range, 1, LOGOP);
4034 range->op_type = OP_RANGE;
4035 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4036 range->op_first = left;
4037 range->op_flags = OPf_KIDS;
4038 leftstart = LINKLIST(left);
4039 range->op_other = LINKLIST(right);
4040 range->op_private = 1 | (flags >> 8);
4042 left->op_sibling = right;
4044 range->op_next = (OP*)range;
4045 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4046 flop = newUNOP(OP_FLOP, 0, flip);
4047 o = newUNOP(OP_NULL, 0, flop);
4049 range->op_next = leftstart;
4051 left->op_next = flip;
4052 right->op_next = flop;
4054 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4055 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4056 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4057 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4059 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4060 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4063 if (!flip->op_private || !flop->op_private)
4064 linklist(o); /* blow off optimizer unless constant */
4070 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4074 int once = block && block->op_flags & OPf_SPECIAL &&
4075 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4078 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4079 return block; /* do {} while 0 does once */
4080 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4081 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4082 expr = newUNOP(OP_DEFINED, 0,
4083 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4084 } else if (expr->op_flags & OPf_KIDS) {
4085 OP *k1 = ((UNOP*)expr)->op_first;
4086 OP *k2 = (k1) ? k1->op_sibling : NULL;
4087 switch (expr->op_type) {
4089 if (k2 && k2->op_type == OP_READLINE
4090 && (k2->op_flags & OPf_STACKED)
4091 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4092 expr = newUNOP(OP_DEFINED, 0, expr);
4096 if (k1->op_type == OP_READDIR
4097 || k1->op_type == OP_GLOB
4098 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4099 || k1->op_type == OP_EACH)
4100 expr = newUNOP(OP_DEFINED, 0, expr);
4106 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4107 o = new_logop(OP_AND, 0, &expr, &listop);
4110 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4112 if (once && o != listop)
4113 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4116 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4118 o->op_flags |= flags;
4120 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4125 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4133 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4134 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4135 expr = newUNOP(OP_DEFINED, 0,
4136 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4137 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4138 OP *k1 = ((UNOP*)expr)->op_first;
4139 OP *k2 = (k1) ? k1->op_sibling : NULL;
4140 switch (expr->op_type) {
4142 if (k2 && k2->op_type == OP_READLINE
4143 && (k2->op_flags & OPf_STACKED)
4144 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4145 expr = newUNOP(OP_DEFINED, 0, expr);
4149 if (k1->op_type == OP_READDIR
4150 || k1->op_type == OP_GLOB
4151 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4152 || k1->op_type == OP_EACH)
4153 expr = newUNOP(OP_DEFINED, 0, expr);
4159 block = newOP(OP_NULL, 0);
4161 block = scope(block);
4165 next = LINKLIST(cont);
4168 OP *unstack = newOP(OP_UNSTACK, 0);
4171 cont = append_elem(OP_LINESEQ, cont, unstack);
4172 if ((line_t)whileline != NOLINE) {
4173 PL_copline = whileline;
4174 cont = append_elem(OP_LINESEQ, cont,
4175 newSTATEOP(0, Nullch, Nullop));
4179 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4180 redo = LINKLIST(listop);
4183 PL_copline = whileline;
4185 o = new_logop(OP_AND, 0, &expr, &listop);
4186 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4187 op_free(expr); /* oops, it's a while (0) */
4189 return Nullop; /* listop already freed by new_logop */
4192 ((LISTOP*)listop)->op_last->op_next =
4193 (o == listop ? redo : LINKLIST(o));
4199 NewOp(1101,loop,1,LOOP);
4200 loop->op_type = OP_ENTERLOOP;
4201 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4202 loop->op_private = 0;
4203 loop->op_next = (OP*)loop;
4206 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4208 loop->op_redoop = redo;
4209 loop->op_lastop = o;
4210 o->op_private |= loopflags;
4213 loop->op_nextop = next;
4215 loop->op_nextop = o;
4217 o->op_flags |= flags;
4218 o->op_private |= (flags >> 8);
4223 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4231 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4232 sv->op_type = OP_RV2GV;
4233 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4235 else if (sv->op_type == OP_PADSV) { /* private variable */
4236 padoff = sv->op_targ;
4241 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4242 padoff = sv->op_targ;
4244 iterflags |= OPf_SPECIAL;
4249 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4252 #ifdef USE_5005THREADS
4253 padoff = find_threadsv("_");
4254 iterflags |= OPf_SPECIAL;
4256 sv = newGVOP(OP_GV, 0, PL_defgv);
4259 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4260 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4261 iterflags |= OPf_STACKED;
4263 else if (expr->op_type == OP_NULL &&
4264 (expr->op_flags & OPf_KIDS) &&
4265 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4267 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4268 * set the STACKED flag to indicate that these values are to be
4269 * treated as min/max values by 'pp_iterinit'.
4271 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4272 LOGOP* range = (LOGOP*) flip->op_first;
4273 OP* left = range->op_first;
4274 OP* right = left->op_sibling;
4277 range->op_flags &= ~OPf_KIDS;
4278 range->op_first = Nullop;
4280 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4281 listop->op_first->op_next = range->op_next;
4282 left->op_next = range->op_other;
4283 right->op_next = (OP*)listop;
4284 listop->op_next = listop->op_first;
4287 expr = (OP*)(listop);
4289 iterflags |= OPf_STACKED;
4292 expr = mod(force_list(expr), OP_GREPSTART);
4296 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4297 append_elem(OP_LIST, expr, scalar(sv))));
4298 assert(!loop->op_next);
4299 #ifdef PL_OP_SLAB_ALLOC
4302 NewOp(1234,tmp,1,LOOP);
4303 Copy(loop,tmp,1,LOOP);
4308 Renew(loop, 1, LOOP);
4310 loop->op_targ = padoff;
4311 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4312 PL_copline = forline;
4313 return newSTATEOP(0, label, wop);
4317 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4322 if (type != OP_GOTO || label->op_type == OP_CONST) {
4323 /* "last()" means "last" */
4324 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4325 o = newOP(type, OPf_SPECIAL);
4327 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4328 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4334 if (label->op_type == OP_ENTERSUB)
4335 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4336 o = newUNOP(type, OPf_STACKED, label);
4338 PL_hints |= HINT_BLOCK_SCOPE;
4343 Perl_cv_undef(pTHX_ CV *cv)
4345 #ifdef USE_5005THREADS
4347 MUTEX_DESTROY(CvMUTEXP(cv));
4348 Safefree(CvMUTEXP(cv));
4351 #endif /* USE_5005THREADS */
4354 if (CvFILE(cv) && !CvXSUB(cv)) {
4355 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4356 Safefree(CvFILE(cv));
4361 if (!CvXSUB(cv) && CvROOT(cv)) {
4362 #ifdef USE_5005THREADS
4363 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4364 Perl_croak(aTHX_ "Can't undef active subroutine");
4367 Perl_croak(aTHX_ "Can't undef active subroutine");
4368 #endif /* USE_5005THREADS */
4371 SAVEVPTR(PL_curpad);
4374 op_free(CvROOT(cv));
4375 CvROOT(cv) = Nullop;
4378 SvPOK_off((SV*)cv); /* forget prototype */
4380 /* Since closure prototypes have the same lifetime as the containing
4381 * CV, they don't hold a refcount on the outside CV. This avoids
4382 * the refcount loop between the outer CV (which keeps a refcount to
4383 * the closure prototype in the pad entry for pp_anoncode()) and the
4384 * closure prototype, and the ensuing memory leak. --GSAR */
4385 if (!CvANON(cv) || CvCLONED(cv))
4386 SvREFCNT_dec(CvOUTSIDE(cv));
4387 CvOUTSIDE(cv) = Nullcv;
4389 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4392 if (CvPADLIST(cv)) {
4393 /* may be during global destruction */
4394 if (SvREFCNT(CvPADLIST(cv))) {
4395 I32 i = AvFILLp(CvPADLIST(cv));
4397 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4398 SV* sv = svp ? *svp : Nullsv;
4401 if (sv == (SV*)PL_comppad_name)
4402 PL_comppad_name = Nullav;
4403 else if (sv == (SV*)PL_comppad) {
4404 PL_comppad = Nullav;
4405 PL_curpad = Null(SV**);
4409 SvREFCNT_dec((SV*)CvPADLIST(cv));
4411 CvPADLIST(cv) = Nullav;
4419 #ifdef DEBUG_CLOSURES
4421 S_cv_dump(pTHX_ CV *cv)
4424 CV *outside = CvOUTSIDE(cv);
4425 AV* padlist = CvPADLIST(cv);
4432 PerlIO_printf(Perl_debug_log,
4433 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4435 (CvANON(cv) ? "ANON"
4436 : (cv == PL_main_cv) ? "MAIN"
4437 : CvUNIQUE(cv) ? "UNIQUE"
4438 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4441 : CvANON(outside) ? "ANON"
4442 : (outside == PL_main_cv) ? "MAIN"
4443 : CvUNIQUE(outside) ? "UNIQUE"
4444 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4449 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4450 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4451 pname = AvARRAY(pad_name);
4452 ppad = AvARRAY(pad);
4454 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4455 if (SvPOK(pname[ix]))
4456 PerlIO_printf(Perl_debug_log,
4457 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4458 (int)ix, PTR2UV(ppad[ix]),
4459 SvFAKE(pname[ix]) ? "FAKE " : "",
4461 (IV)I_32(SvNVX(pname[ix])),
4464 #endif /* DEBUGGING */
4466 #endif /* DEBUG_CLOSURES */
4469 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4473 AV* protopadlist = CvPADLIST(proto);
4474 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4475 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4476 SV** pname = AvARRAY(protopad_name);
4477 SV** ppad = AvARRAY(protopad);
4478 I32 fname = AvFILLp(protopad_name);
4479 I32 fpad = AvFILLp(protopad);
4483 assert(!CvUNIQUE(proto));
4487 SAVESPTR(PL_comppad_name);
4488 SAVESPTR(PL_compcv);
4490 cv = PL_compcv = (CV*)NEWSV(1104,0);
4491 sv_upgrade((SV *)cv, SvTYPE(proto));
4492 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4495 #ifdef USE_5005THREADS
4496 New(666, CvMUTEXP(cv), 1, perl_mutex);
4497 MUTEX_INIT(CvMUTEXP(cv));
4499 #endif /* USE_5005THREADS */
4501 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4502 : savepv(CvFILE(proto));
4504 CvFILE(cv) = CvFILE(proto);
4506 CvGV(cv) = CvGV(proto);
4507 CvSTASH(cv) = CvSTASH(proto);
4508 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4509 CvSTART(cv) = CvSTART(proto);
4511 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4514 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4516 PL_comppad_name = newAV();
4517 for (ix = fname; ix >= 0; ix--)
4518 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4520 PL_comppad = newAV();
4522 comppadlist = newAV();
4523 AvREAL_off(comppadlist);
4524 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4525 av_store(comppadlist, 1, (SV*)PL_comppad);
4526 CvPADLIST(cv) = comppadlist;
4527 av_fill(PL_comppad, AvFILLp(protopad));
4528 PL_curpad = AvARRAY(PL_comppad);
4530 av = newAV(); /* will be @_ */
4532 av_store(PL_comppad, 0, (SV*)av);
4533 AvFLAGS(av) = AVf_REIFY;
4535 for (ix = fpad; ix > 0; ix--) {
4536 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4537 if (namesv && namesv != &PL_sv_undef) {
4538 char *name = SvPVX(namesv); /* XXX */
4539 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4540 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4541 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4543 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4545 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4547 else { /* our own lexical */
4550 /* anon code -- we'll come back for it */
4551 sv = SvREFCNT_inc(ppad[ix]);
4553 else if (*name == '@')
4555 else if (*name == '%')
4564 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4565 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4568 SV* sv = NEWSV(0,0);
4574 /* Now that vars are all in place, clone nested closures. */
4576 for (ix = fpad; ix > 0; ix--) {
4577 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4579 && namesv != &PL_sv_undef
4580 && !(SvFLAGS(namesv) & SVf_FAKE)
4581 && *SvPVX(namesv) == '&'
4582 && CvCLONE(ppad[ix]))
4584 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4585 SvREFCNT_dec(ppad[ix]);
4588 PL_curpad[ix] = (SV*)kid;
4592 #ifdef DEBUG_CLOSURES
4593 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4595 PerlIO_printf(Perl_debug_log, " from:\n");
4597 PerlIO_printf(Perl_debug_log, " to:\n");
4604 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4606 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4608 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4615 Perl_cv_clone(pTHX_ CV *proto)
4618 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4619 cv = cv_clone2(proto, CvOUTSIDE(proto));
4620 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4625 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4627 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4628 SV* msg = sv_newmortal();
4632 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4633 sv_setpv(msg, "Prototype mismatch:");
4635 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4637 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4638 sv_catpv(msg, " vs ");
4640 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4642 sv_catpv(msg, "none");
4643 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4647 static void const_sv_xsub(pTHX_ CV* cv);
4651 =head1 Optree Manipulation Functions
4653 =for apidoc cv_const_sv
4655 If C<cv> is a constant sub eligible for inlining. returns the constant
4656 value returned by the sub. Otherwise, returns NULL.
4658 Constant subs can be created with C<newCONSTSUB> or as described in
4659 L<perlsub/"Constant Functions">.
4664 Perl_cv_const_sv(pTHX_ CV *cv)
4666 if (!cv || !CvCONST(cv))
4668 return (SV*)CvXSUBANY(cv).any_ptr;
4672 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4679 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4680 o = cLISTOPo->op_first->op_sibling;
4682 for (; o; o = o->op_next) {
4683 OPCODE type = o->op_type;
4685 if (sv && o->op_next == o)
4687 if (o->op_next != o) {
4688 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4690 if (type == OP_DBSTATE)
4693 if (type == OP_LEAVESUB || type == OP_RETURN)
4697 if (type == OP_CONST && cSVOPo->op_sv)
4699 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4700 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4701 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4705 /* We get here only from cv_clone2() while creating a closure.
4706 Copy the const value here instead of in cv_clone2 so that
4707 SvREADONLY_on doesn't lead to problems when leaving
4712 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4724 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4734 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4738 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4740 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4744 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4750 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4755 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4756 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4757 SV *sv = sv_newmortal();
4758 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4759 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4764 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4765 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4775 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4776 maximum a prototype before. */
4777 if (SvTYPE(gv) > SVt_NULL) {
4778 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4779 && ckWARN_d(WARN_PROTOTYPE))
4781 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4783 cv_ckproto((CV*)gv, NULL, ps);
4786 sv_setpv((SV*)gv, ps);
4788 sv_setiv((SV*)gv, -1);
4789 SvREFCNT_dec(PL_compcv);
4790 cv = PL_compcv = NULL;
4791 PL_sub_generation++;
4795 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4797 #ifdef GV_UNIQUE_CHECK
4798 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4799 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4803 if (!block || !ps || *ps || attrs)
4806 const_sv = op_const_sv(block, Nullcv);
4809 bool exists = CvROOT(cv) || CvXSUB(cv);
4811 #ifdef GV_UNIQUE_CHECK
4812 if (exists && GvUNIQUE(gv)) {
4813 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4817 /* if the subroutine doesn't exist and wasn't pre-declared
4818 * with a prototype, assume it will be AUTOLOADed,
4819 * skipping the prototype check
4821 if (exists || SvPOK(cv))
4822 cv_ckproto(cv, gv, ps);
4823 /* already defined (or promised)? */
4824 if (exists || GvASSUMECV(gv)) {
4825 if (!block && !attrs) {
4826 /* just a "sub foo;" when &foo is already defined */
4827 SAVEFREESV(PL_compcv);
4830 /* ahem, death to those who redefine active sort subs */
4831 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4832 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4834 if (ckWARN(WARN_REDEFINE)
4836 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4838 line_t oldline = CopLINE(PL_curcop);
4839 if (PL_copline != NOLINE)
4840 CopLINE_set(PL_curcop, PL_copline);
4841 Perl_warner(aTHX_ WARN_REDEFINE,
4842 CvCONST(cv) ? "Constant subroutine %s redefined"
4843 : "Subroutine %s redefined", name);
4844 CopLINE_set(PL_curcop, oldline);
4852 SvREFCNT_inc(const_sv);
4854 assert(!CvROOT(cv) && !CvCONST(cv));
4855 sv_setpv((SV*)cv, ""); /* prototype is "" */
4856 CvXSUBANY(cv).any_ptr = const_sv;
4857 CvXSUB(cv) = const_sv_xsub;
4862 cv = newCONSTSUB(NULL, name, const_sv);
4865 SvREFCNT_dec(PL_compcv);
4867 PL_sub_generation++;
4874 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4875 * before we clobber PL_compcv.
4879 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4880 stash = GvSTASH(CvGV(cv));
4881 else if (CvSTASH(cv))
4882 stash = CvSTASH(cv);
4884 stash = PL_curstash;
4887 /* possibly about to re-define existing subr -- ignore old cv */
4888 rcv = (SV*)PL_compcv;
4889 if (name && GvSTASH(gv))
4890 stash = GvSTASH(gv);
4892 stash = PL_curstash;
4894 apply_attrs(stash, rcv, attrs, FALSE);
4896 if (cv) { /* must reuse cv if autoloaded */
4898 /* got here with just attrs -- work done, so bug out */
4899 SAVEFREESV(PL_compcv);
4903 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4904 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4905 CvOUTSIDE(PL_compcv) = 0;
4906 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4907 CvPADLIST(PL_compcv) = 0;
4908 /* inner references to PL_compcv must be fixed up ... */
4910 AV *padlist = CvPADLIST(cv);
4911 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4912 AV *comppad = (AV*)AvARRAY(padlist)[1];
4913 SV **namepad = AvARRAY(comppad_name);
4914 SV **curpad = AvARRAY(comppad);
4915 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4916 SV *namesv = namepad[ix];
4917 if (namesv && namesv != &PL_sv_undef
4918 && *SvPVX(namesv) == '&')
4920 CV *innercv = (CV*)curpad[ix];
4921 if (CvOUTSIDE(innercv) == PL_compcv) {
4922 CvOUTSIDE(innercv) = cv;
4923 if (!CvANON(innercv) || CvCLONED(innercv)) {
4924 (void)SvREFCNT_inc(cv);
4925 SvREFCNT_dec(PL_compcv);
4931 /* ... before we throw it away */
4932 SvREFCNT_dec(PL_compcv);
4933 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4934 ++PL_sub_generation;
4941 PL_sub_generation++;
4945 CvFILE_set_from_cop(cv, PL_curcop);
4946 CvSTASH(cv) = PL_curstash;
4947 #ifdef USE_5005THREADS
4949 if (!CvMUTEXP(cv)) {
4950 New(666, CvMUTEXP(cv), 1, perl_mutex);
4951 MUTEX_INIT(CvMUTEXP(cv));
4953 #endif /* USE_5005THREADS */
4956 sv_setpv((SV*)cv, ps);
4958 if (PL_error_count) {
4962 char *s = strrchr(name, ':');
4964 if (strEQ(s, "BEGIN")) {
4966 "BEGIN not safe after errors--compilation aborted";
4967 if (PL_in_eval & EVAL_KEEPERR)
4968 Perl_croak(aTHX_ not_safe);
4970 /* force display of errors found but not reported */
4971 sv_catpv(ERRSV, not_safe);
4972 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4980 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4981 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4984 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4985 mod(scalarseq(block), OP_LEAVESUBLV));
4988 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4990 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4991 OpREFCNT_set(CvROOT(cv), 1);
4992 CvSTART(cv) = LINKLIST(CvROOT(cv));
4993 CvROOT(cv)->op_next = 0;
4994 CALL_PEEP(CvSTART(cv));
4996 /* now that optimizer has done its work, adjust pad values */
4998 SV **namep = AvARRAY(PL_comppad_name);
4999 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5002 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5005 * The only things that a clonable function needs in its
5006 * pad are references to outer lexicals and anonymous subs.
5007 * The rest are created anew during cloning.
5009 if (!((namesv = namep[ix]) != Nullsv &&
5010 namesv != &PL_sv_undef &&
5012 *SvPVX(namesv) == '&')))
5014 SvREFCNT_dec(PL_curpad[ix]);
5015 PL_curpad[ix] = Nullsv;
5018 assert(!CvCONST(cv));
5019 if (ps && !*ps && op_const_sv(block, cv))
5023 AV *av = newAV(); /* Will be @_ */
5025 av_store(PL_comppad, 0, (SV*)av);
5026 AvFLAGS(av) = AVf_REIFY;
5028 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5029 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5031 if (!SvPADMY(PL_curpad[ix]))
5032 SvPADTMP_on(PL_curpad[ix]);
5036 /* If a potential closure prototype, don't keep a refcount on outer CV.
5037 * This is okay as the lifetime of the prototype is tied to the
5038 * lifetime of the outer CV. Avoids memory leak due to reference
5041 SvREFCNT_dec(CvOUTSIDE(cv));
5043 if (name || aname) {
5045 char *tname = (name ? name : aname);
5047 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5048 SV *sv = NEWSV(0,0);
5049 SV *tmpstr = sv_newmortal();
5050 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5054 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5056 (long)PL_subline, (long)CopLINE(PL_curcop));
5057 gv_efullname3(tmpstr, gv, Nullch);
5058 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5059 hv = GvHVn(db_postponed);
5060 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5061 && (pcv = GvCV(db_postponed)))
5067 call_sv((SV*)pcv, G_DISCARD);
5071 if ((s = strrchr(tname,':')))
5076 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5079 if (strEQ(s, "BEGIN")) {
5080 I32 oldscope = PL_scopestack_ix;
5082 SAVECOPFILE(&PL_compiling);
5083 SAVECOPLINE(&PL_compiling);
5086 PL_beginav = newAV();
5087 DEBUG_x( dump_sub(gv) );
5088 av_push(PL_beginav, (SV*)cv);
5089 GvCV(gv) = 0; /* cv has been hijacked */
5090 call_list(oldscope, PL_beginav);
5092 PL_curcop = &PL_compiling;
5093 PL_compiling.op_private = PL_hints;
5096 else if (strEQ(s, "END") && !PL_error_count) {
5099 DEBUG_x( dump_sub(gv) );
5100 av_unshift(PL_endav, 1);
5101 av_store(PL_endav, 0, (SV*)cv);
5102 GvCV(gv) = 0; /* cv has been hijacked */
5104 else if (strEQ(s, "CHECK") && !PL_error_count) {
5106 PL_checkav = newAV();
5107 DEBUG_x( dump_sub(gv) );
5108 if (PL_main_start && ckWARN(WARN_VOID))
5109 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5110 av_unshift(PL_checkav, 1);
5111 av_store(PL_checkav, 0, (SV*)cv);
5112 GvCV(gv) = 0; /* cv has been hijacked */
5114 else if (strEQ(s, "INIT") && !PL_error_count) {
5116 PL_initav = newAV();
5117 DEBUG_x( dump_sub(gv) );
5118 if (PL_main_start && ckWARN(WARN_VOID))
5119 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5120 av_push(PL_initav, (SV*)cv);
5121 GvCV(gv) = 0; /* cv has been hijacked */
5126 PL_copline = NOLINE;
5131 /* XXX unsafe for threads if eval_owner isn't held */
5133 =for apidoc newCONSTSUB
5135 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5136 eligible for inlining at compile-time.
5142 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5148 SAVECOPLINE(PL_curcop);
5149 CopLINE_set(PL_curcop, PL_copline);
5152 PL_hints &= ~HINT_BLOCK_SCOPE;
5155 SAVESPTR(PL_curstash);
5156 SAVECOPSTASH(PL_curcop);
5157 PL_curstash = stash;
5158 CopSTASH_set(PL_curcop,stash);
5161 cv = newXS(name, const_sv_xsub, __FILE__);
5162 CvXSUBANY(cv).any_ptr = sv;
5164 sv_setpv((SV*)cv, ""); /* prototype is "" */
5172 =for apidoc U||newXS
5174 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5180 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5182 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5185 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5187 /* just a cached method */
5191 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5192 /* already defined (or promised) */
5193 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5194 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5195 line_t oldline = CopLINE(PL_curcop);
5196 if (PL_copline != NOLINE)
5197 CopLINE_set(PL_curcop, PL_copline);
5198 Perl_warner(aTHX_ WARN_REDEFINE,
5199 CvCONST(cv) ? "Constant subroutine %s redefined"
5200 : "Subroutine %s redefined"
5202 CopLINE_set(PL_curcop, oldline);
5209 if (cv) /* must reuse cv if autoloaded */
5212 cv = (CV*)NEWSV(1105,0);
5213 sv_upgrade((SV *)cv, SVt_PVCV);
5217 PL_sub_generation++;
5221 #ifdef USE_5005THREADS
5222 New(666, CvMUTEXP(cv), 1, perl_mutex);
5223 MUTEX_INIT(CvMUTEXP(cv));
5225 #endif /* USE_5005THREADS */
5226 (void)gv_fetchfile(filename);
5227 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5228 an external constant string */
5229 CvXSUB(cv) = subaddr;
5232 char *s = strrchr(name,':');
5238 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5241 if (strEQ(s, "BEGIN")) {
5243 PL_beginav = newAV();
5244 av_push(PL_beginav, (SV*)cv);
5245 GvCV(gv) = 0; /* cv has been hijacked */
5247 else if (strEQ(s, "END")) {
5250 av_unshift(PL_endav, 1);
5251 av_store(PL_endav, 0, (SV*)cv);
5252 GvCV(gv) = 0; /* cv has been hijacked */
5254 else if (strEQ(s, "CHECK")) {
5256 PL_checkav = newAV();
5257 if (PL_main_start && ckWARN(WARN_VOID))
5258 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5259 av_unshift(PL_checkav, 1);
5260 av_store(PL_checkav, 0, (SV*)cv);
5261 GvCV(gv) = 0; /* cv has been hijacked */
5263 else if (strEQ(s, "INIT")) {
5265 PL_initav = newAV();
5266 if (PL_main_start && ckWARN(WARN_VOID))
5267 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5268 av_push(PL_initav, (SV*)cv);
5269 GvCV(gv) = 0; /* cv has been hijacked */
5280 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5289 name = SvPVx(cSVOPo->op_sv, n_a);
5292 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5293 #ifdef GV_UNIQUE_CHECK
5295 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5299 if ((cv = GvFORM(gv))) {
5300 if (ckWARN(WARN_REDEFINE)) {
5301 line_t oldline = CopLINE(PL_curcop);
5302 if (PL_copline != NOLINE)
5303 CopLINE_set(PL_curcop, PL_copline);
5304 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5305 CopLINE_set(PL_curcop, oldline);
5312 CvFILE_set_from_cop(cv, PL_curcop);
5314 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5315 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5316 SvPADTMP_on(PL_curpad[ix]);
5319 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5320 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5321 OpREFCNT_set(CvROOT(cv), 1);
5322 CvSTART(cv) = LINKLIST(CvROOT(cv));
5323 CvROOT(cv)->op_next = 0;
5324 CALL_PEEP(CvSTART(cv));
5326 PL_copline = NOLINE;
5331 Perl_newANONLIST(pTHX_ OP *o)
5333 return newUNOP(OP_REFGEN, 0,
5334 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5338 Perl_newANONHASH(pTHX_ OP *o)
5340 return newUNOP(OP_REFGEN, 0,
5341 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5345 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5347 return newANONATTRSUB(floor, proto, Nullop, block);
5351 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5353 return newUNOP(OP_REFGEN, 0,
5354 newSVOP(OP_ANONCODE, 0,
5355 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5359 Perl_oopsAV(pTHX_ OP *o)
5361 switch (o->op_type) {
5363 o->op_type = OP_PADAV;
5364 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5365 return ref(o, OP_RV2AV);
5368 o->op_type = OP_RV2AV;
5369 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5374 if (ckWARN_d(WARN_INTERNAL))
5375 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5382 Perl_oopsHV(pTHX_ OP *o)
5384 switch (o->op_type) {
5387 o->op_type = OP_PADHV;
5388 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5389 return ref(o, OP_RV2HV);
5393 o->op_type = OP_RV2HV;
5394 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5399 if (ckWARN_d(WARN_INTERNAL))
5400 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5407 Perl_newAVREF(pTHX_ OP *o)
5409 if (o->op_type == OP_PADANY) {
5410 o->op_type = OP_PADAV;
5411 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5414 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5415 && ckWARN(WARN_DEPRECATED)) {
5416 Perl_warner(aTHX_ WARN_DEPRECATED,
5417 "Using an array as a reference is deprecated");
5419 return newUNOP(OP_RV2AV, 0, scalar(o));
5423 Perl_newGVREF(pTHX_ I32 type, OP *o)
5425 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5426 return newUNOP(OP_NULL, 0, o);
5427 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5431 Perl_newHVREF(pTHX_ OP *o)
5433 if (o->op_type == OP_PADANY) {
5434 o->op_type = OP_PADHV;
5435 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5438 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5439 && ckWARN(WARN_DEPRECATED)) {
5440 Perl_warner(aTHX_ WARN_DEPRECATED,
5441 "Using a hash as a reference is deprecated");
5443 return newUNOP(OP_RV2HV, 0, scalar(o));
5447 Perl_oopsCV(pTHX_ OP *o)
5449 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5455 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5457 return newUNOP(OP_RV2CV, flags, scalar(o));
5461 Perl_newSVREF(pTHX_ OP *o)
5463 if (o->op_type == OP_PADANY) {
5464 o->op_type = OP_PADSV;
5465 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5468 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5469 o->op_flags |= OPpDONE_SVREF;
5472 return newUNOP(OP_RV2SV, 0, scalar(o));
5475 /* Check routines. */
5478 Perl_ck_anoncode(pTHX_ OP *o)
5483 name = NEWSV(1106,0);
5484 sv_upgrade(name, SVt_PVNV);
5485 sv_setpvn(name, "&", 1);
5488 ix = pad_alloc(o->op_type, SVs_PADMY);
5489 av_store(PL_comppad_name, ix, name);
5490 av_store(PL_comppad, ix, cSVOPo->op_sv);
5491 SvPADMY_on(cSVOPo->op_sv);
5492 cSVOPo->op_sv = Nullsv;
5493 cSVOPo->op_targ = ix;
5498 Perl_ck_bitop(pTHX_ OP *o)
5500 o->op_private = PL_hints;
5505 Perl_ck_concat(pTHX_ OP *o)
5507 if (cUNOPo->op_first->op_type == OP_CONCAT)
5508 o->op_flags |= OPf_STACKED;
5513 Perl_ck_spair(pTHX_ OP *o)
5515 if (o->op_flags & OPf_KIDS) {
5518 OPCODE type = o->op_type;
5519 o = modkids(ck_fun(o), type);
5520 kid = cUNOPo->op_first;
5521 newop = kUNOP->op_first->op_sibling;
5523 (newop->op_sibling ||
5524 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5525 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5526 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5530 op_free(kUNOP->op_first);
5531 kUNOP->op_first = newop;
5533 o->op_ppaddr = PL_ppaddr[++o->op_type];
5538 Perl_ck_delete(pTHX_ OP *o)
5542 if (o->op_flags & OPf_KIDS) {
5543 OP *kid = cUNOPo->op_first;
5544 switch (kid->op_type) {
5546 o->op_flags |= OPf_SPECIAL;
5549 o->op_private |= OPpSLICE;
5552 o->op_flags |= OPf_SPECIAL;
5557 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5566 Perl_ck_die(pTHX_ OP *o)
5569 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5575 Perl_ck_eof(pTHX_ OP *o)
5577 I32 type = o->op_type;
5579 if (o->op_flags & OPf_KIDS) {
5580 if (cLISTOPo->op_first->op_type == OP_STUB) {
5582 o = newUNOP(type, OPf_SPECIAL,
5583 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5591 Perl_ck_eval(pTHX_ OP *o)
5593 PL_hints |= HINT_BLOCK_SCOPE;
5594 if (o->op_flags & OPf_KIDS) {
5595 SVOP *kid = (SVOP*)cUNOPo->op_first;
5598 o->op_flags &= ~OPf_KIDS;
5601 else if (kid->op_type == OP_LINESEQ) {
5604 kid->op_next = o->op_next;
5605 cUNOPo->op_first = 0;
5608 NewOp(1101, enter, 1, LOGOP);
5609 enter->op_type = OP_ENTERTRY;
5610 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5611 enter->op_private = 0;
5613 /* establish postfix order */
5614 enter->op_next = (OP*)enter;
5616 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5617 o->op_type = OP_LEAVETRY;
5618 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5619 enter->op_other = o;
5627 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5629 o->op_targ = (PADOFFSET)PL_hints;
5634 Perl_ck_exit(pTHX_ OP *o)
5637 HV *table = GvHV(PL_hintgv);
5639 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5640 if (svp && *svp && SvTRUE(*svp))
5641 o->op_private |= OPpEXIT_VMSISH;
5643 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5649 Perl_ck_exec(pTHX_ OP *o)
5652 if (o->op_flags & OPf_STACKED) {
5654 kid = cUNOPo->op_first->op_sibling;
5655 if (kid->op_type == OP_RV2GV)
5664 Perl_ck_exists(pTHX_ OP *o)
5667 if (o->op_flags & OPf_KIDS) {
5668 OP *kid = cUNOPo->op_first;
5669 if (kid->op_type == OP_ENTERSUB) {
5670 (void) ref(kid, o->op_type);
5671 if (kid->op_type != OP_RV2CV && !PL_error_count)
5672 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5674 o->op_private |= OPpEXISTS_SUB;
5676 else if (kid->op_type == OP_AELEM)
5677 o->op_flags |= OPf_SPECIAL;
5678 else if (kid->op_type != OP_HELEM)
5679 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5688 Perl_ck_gvconst(pTHX_ register OP *o)
5690 o = fold_constants(o);
5691 if (o->op_type == OP_CONST)
5698 Perl_ck_rvconst(pTHX_ register OP *o)
5700 SVOP *kid = (SVOP*)cUNOPo->op_first;
5702 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5703 if (kid->op_type == OP_CONST) {
5707 SV *kidsv = kid->op_sv;
5710 /* Is it a constant from cv_const_sv()? */
5711 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5712 SV *rsv = SvRV(kidsv);
5713 int svtype = SvTYPE(rsv);
5714 char *badtype = Nullch;
5716 switch (o->op_type) {
5718 if (svtype > SVt_PVMG)
5719 badtype = "a SCALAR";
5722 if (svtype != SVt_PVAV)
5723 badtype = "an ARRAY";
5726 if (svtype != SVt_PVHV) {
5727 if (svtype == SVt_PVAV) { /* pseudohash? */
5728 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5729 if (ksv && SvROK(*ksv)
5730 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5739 if (svtype != SVt_PVCV)
5744 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5747 name = SvPV(kidsv, n_a);
5748 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5749 char *badthing = Nullch;
5750 switch (o->op_type) {
5752 badthing = "a SCALAR";
5755 badthing = "an ARRAY";
5758 badthing = "a HASH";
5763 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5767 * This is a little tricky. We only want to add the symbol if we
5768 * didn't add it in the lexer. Otherwise we get duplicate strict
5769 * warnings. But if we didn't add it in the lexer, we must at
5770 * least pretend like we wanted to add it even if it existed before,
5771 * or we get possible typo warnings. OPpCONST_ENTERED says
5772 * whether the lexer already added THIS instance of this symbol.
5774 iscv = (o->op_type == OP_RV2CV) * 2;
5776 gv = gv_fetchpv(name,
5777 iscv | !(kid->op_private & OPpCONST_ENTERED),
5780 : o->op_type == OP_RV2SV
5782 : o->op_type == OP_RV2AV
5784 : o->op_type == OP_RV2HV
5787 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5789 kid->op_type = OP_GV;
5790 SvREFCNT_dec(kid->op_sv);
5792 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5793 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5794 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5796 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5798 kid->op_sv = SvREFCNT_inc(gv);
5800 kid->op_private = 0;
5801 kid->op_ppaddr = PL_ppaddr[OP_GV];
5808 Perl_ck_ftst(pTHX_ OP *o)
5810 I32 type = o->op_type;
5812 if (o->op_flags & OPf_REF) {
5815 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5816 SVOP *kid = (SVOP*)cUNOPo->op_first;
5818 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5820 OP *newop = newGVOP(type, OPf_REF,
5821 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5828 if (type == OP_FTTTY)
5829 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5832 o = newUNOP(type, 0, newDEFSVOP());
5838 Perl_ck_fun(pTHX_ OP *o)
5844 int type = o->op_type;
5845 register I32 oa = PL_opargs[type] >> OASHIFT;
5847 if (o->op_flags & OPf_STACKED) {
5848 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5851 return no_fh_allowed(o);
5854 if (o->op_flags & OPf_KIDS) {
5856 tokid = &cLISTOPo->op_first;
5857 kid = cLISTOPo->op_first;
5858 if (kid->op_type == OP_PUSHMARK ||
5859 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5861 tokid = &kid->op_sibling;
5862 kid = kid->op_sibling;
5864 if (!kid && PL_opargs[type] & OA_DEFGV)
5865 *tokid = kid = newDEFSVOP();
5869 sibl = kid->op_sibling;
5872 /* list seen where single (scalar) arg expected? */
5873 if (numargs == 1 && !(oa >> 4)
5874 && kid->op_type == OP_LIST && type != OP_SCALAR)
5876 return too_many_arguments(o,PL_op_desc[type]);
5889 if ((type == OP_PUSH || type == OP_UNSHIFT)
5890 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5891 Perl_warner(aTHX_ WARN_SYNTAX,
5892 "Useless use of %s with no values",
5895 if (kid->op_type == OP_CONST &&
5896 (kid->op_private & OPpCONST_BARE))
5898 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5899 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5900 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5901 if (ckWARN(WARN_DEPRECATED))
5902 Perl_warner(aTHX_ WARN_DEPRECATED,
5903 "Array @%s missing the @ in argument %"IVdf" of %s()",
5904 name, (IV)numargs, PL_op_desc[type]);
5907 kid->op_sibling = sibl;
5910 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5911 bad_type(numargs, "array", PL_op_desc[type], kid);
5915 if (kid->op_type == OP_CONST &&
5916 (kid->op_private & OPpCONST_BARE))
5918 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5919 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5920 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5921 if (ckWARN(WARN_DEPRECATED))
5922 Perl_warner(aTHX_ WARN_DEPRECATED,
5923 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5924 name, (IV)numargs, PL_op_desc[type]);
5927 kid->op_sibling = sibl;
5930 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5931 bad_type(numargs, "hash", PL_op_desc[type], kid);
5936 OP *newop = newUNOP(OP_NULL, 0, kid);
5937 kid->op_sibling = 0;
5939 newop->op_next = newop;
5941 kid->op_sibling = sibl;
5946 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5947 if (kid->op_type == OP_CONST &&
5948 (kid->op_private & OPpCONST_BARE))
5950 OP *newop = newGVOP(OP_GV, 0,
5951 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5953 if (kid == cLISTOPo->op_last)
5954 cLISTOPo->op_last = newop;
5958 else if (kid->op_type == OP_READLINE) {
5959 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5960 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5963 I32 flags = OPf_SPECIAL;
5967 /* is this op a FH constructor? */
5968 if (is_handle_constructor(o,numargs)) {
5969 char *name = Nullch;
5973 /* Set a flag to tell rv2gv to vivify
5974 * need to "prove" flag does not mean something
5975 * else already - NI-S 1999/05/07
5978 if (kid->op_type == OP_PADSV) {
5979 SV **namep = av_fetch(PL_comppad_name,
5981 if (namep && *namep)
5982 name = SvPV(*namep, len);
5984 else if (kid->op_type == OP_RV2SV
5985 && kUNOP->op_first->op_type == OP_GV)
5987 GV *gv = cGVOPx_gv(kUNOP->op_first);
5989 len = GvNAMELEN(gv);
5991 else if (kid->op_type == OP_AELEM
5992 || kid->op_type == OP_HELEM)
5994 name = "__ANONIO__";
6000 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6001 namesv = PL_curpad[targ];
6002 (void)SvUPGRADE(namesv, SVt_PV);
6004 sv_setpvn(namesv, "$", 1);
6005 sv_catpvn(namesv, name, len);
6008 kid->op_sibling = 0;
6009 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6010 kid->op_targ = targ;
6011 kid->op_private |= priv;
6013 kid->op_sibling = sibl;
6019 mod(scalar(kid), type);
6023 tokid = &kid->op_sibling;
6024 kid = kid->op_sibling;
6026 o->op_private |= numargs;
6028 return too_many_arguments(o,OP_DESC(o));
6031 else if (PL_opargs[type] & OA_DEFGV) {
6033 return newUNOP(type, 0, newDEFSVOP());
6037 while (oa & OA_OPTIONAL)
6039 if (oa && oa != OA_LIST)
6040 return too_few_arguments(o,OP_DESC(o));
6046 Perl_ck_glob(pTHX_ OP *o)
6051 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6052 append_elem(OP_GLOB, o, newDEFSVOP());
6054 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6055 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6057 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6060 #if !defined(PERL_EXTERNAL_GLOB)
6061 /* XXX this can be tightened up and made more failsafe. */
6065 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6066 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6067 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6068 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6069 GvCV(gv) = GvCV(glob_gv);
6070 SvREFCNT_inc((SV*)GvCV(gv));
6071 GvIMPORTED_CV_on(gv);
6074 #endif /* PERL_EXTERNAL_GLOB */
6076 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6077 append_elem(OP_GLOB, o,
6078 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6079 o->op_type = OP_LIST;
6080 o->op_ppaddr = PL_ppaddr[OP_LIST];
6081 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6082 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6083 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6084 append_elem(OP_LIST, o,
6085 scalar(newUNOP(OP_RV2CV, 0,
6086 newGVOP(OP_GV, 0, gv)))));
6087 o = newUNOP(OP_NULL, 0, ck_subr(o));
6088 o->op_targ = OP_GLOB; /* hint at what it used to be */
6091 gv = newGVgen("main");
6093 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6099 Perl_ck_grep(pTHX_ OP *o)
6103 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6105 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6106 NewOp(1101, gwop, 1, LOGOP);
6108 if (o->op_flags & OPf_STACKED) {
6111 kid = cLISTOPo->op_first->op_sibling;
6112 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6115 kid->op_next = (OP*)gwop;
6116 o->op_flags &= ~OPf_STACKED;
6118 kid = cLISTOPo->op_first->op_sibling;
6119 if (type == OP_MAPWHILE)
6126 kid = cLISTOPo->op_first->op_sibling;
6127 if (kid->op_type != OP_NULL)
6128 Perl_croak(aTHX_ "panic: ck_grep");
6129 kid = kUNOP->op_first;
6131 gwop->op_type = type;
6132 gwop->op_ppaddr = PL_ppaddr[type];
6133 gwop->op_first = listkids(o);
6134 gwop->op_flags |= OPf_KIDS;
6135 gwop->op_private = 1;
6136 gwop->op_other = LINKLIST(kid);
6137 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6138 kid->op_next = (OP*)gwop;
6140 kid = cLISTOPo->op_first->op_sibling;
6141 if (!kid || !kid->op_sibling)
6142 return too_few_arguments(o,OP_DESC(o));
6143 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6144 mod(kid, OP_GREPSTART);
6150 Perl_ck_index(pTHX_ OP *o)
6152 if (o->op_flags & OPf_KIDS) {
6153 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6155 kid = kid->op_sibling; /* get past "big" */
6156 if (kid && kid->op_type == OP_CONST)
6157 fbm_compile(((SVOP*)kid)->op_sv, 0);
6163 Perl_ck_lengthconst(pTHX_ OP *o)
6165 /* XXX length optimization goes here */
6170 Perl_ck_lfun(pTHX_ OP *o)
6172 OPCODE type = o->op_type;
6173 return modkids(ck_fun(o), type);
6177 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6179 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6180 switch (cUNOPo->op_first->op_type) {
6182 /* This is needed for
6183 if (defined %stash::)
6184 to work. Do not break Tk.
6186 break; /* Globals via GV can be undef */
6188 case OP_AASSIGN: /* Is this a good idea? */
6189 Perl_warner(aTHX_ WARN_DEPRECATED,
6190 "defined(@array) is deprecated");
6191 Perl_warner(aTHX_ WARN_DEPRECATED,
6192 "\t(Maybe you should just omit the defined()?)\n");
6195 /* This is needed for
6196 if (defined %stash::)
6197 to work. Do not break Tk.
6199 break; /* Globals via GV can be undef */
6201 Perl_warner(aTHX_ WARN_DEPRECATED,
6202 "defined(%%hash) is deprecated");
6203 Perl_warner(aTHX_ WARN_DEPRECATED,
6204 "\t(Maybe you should just omit the defined()?)\n");
6215 Perl_ck_rfun(pTHX_ OP *o)
6217 OPCODE type = o->op_type;
6218 return refkids(ck_fun(o), type);
6222 Perl_ck_listiob(pTHX_ OP *o)
6226 kid = cLISTOPo->op_first;
6229 kid = cLISTOPo->op_first;
6231 if (kid->op_type == OP_PUSHMARK)
6232 kid = kid->op_sibling;
6233 if (kid && o->op_flags & OPf_STACKED)
6234 kid = kid->op_sibling;
6235 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6236 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6237 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6238 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6239 cLISTOPo->op_first->op_sibling = kid;
6240 cLISTOPo->op_last = kid;
6241 kid = kid->op_sibling;
6246 append_elem(o->op_type, o, newDEFSVOP());
6252 Perl_ck_sassign(pTHX_ OP *o)
6254 OP *kid = cLISTOPo->op_first;
6255 /* has a disposable target? */
6256 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6257 && !(kid->op_flags & OPf_STACKED)
6258 /* Cannot steal the second time! */
6259 && !(kid->op_private & OPpTARGET_MY))
6261 OP *kkid = kid->op_sibling;
6263 /* Can just relocate the target. */
6264 if (kkid && kkid->op_type == OP_PADSV
6265 && !(kkid->op_private & OPpLVAL_INTRO))
6267 kid->op_targ = kkid->op_targ;
6269 /* Now we do not need PADSV and SASSIGN. */
6270 kid->op_sibling = o->op_sibling; /* NULL */
6271 cLISTOPo->op_first = NULL;
6274 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6282 Perl_ck_match(pTHX_ OP *o)
6284 o->op_private |= OPpRUNTIME;
6289 Perl_ck_method(pTHX_ OP *o)
6291 OP *kid = cUNOPo->op_first;
6292 if (kid->op_type == OP_CONST) {
6293 SV* sv = kSVOP->op_sv;
6294 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6296 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6297 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6300 kSVOP->op_sv = Nullsv;
6302 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6311 Perl_ck_null(pTHX_ OP *o)
6317 Perl_ck_open(pTHX_ OP *o)
6319 HV *table = GvHV(PL_hintgv);
6323 svp = hv_fetch(table, "open_IN", 7, FALSE);
6325 mode = mode_from_discipline(*svp);
6326 if (mode & O_BINARY)
6327 o->op_private |= OPpOPEN_IN_RAW;
6328 else if (mode & O_TEXT)
6329 o->op_private |= OPpOPEN_IN_CRLF;
6332 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6334 mode = mode_from_discipline(*svp);
6335 if (mode & O_BINARY)
6336 o->op_private |= OPpOPEN_OUT_RAW;
6337 else if (mode & O_TEXT)
6338 o->op_private |= OPpOPEN_OUT_CRLF;
6341 if (o->op_type == OP_BACKTICK)
6347 Perl_ck_repeat(pTHX_ OP *o)
6349 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6350 o->op_private |= OPpREPEAT_DOLIST;
6351 cBINOPo->op_first = force_list(cBINOPo->op_first);
6359 Perl_ck_require(pTHX_ OP *o)
6363 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6364 SVOP *kid = (SVOP*)cUNOPo->op_first;
6366 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6368 for (s = SvPVX(kid->op_sv); *s; s++) {
6369 if (*s == ':' && s[1] == ':') {
6371 Move(s+2, s+1, strlen(s+2)+1, char);
6372 --SvCUR(kid->op_sv);
6375 if (SvREADONLY(kid->op_sv)) {
6376 SvREADONLY_off(kid->op_sv);
6377 sv_catpvn(kid->op_sv, ".pm", 3);
6378 SvREADONLY_on(kid->op_sv);
6381 sv_catpvn(kid->op_sv, ".pm", 3);
6385 /* handle override, if any */
6386 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6387 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6388 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6390 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6391 OP *kid = cUNOPo->op_first;
6392 cUNOPo->op_first = 0;
6394 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6395 append_elem(OP_LIST, kid,
6396 scalar(newUNOP(OP_RV2CV, 0,
6405 Perl_ck_return(pTHX_ OP *o)
6408 if (CvLVALUE(PL_compcv)) {
6409 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6410 mod(kid, OP_LEAVESUBLV);
6417 Perl_ck_retarget(pTHX_ OP *o)
6419 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6426 Perl_ck_select(pTHX_ OP *o)
6429 if (o->op_flags & OPf_KIDS) {
6430 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6431 if (kid && kid->op_sibling) {
6432 o->op_type = OP_SSELECT;
6433 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6435 return fold_constants(o);
6439 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6440 if (kid && kid->op_type == OP_RV2GV)
6441 kid->op_private &= ~HINT_STRICT_REFS;
6446 Perl_ck_shift(pTHX_ OP *o)
6448 I32 type = o->op_type;
6450 if (!(o->op_flags & OPf_KIDS)) {
6454 #ifdef USE_5005THREADS
6455 if (!CvUNIQUE(PL_compcv)) {
6456 argop = newOP(OP_PADAV, OPf_REF);
6457 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6460 argop = newUNOP(OP_RV2AV, 0,
6461 scalar(newGVOP(OP_GV, 0,
6462 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6465 argop = newUNOP(OP_RV2AV, 0,
6466 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6467 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6468 #endif /* USE_5005THREADS */
6469 return newUNOP(type, 0, scalar(argop));
6471 return scalar(modkids(ck_fun(o), type));
6475 Perl_ck_sort(pTHX_ OP *o)
6479 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6481 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6482 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6484 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6486 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6488 if (kid->op_type == OP_SCOPE) {
6492 else if (kid->op_type == OP_LEAVE) {
6493 if (o->op_type == OP_SORT) {
6494 op_null(kid); /* wipe out leave */
6497 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6498 if (k->op_next == kid)
6500 /* don't descend into loops */
6501 else if (k->op_type == OP_ENTERLOOP
6502 || k->op_type == OP_ENTERITER)
6504 k = cLOOPx(k)->op_lastop;
6509 kid->op_next = 0; /* just disconnect the leave */
6510 k = kLISTOP->op_first;
6515 if (o->op_type == OP_SORT) {
6516 /* provide scalar context for comparison function/block */
6522 o->op_flags |= OPf_SPECIAL;
6524 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6527 firstkid = firstkid->op_sibling;
6530 /* provide list context for arguments */
6531 if (o->op_type == OP_SORT)
6538 S_simplify_sort(pTHX_ OP *o)
6540 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6544 if (!(o->op_flags & OPf_STACKED))
6546 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6547 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6548 kid = kUNOP->op_first; /* get past null */
6549 if (kid->op_type != OP_SCOPE)
6551 kid = kLISTOP->op_last; /* get past scope */
6552 switch(kid->op_type) {
6560 k = kid; /* remember this node*/
6561 if (kBINOP->op_first->op_type != OP_RV2SV)
6563 kid = kBINOP->op_first; /* get past cmp */
6564 if (kUNOP->op_first->op_type != OP_GV)
6566 kid = kUNOP->op_first; /* get past rv2sv */
6568 if (GvSTASH(gv) != PL_curstash)
6570 if (strEQ(GvNAME(gv), "a"))
6572 else if (strEQ(GvNAME(gv), "b"))
6576 kid = k; /* back to cmp */
6577 if (kBINOP->op_last->op_type != OP_RV2SV)
6579 kid = kBINOP->op_last; /* down to 2nd arg */
6580 if (kUNOP->op_first->op_type != OP_GV)
6582 kid = kUNOP->op_first; /* get past rv2sv */
6584 if (GvSTASH(gv) != PL_curstash
6586 ? strNE(GvNAME(gv), "a")
6587 : strNE(GvNAME(gv), "b")))
6589 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6591 o->op_private |= OPpSORT_REVERSE;
6592 if (k->op_type == OP_NCMP)
6593 o->op_private |= OPpSORT_NUMERIC;
6594 if (k->op_type == OP_I_NCMP)
6595 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6596 kid = cLISTOPo->op_first->op_sibling;
6597 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6598 op_free(kid); /* then delete it */
6602 Perl_ck_split(pTHX_ OP *o)
6606 if (o->op_flags & OPf_STACKED)
6607 return no_fh_allowed(o);
6609 kid = cLISTOPo->op_first;
6610 if (kid->op_type != OP_NULL)
6611 Perl_croak(aTHX_ "panic: ck_split");
6612 kid = kid->op_sibling;
6613 op_free(cLISTOPo->op_first);
6614 cLISTOPo->op_first = kid;
6616 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6617 cLISTOPo->op_last = kid; /* There was only one element previously */
6620 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6621 OP *sibl = kid->op_sibling;
6622 kid->op_sibling = 0;
6623 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6624 if (cLISTOPo->op_first == cLISTOPo->op_last)
6625 cLISTOPo->op_last = kid;
6626 cLISTOPo->op_first = kid;
6627 kid->op_sibling = sibl;
6630 kid->op_type = OP_PUSHRE;
6631 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6634 if (!kid->op_sibling)
6635 append_elem(OP_SPLIT, o, newDEFSVOP());
6637 kid = kid->op_sibling;
6640 if (!kid->op_sibling)
6641 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6643 kid = kid->op_sibling;
6646 if (kid->op_sibling)
6647 return too_many_arguments(o,OP_DESC(o));
6653 Perl_ck_join(pTHX_ OP *o)
6655 if (ckWARN(WARN_SYNTAX)) {
6656 OP *kid = cLISTOPo->op_first->op_sibling;
6657 if (kid && kid->op_type == OP_MATCH) {
6658 char *pmstr = "STRING";
6659 if (PM_GETRE(kPMOP))
6660 pmstr = PM_GETRE(kPMOP)->precomp;
6661 Perl_warner(aTHX_ WARN_SYNTAX,
6662 "/%s/ should probably be written as \"%s\"",
6670 Perl_ck_subr(pTHX_ OP *o)
6672 OP *prev = ((cUNOPo->op_first->op_sibling)
6673 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6674 OP *o2 = prev->op_sibling;
6681 I32 contextclass = 0;
6685 o->op_private |= OPpENTERSUB_HASTARG;
6686 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6687 if (cvop->op_type == OP_RV2CV) {
6689 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6690 op_null(cvop); /* disable rv2cv */
6691 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6692 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6693 GV *gv = cGVOPx_gv(tmpop);
6696 tmpop->op_private |= OPpEARLY_CV;
6697 else if (SvPOK(cv)) {
6698 namegv = CvANON(cv) ? gv : CvGV(cv);
6699 proto = SvPV((SV*)cv, n_a);
6703 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6704 if (o2->op_type == OP_CONST)
6705 o2->op_private &= ~OPpCONST_STRICT;
6706 else if (o2->op_type == OP_LIST) {
6707 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6708 if (o && o->op_type == OP_CONST)
6709 o->op_private &= ~OPpCONST_STRICT;
6712 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6713 if (PERLDB_SUB && PL_curstash != PL_debstash)
6714 o->op_private |= OPpENTERSUB_DB;
6715 while (o2 != cvop) {
6719 return too_many_arguments(o, gv_ename(namegv));
6737 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6739 arg == 1 ? "block or sub {}" : "sub {}",
6740 gv_ename(namegv), o2);
6743 /* '*' allows any scalar type, including bareword */
6746 if (o2->op_type == OP_RV2GV)
6747 goto wrapref; /* autoconvert GLOB -> GLOBref */
6748 else if (o2->op_type == OP_CONST)
6749 o2->op_private &= ~OPpCONST_STRICT;
6750 else if (o2->op_type == OP_ENTERSUB) {
6751 /* accidental subroutine, revert to bareword */
6752 OP *gvop = ((UNOP*)o2)->op_first;
6753 if (gvop && gvop->op_type == OP_NULL) {
6754 gvop = ((UNOP*)gvop)->op_first;
6756 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6759 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6760 (gvop = ((UNOP*)gvop)->op_first) &&
6761 gvop->op_type == OP_GV)
6763 GV *gv = cGVOPx_gv(gvop);
6764 OP *sibling = o2->op_sibling;
6765 SV *n = newSVpvn("",0);
6767 gv_fullname3(n, gv, "");
6768 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6769 sv_chop(n, SvPVX(n)+6);
6770 o2 = newSVOP(OP_CONST, 0, n);
6771 prev->op_sibling = o2;
6772 o2->op_sibling = sibling;
6788 if (contextclass++ == 0) {
6789 e = strchr(proto, ']');
6790 if (!e || e == proto)
6803 while (*--p != '[');
6804 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6805 gv_ename(namegv), o2);
6811 if (o2->op_type == OP_RV2GV)
6814 bad_type(arg, "symbol", gv_ename(namegv), o2);
6817 if (o2->op_type == OP_ENTERSUB)
6820 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6823 if (o2->op_type == OP_RV2SV ||
6824 o2->op_type == OP_PADSV ||
6825 o2->op_type == OP_HELEM ||
6826 o2->op_type == OP_AELEM ||
6827 o2->op_type == OP_THREADSV)
6830 bad_type(arg, "scalar", gv_ename(namegv), o2);
6833 if (o2->op_type == OP_RV2AV ||
6834 o2->op_type == OP_PADAV)
6837 bad_type(arg, "array", gv_ename(namegv), o2);
6840 if (o2->op_type == OP_RV2HV ||
6841 o2->op_type == OP_PADHV)
6844 bad_type(arg, "hash", gv_ename(namegv), o2);
6849 OP* sib = kid->op_sibling;
6850 kid->op_sibling = 0;
6851 o2 = newUNOP(OP_REFGEN, 0, kid);
6852 o2->op_sibling = sib;
6853 prev->op_sibling = o2;
6855 if (contextclass && e) {
6870 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6871 gv_ename(namegv), SvPV((SV*)cv, n_a));
6876 mod(o2, OP_ENTERSUB);
6878 o2 = o2->op_sibling;
6880 if (proto && !optional &&
6881 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6882 return too_few_arguments(o, gv_ename(namegv));
6887 Perl_ck_svconst(pTHX_ OP *o)
6889 SvREADONLY_on(cSVOPo->op_sv);
6894 Perl_ck_trunc(pTHX_ OP *o)
6896 if (o->op_flags & OPf_KIDS) {
6897 SVOP *kid = (SVOP*)cUNOPo->op_first;
6899 if (kid->op_type == OP_NULL)
6900 kid = (SVOP*)kid->op_sibling;
6901 if (kid && kid->op_type == OP_CONST &&
6902 (kid->op_private & OPpCONST_BARE))
6904 o->op_flags |= OPf_SPECIAL;
6905 kid->op_private &= ~OPpCONST_STRICT;
6912 Perl_ck_substr(pTHX_ OP *o)
6915 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6916 OP *kid = cLISTOPo->op_first;
6918 if (kid->op_type == OP_NULL)
6919 kid = kid->op_sibling;
6921 kid->op_flags |= OPf_MOD;
6927 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6930 Perl_peep(pTHX_ register OP *o)
6932 register OP* oldop = 0;
6935 if (!o || o->op_seq)
6939 SAVEVPTR(PL_curcop);
6940 for (; o; o = o->op_next) {
6946 switch (o->op_type) {
6950 PL_curcop = ((COP*)o); /* for warnings */
6951 o->op_seq = PL_op_seqmax++;
6955 if (cSVOPo->op_private & OPpCONST_STRICT)
6956 no_bareword_allowed(o);
6958 /* Relocate sv to the pad for thread safety.
6959 * Despite being a "constant", the SV is written to,
6960 * for reference counts, sv_upgrade() etc. */
6962 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6963 if (SvPADTMP(cSVOPo->op_sv)) {
6964 /* If op_sv is already a PADTMP then it is being used by
6965 * some pad, so make a copy. */
6966 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6967 SvREADONLY_on(PL_curpad[ix]);
6968 SvREFCNT_dec(cSVOPo->op_sv);
6971 SvREFCNT_dec(PL_curpad[ix]);
6972 SvPADTMP_on(cSVOPo->op_sv);
6973 PL_curpad[ix] = cSVOPo->op_sv;
6974 /* XXX I don't know how this isn't readonly already. */
6975 SvREADONLY_on(PL_curpad[ix]);
6977 cSVOPo->op_sv = Nullsv;
6981 o->op_seq = PL_op_seqmax++;
6985 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6986 if (o->op_next->op_private & OPpTARGET_MY) {
6987 if (o->op_flags & OPf_STACKED) /* chained concats */
6988 goto ignore_optimization;
6990 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6991 o->op_targ = o->op_next->op_targ;
6992 o->op_next->op_targ = 0;
6993 o->op_private |= OPpTARGET_MY;
6996 op_null(o->op_next);
6998 ignore_optimization:
6999 o->op_seq = PL_op_seqmax++;
7002 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7003 o->op_seq = PL_op_seqmax++;
7004 break; /* Scalar stub must produce undef. List stub is noop */
7008 if (o->op_targ == OP_NEXTSTATE
7009 || o->op_targ == OP_DBSTATE
7010 || o->op_targ == OP_SETSTATE)
7012 PL_curcop = ((COP*)o);
7014 /* XXX: We avoid setting op_seq here to prevent later calls
7015 to peep() from mistakenly concluding that optimisation
7016 has already occurred. This doesn't fix the real problem,
7017 though (See 20010220.007). AMS 20010719 */
7018 if (oldop && o->op_next) {
7019 oldop->op_next = o->op_next;
7027 if (oldop && o->op_next) {
7028 oldop->op_next = o->op_next;
7031 o->op_seq = PL_op_seqmax++;
7035 if (o->op_next->op_type == OP_RV2SV) {
7036 if (!(o->op_next->op_private & OPpDEREF)) {
7037 op_null(o->op_next);
7038 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7040 o->op_next = o->op_next->op_next;
7041 o->op_type = OP_GVSV;
7042 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7045 else if (o->op_next->op_type == OP_RV2AV) {
7046 OP* pop = o->op_next->op_next;
7048 if (pop && pop->op_type == OP_CONST &&
7049 (PL_op = pop->op_next) &&
7050 pop->op_next->op_type == OP_AELEM &&
7051 !(pop->op_next->op_private &
7052 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7053 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7058 op_null(o->op_next);
7059 op_null(pop->op_next);
7061 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7062 o->op_next = pop->op_next->op_next;
7063 o->op_type = OP_AELEMFAST;
7064 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7065 o->op_private = (U8)i;
7070 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7072 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7073 /* XXX could check prototype here instead of just carping */
7074 SV *sv = sv_newmortal();
7075 gv_efullname3(sv, gv, Nullch);
7076 Perl_warner(aTHX_ WARN_PROTOTYPE,
7077 "%s() called too early to check prototype",
7081 else if (o->op_next->op_type == OP_READLINE
7082 && o->op_next->op_next->op_type == OP_CONCAT
7083 && (o->op_next->op_next->op_flags & OPf_STACKED))
7085 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7086 o->op_type = OP_RCATLINE;
7087 o->op_flags |= OPf_STACKED;
7088 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7089 op_null(o->op_next->op_next);
7090 op_null(o->op_next);
7093 o->op_seq = PL_op_seqmax++;
7104 o->op_seq = PL_op_seqmax++;
7105 while (cLOGOP->op_other->op_type == OP_NULL)
7106 cLOGOP->op_other = cLOGOP->op_other->op_next;
7107 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7112 o->op_seq = PL_op_seqmax++;
7113 while (cLOOP->op_redoop->op_type == OP_NULL)
7114 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7115 peep(cLOOP->op_redoop);
7116 while (cLOOP->op_nextop->op_type == OP_NULL)
7117 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7118 peep(cLOOP->op_nextop);
7119 while (cLOOP->op_lastop->op_type == OP_NULL)
7120 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7121 peep(cLOOP->op_lastop);
7127 o->op_seq = PL_op_seqmax++;
7128 while (cPMOP->op_pmreplstart &&
7129 cPMOP->op_pmreplstart->op_type == OP_NULL)
7130 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7131 peep(cPMOP->op_pmreplstart);
7135 o->op_seq = PL_op_seqmax++;
7136 if (ckWARN(WARN_SYNTAX) && o->op_next
7137 && o->op_next->op_type == OP_NEXTSTATE) {
7138 if (o->op_next->op_sibling &&
7139 o->op_next->op_sibling->op_type != OP_EXIT &&
7140 o->op_next->op_sibling->op_type != OP_WARN &&
7141 o->op_next->op_sibling->op_type != OP_DIE) {
7142 line_t oldline = CopLINE(PL_curcop);
7144 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7145 Perl_warner(aTHX_ WARN_EXEC,
7146 "Statement unlikely to be reached");
7147 Perl_warner(aTHX_ WARN_EXEC,
7148 "\t(Maybe you meant system() when you said exec()?)\n");
7149 CopLINE_set(PL_curcop, oldline);
7158 SV **svp, **indsvp, *sv;
7163 o->op_seq = PL_op_seqmax++;
7165 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7168 /* Make the CONST have a shared SV */
7169 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7170 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7171 key = SvPV(sv, keylen);
7172 lexname = newSVpvn_share(key,
7173 SvUTF8(sv) ? -(I32)keylen : keylen,
7179 if ((o->op_private & (OPpLVAL_INTRO)))
7182 rop = (UNOP*)((BINOP*)o)->op_first;
7183 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7185 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7186 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7188 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7189 if (!fields || !GvHV(*fields))
7191 key = SvPV(*svp, keylen);
7192 indsvp = hv_fetch(GvHV(*fields), key,
7193 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7195 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7196 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7198 ind = SvIV(*indsvp);
7200 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7201 rop->op_type = OP_RV2AV;
7202 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7203 o->op_type = OP_AELEM;
7204 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7206 if (SvREADONLY(*svp))
7208 SvFLAGS(sv) |= (SvFLAGS(*svp)
7209 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7219 SV **svp, **indsvp, *sv;
7223 SVOP *first_key_op, *key_op;
7225 o->op_seq = PL_op_seqmax++;
7226 if ((o->op_private & (OPpLVAL_INTRO))
7227 /* I bet there's always a pushmark... */
7228 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7229 /* hmmm, no optimization if list contains only one key. */
7231 rop = (UNOP*)((LISTOP*)o)->op_last;
7232 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7234 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7235 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7237 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7238 if (!fields || !GvHV(*fields))
7240 /* Again guessing that the pushmark can be jumped over.... */
7241 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7242 ->op_first->op_sibling;
7243 /* Check that the key list contains only constants. */
7244 for (key_op = first_key_op; key_op;
7245 key_op = (SVOP*)key_op->op_sibling)
7246 if (key_op->op_type != OP_CONST)
7250 rop->op_type = OP_RV2AV;
7251 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7252 o->op_type = OP_ASLICE;
7253 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7254 for (key_op = first_key_op; key_op;
7255 key_op = (SVOP*)key_op->op_sibling) {
7256 svp = cSVOPx_svp(key_op);
7257 key = SvPV(*svp, keylen);
7258 indsvp = hv_fetch(GvHV(*fields), key,
7259 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7261 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7262 "in variable %s of type %s",
7263 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7265 ind = SvIV(*indsvp);
7267 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7269 if (SvREADONLY(*svp))
7271 SvFLAGS(sv) |= (SvFLAGS(*svp)
7272 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7280 o->op_seq = PL_op_seqmax++;
7290 char* Perl_custom_op_name(pTHX_ OP* o)
7292 IV index = PTR2IV(o->op_ppaddr);
7296 if (!PL_custom_op_names) /* This probably shouldn't happen */
7297 return PL_op_name[OP_CUSTOM];
7299 keysv = sv_2mortal(newSViv(index));
7301 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7303 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7305 return SvPV_nolen(HeVAL(he));
7308 char* Perl_custom_op_desc(pTHX_ OP* o)
7310 IV index = PTR2IV(o->op_ppaddr);
7314 if (!PL_custom_op_descs)
7315 return PL_op_desc[OP_CUSTOM];
7317 keysv = sv_2mortal(newSViv(index));
7319 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7321 return PL_op_desc[OP_CUSTOM];
7323 return SvPV_nolen(HeVAL(he));
7329 /* Efficient sub that returns a constant scalar value. */
7331 const_sv_xsub(pTHX_ CV* cv)
7336 Perl_croak(aTHX_ "usage: %s::%s()",
7337 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7341 ST(0) = (SV*)XSANY.any_ptr;