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) ));
3455 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3456 Perl_warner(aTHX_ WARN_MISC,
3457 "Package `%s' not found "
3458 "(did you use the incorrect case?)", packname);
3464 PL_hints |= HINT_BLOCK_SCOPE;
3465 PL_copline = NOLINE;
3470 =head1 Embedding Functions
3472 =for apidoc load_module
3474 Loads the module whose name is pointed to by the string part of name.
3475 Note that the actual module name, not its filename, should be given.
3476 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3477 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3478 (or 0 for no flags). ver, if specified, provides version semantics
3479 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3480 arguments can be used to specify arguments to the module's import()
3481 method, similar to C<use Foo::Bar VERSION LIST>.
3486 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3489 va_start(args, ver);
3490 vload_module(flags, name, ver, &args);
3494 #ifdef PERL_IMPLICIT_CONTEXT
3496 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3500 va_start(args, ver);
3501 vload_module(flags, name, ver, &args);
3507 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3509 OP *modname, *veop, *imop;
3511 modname = newSVOP(OP_CONST, 0, name);
3512 modname->op_private |= OPpCONST_BARE;
3514 veop = newSVOP(OP_CONST, 0, ver);
3518 if (flags & PERL_LOADMOD_NOIMPORT) {
3519 imop = sawparens(newNULLLIST());
3521 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3522 imop = va_arg(*args, OP*);
3527 sv = va_arg(*args, SV*);
3529 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3530 sv = va_arg(*args, SV*);
3534 line_t ocopline = PL_copline;
3535 int oexpect = PL_expect;
3537 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3538 veop, modname, imop);
3539 PL_expect = oexpect;
3540 PL_copline = ocopline;
3545 Perl_dofile(pTHX_ OP *term)
3550 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3551 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3552 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3554 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3555 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3556 append_elem(OP_LIST, term,
3557 scalar(newUNOP(OP_RV2CV, 0,
3562 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3568 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3570 return newBINOP(OP_LSLICE, flags,
3571 list(force_list(subscript)),
3572 list(force_list(listval)) );
3576 S_list_assignment(pTHX_ register OP *o)
3581 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3582 o = cUNOPo->op_first;
3584 if (o->op_type == OP_COND_EXPR) {
3585 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3586 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3591 yyerror("Assignment to both a list and a scalar");
3595 if (o->op_type == OP_LIST &&
3596 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3597 o->op_private & OPpLVAL_INTRO)
3600 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3601 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3602 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3605 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3608 if (o->op_type == OP_RV2SV)
3615 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3620 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3621 return newLOGOP(optype, 0,
3622 mod(scalar(left), optype),
3623 newUNOP(OP_SASSIGN, 0, scalar(right)));
3626 return newBINOP(optype, OPf_STACKED,
3627 mod(scalar(left), optype), scalar(right));
3631 if (list_assignment(left)) {
3635 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3636 left = mod(left, OP_AASSIGN);
3644 curop = list(force_list(left));
3645 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3646 o->op_private = 0 | (flags >> 8);
3647 for (curop = ((LISTOP*)curop)->op_first;
3648 curop; curop = curop->op_sibling)
3650 if (curop->op_type == OP_RV2HV &&
3651 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3652 o->op_private |= OPpASSIGN_HASH;
3656 if (!(left->op_private & OPpLVAL_INTRO)) {
3659 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3660 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3661 if (curop->op_type == OP_GV) {
3662 GV *gv = cGVOPx_gv(curop);
3663 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3665 SvCUR(gv) = PL_generation;
3667 else if (curop->op_type == OP_PADSV ||
3668 curop->op_type == OP_PADAV ||
3669 curop->op_type == OP_PADHV ||
3670 curop->op_type == OP_PADANY) {
3671 SV **svp = AvARRAY(PL_comppad_name);
3672 SV *sv = svp[curop->op_targ];
3673 if (SvCUR(sv) == PL_generation)
3675 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3677 else if (curop->op_type == OP_RV2CV)
3679 else if (curop->op_type == OP_RV2SV ||
3680 curop->op_type == OP_RV2AV ||
3681 curop->op_type == OP_RV2HV ||
3682 curop->op_type == OP_RV2GV) {
3683 if (lastop->op_type != OP_GV) /* funny deref? */
3686 else if (curop->op_type == OP_PUSHRE) {
3687 if (((PMOP*)curop)->op_pmreplroot) {
3689 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3691 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3693 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3695 SvCUR(gv) = PL_generation;
3704 o->op_private |= OPpASSIGN_COMMON;
3706 if (right && right->op_type == OP_SPLIT) {
3708 if ((tmpop = ((LISTOP*)right)->op_first) &&
3709 tmpop->op_type == OP_PUSHRE)
3711 PMOP *pm = (PMOP*)tmpop;
3712 if (left->op_type == OP_RV2AV &&
3713 !(left->op_private & OPpLVAL_INTRO) &&
3714 !(o->op_private & OPpASSIGN_COMMON) )
3716 tmpop = ((UNOP*)left)->op_first;
3717 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3719 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3720 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3722 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3723 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3725 pm->op_pmflags |= PMf_ONCE;
3726 tmpop = cUNOPo->op_first; /* to list (nulled) */
3727 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3728 tmpop->op_sibling = Nullop; /* don't free split */
3729 right->op_next = tmpop->op_next; /* fix starting loc */
3730 op_free(o); /* blow off assign */
3731 right->op_flags &= ~OPf_WANT;
3732 /* "I don't know and I don't care." */
3737 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3738 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3740 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3742 sv_setiv(sv, PL_modcount+1);
3750 right = newOP(OP_UNDEF, 0);
3751 if (right->op_type == OP_READLINE) {
3752 right->op_flags |= OPf_STACKED;
3753 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3756 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3757 o = newBINOP(OP_SASSIGN, flags,
3758 scalar(right), mod(scalar(left), OP_SASSIGN) );
3770 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3772 U32 seq = intro_my();
3775 NewOp(1101, cop, 1, COP);
3776 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3777 cop->op_type = OP_DBSTATE;
3778 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3781 cop->op_type = OP_NEXTSTATE;
3782 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3784 cop->op_flags = flags;
3785 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3787 cop->op_private |= NATIVE_HINTS;
3789 PL_compiling.op_private = cop->op_private;
3790 cop->op_next = (OP*)cop;
3793 cop->cop_label = label;
3794 PL_hints |= HINT_BLOCK_SCOPE;
3797 cop->cop_arybase = PL_curcop->cop_arybase;
3798 if (specialWARN(PL_curcop->cop_warnings))
3799 cop->cop_warnings = PL_curcop->cop_warnings ;
3801 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3802 if (specialCopIO(PL_curcop->cop_io))
3803 cop->cop_io = PL_curcop->cop_io;
3805 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3808 if (PL_copline == NOLINE)
3809 CopLINE_set(cop, CopLINE(PL_curcop));
3811 CopLINE_set(cop, PL_copline);
3812 PL_copline = NOLINE;
3815 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3817 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3819 CopSTASH_set(cop, PL_curstash);
3821 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3822 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3823 if (svp && *svp != &PL_sv_undef ) {
3824 (void)SvIOK_on(*svp);
3825 SvIVX(*svp) = PTR2IV(cop);
3829 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3832 /* "Introduce" my variables to visible status. */
3840 if (! PL_min_intro_pending)
3841 return PL_cop_seqmax;
3843 svp = AvARRAY(PL_comppad_name);
3844 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3845 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3846 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3847 SvNVX(sv) = (NV)PL_cop_seqmax;
3850 PL_min_intro_pending = 0;
3851 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3852 return PL_cop_seqmax++;
3856 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3858 return new_logop(type, flags, &first, &other);
3862 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3866 OP *first = *firstp;
3867 OP *other = *otherp;
3869 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3870 return newBINOP(type, flags, scalar(first), scalar(other));
3872 scalarboolean(first);
3873 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3874 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3875 if (type == OP_AND || type == OP_OR) {
3881 first = *firstp = cUNOPo->op_first;
3883 first->op_next = o->op_next;
3884 cUNOPo->op_first = Nullop;
3888 if (first->op_type == OP_CONST) {
3889 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3890 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3891 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3902 else if (first->op_type == OP_WANTARRAY) {
3908 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3909 OP *k1 = ((UNOP*)first)->op_first;
3910 OP *k2 = k1->op_sibling;
3912 switch (first->op_type)
3915 if (k2 && k2->op_type == OP_READLINE
3916 && (k2->op_flags & OPf_STACKED)
3917 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3919 warnop = k2->op_type;
3924 if (k1->op_type == OP_READDIR
3925 || k1->op_type == OP_GLOB
3926 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3927 || k1->op_type == OP_EACH)
3929 warnop = ((k1->op_type == OP_NULL)
3930 ? k1->op_targ : k1->op_type);
3935 line_t oldline = CopLINE(PL_curcop);
3936 CopLINE_set(PL_curcop, PL_copline);
3937 Perl_warner(aTHX_ WARN_MISC,
3938 "Value of %s%s can be \"0\"; test with defined()",
3940 ((warnop == OP_READLINE || warnop == OP_GLOB)
3941 ? " construct" : "() operator"));
3942 CopLINE_set(PL_curcop, oldline);
3949 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3950 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3952 NewOp(1101, logop, 1, LOGOP);
3954 logop->op_type = type;
3955 logop->op_ppaddr = PL_ppaddr[type];
3956 logop->op_first = first;
3957 logop->op_flags = flags | OPf_KIDS;
3958 logop->op_other = LINKLIST(other);
3959 logop->op_private = 1 | (flags >> 8);
3961 /* establish postfix order */
3962 logop->op_next = LINKLIST(first);
3963 first->op_next = (OP*)logop;
3964 first->op_sibling = other;
3966 o = newUNOP(OP_NULL, 0, (OP*)logop);
3973 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3980 return newLOGOP(OP_AND, 0, first, trueop);
3982 return newLOGOP(OP_OR, 0, first, falseop);
3984 scalarboolean(first);
3985 if (first->op_type == OP_CONST) {
3986 if (SvTRUE(((SVOP*)first)->op_sv)) {
3997 else if (first->op_type == OP_WANTARRAY) {
4001 NewOp(1101, logop, 1, LOGOP);
4002 logop->op_type = OP_COND_EXPR;
4003 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4004 logop->op_first = first;
4005 logop->op_flags = flags | OPf_KIDS;
4006 logop->op_private = 1 | (flags >> 8);
4007 logop->op_other = LINKLIST(trueop);
4008 logop->op_next = LINKLIST(falseop);
4011 /* establish postfix order */
4012 start = LINKLIST(first);
4013 first->op_next = (OP*)logop;
4015 first->op_sibling = trueop;
4016 trueop->op_sibling = falseop;
4017 o = newUNOP(OP_NULL, 0, (OP*)logop);
4019 trueop->op_next = falseop->op_next = o;
4026 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4034 NewOp(1101, range, 1, LOGOP);
4036 range->op_type = OP_RANGE;
4037 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4038 range->op_first = left;
4039 range->op_flags = OPf_KIDS;
4040 leftstart = LINKLIST(left);
4041 range->op_other = LINKLIST(right);
4042 range->op_private = 1 | (flags >> 8);
4044 left->op_sibling = right;
4046 range->op_next = (OP*)range;
4047 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4048 flop = newUNOP(OP_FLOP, 0, flip);
4049 o = newUNOP(OP_NULL, 0, flop);
4051 range->op_next = leftstart;
4053 left->op_next = flip;
4054 right->op_next = flop;
4056 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4057 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4058 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4059 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4061 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4062 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4065 if (!flip->op_private || !flop->op_private)
4066 linklist(o); /* blow off optimizer unless constant */
4072 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4076 int once = block && block->op_flags & OPf_SPECIAL &&
4077 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4080 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4081 return block; /* do {} while 0 does once */
4082 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4083 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4084 expr = newUNOP(OP_DEFINED, 0,
4085 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4086 } else if (expr->op_flags & OPf_KIDS) {
4087 OP *k1 = ((UNOP*)expr)->op_first;
4088 OP *k2 = (k1) ? k1->op_sibling : NULL;
4089 switch (expr->op_type) {
4091 if (k2 && k2->op_type == OP_READLINE
4092 && (k2->op_flags & OPf_STACKED)
4093 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4094 expr = newUNOP(OP_DEFINED, 0, expr);
4098 if (k1->op_type == OP_READDIR
4099 || k1->op_type == OP_GLOB
4100 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4101 || k1->op_type == OP_EACH)
4102 expr = newUNOP(OP_DEFINED, 0, expr);
4108 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4109 o = new_logop(OP_AND, 0, &expr, &listop);
4112 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4114 if (once && o != listop)
4115 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4118 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4120 o->op_flags |= flags;
4122 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4127 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4135 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4136 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4137 expr = newUNOP(OP_DEFINED, 0,
4138 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4139 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4140 OP *k1 = ((UNOP*)expr)->op_first;
4141 OP *k2 = (k1) ? k1->op_sibling : NULL;
4142 switch (expr->op_type) {
4144 if (k2 && k2->op_type == OP_READLINE
4145 && (k2->op_flags & OPf_STACKED)
4146 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4147 expr = newUNOP(OP_DEFINED, 0, expr);
4151 if (k1->op_type == OP_READDIR
4152 || k1->op_type == OP_GLOB
4153 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4154 || k1->op_type == OP_EACH)
4155 expr = newUNOP(OP_DEFINED, 0, expr);
4161 block = newOP(OP_NULL, 0);
4163 block = scope(block);
4167 next = LINKLIST(cont);
4170 OP *unstack = newOP(OP_UNSTACK, 0);
4173 cont = append_elem(OP_LINESEQ, cont, unstack);
4174 if ((line_t)whileline != NOLINE) {
4175 PL_copline = whileline;
4176 cont = append_elem(OP_LINESEQ, cont,
4177 newSTATEOP(0, Nullch, Nullop));
4181 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4182 redo = LINKLIST(listop);
4185 PL_copline = whileline;
4187 o = new_logop(OP_AND, 0, &expr, &listop);
4188 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4189 op_free(expr); /* oops, it's a while (0) */
4191 return Nullop; /* listop already freed by new_logop */
4194 ((LISTOP*)listop)->op_last->op_next =
4195 (o == listop ? redo : LINKLIST(o));
4201 NewOp(1101,loop,1,LOOP);
4202 loop->op_type = OP_ENTERLOOP;
4203 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4204 loop->op_private = 0;
4205 loop->op_next = (OP*)loop;
4208 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4210 loop->op_redoop = redo;
4211 loop->op_lastop = o;
4212 o->op_private |= loopflags;
4215 loop->op_nextop = next;
4217 loop->op_nextop = o;
4219 o->op_flags |= flags;
4220 o->op_private |= (flags >> 8);
4225 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4233 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4234 sv->op_type = OP_RV2GV;
4235 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4237 else if (sv->op_type == OP_PADSV) { /* private variable */
4238 padoff = sv->op_targ;
4243 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4244 padoff = sv->op_targ;
4246 iterflags |= OPf_SPECIAL;
4251 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4254 #ifdef USE_5005THREADS
4255 padoff = find_threadsv("_");
4256 iterflags |= OPf_SPECIAL;
4258 sv = newGVOP(OP_GV, 0, PL_defgv);
4261 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4262 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4263 iterflags |= OPf_STACKED;
4265 else if (expr->op_type == OP_NULL &&
4266 (expr->op_flags & OPf_KIDS) &&
4267 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4269 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4270 * set the STACKED flag to indicate that these values are to be
4271 * treated as min/max values by 'pp_iterinit'.
4273 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4274 LOGOP* range = (LOGOP*) flip->op_first;
4275 OP* left = range->op_first;
4276 OP* right = left->op_sibling;
4279 range->op_flags &= ~OPf_KIDS;
4280 range->op_first = Nullop;
4282 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4283 listop->op_first->op_next = range->op_next;
4284 left->op_next = range->op_other;
4285 right->op_next = (OP*)listop;
4286 listop->op_next = listop->op_first;
4289 expr = (OP*)(listop);
4291 iterflags |= OPf_STACKED;
4294 expr = mod(force_list(expr), OP_GREPSTART);
4298 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4299 append_elem(OP_LIST, expr, scalar(sv))));
4300 assert(!loop->op_next);
4301 #ifdef PL_OP_SLAB_ALLOC
4304 NewOp(1234,tmp,1,LOOP);
4305 Copy(loop,tmp,1,LOOP);
4310 Renew(loop, 1, LOOP);
4312 loop->op_targ = padoff;
4313 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4314 PL_copline = forline;
4315 return newSTATEOP(0, label, wop);
4319 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4324 if (type != OP_GOTO || label->op_type == OP_CONST) {
4325 /* "last()" means "last" */
4326 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4327 o = newOP(type, OPf_SPECIAL);
4329 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4330 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4336 if (label->op_type == OP_ENTERSUB)
4337 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4338 o = newUNOP(type, OPf_STACKED, label);
4340 PL_hints |= HINT_BLOCK_SCOPE;
4345 Perl_cv_undef(pTHX_ CV *cv)
4347 #ifdef USE_5005THREADS
4349 MUTEX_DESTROY(CvMUTEXP(cv));
4350 Safefree(CvMUTEXP(cv));
4353 #endif /* USE_5005THREADS */
4356 if (CvFILE(cv) && !CvXSUB(cv)) {
4357 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4358 Safefree(CvFILE(cv));
4363 if (!CvXSUB(cv) && CvROOT(cv)) {
4364 #ifdef USE_5005THREADS
4365 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4366 Perl_croak(aTHX_ "Can't undef active subroutine");
4369 Perl_croak(aTHX_ "Can't undef active subroutine");
4370 #endif /* USE_5005THREADS */
4373 SAVEVPTR(PL_curpad);
4376 op_free(CvROOT(cv));
4377 CvROOT(cv) = Nullop;
4380 SvPOK_off((SV*)cv); /* forget prototype */
4382 /* Since closure prototypes have the same lifetime as the containing
4383 * CV, they don't hold a refcount on the outside CV. This avoids
4384 * the refcount loop between the outer CV (which keeps a refcount to
4385 * the closure prototype in the pad entry for pp_anoncode()) and the
4386 * closure prototype, and the ensuing memory leak. --GSAR */
4387 if (!CvANON(cv) || CvCLONED(cv))
4388 SvREFCNT_dec(CvOUTSIDE(cv));
4389 CvOUTSIDE(cv) = Nullcv;
4391 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4394 if (CvPADLIST(cv)) {
4395 /* may be during global destruction */
4396 if (SvREFCNT(CvPADLIST(cv))) {
4397 I32 i = AvFILLp(CvPADLIST(cv));
4399 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4400 SV* sv = svp ? *svp : Nullsv;
4403 if (sv == (SV*)PL_comppad_name)
4404 PL_comppad_name = Nullav;
4405 else if (sv == (SV*)PL_comppad) {
4406 PL_comppad = Nullav;
4407 PL_curpad = Null(SV**);
4411 SvREFCNT_dec((SV*)CvPADLIST(cv));
4413 CvPADLIST(cv) = Nullav;
4421 #ifdef DEBUG_CLOSURES
4423 S_cv_dump(pTHX_ CV *cv)
4426 CV *outside = CvOUTSIDE(cv);
4427 AV* padlist = CvPADLIST(cv);
4434 PerlIO_printf(Perl_debug_log,
4435 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4437 (CvANON(cv) ? "ANON"
4438 : (cv == PL_main_cv) ? "MAIN"
4439 : CvUNIQUE(cv) ? "UNIQUE"
4440 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4443 : CvANON(outside) ? "ANON"
4444 : (outside == PL_main_cv) ? "MAIN"
4445 : CvUNIQUE(outside) ? "UNIQUE"
4446 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4451 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4452 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4453 pname = AvARRAY(pad_name);
4454 ppad = AvARRAY(pad);
4456 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4457 if (SvPOK(pname[ix]))
4458 PerlIO_printf(Perl_debug_log,
4459 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4460 (int)ix, PTR2UV(ppad[ix]),
4461 SvFAKE(pname[ix]) ? "FAKE " : "",
4463 (IV)I_32(SvNVX(pname[ix])),
4466 #endif /* DEBUGGING */
4468 #endif /* DEBUG_CLOSURES */
4471 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4475 AV* protopadlist = CvPADLIST(proto);
4476 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4477 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4478 SV** pname = AvARRAY(protopad_name);
4479 SV** ppad = AvARRAY(protopad);
4480 I32 fname = AvFILLp(protopad_name);
4481 I32 fpad = AvFILLp(protopad);
4485 assert(!CvUNIQUE(proto));
4489 SAVESPTR(PL_comppad_name);
4490 SAVESPTR(PL_compcv);
4492 cv = PL_compcv = (CV*)NEWSV(1104,0);
4493 sv_upgrade((SV *)cv, SvTYPE(proto));
4494 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4497 #ifdef USE_5005THREADS
4498 New(666, CvMUTEXP(cv), 1, perl_mutex);
4499 MUTEX_INIT(CvMUTEXP(cv));
4501 #endif /* USE_5005THREADS */
4503 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4504 : savepv(CvFILE(proto));
4506 CvFILE(cv) = CvFILE(proto);
4508 CvGV(cv) = CvGV(proto);
4509 CvSTASH(cv) = CvSTASH(proto);
4510 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4511 CvSTART(cv) = CvSTART(proto);
4513 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4516 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4518 PL_comppad_name = newAV();
4519 for (ix = fname; ix >= 0; ix--)
4520 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4522 PL_comppad = newAV();
4524 comppadlist = newAV();
4525 AvREAL_off(comppadlist);
4526 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4527 av_store(comppadlist, 1, (SV*)PL_comppad);
4528 CvPADLIST(cv) = comppadlist;
4529 av_fill(PL_comppad, AvFILLp(protopad));
4530 PL_curpad = AvARRAY(PL_comppad);
4532 av = newAV(); /* will be @_ */
4534 av_store(PL_comppad, 0, (SV*)av);
4535 AvFLAGS(av) = AVf_REIFY;
4537 for (ix = fpad; ix > 0; ix--) {
4538 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4539 if (namesv && namesv != &PL_sv_undef) {
4540 char *name = SvPVX(namesv); /* XXX */
4541 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4542 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4543 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4545 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4547 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4549 else { /* our own lexical */
4552 /* anon code -- we'll come back for it */
4553 sv = SvREFCNT_inc(ppad[ix]);
4555 else if (*name == '@')
4557 else if (*name == '%')
4566 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4567 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4570 SV* sv = NEWSV(0,0);
4576 /* Now that vars are all in place, clone nested closures. */
4578 for (ix = fpad; ix > 0; ix--) {
4579 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4581 && namesv != &PL_sv_undef
4582 && !(SvFLAGS(namesv) & SVf_FAKE)
4583 && *SvPVX(namesv) == '&'
4584 && CvCLONE(ppad[ix]))
4586 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4587 SvREFCNT_dec(ppad[ix]);
4590 PL_curpad[ix] = (SV*)kid;
4594 #ifdef DEBUG_CLOSURES
4595 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4597 PerlIO_printf(Perl_debug_log, " from:\n");
4599 PerlIO_printf(Perl_debug_log, " to:\n");
4606 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4608 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4610 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4617 Perl_cv_clone(pTHX_ CV *proto)
4620 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4621 cv = cv_clone2(proto, CvOUTSIDE(proto));
4622 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4627 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4629 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4630 SV* msg = sv_newmortal();
4634 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4635 sv_setpv(msg, "Prototype mismatch:");
4637 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4639 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4640 sv_catpv(msg, " vs ");
4642 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4644 sv_catpv(msg, "none");
4645 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4649 static void const_sv_xsub(pTHX_ CV* cv);
4653 =head1 Optree Manipulation Functions
4655 =for apidoc cv_const_sv
4657 If C<cv> is a constant sub eligible for inlining. returns the constant
4658 value returned by the sub. Otherwise, returns NULL.
4660 Constant subs can be created with C<newCONSTSUB> or as described in
4661 L<perlsub/"Constant Functions">.
4666 Perl_cv_const_sv(pTHX_ CV *cv)
4668 if (!cv || !CvCONST(cv))
4670 return (SV*)CvXSUBANY(cv).any_ptr;
4674 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4681 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4682 o = cLISTOPo->op_first->op_sibling;
4684 for (; o; o = o->op_next) {
4685 OPCODE type = o->op_type;
4687 if (sv && o->op_next == o)
4689 if (o->op_next != o) {
4690 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4692 if (type == OP_DBSTATE)
4695 if (type == OP_LEAVESUB || type == OP_RETURN)
4699 if (type == OP_CONST && cSVOPo->op_sv)
4701 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4702 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4703 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4707 /* We get here only from cv_clone2() while creating a closure.
4708 Copy the const value here instead of in cv_clone2 so that
4709 SvREADONLY_on doesn't lead to problems when leaving
4714 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4726 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4736 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4740 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4742 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4746 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4752 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4757 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4758 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4759 SV *sv = sv_newmortal();
4760 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4761 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4762 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4767 gv = gv_fetchpv(name ? name : (aname ? aname :
4768 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4769 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4779 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4780 maximum a prototype before. */
4781 if (SvTYPE(gv) > SVt_NULL) {
4782 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4783 && ckWARN_d(WARN_PROTOTYPE))
4785 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4787 cv_ckproto((CV*)gv, NULL, ps);
4790 sv_setpv((SV*)gv, ps);
4792 sv_setiv((SV*)gv, -1);
4793 SvREFCNT_dec(PL_compcv);
4794 cv = PL_compcv = NULL;
4795 PL_sub_generation++;
4799 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4801 #ifdef GV_UNIQUE_CHECK
4802 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4803 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4807 if (!block || !ps || *ps || attrs)
4810 const_sv = op_const_sv(block, Nullcv);
4813 bool exists = CvROOT(cv) || CvXSUB(cv);
4815 #ifdef GV_UNIQUE_CHECK
4816 if (exists && GvUNIQUE(gv)) {
4817 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4821 /* if the subroutine doesn't exist and wasn't pre-declared
4822 * with a prototype, assume it will be AUTOLOADed,
4823 * skipping the prototype check
4825 if (exists || SvPOK(cv))
4826 cv_ckproto(cv, gv, ps);
4827 /* already defined (or promised)? */
4828 if (exists || GvASSUMECV(gv)) {
4829 if (!block && !attrs) {
4830 /* just a "sub foo;" when &foo is already defined */
4831 SAVEFREESV(PL_compcv);
4834 /* ahem, death to those who redefine active sort subs */
4835 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4836 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4838 if (ckWARN(WARN_REDEFINE)
4840 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4842 line_t oldline = CopLINE(PL_curcop);
4843 if (PL_copline != NOLINE)
4844 CopLINE_set(PL_curcop, PL_copline);
4845 Perl_warner(aTHX_ WARN_REDEFINE,
4846 CvCONST(cv) ? "Constant subroutine %s redefined"
4847 : "Subroutine %s redefined", name);
4848 CopLINE_set(PL_curcop, oldline);
4856 SvREFCNT_inc(const_sv);
4858 assert(!CvROOT(cv) && !CvCONST(cv));
4859 sv_setpv((SV*)cv, ""); /* prototype is "" */
4860 CvXSUBANY(cv).any_ptr = const_sv;
4861 CvXSUB(cv) = const_sv_xsub;
4866 cv = newCONSTSUB(NULL, name, const_sv);
4869 SvREFCNT_dec(PL_compcv);
4871 PL_sub_generation++;
4878 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4879 * before we clobber PL_compcv.
4883 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4884 stash = GvSTASH(CvGV(cv));
4885 else if (CvSTASH(cv))
4886 stash = CvSTASH(cv);
4888 stash = PL_curstash;
4891 /* possibly about to re-define existing subr -- ignore old cv */
4892 rcv = (SV*)PL_compcv;
4893 if (name && GvSTASH(gv))
4894 stash = GvSTASH(gv);
4896 stash = PL_curstash;
4898 apply_attrs(stash, rcv, attrs, FALSE);
4900 if (cv) { /* must reuse cv if autoloaded */
4902 /* got here with just attrs -- work done, so bug out */
4903 SAVEFREESV(PL_compcv);
4907 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4908 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4909 CvOUTSIDE(PL_compcv) = 0;
4910 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4911 CvPADLIST(PL_compcv) = 0;
4912 /* inner references to PL_compcv must be fixed up ... */
4914 AV *padlist = CvPADLIST(cv);
4915 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4916 AV *comppad = (AV*)AvARRAY(padlist)[1];
4917 SV **namepad = AvARRAY(comppad_name);
4918 SV **curpad = AvARRAY(comppad);
4919 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4920 SV *namesv = namepad[ix];
4921 if (namesv && namesv != &PL_sv_undef
4922 && *SvPVX(namesv) == '&')
4924 CV *innercv = (CV*)curpad[ix];
4925 if (CvOUTSIDE(innercv) == PL_compcv) {
4926 CvOUTSIDE(innercv) = cv;
4927 if (!CvANON(innercv) || CvCLONED(innercv)) {
4928 (void)SvREFCNT_inc(cv);
4929 SvREFCNT_dec(PL_compcv);
4935 /* ... before we throw it away */
4936 SvREFCNT_dec(PL_compcv);
4937 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4938 ++PL_sub_generation;
4945 PL_sub_generation++;
4949 CvFILE_set_from_cop(cv, PL_curcop);
4950 CvSTASH(cv) = PL_curstash;
4951 #ifdef USE_5005THREADS
4953 if (!CvMUTEXP(cv)) {
4954 New(666, CvMUTEXP(cv), 1, perl_mutex);
4955 MUTEX_INIT(CvMUTEXP(cv));
4957 #endif /* USE_5005THREADS */
4960 sv_setpv((SV*)cv, ps);
4962 if (PL_error_count) {
4966 char *s = strrchr(name, ':');
4968 if (strEQ(s, "BEGIN")) {
4970 "BEGIN not safe after errors--compilation aborted";
4971 if (PL_in_eval & EVAL_KEEPERR)
4972 Perl_croak(aTHX_ not_safe);
4974 /* force display of errors found but not reported */
4975 sv_catpv(ERRSV, not_safe);
4976 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4984 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4985 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4988 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4989 mod(scalarseq(block), OP_LEAVESUBLV));
4992 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4994 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4995 OpREFCNT_set(CvROOT(cv), 1);
4996 CvSTART(cv) = LINKLIST(CvROOT(cv));
4997 CvROOT(cv)->op_next = 0;
4998 CALL_PEEP(CvSTART(cv));
5000 /* now that optimizer has done its work, adjust pad values */
5002 SV **namep = AvARRAY(PL_comppad_name);
5003 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5006 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5009 * The only things that a clonable function needs in its
5010 * pad are references to outer lexicals and anonymous subs.
5011 * The rest are created anew during cloning.
5013 if (!((namesv = namep[ix]) != Nullsv &&
5014 namesv != &PL_sv_undef &&
5016 *SvPVX(namesv) == '&')))
5018 SvREFCNT_dec(PL_curpad[ix]);
5019 PL_curpad[ix] = Nullsv;
5022 assert(!CvCONST(cv));
5023 if (ps && !*ps && op_const_sv(block, cv))
5027 AV *av = newAV(); /* Will be @_ */
5029 av_store(PL_comppad, 0, (SV*)av);
5030 AvFLAGS(av) = AVf_REIFY;
5032 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5033 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5035 if (!SvPADMY(PL_curpad[ix]))
5036 SvPADTMP_on(PL_curpad[ix]);
5040 /* If a potential closure prototype, don't keep a refcount on outer CV.
5041 * This is okay as the lifetime of the prototype is tied to the
5042 * lifetime of the outer CV. Avoids memory leak due to reference
5045 SvREFCNT_dec(CvOUTSIDE(cv));
5047 if (name || aname) {
5049 char *tname = (name ? name : aname);
5051 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5052 SV *sv = NEWSV(0,0);
5053 SV *tmpstr = sv_newmortal();
5054 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5058 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5060 (long)PL_subline, (long)CopLINE(PL_curcop));
5061 gv_efullname3(tmpstr, gv, Nullch);
5062 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5063 hv = GvHVn(db_postponed);
5064 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5065 && (pcv = GvCV(db_postponed)))
5071 call_sv((SV*)pcv, G_DISCARD);
5075 if ((s = strrchr(tname,':')))
5080 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5083 if (strEQ(s, "BEGIN")) {
5084 I32 oldscope = PL_scopestack_ix;
5086 SAVECOPFILE(&PL_compiling);
5087 SAVECOPLINE(&PL_compiling);
5090 PL_beginav = newAV();
5091 DEBUG_x( dump_sub(gv) );
5092 av_push(PL_beginav, (SV*)cv);
5093 GvCV(gv) = 0; /* cv has been hijacked */
5094 call_list(oldscope, PL_beginav);
5096 PL_curcop = &PL_compiling;
5097 PL_compiling.op_private = PL_hints;
5100 else if (strEQ(s, "END") && !PL_error_count) {
5103 DEBUG_x( dump_sub(gv) );
5104 av_unshift(PL_endav, 1);
5105 av_store(PL_endav, 0, (SV*)cv);
5106 GvCV(gv) = 0; /* cv has been hijacked */
5108 else if (strEQ(s, "CHECK") && !PL_error_count) {
5110 PL_checkav = newAV();
5111 DEBUG_x( dump_sub(gv) );
5112 if (PL_main_start && ckWARN(WARN_VOID))
5113 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5114 av_unshift(PL_checkav, 1);
5115 av_store(PL_checkav, 0, (SV*)cv);
5116 GvCV(gv) = 0; /* cv has been hijacked */
5118 else if (strEQ(s, "INIT") && !PL_error_count) {
5120 PL_initav = newAV();
5121 DEBUG_x( dump_sub(gv) );
5122 if (PL_main_start && ckWARN(WARN_VOID))
5123 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5124 av_push(PL_initav, (SV*)cv);
5125 GvCV(gv) = 0; /* cv has been hijacked */
5130 PL_copline = NOLINE;
5135 /* XXX unsafe for threads if eval_owner isn't held */
5137 =for apidoc newCONSTSUB
5139 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5140 eligible for inlining at compile-time.
5146 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5152 SAVECOPLINE(PL_curcop);
5153 CopLINE_set(PL_curcop, PL_copline);
5156 PL_hints &= ~HINT_BLOCK_SCOPE;
5159 SAVESPTR(PL_curstash);
5160 SAVECOPSTASH(PL_curcop);
5161 PL_curstash = stash;
5162 CopSTASH_set(PL_curcop,stash);
5165 cv = newXS(name, const_sv_xsub, __FILE__);
5166 CvXSUBANY(cv).any_ptr = sv;
5168 sv_setpv((SV*)cv, ""); /* prototype is "" */
5176 =for apidoc U||newXS
5178 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5184 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5186 GV *gv = gv_fetchpv(name ? name :
5187 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5188 GV_ADDMULTI, SVt_PVCV);
5191 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5193 /* just a cached method */
5197 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5198 /* already defined (or promised) */
5199 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5200 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5201 line_t oldline = CopLINE(PL_curcop);
5202 if (PL_copline != NOLINE)
5203 CopLINE_set(PL_curcop, PL_copline);
5204 Perl_warner(aTHX_ WARN_REDEFINE,
5205 CvCONST(cv) ? "Constant subroutine %s redefined"
5206 : "Subroutine %s redefined"
5208 CopLINE_set(PL_curcop, oldline);
5215 if (cv) /* must reuse cv if autoloaded */
5218 cv = (CV*)NEWSV(1105,0);
5219 sv_upgrade((SV *)cv, SVt_PVCV);
5223 PL_sub_generation++;
5227 #ifdef USE_5005THREADS
5228 New(666, CvMUTEXP(cv), 1, perl_mutex);
5229 MUTEX_INIT(CvMUTEXP(cv));
5231 #endif /* USE_5005THREADS */
5232 (void)gv_fetchfile(filename);
5233 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5234 an external constant string */
5235 CvXSUB(cv) = subaddr;
5238 char *s = strrchr(name,':');
5244 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5247 if (strEQ(s, "BEGIN")) {
5249 PL_beginav = newAV();
5250 av_push(PL_beginav, (SV*)cv);
5251 GvCV(gv) = 0; /* cv has been hijacked */
5253 else if (strEQ(s, "END")) {
5256 av_unshift(PL_endav, 1);
5257 av_store(PL_endav, 0, (SV*)cv);
5258 GvCV(gv) = 0; /* cv has been hijacked */
5260 else if (strEQ(s, "CHECK")) {
5262 PL_checkav = newAV();
5263 if (PL_main_start && ckWARN(WARN_VOID))
5264 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5265 av_unshift(PL_checkav, 1);
5266 av_store(PL_checkav, 0, (SV*)cv);
5267 GvCV(gv) = 0; /* cv has been hijacked */
5269 else if (strEQ(s, "INIT")) {
5271 PL_initav = newAV();
5272 if (PL_main_start && ckWARN(WARN_VOID))
5273 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5274 av_push(PL_initav, (SV*)cv);
5275 GvCV(gv) = 0; /* cv has been hijacked */
5286 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5295 name = SvPVx(cSVOPo->op_sv, n_a);
5298 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5299 #ifdef GV_UNIQUE_CHECK
5301 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5305 if ((cv = GvFORM(gv))) {
5306 if (ckWARN(WARN_REDEFINE)) {
5307 line_t oldline = CopLINE(PL_curcop);
5308 if (PL_copline != NOLINE)
5309 CopLINE_set(PL_curcop, PL_copline);
5310 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5311 CopLINE_set(PL_curcop, oldline);
5318 CvFILE_set_from_cop(cv, PL_curcop);
5320 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5321 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5322 SvPADTMP_on(PL_curpad[ix]);
5325 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5326 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5327 OpREFCNT_set(CvROOT(cv), 1);
5328 CvSTART(cv) = LINKLIST(CvROOT(cv));
5329 CvROOT(cv)->op_next = 0;
5330 CALL_PEEP(CvSTART(cv));
5332 PL_copline = NOLINE;
5337 Perl_newANONLIST(pTHX_ OP *o)
5339 return newUNOP(OP_REFGEN, 0,
5340 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5344 Perl_newANONHASH(pTHX_ OP *o)
5346 return newUNOP(OP_REFGEN, 0,
5347 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5351 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5353 return newANONATTRSUB(floor, proto, Nullop, block);
5357 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5359 return newUNOP(OP_REFGEN, 0,
5360 newSVOP(OP_ANONCODE, 0,
5361 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5365 Perl_oopsAV(pTHX_ OP *o)
5367 switch (o->op_type) {
5369 o->op_type = OP_PADAV;
5370 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5371 return ref(o, OP_RV2AV);
5374 o->op_type = OP_RV2AV;
5375 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5380 if (ckWARN_d(WARN_INTERNAL))
5381 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5388 Perl_oopsHV(pTHX_ OP *o)
5390 switch (o->op_type) {
5393 o->op_type = OP_PADHV;
5394 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5395 return ref(o, OP_RV2HV);
5399 o->op_type = OP_RV2HV;
5400 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5405 if (ckWARN_d(WARN_INTERNAL))
5406 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5413 Perl_newAVREF(pTHX_ OP *o)
5415 if (o->op_type == OP_PADANY) {
5416 o->op_type = OP_PADAV;
5417 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5420 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5421 && ckWARN(WARN_DEPRECATED)) {
5422 Perl_warner(aTHX_ WARN_DEPRECATED,
5423 "Using an array as a reference is deprecated");
5425 return newUNOP(OP_RV2AV, 0, scalar(o));
5429 Perl_newGVREF(pTHX_ I32 type, OP *o)
5431 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5432 return newUNOP(OP_NULL, 0, o);
5433 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5437 Perl_newHVREF(pTHX_ OP *o)
5439 if (o->op_type == OP_PADANY) {
5440 o->op_type = OP_PADHV;
5441 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5444 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5445 && ckWARN(WARN_DEPRECATED)) {
5446 Perl_warner(aTHX_ WARN_DEPRECATED,
5447 "Using a hash as a reference is deprecated");
5449 return newUNOP(OP_RV2HV, 0, scalar(o));
5453 Perl_oopsCV(pTHX_ OP *o)
5455 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5461 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5463 return newUNOP(OP_RV2CV, flags, scalar(o));
5467 Perl_newSVREF(pTHX_ OP *o)
5469 if (o->op_type == OP_PADANY) {
5470 o->op_type = OP_PADSV;
5471 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5474 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5475 o->op_flags |= OPpDONE_SVREF;
5478 return newUNOP(OP_RV2SV, 0, scalar(o));
5481 /* Check routines. */
5484 Perl_ck_anoncode(pTHX_ OP *o)
5489 name = NEWSV(1106,0);
5490 sv_upgrade(name, SVt_PVNV);
5491 sv_setpvn(name, "&", 1);
5494 ix = pad_alloc(o->op_type, SVs_PADMY);
5495 av_store(PL_comppad_name, ix, name);
5496 av_store(PL_comppad, ix, cSVOPo->op_sv);
5497 SvPADMY_on(cSVOPo->op_sv);
5498 cSVOPo->op_sv = Nullsv;
5499 cSVOPo->op_targ = ix;
5504 Perl_ck_bitop(pTHX_ OP *o)
5506 o->op_private = PL_hints;
5511 Perl_ck_concat(pTHX_ OP *o)
5513 if (cUNOPo->op_first->op_type == OP_CONCAT)
5514 o->op_flags |= OPf_STACKED;
5519 Perl_ck_spair(pTHX_ OP *o)
5521 if (o->op_flags & OPf_KIDS) {
5524 OPCODE type = o->op_type;
5525 o = modkids(ck_fun(o), type);
5526 kid = cUNOPo->op_first;
5527 newop = kUNOP->op_first->op_sibling;
5529 (newop->op_sibling ||
5530 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5531 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5532 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5536 op_free(kUNOP->op_first);
5537 kUNOP->op_first = newop;
5539 o->op_ppaddr = PL_ppaddr[++o->op_type];
5544 Perl_ck_delete(pTHX_ OP *o)
5548 if (o->op_flags & OPf_KIDS) {
5549 OP *kid = cUNOPo->op_first;
5550 switch (kid->op_type) {
5552 o->op_flags |= OPf_SPECIAL;
5555 o->op_private |= OPpSLICE;
5558 o->op_flags |= OPf_SPECIAL;
5563 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5572 Perl_ck_die(pTHX_ OP *o)
5575 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5581 Perl_ck_eof(pTHX_ OP *o)
5583 I32 type = o->op_type;
5585 if (o->op_flags & OPf_KIDS) {
5586 if (cLISTOPo->op_first->op_type == OP_STUB) {
5588 o = newUNOP(type, OPf_SPECIAL,
5589 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5597 Perl_ck_eval(pTHX_ OP *o)
5599 PL_hints |= HINT_BLOCK_SCOPE;
5600 if (o->op_flags & OPf_KIDS) {
5601 SVOP *kid = (SVOP*)cUNOPo->op_first;
5604 o->op_flags &= ~OPf_KIDS;
5607 else if (kid->op_type == OP_LINESEQ) {
5610 kid->op_next = o->op_next;
5611 cUNOPo->op_first = 0;
5614 NewOp(1101, enter, 1, LOGOP);
5615 enter->op_type = OP_ENTERTRY;
5616 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5617 enter->op_private = 0;
5619 /* establish postfix order */
5620 enter->op_next = (OP*)enter;
5622 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5623 o->op_type = OP_LEAVETRY;
5624 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5625 enter->op_other = o;
5633 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5635 o->op_targ = (PADOFFSET)PL_hints;
5640 Perl_ck_exit(pTHX_ OP *o)
5643 HV *table = GvHV(PL_hintgv);
5645 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5646 if (svp && *svp && SvTRUE(*svp))
5647 o->op_private |= OPpEXIT_VMSISH;
5649 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5655 Perl_ck_exec(pTHX_ OP *o)
5658 if (o->op_flags & OPf_STACKED) {
5660 kid = cUNOPo->op_first->op_sibling;
5661 if (kid->op_type == OP_RV2GV)
5670 Perl_ck_exists(pTHX_ OP *o)
5673 if (o->op_flags & OPf_KIDS) {
5674 OP *kid = cUNOPo->op_first;
5675 if (kid->op_type == OP_ENTERSUB) {
5676 (void) ref(kid, o->op_type);
5677 if (kid->op_type != OP_RV2CV && !PL_error_count)
5678 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5680 o->op_private |= OPpEXISTS_SUB;
5682 else if (kid->op_type == OP_AELEM)
5683 o->op_flags |= OPf_SPECIAL;
5684 else if (kid->op_type != OP_HELEM)
5685 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5694 Perl_ck_gvconst(pTHX_ register OP *o)
5696 o = fold_constants(o);
5697 if (o->op_type == OP_CONST)
5704 Perl_ck_rvconst(pTHX_ register OP *o)
5706 SVOP *kid = (SVOP*)cUNOPo->op_first;
5708 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5709 if (kid->op_type == OP_CONST) {
5713 SV *kidsv = kid->op_sv;
5716 /* Is it a constant from cv_const_sv()? */
5717 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5718 SV *rsv = SvRV(kidsv);
5719 int svtype = SvTYPE(rsv);
5720 char *badtype = Nullch;
5722 switch (o->op_type) {
5724 if (svtype > SVt_PVMG)
5725 badtype = "a SCALAR";
5728 if (svtype != SVt_PVAV)
5729 badtype = "an ARRAY";
5732 if (svtype != SVt_PVHV) {
5733 if (svtype == SVt_PVAV) { /* pseudohash? */
5734 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5735 if (ksv && SvROK(*ksv)
5736 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5745 if (svtype != SVt_PVCV)
5750 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5753 name = SvPV(kidsv, n_a);
5754 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5755 char *badthing = Nullch;
5756 switch (o->op_type) {
5758 badthing = "a SCALAR";
5761 badthing = "an ARRAY";
5764 badthing = "a HASH";
5769 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5773 * This is a little tricky. We only want to add the symbol if we
5774 * didn't add it in the lexer. Otherwise we get duplicate strict
5775 * warnings. But if we didn't add it in the lexer, we must at
5776 * least pretend like we wanted to add it even if it existed before,
5777 * or we get possible typo warnings. OPpCONST_ENTERED says
5778 * whether the lexer already added THIS instance of this symbol.
5780 iscv = (o->op_type == OP_RV2CV) * 2;
5782 gv = gv_fetchpv(name,
5783 iscv | !(kid->op_private & OPpCONST_ENTERED),
5786 : o->op_type == OP_RV2SV
5788 : o->op_type == OP_RV2AV
5790 : o->op_type == OP_RV2HV
5793 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5795 kid->op_type = OP_GV;
5796 SvREFCNT_dec(kid->op_sv);
5798 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5799 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5800 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5802 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5804 kid->op_sv = SvREFCNT_inc(gv);
5806 kid->op_private = 0;
5807 kid->op_ppaddr = PL_ppaddr[OP_GV];
5814 Perl_ck_ftst(pTHX_ OP *o)
5816 I32 type = o->op_type;
5818 if (o->op_flags & OPf_REF) {
5821 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5822 SVOP *kid = (SVOP*)cUNOPo->op_first;
5824 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5826 OP *newop = newGVOP(type, OPf_REF,
5827 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5834 if (type == OP_FTTTY)
5835 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5838 o = newUNOP(type, 0, newDEFSVOP());
5844 Perl_ck_fun(pTHX_ OP *o)
5850 int type = o->op_type;
5851 register I32 oa = PL_opargs[type] >> OASHIFT;
5853 if (o->op_flags & OPf_STACKED) {
5854 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5857 return no_fh_allowed(o);
5860 if (o->op_flags & OPf_KIDS) {
5862 tokid = &cLISTOPo->op_first;
5863 kid = cLISTOPo->op_first;
5864 if (kid->op_type == OP_PUSHMARK ||
5865 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5867 tokid = &kid->op_sibling;
5868 kid = kid->op_sibling;
5870 if (!kid && PL_opargs[type] & OA_DEFGV)
5871 *tokid = kid = newDEFSVOP();
5875 sibl = kid->op_sibling;
5878 /* list seen where single (scalar) arg expected? */
5879 if (numargs == 1 && !(oa >> 4)
5880 && kid->op_type == OP_LIST && type != OP_SCALAR)
5882 return too_many_arguments(o,PL_op_desc[type]);
5895 if ((type == OP_PUSH || type == OP_UNSHIFT)
5896 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5897 Perl_warner(aTHX_ WARN_SYNTAX,
5898 "Useless use of %s with no values",
5901 if (kid->op_type == OP_CONST &&
5902 (kid->op_private & OPpCONST_BARE))
5904 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5905 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5906 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5907 if (ckWARN(WARN_DEPRECATED))
5908 Perl_warner(aTHX_ WARN_DEPRECATED,
5909 "Array @%s missing the @ in argument %"IVdf" of %s()",
5910 name, (IV)numargs, PL_op_desc[type]);
5913 kid->op_sibling = sibl;
5916 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5917 bad_type(numargs, "array", PL_op_desc[type], kid);
5921 if (kid->op_type == OP_CONST &&
5922 (kid->op_private & OPpCONST_BARE))
5924 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5925 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5926 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5927 if (ckWARN(WARN_DEPRECATED))
5928 Perl_warner(aTHX_ WARN_DEPRECATED,
5929 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5930 name, (IV)numargs, PL_op_desc[type]);
5933 kid->op_sibling = sibl;
5936 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5937 bad_type(numargs, "hash", PL_op_desc[type], kid);
5942 OP *newop = newUNOP(OP_NULL, 0, kid);
5943 kid->op_sibling = 0;
5945 newop->op_next = newop;
5947 kid->op_sibling = sibl;
5952 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5953 if (kid->op_type == OP_CONST &&
5954 (kid->op_private & OPpCONST_BARE))
5956 OP *newop = newGVOP(OP_GV, 0,
5957 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5959 if (kid == cLISTOPo->op_last)
5960 cLISTOPo->op_last = newop;
5964 else if (kid->op_type == OP_READLINE) {
5965 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5966 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5969 I32 flags = OPf_SPECIAL;
5973 /* is this op a FH constructor? */
5974 if (is_handle_constructor(o,numargs)) {
5975 char *name = Nullch;
5979 /* Set a flag to tell rv2gv to vivify
5980 * need to "prove" flag does not mean something
5981 * else already - NI-S 1999/05/07
5984 if (kid->op_type == OP_PADSV) {
5985 SV **namep = av_fetch(PL_comppad_name,
5987 if (namep && *namep)
5988 name = SvPV(*namep, len);
5990 else if (kid->op_type == OP_RV2SV
5991 && kUNOP->op_first->op_type == OP_GV)
5993 GV *gv = cGVOPx_gv(kUNOP->op_first);
5995 len = GvNAMELEN(gv);
5997 else if (kid->op_type == OP_AELEM
5998 || kid->op_type == OP_HELEM)
6000 name = "__ANONIO__";
6006 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6007 namesv = PL_curpad[targ];
6008 (void)SvUPGRADE(namesv, SVt_PV);
6010 sv_setpvn(namesv, "$", 1);
6011 sv_catpvn(namesv, name, len);
6014 kid->op_sibling = 0;
6015 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6016 kid->op_targ = targ;
6017 kid->op_private |= priv;
6019 kid->op_sibling = sibl;
6025 mod(scalar(kid), type);
6029 tokid = &kid->op_sibling;
6030 kid = kid->op_sibling;
6032 o->op_private |= numargs;
6034 return too_many_arguments(o,OP_DESC(o));
6037 else if (PL_opargs[type] & OA_DEFGV) {
6039 return newUNOP(type, 0, newDEFSVOP());
6043 while (oa & OA_OPTIONAL)
6045 if (oa && oa != OA_LIST)
6046 return too_few_arguments(o,OP_DESC(o));
6052 Perl_ck_glob(pTHX_ OP *o)
6057 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6058 append_elem(OP_GLOB, o, newDEFSVOP());
6060 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6061 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6063 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6066 #if !defined(PERL_EXTERNAL_GLOB)
6067 /* XXX this can be tightened up and made more failsafe. */
6071 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6072 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6073 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6074 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6075 GvCV(gv) = GvCV(glob_gv);
6076 SvREFCNT_inc((SV*)GvCV(gv));
6077 GvIMPORTED_CV_on(gv);
6080 #endif /* PERL_EXTERNAL_GLOB */
6082 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6083 append_elem(OP_GLOB, o,
6084 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6085 o->op_type = OP_LIST;
6086 o->op_ppaddr = PL_ppaddr[OP_LIST];
6087 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6088 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6089 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6090 append_elem(OP_LIST, o,
6091 scalar(newUNOP(OP_RV2CV, 0,
6092 newGVOP(OP_GV, 0, gv)))));
6093 o = newUNOP(OP_NULL, 0, ck_subr(o));
6094 o->op_targ = OP_GLOB; /* hint at what it used to be */
6097 gv = newGVgen("main");
6099 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6105 Perl_ck_grep(pTHX_ OP *o)
6109 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6111 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6112 NewOp(1101, gwop, 1, LOGOP);
6114 if (o->op_flags & OPf_STACKED) {
6117 kid = cLISTOPo->op_first->op_sibling;
6118 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6121 kid->op_next = (OP*)gwop;
6122 o->op_flags &= ~OPf_STACKED;
6124 kid = cLISTOPo->op_first->op_sibling;
6125 if (type == OP_MAPWHILE)
6132 kid = cLISTOPo->op_first->op_sibling;
6133 if (kid->op_type != OP_NULL)
6134 Perl_croak(aTHX_ "panic: ck_grep");
6135 kid = kUNOP->op_first;
6137 gwop->op_type = type;
6138 gwop->op_ppaddr = PL_ppaddr[type];
6139 gwop->op_first = listkids(o);
6140 gwop->op_flags |= OPf_KIDS;
6141 gwop->op_private = 1;
6142 gwop->op_other = LINKLIST(kid);
6143 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6144 kid->op_next = (OP*)gwop;
6146 kid = cLISTOPo->op_first->op_sibling;
6147 if (!kid || !kid->op_sibling)
6148 return too_few_arguments(o,OP_DESC(o));
6149 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6150 mod(kid, OP_GREPSTART);
6156 Perl_ck_index(pTHX_ OP *o)
6158 if (o->op_flags & OPf_KIDS) {
6159 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6161 kid = kid->op_sibling; /* get past "big" */
6162 if (kid && kid->op_type == OP_CONST)
6163 fbm_compile(((SVOP*)kid)->op_sv, 0);
6169 Perl_ck_lengthconst(pTHX_ OP *o)
6171 /* XXX length optimization goes here */
6176 Perl_ck_lfun(pTHX_ OP *o)
6178 OPCODE type = o->op_type;
6179 return modkids(ck_fun(o), type);
6183 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6185 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6186 switch (cUNOPo->op_first->op_type) {
6188 /* This is needed for
6189 if (defined %stash::)
6190 to work. Do not break Tk.
6192 break; /* Globals via GV can be undef */
6194 case OP_AASSIGN: /* Is this a good idea? */
6195 Perl_warner(aTHX_ WARN_DEPRECATED,
6196 "defined(@array) is deprecated");
6197 Perl_warner(aTHX_ WARN_DEPRECATED,
6198 "\t(Maybe you should just omit the defined()?)\n");
6201 /* This is needed for
6202 if (defined %stash::)
6203 to work. Do not break Tk.
6205 break; /* Globals via GV can be undef */
6207 Perl_warner(aTHX_ WARN_DEPRECATED,
6208 "defined(%%hash) is deprecated");
6209 Perl_warner(aTHX_ WARN_DEPRECATED,
6210 "\t(Maybe you should just omit the defined()?)\n");
6221 Perl_ck_rfun(pTHX_ OP *o)
6223 OPCODE type = o->op_type;
6224 return refkids(ck_fun(o), type);
6228 Perl_ck_listiob(pTHX_ OP *o)
6232 kid = cLISTOPo->op_first;
6235 kid = cLISTOPo->op_first;
6237 if (kid->op_type == OP_PUSHMARK)
6238 kid = kid->op_sibling;
6239 if (kid && o->op_flags & OPf_STACKED)
6240 kid = kid->op_sibling;
6241 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6242 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6243 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6244 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6245 cLISTOPo->op_first->op_sibling = kid;
6246 cLISTOPo->op_last = kid;
6247 kid = kid->op_sibling;
6252 append_elem(o->op_type, o, newDEFSVOP());
6258 Perl_ck_sassign(pTHX_ OP *o)
6260 OP *kid = cLISTOPo->op_first;
6261 /* has a disposable target? */
6262 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6263 && !(kid->op_flags & OPf_STACKED)
6264 /* Cannot steal the second time! */
6265 && !(kid->op_private & OPpTARGET_MY))
6267 OP *kkid = kid->op_sibling;
6269 /* Can just relocate the target. */
6270 if (kkid && kkid->op_type == OP_PADSV
6271 && !(kkid->op_private & OPpLVAL_INTRO))
6273 kid->op_targ = kkid->op_targ;
6275 /* Now we do not need PADSV and SASSIGN. */
6276 kid->op_sibling = o->op_sibling; /* NULL */
6277 cLISTOPo->op_first = NULL;
6280 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6288 Perl_ck_match(pTHX_ OP *o)
6290 o->op_private |= OPpRUNTIME;
6295 Perl_ck_method(pTHX_ OP *o)
6297 OP *kid = cUNOPo->op_first;
6298 if (kid->op_type == OP_CONST) {
6299 SV* sv = kSVOP->op_sv;
6300 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6302 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6303 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6306 kSVOP->op_sv = Nullsv;
6308 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6317 Perl_ck_null(pTHX_ OP *o)
6323 Perl_ck_open(pTHX_ OP *o)
6325 HV *table = GvHV(PL_hintgv);
6329 svp = hv_fetch(table, "open_IN", 7, FALSE);
6331 mode = mode_from_discipline(*svp);
6332 if (mode & O_BINARY)
6333 o->op_private |= OPpOPEN_IN_RAW;
6334 else if (mode & O_TEXT)
6335 o->op_private |= OPpOPEN_IN_CRLF;
6338 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6340 mode = mode_from_discipline(*svp);
6341 if (mode & O_BINARY)
6342 o->op_private |= OPpOPEN_OUT_RAW;
6343 else if (mode & O_TEXT)
6344 o->op_private |= OPpOPEN_OUT_CRLF;
6347 if (o->op_type == OP_BACKTICK)
6353 Perl_ck_repeat(pTHX_ OP *o)
6355 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6356 o->op_private |= OPpREPEAT_DOLIST;
6357 cBINOPo->op_first = force_list(cBINOPo->op_first);
6365 Perl_ck_require(pTHX_ OP *o)
6369 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6370 SVOP *kid = (SVOP*)cUNOPo->op_first;
6372 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6374 for (s = SvPVX(kid->op_sv); *s; s++) {
6375 if (*s == ':' && s[1] == ':') {
6377 Move(s+2, s+1, strlen(s+2)+1, char);
6378 --SvCUR(kid->op_sv);
6381 if (SvREADONLY(kid->op_sv)) {
6382 SvREADONLY_off(kid->op_sv);
6383 sv_catpvn(kid->op_sv, ".pm", 3);
6384 SvREADONLY_on(kid->op_sv);
6387 sv_catpvn(kid->op_sv, ".pm", 3);
6391 /* handle override, if any */
6392 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6393 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6394 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6396 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6397 OP *kid = cUNOPo->op_first;
6398 cUNOPo->op_first = 0;
6400 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6401 append_elem(OP_LIST, kid,
6402 scalar(newUNOP(OP_RV2CV, 0,
6411 Perl_ck_return(pTHX_ OP *o)
6414 if (CvLVALUE(PL_compcv)) {
6415 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6416 mod(kid, OP_LEAVESUBLV);
6423 Perl_ck_retarget(pTHX_ OP *o)
6425 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6432 Perl_ck_select(pTHX_ OP *o)
6435 if (o->op_flags & OPf_KIDS) {
6436 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6437 if (kid && kid->op_sibling) {
6438 o->op_type = OP_SSELECT;
6439 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6441 return fold_constants(o);
6445 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6446 if (kid && kid->op_type == OP_RV2GV)
6447 kid->op_private &= ~HINT_STRICT_REFS;
6452 Perl_ck_shift(pTHX_ OP *o)
6454 I32 type = o->op_type;
6456 if (!(o->op_flags & OPf_KIDS)) {
6460 #ifdef USE_5005THREADS
6461 if (!CvUNIQUE(PL_compcv)) {
6462 argop = newOP(OP_PADAV, OPf_REF);
6463 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6466 argop = newUNOP(OP_RV2AV, 0,
6467 scalar(newGVOP(OP_GV, 0,
6468 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6471 argop = newUNOP(OP_RV2AV, 0,
6472 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6473 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6474 #endif /* USE_5005THREADS */
6475 return newUNOP(type, 0, scalar(argop));
6477 return scalar(modkids(ck_fun(o), type));
6481 Perl_ck_sort(pTHX_ OP *o)
6485 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6487 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6488 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6490 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6492 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6494 if (kid->op_type == OP_SCOPE) {
6498 else if (kid->op_type == OP_LEAVE) {
6499 if (o->op_type == OP_SORT) {
6500 op_null(kid); /* wipe out leave */
6503 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6504 if (k->op_next == kid)
6506 /* don't descend into loops */
6507 else if (k->op_type == OP_ENTERLOOP
6508 || k->op_type == OP_ENTERITER)
6510 k = cLOOPx(k)->op_lastop;
6515 kid->op_next = 0; /* just disconnect the leave */
6516 k = kLISTOP->op_first;
6521 if (o->op_type == OP_SORT) {
6522 /* provide scalar context for comparison function/block */
6528 o->op_flags |= OPf_SPECIAL;
6530 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6533 firstkid = firstkid->op_sibling;
6536 /* provide list context for arguments */
6537 if (o->op_type == OP_SORT)
6544 S_simplify_sort(pTHX_ OP *o)
6546 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6550 if (!(o->op_flags & OPf_STACKED))
6552 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6553 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6554 kid = kUNOP->op_first; /* get past null */
6555 if (kid->op_type != OP_SCOPE)
6557 kid = kLISTOP->op_last; /* get past scope */
6558 switch(kid->op_type) {
6566 k = kid; /* remember this node*/
6567 if (kBINOP->op_first->op_type != OP_RV2SV)
6569 kid = kBINOP->op_first; /* get past cmp */
6570 if (kUNOP->op_first->op_type != OP_GV)
6572 kid = kUNOP->op_first; /* get past rv2sv */
6574 if (GvSTASH(gv) != PL_curstash)
6576 if (strEQ(GvNAME(gv), "a"))
6578 else if (strEQ(GvNAME(gv), "b"))
6582 kid = k; /* back to cmp */
6583 if (kBINOP->op_last->op_type != OP_RV2SV)
6585 kid = kBINOP->op_last; /* down to 2nd arg */
6586 if (kUNOP->op_first->op_type != OP_GV)
6588 kid = kUNOP->op_first; /* get past rv2sv */
6590 if (GvSTASH(gv) != PL_curstash
6592 ? strNE(GvNAME(gv), "a")
6593 : strNE(GvNAME(gv), "b")))
6595 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6597 o->op_private |= OPpSORT_REVERSE;
6598 if (k->op_type == OP_NCMP)
6599 o->op_private |= OPpSORT_NUMERIC;
6600 if (k->op_type == OP_I_NCMP)
6601 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6602 kid = cLISTOPo->op_first->op_sibling;
6603 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6604 op_free(kid); /* then delete it */
6608 Perl_ck_split(pTHX_ OP *o)
6612 if (o->op_flags & OPf_STACKED)
6613 return no_fh_allowed(o);
6615 kid = cLISTOPo->op_first;
6616 if (kid->op_type != OP_NULL)
6617 Perl_croak(aTHX_ "panic: ck_split");
6618 kid = kid->op_sibling;
6619 op_free(cLISTOPo->op_first);
6620 cLISTOPo->op_first = kid;
6622 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6623 cLISTOPo->op_last = kid; /* There was only one element previously */
6626 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6627 OP *sibl = kid->op_sibling;
6628 kid->op_sibling = 0;
6629 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6630 if (cLISTOPo->op_first == cLISTOPo->op_last)
6631 cLISTOPo->op_last = kid;
6632 cLISTOPo->op_first = kid;
6633 kid->op_sibling = sibl;
6636 kid->op_type = OP_PUSHRE;
6637 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6640 if (!kid->op_sibling)
6641 append_elem(OP_SPLIT, o, newDEFSVOP());
6643 kid = kid->op_sibling;
6646 if (!kid->op_sibling)
6647 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6649 kid = kid->op_sibling;
6652 if (kid->op_sibling)
6653 return too_many_arguments(o,OP_DESC(o));
6659 Perl_ck_join(pTHX_ OP *o)
6661 if (ckWARN(WARN_SYNTAX)) {
6662 OP *kid = cLISTOPo->op_first->op_sibling;
6663 if (kid && kid->op_type == OP_MATCH) {
6664 char *pmstr = "STRING";
6665 if (PM_GETRE(kPMOP))
6666 pmstr = PM_GETRE(kPMOP)->precomp;
6667 Perl_warner(aTHX_ WARN_SYNTAX,
6668 "/%s/ should probably be written as \"%s\"",
6676 Perl_ck_subr(pTHX_ OP *o)
6678 OP *prev = ((cUNOPo->op_first->op_sibling)
6679 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6680 OP *o2 = prev->op_sibling;
6687 I32 contextclass = 0;
6691 o->op_private |= OPpENTERSUB_HASTARG;
6692 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6693 if (cvop->op_type == OP_RV2CV) {
6695 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6696 op_null(cvop); /* disable rv2cv */
6697 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6698 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6699 GV *gv = cGVOPx_gv(tmpop);
6702 tmpop->op_private |= OPpEARLY_CV;
6703 else if (SvPOK(cv)) {
6704 namegv = CvANON(cv) ? gv : CvGV(cv);
6705 proto = SvPV((SV*)cv, n_a);
6709 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6710 if (o2->op_type == OP_CONST)
6711 o2->op_private &= ~OPpCONST_STRICT;
6712 else if (o2->op_type == OP_LIST) {
6713 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6714 if (o && o->op_type == OP_CONST)
6715 o->op_private &= ~OPpCONST_STRICT;
6718 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6719 if (PERLDB_SUB && PL_curstash != PL_debstash)
6720 o->op_private |= OPpENTERSUB_DB;
6721 while (o2 != cvop) {
6725 return too_many_arguments(o, gv_ename(namegv));
6743 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6745 arg == 1 ? "block or sub {}" : "sub {}",
6746 gv_ename(namegv), o2);
6749 /* '*' allows any scalar type, including bareword */
6752 if (o2->op_type == OP_RV2GV)
6753 goto wrapref; /* autoconvert GLOB -> GLOBref */
6754 else if (o2->op_type == OP_CONST)
6755 o2->op_private &= ~OPpCONST_STRICT;
6756 else if (o2->op_type == OP_ENTERSUB) {
6757 /* accidental subroutine, revert to bareword */
6758 OP *gvop = ((UNOP*)o2)->op_first;
6759 if (gvop && gvop->op_type == OP_NULL) {
6760 gvop = ((UNOP*)gvop)->op_first;
6762 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6765 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6766 (gvop = ((UNOP*)gvop)->op_first) &&
6767 gvop->op_type == OP_GV)
6769 GV *gv = cGVOPx_gv(gvop);
6770 OP *sibling = o2->op_sibling;
6771 SV *n = newSVpvn("",0);
6773 gv_fullname3(n, gv, "");
6774 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6775 sv_chop(n, SvPVX(n)+6);
6776 o2 = newSVOP(OP_CONST, 0, n);
6777 prev->op_sibling = o2;
6778 o2->op_sibling = sibling;
6794 if (contextclass++ == 0) {
6795 e = strchr(proto, ']');
6796 if (!e || e == proto)
6809 while (*--p != '[');
6810 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6811 gv_ename(namegv), o2);
6817 if (o2->op_type == OP_RV2GV)
6820 bad_type(arg, "symbol", gv_ename(namegv), o2);
6823 if (o2->op_type == OP_ENTERSUB)
6826 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6829 if (o2->op_type == OP_RV2SV ||
6830 o2->op_type == OP_PADSV ||
6831 o2->op_type == OP_HELEM ||
6832 o2->op_type == OP_AELEM ||
6833 o2->op_type == OP_THREADSV)
6836 bad_type(arg, "scalar", gv_ename(namegv), o2);
6839 if (o2->op_type == OP_RV2AV ||
6840 o2->op_type == OP_PADAV)
6843 bad_type(arg, "array", gv_ename(namegv), o2);
6846 if (o2->op_type == OP_RV2HV ||
6847 o2->op_type == OP_PADHV)
6850 bad_type(arg, "hash", gv_ename(namegv), o2);
6855 OP* sib = kid->op_sibling;
6856 kid->op_sibling = 0;
6857 o2 = newUNOP(OP_REFGEN, 0, kid);
6858 o2->op_sibling = sib;
6859 prev->op_sibling = o2;
6861 if (contextclass && e) {
6876 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6877 gv_ename(namegv), SvPV((SV*)cv, n_a));
6882 mod(o2, OP_ENTERSUB);
6884 o2 = o2->op_sibling;
6886 if (proto && !optional &&
6887 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6888 return too_few_arguments(o, gv_ename(namegv));
6893 Perl_ck_svconst(pTHX_ OP *o)
6895 SvREADONLY_on(cSVOPo->op_sv);
6900 Perl_ck_trunc(pTHX_ OP *o)
6902 if (o->op_flags & OPf_KIDS) {
6903 SVOP *kid = (SVOP*)cUNOPo->op_first;
6905 if (kid->op_type == OP_NULL)
6906 kid = (SVOP*)kid->op_sibling;
6907 if (kid && kid->op_type == OP_CONST &&
6908 (kid->op_private & OPpCONST_BARE))
6910 o->op_flags |= OPf_SPECIAL;
6911 kid->op_private &= ~OPpCONST_STRICT;
6918 Perl_ck_substr(pTHX_ OP *o)
6921 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6922 OP *kid = cLISTOPo->op_first;
6924 if (kid->op_type == OP_NULL)
6925 kid = kid->op_sibling;
6927 kid->op_flags |= OPf_MOD;
6933 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6936 Perl_peep(pTHX_ register OP *o)
6938 register OP* oldop = 0;
6941 if (!o || o->op_seq)
6945 SAVEVPTR(PL_curcop);
6946 for (; o; o = o->op_next) {
6952 switch (o->op_type) {
6956 PL_curcop = ((COP*)o); /* for warnings */
6957 o->op_seq = PL_op_seqmax++;
6961 if (cSVOPo->op_private & OPpCONST_STRICT)
6962 no_bareword_allowed(o);
6964 /* Relocate sv to the pad for thread safety.
6965 * Despite being a "constant", the SV is written to,
6966 * for reference counts, sv_upgrade() etc. */
6968 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6969 if (SvPADTMP(cSVOPo->op_sv)) {
6970 /* If op_sv is already a PADTMP then it is being used by
6971 * some pad, so make a copy. */
6972 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6973 SvREADONLY_on(PL_curpad[ix]);
6974 SvREFCNT_dec(cSVOPo->op_sv);
6977 SvREFCNT_dec(PL_curpad[ix]);
6978 SvPADTMP_on(cSVOPo->op_sv);
6979 PL_curpad[ix] = cSVOPo->op_sv;
6980 /* XXX I don't know how this isn't readonly already. */
6981 SvREADONLY_on(PL_curpad[ix]);
6983 cSVOPo->op_sv = Nullsv;
6987 o->op_seq = PL_op_seqmax++;
6991 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6992 if (o->op_next->op_private & OPpTARGET_MY) {
6993 if (o->op_flags & OPf_STACKED) /* chained concats */
6994 goto ignore_optimization;
6996 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6997 o->op_targ = o->op_next->op_targ;
6998 o->op_next->op_targ = 0;
6999 o->op_private |= OPpTARGET_MY;
7002 op_null(o->op_next);
7004 ignore_optimization:
7005 o->op_seq = PL_op_seqmax++;
7008 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7009 o->op_seq = PL_op_seqmax++;
7010 break; /* Scalar stub must produce undef. List stub is noop */
7014 if (o->op_targ == OP_NEXTSTATE
7015 || o->op_targ == OP_DBSTATE
7016 || o->op_targ == OP_SETSTATE)
7018 PL_curcop = ((COP*)o);
7020 /* XXX: We avoid setting op_seq here to prevent later calls
7021 to peep() from mistakenly concluding that optimisation
7022 has already occurred. This doesn't fix the real problem,
7023 though (See 20010220.007). AMS 20010719 */
7024 if (oldop && o->op_next) {
7025 oldop->op_next = o->op_next;
7033 if (oldop && o->op_next) {
7034 oldop->op_next = o->op_next;
7037 o->op_seq = PL_op_seqmax++;
7041 if (o->op_next->op_type == OP_RV2SV) {
7042 if (!(o->op_next->op_private & OPpDEREF)) {
7043 op_null(o->op_next);
7044 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7046 o->op_next = o->op_next->op_next;
7047 o->op_type = OP_GVSV;
7048 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7051 else if (o->op_next->op_type == OP_RV2AV) {
7052 OP* pop = o->op_next->op_next;
7054 if (pop && pop->op_type == OP_CONST &&
7055 (PL_op = pop->op_next) &&
7056 pop->op_next->op_type == OP_AELEM &&
7057 !(pop->op_next->op_private &
7058 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7059 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7064 op_null(o->op_next);
7065 op_null(pop->op_next);
7067 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7068 o->op_next = pop->op_next->op_next;
7069 o->op_type = OP_AELEMFAST;
7070 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7071 o->op_private = (U8)i;
7076 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7078 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7079 /* XXX could check prototype here instead of just carping */
7080 SV *sv = sv_newmortal();
7081 gv_efullname3(sv, gv, Nullch);
7082 Perl_warner(aTHX_ WARN_PROTOTYPE,
7083 "%s() called too early to check prototype",
7087 else if (o->op_next->op_type == OP_READLINE
7088 && o->op_next->op_next->op_type == OP_CONCAT
7089 && (o->op_next->op_next->op_flags & OPf_STACKED))
7091 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7092 o->op_type = OP_RCATLINE;
7093 o->op_flags |= OPf_STACKED;
7094 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7095 op_null(o->op_next->op_next);
7096 op_null(o->op_next);
7099 o->op_seq = PL_op_seqmax++;
7110 o->op_seq = PL_op_seqmax++;
7111 while (cLOGOP->op_other->op_type == OP_NULL)
7112 cLOGOP->op_other = cLOGOP->op_other->op_next;
7113 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7118 o->op_seq = PL_op_seqmax++;
7119 while (cLOOP->op_redoop->op_type == OP_NULL)
7120 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7121 peep(cLOOP->op_redoop);
7122 while (cLOOP->op_nextop->op_type == OP_NULL)
7123 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7124 peep(cLOOP->op_nextop);
7125 while (cLOOP->op_lastop->op_type == OP_NULL)
7126 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7127 peep(cLOOP->op_lastop);
7133 o->op_seq = PL_op_seqmax++;
7134 while (cPMOP->op_pmreplstart &&
7135 cPMOP->op_pmreplstart->op_type == OP_NULL)
7136 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7137 peep(cPMOP->op_pmreplstart);
7141 o->op_seq = PL_op_seqmax++;
7142 if (ckWARN(WARN_SYNTAX) && o->op_next
7143 && o->op_next->op_type == OP_NEXTSTATE) {
7144 if (o->op_next->op_sibling &&
7145 o->op_next->op_sibling->op_type != OP_EXIT &&
7146 o->op_next->op_sibling->op_type != OP_WARN &&
7147 o->op_next->op_sibling->op_type != OP_DIE) {
7148 line_t oldline = CopLINE(PL_curcop);
7150 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7151 Perl_warner(aTHX_ WARN_EXEC,
7152 "Statement unlikely to be reached");
7153 Perl_warner(aTHX_ WARN_EXEC,
7154 "\t(Maybe you meant system() when you said exec()?)\n");
7155 CopLINE_set(PL_curcop, oldline);
7164 SV **svp, **indsvp, *sv;
7169 o->op_seq = PL_op_seqmax++;
7171 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7174 /* Make the CONST have a shared SV */
7175 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7176 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7177 key = SvPV(sv, keylen);
7178 lexname = newSVpvn_share(key,
7179 SvUTF8(sv) ? -(I32)keylen : keylen,
7185 if ((o->op_private & (OPpLVAL_INTRO)))
7188 rop = (UNOP*)((BINOP*)o)->op_first;
7189 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7191 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7192 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7194 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7195 if (!fields || !GvHV(*fields))
7197 key = SvPV(*svp, keylen);
7198 indsvp = hv_fetch(GvHV(*fields), key,
7199 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7201 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7202 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7204 ind = SvIV(*indsvp);
7206 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7207 rop->op_type = OP_RV2AV;
7208 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7209 o->op_type = OP_AELEM;
7210 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7212 if (SvREADONLY(*svp))
7214 SvFLAGS(sv) |= (SvFLAGS(*svp)
7215 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7225 SV **svp, **indsvp, *sv;
7229 SVOP *first_key_op, *key_op;
7231 o->op_seq = PL_op_seqmax++;
7232 if ((o->op_private & (OPpLVAL_INTRO))
7233 /* I bet there's always a pushmark... */
7234 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7235 /* hmmm, no optimization if list contains only one key. */
7237 rop = (UNOP*)((LISTOP*)o)->op_last;
7238 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7240 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7241 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7243 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7244 if (!fields || !GvHV(*fields))
7246 /* Again guessing that the pushmark can be jumped over.... */
7247 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7248 ->op_first->op_sibling;
7249 /* Check that the key list contains only constants. */
7250 for (key_op = first_key_op; key_op;
7251 key_op = (SVOP*)key_op->op_sibling)
7252 if (key_op->op_type != OP_CONST)
7256 rop->op_type = OP_RV2AV;
7257 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7258 o->op_type = OP_ASLICE;
7259 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7260 for (key_op = first_key_op; key_op;
7261 key_op = (SVOP*)key_op->op_sibling) {
7262 svp = cSVOPx_svp(key_op);
7263 key = SvPV(*svp, keylen);
7264 indsvp = hv_fetch(GvHV(*fields), key,
7265 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7267 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7268 "in variable %s of type %s",
7269 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7271 ind = SvIV(*indsvp);
7273 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7275 if (SvREADONLY(*svp))
7277 SvFLAGS(sv) |= (SvFLAGS(*svp)
7278 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7286 o->op_seq = PL_op_seqmax++;
7296 char* Perl_custom_op_name(pTHX_ OP* o)
7298 IV index = PTR2IV(o->op_ppaddr);
7302 if (!PL_custom_op_names) /* This probably shouldn't happen */
7303 return PL_op_name[OP_CUSTOM];
7305 keysv = sv_2mortal(newSViv(index));
7307 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7309 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7311 return SvPV_nolen(HeVAL(he));
7314 char* Perl_custom_op_desc(pTHX_ OP* o)
7316 IV index = PTR2IV(o->op_ppaddr);
7320 if (!PL_custom_op_descs)
7321 return PL_op_desc[OP_CUSTOM];
7323 keysv = sv_2mortal(newSViv(index));
7325 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7327 return PL_op_desc[OP_CUSTOM];
7329 return SvPV_nolen(HeVAL(he));
7335 /* Efficient sub that returns a constant scalar value. */
7337 const_sv_xsub(pTHX_ CV* cv)
7342 Perl_croak(aTHX_ "usage: %s::%s()",
7343 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7347 ST(0) = (SV*)XSANY.any_ptr;