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 curop = ((UNOP*)o)->op_first;
2526 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2533 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2535 if (!o || o->op_type != OP_LIST)
2536 o = newLISTOP(OP_LIST, 0, o, Nullop);
2538 o->op_flags &= ~OPf_WANT;
2540 if (!(PL_opargs[type] & OA_MARK))
2541 op_null(cLISTOPo->op_first);
2544 o->op_ppaddr = PL_ppaddr[type];
2545 o->op_flags |= flags;
2547 o = CHECKOP(type, o);
2548 if (o->op_type != type)
2551 return fold_constants(o);
2554 /* List constructors */
2557 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2565 if (first->op_type != type
2566 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2568 return newLISTOP(type, 0, first, last);
2571 if (first->op_flags & OPf_KIDS)
2572 ((LISTOP*)first)->op_last->op_sibling = last;
2574 first->op_flags |= OPf_KIDS;
2575 ((LISTOP*)first)->op_first = last;
2577 ((LISTOP*)first)->op_last = last;
2582 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2590 if (first->op_type != type)
2591 return prepend_elem(type, (OP*)first, (OP*)last);
2593 if (last->op_type != type)
2594 return append_elem(type, (OP*)first, (OP*)last);
2596 first->op_last->op_sibling = last->op_first;
2597 first->op_last = last->op_last;
2598 first->op_flags |= (last->op_flags & OPf_KIDS);
2606 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2614 if (last->op_type == type) {
2615 if (type == OP_LIST) { /* already a PUSHMARK there */
2616 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2617 ((LISTOP*)last)->op_first->op_sibling = first;
2618 if (!(first->op_flags & OPf_PARENS))
2619 last->op_flags &= ~OPf_PARENS;
2622 if (!(last->op_flags & OPf_KIDS)) {
2623 ((LISTOP*)last)->op_last = first;
2624 last->op_flags |= OPf_KIDS;
2626 first->op_sibling = ((LISTOP*)last)->op_first;
2627 ((LISTOP*)last)->op_first = first;
2629 last->op_flags |= OPf_KIDS;
2633 return newLISTOP(type, 0, first, last);
2639 Perl_newNULLLIST(pTHX)
2641 return newOP(OP_STUB, 0);
2645 Perl_force_list(pTHX_ OP *o)
2647 if (!o || o->op_type != OP_LIST)
2648 o = newLISTOP(OP_LIST, 0, o, Nullop);
2654 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2658 NewOp(1101, listop, 1, LISTOP);
2660 listop->op_type = type;
2661 listop->op_ppaddr = PL_ppaddr[type];
2664 listop->op_flags = flags;
2668 else if (!first && last)
2671 first->op_sibling = last;
2672 listop->op_first = first;
2673 listop->op_last = last;
2674 if (type == OP_LIST) {
2676 pushop = newOP(OP_PUSHMARK, 0);
2677 pushop->op_sibling = first;
2678 listop->op_first = pushop;
2679 listop->op_flags |= OPf_KIDS;
2681 listop->op_last = pushop;
2688 Perl_newOP(pTHX_ I32 type, I32 flags)
2691 NewOp(1101, o, 1, OP);
2693 o->op_ppaddr = PL_ppaddr[type];
2694 o->op_flags = flags;
2697 o->op_private = 0 + (flags >> 8);
2698 if (PL_opargs[type] & OA_RETSCALAR)
2700 if (PL_opargs[type] & OA_TARGET)
2701 o->op_targ = pad_alloc(type, SVs_PADTMP);
2702 return CHECKOP(type, o);
2706 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2711 first = newOP(OP_STUB, 0);
2712 if (PL_opargs[type] & OA_MARK)
2713 first = force_list(first);
2715 NewOp(1101, unop, 1, UNOP);
2716 unop->op_type = type;
2717 unop->op_ppaddr = PL_ppaddr[type];
2718 unop->op_first = first;
2719 unop->op_flags = flags | OPf_KIDS;
2720 unop->op_private = 1 | (flags >> 8);
2721 unop = (UNOP*) CHECKOP(type, unop);
2725 return fold_constants((OP *) unop);
2729 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2732 NewOp(1101, binop, 1, BINOP);
2735 first = newOP(OP_NULL, 0);
2737 binop->op_type = type;
2738 binop->op_ppaddr = PL_ppaddr[type];
2739 binop->op_first = first;
2740 binop->op_flags = flags | OPf_KIDS;
2743 binop->op_private = 1 | (flags >> 8);
2746 binop->op_private = 2 | (flags >> 8);
2747 first->op_sibling = last;
2750 binop = (BINOP*)CHECKOP(type, binop);
2751 if (binop->op_next || binop->op_type != type)
2754 binop->op_last = binop->op_first->op_sibling;
2756 return fold_constants((OP *)binop);
2760 uvcompare(const void *a, const void *b)
2762 if (*((UV *)a) < (*(UV *)b))
2764 if (*((UV *)a) > (*(UV *)b))
2766 if (*((UV *)a+1) < (*(UV *)b+1))
2768 if (*((UV *)a+1) > (*(UV *)b+1))
2774 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2776 SV *tstr = ((SVOP*)expr)->op_sv;
2777 SV *rstr = ((SVOP*)repl)->op_sv;
2780 U8 *t = (U8*)SvPV(tstr, tlen);
2781 U8 *r = (U8*)SvPV(rstr, rlen);
2788 register short *tbl;
2790 PL_hints |= HINT_BLOCK_SCOPE;
2791 complement = o->op_private & OPpTRANS_COMPLEMENT;
2792 del = o->op_private & OPpTRANS_DELETE;
2793 squash = o->op_private & OPpTRANS_SQUASH;
2796 o->op_private |= OPpTRANS_FROM_UTF;
2799 o->op_private |= OPpTRANS_TO_UTF;
2801 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2802 SV* listsv = newSVpvn("# comment\n",10);
2804 U8* tend = t + tlen;
2805 U8* rend = r + rlen;
2819 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2820 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2826 tsave = t = bytes_to_utf8(t, &len);
2829 if (!to_utf && rlen) {
2831 rsave = r = bytes_to_utf8(r, &len);
2835 /* There are several snags with this code on EBCDIC:
2836 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2837 2. scan_const() in toke.c has encoded chars in native encoding which makes
2838 ranges at least in EBCDIC 0..255 range the bottom odd.
2842 U8 tmpbuf[UTF8_MAXLEN+1];
2845 New(1109, cp, 2*tlen, UV);
2847 transv = newSVpvn("",0);
2849 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2851 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2853 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2857 cp[2*i+1] = cp[2*i];
2861 qsort(cp, i, 2*sizeof(UV), uvcompare);
2862 for (j = 0; j < i; j++) {
2864 diff = val - nextmin;
2866 t = uvuni_to_utf8(tmpbuf,nextmin);
2867 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2869 U8 range_mark = UTF_TO_NATIVE(0xff);
2870 t = uvuni_to_utf8(tmpbuf, val - 1);
2871 sv_catpvn(transv, (char *)&range_mark, 1);
2872 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2879 t = uvuni_to_utf8(tmpbuf,nextmin);
2880 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2882 U8 range_mark = UTF_TO_NATIVE(0xff);
2883 sv_catpvn(transv, (char *)&range_mark, 1);
2885 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2886 UNICODE_ALLOW_SUPER);
2887 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2888 t = (U8*)SvPVX(transv);
2889 tlen = SvCUR(transv);
2893 else if (!rlen && !del) {
2894 r = t; rlen = tlen; rend = tend;
2897 if ((!rlen && !del) || t == r ||
2898 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2900 o->op_private |= OPpTRANS_IDENTICAL;
2904 while (t < tend || tfirst <= tlast) {
2905 /* see if we need more "t" chars */
2906 if (tfirst > tlast) {
2907 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2909 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2911 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2918 /* now see if we need more "r" chars */
2919 if (rfirst > rlast) {
2921 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2923 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2925 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2934 rfirst = rlast = 0xffffffff;
2938 /* now see which range will peter our first, if either. */
2939 tdiff = tlast - tfirst;
2940 rdiff = rlast - rfirst;
2947 if (rfirst == 0xffffffff) {
2948 diff = tdiff; /* oops, pretend rdiff is infinite */
2950 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2951 (long)tfirst, (long)tlast);
2953 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2957 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2958 (long)tfirst, (long)(tfirst + diff),
2961 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2962 (long)tfirst, (long)rfirst);
2964 if (rfirst + diff > max)
2965 max = rfirst + diff;
2967 grows = (tfirst < rfirst &&
2968 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2980 else if (max > 0xff)
2985 Safefree(cPVOPo->op_pv);
2986 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2987 SvREFCNT_dec(listsv);
2989 SvREFCNT_dec(transv);
2991 if (!del && havefinal && rlen)
2992 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2993 newSVuv((UV)final), 0);
2996 o->op_private |= OPpTRANS_GROWS;
3008 tbl = (short*)cPVOPo->op_pv;
3010 Zero(tbl, 256, short);
3011 for (i = 0; i < tlen; i++)
3013 for (i = 0, j = 0; i < 256; i++) {
3024 if (i < 128 && r[j] >= 128)
3034 o->op_private |= OPpTRANS_IDENTICAL;
3039 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3040 tbl[0x100] = rlen - j;
3041 for (i=0; i < rlen - j; i++)
3042 tbl[0x101+i] = r[j+i];
3046 if (!rlen && !del) {
3049 o->op_private |= OPpTRANS_IDENTICAL;
3051 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3052 o->op_private |= OPpTRANS_IDENTICAL;
3054 for (i = 0; i < 256; i++)
3056 for (i = 0, j = 0; i < tlen; i++,j++) {
3059 if (tbl[t[i]] == -1)
3065 if (tbl[t[i]] == -1) {
3066 if (t[i] < 128 && r[j] >= 128)
3073 o->op_private |= OPpTRANS_GROWS;
3081 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3085 NewOp(1101, pmop, 1, PMOP);
3086 pmop->op_type = type;
3087 pmop->op_ppaddr = PL_ppaddr[type];
3088 pmop->op_flags = flags;
3089 pmop->op_private = 0 | (flags >> 8);
3091 if (PL_hints & HINT_RE_TAINT)
3092 pmop->op_pmpermflags |= PMf_RETAINT;
3093 if (PL_hints & HINT_LOCALE)
3094 pmop->op_pmpermflags |= PMf_LOCALE;
3095 pmop->op_pmflags = pmop->op_pmpermflags;
3100 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3101 repointer = av_pop((AV*)PL_regex_pad[0]);
3102 pmop->op_pmoffset = SvIV(repointer);
3103 SvREPADTMP_off(repointer);
3104 sv_setiv(repointer,0);
3106 repointer = newSViv(0);
3107 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3108 pmop->op_pmoffset = av_len(PL_regex_padav);
3109 PL_regex_pad = AvARRAY(PL_regex_padav);
3114 /* link into pm list */
3115 if (type != OP_TRANS && PL_curstash) {
3116 pmop->op_pmnext = HvPMROOT(PL_curstash);
3117 HvPMROOT(PL_curstash) = pmop;
3118 PmopSTASH_set(pmop,PL_curstash);
3125 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3129 I32 repl_has_vars = 0;
3131 if (o->op_type == OP_TRANS)
3132 return pmtrans(o, expr, repl);
3134 PL_hints |= HINT_BLOCK_SCOPE;
3137 if (expr->op_type == OP_CONST) {
3139 SV *pat = ((SVOP*)expr)->op_sv;
3140 char *p = SvPV(pat, plen);
3141 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3142 sv_setpvn(pat, "\\s+", 3);
3143 p = SvPV(pat, plen);
3144 pm->op_pmflags |= PMf_SKIPWHITE;
3147 pm->op_pmdynflags |= PMdf_UTF8;
3148 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3149 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3150 pm->op_pmflags |= PMf_WHITE;
3154 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3155 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3157 : OP_REGCMAYBE),0,expr);
3159 NewOp(1101, rcop, 1, LOGOP);
3160 rcop->op_type = OP_REGCOMP;
3161 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3162 rcop->op_first = scalar(expr);
3163 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3164 ? (OPf_SPECIAL | OPf_KIDS)
3166 rcop->op_private = 1;
3169 /* establish postfix order */
3170 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3172 rcop->op_next = expr;
3173 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3176 rcop->op_next = LINKLIST(expr);
3177 expr->op_next = (OP*)rcop;
3180 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3185 if (pm->op_pmflags & PMf_EVAL) {
3187 if (CopLINE(PL_curcop) < PL_multi_end)
3188 CopLINE_set(PL_curcop, PL_multi_end);
3190 #ifdef USE_5005THREADS
3191 else if (repl->op_type == OP_THREADSV
3192 && strchr("&`'123456789+",
3193 PL_threadsv_names[repl->op_targ]))
3197 #endif /* USE_5005THREADS */
3198 else if (repl->op_type == OP_CONST)
3202 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3203 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3204 #ifdef USE_5005THREADS
3205 if (curop->op_type == OP_THREADSV) {
3207 if (strchr("&`'123456789+", curop->op_private))
3211 if (curop->op_type == OP_GV) {
3212 GV *gv = cGVOPx_gv(curop);
3214 if (strchr("&`'123456789+", *GvENAME(gv)))
3217 #endif /* USE_5005THREADS */
3218 else if (curop->op_type == OP_RV2CV)
3220 else if (curop->op_type == OP_RV2SV ||
3221 curop->op_type == OP_RV2AV ||
3222 curop->op_type == OP_RV2HV ||
3223 curop->op_type == OP_RV2GV) {
3224 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3227 else if (curop->op_type == OP_PADSV ||
3228 curop->op_type == OP_PADAV ||
3229 curop->op_type == OP_PADHV ||
3230 curop->op_type == OP_PADANY) {
3233 else if (curop->op_type == OP_PUSHRE)
3234 ; /* Okay here, dangerous in newASSIGNOP */
3244 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3245 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3246 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3247 prepend_elem(o->op_type, scalar(repl), o);
3250 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3251 pm->op_pmflags |= PMf_MAYBE_CONST;
3252 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3254 NewOp(1101, rcop, 1, LOGOP);
3255 rcop->op_type = OP_SUBSTCONT;
3256 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3257 rcop->op_first = scalar(repl);
3258 rcop->op_flags |= OPf_KIDS;
3259 rcop->op_private = 1;
3262 /* establish postfix order */
3263 rcop->op_next = LINKLIST(repl);
3264 repl->op_next = (OP*)rcop;
3266 pm->op_pmreplroot = scalar((OP*)rcop);
3267 pm->op_pmreplstart = LINKLIST(rcop);
3276 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3279 NewOp(1101, svop, 1, SVOP);
3280 svop->op_type = type;
3281 svop->op_ppaddr = PL_ppaddr[type];
3283 svop->op_next = (OP*)svop;
3284 svop->op_flags = flags;
3285 if (PL_opargs[type] & OA_RETSCALAR)
3287 if (PL_opargs[type] & OA_TARGET)
3288 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3289 return CHECKOP(type, svop);
3293 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3296 NewOp(1101, padop, 1, PADOP);
3297 padop->op_type = type;
3298 padop->op_ppaddr = PL_ppaddr[type];
3299 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3300 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3301 PL_curpad[padop->op_padix] = sv;
3303 padop->op_next = (OP*)padop;
3304 padop->op_flags = flags;
3305 if (PL_opargs[type] & OA_RETSCALAR)
3307 if (PL_opargs[type] & OA_TARGET)
3308 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3309 return CHECKOP(type, padop);
3313 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3317 return newPADOP(type, flags, SvREFCNT_inc(gv));
3319 return newSVOP(type, flags, SvREFCNT_inc(gv));
3324 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3327 NewOp(1101, pvop, 1, PVOP);
3328 pvop->op_type = type;
3329 pvop->op_ppaddr = PL_ppaddr[type];
3331 pvop->op_next = (OP*)pvop;
3332 pvop->op_flags = flags;
3333 if (PL_opargs[type] & OA_RETSCALAR)
3335 if (PL_opargs[type] & OA_TARGET)
3336 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3337 return CHECKOP(type, pvop);
3341 Perl_package(pTHX_ OP *o)
3345 save_hptr(&PL_curstash);
3346 save_item(PL_curstname);
3351 name = SvPV(sv, len);
3352 PL_curstash = gv_stashpvn(name,len,TRUE);
3353 sv_setpvn(PL_curstname, name, len);
3357 deprecate("\"package\" with no arguments");
3358 sv_setpv(PL_curstname,"<none>");
3359 PL_curstash = Nullhv;
3361 PL_hints |= HINT_BLOCK_SCOPE;
3362 PL_copline = NOLINE;
3367 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3372 char *packname = Nullch;
3376 if (id->op_type != OP_CONST)
3377 Perl_croak(aTHX_ "Module name must be constant");
3381 if (version != Nullop) {
3382 SV *vesv = ((SVOP*)version)->op_sv;
3384 if (arg == Nullop && !SvNIOKp(vesv)) {
3391 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3392 Perl_croak(aTHX_ "Version number must be constant number");
3394 /* Make copy of id so we don't free it twice */
3395 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3397 /* Fake up a method call to VERSION */
3398 meth = newSVpvn("VERSION",7);
3399 sv_upgrade(meth, SVt_PVIV);
3400 (void)SvIOK_on(meth);
3401 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3402 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3403 append_elem(OP_LIST,
3404 prepend_elem(OP_LIST, pack, list(version)),
3405 newSVOP(OP_METHOD_NAMED, 0, meth)));
3409 /* Fake up an import/unimport */
3410 if (arg && arg->op_type == OP_STUB)
3411 imop = arg; /* no import on explicit () */
3412 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3413 imop = Nullop; /* use 5.0; */
3418 /* Make copy of id so we don't free it twice */
3419 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3421 /* Fake up a method call to import/unimport */
3422 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3423 (void)SvUPGRADE(meth, SVt_PVIV);
3424 (void)SvIOK_on(meth);
3425 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3426 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3427 append_elem(OP_LIST,
3428 prepend_elem(OP_LIST, pack, list(arg)),
3429 newSVOP(OP_METHOD_NAMED, 0, meth)));
3432 if (ckWARN(WARN_MISC) &&
3433 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3434 SvPOK(packsv = ((SVOP*)id)->op_sv))
3436 /* BEGIN will free the ops, so we need to make a copy */
3437 packlen = SvCUR(packsv);
3438 packname = savepvn(SvPVX(packsv), packlen);
3441 /* Fake up the BEGIN {}, which does its thing immediately. */
3443 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3446 append_elem(OP_LINESEQ,
3447 append_elem(OP_LINESEQ,
3448 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3449 newSTATEOP(0, Nullch, veop)),
3450 newSTATEOP(0, Nullch, imop) ));
3453 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3454 Perl_warner(aTHX_ WARN_MISC,
3455 "Package `%s' not found "
3456 "(did you use the incorrect case?)", packname);
3461 PL_hints |= HINT_BLOCK_SCOPE;
3462 PL_copline = NOLINE;
3467 =head1 Embedding Functions
3469 =for apidoc load_module
3471 Loads the module whose name is pointed to by the string part of name.
3472 Note that the actual module name, not its filename, should be given.
3473 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3474 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3475 (or 0 for no flags). ver, if specified, provides version semantics
3476 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3477 arguments can be used to specify arguments to the module's import()
3478 method, similar to C<use Foo::Bar VERSION LIST>.
3483 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3486 va_start(args, ver);
3487 vload_module(flags, name, ver, &args);
3491 #ifdef PERL_IMPLICIT_CONTEXT
3493 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3497 va_start(args, ver);
3498 vload_module(flags, name, ver, &args);
3504 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3506 OP *modname, *veop, *imop;
3508 modname = newSVOP(OP_CONST, 0, name);
3509 modname->op_private |= OPpCONST_BARE;
3511 veop = newSVOP(OP_CONST, 0, ver);
3515 if (flags & PERL_LOADMOD_NOIMPORT) {
3516 imop = sawparens(newNULLLIST());
3518 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3519 imop = va_arg(*args, OP*);
3524 sv = va_arg(*args, SV*);
3526 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3527 sv = va_arg(*args, SV*);
3531 line_t ocopline = PL_copline;
3532 int oexpect = PL_expect;
3534 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3535 veop, modname, imop);
3536 PL_expect = oexpect;
3537 PL_copline = ocopline;
3542 Perl_dofile(pTHX_ OP *term)
3547 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3548 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3549 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3551 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3552 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3553 append_elem(OP_LIST, term,
3554 scalar(newUNOP(OP_RV2CV, 0,
3559 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3565 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3567 return newBINOP(OP_LSLICE, flags,
3568 list(force_list(subscript)),
3569 list(force_list(listval)) );
3573 S_list_assignment(pTHX_ register OP *o)
3578 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3579 o = cUNOPo->op_first;
3581 if (o->op_type == OP_COND_EXPR) {
3582 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3583 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3588 yyerror("Assignment to both a list and a scalar");
3592 if (o->op_type == OP_LIST &&
3593 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3594 o->op_private & OPpLVAL_INTRO)
3597 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3598 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3599 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3602 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3605 if (o->op_type == OP_RV2SV)
3612 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3617 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3618 return newLOGOP(optype, 0,
3619 mod(scalar(left), optype),
3620 newUNOP(OP_SASSIGN, 0, scalar(right)));
3623 return newBINOP(optype, OPf_STACKED,
3624 mod(scalar(left), optype), scalar(right));
3628 if (list_assignment(left)) {
3632 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3633 left = mod(left, OP_AASSIGN);
3641 curop = list(force_list(left));
3642 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3643 o->op_private = 0 | (flags >> 8);
3644 for (curop = ((LISTOP*)curop)->op_first;
3645 curop; curop = curop->op_sibling)
3647 if (curop->op_type == OP_RV2HV &&
3648 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3649 o->op_private |= OPpASSIGN_HASH;
3653 if (!(left->op_private & OPpLVAL_INTRO)) {
3656 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3657 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3658 if (curop->op_type == OP_GV) {
3659 GV *gv = cGVOPx_gv(curop);
3660 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3662 SvCUR(gv) = PL_generation;
3664 else if (curop->op_type == OP_PADSV ||
3665 curop->op_type == OP_PADAV ||
3666 curop->op_type == OP_PADHV ||
3667 curop->op_type == OP_PADANY) {
3668 SV **svp = AvARRAY(PL_comppad_name);
3669 SV *sv = svp[curop->op_targ];
3670 if (SvCUR(sv) == PL_generation)
3672 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3674 else if (curop->op_type == OP_RV2CV)
3676 else if (curop->op_type == OP_RV2SV ||
3677 curop->op_type == OP_RV2AV ||
3678 curop->op_type == OP_RV2HV ||
3679 curop->op_type == OP_RV2GV) {
3680 if (lastop->op_type != OP_GV) /* funny deref? */
3683 else if (curop->op_type == OP_PUSHRE) {
3684 if (((PMOP*)curop)->op_pmreplroot) {
3686 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3688 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3690 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3692 SvCUR(gv) = PL_generation;
3701 o->op_private |= OPpASSIGN_COMMON;
3703 if (right && right->op_type == OP_SPLIT) {
3705 if ((tmpop = ((LISTOP*)right)->op_first) &&
3706 tmpop->op_type == OP_PUSHRE)
3708 PMOP *pm = (PMOP*)tmpop;
3709 if (left->op_type == OP_RV2AV &&
3710 !(left->op_private & OPpLVAL_INTRO) &&
3711 !(o->op_private & OPpASSIGN_COMMON) )
3713 tmpop = ((UNOP*)left)->op_first;
3714 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3716 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3717 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3719 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3720 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3722 pm->op_pmflags |= PMf_ONCE;
3723 tmpop = cUNOPo->op_first; /* to list (nulled) */
3724 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3725 tmpop->op_sibling = Nullop; /* don't free split */
3726 right->op_next = tmpop->op_next; /* fix starting loc */
3727 op_free(o); /* blow off assign */
3728 right->op_flags &= ~OPf_WANT;
3729 /* "I don't know and I don't care." */
3734 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3735 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3737 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3739 sv_setiv(sv, PL_modcount+1);
3747 right = newOP(OP_UNDEF, 0);
3748 if (right->op_type == OP_READLINE) {
3749 right->op_flags |= OPf_STACKED;
3750 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3753 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3754 o = newBINOP(OP_SASSIGN, flags,
3755 scalar(right), mod(scalar(left), OP_SASSIGN) );
3767 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3769 U32 seq = intro_my();
3772 NewOp(1101, cop, 1, COP);
3773 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3774 cop->op_type = OP_DBSTATE;
3775 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3778 cop->op_type = OP_NEXTSTATE;
3779 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3781 cop->op_flags = flags;
3782 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3784 cop->op_private |= NATIVE_HINTS;
3786 PL_compiling.op_private = cop->op_private;
3787 cop->op_next = (OP*)cop;
3790 cop->cop_label = label;
3791 PL_hints |= HINT_BLOCK_SCOPE;
3794 cop->cop_arybase = PL_curcop->cop_arybase;
3795 if (specialWARN(PL_curcop->cop_warnings))
3796 cop->cop_warnings = PL_curcop->cop_warnings ;
3798 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3799 if (specialCopIO(PL_curcop->cop_io))
3800 cop->cop_io = PL_curcop->cop_io;
3802 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3805 if (PL_copline == NOLINE)
3806 CopLINE_set(cop, CopLINE(PL_curcop));
3808 CopLINE_set(cop, PL_copline);
3809 PL_copline = NOLINE;
3812 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3814 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3816 CopSTASH_set(cop, PL_curstash);
3818 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3819 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3820 if (svp && *svp != &PL_sv_undef ) {
3821 (void)SvIOK_on(*svp);
3822 SvIVX(*svp) = PTR2IV(cop);
3826 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3829 /* "Introduce" my variables to visible status. */
3837 if (! PL_min_intro_pending)
3838 return PL_cop_seqmax;
3840 svp = AvARRAY(PL_comppad_name);
3841 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3842 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3843 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3844 SvNVX(sv) = (NV)PL_cop_seqmax;
3847 PL_min_intro_pending = 0;
3848 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3849 return PL_cop_seqmax++;
3853 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3855 return new_logop(type, flags, &first, &other);
3859 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3863 OP *first = *firstp;
3864 OP *other = *otherp;
3866 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3867 return newBINOP(type, flags, scalar(first), scalar(other));
3869 scalarboolean(first);
3870 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3871 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3872 if (type == OP_AND || type == OP_OR) {
3878 first = *firstp = cUNOPo->op_first;
3880 first->op_next = o->op_next;
3881 cUNOPo->op_first = Nullop;
3885 if (first->op_type == OP_CONST) {
3886 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3887 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3888 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3899 else if (first->op_type == OP_WANTARRAY) {
3905 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3906 OP *k1 = ((UNOP*)first)->op_first;
3907 OP *k2 = k1->op_sibling;
3909 switch (first->op_type)
3912 if (k2 && k2->op_type == OP_READLINE
3913 && (k2->op_flags & OPf_STACKED)
3914 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3916 warnop = k2->op_type;
3921 if (k1->op_type == OP_READDIR
3922 || k1->op_type == OP_GLOB
3923 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3924 || k1->op_type == OP_EACH)
3926 warnop = ((k1->op_type == OP_NULL)
3927 ? k1->op_targ : k1->op_type);
3932 line_t oldline = CopLINE(PL_curcop);
3933 CopLINE_set(PL_curcop, PL_copline);
3934 Perl_warner(aTHX_ WARN_MISC,
3935 "Value of %s%s can be \"0\"; test with defined()",
3937 ((warnop == OP_READLINE || warnop == OP_GLOB)
3938 ? " construct" : "() operator"));
3939 CopLINE_set(PL_curcop, oldline);
3946 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3947 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3949 NewOp(1101, logop, 1, LOGOP);
3951 logop->op_type = type;
3952 logop->op_ppaddr = PL_ppaddr[type];
3953 logop->op_first = first;
3954 logop->op_flags = flags | OPf_KIDS;
3955 logop->op_other = LINKLIST(other);
3956 logop->op_private = 1 | (flags >> 8);
3958 /* establish postfix order */
3959 logop->op_next = LINKLIST(first);
3960 first->op_next = (OP*)logop;
3961 first->op_sibling = other;
3963 o = newUNOP(OP_NULL, 0, (OP*)logop);
3970 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3977 return newLOGOP(OP_AND, 0, first, trueop);
3979 return newLOGOP(OP_OR, 0, first, falseop);
3981 scalarboolean(first);
3982 if (first->op_type == OP_CONST) {
3983 if (SvTRUE(((SVOP*)first)->op_sv)) {
3994 else if (first->op_type == OP_WANTARRAY) {
3998 NewOp(1101, logop, 1, LOGOP);
3999 logop->op_type = OP_COND_EXPR;
4000 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4001 logop->op_first = first;
4002 logop->op_flags = flags | OPf_KIDS;
4003 logop->op_private = 1 | (flags >> 8);
4004 logop->op_other = LINKLIST(trueop);
4005 logop->op_next = LINKLIST(falseop);
4008 /* establish postfix order */
4009 start = LINKLIST(first);
4010 first->op_next = (OP*)logop;
4012 first->op_sibling = trueop;
4013 trueop->op_sibling = falseop;
4014 o = newUNOP(OP_NULL, 0, (OP*)logop);
4016 trueop->op_next = falseop->op_next = o;
4023 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4031 NewOp(1101, range, 1, LOGOP);
4033 range->op_type = OP_RANGE;
4034 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4035 range->op_first = left;
4036 range->op_flags = OPf_KIDS;
4037 leftstart = LINKLIST(left);
4038 range->op_other = LINKLIST(right);
4039 range->op_private = 1 | (flags >> 8);
4041 left->op_sibling = right;
4043 range->op_next = (OP*)range;
4044 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4045 flop = newUNOP(OP_FLOP, 0, flip);
4046 o = newUNOP(OP_NULL, 0, flop);
4048 range->op_next = leftstart;
4050 left->op_next = flip;
4051 right->op_next = flop;
4053 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4054 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4055 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4056 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4058 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4059 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4062 if (!flip->op_private || !flop->op_private)
4063 linklist(o); /* blow off optimizer unless constant */
4069 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4073 int once = block && block->op_flags & OPf_SPECIAL &&
4074 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4077 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4078 return block; /* do {} while 0 does once */
4079 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4080 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4081 expr = newUNOP(OP_DEFINED, 0,
4082 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4083 } else if (expr->op_flags & OPf_KIDS) {
4084 OP *k1 = ((UNOP*)expr)->op_first;
4085 OP *k2 = (k1) ? k1->op_sibling : NULL;
4086 switch (expr->op_type) {
4088 if (k2 && k2->op_type == OP_READLINE
4089 && (k2->op_flags & OPf_STACKED)
4090 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4091 expr = newUNOP(OP_DEFINED, 0, expr);
4095 if (k1->op_type == OP_READDIR
4096 || k1->op_type == OP_GLOB
4097 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4098 || k1->op_type == OP_EACH)
4099 expr = newUNOP(OP_DEFINED, 0, expr);
4105 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4106 o = new_logop(OP_AND, 0, &expr, &listop);
4109 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4111 if (once && o != listop)
4112 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4115 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4117 o->op_flags |= flags;
4119 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4124 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4132 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4133 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4134 expr = newUNOP(OP_DEFINED, 0,
4135 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4136 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4137 OP *k1 = ((UNOP*)expr)->op_first;
4138 OP *k2 = (k1) ? k1->op_sibling : NULL;
4139 switch (expr->op_type) {
4141 if (k2 && k2->op_type == OP_READLINE
4142 && (k2->op_flags & OPf_STACKED)
4143 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4144 expr = newUNOP(OP_DEFINED, 0, expr);
4148 if (k1->op_type == OP_READDIR
4149 || k1->op_type == OP_GLOB
4150 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4151 || k1->op_type == OP_EACH)
4152 expr = newUNOP(OP_DEFINED, 0, expr);
4158 block = newOP(OP_NULL, 0);
4160 block = scope(block);
4164 next = LINKLIST(cont);
4167 OP *unstack = newOP(OP_UNSTACK, 0);
4170 cont = append_elem(OP_LINESEQ, cont, unstack);
4171 if ((line_t)whileline != NOLINE) {
4172 PL_copline = whileline;
4173 cont = append_elem(OP_LINESEQ, cont,
4174 newSTATEOP(0, Nullch, Nullop));
4178 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4179 redo = LINKLIST(listop);
4182 PL_copline = whileline;
4184 o = new_logop(OP_AND, 0, &expr, &listop);
4185 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4186 op_free(expr); /* oops, it's a while (0) */
4188 return Nullop; /* listop already freed by new_logop */
4191 ((LISTOP*)listop)->op_last->op_next =
4192 (o == listop ? redo : LINKLIST(o));
4198 NewOp(1101,loop,1,LOOP);
4199 loop->op_type = OP_ENTERLOOP;
4200 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4201 loop->op_private = 0;
4202 loop->op_next = (OP*)loop;
4205 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4207 loop->op_redoop = redo;
4208 loop->op_lastop = o;
4209 o->op_private |= loopflags;
4212 loop->op_nextop = next;
4214 loop->op_nextop = o;
4216 o->op_flags |= flags;
4217 o->op_private |= (flags >> 8);
4222 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4230 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4231 sv->op_type = OP_RV2GV;
4232 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4234 else if (sv->op_type == OP_PADSV) { /* private variable */
4235 padoff = sv->op_targ;
4240 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4241 padoff = sv->op_targ;
4243 iterflags |= OPf_SPECIAL;
4248 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4251 #ifdef USE_5005THREADS
4252 padoff = find_threadsv("_");
4253 iterflags |= OPf_SPECIAL;
4255 sv = newGVOP(OP_GV, 0, PL_defgv);
4258 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4259 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4260 iterflags |= OPf_STACKED;
4262 else if (expr->op_type == OP_NULL &&
4263 (expr->op_flags & OPf_KIDS) &&
4264 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4266 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4267 * set the STACKED flag to indicate that these values are to be
4268 * treated as min/max values by 'pp_iterinit'.
4270 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4271 LOGOP* range = (LOGOP*) flip->op_first;
4272 OP* left = range->op_first;
4273 OP* right = left->op_sibling;
4276 range->op_flags &= ~OPf_KIDS;
4277 range->op_first = Nullop;
4279 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4280 listop->op_first->op_next = range->op_next;
4281 left->op_next = range->op_other;
4282 right->op_next = (OP*)listop;
4283 listop->op_next = listop->op_first;
4286 expr = (OP*)(listop);
4288 iterflags |= OPf_STACKED;
4291 expr = mod(force_list(expr), OP_GREPSTART);
4295 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4296 append_elem(OP_LIST, expr, scalar(sv))));
4297 assert(!loop->op_next);
4298 #ifdef PL_OP_SLAB_ALLOC
4301 NewOp(1234,tmp,1,LOOP);
4302 Copy(loop,tmp,1,LOOP);
4307 Renew(loop, 1, LOOP);
4309 loop->op_targ = padoff;
4310 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4311 PL_copline = forline;
4312 return newSTATEOP(0, label, wop);
4316 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4321 if (type != OP_GOTO || label->op_type == OP_CONST) {
4322 /* "last()" means "last" */
4323 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4324 o = newOP(type, OPf_SPECIAL);
4326 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4327 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4333 if (label->op_type == OP_ENTERSUB)
4334 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4335 o = newUNOP(type, OPf_STACKED, label);
4337 PL_hints |= HINT_BLOCK_SCOPE;
4342 Perl_cv_undef(pTHX_ CV *cv)
4344 #ifdef USE_5005THREADS
4346 MUTEX_DESTROY(CvMUTEXP(cv));
4347 Safefree(CvMUTEXP(cv));
4350 #endif /* USE_5005THREADS */
4353 if (CvFILE(cv) && !CvXSUB(cv)) {
4354 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4355 Safefree(CvFILE(cv));
4360 if (!CvXSUB(cv) && CvROOT(cv)) {
4361 #ifdef USE_5005THREADS
4362 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4363 Perl_croak(aTHX_ "Can't undef active subroutine");
4366 Perl_croak(aTHX_ "Can't undef active subroutine");
4367 #endif /* USE_5005THREADS */
4370 SAVEVPTR(PL_curpad);
4373 op_free(CvROOT(cv));
4374 CvROOT(cv) = Nullop;
4377 SvPOK_off((SV*)cv); /* forget prototype */
4379 /* Since closure prototypes have the same lifetime as the containing
4380 * CV, they don't hold a refcount on the outside CV. This avoids
4381 * the refcount loop between the outer CV (which keeps a refcount to
4382 * the closure prototype in the pad entry for pp_anoncode()) and the
4383 * closure prototype, and the ensuing memory leak. --GSAR */
4384 if (!CvANON(cv) || CvCLONED(cv))
4385 SvREFCNT_dec(CvOUTSIDE(cv));
4386 CvOUTSIDE(cv) = Nullcv;
4388 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4391 if (CvPADLIST(cv)) {
4392 /* may be during global destruction */
4393 if (SvREFCNT(CvPADLIST(cv))) {
4394 I32 i = AvFILLp(CvPADLIST(cv));
4396 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4397 SV* sv = svp ? *svp : Nullsv;
4400 if (sv == (SV*)PL_comppad_name)
4401 PL_comppad_name = Nullav;
4402 else if (sv == (SV*)PL_comppad) {
4403 PL_comppad = Nullav;
4404 PL_curpad = Null(SV**);
4408 SvREFCNT_dec((SV*)CvPADLIST(cv));
4410 CvPADLIST(cv) = Nullav;
4418 #ifdef DEBUG_CLOSURES
4420 S_cv_dump(pTHX_ CV *cv)
4423 CV *outside = CvOUTSIDE(cv);
4424 AV* padlist = CvPADLIST(cv);
4431 PerlIO_printf(Perl_debug_log,
4432 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4434 (CvANON(cv) ? "ANON"
4435 : (cv == PL_main_cv) ? "MAIN"
4436 : CvUNIQUE(cv) ? "UNIQUE"
4437 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4440 : CvANON(outside) ? "ANON"
4441 : (outside == PL_main_cv) ? "MAIN"
4442 : CvUNIQUE(outside) ? "UNIQUE"
4443 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4448 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4449 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4450 pname = AvARRAY(pad_name);
4451 ppad = AvARRAY(pad);
4453 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4454 if (SvPOK(pname[ix]))
4455 PerlIO_printf(Perl_debug_log,
4456 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4457 (int)ix, PTR2UV(ppad[ix]),
4458 SvFAKE(pname[ix]) ? "FAKE " : "",
4460 (IV)I_32(SvNVX(pname[ix])),
4463 #endif /* DEBUGGING */
4465 #endif /* DEBUG_CLOSURES */
4468 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4472 AV* protopadlist = CvPADLIST(proto);
4473 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4474 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4475 SV** pname = AvARRAY(protopad_name);
4476 SV** ppad = AvARRAY(protopad);
4477 I32 fname = AvFILLp(protopad_name);
4478 I32 fpad = AvFILLp(protopad);
4482 assert(!CvUNIQUE(proto));
4486 SAVESPTR(PL_comppad_name);
4487 SAVESPTR(PL_compcv);
4489 cv = PL_compcv = (CV*)NEWSV(1104,0);
4490 sv_upgrade((SV *)cv, SvTYPE(proto));
4491 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4494 #ifdef USE_5005THREADS
4495 New(666, CvMUTEXP(cv), 1, perl_mutex);
4496 MUTEX_INIT(CvMUTEXP(cv));
4498 #endif /* USE_5005THREADS */
4500 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4501 : savepv(CvFILE(proto));
4503 CvFILE(cv) = CvFILE(proto);
4505 CvGV(cv) = CvGV(proto);
4506 CvSTASH(cv) = CvSTASH(proto);
4507 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4508 CvSTART(cv) = CvSTART(proto);
4510 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4513 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4515 PL_comppad_name = newAV();
4516 for (ix = fname; ix >= 0; ix--)
4517 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4519 PL_comppad = newAV();
4521 comppadlist = newAV();
4522 AvREAL_off(comppadlist);
4523 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4524 av_store(comppadlist, 1, (SV*)PL_comppad);
4525 CvPADLIST(cv) = comppadlist;
4526 av_fill(PL_comppad, AvFILLp(protopad));
4527 PL_curpad = AvARRAY(PL_comppad);
4529 av = newAV(); /* will be @_ */
4531 av_store(PL_comppad, 0, (SV*)av);
4532 AvFLAGS(av) = AVf_REIFY;
4534 for (ix = fpad; ix > 0; ix--) {
4535 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4536 if (namesv && namesv != &PL_sv_undef) {
4537 char *name = SvPVX(namesv); /* XXX */
4538 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4539 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4540 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4542 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4544 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4546 else { /* our own lexical */
4549 /* anon code -- we'll come back for it */
4550 sv = SvREFCNT_inc(ppad[ix]);
4552 else if (*name == '@')
4554 else if (*name == '%')
4563 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4564 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4567 SV* sv = NEWSV(0,0);
4573 /* Now that vars are all in place, clone nested closures. */
4575 for (ix = fpad; ix > 0; ix--) {
4576 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4578 && namesv != &PL_sv_undef
4579 && !(SvFLAGS(namesv) & SVf_FAKE)
4580 && *SvPVX(namesv) == '&'
4581 && CvCLONE(ppad[ix]))
4583 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4584 SvREFCNT_dec(ppad[ix]);
4587 PL_curpad[ix] = (SV*)kid;
4591 #ifdef DEBUG_CLOSURES
4592 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4594 PerlIO_printf(Perl_debug_log, " from:\n");
4596 PerlIO_printf(Perl_debug_log, " to:\n");
4603 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4605 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4607 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4614 Perl_cv_clone(pTHX_ CV *proto)
4617 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4618 cv = cv_clone2(proto, CvOUTSIDE(proto));
4619 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4624 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4626 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4627 SV* msg = sv_newmortal();
4631 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4632 sv_setpv(msg, "Prototype mismatch:");
4634 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4636 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4637 sv_catpv(msg, " vs ");
4639 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4641 sv_catpv(msg, "none");
4642 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4646 static void const_sv_xsub(pTHX_ CV* cv);
4650 =head1 Optree Manipulation Functions
4652 =for apidoc cv_const_sv
4654 If C<cv> is a constant sub eligible for inlining. returns the constant
4655 value returned by the sub. Otherwise, returns NULL.
4657 Constant subs can be created with C<newCONSTSUB> or as described in
4658 L<perlsub/"Constant Functions">.
4663 Perl_cv_const_sv(pTHX_ CV *cv)
4665 if (!cv || !CvCONST(cv))
4667 return (SV*)CvXSUBANY(cv).any_ptr;
4671 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4678 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4679 o = cLISTOPo->op_first->op_sibling;
4681 for (; o; o = o->op_next) {
4682 OPCODE type = o->op_type;
4684 if (sv && o->op_next == o)
4686 if (o->op_next != o) {
4687 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4689 if (type == OP_DBSTATE)
4692 if (type == OP_LEAVESUB || type == OP_RETURN)
4696 if (type == OP_CONST && cSVOPo->op_sv)
4698 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4699 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4700 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4704 /* We get here only from cv_clone2() while creating a closure.
4705 Copy the const value here instead of in cv_clone2 so that
4706 SvREADONLY_on doesn't lead to problems when leaving
4711 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4723 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4733 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4737 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4739 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4743 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4749 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4754 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4755 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4756 SV *sv = sv_newmortal();
4757 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4758 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4763 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4764 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4774 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4775 maximum a prototype before. */
4776 if (SvTYPE(gv) > SVt_NULL) {
4777 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4778 && ckWARN_d(WARN_PROTOTYPE))
4780 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4782 cv_ckproto((CV*)gv, NULL, ps);
4785 sv_setpv((SV*)gv, ps);
4787 sv_setiv((SV*)gv, -1);
4788 SvREFCNT_dec(PL_compcv);
4789 cv = PL_compcv = NULL;
4790 PL_sub_generation++;
4794 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4796 #ifdef GV_UNIQUE_CHECK
4797 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4798 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4802 if (!block || !ps || *ps || attrs)
4805 const_sv = op_const_sv(block, Nullcv);
4808 bool exists = CvROOT(cv) || CvXSUB(cv);
4810 #ifdef GV_UNIQUE_CHECK
4811 if (exists && GvUNIQUE(gv)) {
4812 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4816 /* if the subroutine doesn't exist and wasn't pre-declared
4817 * with a prototype, assume it will be AUTOLOADed,
4818 * skipping the prototype check
4820 if (exists || SvPOK(cv))
4821 cv_ckproto(cv, gv, ps);
4822 /* already defined (or promised)? */
4823 if (exists || GvASSUMECV(gv)) {
4824 if (!block && !attrs) {
4825 /* just a "sub foo;" when &foo is already defined */
4826 SAVEFREESV(PL_compcv);
4829 /* ahem, death to those who redefine active sort subs */
4830 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4831 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4833 if (ckWARN(WARN_REDEFINE)
4835 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4837 line_t oldline = CopLINE(PL_curcop);
4838 if (PL_copline != NOLINE)
4839 CopLINE_set(PL_curcop, PL_copline);
4840 Perl_warner(aTHX_ WARN_REDEFINE,
4841 CvCONST(cv) ? "Constant subroutine %s redefined"
4842 : "Subroutine %s redefined", name);
4843 CopLINE_set(PL_curcop, oldline);
4851 SvREFCNT_inc(const_sv);
4853 assert(!CvROOT(cv) && !CvCONST(cv));
4854 sv_setpv((SV*)cv, ""); /* prototype is "" */
4855 CvXSUBANY(cv).any_ptr = const_sv;
4856 CvXSUB(cv) = const_sv_xsub;
4861 cv = newCONSTSUB(NULL, name, const_sv);
4864 SvREFCNT_dec(PL_compcv);
4866 PL_sub_generation++;
4873 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4874 * before we clobber PL_compcv.
4878 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4879 stash = GvSTASH(CvGV(cv));
4880 else if (CvSTASH(cv))
4881 stash = CvSTASH(cv);
4883 stash = PL_curstash;
4886 /* possibly about to re-define existing subr -- ignore old cv */
4887 rcv = (SV*)PL_compcv;
4888 if (name && GvSTASH(gv))
4889 stash = GvSTASH(gv);
4891 stash = PL_curstash;
4893 apply_attrs(stash, rcv, attrs, FALSE);
4895 if (cv) { /* must reuse cv if autoloaded */
4897 /* got here with just attrs -- work done, so bug out */
4898 SAVEFREESV(PL_compcv);
4902 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4903 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4904 CvOUTSIDE(PL_compcv) = 0;
4905 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4906 CvPADLIST(PL_compcv) = 0;
4907 /* inner references to PL_compcv must be fixed up ... */
4909 AV *padlist = CvPADLIST(cv);
4910 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4911 AV *comppad = (AV*)AvARRAY(padlist)[1];
4912 SV **namepad = AvARRAY(comppad_name);
4913 SV **curpad = AvARRAY(comppad);
4914 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4915 SV *namesv = namepad[ix];
4916 if (namesv && namesv != &PL_sv_undef
4917 && *SvPVX(namesv) == '&')
4919 CV *innercv = (CV*)curpad[ix];
4920 if (CvOUTSIDE(innercv) == PL_compcv) {
4921 CvOUTSIDE(innercv) = cv;
4922 if (!CvANON(innercv) || CvCLONED(innercv)) {
4923 (void)SvREFCNT_inc(cv);
4924 SvREFCNT_dec(PL_compcv);
4930 /* ... before we throw it away */
4931 SvREFCNT_dec(PL_compcv);
4932 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4933 ++PL_sub_generation;
4940 PL_sub_generation++;
4944 CvFILE_set_from_cop(cv, PL_curcop);
4945 CvSTASH(cv) = PL_curstash;
4946 #ifdef USE_5005THREADS
4948 if (!CvMUTEXP(cv)) {
4949 New(666, CvMUTEXP(cv), 1, perl_mutex);
4950 MUTEX_INIT(CvMUTEXP(cv));
4952 #endif /* USE_5005THREADS */
4955 sv_setpv((SV*)cv, ps);
4957 if (PL_error_count) {
4961 char *s = strrchr(name, ':');
4963 if (strEQ(s, "BEGIN")) {
4965 "BEGIN not safe after errors--compilation aborted";
4966 if (PL_in_eval & EVAL_KEEPERR)
4967 Perl_croak(aTHX_ not_safe);
4969 /* force display of errors found but not reported */
4970 sv_catpv(ERRSV, not_safe);
4971 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4979 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4980 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4983 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4984 mod(scalarseq(block), OP_LEAVESUBLV));
4987 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4989 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4990 OpREFCNT_set(CvROOT(cv), 1);
4991 CvSTART(cv) = LINKLIST(CvROOT(cv));
4992 CvROOT(cv)->op_next = 0;
4993 CALL_PEEP(CvSTART(cv));
4995 /* now that optimizer has done its work, adjust pad values */
4997 SV **namep = AvARRAY(PL_comppad_name);
4998 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5001 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5004 * The only things that a clonable function needs in its
5005 * pad are references to outer lexicals and anonymous subs.
5006 * The rest are created anew during cloning.
5008 if (!((namesv = namep[ix]) != Nullsv &&
5009 namesv != &PL_sv_undef &&
5011 *SvPVX(namesv) == '&')))
5013 SvREFCNT_dec(PL_curpad[ix]);
5014 PL_curpad[ix] = Nullsv;
5017 assert(!CvCONST(cv));
5018 if (ps && !*ps && op_const_sv(block, cv))
5022 AV *av = newAV(); /* Will be @_ */
5024 av_store(PL_comppad, 0, (SV*)av);
5025 AvFLAGS(av) = AVf_REIFY;
5027 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5028 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5030 if (!SvPADMY(PL_curpad[ix]))
5031 SvPADTMP_on(PL_curpad[ix]);
5035 /* If a potential closure prototype, don't keep a refcount on outer CV.
5036 * This is okay as the lifetime of the prototype is tied to the
5037 * lifetime of the outer CV. Avoids memory leak due to reference
5040 SvREFCNT_dec(CvOUTSIDE(cv));
5042 if (name || aname) {
5044 char *tname = (name ? name : aname);
5046 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5047 SV *sv = NEWSV(0,0);
5048 SV *tmpstr = sv_newmortal();
5049 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5053 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5055 (long)PL_subline, (long)CopLINE(PL_curcop));
5056 gv_efullname3(tmpstr, gv, Nullch);
5057 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5058 hv = GvHVn(db_postponed);
5059 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5060 && (pcv = GvCV(db_postponed)))
5066 call_sv((SV*)pcv, G_DISCARD);
5070 if ((s = strrchr(tname,':')))
5075 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5078 if (strEQ(s, "BEGIN")) {
5079 I32 oldscope = PL_scopestack_ix;
5081 SAVECOPFILE(&PL_compiling);
5082 SAVECOPLINE(&PL_compiling);
5085 PL_beginav = newAV();
5086 DEBUG_x( dump_sub(gv) );
5087 av_push(PL_beginav, (SV*)cv);
5088 GvCV(gv) = 0; /* cv has been hijacked */
5089 call_list(oldscope, PL_beginav);
5091 PL_curcop = &PL_compiling;
5092 PL_compiling.op_private = PL_hints;
5095 else if (strEQ(s, "END") && !PL_error_count) {
5098 DEBUG_x( dump_sub(gv) );
5099 av_unshift(PL_endav, 1);
5100 av_store(PL_endav, 0, (SV*)cv);
5101 GvCV(gv) = 0; /* cv has been hijacked */
5103 else if (strEQ(s, "CHECK") && !PL_error_count) {
5105 PL_checkav = newAV();
5106 DEBUG_x( dump_sub(gv) );
5107 if (PL_main_start && ckWARN(WARN_VOID))
5108 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5109 av_unshift(PL_checkav, 1);
5110 av_store(PL_checkav, 0, (SV*)cv);
5111 GvCV(gv) = 0; /* cv has been hijacked */
5113 else if (strEQ(s, "INIT") && !PL_error_count) {
5115 PL_initav = newAV();
5116 DEBUG_x( dump_sub(gv) );
5117 if (PL_main_start && ckWARN(WARN_VOID))
5118 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5119 av_push(PL_initav, (SV*)cv);
5120 GvCV(gv) = 0; /* cv has been hijacked */
5125 PL_copline = NOLINE;
5130 /* XXX unsafe for threads if eval_owner isn't held */
5132 =for apidoc newCONSTSUB
5134 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5135 eligible for inlining at compile-time.
5141 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5147 SAVECOPLINE(PL_curcop);
5148 CopLINE_set(PL_curcop, PL_copline);
5151 PL_hints &= ~HINT_BLOCK_SCOPE;
5154 SAVESPTR(PL_curstash);
5155 SAVECOPSTASH(PL_curcop);
5156 PL_curstash = stash;
5157 CopSTASH_set(PL_curcop,stash);
5160 cv = newXS(name, const_sv_xsub, __FILE__);
5161 CvXSUBANY(cv).any_ptr = sv;
5163 sv_setpv((SV*)cv, ""); /* prototype is "" */
5171 =for apidoc U||newXS
5173 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5179 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5181 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5184 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5186 /* just a cached method */
5190 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5191 /* already defined (or promised) */
5192 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5193 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5194 line_t oldline = CopLINE(PL_curcop);
5195 if (PL_copline != NOLINE)
5196 CopLINE_set(PL_curcop, PL_copline);
5197 Perl_warner(aTHX_ WARN_REDEFINE,
5198 CvCONST(cv) ? "Constant subroutine %s redefined"
5199 : "Subroutine %s redefined"
5201 CopLINE_set(PL_curcop, oldline);
5208 if (cv) /* must reuse cv if autoloaded */
5211 cv = (CV*)NEWSV(1105,0);
5212 sv_upgrade((SV *)cv, SVt_PVCV);
5216 PL_sub_generation++;
5220 #ifdef USE_5005THREADS
5221 New(666, CvMUTEXP(cv), 1, perl_mutex);
5222 MUTEX_INIT(CvMUTEXP(cv));
5224 #endif /* USE_5005THREADS */
5225 (void)gv_fetchfile(filename);
5226 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5227 an external constant string */
5228 CvXSUB(cv) = subaddr;
5231 char *s = strrchr(name,':');
5237 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5240 if (strEQ(s, "BEGIN")) {
5242 PL_beginav = newAV();
5243 av_push(PL_beginav, (SV*)cv);
5244 GvCV(gv) = 0; /* cv has been hijacked */
5246 else if (strEQ(s, "END")) {
5249 av_unshift(PL_endav, 1);
5250 av_store(PL_endav, 0, (SV*)cv);
5251 GvCV(gv) = 0; /* cv has been hijacked */
5253 else if (strEQ(s, "CHECK")) {
5255 PL_checkav = newAV();
5256 if (PL_main_start && ckWARN(WARN_VOID))
5257 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5258 av_unshift(PL_checkav, 1);
5259 av_store(PL_checkav, 0, (SV*)cv);
5260 GvCV(gv) = 0; /* cv has been hijacked */
5262 else if (strEQ(s, "INIT")) {
5264 PL_initav = newAV();
5265 if (PL_main_start && ckWARN(WARN_VOID))
5266 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5267 av_push(PL_initav, (SV*)cv);
5268 GvCV(gv) = 0; /* cv has been hijacked */
5279 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5288 name = SvPVx(cSVOPo->op_sv, n_a);
5291 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5292 #ifdef GV_UNIQUE_CHECK
5294 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5298 if ((cv = GvFORM(gv))) {
5299 if (ckWARN(WARN_REDEFINE)) {
5300 line_t oldline = CopLINE(PL_curcop);
5301 if (PL_copline != NOLINE)
5302 CopLINE_set(PL_curcop, PL_copline);
5303 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5304 CopLINE_set(PL_curcop, oldline);
5311 CvFILE_set_from_cop(cv, PL_curcop);
5313 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5314 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5315 SvPADTMP_on(PL_curpad[ix]);
5318 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5319 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5320 OpREFCNT_set(CvROOT(cv), 1);
5321 CvSTART(cv) = LINKLIST(CvROOT(cv));
5322 CvROOT(cv)->op_next = 0;
5323 CALL_PEEP(CvSTART(cv));
5325 PL_copline = NOLINE;
5330 Perl_newANONLIST(pTHX_ OP *o)
5332 return newUNOP(OP_REFGEN, 0,
5333 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5337 Perl_newANONHASH(pTHX_ OP *o)
5339 return newUNOP(OP_REFGEN, 0,
5340 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5344 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5346 return newANONATTRSUB(floor, proto, Nullop, block);
5350 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5352 return newUNOP(OP_REFGEN, 0,
5353 newSVOP(OP_ANONCODE, 0,
5354 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5358 Perl_oopsAV(pTHX_ OP *o)
5360 switch (o->op_type) {
5362 o->op_type = OP_PADAV;
5363 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5364 return ref(o, OP_RV2AV);
5367 o->op_type = OP_RV2AV;
5368 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5373 if (ckWARN_d(WARN_INTERNAL))
5374 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5381 Perl_oopsHV(pTHX_ OP *o)
5383 switch (o->op_type) {
5386 o->op_type = OP_PADHV;
5387 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5388 return ref(o, OP_RV2HV);
5392 o->op_type = OP_RV2HV;
5393 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5398 if (ckWARN_d(WARN_INTERNAL))
5399 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5406 Perl_newAVREF(pTHX_ OP *o)
5408 if (o->op_type == OP_PADANY) {
5409 o->op_type = OP_PADAV;
5410 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5413 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5414 && ckWARN(WARN_DEPRECATED)) {
5415 Perl_warner(aTHX_ WARN_DEPRECATED,
5416 "Using an array as a reference is deprecated");
5418 return newUNOP(OP_RV2AV, 0, scalar(o));
5422 Perl_newGVREF(pTHX_ I32 type, OP *o)
5424 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5425 return newUNOP(OP_NULL, 0, o);
5426 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5430 Perl_newHVREF(pTHX_ OP *o)
5432 if (o->op_type == OP_PADANY) {
5433 o->op_type = OP_PADHV;
5434 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5437 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5438 && ckWARN(WARN_DEPRECATED)) {
5439 Perl_warner(aTHX_ WARN_DEPRECATED,
5440 "Using a hash as a reference is deprecated");
5442 return newUNOP(OP_RV2HV, 0, scalar(o));
5446 Perl_oopsCV(pTHX_ OP *o)
5448 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5454 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5456 return newUNOP(OP_RV2CV, flags, scalar(o));
5460 Perl_newSVREF(pTHX_ OP *o)
5462 if (o->op_type == OP_PADANY) {
5463 o->op_type = OP_PADSV;
5464 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5467 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5468 o->op_flags |= OPpDONE_SVREF;
5471 return newUNOP(OP_RV2SV, 0, scalar(o));
5474 /* Check routines. */
5477 Perl_ck_anoncode(pTHX_ OP *o)
5482 name = NEWSV(1106,0);
5483 sv_upgrade(name, SVt_PVNV);
5484 sv_setpvn(name, "&", 1);
5487 ix = pad_alloc(o->op_type, SVs_PADMY);
5488 av_store(PL_comppad_name, ix, name);
5489 av_store(PL_comppad, ix, cSVOPo->op_sv);
5490 SvPADMY_on(cSVOPo->op_sv);
5491 cSVOPo->op_sv = Nullsv;
5492 cSVOPo->op_targ = ix;
5497 Perl_ck_bitop(pTHX_ OP *o)
5499 o->op_private = PL_hints;
5504 Perl_ck_concat(pTHX_ OP *o)
5506 if (cUNOPo->op_first->op_type == OP_CONCAT)
5507 o->op_flags |= OPf_STACKED;
5512 Perl_ck_spair(pTHX_ OP *o)
5514 if (o->op_flags & OPf_KIDS) {
5517 OPCODE type = o->op_type;
5518 o = modkids(ck_fun(o), type);
5519 kid = cUNOPo->op_first;
5520 newop = kUNOP->op_first->op_sibling;
5522 (newop->op_sibling ||
5523 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5524 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5525 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5529 op_free(kUNOP->op_first);
5530 kUNOP->op_first = newop;
5532 o->op_ppaddr = PL_ppaddr[++o->op_type];
5537 Perl_ck_delete(pTHX_ OP *o)
5541 if (o->op_flags & OPf_KIDS) {
5542 OP *kid = cUNOPo->op_first;
5543 switch (kid->op_type) {
5545 o->op_flags |= OPf_SPECIAL;
5548 o->op_private |= OPpSLICE;
5551 o->op_flags |= OPf_SPECIAL;
5556 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5565 Perl_ck_die(pTHX_ OP *o)
5568 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5574 Perl_ck_eof(pTHX_ OP *o)
5576 I32 type = o->op_type;
5578 if (o->op_flags & OPf_KIDS) {
5579 if (cLISTOPo->op_first->op_type == OP_STUB) {
5581 o = newUNOP(type, OPf_SPECIAL,
5582 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5590 Perl_ck_eval(pTHX_ OP *o)
5592 PL_hints |= HINT_BLOCK_SCOPE;
5593 if (o->op_flags & OPf_KIDS) {
5594 SVOP *kid = (SVOP*)cUNOPo->op_first;
5597 o->op_flags &= ~OPf_KIDS;
5600 else if (kid->op_type == OP_LINESEQ) {
5603 kid->op_next = o->op_next;
5604 cUNOPo->op_first = 0;
5607 NewOp(1101, enter, 1, LOGOP);
5608 enter->op_type = OP_ENTERTRY;
5609 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5610 enter->op_private = 0;
5612 /* establish postfix order */
5613 enter->op_next = (OP*)enter;
5615 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5616 o->op_type = OP_LEAVETRY;
5617 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5618 enter->op_other = o;
5626 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5628 o->op_targ = (PADOFFSET)PL_hints;
5633 Perl_ck_exit(pTHX_ OP *o)
5636 HV *table = GvHV(PL_hintgv);
5638 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5639 if (svp && *svp && SvTRUE(*svp))
5640 o->op_private |= OPpEXIT_VMSISH;
5642 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5648 Perl_ck_exec(pTHX_ OP *o)
5651 if (o->op_flags & OPf_STACKED) {
5653 kid = cUNOPo->op_first->op_sibling;
5654 if (kid->op_type == OP_RV2GV)
5663 Perl_ck_exists(pTHX_ OP *o)
5666 if (o->op_flags & OPf_KIDS) {
5667 OP *kid = cUNOPo->op_first;
5668 if (kid->op_type == OP_ENTERSUB) {
5669 (void) ref(kid, o->op_type);
5670 if (kid->op_type != OP_RV2CV && !PL_error_count)
5671 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5673 o->op_private |= OPpEXISTS_SUB;
5675 else if (kid->op_type == OP_AELEM)
5676 o->op_flags |= OPf_SPECIAL;
5677 else if (kid->op_type != OP_HELEM)
5678 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5687 Perl_ck_gvconst(pTHX_ register OP *o)
5689 o = fold_constants(o);
5690 if (o->op_type == OP_CONST)
5697 Perl_ck_rvconst(pTHX_ register OP *o)
5699 SVOP *kid = (SVOP*)cUNOPo->op_first;
5701 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5702 if (kid->op_type == OP_CONST) {
5706 SV *kidsv = kid->op_sv;
5709 /* Is it a constant from cv_const_sv()? */
5710 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5711 SV *rsv = SvRV(kidsv);
5712 int svtype = SvTYPE(rsv);
5713 char *badtype = Nullch;
5715 switch (o->op_type) {
5717 if (svtype > SVt_PVMG)
5718 badtype = "a SCALAR";
5721 if (svtype != SVt_PVAV)
5722 badtype = "an ARRAY";
5725 if (svtype != SVt_PVHV) {
5726 if (svtype == SVt_PVAV) { /* pseudohash? */
5727 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5728 if (ksv && SvROK(*ksv)
5729 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5738 if (svtype != SVt_PVCV)
5743 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5746 name = SvPV(kidsv, n_a);
5747 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5748 char *badthing = Nullch;
5749 switch (o->op_type) {
5751 badthing = "a SCALAR";
5754 badthing = "an ARRAY";
5757 badthing = "a HASH";
5762 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5766 * This is a little tricky. We only want to add the symbol if we
5767 * didn't add it in the lexer. Otherwise we get duplicate strict
5768 * warnings. But if we didn't add it in the lexer, we must at
5769 * least pretend like we wanted to add it even if it existed before,
5770 * or we get possible typo warnings. OPpCONST_ENTERED says
5771 * whether the lexer already added THIS instance of this symbol.
5773 iscv = (o->op_type == OP_RV2CV) * 2;
5775 gv = gv_fetchpv(name,
5776 iscv | !(kid->op_private & OPpCONST_ENTERED),
5779 : o->op_type == OP_RV2SV
5781 : o->op_type == OP_RV2AV
5783 : o->op_type == OP_RV2HV
5786 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5788 kid->op_type = OP_GV;
5789 SvREFCNT_dec(kid->op_sv);
5791 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5792 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5793 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5795 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5797 kid->op_sv = SvREFCNT_inc(gv);
5799 kid->op_private = 0;
5800 kid->op_ppaddr = PL_ppaddr[OP_GV];
5807 Perl_ck_ftst(pTHX_ OP *o)
5809 I32 type = o->op_type;
5811 if (o->op_flags & OPf_REF) {
5814 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5815 SVOP *kid = (SVOP*)cUNOPo->op_first;
5817 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5819 OP *newop = newGVOP(type, OPf_REF,
5820 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5827 if (type == OP_FTTTY)
5828 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5831 o = newUNOP(type, 0, newDEFSVOP());
5837 Perl_ck_fun(pTHX_ OP *o)
5843 int type = o->op_type;
5844 register I32 oa = PL_opargs[type] >> OASHIFT;
5846 if (o->op_flags & OPf_STACKED) {
5847 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5850 return no_fh_allowed(o);
5853 if (o->op_flags & OPf_KIDS) {
5855 tokid = &cLISTOPo->op_first;
5856 kid = cLISTOPo->op_first;
5857 if (kid->op_type == OP_PUSHMARK ||
5858 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5860 tokid = &kid->op_sibling;
5861 kid = kid->op_sibling;
5863 if (!kid && PL_opargs[type] & OA_DEFGV)
5864 *tokid = kid = newDEFSVOP();
5868 sibl = kid->op_sibling;
5871 /* list seen where single (scalar) arg expected? */
5872 if (numargs == 1 && !(oa >> 4)
5873 && kid->op_type == OP_LIST && type != OP_SCALAR)
5875 return too_many_arguments(o,PL_op_desc[type]);
5888 if ((type == OP_PUSH || type == OP_UNSHIFT)
5889 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5890 Perl_warner(aTHX_ WARN_SYNTAX,
5891 "Useless use of %s with no values",
5894 if (kid->op_type == OP_CONST &&
5895 (kid->op_private & OPpCONST_BARE))
5897 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5898 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5899 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5900 if (ckWARN(WARN_DEPRECATED))
5901 Perl_warner(aTHX_ WARN_DEPRECATED,
5902 "Array @%s missing the @ in argument %"IVdf" of %s()",
5903 name, (IV)numargs, PL_op_desc[type]);
5906 kid->op_sibling = sibl;
5909 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5910 bad_type(numargs, "array", PL_op_desc[type], kid);
5914 if (kid->op_type == OP_CONST &&
5915 (kid->op_private & OPpCONST_BARE))
5917 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5918 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5919 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5920 if (ckWARN(WARN_DEPRECATED))
5921 Perl_warner(aTHX_ WARN_DEPRECATED,
5922 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5923 name, (IV)numargs, PL_op_desc[type]);
5926 kid->op_sibling = sibl;
5929 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5930 bad_type(numargs, "hash", PL_op_desc[type], kid);
5935 OP *newop = newUNOP(OP_NULL, 0, kid);
5936 kid->op_sibling = 0;
5938 newop->op_next = newop;
5940 kid->op_sibling = sibl;
5945 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5946 if (kid->op_type == OP_CONST &&
5947 (kid->op_private & OPpCONST_BARE))
5949 OP *newop = newGVOP(OP_GV, 0,
5950 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5952 if (kid == cLISTOPo->op_last)
5953 cLISTOPo->op_last = newop;
5957 else if (kid->op_type == OP_READLINE) {
5958 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5959 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5962 I32 flags = OPf_SPECIAL;
5966 /* is this op a FH constructor? */
5967 if (is_handle_constructor(o,numargs)) {
5968 char *name = Nullch;
5972 /* Set a flag to tell rv2gv to vivify
5973 * need to "prove" flag does not mean something
5974 * else already - NI-S 1999/05/07
5977 if (kid->op_type == OP_PADSV) {
5978 SV **namep = av_fetch(PL_comppad_name,
5980 if (namep && *namep)
5981 name = SvPV(*namep, len);
5983 else if (kid->op_type == OP_RV2SV
5984 && kUNOP->op_first->op_type == OP_GV)
5986 GV *gv = cGVOPx_gv(kUNOP->op_first);
5988 len = GvNAMELEN(gv);
5990 else if (kid->op_type == OP_AELEM
5991 || kid->op_type == OP_HELEM)
5993 name = "__ANONIO__";
5999 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6000 namesv = PL_curpad[targ];
6001 (void)SvUPGRADE(namesv, SVt_PV);
6003 sv_setpvn(namesv, "$", 1);
6004 sv_catpvn(namesv, name, len);
6007 kid->op_sibling = 0;
6008 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6009 kid->op_targ = targ;
6010 kid->op_private |= priv;
6012 kid->op_sibling = sibl;
6018 mod(scalar(kid), type);
6022 tokid = &kid->op_sibling;
6023 kid = kid->op_sibling;
6025 o->op_private |= numargs;
6027 return too_many_arguments(o,OP_DESC(o));
6030 else if (PL_opargs[type] & OA_DEFGV) {
6032 return newUNOP(type, 0, newDEFSVOP());
6036 while (oa & OA_OPTIONAL)
6038 if (oa && oa != OA_LIST)
6039 return too_few_arguments(o,OP_DESC(o));
6045 Perl_ck_glob(pTHX_ OP *o)
6050 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6051 append_elem(OP_GLOB, o, newDEFSVOP());
6053 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6054 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6056 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6059 #if !defined(PERL_EXTERNAL_GLOB)
6060 /* XXX this can be tightened up and made more failsafe. */
6064 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6065 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6066 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6067 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6068 GvCV(gv) = GvCV(glob_gv);
6069 SvREFCNT_inc((SV*)GvCV(gv));
6070 GvIMPORTED_CV_on(gv);
6073 #endif /* PERL_EXTERNAL_GLOB */
6075 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6076 append_elem(OP_GLOB, o,
6077 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6078 o->op_type = OP_LIST;
6079 o->op_ppaddr = PL_ppaddr[OP_LIST];
6080 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6081 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6082 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6083 append_elem(OP_LIST, o,
6084 scalar(newUNOP(OP_RV2CV, 0,
6085 newGVOP(OP_GV, 0, gv)))));
6086 o = newUNOP(OP_NULL, 0, ck_subr(o));
6087 o->op_targ = OP_GLOB; /* hint at what it used to be */
6090 gv = newGVgen("main");
6092 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6098 Perl_ck_grep(pTHX_ OP *o)
6102 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6104 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6105 NewOp(1101, gwop, 1, LOGOP);
6107 if (o->op_flags & OPf_STACKED) {
6110 kid = cLISTOPo->op_first->op_sibling;
6111 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6114 kid->op_next = (OP*)gwop;
6115 o->op_flags &= ~OPf_STACKED;
6117 kid = cLISTOPo->op_first->op_sibling;
6118 if (type == OP_MAPWHILE)
6125 kid = cLISTOPo->op_first->op_sibling;
6126 if (kid->op_type != OP_NULL)
6127 Perl_croak(aTHX_ "panic: ck_grep");
6128 kid = kUNOP->op_first;
6130 gwop->op_type = type;
6131 gwop->op_ppaddr = PL_ppaddr[type];
6132 gwop->op_first = listkids(o);
6133 gwop->op_flags |= OPf_KIDS;
6134 gwop->op_private = 1;
6135 gwop->op_other = LINKLIST(kid);
6136 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6137 kid->op_next = (OP*)gwop;
6139 kid = cLISTOPo->op_first->op_sibling;
6140 if (!kid || !kid->op_sibling)
6141 return too_few_arguments(o,OP_DESC(o));
6142 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6143 mod(kid, OP_GREPSTART);
6149 Perl_ck_index(pTHX_ OP *o)
6151 if (o->op_flags & OPf_KIDS) {
6152 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6154 kid = kid->op_sibling; /* get past "big" */
6155 if (kid && kid->op_type == OP_CONST)
6156 fbm_compile(((SVOP*)kid)->op_sv, 0);
6162 Perl_ck_lengthconst(pTHX_ OP *o)
6164 /* XXX length optimization goes here */
6169 Perl_ck_lfun(pTHX_ OP *o)
6171 OPCODE type = o->op_type;
6172 return modkids(ck_fun(o), type);
6176 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6178 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6179 switch (cUNOPo->op_first->op_type) {
6181 /* This is needed for
6182 if (defined %stash::)
6183 to work. Do not break Tk.
6185 break; /* Globals via GV can be undef */
6187 case OP_AASSIGN: /* Is this a good idea? */
6188 Perl_warner(aTHX_ WARN_DEPRECATED,
6189 "defined(@array) is deprecated");
6190 Perl_warner(aTHX_ WARN_DEPRECATED,
6191 "\t(Maybe you should just omit the defined()?)\n");
6194 /* This is needed for
6195 if (defined %stash::)
6196 to work. Do not break Tk.
6198 break; /* Globals via GV can be undef */
6200 Perl_warner(aTHX_ WARN_DEPRECATED,
6201 "defined(%%hash) is deprecated");
6202 Perl_warner(aTHX_ WARN_DEPRECATED,
6203 "\t(Maybe you should just omit the defined()?)\n");
6214 Perl_ck_rfun(pTHX_ OP *o)
6216 OPCODE type = o->op_type;
6217 return refkids(ck_fun(o), type);
6221 Perl_ck_listiob(pTHX_ OP *o)
6225 kid = cLISTOPo->op_first;
6228 kid = cLISTOPo->op_first;
6230 if (kid->op_type == OP_PUSHMARK)
6231 kid = kid->op_sibling;
6232 if (kid && o->op_flags & OPf_STACKED)
6233 kid = kid->op_sibling;
6234 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6235 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6236 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6237 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6238 cLISTOPo->op_first->op_sibling = kid;
6239 cLISTOPo->op_last = kid;
6240 kid = kid->op_sibling;
6245 append_elem(o->op_type, o, newDEFSVOP());
6251 Perl_ck_sassign(pTHX_ OP *o)
6253 OP *kid = cLISTOPo->op_first;
6254 /* has a disposable target? */
6255 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6256 && !(kid->op_flags & OPf_STACKED)
6257 /* Cannot steal the second time! */
6258 && !(kid->op_private & OPpTARGET_MY))
6260 OP *kkid = kid->op_sibling;
6262 /* Can just relocate the target. */
6263 if (kkid && kkid->op_type == OP_PADSV
6264 && !(kkid->op_private & OPpLVAL_INTRO))
6266 kid->op_targ = kkid->op_targ;
6268 /* Now we do not need PADSV and SASSIGN. */
6269 kid->op_sibling = o->op_sibling; /* NULL */
6270 cLISTOPo->op_first = NULL;
6273 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6281 Perl_ck_match(pTHX_ OP *o)
6283 o->op_private |= OPpRUNTIME;
6288 Perl_ck_method(pTHX_ OP *o)
6290 OP *kid = cUNOPo->op_first;
6291 if (kid->op_type == OP_CONST) {
6292 SV* sv = kSVOP->op_sv;
6293 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6295 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6296 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6299 kSVOP->op_sv = Nullsv;
6301 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6310 Perl_ck_null(pTHX_ OP *o)
6316 Perl_ck_open(pTHX_ OP *o)
6318 HV *table = GvHV(PL_hintgv);
6322 svp = hv_fetch(table, "open_IN", 7, FALSE);
6324 mode = mode_from_discipline(*svp);
6325 if (mode & O_BINARY)
6326 o->op_private |= OPpOPEN_IN_RAW;
6327 else if (mode & O_TEXT)
6328 o->op_private |= OPpOPEN_IN_CRLF;
6331 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6333 mode = mode_from_discipline(*svp);
6334 if (mode & O_BINARY)
6335 o->op_private |= OPpOPEN_OUT_RAW;
6336 else if (mode & O_TEXT)
6337 o->op_private |= OPpOPEN_OUT_CRLF;
6340 if (o->op_type == OP_BACKTICK)
6346 Perl_ck_repeat(pTHX_ OP *o)
6348 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6349 o->op_private |= OPpREPEAT_DOLIST;
6350 cBINOPo->op_first = force_list(cBINOPo->op_first);
6358 Perl_ck_require(pTHX_ OP *o)
6362 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6363 SVOP *kid = (SVOP*)cUNOPo->op_first;
6365 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6367 for (s = SvPVX(kid->op_sv); *s; s++) {
6368 if (*s == ':' && s[1] == ':') {
6370 Move(s+2, s+1, strlen(s+2)+1, char);
6371 --SvCUR(kid->op_sv);
6374 if (SvREADONLY(kid->op_sv)) {
6375 SvREADONLY_off(kid->op_sv);
6376 sv_catpvn(kid->op_sv, ".pm", 3);
6377 SvREADONLY_on(kid->op_sv);
6380 sv_catpvn(kid->op_sv, ".pm", 3);
6384 /* handle override, if any */
6385 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6386 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6387 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6389 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6390 OP *kid = cUNOPo->op_first;
6391 cUNOPo->op_first = 0;
6393 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6394 append_elem(OP_LIST, kid,
6395 scalar(newUNOP(OP_RV2CV, 0,
6404 Perl_ck_return(pTHX_ OP *o)
6407 if (CvLVALUE(PL_compcv)) {
6408 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6409 mod(kid, OP_LEAVESUBLV);
6416 Perl_ck_retarget(pTHX_ OP *o)
6418 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6425 Perl_ck_select(pTHX_ OP *o)
6428 if (o->op_flags & OPf_KIDS) {
6429 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6430 if (kid && kid->op_sibling) {
6431 o->op_type = OP_SSELECT;
6432 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6434 return fold_constants(o);
6438 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6439 if (kid && kid->op_type == OP_RV2GV)
6440 kid->op_private &= ~HINT_STRICT_REFS;
6445 Perl_ck_shift(pTHX_ OP *o)
6447 I32 type = o->op_type;
6449 if (!(o->op_flags & OPf_KIDS)) {
6453 #ifdef USE_5005THREADS
6454 if (!CvUNIQUE(PL_compcv)) {
6455 argop = newOP(OP_PADAV, OPf_REF);
6456 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6459 argop = newUNOP(OP_RV2AV, 0,
6460 scalar(newGVOP(OP_GV, 0,
6461 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6464 argop = newUNOP(OP_RV2AV, 0,
6465 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6466 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6467 #endif /* USE_5005THREADS */
6468 return newUNOP(type, 0, scalar(argop));
6470 return scalar(modkids(ck_fun(o), type));
6474 Perl_ck_sort(pTHX_ OP *o)
6478 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6480 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6481 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6483 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6485 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6487 if (kid->op_type == OP_SCOPE) {
6491 else if (kid->op_type == OP_LEAVE) {
6492 if (o->op_type == OP_SORT) {
6493 op_null(kid); /* wipe out leave */
6496 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6497 if (k->op_next == kid)
6499 /* don't descend into loops */
6500 else if (k->op_type == OP_ENTERLOOP
6501 || k->op_type == OP_ENTERITER)
6503 k = cLOOPx(k)->op_lastop;
6508 kid->op_next = 0; /* just disconnect the leave */
6509 k = kLISTOP->op_first;
6514 if (o->op_type == OP_SORT) {
6515 /* provide scalar context for comparison function/block */
6521 o->op_flags |= OPf_SPECIAL;
6523 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6526 firstkid = firstkid->op_sibling;
6529 /* provide list context for arguments */
6530 if (o->op_type == OP_SORT)
6537 S_simplify_sort(pTHX_ OP *o)
6539 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6543 if (!(o->op_flags & OPf_STACKED))
6545 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6546 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6547 kid = kUNOP->op_first; /* get past null */
6548 if (kid->op_type != OP_SCOPE)
6550 kid = kLISTOP->op_last; /* get past scope */
6551 switch(kid->op_type) {
6559 k = kid; /* remember this node*/
6560 if (kBINOP->op_first->op_type != OP_RV2SV)
6562 kid = kBINOP->op_first; /* get past cmp */
6563 if (kUNOP->op_first->op_type != OP_GV)
6565 kid = kUNOP->op_first; /* get past rv2sv */
6567 if (GvSTASH(gv) != PL_curstash)
6569 if (strEQ(GvNAME(gv), "a"))
6571 else if (strEQ(GvNAME(gv), "b"))
6575 kid = k; /* back to cmp */
6576 if (kBINOP->op_last->op_type != OP_RV2SV)
6578 kid = kBINOP->op_last; /* down to 2nd arg */
6579 if (kUNOP->op_first->op_type != OP_GV)
6581 kid = kUNOP->op_first; /* get past rv2sv */
6583 if (GvSTASH(gv) != PL_curstash
6585 ? strNE(GvNAME(gv), "a")
6586 : strNE(GvNAME(gv), "b")))
6588 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6590 o->op_private |= OPpSORT_REVERSE;
6591 if (k->op_type == OP_NCMP)
6592 o->op_private |= OPpSORT_NUMERIC;
6593 if (k->op_type == OP_I_NCMP)
6594 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6595 kid = cLISTOPo->op_first->op_sibling;
6596 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6597 op_free(kid); /* then delete it */
6601 Perl_ck_split(pTHX_ OP *o)
6605 if (o->op_flags & OPf_STACKED)
6606 return no_fh_allowed(o);
6608 kid = cLISTOPo->op_first;
6609 if (kid->op_type != OP_NULL)
6610 Perl_croak(aTHX_ "panic: ck_split");
6611 kid = kid->op_sibling;
6612 op_free(cLISTOPo->op_first);
6613 cLISTOPo->op_first = kid;
6615 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6616 cLISTOPo->op_last = kid; /* There was only one element previously */
6619 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6620 OP *sibl = kid->op_sibling;
6621 kid->op_sibling = 0;
6622 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6623 if (cLISTOPo->op_first == cLISTOPo->op_last)
6624 cLISTOPo->op_last = kid;
6625 cLISTOPo->op_first = kid;
6626 kid->op_sibling = sibl;
6629 kid->op_type = OP_PUSHRE;
6630 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6633 if (!kid->op_sibling)
6634 append_elem(OP_SPLIT, o, newDEFSVOP());
6636 kid = kid->op_sibling;
6639 if (!kid->op_sibling)
6640 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6642 kid = kid->op_sibling;
6645 if (kid->op_sibling)
6646 return too_many_arguments(o,OP_DESC(o));
6652 Perl_ck_join(pTHX_ OP *o)
6654 if (ckWARN(WARN_SYNTAX)) {
6655 OP *kid = cLISTOPo->op_first->op_sibling;
6656 if (kid && kid->op_type == OP_MATCH) {
6657 char *pmstr = "STRING";
6658 if (PM_GETRE(kPMOP))
6659 pmstr = PM_GETRE(kPMOP)->precomp;
6660 Perl_warner(aTHX_ WARN_SYNTAX,
6661 "/%s/ should probably be written as \"%s\"",
6669 Perl_ck_subr(pTHX_ OP *o)
6671 OP *prev = ((cUNOPo->op_first->op_sibling)
6672 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6673 OP *o2 = prev->op_sibling;
6680 I32 contextclass = 0;
6684 o->op_private |= OPpENTERSUB_HASTARG;
6685 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6686 if (cvop->op_type == OP_RV2CV) {
6688 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6689 op_null(cvop); /* disable rv2cv */
6690 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6691 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6692 GV *gv = cGVOPx_gv(tmpop);
6695 tmpop->op_private |= OPpEARLY_CV;
6696 else if (SvPOK(cv)) {
6697 namegv = CvANON(cv) ? gv : CvGV(cv);
6698 proto = SvPV((SV*)cv, n_a);
6702 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6703 if (o2->op_type == OP_CONST)
6704 o2->op_private &= ~OPpCONST_STRICT;
6705 else if (o2->op_type == OP_LIST) {
6706 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6707 if (o && o->op_type == OP_CONST)
6708 o->op_private &= ~OPpCONST_STRICT;
6711 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6712 if (PERLDB_SUB && PL_curstash != PL_debstash)
6713 o->op_private |= OPpENTERSUB_DB;
6714 while (o2 != cvop) {
6718 return too_many_arguments(o, gv_ename(namegv));
6736 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6738 arg == 1 ? "block or sub {}" : "sub {}",
6739 gv_ename(namegv), o2);
6742 /* '*' allows any scalar type, including bareword */
6745 if (o2->op_type == OP_RV2GV)
6746 goto wrapref; /* autoconvert GLOB -> GLOBref */
6747 else if (o2->op_type == OP_CONST)
6748 o2->op_private &= ~OPpCONST_STRICT;
6749 else if (o2->op_type == OP_ENTERSUB) {
6750 /* accidental subroutine, revert to bareword */
6751 OP *gvop = ((UNOP*)o2)->op_first;
6752 if (gvop && gvop->op_type == OP_NULL) {
6753 gvop = ((UNOP*)gvop)->op_first;
6755 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6758 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6759 (gvop = ((UNOP*)gvop)->op_first) &&
6760 gvop->op_type == OP_GV)
6762 GV *gv = cGVOPx_gv(gvop);
6763 OP *sibling = o2->op_sibling;
6764 SV *n = newSVpvn("",0);
6766 gv_fullname3(n, gv, "");
6767 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6768 sv_chop(n, SvPVX(n)+6);
6769 o2 = newSVOP(OP_CONST, 0, n);
6770 prev->op_sibling = o2;
6771 o2->op_sibling = sibling;
6787 if (contextclass++ == 0) {
6788 e = strchr(proto, ']');
6789 if (!e || e == proto)
6802 while (*--p != '[');
6803 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6804 gv_ename(namegv), o2);
6810 if (o2->op_type == OP_RV2GV)
6813 bad_type(arg, "symbol", gv_ename(namegv), o2);
6816 if (o2->op_type == OP_ENTERSUB)
6819 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6822 if (o2->op_type == OP_RV2SV ||
6823 o2->op_type == OP_PADSV ||
6824 o2->op_type == OP_HELEM ||
6825 o2->op_type == OP_AELEM ||
6826 o2->op_type == OP_THREADSV)
6829 bad_type(arg, "scalar", gv_ename(namegv), o2);
6832 if (o2->op_type == OP_RV2AV ||
6833 o2->op_type == OP_PADAV)
6836 bad_type(arg, "array", gv_ename(namegv), o2);
6839 if (o2->op_type == OP_RV2HV ||
6840 o2->op_type == OP_PADHV)
6843 bad_type(arg, "hash", gv_ename(namegv), o2);
6848 OP* sib = kid->op_sibling;
6849 kid->op_sibling = 0;
6850 o2 = newUNOP(OP_REFGEN, 0, kid);
6851 o2->op_sibling = sib;
6852 prev->op_sibling = o2;
6854 if (contextclass && e) {
6869 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6870 gv_ename(namegv), SvPV((SV*)cv, n_a));
6875 mod(o2, OP_ENTERSUB);
6877 o2 = o2->op_sibling;
6879 if (proto && !optional &&
6880 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6881 return too_few_arguments(o, gv_ename(namegv));
6886 Perl_ck_svconst(pTHX_ OP *o)
6888 SvREADONLY_on(cSVOPo->op_sv);
6893 Perl_ck_trunc(pTHX_ OP *o)
6895 if (o->op_flags & OPf_KIDS) {
6896 SVOP *kid = (SVOP*)cUNOPo->op_first;
6898 if (kid->op_type == OP_NULL)
6899 kid = (SVOP*)kid->op_sibling;
6900 if (kid && kid->op_type == OP_CONST &&
6901 (kid->op_private & OPpCONST_BARE))
6903 o->op_flags |= OPf_SPECIAL;
6904 kid->op_private &= ~OPpCONST_STRICT;
6911 Perl_ck_substr(pTHX_ OP *o)
6914 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6915 OP *kid = cLISTOPo->op_first;
6917 if (kid->op_type == OP_NULL)
6918 kid = kid->op_sibling;
6920 kid->op_flags |= OPf_MOD;
6926 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6929 Perl_peep(pTHX_ register OP *o)
6931 register OP* oldop = 0;
6934 if (!o || o->op_seq)
6938 SAVEVPTR(PL_curcop);
6939 for (; o; o = o->op_next) {
6945 switch (o->op_type) {
6949 PL_curcop = ((COP*)o); /* for warnings */
6950 o->op_seq = PL_op_seqmax++;
6954 if (cSVOPo->op_private & OPpCONST_STRICT)
6955 no_bareword_allowed(o);
6957 /* Relocate sv to the pad for thread safety.
6958 * Despite being a "constant", the SV is written to,
6959 * for reference counts, sv_upgrade() etc. */
6961 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6962 if (SvPADTMP(cSVOPo->op_sv)) {
6963 /* If op_sv is already a PADTMP then it is being used by
6964 * some pad, so make a copy. */
6965 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6966 SvREADONLY_on(PL_curpad[ix]);
6967 SvREFCNT_dec(cSVOPo->op_sv);
6970 SvREFCNT_dec(PL_curpad[ix]);
6971 SvPADTMP_on(cSVOPo->op_sv);
6972 PL_curpad[ix] = cSVOPo->op_sv;
6973 /* XXX I don't know how this isn't readonly already. */
6974 SvREADONLY_on(PL_curpad[ix]);
6976 cSVOPo->op_sv = Nullsv;
6980 o->op_seq = PL_op_seqmax++;
6984 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6985 if (o->op_next->op_private & OPpTARGET_MY) {
6986 if (o->op_flags & OPf_STACKED) /* chained concats */
6987 goto ignore_optimization;
6989 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6990 o->op_targ = o->op_next->op_targ;
6991 o->op_next->op_targ = 0;
6992 o->op_private |= OPpTARGET_MY;
6995 op_null(o->op_next);
6997 ignore_optimization:
6998 o->op_seq = PL_op_seqmax++;
7001 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7002 o->op_seq = PL_op_seqmax++;
7003 break; /* Scalar stub must produce undef. List stub is noop */
7007 if (o->op_targ == OP_NEXTSTATE
7008 || o->op_targ == OP_DBSTATE
7009 || o->op_targ == OP_SETSTATE)
7011 PL_curcop = ((COP*)o);
7013 /* XXX: We avoid setting op_seq here to prevent later calls
7014 to peep() from mistakenly concluding that optimisation
7015 has already occurred. This doesn't fix the real problem,
7016 though (See 20010220.007). AMS 20010719 */
7017 if (oldop && o->op_next) {
7018 oldop->op_next = o->op_next;
7026 if (oldop && o->op_next) {
7027 oldop->op_next = o->op_next;
7030 o->op_seq = PL_op_seqmax++;
7034 if (o->op_next->op_type == OP_RV2SV) {
7035 if (!(o->op_next->op_private & OPpDEREF)) {
7036 op_null(o->op_next);
7037 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7039 o->op_next = o->op_next->op_next;
7040 o->op_type = OP_GVSV;
7041 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7044 else if (o->op_next->op_type == OP_RV2AV) {
7045 OP* pop = o->op_next->op_next;
7047 if (pop && pop->op_type == OP_CONST &&
7048 (PL_op = pop->op_next) &&
7049 pop->op_next->op_type == OP_AELEM &&
7050 !(pop->op_next->op_private &
7051 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7052 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7057 op_null(o->op_next);
7058 op_null(pop->op_next);
7060 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7061 o->op_next = pop->op_next->op_next;
7062 o->op_type = OP_AELEMFAST;
7063 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7064 o->op_private = (U8)i;
7069 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7071 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7072 /* XXX could check prototype here instead of just carping */
7073 SV *sv = sv_newmortal();
7074 gv_efullname3(sv, gv, Nullch);
7075 Perl_warner(aTHX_ WARN_PROTOTYPE,
7076 "%s() called too early to check prototype",
7080 else if (o->op_next->op_type == OP_READLINE
7081 && o->op_next->op_next->op_type == OP_CONCAT
7082 && (o->op_next->op_next->op_flags & OPf_STACKED))
7084 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7085 o->op_type = OP_RCATLINE;
7086 o->op_flags |= OPf_STACKED;
7087 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7088 op_null(o->op_next->op_next);
7089 op_null(o->op_next);
7092 o->op_seq = PL_op_seqmax++;
7103 o->op_seq = PL_op_seqmax++;
7104 while (cLOGOP->op_other->op_type == OP_NULL)
7105 cLOGOP->op_other = cLOGOP->op_other->op_next;
7106 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7111 o->op_seq = PL_op_seqmax++;
7112 while (cLOOP->op_redoop->op_type == OP_NULL)
7113 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7114 peep(cLOOP->op_redoop);
7115 while (cLOOP->op_nextop->op_type == OP_NULL)
7116 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7117 peep(cLOOP->op_nextop);
7118 while (cLOOP->op_lastop->op_type == OP_NULL)
7119 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7120 peep(cLOOP->op_lastop);
7126 o->op_seq = PL_op_seqmax++;
7127 while (cPMOP->op_pmreplstart &&
7128 cPMOP->op_pmreplstart->op_type == OP_NULL)
7129 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7130 peep(cPMOP->op_pmreplstart);
7134 o->op_seq = PL_op_seqmax++;
7135 if (ckWARN(WARN_SYNTAX) && o->op_next
7136 && o->op_next->op_type == OP_NEXTSTATE) {
7137 if (o->op_next->op_sibling &&
7138 o->op_next->op_sibling->op_type != OP_EXIT &&
7139 o->op_next->op_sibling->op_type != OP_WARN &&
7140 o->op_next->op_sibling->op_type != OP_DIE) {
7141 line_t oldline = CopLINE(PL_curcop);
7143 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7144 Perl_warner(aTHX_ WARN_EXEC,
7145 "Statement unlikely to be reached");
7146 Perl_warner(aTHX_ WARN_EXEC,
7147 "\t(Maybe you meant system() when you said exec()?)\n");
7148 CopLINE_set(PL_curcop, oldline);
7157 SV **svp, **indsvp, *sv;
7162 o->op_seq = PL_op_seqmax++;
7164 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7167 /* Make the CONST have a shared SV */
7168 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7169 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7170 key = SvPV(sv, keylen);
7171 lexname = newSVpvn_share(key,
7172 SvUTF8(sv) ? -(I32)keylen : keylen,
7178 if ((o->op_private & (OPpLVAL_INTRO)))
7181 rop = (UNOP*)((BINOP*)o)->op_first;
7182 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7184 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7185 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7187 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7188 if (!fields || !GvHV(*fields))
7190 key = SvPV(*svp, keylen);
7191 indsvp = hv_fetch(GvHV(*fields), key,
7192 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7194 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7195 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7197 ind = SvIV(*indsvp);
7199 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7200 rop->op_type = OP_RV2AV;
7201 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7202 o->op_type = OP_AELEM;
7203 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7205 if (SvREADONLY(*svp))
7207 SvFLAGS(sv) |= (SvFLAGS(*svp)
7208 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7218 SV **svp, **indsvp, *sv;
7222 SVOP *first_key_op, *key_op;
7224 o->op_seq = PL_op_seqmax++;
7225 if ((o->op_private & (OPpLVAL_INTRO))
7226 /* I bet there's always a pushmark... */
7227 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7228 /* hmmm, no optimization if list contains only one key. */
7230 rop = (UNOP*)((LISTOP*)o)->op_last;
7231 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7233 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7234 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7236 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7237 if (!fields || !GvHV(*fields))
7239 /* Again guessing that the pushmark can be jumped over.... */
7240 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7241 ->op_first->op_sibling;
7242 /* Check that the key list contains only constants. */
7243 for (key_op = first_key_op; key_op;
7244 key_op = (SVOP*)key_op->op_sibling)
7245 if (key_op->op_type != OP_CONST)
7249 rop->op_type = OP_RV2AV;
7250 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7251 o->op_type = OP_ASLICE;
7252 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7253 for (key_op = first_key_op; key_op;
7254 key_op = (SVOP*)key_op->op_sibling) {
7255 svp = cSVOPx_svp(key_op);
7256 key = SvPV(*svp, keylen);
7257 indsvp = hv_fetch(GvHV(*fields), key,
7258 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7260 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7261 "in variable %s of type %s",
7262 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7264 ind = SvIV(*indsvp);
7266 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7268 if (SvREADONLY(*svp))
7270 SvFLAGS(sv) |= (SvFLAGS(*svp)
7271 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7279 o->op_seq = PL_op_seqmax++;
7289 char* Perl_custom_op_name(pTHX_ OP* o)
7291 IV index = PTR2IV(o->op_ppaddr);
7295 if (!PL_custom_op_names) /* This probably shouldn't happen */
7296 return PL_op_name[OP_CUSTOM];
7298 keysv = sv_2mortal(newSViv(index));
7300 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7302 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7304 return SvPV_nolen(HeVAL(he));
7307 char* Perl_custom_op_desc(pTHX_ OP* o)
7309 IV index = PTR2IV(o->op_ppaddr);
7313 if (!PL_custom_op_descs)
7314 return PL_op_desc[OP_CUSTOM];
7316 keysv = sv_2mortal(newSViv(index));
7318 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7320 return PL_op_desc[OP_CUSTOM];
7322 return SvPV_nolen(HeVAL(he));
7328 /* Efficient sub that returns a constant scalar value. */
7330 const_sv_xsub(pTHX_ CV* cv)
7335 Perl_croak(aTHX_ "usage: %s::%s()",
7336 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7340 ST(0) = (SV*)XSANY.any_ptr;