3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
47 if ((PL_OpSpace -= sz) < 0) {
48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
63 PL_OpPtr += PERL_SLAB_SIZE;
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
77 S_Slab_Free(pTHX_ void *op)
79 I32 **ptr = (I32 **) op;
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
85 PerlMemShared_free(slab);
86 if (slab == PL_OpSlab) {
93 #define NewOp(m, var, c, type) Newz(m, var, c, type)
94 #define FreeOp(p) Safefree(p)
97 * In the following definition, the ", Nullop" is just to make the compiler
98 * think the expression is of the right type: croak actually does a Siglongjmp.
100 #define CHECKOP(type,o) \
101 ((PL_op_mask && PL_op_mask[type]) \
102 ? ( op_free((OP*)o), \
103 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
105 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
107 #define PAD_MAX 999999999
108 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
111 S_gv_ename(pTHX_ GV *gv)
114 SV* tmpsv = sv_newmortal();
115 gv_efullname3(tmpsv, gv, Nullch);
116 return SvPV(tmpsv,n_a);
120 S_no_fh_allowed(pTHX_ OP *o)
122 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
128 S_too_few_arguments(pTHX_ OP *o, char *name)
130 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
135 S_too_many_arguments(pTHX_ OP *o, char *name)
137 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
142 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
144 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
145 (int)n, name, t, OP_DESC(kid)));
149 S_no_bareword_allowed(pTHX_ OP *o)
151 qerror(Perl_mess(aTHX_
152 "Bareword \"%s\" not allowed while \"strict subs\" in use",
153 SvPV_nolen(cSVOPo_sv)));
156 /* "register" allocation */
159 Perl_pad_allocmy(pTHX_ char *name)
164 if (!(PL_in_my == KEY_our ||
166 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
167 (name[1] == '_' && (int)strlen(name) > 2)))
169 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
170 /* 1999-02-27 mjd@plover.com */
172 p = strchr(name, '\0');
173 /* The next block assumes the buffer is at least 205 chars
174 long. At present, it's always at least 256 chars. */
176 strcpy(name+200, "...");
182 /* Move everything else down one character */
183 for (; p-name > 2; p--)
185 name[2] = toCTRL(name[1]);
188 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
190 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
191 SV **svp = AvARRAY(PL_comppad_name);
192 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
193 PADOFFSET top = AvFILLp(PL_comppad_name);
194 for (off = top; off > PL_comppad_name_floor; off--) {
196 && sv != &PL_sv_undef
197 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
198 && (PL_in_my != KEY_our
199 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
200 && strEQ(name, SvPVX(sv)))
202 Perl_warner(aTHX_ WARN_MISC,
203 "\"%s\" variable %s masks earlier declaration in same %s",
204 (PL_in_my == KEY_our ? "our" : "my"),
206 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
211 if (PL_in_my == KEY_our) {
214 && sv != &PL_sv_undef
215 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
216 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
217 && strEQ(name, SvPVX(sv)))
219 Perl_warner(aTHX_ WARN_MISC,
220 "\"our\" variable %s redeclared", name);
221 Perl_warner(aTHX_ WARN_MISC,
222 "\t(Did you mean \"local\" instead of \"our\"?)\n");
225 } while ( off-- > 0 );
228 off = pad_alloc(OP_PADSV, SVs_PADMY);
230 sv_upgrade(sv, SVt_PVNV);
232 if (PL_in_my_stash) {
234 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
235 name, PL_in_my == KEY_our ? "our" : "my"));
236 SvFLAGS(sv) |= SVpad_TYPED;
237 (void)SvUPGRADE(sv, SVt_PVMG);
238 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
240 if (PL_in_my == KEY_our) {
241 (void)SvUPGRADE(sv, SVt_PVGV);
242 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
243 SvFLAGS(sv) |= SVpad_OUR;
245 av_store(PL_comppad_name, off, sv);
246 SvNVX(sv) = (NV)PAD_MAX;
247 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
248 if (!PL_min_intro_pending)
249 PL_min_intro_pending = off;
250 PL_max_intro_pending = off;
252 av_store(PL_comppad, off, (SV*)newAV());
253 else if (*name == '%')
254 av_store(PL_comppad, off, (SV*)newHV());
255 SvPADMY_on(PL_curpad[off]);
260 S_pad_addlex(pTHX_ SV *proto_namesv)
262 SV *namesv = NEWSV(1103,0);
263 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
264 sv_upgrade(namesv, SVt_PVNV);
265 sv_setpv(namesv, SvPVX(proto_namesv));
266 av_store(PL_comppad_name, newoff, namesv);
267 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
268 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
269 SvFAKE_on(namesv); /* A ref, not a real var */
270 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
271 SvFLAGS(namesv) |= SVpad_OUR;
272 (void)SvUPGRADE(namesv, SVt_PVGV);
273 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
275 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
276 SvFLAGS(namesv) |= SVpad_TYPED;
277 (void)SvUPGRADE(namesv, SVt_PVMG);
278 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
283 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
286 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
287 I32 cx_ix, I32 saweval, U32 flags)
293 register PERL_CONTEXT *cx;
295 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
296 AV *curlist = CvPADLIST(cv);
297 SV **svp = av_fetch(curlist, 0, FALSE);
300 if (!svp || *svp == &PL_sv_undef)
303 svp = AvARRAY(curname);
304 for (off = AvFILLp(curname); off > 0; off--) {
305 if ((sv = svp[off]) &&
306 sv != &PL_sv_undef &&
308 seq > I_32(SvNVX(sv)) &&
309 strEQ(SvPVX(sv), name))
320 return 0; /* don't clone from inactive stack frame */
324 oldpad = (AV*)AvARRAY(curlist)[depth];
325 oldsv = *av_fetch(oldpad, off, TRUE);
326 if (!newoff) { /* Not a mere clone operation. */
327 newoff = pad_addlex(sv);
328 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
329 /* "It's closures all the way down." */
330 CvCLONE_on(PL_compcv);
332 if (CvANON(PL_compcv))
333 oldsv = Nullsv; /* no need to keep ref */
338 bcv && bcv != cv && !CvCLONE(bcv);
339 bcv = CvOUTSIDE(bcv))
342 /* install the missing pad entry in intervening
343 * nested subs and mark them cloneable.
344 * XXX fix pad_foo() to not use globals */
345 AV *ocomppad_name = PL_comppad_name;
346 AV *ocomppad = PL_comppad;
347 SV **ocurpad = PL_curpad;
348 AV *padlist = CvPADLIST(bcv);
349 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
350 PL_comppad = (AV*)AvARRAY(padlist)[1];
351 PL_curpad = AvARRAY(PL_comppad);
353 PL_comppad_name = ocomppad_name;
354 PL_comppad = ocomppad;
359 if (ckWARN(WARN_CLOSURE)
360 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
362 Perl_warner(aTHX_ WARN_CLOSURE,
363 "Variable \"%s\" may be unavailable",
371 else if (!CvUNIQUE(PL_compcv)) {
372 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
373 && !(SvFLAGS(sv) & SVpad_OUR))
375 Perl_warner(aTHX_ WARN_CLOSURE,
376 "Variable \"%s\" will not stay shared", name);
380 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
386 if (flags & FINDLEX_NOSEARCH)
389 /* Nothing in current lexical context--try eval's context, if any.
390 * This is necessary to let the perldb get at lexically scoped variables.
391 * XXX This will also probably interact badly with eval tree caching.
394 for (i = cx_ix; i >= 0; i--) {
396 switch (CxTYPE(cx)) {
398 if (i == 0 && saweval) {
399 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
403 switch (cx->blk_eval.old_op_type) {
405 if (CxREALEVAL(cx)) {
408 seq = cxstack[i].blk_oldcop->cop_seq;
409 startcv = cxstack[i].blk_eval.cv;
410 if (startcv && CvOUTSIDE(startcv)) {
411 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
413 if (off) /* continue looking if not found here */
420 /* require/do must have their own scope */
429 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
430 saweval = i; /* so we know where we were called from */
431 seq = cxstack[i].blk_oldcop->cop_seq;
434 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
442 Perl_pad_findmy(pTHX_ char *name)
447 SV **svp = AvARRAY(PL_comppad_name);
448 U32 seq = PL_cop_seqmax;
452 #ifdef USE_5005THREADS
454 * Special case to get lexical (and hence per-thread) @_.
455 * XXX I need to find out how to tell at parse-time whether use
456 * of @_ should refer to a lexical (from a sub) or defgv (global
457 * scope and maybe weird sub-ish things like formats). See
458 * startsub in perly.y. It's possible that @_ could be lexical
459 * (at least from subs) even in non-threaded perl.
461 if (strEQ(name, "@_"))
462 return 0; /* success. (NOT_IN_PAD indicates failure) */
463 #endif /* USE_5005THREADS */
465 /* The one we're looking for is probably just before comppad_name_fill. */
466 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
467 if ((sv = svp[off]) &&
468 sv != &PL_sv_undef &&
471 seq > I_32(SvNVX(sv)))) &&
472 strEQ(SvPVX(sv), name))
474 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
475 return (PADOFFSET)off;
476 pendoff = off; /* this pending def. will override import */
480 outside = CvOUTSIDE(PL_compcv);
482 /* Check if if we're compiling an eval'', and adjust seq to be the
483 * eval's seq number. This depends on eval'' having a non-null
484 * CvOUTSIDE() while it is being compiled. The eval'' itself is
485 * identified by CvEVAL being true and CvGV being null. */
486 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
487 cx = &cxstack[cxstack_ix];
489 seq = cx->blk_oldcop->cop_seq;
492 /* See if it's in a nested scope */
493 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
495 /* If there is a pending local definition, this new alias must die */
497 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
498 return off; /* pad_findlex returns 0 for failure...*/
500 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
504 Perl_pad_leavemy(pTHX_ I32 fill)
507 SV **svp = AvARRAY(PL_comppad_name);
509 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
510 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
511 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
512 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
515 /* "Deintroduce" my variables that are leaving with this scope. */
516 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
517 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
518 SvIVX(sv) = PL_cop_seqmax;
523 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
528 if (AvARRAY(PL_comppad) != PL_curpad)
529 Perl_croak(aTHX_ "panic: pad_alloc");
530 if (PL_pad_reset_pending)
532 if (tmptype & SVs_PADMY) {
534 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
535 } while (SvPADBUSY(sv)); /* need a fresh one */
536 retval = AvFILLp(PL_comppad);
539 SV **names = AvARRAY(PL_comppad_name);
540 SSize_t names_fill = AvFILLp(PL_comppad_name);
543 * "foreach" index vars temporarily become aliases to non-"my"
544 * values. Thus we must skip, not just pad values that are
545 * marked as current pad values, but also those with names.
547 if (++PL_padix <= names_fill &&
548 (sv = names[PL_padix]) && sv != &PL_sv_undef)
550 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
551 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
552 !IS_PADGV(sv) && !IS_PADCONST(sv))
557 SvFLAGS(sv) |= tmptype;
558 PL_curpad = AvARRAY(PL_comppad);
559 #ifdef USE_5005THREADS
560 DEBUG_X(PerlIO_printf(Perl_debug_log,
561 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
562 PTR2UV(thr), PTR2UV(PL_curpad),
563 (long) retval, PL_op_name[optype]));
565 DEBUG_X(PerlIO_printf(Perl_debug_log,
566 "Pad 0x%"UVxf" alloc %ld for %s\n",
568 (long) retval, PL_op_name[optype]));
569 #endif /* USE_5005THREADS */
570 return (PADOFFSET)retval;
574 Perl_pad_sv(pTHX_ PADOFFSET po)
576 #ifdef USE_5005THREADS
577 DEBUG_X(PerlIO_printf(Perl_debug_log,
578 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
579 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
582 Perl_croak(aTHX_ "panic: pad_sv po");
583 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
584 PTR2UV(PL_curpad), (IV)po));
585 #endif /* USE_5005THREADS */
586 return PL_curpad[po]; /* eventually we'll turn this into a macro */
590 Perl_pad_free(pTHX_ PADOFFSET po)
594 if (AvARRAY(PL_comppad) != PL_curpad)
595 Perl_croak(aTHX_ "panic: pad_free curpad");
597 Perl_croak(aTHX_ "panic: pad_free po");
598 #ifdef USE_5005THREADS
599 DEBUG_X(PerlIO_printf(Perl_debug_log,
600 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
601 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
603 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
604 PTR2UV(PL_curpad), (IV)po));
605 #endif /* USE_5005THREADS */
606 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
607 SvPADTMP_off(PL_curpad[po]);
609 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
612 if ((I32)po < PL_padix)
617 Perl_pad_swipe(pTHX_ PADOFFSET po)
619 if (AvARRAY(PL_comppad) != PL_curpad)
620 Perl_croak(aTHX_ "panic: pad_swipe curpad");
622 Perl_croak(aTHX_ "panic: pad_swipe po");
623 #ifdef USE_5005THREADS
624 DEBUG_X(PerlIO_printf(Perl_debug_log,
625 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
626 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
628 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
629 PTR2UV(PL_curpad), (IV)po));
630 #endif /* USE_5005THREADS */
631 SvPADTMP_off(PL_curpad[po]);
632 PL_curpad[po] = NEWSV(1107,0);
633 SvPADTMP_on(PL_curpad[po]);
634 if ((I32)po < PL_padix)
638 /* XXX pad_reset() is currently disabled because it results in serious bugs.
639 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
640 * on the stack by OPs that use them, there are several ways to get an alias
641 * to a shared TARG. Such an alias will change randomly and unpredictably.
642 * We avoid doing this until we can think of a Better Way.
647 #ifdef USE_BROKEN_PAD_RESET
650 if (AvARRAY(PL_comppad) != PL_curpad)
651 Perl_croak(aTHX_ "panic: pad_reset curpad");
652 #ifdef USE_5005THREADS
653 DEBUG_X(PerlIO_printf(Perl_debug_log,
654 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
655 PTR2UV(thr), PTR2UV(PL_curpad)));
657 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
659 #endif /* USE_5005THREADS */
660 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
661 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
662 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
663 SvPADTMP_off(PL_curpad[po]);
665 PL_padix = PL_padix_floor;
668 PL_pad_reset_pending = FALSE;
671 #ifdef USE_5005THREADS
672 /* find_threadsv is not reentrant */
674 Perl_find_threadsv(pTHX_ const char *name)
679 /* We currently only handle names of a single character */
680 p = strchr(PL_threadsv_names, *name);
683 key = p - PL_threadsv_names;
684 MUTEX_LOCK(&thr->mutex);
685 svp = av_fetch(thr->threadsv, key, FALSE);
687 MUTEX_UNLOCK(&thr->mutex);
689 SV *sv = NEWSV(0, 0);
690 av_store(thr->threadsv, key, sv);
691 thr->threadsvp = AvARRAY(thr->threadsv);
692 MUTEX_UNLOCK(&thr->mutex);
694 * Some magic variables used to be automagically initialised
695 * in gv_fetchpv. Those which are now per-thread magicals get
696 * initialised here instead.
702 sv_setpv(sv, "\034");
703 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
708 PL_sawampersand = TRUE;
722 /* XXX %! tied to Errno.pm needs to be added here.
723 * See gv_fetchpv(). */
727 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
729 DEBUG_S(PerlIO_printf(Perl_error_log,
730 "find_threadsv: new SV %p for $%s%c\n",
731 sv, (*name < 32) ? "^" : "",
732 (*name < 32) ? toCTRL(*name) : *name));
736 #endif /* USE_5005THREADS */
741 Perl_op_free(pTHX_ OP *o)
743 register OP *kid, *nextkid;
746 if (!o || o->op_seq == (U16)-1)
749 if (o->op_private & OPpREFCOUNTED) {
750 switch (o->op_type) {
758 if (OpREFCNT_dec(o)) {
769 if (o->op_flags & OPf_KIDS) {
770 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
771 nextkid = kid->op_sibling; /* Get before next freeing kid */
779 /* COP* is not cleared by op_clear() so that we may track line
780 * numbers etc even after null() */
781 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
789 Perl_op_clear(pTHX_ OP *o)
792 switch (o->op_type) {
793 case OP_NULL: /* Was holding old type, if any. */
794 case OP_ENTEREVAL: /* Was holding hints. */
795 #ifdef USE_5005THREADS
796 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
800 #ifdef USE_5005THREADS
802 if (!(o->op_flags & OPf_SPECIAL))
805 #endif /* USE_5005THREADS */
807 if (!(o->op_flags & OPf_REF)
808 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
815 if (cPADOPo->op_padix > 0) {
818 pad_swipe(cPADOPo->op_padix);
819 /* No GvIN_PAD_off(gv) here, because other references may still
820 * exist on the pad */
823 cPADOPo->op_padix = 0;
826 SvREFCNT_dec(cSVOPo->op_sv);
827 cSVOPo->op_sv = Nullsv;
830 case OP_METHOD_NAMED:
832 SvREFCNT_dec(cSVOPo->op_sv);
833 cSVOPo->op_sv = Nullsv;
839 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
843 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
844 SvREFCNT_dec(cSVOPo->op_sv);
845 cSVOPo->op_sv = Nullsv;
848 Safefree(cPVOPo->op_pv);
849 cPVOPo->op_pv = Nullch;
853 op_free(cPMOPo->op_pmreplroot);
857 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
859 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
860 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
861 /* No GvIN_PAD_off(gv) here, because other references may still
862 * exist on the pad */
867 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
874 HV *pmstash = PmopSTASH(cPMOPo);
875 if (pmstash && SvREFCNT(pmstash)) {
876 PMOP *pmop = HvPMROOT(pmstash);
877 PMOP *lastpmop = NULL;
879 if (cPMOPo == pmop) {
881 lastpmop->op_pmnext = pmop->op_pmnext;
883 HvPMROOT(pmstash) = pmop->op_pmnext;
887 pmop = pmop->op_pmnext;
890 PmopSTASH_free(cPMOPo);
892 cPMOPo->op_pmreplroot = Nullop;
893 /* we use the "SAFE" version of the PM_ macros here
894 * since sv_clean_all might release some PMOPs
895 * after PL_regex_padav has been cleared
896 * and the clearing of PL_regex_padav needs to
897 * happen before sv_clean_all
899 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
900 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
902 if(PL_regex_pad) { /* We could be in destruction */
903 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
904 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
905 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
912 if (o->op_targ > 0) {
913 pad_free(o->op_targ);
919 S_cop_free(pTHX_ COP* cop)
921 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
924 if (! specialWARN(cop->cop_warnings))
925 SvREFCNT_dec(cop->cop_warnings);
926 if (! specialCopIO(cop->cop_io)) {
929 char *s = SvPV(cop->cop_io,len);
930 Perl_warn(aTHX_ "io='%.*s'",(int) len,s);
932 SvREFCNT_dec(cop->cop_io);
938 Perl_op_null(pTHX_ OP *o)
940 if (o->op_type == OP_NULL)
943 o->op_targ = o->op_type;
944 o->op_type = OP_NULL;
945 o->op_ppaddr = PL_ppaddr[OP_NULL];
948 /* Contextualizers */
950 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
953 Perl_linklist(pTHX_ OP *o)
960 /* establish postfix order */
961 if (cUNOPo->op_first) {
962 o->op_next = LINKLIST(cUNOPo->op_first);
963 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
965 kid->op_next = LINKLIST(kid->op_sibling);
977 Perl_scalarkids(pTHX_ OP *o)
980 if (o && o->op_flags & OPf_KIDS) {
981 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
988 S_scalarboolean(pTHX_ OP *o)
990 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
991 if (ckWARN(WARN_SYNTAX)) {
992 line_t oldline = CopLINE(PL_curcop);
994 if (PL_copline != NOLINE)
995 CopLINE_set(PL_curcop, PL_copline);
996 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
997 CopLINE_set(PL_curcop, oldline);
1004 Perl_scalar(pTHX_ OP *o)
1008 /* assumes no premature commitment */
1009 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1010 || o->op_type == OP_RETURN)
1015 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1017 switch (o->op_type) {
1019 scalar(cBINOPo->op_first);
1024 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1028 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1029 if (!kPMOP->op_pmreplroot)
1030 deprecate("implicit split to @_");
1038 if (o->op_flags & OPf_KIDS) {
1039 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1045 kid = cLISTOPo->op_first;
1047 while ((kid = kid->op_sibling)) {
1048 if (kid->op_sibling)
1053 WITH_THR(PL_curcop = &PL_compiling);
1058 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1059 if (kid->op_sibling)
1064 WITH_THR(PL_curcop = &PL_compiling);
1067 if (ckWARN(WARN_VOID))
1068 Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
1074 Perl_scalarvoid(pTHX_ OP *o)
1081 if (o->op_type == OP_NEXTSTATE
1082 || o->op_type == OP_SETSTATE
1083 || o->op_type == OP_DBSTATE
1084 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1085 || o->op_targ == OP_SETSTATE
1086 || o->op_targ == OP_DBSTATE)))
1087 PL_curcop = (COP*)o; /* for warning below */
1089 /* assumes no premature commitment */
1090 want = o->op_flags & OPf_WANT;
1091 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1092 || o->op_type == OP_RETURN)
1097 if ((o->op_private & OPpTARGET_MY)
1098 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1100 return scalar(o); /* As if inside SASSIGN */
1103 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1105 switch (o->op_type) {
1107 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1111 if (o->op_flags & OPf_STACKED)
1115 if (o->op_private == 4)
1157 case OP_GETSOCKNAME:
1158 case OP_GETPEERNAME:
1163 case OP_GETPRIORITY:
1186 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1187 useless = OP_DESC(o);
1194 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1195 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1196 useless = "a variable";
1201 if (cSVOPo->op_private & OPpCONST_STRICT)
1202 no_bareword_allowed(o);
1204 if (ckWARN(WARN_VOID)) {
1205 useless = "a constant";
1206 /* the constants 0 and 1 are permitted as they are
1207 conventionally used as dummies in constructs like
1208 1 while some_condition_with_side_effects; */
1209 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1211 else if (SvPOK(sv)) {
1212 /* perl4's way of mixing documentation and code
1213 (before the invention of POD) was based on a
1214 trick to mix nroff and perl code. The trick was
1215 built upon these three nroff macros being used in
1216 void context. The pink camel has the details in
1217 the script wrapman near page 319. */
1218 if (strnEQ(SvPVX(sv), "di", 2) ||
1219 strnEQ(SvPVX(sv), "ds", 2) ||
1220 strnEQ(SvPVX(sv), "ig", 2))
1225 op_null(o); /* don't execute or even remember it */
1229 o->op_type = OP_PREINC; /* pre-increment is faster */
1230 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1234 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1235 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1241 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1246 if (o->op_flags & OPf_STACKED)
1253 if (!(o->op_flags & OPf_KIDS))
1262 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1269 /* all requires must return a boolean value */
1270 o->op_flags &= ~OPf_WANT;
1275 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1276 if (!kPMOP->op_pmreplroot)
1277 deprecate("implicit split to @_");
1281 if (useless && ckWARN(WARN_VOID))
1282 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1287 Perl_listkids(pTHX_ OP *o)
1290 if (o && o->op_flags & OPf_KIDS) {
1291 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1298 Perl_list(pTHX_ OP *o)
1302 /* assumes no premature commitment */
1303 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1304 || o->op_type == OP_RETURN)
1309 if ((o->op_private & OPpTARGET_MY)
1310 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1312 return o; /* As if inside SASSIGN */
1315 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1317 switch (o->op_type) {
1320 list(cBINOPo->op_first);
1325 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1333 if (!(o->op_flags & OPf_KIDS))
1335 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1336 list(cBINOPo->op_first);
1337 return gen_constant_list(o);
1344 kid = cLISTOPo->op_first;
1346 while ((kid = kid->op_sibling)) {
1347 if (kid->op_sibling)
1352 WITH_THR(PL_curcop = &PL_compiling);
1356 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1357 if (kid->op_sibling)
1362 WITH_THR(PL_curcop = &PL_compiling);
1365 /* all requires must return a boolean value */
1366 o->op_flags &= ~OPf_WANT;
1373 Perl_scalarseq(pTHX_ OP *o)
1378 if (o->op_type == OP_LINESEQ ||
1379 o->op_type == OP_SCOPE ||
1380 o->op_type == OP_LEAVE ||
1381 o->op_type == OP_LEAVETRY)
1383 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1384 if (kid->op_sibling) {
1388 PL_curcop = &PL_compiling;
1390 o->op_flags &= ~OPf_PARENS;
1391 if (PL_hints & HINT_BLOCK_SCOPE)
1392 o->op_flags |= OPf_PARENS;
1395 o = newOP(OP_STUB, 0);
1400 S_modkids(pTHX_ OP *o, I32 type)
1403 if (o && o->op_flags & OPf_KIDS) {
1404 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1411 Perl_mod(pTHX_ OP *o, I32 type)
1416 if (!o || PL_error_count)
1419 if ((o->op_private & OPpTARGET_MY)
1420 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1425 switch (o->op_type) {
1430 if (!(o->op_private & (OPpCONST_ARYBASE)))
1432 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1433 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1437 SAVEI32(PL_compiling.cop_arybase);
1438 PL_compiling.cop_arybase = 0;
1440 else if (type == OP_REFGEN)
1443 Perl_croak(aTHX_ "That use of $[ is unsupported");
1446 if (o->op_flags & OPf_PARENS)
1450 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1451 !(o->op_flags & OPf_STACKED)) {
1452 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1453 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1454 assert(cUNOPo->op_first->op_type == OP_NULL);
1455 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1458 else if (o->op_private & OPpENTERSUB_NOMOD)
1460 else { /* lvalue subroutine call */
1461 o->op_private |= OPpLVAL_INTRO;
1462 PL_modcount = RETURN_UNLIMITED_NUMBER;
1463 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1464 /* Backward compatibility mode: */
1465 o->op_private |= OPpENTERSUB_INARGS;
1468 else { /* Compile-time error message: */
1469 OP *kid = cUNOPo->op_first;
1473 if (kid->op_type == OP_PUSHMARK)
1475 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1477 "panic: unexpected lvalue entersub "
1478 "args: type/targ %ld:%"UVuf,
1479 (long)kid->op_type, (UV)kid->op_targ);
1480 kid = kLISTOP->op_first;
1482 while (kid->op_sibling)
1483 kid = kid->op_sibling;
1484 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1486 if (kid->op_type == OP_METHOD_NAMED
1487 || kid->op_type == OP_METHOD)
1491 NewOp(1101, newop, 1, UNOP);
1492 newop->op_type = OP_RV2CV;
1493 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1494 newop->op_first = Nullop;
1495 newop->op_next = (OP*)newop;
1496 kid->op_sibling = (OP*)newop;
1497 newop->op_private |= OPpLVAL_INTRO;
1501 if (kid->op_type != OP_RV2CV)
1503 "panic: unexpected lvalue entersub "
1504 "entry via type/targ %ld:%"UVuf,
1505 (long)kid->op_type, (UV)kid->op_targ);
1506 kid->op_private |= OPpLVAL_INTRO;
1507 break; /* Postpone until runtime */
1511 kid = kUNOP->op_first;
1512 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1513 kid = kUNOP->op_first;
1514 if (kid->op_type == OP_NULL)
1516 "Unexpected constant lvalue entersub "
1517 "entry via type/targ %ld:%"UVuf,
1518 (long)kid->op_type, (UV)kid->op_targ);
1519 if (kid->op_type != OP_GV) {
1520 /* Restore RV2CV to check lvalueness */
1522 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1523 okid->op_next = kid->op_next;
1524 kid->op_next = okid;
1527 okid->op_next = Nullop;
1528 okid->op_type = OP_RV2CV;
1530 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1531 okid->op_private |= OPpLVAL_INTRO;
1535 cv = GvCV(kGVOP_gv);
1545 /* grep, foreach, subcalls, refgen */
1546 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1548 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1549 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1551 : (o->op_type == OP_ENTERSUB
1552 ? "non-lvalue subroutine call"
1554 type ? PL_op_desc[type] : "local"));
1568 case OP_RIGHT_SHIFT:
1577 if (!(o->op_flags & OPf_STACKED))
1583 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1589 if (!type && cUNOPo->op_first->op_type != OP_GV)
1590 Perl_croak(aTHX_ "Can't localize through a reference");
1591 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1592 PL_modcount = RETURN_UNLIMITED_NUMBER;
1593 return o; /* Treat \(@foo) like ordinary list. */
1597 if (scalar_mod_type(o, type))
1599 ref(cUNOPo->op_first, o->op_type);
1603 if (type == OP_LEAVESUBLV)
1604 o->op_private |= OPpMAYBE_LVSUB;
1610 PL_modcount = RETURN_UNLIMITED_NUMBER;
1613 if (!type && cUNOPo->op_first->op_type != OP_GV)
1614 Perl_croak(aTHX_ "Can't localize through a reference");
1615 ref(cUNOPo->op_first, o->op_type);
1619 PL_hints |= HINT_BLOCK_SCOPE;
1629 PL_modcount = RETURN_UNLIMITED_NUMBER;
1630 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1631 return o; /* Treat \(@foo) like ordinary list. */
1632 if (scalar_mod_type(o, type))
1634 if (type == OP_LEAVESUBLV)
1635 o->op_private |= OPpMAYBE_LVSUB;
1640 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1641 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1644 #ifdef USE_5005THREADS
1646 PL_modcount++; /* XXX ??? */
1648 #endif /* USE_5005THREADS */
1654 if (type != OP_SASSIGN)
1658 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1663 if (type == OP_LEAVESUBLV)
1664 o->op_private |= OPpMAYBE_LVSUB;
1666 pad_free(o->op_targ);
1667 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1668 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1669 if (o->op_flags & OPf_KIDS)
1670 mod(cBINOPo->op_first->op_sibling, type);
1675 ref(cBINOPo->op_first, o->op_type);
1676 if (type == OP_ENTERSUB &&
1677 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1678 o->op_private |= OPpLVAL_DEFER;
1679 if (type == OP_LEAVESUBLV)
1680 o->op_private |= OPpMAYBE_LVSUB;
1688 if (o->op_flags & OPf_KIDS)
1689 mod(cLISTOPo->op_last, type);
1693 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1695 else if (!(o->op_flags & OPf_KIDS))
1697 if (o->op_targ != OP_LIST) {
1698 mod(cBINOPo->op_first, type);
1703 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1708 if (type != OP_LEAVESUBLV)
1710 break; /* mod()ing was handled by ck_return() */
1713 /* [20011101.069] File test operators interpret OPf_REF to mean that
1714 their argument is a filehandle; thus \stat(".") should not set
1716 if (type == OP_REFGEN &&
1717 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1720 if (type != OP_LEAVESUBLV)
1721 o->op_flags |= OPf_MOD;
1723 if (type == OP_AASSIGN || type == OP_SASSIGN)
1724 o->op_flags |= OPf_SPECIAL|OPf_REF;
1726 o->op_private |= OPpLVAL_INTRO;
1727 o->op_flags &= ~OPf_SPECIAL;
1728 PL_hints |= HINT_BLOCK_SCOPE;
1730 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1731 && type != OP_LEAVESUBLV)
1732 o->op_flags |= OPf_REF;
1737 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1741 if (o->op_type == OP_RV2GV)
1765 case OP_RIGHT_SHIFT:
1784 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1786 switch (o->op_type) {
1794 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1807 Perl_refkids(pTHX_ OP *o, I32 type)
1810 if (o && o->op_flags & OPf_KIDS) {
1811 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1818 Perl_ref(pTHX_ OP *o, I32 type)
1822 if (!o || PL_error_count)
1825 switch (o->op_type) {
1827 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1828 !(o->op_flags & OPf_STACKED)) {
1829 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1830 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1831 assert(cUNOPo->op_first->op_type == OP_NULL);
1832 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1833 o->op_flags |= OPf_SPECIAL;
1838 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1842 if (type == OP_DEFINED)
1843 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1844 ref(cUNOPo->op_first, o->op_type);
1847 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1848 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1849 : type == OP_RV2HV ? OPpDEREF_HV
1851 o->op_flags |= OPf_MOD;
1856 o->op_flags |= OPf_MOD; /* XXX ??? */
1861 o->op_flags |= OPf_REF;
1864 if (type == OP_DEFINED)
1865 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1866 ref(cUNOPo->op_first, o->op_type);
1871 o->op_flags |= OPf_REF;
1876 if (!(o->op_flags & OPf_KIDS))
1878 ref(cBINOPo->op_first, type);
1882 ref(cBINOPo->op_first, o->op_type);
1883 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1884 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1885 : type == OP_RV2HV ? OPpDEREF_HV
1887 o->op_flags |= OPf_MOD;
1895 if (!(o->op_flags & OPf_KIDS))
1897 ref(cLISTOPo->op_last, type);
1907 S_dup_attrlist(pTHX_ OP *o)
1911 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1912 * where the first kid is OP_PUSHMARK and the remaining ones
1913 * are OP_CONST. We need to push the OP_CONST values.
1915 if (o->op_type == OP_CONST)
1916 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1918 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1919 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1920 if (o->op_type == OP_CONST)
1921 rop = append_elem(OP_LIST, rop,
1922 newSVOP(OP_CONST, o->op_flags,
1923 SvREFCNT_inc(cSVOPo->op_sv)));
1930 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1934 /* fake up C<use attributes $pkg,$rv,@attrs> */
1935 ENTER; /* need to protect against side-effects of 'use' */
1938 stashsv = newSVpv(HvNAME(stash), 0);
1940 stashsv = &PL_sv_no;
1942 #define ATTRSMODULE "attributes"
1943 #define ATTRSMODULE_PM "attributes.pm"
1947 /* Don't force the C<use> if we don't need it. */
1948 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1949 sizeof(ATTRSMODULE_PM)-1, 0);
1950 if (svp && *svp != &PL_sv_undef)
1951 ; /* already in %INC */
1953 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1954 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1958 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1959 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1961 prepend_elem(OP_LIST,
1962 newSVOP(OP_CONST, 0, stashsv),
1963 prepend_elem(OP_LIST,
1964 newSVOP(OP_CONST, 0,
1966 dup_attrlist(attrs))));
1972 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1974 OP *pack, *imop, *arg;
1980 assert(target->op_type == OP_PADSV ||
1981 target->op_type == OP_PADHV ||
1982 target->op_type == OP_PADAV);
1984 /* Ensure that attributes.pm is loaded. */
1985 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1987 /* Need package name for method call. */
1988 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1990 /* Build up the real arg-list. */
1992 stashsv = newSVpv(HvNAME(stash), 0);
1994 stashsv = &PL_sv_no;
1995 arg = newOP(OP_PADSV, 0);
1996 arg->op_targ = target->op_targ;
1997 arg = prepend_elem(OP_LIST,
1998 newSVOP(OP_CONST, 0, stashsv),
1999 prepend_elem(OP_LIST,
2000 newUNOP(OP_REFGEN, 0,
2001 mod(arg, OP_REFGEN)),
2002 dup_attrlist(attrs)));
2004 /* Fake up a method call to import */
2005 meth = newSVpvn("import", 6);
2006 (void)SvUPGRADE(meth, SVt_PVIV);
2007 (void)SvIOK_on(meth);
2008 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2009 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2010 append_elem(OP_LIST,
2011 prepend_elem(OP_LIST, pack, list(arg)),
2012 newSVOP(OP_METHOD_NAMED, 0, meth)));
2013 imop->op_private |= OPpENTERSUB_NOMOD;
2015 /* Combine the ops. */
2016 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2020 =notfor apidoc apply_attrs_string
2022 Attempts to apply a list of attributes specified by the C<attrstr> and
2023 C<len> arguments to the subroutine identified by the C<cv> argument which
2024 is expected to be associated with the package identified by the C<stashpv>
2025 argument (see L<attributes>). It gets this wrong, though, in that it
2026 does not correctly identify the boundaries of the individual attribute
2027 specifications within C<attrstr>. This is not really intended for the
2028 public API, but has to be listed here for systems such as AIX which
2029 need an explicit export list for symbols. (It's called from XS code
2030 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2031 to respect attribute syntax properly would be welcome.
2037 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2038 char *attrstr, STRLEN len)
2043 len = strlen(attrstr);
2047 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2049 char *sstr = attrstr;
2050 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2051 attrs = append_elem(OP_LIST, attrs,
2052 newSVOP(OP_CONST, 0,
2053 newSVpvn(sstr, attrstr-sstr)));
2057 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2058 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2059 Nullsv, prepend_elem(OP_LIST,
2060 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2061 prepend_elem(OP_LIST,
2062 newSVOP(OP_CONST, 0,
2068 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2073 if (!o || PL_error_count)
2077 if (type == OP_LIST) {
2078 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2079 my_kid(kid, attrs, imopsp);
2080 } else if (type == OP_UNDEF) {
2082 } else if (type == OP_RV2SV || /* "our" declaration */
2084 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2085 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2086 yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
2089 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2091 PL_in_my_stash = Nullhv;
2092 apply_attrs(GvSTASH(gv),
2093 (type == OP_RV2SV ? GvSV(gv) :
2094 type == OP_RV2AV ? (SV*)GvAV(gv) :
2095 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2098 o->op_private |= OPpOUR_INTRO;
2101 else if (type != OP_PADSV &&
2104 type != OP_PUSHMARK)
2106 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2108 PL_in_my == KEY_our ? "our" : "my"));
2111 else if (attrs && type != OP_PUSHMARK) {
2116 PL_in_my_stash = Nullhv;
2118 /* check for C<my Dog $spot> when deciding package */
2119 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2120 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2121 stash = SvSTASH(*namesvp);
2123 stash = PL_curstash;
2124 apply_attrs_my(stash, o, attrs, imopsp);
2126 o->op_flags |= OPf_MOD;
2127 o->op_private |= OPpLVAL_INTRO;
2132 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2135 int maybe_scalar = 0;
2137 if (o->op_flags & OPf_PARENS)
2143 o = my_kid(o, attrs, &rops);
2145 if (maybe_scalar && o->op_type == OP_PADSV) {
2146 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2147 o->op_private |= OPpLVAL_INTRO;
2150 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2153 PL_in_my_stash = Nullhv;
2158 Perl_my(pTHX_ OP *o)
2160 return my_attrs(o, Nullop);
2164 Perl_sawparens(pTHX_ OP *o)
2167 o->op_flags |= OPf_PARENS;
2172 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2176 if (ckWARN(WARN_MISC) &&
2177 (left->op_type == OP_RV2AV ||
2178 left->op_type == OP_RV2HV ||
2179 left->op_type == OP_PADAV ||
2180 left->op_type == OP_PADHV)) {
2181 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2182 right->op_type == OP_TRANS)
2183 ? right->op_type : OP_MATCH];
2184 const char *sample = ((left->op_type == OP_RV2AV ||
2185 left->op_type == OP_PADAV)
2186 ? "@array" : "%hash");
2187 Perl_warner(aTHX_ WARN_MISC,
2188 "Applying %s to %s will act on scalar(%s)",
2189 desc, sample, sample);
2192 if (right->op_type == OP_CONST &&
2193 cSVOPx(right)->op_private & OPpCONST_BARE &&
2194 cSVOPx(right)->op_private & OPpCONST_STRICT)
2196 no_bareword_allowed(right);
2199 if (!(right->op_flags & OPf_STACKED) &&
2200 (right->op_type == OP_MATCH ||
2201 right->op_type == OP_SUBST ||
2202 right->op_type == OP_TRANS)) {
2203 right->op_flags |= OPf_STACKED;
2204 if (right->op_type != OP_MATCH &&
2205 ! (right->op_type == OP_TRANS &&
2206 right->op_private & OPpTRANS_IDENTICAL))
2207 left = mod(left, right->op_type);
2208 if (right->op_type == OP_TRANS)
2209 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2211 o = prepend_elem(right->op_type, scalar(left), right);
2213 return newUNOP(OP_NOT, 0, scalar(o));
2217 return bind_match(type, left,
2218 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2222 Perl_invert(pTHX_ OP *o)
2226 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2227 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2231 Perl_scope(pTHX_ OP *o)
2234 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2235 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2236 o->op_type = OP_LEAVE;
2237 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2240 if (o->op_type == OP_LINESEQ) {
2242 o->op_type = OP_SCOPE;
2243 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2244 kid = ((LISTOP*)o)->op_first;
2245 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2249 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2256 Perl_save_hints(pTHX)
2259 SAVESPTR(GvHV(PL_hintgv));
2260 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2261 SAVEFREESV(GvHV(PL_hintgv));
2265 Perl_block_start(pTHX_ int full)
2267 int retval = PL_savestack_ix;
2269 SAVEI32(PL_comppad_name_floor);
2270 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2272 PL_comppad_name_fill = PL_comppad_name_floor;
2273 if (PL_comppad_name_floor < 0)
2274 PL_comppad_name_floor = 0;
2275 SAVEI32(PL_min_intro_pending);
2276 SAVEI32(PL_max_intro_pending);
2277 PL_min_intro_pending = 0;
2278 SAVEI32(PL_comppad_name_fill);
2279 SAVEI32(PL_padix_floor);
2280 PL_padix_floor = PL_padix;
2281 PL_pad_reset_pending = FALSE;
2283 PL_hints &= ~HINT_BLOCK_SCOPE;
2284 SAVESPTR(PL_compiling.cop_warnings);
2285 if (! specialWARN(PL_compiling.cop_warnings)) {
2286 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2287 SAVEFREESV(PL_compiling.cop_warnings) ;
2289 SAVESPTR(PL_compiling.cop_io);
2290 if (! specialCopIO(PL_compiling.cop_io)) {
2291 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2292 SAVEFREESV(PL_compiling.cop_io) ;
2298 Perl_block_end(pTHX_ I32 floor, OP *seq)
2300 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2301 line_t copline = PL_copline;
2302 /* there should be a nextstate in every block */
2303 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2304 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2306 PL_pad_reset_pending = FALSE;
2307 PL_compiling.op_private = PL_hints;
2309 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2310 pad_leavemy(PL_comppad_name_fill);
2318 #ifdef USE_5005THREADS
2319 OP *o = newOP(OP_THREADSV, 0);
2320 o->op_targ = find_threadsv("_");
2323 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2324 #endif /* USE_5005THREADS */
2328 Perl_newPROG(pTHX_ OP *o)
2333 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2334 ((PL_in_eval & EVAL_KEEPERR)
2335 ? OPf_SPECIAL : 0), o);
2336 PL_eval_start = linklist(PL_eval_root);
2337 PL_eval_root->op_private |= OPpREFCOUNTED;
2338 OpREFCNT_set(PL_eval_root, 1);
2339 PL_eval_root->op_next = 0;
2340 CALL_PEEP(PL_eval_start);
2345 PL_main_root = scope(sawparens(scalarvoid(o)));
2346 PL_curcop = &PL_compiling;
2347 PL_main_start = LINKLIST(PL_main_root);
2348 PL_main_root->op_private |= OPpREFCOUNTED;
2349 OpREFCNT_set(PL_main_root, 1);
2350 PL_main_root->op_next = 0;
2351 CALL_PEEP(PL_main_start);
2354 /* Register with debugger */
2356 CV *cv = get_cv("DB::postponed", FALSE);
2360 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2362 call_sv((SV*)cv, G_DISCARD);
2369 Perl_localize(pTHX_ OP *o, I32 lex)
2371 if (o->op_flags & OPf_PARENS)
2374 if (ckWARN(WARN_PARENTHESIS)
2375 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2377 char *s = PL_bufptr;
2379 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2382 if (*s == ';' || *s == '=')
2383 Perl_warner(aTHX_ WARN_PARENTHESIS,
2384 "Parentheses missing around \"%s\" list",
2385 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2391 o = mod(o, OP_NULL); /* a bit kludgey */
2393 PL_in_my_stash = Nullhv;
2398 Perl_jmaybe(pTHX_ OP *o)
2400 if (o->op_type == OP_LIST) {
2402 #ifdef USE_5005THREADS
2403 o2 = newOP(OP_THREADSV, 0);
2404 o2->op_targ = find_threadsv(";");
2406 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2407 #endif /* USE_5005THREADS */
2408 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2414 Perl_fold_constants(pTHX_ register OP *o)
2417 I32 type = o->op_type;
2420 if (PL_opargs[type] & OA_RETSCALAR)
2422 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2423 o->op_targ = pad_alloc(type, SVs_PADTMP);
2425 /* integerize op, unless it happens to be C<-foo>.
2426 * XXX should pp_i_negate() do magic string negation instead? */
2427 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2428 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2429 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2431 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2434 if (!(PL_opargs[type] & OA_FOLDCONST))
2439 /* XXX might want a ck_negate() for this */
2440 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2452 /* XXX what about the numeric ops? */
2453 if (PL_hints & HINT_LOCALE)
2458 goto nope; /* Don't try to run w/ errors */
2460 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2461 if ((curop->op_type != OP_CONST ||
2462 (curop->op_private & OPpCONST_BARE)) &&
2463 curop->op_type != OP_LIST &&
2464 curop->op_type != OP_SCALAR &&
2465 curop->op_type != OP_NULL &&
2466 curop->op_type != OP_PUSHMARK)
2472 curop = LINKLIST(o);
2476 sv = *(PL_stack_sp--);
2477 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2478 pad_swipe(o->op_targ);
2479 else if (SvTEMP(sv)) { /* grab mortal temp? */
2480 (void)SvREFCNT_inc(sv);
2484 if (type == OP_RV2GV)
2485 return newGVOP(OP_GV, 0, (GV*)sv);
2487 /* try to smush double to int, but don't smush -2.0 to -2 */
2488 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2491 #ifdef PERL_PRESERVE_IVUV
2492 /* Only bother to attempt to fold to IV if
2493 most operators will benefit */
2497 return newSVOP(OP_CONST, 0, sv);
2501 if (!(PL_opargs[type] & OA_OTHERINT))
2504 if (!(PL_hints & HINT_INTEGER)) {
2505 if (type == OP_MODULO
2506 || type == OP_DIVIDE
2507 || !(o->op_flags & OPf_KIDS))
2512 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2513 if (curop->op_type == OP_CONST) {
2514 if (SvIOK(((SVOP*)curop)->op_sv))
2518 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2522 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2529 Perl_gen_constant_list(pTHX_ register OP *o)
2532 I32 oldtmps_floor = PL_tmps_floor;
2536 return o; /* Don't attempt to run with errors */
2538 PL_op = curop = LINKLIST(o);
2545 PL_tmps_floor = oldtmps_floor;
2547 o->op_type = OP_RV2AV;
2548 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2549 curop = ((UNOP*)o)->op_first;
2550 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2557 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2559 if (!o || o->op_type != OP_LIST)
2560 o = newLISTOP(OP_LIST, 0, o, Nullop);
2562 o->op_flags &= ~OPf_WANT;
2564 if (!(PL_opargs[type] & OA_MARK))
2565 op_null(cLISTOPo->op_first);
2568 o->op_ppaddr = PL_ppaddr[type];
2569 o->op_flags |= flags;
2571 o = CHECKOP(type, o);
2572 if (o->op_type != type)
2575 return fold_constants(o);
2578 /* List constructors */
2581 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2589 if (first->op_type != type
2590 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2592 return newLISTOP(type, 0, first, last);
2595 if (first->op_flags & OPf_KIDS)
2596 ((LISTOP*)first)->op_last->op_sibling = last;
2598 first->op_flags |= OPf_KIDS;
2599 ((LISTOP*)first)->op_first = last;
2601 ((LISTOP*)first)->op_last = last;
2606 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2614 if (first->op_type != type)
2615 return prepend_elem(type, (OP*)first, (OP*)last);
2617 if (last->op_type != type)
2618 return append_elem(type, (OP*)first, (OP*)last);
2620 first->op_last->op_sibling = last->op_first;
2621 first->op_last = last->op_last;
2622 first->op_flags |= (last->op_flags & OPf_KIDS);
2630 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2638 if (last->op_type == type) {
2639 if (type == OP_LIST) { /* already a PUSHMARK there */
2640 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2641 ((LISTOP*)last)->op_first->op_sibling = first;
2642 if (!(first->op_flags & OPf_PARENS))
2643 last->op_flags &= ~OPf_PARENS;
2646 if (!(last->op_flags & OPf_KIDS)) {
2647 ((LISTOP*)last)->op_last = first;
2648 last->op_flags |= OPf_KIDS;
2650 first->op_sibling = ((LISTOP*)last)->op_first;
2651 ((LISTOP*)last)->op_first = first;
2653 last->op_flags |= OPf_KIDS;
2657 return newLISTOP(type, 0, first, last);
2663 Perl_newNULLLIST(pTHX)
2665 return newOP(OP_STUB, 0);
2669 Perl_force_list(pTHX_ OP *o)
2671 if (!o || o->op_type != OP_LIST)
2672 o = newLISTOP(OP_LIST, 0, o, Nullop);
2678 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2682 NewOp(1101, listop, 1, LISTOP);
2684 listop->op_type = type;
2685 listop->op_ppaddr = PL_ppaddr[type];
2688 listop->op_flags = flags;
2692 else if (!first && last)
2695 first->op_sibling = last;
2696 listop->op_first = first;
2697 listop->op_last = last;
2698 if (type == OP_LIST) {
2700 pushop = newOP(OP_PUSHMARK, 0);
2701 pushop->op_sibling = first;
2702 listop->op_first = pushop;
2703 listop->op_flags |= OPf_KIDS;
2705 listop->op_last = pushop;
2712 Perl_newOP(pTHX_ I32 type, I32 flags)
2715 NewOp(1101, o, 1, OP);
2717 o->op_ppaddr = PL_ppaddr[type];
2718 o->op_flags = flags;
2721 o->op_private = 0 + (flags >> 8);
2722 if (PL_opargs[type] & OA_RETSCALAR)
2724 if (PL_opargs[type] & OA_TARGET)
2725 o->op_targ = pad_alloc(type, SVs_PADTMP);
2726 return CHECKOP(type, o);
2730 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2735 first = newOP(OP_STUB, 0);
2736 if (PL_opargs[type] & OA_MARK)
2737 first = force_list(first);
2739 NewOp(1101, unop, 1, UNOP);
2740 unop->op_type = type;
2741 unop->op_ppaddr = PL_ppaddr[type];
2742 unop->op_first = first;
2743 unop->op_flags = flags | OPf_KIDS;
2744 unop->op_private = 1 | (flags >> 8);
2745 unop = (UNOP*) CHECKOP(type, unop);
2749 return fold_constants((OP *) unop);
2753 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2756 NewOp(1101, binop, 1, BINOP);
2759 first = newOP(OP_NULL, 0);
2761 binop->op_type = type;
2762 binop->op_ppaddr = PL_ppaddr[type];
2763 binop->op_first = first;
2764 binop->op_flags = flags | OPf_KIDS;
2767 binop->op_private = 1 | (flags >> 8);
2770 binop->op_private = 2 | (flags >> 8);
2771 first->op_sibling = last;
2774 binop = (BINOP*)CHECKOP(type, binop);
2775 if (binop->op_next || binop->op_type != type)
2778 binop->op_last = binop->op_first->op_sibling;
2780 return fold_constants((OP *)binop);
2784 uvcompare(const void *a, const void *b)
2786 if (*((UV *)a) < (*(UV *)b))
2788 if (*((UV *)a) > (*(UV *)b))
2790 if (*((UV *)a+1) < (*(UV *)b+1))
2792 if (*((UV *)a+1) > (*(UV *)b+1))
2798 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2800 SV *tstr = ((SVOP*)expr)->op_sv;
2801 SV *rstr = ((SVOP*)repl)->op_sv;
2804 U8 *t = (U8*)SvPV(tstr, tlen);
2805 U8 *r = (U8*)SvPV(rstr, rlen);
2812 register short *tbl;
2814 PL_hints |= HINT_BLOCK_SCOPE;
2815 complement = o->op_private & OPpTRANS_COMPLEMENT;
2816 del = o->op_private & OPpTRANS_DELETE;
2817 squash = o->op_private & OPpTRANS_SQUASH;
2820 o->op_private |= OPpTRANS_FROM_UTF;
2823 o->op_private |= OPpTRANS_TO_UTF;
2825 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2826 SV* listsv = newSVpvn("# comment\n",10);
2828 U8* tend = t + tlen;
2829 U8* rend = r + rlen;
2843 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2844 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2850 tsave = t = bytes_to_utf8(t, &len);
2853 if (!to_utf && rlen) {
2855 rsave = r = bytes_to_utf8(r, &len);
2859 /* There are several snags with this code on EBCDIC:
2860 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2861 2. scan_const() in toke.c has encoded chars in native encoding which makes
2862 ranges at least in EBCDIC 0..255 range the bottom odd.
2866 U8 tmpbuf[UTF8_MAXLEN+1];
2869 New(1109, cp, 2*tlen, UV);
2871 transv = newSVpvn("",0);
2873 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2875 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2877 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2881 cp[2*i+1] = cp[2*i];
2885 qsort(cp, i, 2*sizeof(UV), uvcompare);
2886 for (j = 0; j < i; j++) {
2888 diff = val - nextmin;
2890 t = uvuni_to_utf8(tmpbuf,nextmin);
2891 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2893 U8 range_mark = UTF_TO_NATIVE(0xff);
2894 t = uvuni_to_utf8(tmpbuf, val - 1);
2895 sv_catpvn(transv, (char *)&range_mark, 1);
2896 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2903 t = uvuni_to_utf8(tmpbuf,nextmin);
2904 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2906 U8 range_mark = UTF_TO_NATIVE(0xff);
2907 sv_catpvn(transv, (char *)&range_mark, 1);
2909 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2910 UNICODE_ALLOW_SUPER);
2911 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2912 t = (U8*)SvPVX(transv);
2913 tlen = SvCUR(transv);
2917 else if (!rlen && !del) {
2918 r = t; rlen = tlen; rend = tend;
2921 if ((!rlen && !del) || t == r ||
2922 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2924 o->op_private |= OPpTRANS_IDENTICAL;
2928 while (t < tend || tfirst <= tlast) {
2929 /* see if we need more "t" chars */
2930 if (tfirst > tlast) {
2931 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2933 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2935 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2942 /* now see if we need more "r" chars */
2943 if (rfirst > rlast) {
2945 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2947 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2949 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2958 rfirst = rlast = 0xffffffff;
2962 /* now see which range will peter our first, if either. */
2963 tdiff = tlast - tfirst;
2964 rdiff = rlast - rfirst;
2971 if (rfirst == 0xffffffff) {
2972 diff = tdiff; /* oops, pretend rdiff is infinite */
2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2975 (long)tfirst, (long)tlast);
2977 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2981 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2982 (long)tfirst, (long)(tfirst + diff),
2985 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2986 (long)tfirst, (long)rfirst);
2988 if (rfirst + diff > max)
2989 max = rfirst + diff;
2991 grows = (tfirst < rfirst &&
2992 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3004 else if (max > 0xff)
3009 Safefree(cPVOPo->op_pv);
3010 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3011 SvREFCNT_dec(listsv);
3013 SvREFCNT_dec(transv);
3015 if (!del && havefinal && rlen)
3016 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3017 newSVuv((UV)final), 0);
3020 o->op_private |= OPpTRANS_GROWS;
3032 tbl = (short*)cPVOPo->op_pv;
3034 Zero(tbl, 256, short);
3035 for (i = 0; i < tlen; i++)
3037 for (i = 0, j = 0; i < 256; i++) {
3048 if (i < 128 && r[j] >= 128)
3058 o->op_private |= OPpTRANS_IDENTICAL;
3063 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3064 tbl[0x100] = rlen - j;
3065 for (i=0; i < rlen - j; i++)
3066 tbl[0x101+i] = r[j+i];
3070 if (!rlen && !del) {
3073 o->op_private |= OPpTRANS_IDENTICAL;
3075 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3076 o->op_private |= OPpTRANS_IDENTICAL;
3078 for (i = 0; i < 256; i++)
3080 for (i = 0, j = 0; i < tlen; i++,j++) {
3083 if (tbl[t[i]] == -1)
3089 if (tbl[t[i]] == -1) {
3090 if (t[i] < 128 && r[j] >= 128)
3097 o->op_private |= OPpTRANS_GROWS;
3105 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3109 NewOp(1101, pmop, 1, PMOP);
3110 pmop->op_type = type;
3111 pmop->op_ppaddr = PL_ppaddr[type];
3112 pmop->op_flags = flags;
3113 pmop->op_private = 0 | (flags >> 8);
3115 if (PL_hints & HINT_RE_TAINT)
3116 pmop->op_pmpermflags |= PMf_RETAINT;
3117 if (PL_hints & HINT_LOCALE)
3118 pmop->op_pmpermflags |= PMf_LOCALE;
3119 pmop->op_pmflags = pmop->op_pmpermflags;
3124 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3125 repointer = av_pop((AV*)PL_regex_pad[0]);
3126 pmop->op_pmoffset = SvIV(repointer);
3127 SvREPADTMP_off(repointer);
3128 sv_setiv(repointer,0);
3130 repointer = newSViv(0);
3131 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3132 pmop->op_pmoffset = av_len(PL_regex_padav);
3133 PL_regex_pad = AvARRAY(PL_regex_padav);
3138 /* link into pm list */
3139 if (type != OP_TRANS && PL_curstash) {
3140 pmop->op_pmnext = HvPMROOT(PL_curstash);
3141 HvPMROOT(PL_curstash) = pmop;
3142 PmopSTASH_set(pmop,PL_curstash);
3149 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3153 I32 repl_has_vars = 0;
3155 if (o->op_type == OP_TRANS)
3156 return pmtrans(o, expr, repl);
3158 PL_hints |= HINT_BLOCK_SCOPE;
3161 if (expr->op_type == OP_CONST) {
3163 SV *pat = ((SVOP*)expr)->op_sv;
3164 char *p = SvPV(pat, plen);
3165 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3166 sv_setpvn(pat, "\\s+", 3);
3167 p = SvPV(pat, plen);
3168 pm->op_pmflags |= PMf_SKIPWHITE;
3171 pm->op_pmdynflags |= PMdf_UTF8;
3172 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3173 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3174 pm->op_pmflags |= PMf_WHITE;
3178 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3179 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3181 : OP_REGCMAYBE),0,expr);
3183 NewOp(1101, rcop, 1, LOGOP);
3184 rcop->op_type = OP_REGCOMP;
3185 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3186 rcop->op_first = scalar(expr);
3187 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3188 ? (OPf_SPECIAL | OPf_KIDS)
3190 rcop->op_private = 1;
3193 /* establish postfix order */
3194 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3196 rcop->op_next = expr;
3197 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3200 rcop->op_next = LINKLIST(expr);
3201 expr->op_next = (OP*)rcop;
3204 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3209 if (pm->op_pmflags & PMf_EVAL) {
3211 if (CopLINE(PL_curcop) < PL_multi_end)
3212 CopLINE_set(PL_curcop, PL_multi_end);
3214 #ifdef USE_5005THREADS
3215 else if (repl->op_type == OP_THREADSV
3216 && strchr("&`'123456789+",
3217 PL_threadsv_names[repl->op_targ]))
3221 #endif /* USE_5005THREADS */
3222 else if (repl->op_type == OP_CONST)
3226 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3227 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3228 #ifdef USE_5005THREADS
3229 if (curop->op_type == OP_THREADSV) {
3231 if (strchr("&`'123456789+", curop->op_private))
3235 if (curop->op_type == OP_GV) {
3236 GV *gv = cGVOPx_gv(curop);
3238 if (strchr("&`'123456789+", *GvENAME(gv)))
3241 #endif /* USE_5005THREADS */
3242 else if (curop->op_type == OP_RV2CV)
3244 else if (curop->op_type == OP_RV2SV ||
3245 curop->op_type == OP_RV2AV ||
3246 curop->op_type == OP_RV2HV ||
3247 curop->op_type == OP_RV2GV) {
3248 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3251 else if (curop->op_type == OP_PADSV ||
3252 curop->op_type == OP_PADAV ||
3253 curop->op_type == OP_PADHV ||
3254 curop->op_type == OP_PADANY) {
3257 else if (curop->op_type == OP_PUSHRE)
3258 ; /* Okay here, dangerous in newASSIGNOP */
3268 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3269 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3270 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3271 prepend_elem(o->op_type, scalar(repl), o);
3274 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3275 pm->op_pmflags |= PMf_MAYBE_CONST;
3276 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3278 NewOp(1101, rcop, 1, LOGOP);
3279 rcop->op_type = OP_SUBSTCONT;
3280 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3281 rcop->op_first = scalar(repl);
3282 rcop->op_flags |= OPf_KIDS;
3283 rcop->op_private = 1;
3286 /* establish postfix order */
3287 rcop->op_next = LINKLIST(repl);
3288 repl->op_next = (OP*)rcop;
3290 pm->op_pmreplroot = scalar((OP*)rcop);
3291 pm->op_pmreplstart = LINKLIST(rcop);
3300 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3303 NewOp(1101, svop, 1, SVOP);
3304 svop->op_type = type;
3305 svop->op_ppaddr = PL_ppaddr[type];
3307 svop->op_next = (OP*)svop;
3308 svop->op_flags = flags;
3309 if (PL_opargs[type] & OA_RETSCALAR)
3311 if (PL_opargs[type] & OA_TARGET)
3312 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3313 return CHECKOP(type, svop);
3317 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3320 NewOp(1101, padop, 1, PADOP);
3321 padop->op_type = type;
3322 padop->op_ppaddr = PL_ppaddr[type];
3323 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3324 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3325 PL_curpad[padop->op_padix] = sv;
3327 padop->op_next = (OP*)padop;
3328 padop->op_flags = flags;
3329 if (PL_opargs[type] & OA_RETSCALAR)
3331 if (PL_opargs[type] & OA_TARGET)
3332 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3333 return CHECKOP(type, padop);
3337 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3341 return newPADOP(type, flags, SvREFCNT_inc(gv));
3343 return newSVOP(type, flags, SvREFCNT_inc(gv));
3348 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3351 NewOp(1101, pvop, 1, PVOP);
3352 pvop->op_type = type;
3353 pvop->op_ppaddr = PL_ppaddr[type];
3355 pvop->op_next = (OP*)pvop;
3356 pvop->op_flags = flags;
3357 if (PL_opargs[type] & OA_RETSCALAR)
3359 if (PL_opargs[type] & OA_TARGET)
3360 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3361 return CHECKOP(type, pvop);
3365 Perl_package(pTHX_ OP *o)
3369 save_hptr(&PL_curstash);
3370 save_item(PL_curstname);
3375 name = SvPV(sv, len);
3376 PL_curstash = gv_stashpvn(name,len,TRUE);
3377 sv_setpvn(PL_curstname, name, len);
3381 deprecate("\"package\" with no arguments");
3382 sv_setpv(PL_curstname,"<none>");
3383 PL_curstash = Nullhv;
3385 PL_hints |= HINT_BLOCK_SCOPE;
3386 PL_copline = NOLINE;
3391 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3396 char *packname = Nullch;
3400 if (id->op_type != OP_CONST)
3401 Perl_croak(aTHX_ "Module name must be constant");
3405 if (version != Nullop) {
3406 SV *vesv = ((SVOP*)version)->op_sv;
3408 if (arg == Nullop && !SvNIOKp(vesv)) {
3415 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3416 Perl_croak(aTHX_ "Version number must be constant number");
3418 /* Make copy of id so we don't free it twice */
3419 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3421 /* Fake up a method call to VERSION */
3422 meth = newSVpvn("VERSION",7);
3423 sv_upgrade(meth, SVt_PVIV);
3424 (void)SvIOK_on(meth);
3425 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3426 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3427 append_elem(OP_LIST,
3428 prepend_elem(OP_LIST, pack, list(version)),
3429 newSVOP(OP_METHOD_NAMED, 0, meth)));
3433 /* Fake up an import/unimport */
3434 if (arg && arg->op_type == OP_STUB)
3435 imop = arg; /* no import on explicit () */
3436 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3437 imop = Nullop; /* use 5.0; */
3442 /* Make copy of id so we don't free it twice */
3443 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3445 /* Fake up a method call to import/unimport */
3446 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3447 (void)SvUPGRADE(meth, SVt_PVIV);
3448 (void)SvIOK_on(meth);
3449 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3450 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3451 append_elem(OP_LIST,
3452 prepend_elem(OP_LIST, pack, list(arg)),
3453 newSVOP(OP_METHOD_NAMED, 0, meth)));
3456 if (ckWARN(WARN_MISC) &&
3457 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3458 SvPOK(packsv = ((SVOP*)id)->op_sv))
3460 /* BEGIN will free the ops, so we need to make a copy */
3461 packlen = SvCUR(packsv);
3462 packname = savepvn(SvPVX(packsv), packlen);
3465 /* Fake up the BEGIN {}, which does its thing immediately. */
3467 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3470 append_elem(OP_LINESEQ,
3471 append_elem(OP_LINESEQ,
3472 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3473 newSTATEOP(0, Nullch, veop)),
3474 newSTATEOP(0, Nullch, imop) ));
3477 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3478 Perl_warner(aTHX_ WARN_MISC,
3479 "Package `%s' not found "
3480 "(did you use the incorrect case?)", packname);
3485 PL_hints |= HINT_BLOCK_SCOPE;
3486 PL_copline = NOLINE;
3491 =head1 Embedding Functions
3493 =for apidoc load_module
3495 Loads the module whose name is pointed to by the string part of name.
3496 Note that the actual module name, not its filename, should be given.
3497 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3498 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3499 (or 0 for no flags). ver, if specified, provides version semantics
3500 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3501 arguments can be used to specify arguments to the module's import()
3502 method, similar to C<use Foo::Bar VERSION LIST>.
3507 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3510 va_start(args, ver);
3511 vload_module(flags, name, ver, &args);
3515 #ifdef PERL_IMPLICIT_CONTEXT
3517 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3521 va_start(args, ver);
3522 vload_module(flags, name, ver, &args);
3528 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3530 OP *modname, *veop, *imop;
3532 modname = newSVOP(OP_CONST, 0, name);
3533 modname->op_private |= OPpCONST_BARE;
3535 veop = newSVOP(OP_CONST, 0, ver);
3539 if (flags & PERL_LOADMOD_NOIMPORT) {
3540 imop = sawparens(newNULLLIST());
3542 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3543 imop = va_arg(*args, OP*);
3548 sv = va_arg(*args, SV*);
3550 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3551 sv = va_arg(*args, SV*);
3555 line_t ocopline = PL_copline;
3556 int oexpect = PL_expect;
3558 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3559 veop, modname, imop);
3560 PL_expect = oexpect;
3561 PL_copline = ocopline;
3566 Perl_dofile(pTHX_ OP *term)
3571 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3572 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3573 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3575 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3576 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3577 append_elem(OP_LIST, term,
3578 scalar(newUNOP(OP_RV2CV, 0,
3583 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3589 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3591 return newBINOP(OP_LSLICE, flags,
3592 list(force_list(subscript)),
3593 list(force_list(listval)) );
3597 S_list_assignment(pTHX_ register OP *o)
3602 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3603 o = cUNOPo->op_first;
3605 if (o->op_type == OP_COND_EXPR) {
3606 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3607 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3612 yyerror("Assignment to both a list and a scalar");
3616 if (o->op_type == OP_LIST &&
3617 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3618 o->op_private & OPpLVAL_INTRO)
3621 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3622 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3623 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3626 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3629 if (o->op_type == OP_RV2SV)
3636 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3641 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3642 return newLOGOP(optype, 0,
3643 mod(scalar(left), optype),
3644 newUNOP(OP_SASSIGN, 0, scalar(right)));
3647 return newBINOP(optype, OPf_STACKED,
3648 mod(scalar(left), optype), scalar(right));
3652 if (list_assignment(left)) {
3656 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3657 left = mod(left, OP_AASSIGN);
3665 curop = list(force_list(left));
3666 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3667 o->op_private = 0 | (flags >> 8);
3668 for (curop = ((LISTOP*)curop)->op_first;
3669 curop; curop = curop->op_sibling)
3671 if (curop->op_type == OP_RV2HV &&
3672 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3673 o->op_private |= OPpASSIGN_HASH;
3677 if (!(left->op_private & OPpLVAL_INTRO)) {
3680 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3681 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3682 if (curop->op_type == OP_GV) {
3683 GV *gv = cGVOPx_gv(curop);
3684 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3686 SvCUR(gv) = PL_generation;
3688 else if (curop->op_type == OP_PADSV ||
3689 curop->op_type == OP_PADAV ||
3690 curop->op_type == OP_PADHV ||
3691 curop->op_type == OP_PADANY) {
3692 SV **svp = AvARRAY(PL_comppad_name);
3693 SV *sv = svp[curop->op_targ];
3694 if (SvCUR(sv) == PL_generation)
3696 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3698 else if (curop->op_type == OP_RV2CV)
3700 else if (curop->op_type == OP_RV2SV ||
3701 curop->op_type == OP_RV2AV ||
3702 curop->op_type == OP_RV2HV ||
3703 curop->op_type == OP_RV2GV) {
3704 if (lastop->op_type != OP_GV) /* funny deref? */
3707 else if (curop->op_type == OP_PUSHRE) {
3708 if (((PMOP*)curop)->op_pmreplroot) {
3710 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3712 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3714 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3716 SvCUR(gv) = PL_generation;
3725 o->op_private |= OPpASSIGN_COMMON;
3727 if (right && right->op_type == OP_SPLIT) {
3729 if ((tmpop = ((LISTOP*)right)->op_first) &&
3730 tmpop->op_type == OP_PUSHRE)
3732 PMOP *pm = (PMOP*)tmpop;
3733 if (left->op_type == OP_RV2AV &&
3734 !(left->op_private & OPpLVAL_INTRO) &&
3735 !(o->op_private & OPpASSIGN_COMMON) )
3737 tmpop = ((UNOP*)left)->op_first;
3738 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3740 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3741 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3743 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3744 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3746 pm->op_pmflags |= PMf_ONCE;
3747 tmpop = cUNOPo->op_first; /* to list (nulled) */
3748 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3749 tmpop->op_sibling = Nullop; /* don't free split */
3750 right->op_next = tmpop->op_next; /* fix starting loc */
3751 op_free(o); /* blow off assign */
3752 right->op_flags &= ~OPf_WANT;
3753 /* "I don't know and I don't care." */
3758 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3759 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3761 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3763 sv_setiv(sv, PL_modcount+1);
3771 right = newOP(OP_UNDEF, 0);
3772 if (right->op_type == OP_READLINE) {
3773 right->op_flags |= OPf_STACKED;
3774 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3777 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3778 o = newBINOP(OP_SASSIGN, flags,
3779 scalar(right), mod(scalar(left), OP_SASSIGN) );
3791 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3793 U32 seq = intro_my();
3796 NewOp(1101, cop, 1, COP);
3797 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3798 cop->op_type = OP_DBSTATE;
3799 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3802 cop->op_type = OP_NEXTSTATE;
3803 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3805 cop->op_flags = flags;
3806 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3808 cop->op_private |= NATIVE_HINTS;
3810 PL_compiling.op_private = cop->op_private;
3811 cop->op_next = (OP*)cop;
3814 cop->cop_label = label;
3815 PL_hints |= HINT_BLOCK_SCOPE;
3818 cop->cop_arybase = PL_curcop->cop_arybase;
3819 if (specialWARN(PL_curcop->cop_warnings))
3820 cop->cop_warnings = PL_curcop->cop_warnings ;
3822 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3823 if (specialCopIO(PL_curcop->cop_io))
3824 cop->cop_io = PL_curcop->cop_io;
3826 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3829 if (PL_copline == NOLINE)
3830 CopLINE_set(cop, CopLINE(PL_curcop));
3832 CopLINE_set(cop, PL_copline);
3833 PL_copline = NOLINE;
3836 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3838 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3840 CopSTASH_set(cop, PL_curstash);
3842 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3843 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3844 if (svp && *svp != &PL_sv_undef ) {
3845 (void)SvIOK_on(*svp);
3846 SvIVX(*svp) = PTR2IV(cop);
3850 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3853 /* "Introduce" my variables to visible status. */
3861 if (! PL_min_intro_pending)
3862 return PL_cop_seqmax;
3864 svp = AvARRAY(PL_comppad_name);
3865 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3866 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3867 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3868 SvNVX(sv) = (NV)PL_cop_seqmax;
3871 PL_min_intro_pending = 0;
3872 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3873 return PL_cop_seqmax++;
3877 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3879 return new_logop(type, flags, &first, &other);
3883 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3887 OP *first = *firstp;
3888 OP *other = *otherp;
3890 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3891 return newBINOP(type, flags, scalar(first), scalar(other));
3893 scalarboolean(first);
3894 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3895 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3896 if (type == OP_AND || type == OP_OR) {
3902 first = *firstp = cUNOPo->op_first;
3904 first->op_next = o->op_next;
3905 cUNOPo->op_first = Nullop;
3909 if (first->op_type == OP_CONST) {
3910 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3911 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3912 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3923 else if (first->op_type == OP_WANTARRAY) {
3929 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3930 OP *k1 = ((UNOP*)first)->op_first;
3931 OP *k2 = k1->op_sibling;
3933 switch (first->op_type)
3936 if (k2 && k2->op_type == OP_READLINE
3937 && (k2->op_flags & OPf_STACKED)
3938 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3940 warnop = k2->op_type;
3945 if (k1->op_type == OP_READDIR
3946 || k1->op_type == OP_GLOB
3947 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3948 || k1->op_type == OP_EACH)
3950 warnop = ((k1->op_type == OP_NULL)
3951 ? k1->op_targ : k1->op_type);
3956 line_t oldline = CopLINE(PL_curcop);
3957 CopLINE_set(PL_curcop, PL_copline);
3958 Perl_warner(aTHX_ WARN_MISC,
3959 "Value of %s%s can be \"0\"; test with defined()",
3961 ((warnop == OP_READLINE || warnop == OP_GLOB)
3962 ? " construct" : "() operator"));
3963 CopLINE_set(PL_curcop, oldline);
3970 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3971 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3973 NewOp(1101, logop, 1, LOGOP);
3975 logop->op_type = type;
3976 logop->op_ppaddr = PL_ppaddr[type];
3977 logop->op_first = first;
3978 logop->op_flags = flags | OPf_KIDS;
3979 logop->op_other = LINKLIST(other);
3980 logop->op_private = 1 | (flags >> 8);
3982 /* establish postfix order */
3983 logop->op_next = LINKLIST(first);
3984 first->op_next = (OP*)logop;
3985 first->op_sibling = other;
3987 o = newUNOP(OP_NULL, 0, (OP*)logop);
3994 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4001 return newLOGOP(OP_AND, 0, first, trueop);
4003 return newLOGOP(OP_OR, 0, first, falseop);
4005 scalarboolean(first);
4006 if (first->op_type == OP_CONST) {
4007 if (SvTRUE(((SVOP*)first)->op_sv)) {
4018 else if (first->op_type == OP_WANTARRAY) {
4022 NewOp(1101, logop, 1, LOGOP);
4023 logop->op_type = OP_COND_EXPR;
4024 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4025 logop->op_first = first;
4026 logop->op_flags = flags | OPf_KIDS;
4027 logop->op_private = 1 | (flags >> 8);
4028 logop->op_other = LINKLIST(trueop);
4029 logop->op_next = LINKLIST(falseop);
4032 /* establish postfix order */
4033 start = LINKLIST(first);
4034 first->op_next = (OP*)logop;
4036 first->op_sibling = trueop;
4037 trueop->op_sibling = falseop;
4038 o = newUNOP(OP_NULL, 0, (OP*)logop);
4040 trueop->op_next = falseop->op_next = o;
4047 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4055 NewOp(1101, range, 1, LOGOP);
4057 range->op_type = OP_RANGE;
4058 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4059 range->op_first = left;
4060 range->op_flags = OPf_KIDS;
4061 leftstart = LINKLIST(left);
4062 range->op_other = LINKLIST(right);
4063 range->op_private = 1 | (flags >> 8);
4065 left->op_sibling = right;
4067 range->op_next = (OP*)range;
4068 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4069 flop = newUNOP(OP_FLOP, 0, flip);
4070 o = newUNOP(OP_NULL, 0, flop);
4072 range->op_next = leftstart;
4074 left->op_next = flip;
4075 right->op_next = flop;
4077 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4078 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4079 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4080 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4082 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4083 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4086 if (!flip->op_private || !flop->op_private)
4087 linklist(o); /* blow off optimizer unless constant */
4093 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4097 int once = block && block->op_flags & OPf_SPECIAL &&
4098 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4101 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4102 return block; /* do {} while 0 does once */
4103 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4104 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4105 expr = newUNOP(OP_DEFINED, 0,
4106 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4107 } else if (expr->op_flags & OPf_KIDS) {
4108 OP *k1 = ((UNOP*)expr)->op_first;
4109 OP *k2 = (k1) ? k1->op_sibling : NULL;
4110 switch (expr->op_type) {
4112 if (k2 && k2->op_type == OP_READLINE
4113 && (k2->op_flags & OPf_STACKED)
4114 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4115 expr = newUNOP(OP_DEFINED, 0, expr);
4119 if (k1->op_type == OP_READDIR
4120 || k1->op_type == OP_GLOB
4121 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4122 || k1->op_type == OP_EACH)
4123 expr = newUNOP(OP_DEFINED, 0, expr);
4129 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4130 o = new_logop(OP_AND, 0, &expr, &listop);
4133 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4135 if (once && o != listop)
4136 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4139 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4141 o->op_flags |= flags;
4143 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4148 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4156 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4157 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4158 expr = newUNOP(OP_DEFINED, 0,
4159 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4160 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4161 OP *k1 = ((UNOP*)expr)->op_first;
4162 OP *k2 = (k1) ? k1->op_sibling : NULL;
4163 switch (expr->op_type) {
4165 if (k2 && k2->op_type == OP_READLINE
4166 && (k2->op_flags & OPf_STACKED)
4167 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4168 expr = newUNOP(OP_DEFINED, 0, expr);
4172 if (k1->op_type == OP_READDIR
4173 || k1->op_type == OP_GLOB
4174 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4175 || k1->op_type == OP_EACH)
4176 expr = newUNOP(OP_DEFINED, 0, expr);
4182 block = newOP(OP_NULL, 0);
4184 block = scope(block);
4188 next = LINKLIST(cont);
4191 OP *unstack = newOP(OP_UNSTACK, 0);
4194 cont = append_elem(OP_LINESEQ, cont, unstack);
4195 if ((line_t)whileline != NOLINE) {
4196 PL_copline = whileline;
4197 cont = append_elem(OP_LINESEQ, cont,
4198 newSTATEOP(0, Nullch, Nullop));
4202 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4203 redo = LINKLIST(listop);
4206 PL_copline = whileline;
4208 o = new_logop(OP_AND, 0, &expr, &listop);
4209 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4210 op_free(expr); /* oops, it's a while (0) */
4212 return Nullop; /* listop already freed by new_logop */
4215 ((LISTOP*)listop)->op_last->op_next =
4216 (o == listop ? redo : LINKLIST(o));
4222 NewOp(1101,loop,1,LOOP);
4223 loop->op_type = OP_ENTERLOOP;
4224 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4225 loop->op_private = 0;
4226 loop->op_next = (OP*)loop;
4229 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4231 loop->op_redoop = redo;
4232 loop->op_lastop = o;
4233 o->op_private |= loopflags;
4236 loop->op_nextop = next;
4238 loop->op_nextop = o;
4240 o->op_flags |= flags;
4241 o->op_private |= (flags >> 8);
4246 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4254 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4255 sv->op_type = OP_RV2GV;
4256 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4258 else if (sv->op_type == OP_PADSV) { /* private variable */
4259 padoff = sv->op_targ;
4264 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4265 padoff = sv->op_targ;
4267 iterflags |= OPf_SPECIAL;
4272 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4275 #ifdef USE_5005THREADS
4276 padoff = find_threadsv("_");
4277 iterflags |= OPf_SPECIAL;
4279 sv = newGVOP(OP_GV, 0, PL_defgv);
4282 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4283 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4284 iterflags |= OPf_STACKED;
4286 else if (expr->op_type == OP_NULL &&
4287 (expr->op_flags & OPf_KIDS) &&
4288 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4290 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4291 * set the STACKED flag to indicate that these values are to be
4292 * treated as min/max values by 'pp_iterinit'.
4294 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4295 LOGOP* range = (LOGOP*) flip->op_first;
4296 OP* left = range->op_first;
4297 OP* right = left->op_sibling;
4300 range->op_flags &= ~OPf_KIDS;
4301 range->op_first = Nullop;
4303 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4304 listop->op_first->op_next = range->op_next;
4305 left->op_next = range->op_other;
4306 right->op_next = (OP*)listop;
4307 listop->op_next = listop->op_first;
4310 expr = (OP*)(listop);
4312 iterflags |= OPf_STACKED;
4315 expr = mod(force_list(expr), OP_GREPSTART);
4319 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4320 append_elem(OP_LIST, expr, scalar(sv))));
4321 assert(!loop->op_next);
4322 #ifdef PL_OP_SLAB_ALLOC
4325 NewOp(1234,tmp,1,LOOP);
4326 Copy(loop,tmp,1,LOOP);
4331 Renew(loop, 1, LOOP);
4333 loop->op_targ = padoff;
4334 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4335 PL_copline = forline;
4336 return newSTATEOP(0, label, wop);
4340 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4345 if (type != OP_GOTO || label->op_type == OP_CONST) {
4346 /* "last()" means "last" */
4347 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4348 o = newOP(type, OPf_SPECIAL);
4350 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4351 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4357 if (label->op_type == OP_ENTERSUB)
4358 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4359 o = newUNOP(type, OPf_STACKED, label);
4361 PL_hints |= HINT_BLOCK_SCOPE;
4366 Perl_cv_undef(pTHX_ CV *cv)
4368 #ifdef USE_5005THREADS
4370 MUTEX_DESTROY(CvMUTEXP(cv));
4371 Safefree(CvMUTEXP(cv));
4374 #endif /* USE_5005THREADS */
4377 if (CvFILE(cv) && !CvXSUB(cv)) {
4378 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4379 Safefree(CvFILE(cv));
4384 if (!CvXSUB(cv) && CvROOT(cv)) {
4385 #ifdef USE_5005THREADS
4386 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4387 Perl_croak(aTHX_ "Can't undef active subroutine");
4390 Perl_croak(aTHX_ "Can't undef active subroutine");
4391 #endif /* USE_5005THREADS */
4394 SAVEVPTR(PL_curpad);
4397 op_free(CvROOT(cv));
4398 CvROOT(cv) = Nullop;
4401 SvPOK_off((SV*)cv); /* forget prototype */
4403 /* Since closure prototypes have the same lifetime as the containing
4404 * CV, they don't hold a refcount on the outside CV. This avoids
4405 * the refcount loop between the outer CV (which keeps a refcount to
4406 * the closure prototype in the pad entry for pp_anoncode()) and the
4407 * closure prototype, and the ensuing memory leak. --GSAR */
4408 if (!CvANON(cv) || CvCLONED(cv))
4409 SvREFCNT_dec(CvOUTSIDE(cv));
4410 CvOUTSIDE(cv) = Nullcv;
4412 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4415 if (CvPADLIST(cv)) {
4416 /* may be during global destruction */
4417 if (SvREFCNT(CvPADLIST(cv))) {
4418 I32 i = AvFILLp(CvPADLIST(cv));
4420 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4421 SV* sv = svp ? *svp : Nullsv;
4424 if (sv == (SV*)PL_comppad_name)
4425 PL_comppad_name = Nullav;
4426 else if (sv == (SV*)PL_comppad) {
4427 PL_comppad = Nullav;
4428 PL_curpad = Null(SV**);
4432 SvREFCNT_dec((SV*)CvPADLIST(cv));
4434 CvPADLIST(cv) = Nullav;
4442 #ifdef DEBUG_CLOSURES
4444 S_cv_dump(pTHX_ CV *cv)
4447 CV *outside = CvOUTSIDE(cv);
4448 AV* padlist = CvPADLIST(cv);
4455 PerlIO_printf(Perl_debug_log,
4456 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4458 (CvANON(cv) ? "ANON"
4459 : (cv == PL_main_cv) ? "MAIN"
4460 : CvUNIQUE(cv) ? "UNIQUE"
4461 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4464 : CvANON(outside) ? "ANON"
4465 : (outside == PL_main_cv) ? "MAIN"
4466 : CvUNIQUE(outside) ? "UNIQUE"
4467 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4472 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4473 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4474 pname = AvARRAY(pad_name);
4475 ppad = AvARRAY(pad);
4477 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4478 if (SvPOK(pname[ix]))
4479 PerlIO_printf(Perl_debug_log,
4480 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4481 (int)ix, PTR2UV(ppad[ix]),
4482 SvFAKE(pname[ix]) ? "FAKE " : "",
4484 (IV)I_32(SvNVX(pname[ix])),
4487 #endif /* DEBUGGING */
4489 #endif /* DEBUG_CLOSURES */
4492 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4496 AV* protopadlist = CvPADLIST(proto);
4497 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4498 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4499 SV** pname = AvARRAY(protopad_name);
4500 SV** ppad = AvARRAY(protopad);
4501 I32 fname = AvFILLp(protopad_name);
4502 I32 fpad = AvFILLp(protopad);
4506 assert(!CvUNIQUE(proto));
4510 SAVESPTR(PL_comppad_name);
4511 SAVESPTR(PL_compcv);
4513 cv = PL_compcv = (CV*)NEWSV(1104,0);
4514 sv_upgrade((SV *)cv, SvTYPE(proto));
4515 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4518 #ifdef USE_5005THREADS
4519 New(666, CvMUTEXP(cv), 1, perl_mutex);
4520 MUTEX_INIT(CvMUTEXP(cv));
4522 #endif /* USE_5005THREADS */
4524 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4525 : savepv(CvFILE(proto));
4527 CvFILE(cv) = CvFILE(proto);
4529 CvGV(cv) = CvGV(proto);
4530 CvSTASH(cv) = CvSTASH(proto);
4531 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4532 CvSTART(cv) = CvSTART(proto);
4534 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4537 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4539 PL_comppad_name = newAV();
4540 for (ix = fname; ix >= 0; ix--)
4541 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4543 PL_comppad = newAV();
4545 comppadlist = newAV();
4546 AvREAL_off(comppadlist);
4547 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4548 av_store(comppadlist, 1, (SV*)PL_comppad);
4549 CvPADLIST(cv) = comppadlist;
4550 av_fill(PL_comppad, AvFILLp(protopad));
4551 PL_curpad = AvARRAY(PL_comppad);
4553 av = newAV(); /* will be @_ */
4555 av_store(PL_comppad, 0, (SV*)av);
4556 AvFLAGS(av) = AVf_REIFY;
4558 for (ix = fpad; ix > 0; ix--) {
4559 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4560 if (namesv && namesv != &PL_sv_undef) {
4561 char *name = SvPVX(namesv); /* XXX */
4562 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4563 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4564 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4566 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4568 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4570 else { /* our own lexical */
4573 /* anon code -- we'll come back for it */
4574 sv = SvREFCNT_inc(ppad[ix]);
4576 else if (*name == '@')
4578 else if (*name == '%')
4587 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4588 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4591 SV* sv = NEWSV(0,0);
4597 /* Now that vars are all in place, clone nested closures. */
4599 for (ix = fpad; ix > 0; ix--) {
4600 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4602 && namesv != &PL_sv_undef
4603 && !(SvFLAGS(namesv) & SVf_FAKE)
4604 && *SvPVX(namesv) == '&'
4605 && CvCLONE(ppad[ix]))
4607 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4608 SvREFCNT_dec(ppad[ix]);
4611 PL_curpad[ix] = (SV*)kid;
4615 #ifdef DEBUG_CLOSURES
4616 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4618 PerlIO_printf(Perl_debug_log, " from:\n");
4620 PerlIO_printf(Perl_debug_log, " to:\n");
4627 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4629 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4631 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4638 Perl_cv_clone(pTHX_ CV *proto)
4641 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4642 cv = cv_clone2(proto, CvOUTSIDE(proto));
4643 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4648 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4650 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4651 SV* msg = sv_newmortal();
4655 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4656 sv_setpv(msg, "Prototype mismatch:");
4658 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4660 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4661 sv_catpv(msg, " vs ");
4663 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4665 sv_catpv(msg, "none");
4666 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4670 static void const_sv_xsub(pTHX_ CV* cv);
4674 =head1 Optree Manipulation Functions
4676 =for apidoc cv_const_sv
4678 If C<cv> is a constant sub eligible for inlining. returns the constant
4679 value returned by the sub. Otherwise, returns NULL.
4681 Constant subs can be created with C<newCONSTSUB> or as described in
4682 L<perlsub/"Constant Functions">.
4687 Perl_cv_const_sv(pTHX_ CV *cv)
4689 if (!cv || !CvCONST(cv))
4691 return (SV*)CvXSUBANY(cv).any_ptr;
4695 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4702 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4703 o = cLISTOPo->op_first->op_sibling;
4705 for (; o; o = o->op_next) {
4706 OPCODE type = o->op_type;
4708 if (sv && o->op_next == o)
4710 if (o->op_next != o) {
4711 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4713 if (type == OP_DBSTATE)
4716 if (type == OP_LEAVESUB || type == OP_RETURN)
4720 if (type == OP_CONST && cSVOPo->op_sv)
4722 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4723 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4724 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4728 /* We get here only from cv_clone2() while creating a closure.
4729 Copy the const value here instead of in cv_clone2 so that
4730 SvREADONLY_on doesn't lead to problems when leaving
4735 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4747 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4757 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4761 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4763 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4767 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4773 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4778 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4779 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4780 SV *sv = sv_newmortal();
4781 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4782 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4787 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4788 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4798 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4799 maximum a prototype before. */
4800 if (SvTYPE(gv) > SVt_NULL) {
4801 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4802 && ckWARN_d(WARN_PROTOTYPE))
4804 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4806 cv_ckproto((CV*)gv, NULL, ps);
4809 sv_setpv((SV*)gv, ps);
4811 sv_setiv((SV*)gv, -1);
4812 SvREFCNT_dec(PL_compcv);
4813 cv = PL_compcv = NULL;
4814 PL_sub_generation++;
4818 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4820 #ifdef GV_UNIQUE_CHECK
4821 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4822 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4826 if (!block || !ps || *ps || attrs)
4829 const_sv = op_const_sv(block, Nullcv);
4832 bool exists = CvROOT(cv) || CvXSUB(cv);
4834 #ifdef GV_UNIQUE_CHECK
4835 if (exists && GvUNIQUE(gv)) {
4836 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4840 /* if the subroutine doesn't exist and wasn't pre-declared
4841 * with a prototype, assume it will be AUTOLOADed,
4842 * skipping the prototype check
4844 if (exists || SvPOK(cv))
4845 cv_ckproto(cv, gv, ps);
4846 /* already defined (or promised)? */
4847 if (exists || GvASSUMECV(gv)) {
4848 if (!block && !attrs) {
4849 /* just a "sub foo;" when &foo is already defined */
4850 SAVEFREESV(PL_compcv);
4853 /* ahem, death to those who redefine active sort subs */
4854 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4855 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4857 if (ckWARN(WARN_REDEFINE)
4859 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4861 line_t oldline = CopLINE(PL_curcop);
4862 if (PL_copline != NOLINE)
4863 CopLINE_set(PL_curcop, PL_copline);
4864 Perl_warner(aTHX_ WARN_REDEFINE,
4865 CvCONST(cv) ? "Constant subroutine %s redefined"
4866 : "Subroutine %s redefined", name);
4867 CopLINE_set(PL_curcop, oldline);
4875 SvREFCNT_inc(const_sv);
4877 assert(!CvROOT(cv) && !CvCONST(cv));
4878 sv_setpv((SV*)cv, ""); /* prototype is "" */
4879 CvXSUBANY(cv).any_ptr = const_sv;
4880 CvXSUB(cv) = const_sv_xsub;
4885 cv = newCONSTSUB(NULL, name, const_sv);
4888 SvREFCNT_dec(PL_compcv);
4890 PL_sub_generation++;
4897 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4898 * before we clobber PL_compcv.
4902 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4903 stash = GvSTASH(CvGV(cv));
4904 else if (CvSTASH(cv))
4905 stash = CvSTASH(cv);
4907 stash = PL_curstash;
4910 /* possibly about to re-define existing subr -- ignore old cv */
4911 rcv = (SV*)PL_compcv;
4912 if (name && GvSTASH(gv))
4913 stash = GvSTASH(gv);
4915 stash = PL_curstash;
4917 apply_attrs(stash, rcv, attrs, FALSE);
4919 if (cv) { /* must reuse cv if autoloaded */
4921 /* got here with just attrs -- work done, so bug out */
4922 SAVEFREESV(PL_compcv);
4926 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4927 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4928 CvOUTSIDE(PL_compcv) = 0;
4929 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4930 CvPADLIST(PL_compcv) = 0;
4931 /* inner references to PL_compcv must be fixed up ... */
4933 AV *padlist = CvPADLIST(cv);
4934 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4935 AV *comppad = (AV*)AvARRAY(padlist)[1];
4936 SV **namepad = AvARRAY(comppad_name);
4937 SV **curpad = AvARRAY(comppad);
4938 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4939 SV *namesv = namepad[ix];
4940 if (namesv && namesv != &PL_sv_undef
4941 && *SvPVX(namesv) == '&')
4943 CV *innercv = (CV*)curpad[ix];
4944 if (CvOUTSIDE(innercv) == PL_compcv) {
4945 CvOUTSIDE(innercv) = cv;
4946 if (!CvANON(innercv) || CvCLONED(innercv)) {
4947 (void)SvREFCNT_inc(cv);
4948 SvREFCNT_dec(PL_compcv);
4954 /* ... before we throw it away */
4955 SvREFCNT_dec(PL_compcv);
4956 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4957 ++PL_sub_generation;
4964 PL_sub_generation++;
4968 CvFILE_set_from_cop(cv, PL_curcop);
4969 CvSTASH(cv) = PL_curstash;
4970 #ifdef USE_5005THREADS
4972 if (!CvMUTEXP(cv)) {
4973 New(666, CvMUTEXP(cv), 1, perl_mutex);
4974 MUTEX_INIT(CvMUTEXP(cv));
4976 #endif /* USE_5005THREADS */
4979 sv_setpv((SV*)cv, ps);
4981 if (PL_error_count) {
4985 char *s = strrchr(name, ':');
4987 if (strEQ(s, "BEGIN")) {
4989 "BEGIN not safe after errors--compilation aborted";
4990 if (PL_in_eval & EVAL_KEEPERR)
4991 Perl_croak(aTHX_ not_safe);
4993 /* force display of errors found but not reported */
4994 sv_catpv(ERRSV, not_safe);
4995 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
5003 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5004 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5007 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5008 mod(scalarseq(block), OP_LEAVESUBLV));
5011 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5013 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5014 OpREFCNT_set(CvROOT(cv), 1);
5015 CvSTART(cv) = LINKLIST(CvROOT(cv));
5016 CvROOT(cv)->op_next = 0;
5017 CALL_PEEP(CvSTART(cv));
5019 /* now that optimizer has done its work, adjust pad values */
5021 SV **namep = AvARRAY(PL_comppad_name);
5022 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5025 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5028 * The only things that a clonable function needs in its
5029 * pad are references to outer lexicals and anonymous subs.
5030 * The rest are created anew during cloning.
5032 if (!((namesv = namep[ix]) != Nullsv &&
5033 namesv != &PL_sv_undef &&
5035 *SvPVX(namesv) == '&')))
5037 SvREFCNT_dec(PL_curpad[ix]);
5038 PL_curpad[ix] = Nullsv;
5041 assert(!CvCONST(cv));
5042 if (ps && !*ps && op_const_sv(block, cv))
5046 AV *av = newAV(); /* Will be @_ */
5048 av_store(PL_comppad, 0, (SV*)av);
5049 AvFLAGS(av) = AVf_REIFY;
5051 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5052 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5054 if (!SvPADMY(PL_curpad[ix]))
5055 SvPADTMP_on(PL_curpad[ix]);
5059 /* If a potential closure prototype, don't keep a refcount on outer CV.
5060 * This is okay as the lifetime of the prototype is tied to the
5061 * lifetime of the outer CV. Avoids memory leak due to reference
5064 SvREFCNT_dec(CvOUTSIDE(cv));
5066 if (name || aname) {
5068 char *tname = (name ? name : aname);
5070 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5071 SV *sv = NEWSV(0,0);
5072 SV *tmpstr = sv_newmortal();
5073 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5077 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5079 (long)PL_subline, (long)CopLINE(PL_curcop));
5080 gv_efullname3(tmpstr, gv, Nullch);
5081 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5082 hv = GvHVn(db_postponed);
5083 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5084 && (pcv = GvCV(db_postponed)))
5090 call_sv((SV*)pcv, G_DISCARD);
5094 if ((s = strrchr(tname,':')))
5099 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5102 if (strEQ(s, "BEGIN")) {
5103 I32 oldscope = PL_scopestack_ix;
5105 SAVECOPFILE(&PL_compiling);
5106 SAVECOPLINE(&PL_compiling);
5109 PL_beginav = newAV();
5110 DEBUG_x( dump_sub(gv) );
5111 av_push(PL_beginav, (SV*)cv);
5112 GvCV(gv) = 0; /* cv has been hijacked */
5113 call_list(oldscope, PL_beginav);
5115 PL_curcop = &PL_compiling;
5116 PL_compiling.op_private = PL_hints;
5119 else if (strEQ(s, "END") && !PL_error_count) {
5122 DEBUG_x( dump_sub(gv) );
5123 av_unshift(PL_endav, 1);
5124 av_store(PL_endav, 0, (SV*)cv);
5125 GvCV(gv) = 0; /* cv has been hijacked */
5127 else if (strEQ(s, "CHECK") && !PL_error_count) {
5129 PL_checkav = newAV();
5130 DEBUG_x( dump_sub(gv) );
5131 if (PL_main_start && ckWARN(WARN_VOID))
5132 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5133 av_unshift(PL_checkav, 1);
5134 av_store(PL_checkav, 0, (SV*)cv);
5135 GvCV(gv) = 0; /* cv has been hijacked */
5137 else if (strEQ(s, "INIT") && !PL_error_count) {
5139 PL_initav = newAV();
5140 DEBUG_x( dump_sub(gv) );
5141 if (PL_main_start && ckWARN(WARN_VOID))
5142 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5143 av_push(PL_initav, (SV*)cv);
5144 GvCV(gv) = 0; /* cv has been hijacked */
5149 PL_copline = NOLINE;
5154 /* XXX unsafe for threads if eval_owner isn't held */
5156 =for apidoc newCONSTSUB
5158 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5159 eligible for inlining at compile-time.
5165 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5171 SAVECOPLINE(PL_curcop);
5172 CopLINE_set(PL_curcop, PL_copline);
5175 PL_hints &= ~HINT_BLOCK_SCOPE;
5178 SAVESPTR(PL_curstash);
5179 SAVECOPSTASH(PL_curcop);
5180 PL_curstash = stash;
5181 CopSTASH_set(PL_curcop,stash);
5184 cv = newXS(name, const_sv_xsub, __FILE__);
5185 CvXSUBANY(cv).any_ptr = sv;
5187 sv_setpv((SV*)cv, ""); /* prototype is "" */
5195 =for apidoc U||newXS
5197 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5203 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5205 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5208 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5210 /* just a cached method */
5214 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5215 /* already defined (or promised) */
5216 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5217 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5218 line_t oldline = CopLINE(PL_curcop);
5219 if (PL_copline != NOLINE)
5220 CopLINE_set(PL_curcop, PL_copline);
5221 Perl_warner(aTHX_ WARN_REDEFINE,
5222 CvCONST(cv) ? "Constant subroutine %s redefined"
5223 : "Subroutine %s redefined"
5225 CopLINE_set(PL_curcop, oldline);
5232 if (cv) /* must reuse cv if autoloaded */
5235 cv = (CV*)NEWSV(1105,0);
5236 sv_upgrade((SV *)cv, SVt_PVCV);
5240 PL_sub_generation++;
5244 #ifdef USE_5005THREADS
5245 New(666, CvMUTEXP(cv), 1, perl_mutex);
5246 MUTEX_INIT(CvMUTEXP(cv));
5248 #endif /* USE_5005THREADS */
5249 (void)gv_fetchfile(filename);
5250 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5251 an external constant string */
5252 CvXSUB(cv) = subaddr;
5255 char *s = strrchr(name,':');
5261 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5264 if (strEQ(s, "BEGIN")) {
5266 PL_beginav = newAV();
5267 av_push(PL_beginav, (SV*)cv);
5268 GvCV(gv) = 0; /* cv has been hijacked */
5270 else if (strEQ(s, "END")) {
5273 av_unshift(PL_endav, 1);
5274 av_store(PL_endav, 0, (SV*)cv);
5275 GvCV(gv) = 0; /* cv has been hijacked */
5277 else if (strEQ(s, "CHECK")) {
5279 PL_checkav = newAV();
5280 if (PL_main_start && ckWARN(WARN_VOID))
5281 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5282 av_unshift(PL_checkav, 1);
5283 av_store(PL_checkav, 0, (SV*)cv);
5284 GvCV(gv) = 0; /* cv has been hijacked */
5286 else if (strEQ(s, "INIT")) {
5288 PL_initav = newAV();
5289 if (PL_main_start && ckWARN(WARN_VOID))
5290 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5291 av_push(PL_initav, (SV*)cv);
5292 GvCV(gv) = 0; /* cv has been hijacked */
5303 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5312 name = SvPVx(cSVOPo->op_sv, n_a);
5315 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5316 #ifdef GV_UNIQUE_CHECK
5318 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5322 if ((cv = GvFORM(gv))) {
5323 if (ckWARN(WARN_REDEFINE)) {
5324 line_t oldline = CopLINE(PL_curcop);
5325 if (PL_copline != NOLINE)
5326 CopLINE_set(PL_curcop, PL_copline);
5327 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5328 CopLINE_set(PL_curcop, oldline);
5335 CvFILE_set_from_cop(cv, PL_curcop);
5337 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5338 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5339 SvPADTMP_on(PL_curpad[ix]);
5342 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5343 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5344 OpREFCNT_set(CvROOT(cv), 1);
5345 CvSTART(cv) = LINKLIST(CvROOT(cv));
5346 CvROOT(cv)->op_next = 0;
5347 CALL_PEEP(CvSTART(cv));
5349 PL_copline = NOLINE;
5354 Perl_newANONLIST(pTHX_ OP *o)
5356 return newUNOP(OP_REFGEN, 0,
5357 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5361 Perl_newANONHASH(pTHX_ OP *o)
5363 return newUNOP(OP_REFGEN, 0,
5364 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5368 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5370 return newANONATTRSUB(floor, proto, Nullop, block);
5374 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5376 return newUNOP(OP_REFGEN, 0,
5377 newSVOP(OP_ANONCODE, 0,
5378 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5382 Perl_oopsAV(pTHX_ OP *o)
5384 switch (o->op_type) {
5386 o->op_type = OP_PADAV;
5387 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5388 return ref(o, OP_RV2AV);
5391 o->op_type = OP_RV2AV;
5392 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5397 if (ckWARN_d(WARN_INTERNAL))
5398 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5405 Perl_oopsHV(pTHX_ OP *o)
5407 switch (o->op_type) {
5410 o->op_type = OP_PADHV;
5411 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5412 return ref(o, OP_RV2HV);
5416 o->op_type = OP_RV2HV;
5417 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5422 if (ckWARN_d(WARN_INTERNAL))
5423 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5430 Perl_newAVREF(pTHX_ OP *o)
5432 if (o->op_type == OP_PADANY) {
5433 o->op_type = OP_PADAV;
5434 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5437 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5438 && ckWARN(WARN_DEPRECATED)) {
5439 Perl_warner(aTHX_ WARN_DEPRECATED,
5440 "Using an array as a reference is deprecated");
5442 return newUNOP(OP_RV2AV, 0, scalar(o));
5446 Perl_newGVREF(pTHX_ I32 type, OP *o)
5448 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5449 return newUNOP(OP_NULL, 0, o);
5450 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5454 Perl_newHVREF(pTHX_ OP *o)
5456 if (o->op_type == OP_PADANY) {
5457 o->op_type = OP_PADHV;
5458 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5461 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5462 && ckWARN(WARN_DEPRECATED)) {
5463 Perl_warner(aTHX_ WARN_DEPRECATED,
5464 "Using a hash as a reference is deprecated");
5466 return newUNOP(OP_RV2HV, 0, scalar(o));
5470 Perl_oopsCV(pTHX_ OP *o)
5472 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5478 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5480 return newUNOP(OP_RV2CV, flags, scalar(o));
5484 Perl_newSVREF(pTHX_ OP *o)
5486 if (o->op_type == OP_PADANY) {
5487 o->op_type = OP_PADSV;
5488 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5491 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5492 o->op_flags |= OPpDONE_SVREF;
5495 return newUNOP(OP_RV2SV, 0, scalar(o));
5498 /* Check routines. */
5501 Perl_ck_anoncode(pTHX_ OP *o)
5506 name = NEWSV(1106,0);
5507 sv_upgrade(name, SVt_PVNV);
5508 sv_setpvn(name, "&", 1);
5511 ix = pad_alloc(o->op_type, SVs_PADMY);
5512 av_store(PL_comppad_name, ix, name);
5513 av_store(PL_comppad, ix, cSVOPo->op_sv);
5514 SvPADMY_on(cSVOPo->op_sv);
5515 cSVOPo->op_sv = Nullsv;
5516 cSVOPo->op_targ = ix;
5521 Perl_ck_bitop(pTHX_ OP *o)
5523 o->op_private = PL_hints;
5528 Perl_ck_concat(pTHX_ OP *o)
5530 if (cUNOPo->op_first->op_type == OP_CONCAT)
5531 o->op_flags |= OPf_STACKED;
5536 Perl_ck_spair(pTHX_ OP *o)
5538 if (o->op_flags & OPf_KIDS) {
5541 OPCODE type = o->op_type;
5542 o = modkids(ck_fun(o), type);
5543 kid = cUNOPo->op_first;
5544 newop = kUNOP->op_first->op_sibling;
5546 (newop->op_sibling ||
5547 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5548 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5549 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5553 op_free(kUNOP->op_first);
5554 kUNOP->op_first = newop;
5556 o->op_ppaddr = PL_ppaddr[++o->op_type];
5561 Perl_ck_delete(pTHX_ OP *o)
5565 if (o->op_flags & OPf_KIDS) {
5566 OP *kid = cUNOPo->op_first;
5567 switch (kid->op_type) {
5569 o->op_flags |= OPf_SPECIAL;
5572 o->op_private |= OPpSLICE;
5575 o->op_flags |= OPf_SPECIAL;
5580 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5589 Perl_ck_die(pTHX_ OP *o)
5592 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5598 Perl_ck_eof(pTHX_ OP *o)
5600 I32 type = o->op_type;
5602 if (o->op_flags & OPf_KIDS) {
5603 if (cLISTOPo->op_first->op_type == OP_STUB) {
5605 o = newUNOP(type, OPf_SPECIAL,
5606 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5614 Perl_ck_eval(pTHX_ OP *o)
5616 PL_hints |= HINT_BLOCK_SCOPE;
5617 if (o->op_flags & OPf_KIDS) {
5618 SVOP *kid = (SVOP*)cUNOPo->op_first;
5621 o->op_flags &= ~OPf_KIDS;
5624 else if (kid->op_type == OP_LINESEQ) {
5627 kid->op_next = o->op_next;
5628 cUNOPo->op_first = 0;
5631 NewOp(1101, enter, 1, LOGOP);
5632 enter->op_type = OP_ENTERTRY;
5633 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5634 enter->op_private = 0;
5636 /* establish postfix order */
5637 enter->op_next = (OP*)enter;
5639 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5640 o->op_type = OP_LEAVETRY;
5641 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5642 enter->op_other = o;
5650 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5652 o->op_targ = (PADOFFSET)PL_hints;
5657 Perl_ck_exit(pTHX_ OP *o)
5660 HV *table = GvHV(PL_hintgv);
5662 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5663 if (svp && *svp && SvTRUE(*svp))
5664 o->op_private |= OPpEXIT_VMSISH;
5666 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5672 Perl_ck_exec(pTHX_ OP *o)
5675 if (o->op_flags & OPf_STACKED) {
5677 kid = cUNOPo->op_first->op_sibling;
5678 if (kid->op_type == OP_RV2GV)
5687 Perl_ck_exists(pTHX_ OP *o)
5690 if (o->op_flags & OPf_KIDS) {
5691 OP *kid = cUNOPo->op_first;
5692 if (kid->op_type == OP_ENTERSUB) {
5693 (void) ref(kid, o->op_type);
5694 if (kid->op_type != OP_RV2CV && !PL_error_count)
5695 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5697 o->op_private |= OPpEXISTS_SUB;
5699 else if (kid->op_type == OP_AELEM)
5700 o->op_flags |= OPf_SPECIAL;
5701 else if (kid->op_type != OP_HELEM)
5702 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5711 Perl_ck_gvconst(pTHX_ register OP *o)
5713 o = fold_constants(o);
5714 if (o->op_type == OP_CONST)
5721 Perl_ck_rvconst(pTHX_ register OP *o)
5723 SVOP *kid = (SVOP*)cUNOPo->op_first;
5725 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5726 if (kid->op_type == OP_CONST) {
5730 SV *kidsv = kid->op_sv;
5733 /* Is it a constant from cv_const_sv()? */
5734 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5735 SV *rsv = SvRV(kidsv);
5736 int svtype = SvTYPE(rsv);
5737 char *badtype = Nullch;
5739 switch (o->op_type) {
5741 if (svtype > SVt_PVMG)
5742 badtype = "a SCALAR";
5745 if (svtype != SVt_PVAV)
5746 badtype = "an ARRAY";
5749 if (svtype != SVt_PVHV) {
5750 if (svtype == SVt_PVAV) { /* pseudohash? */
5751 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5752 if (ksv && SvROK(*ksv)
5753 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5762 if (svtype != SVt_PVCV)
5767 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5770 name = SvPV(kidsv, n_a);
5771 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5772 char *badthing = Nullch;
5773 switch (o->op_type) {
5775 badthing = "a SCALAR";
5778 badthing = "an ARRAY";
5781 badthing = "a HASH";
5786 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5790 * This is a little tricky. We only want to add the symbol if we
5791 * didn't add it in the lexer. Otherwise we get duplicate strict
5792 * warnings. But if we didn't add it in the lexer, we must at
5793 * least pretend like we wanted to add it even if it existed before,
5794 * or we get possible typo warnings. OPpCONST_ENTERED says
5795 * whether the lexer already added THIS instance of this symbol.
5797 iscv = (o->op_type == OP_RV2CV) * 2;
5799 gv = gv_fetchpv(name,
5800 iscv | !(kid->op_private & OPpCONST_ENTERED),
5803 : o->op_type == OP_RV2SV
5805 : o->op_type == OP_RV2AV
5807 : o->op_type == OP_RV2HV
5810 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5812 kid->op_type = OP_GV;
5813 SvREFCNT_dec(kid->op_sv);
5815 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5816 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5817 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5819 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5821 kid->op_sv = SvREFCNT_inc(gv);
5823 kid->op_private = 0;
5824 kid->op_ppaddr = PL_ppaddr[OP_GV];
5831 Perl_ck_ftst(pTHX_ OP *o)
5833 I32 type = o->op_type;
5835 if (o->op_flags & OPf_REF) {
5838 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5839 SVOP *kid = (SVOP*)cUNOPo->op_first;
5841 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5843 OP *newop = newGVOP(type, OPf_REF,
5844 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5851 if (type == OP_FTTTY)
5852 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5855 o = newUNOP(type, 0, newDEFSVOP());
5861 Perl_ck_fun(pTHX_ OP *o)
5867 int type = o->op_type;
5868 register I32 oa = PL_opargs[type] >> OASHIFT;
5870 if (o->op_flags & OPf_STACKED) {
5871 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5874 return no_fh_allowed(o);
5877 if (o->op_flags & OPf_KIDS) {
5879 tokid = &cLISTOPo->op_first;
5880 kid = cLISTOPo->op_first;
5881 if (kid->op_type == OP_PUSHMARK ||
5882 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5884 tokid = &kid->op_sibling;
5885 kid = kid->op_sibling;
5887 if (!kid && PL_opargs[type] & OA_DEFGV)
5888 *tokid = kid = newDEFSVOP();
5892 sibl = kid->op_sibling;
5895 /* list seen where single (scalar) arg expected? */
5896 if (numargs == 1 && !(oa >> 4)
5897 && kid->op_type == OP_LIST && type != OP_SCALAR)
5899 return too_many_arguments(o,PL_op_desc[type]);
5912 if ((type == OP_PUSH || type == OP_UNSHIFT)
5913 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5914 Perl_warner(aTHX_ WARN_SYNTAX,
5915 "Useless use of %s with no values",
5918 if (kid->op_type == OP_CONST &&
5919 (kid->op_private & OPpCONST_BARE))
5921 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5922 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5923 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5924 if (ckWARN(WARN_DEPRECATED))
5925 Perl_warner(aTHX_ WARN_DEPRECATED,
5926 "Array @%s missing the @ in argument %"IVdf" of %s()",
5927 name, (IV)numargs, PL_op_desc[type]);
5930 kid->op_sibling = sibl;
5933 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5934 bad_type(numargs, "array", PL_op_desc[type], kid);
5938 if (kid->op_type == OP_CONST &&
5939 (kid->op_private & OPpCONST_BARE))
5941 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5942 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5943 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5944 if (ckWARN(WARN_DEPRECATED))
5945 Perl_warner(aTHX_ WARN_DEPRECATED,
5946 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5947 name, (IV)numargs, PL_op_desc[type]);
5950 kid->op_sibling = sibl;
5953 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5954 bad_type(numargs, "hash", PL_op_desc[type], kid);
5959 OP *newop = newUNOP(OP_NULL, 0, kid);
5960 kid->op_sibling = 0;
5962 newop->op_next = newop;
5964 kid->op_sibling = sibl;
5969 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5970 if (kid->op_type == OP_CONST &&
5971 (kid->op_private & OPpCONST_BARE))
5973 OP *newop = newGVOP(OP_GV, 0,
5974 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5976 if (kid == cLISTOPo->op_last)
5977 cLISTOPo->op_last = newop;
5981 else if (kid->op_type == OP_READLINE) {
5982 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5983 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5986 I32 flags = OPf_SPECIAL;
5990 /* is this op a FH constructor? */
5991 if (is_handle_constructor(o,numargs)) {
5992 char *name = Nullch;
5996 /* Set a flag to tell rv2gv to vivify
5997 * need to "prove" flag does not mean something
5998 * else already - NI-S 1999/05/07
6001 if (kid->op_type == OP_PADSV) {
6002 SV **namep = av_fetch(PL_comppad_name,
6004 if (namep && *namep)
6005 name = SvPV(*namep, len);
6007 else if (kid->op_type == OP_RV2SV
6008 && kUNOP->op_first->op_type == OP_GV)
6010 GV *gv = cGVOPx_gv(kUNOP->op_first);
6012 len = GvNAMELEN(gv);
6014 else if (kid->op_type == OP_AELEM
6015 || kid->op_type == OP_HELEM)
6017 name = "__ANONIO__";
6023 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6024 namesv = PL_curpad[targ];
6025 (void)SvUPGRADE(namesv, SVt_PV);
6027 sv_setpvn(namesv, "$", 1);
6028 sv_catpvn(namesv, name, len);
6031 kid->op_sibling = 0;
6032 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6033 kid->op_targ = targ;
6034 kid->op_private |= priv;
6036 kid->op_sibling = sibl;
6042 mod(scalar(kid), type);
6046 tokid = &kid->op_sibling;
6047 kid = kid->op_sibling;
6049 o->op_private |= numargs;
6051 return too_many_arguments(o,OP_DESC(o));
6054 else if (PL_opargs[type] & OA_DEFGV) {
6056 return newUNOP(type, 0, newDEFSVOP());
6060 while (oa & OA_OPTIONAL)
6062 if (oa && oa != OA_LIST)
6063 return too_few_arguments(o,OP_DESC(o));
6069 Perl_ck_glob(pTHX_ OP *o)
6074 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6075 append_elem(OP_GLOB, o, newDEFSVOP());
6077 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6078 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6080 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6083 #if !defined(PERL_EXTERNAL_GLOB)
6084 /* XXX this can be tightened up and made more failsafe. */
6088 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6089 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6090 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6091 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6092 GvCV(gv) = GvCV(glob_gv);
6093 SvREFCNT_inc((SV*)GvCV(gv));
6094 GvIMPORTED_CV_on(gv);
6097 #endif /* PERL_EXTERNAL_GLOB */
6099 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6100 append_elem(OP_GLOB, o,
6101 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6102 o->op_type = OP_LIST;
6103 o->op_ppaddr = PL_ppaddr[OP_LIST];
6104 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6105 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6106 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6107 append_elem(OP_LIST, o,
6108 scalar(newUNOP(OP_RV2CV, 0,
6109 newGVOP(OP_GV, 0, gv)))));
6110 o = newUNOP(OP_NULL, 0, ck_subr(o));
6111 o->op_targ = OP_GLOB; /* hint at what it used to be */
6114 gv = newGVgen("main");
6116 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6122 Perl_ck_grep(pTHX_ OP *o)
6126 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6128 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6129 NewOp(1101, gwop, 1, LOGOP);
6131 if (o->op_flags & OPf_STACKED) {
6134 kid = cLISTOPo->op_first->op_sibling;
6135 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6138 kid->op_next = (OP*)gwop;
6139 o->op_flags &= ~OPf_STACKED;
6141 kid = cLISTOPo->op_first->op_sibling;
6142 if (type == OP_MAPWHILE)
6149 kid = cLISTOPo->op_first->op_sibling;
6150 if (kid->op_type != OP_NULL)
6151 Perl_croak(aTHX_ "panic: ck_grep");
6152 kid = kUNOP->op_first;
6154 gwop->op_type = type;
6155 gwop->op_ppaddr = PL_ppaddr[type];
6156 gwop->op_first = listkids(o);
6157 gwop->op_flags |= OPf_KIDS;
6158 gwop->op_private = 1;
6159 gwop->op_other = LINKLIST(kid);
6160 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6161 kid->op_next = (OP*)gwop;
6163 kid = cLISTOPo->op_first->op_sibling;
6164 if (!kid || !kid->op_sibling)
6165 return too_few_arguments(o,OP_DESC(o));
6166 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6167 mod(kid, OP_GREPSTART);
6173 Perl_ck_index(pTHX_ OP *o)
6175 if (o->op_flags & OPf_KIDS) {
6176 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6178 kid = kid->op_sibling; /* get past "big" */
6179 if (kid && kid->op_type == OP_CONST)
6180 fbm_compile(((SVOP*)kid)->op_sv, 0);
6186 Perl_ck_lengthconst(pTHX_ OP *o)
6188 /* XXX length optimization goes here */
6193 Perl_ck_lfun(pTHX_ OP *o)
6195 OPCODE type = o->op_type;
6196 return modkids(ck_fun(o), type);
6200 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6202 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6203 switch (cUNOPo->op_first->op_type) {
6205 /* This is needed for
6206 if (defined %stash::)
6207 to work. Do not break Tk.
6209 break; /* Globals via GV can be undef */
6211 case OP_AASSIGN: /* Is this a good idea? */
6212 Perl_warner(aTHX_ WARN_DEPRECATED,
6213 "defined(@array) is deprecated");
6214 Perl_warner(aTHX_ WARN_DEPRECATED,
6215 "\t(Maybe you should just omit the defined()?)\n");
6218 /* This is needed for
6219 if (defined %stash::)
6220 to work. Do not break Tk.
6222 break; /* Globals via GV can be undef */
6224 Perl_warner(aTHX_ WARN_DEPRECATED,
6225 "defined(%%hash) is deprecated");
6226 Perl_warner(aTHX_ WARN_DEPRECATED,
6227 "\t(Maybe you should just omit the defined()?)\n");
6238 Perl_ck_rfun(pTHX_ OP *o)
6240 OPCODE type = o->op_type;
6241 return refkids(ck_fun(o), type);
6245 Perl_ck_listiob(pTHX_ OP *o)
6249 kid = cLISTOPo->op_first;
6252 kid = cLISTOPo->op_first;
6254 if (kid->op_type == OP_PUSHMARK)
6255 kid = kid->op_sibling;
6256 if (kid && o->op_flags & OPf_STACKED)
6257 kid = kid->op_sibling;
6258 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6259 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6260 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6261 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6262 cLISTOPo->op_first->op_sibling = kid;
6263 cLISTOPo->op_last = kid;
6264 kid = kid->op_sibling;
6269 append_elem(o->op_type, o, newDEFSVOP());
6275 Perl_ck_sassign(pTHX_ OP *o)
6277 OP *kid = cLISTOPo->op_first;
6278 /* has a disposable target? */
6279 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6280 && !(kid->op_flags & OPf_STACKED)
6281 /* Cannot steal the second time! */
6282 && !(kid->op_private & OPpTARGET_MY))
6284 OP *kkid = kid->op_sibling;
6286 /* Can just relocate the target. */
6287 if (kkid && kkid->op_type == OP_PADSV
6288 && !(kkid->op_private & OPpLVAL_INTRO))
6290 kid->op_targ = kkid->op_targ;
6292 /* Now we do not need PADSV and SASSIGN. */
6293 kid->op_sibling = o->op_sibling; /* NULL */
6294 cLISTOPo->op_first = NULL;
6297 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6305 Perl_ck_match(pTHX_ OP *o)
6307 o->op_private |= OPpRUNTIME;
6312 Perl_ck_method(pTHX_ OP *o)
6314 OP *kid = cUNOPo->op_first;
6315 if (kid->op_type == OP_CONST) {
6316 SV* sv = kSVOP->op_sv;
6317 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6319 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6320 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6323 kSVOP->op_sv = Nullsv;
6325 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6334 Perl_ck_null(pTHX_ OP *o)
6340 Perl_ck_open(pTHX_ OP *o)
6342 HV *table = GvHV(PL_hintgv);
6346 svp = hv_fetch(table, "open_IN", 7, FALSE);
6348 mode = mode_from_discipline(*svp);
6349 if (mode & O_BINARY)
6350 o->op_private |= OPpOPEN_IN_RAW;
6351 else if (mode & O_TEXT)
6352 o->op_private |= OPpOPEN_IN_CRLF;
6355 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6357 mode = mode_from_discipline(*svp);
6358 if (mode & O_BINARY)
6359 o->op_private |= OPpOPEN_OUT_RAW;
6360 else if (mode & O_TEXT)
6361 o->op_private |= OPpOPEN_OUT_CRLF;
6364 if (o->op_type == OP_BACKTICK)
6370 Perl_ck_repeat(pTHX_ OP *o)
6372 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6373 o->op_private |= OPpREPEAT_DOLIST;
6374 cBINOPo->op_first = force_list(cBINOPo->op_first);
6382 Perl_ck_require(pTHX_ OP *o)
6386 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6387 SVOP *kid = (SVOP*)cUNOPo->op_first;
6389 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6391 for (s = SvPVX(kid->op_sv); *s; s++) {
6392 if (*s == ':' && s[1] == ':') {
6394 Move(s+2, s+1, strlen(s+2)+1, char);
6395 --SvCUR(kid->op_sv);
6398 if (SvREADONLY(kid->op_sv)) {
6399 SvREADONLY_off(kid->op_sv);
6400 sv_catpvn(kid->op_sv, ".pm", 3);
6401 SvREADONLY_on(kid->op_sv);
6404 sv_catpvn(kid->op_sv, ".pm", 3);
6408 /* handle override, if any */
6409 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6410 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6411 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6413 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6414 OP *kid = cUNOPo->op_first;
6415 cUNOPo->op_first = 0;
6417 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6418 append_elem(OP_LIST, kid,
6419 scalar(newUNOP(OP_RV2CV, 0,
6428 Perl_ck_return(pTHX_ OP *o)
6431 if (CvLVALUE(PL_compcv)) {
6432 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6433 mod(kid, OP_LEAVESUBLV);
6440 Perl_ck_retarget(pTHX_ OP *o)
6442 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6449 Perl_ck_select(pTHX_ OP *o)
6452 if (o->op_flags & OPf_KIDS) {
6453 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6454 if (kid && kid->op_sibling) {
6455 o->op_type = OP_SSELECT;
6456 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6458 return fold_constants(o);
6462 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6463 if (kid && kid->op_type == OP_RV2GV)
6464 kid->op_private &= ~HINT_STRICT_REFS;
6469 Perl_ck_shift(pTHX_ OP *o)
6471 I32 type = o->op_type;
6473 if (!(o->op_flags & OPf_KIDS)) {
6477 #ifdef USE_5005THREADS
6478 if (!CvUNIQUE(PL_compcv)) {
6479 argop = newOP(OP_PADAV, OPf_REF);
6480 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6483 argop = newUNOP(OP_RV2AV, 0,
6484 scalar(newGVOP(OP_GV, 0,
6485 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6488 argop = newUNOP(OP_RV2AV, 0,
6489 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6490 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6491 #endif /* USE_5005THREADS */
6492 return newUNOP(type, 0, scalar(argop));
6494 return scalar(modkids(ck_fun(o), type));
6498 Perl_ck_sort(pTHX_ OP *o)
6502 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6504 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6505 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6507 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6509 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6511 if (kid->op_type == OP_SCOPE) {
6515 else if (kid->op_type == OP_LEAVE) {
6516 if (o->op_type == OP_SORT) {
6517 op_null(kid); /* wipe out leave */
6520 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6521 if (k->op_next == kid)
6523 /* don't descend into loops */
6524 else if (k->op_type == OP_ENTERLOOP
6525 || k->op_type == OP_ENTERITER)
6527 k = cLOOPx(k)->op_lastop;
6532 kid->op_next = 0; /* just disconnect the leave */
6533 k = kLISTOP->op_first;
6538 if (o->op_type == OP_SORT) {
6539 /* provide scalar context for comparison function/block */
6545 o->op_flags |= OPf_SPECIAL;
6547 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6550 firstkid = firstkid->op_sibling;
6553 /* provide list context for arguments */
6554 if (o->op_type == OP_SORT)
6561 S_simplify_sort(pTHX_ OP *o)
6563 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6567 if (!(o->op_flags & OPf_STACKED))
6569 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6570 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6571 kid = kUNOP->op_first; /* get past null */
6572 if (kid->op_type != OP_SCOPE)
6574 kid = kLISTOP->op_last; /* get past scope */
6575 switch(kid->op_type) {
6583 k = kid; /* remember this node*/
6584 if (kBINOP->op_first->op_type != OP_RV2SV)
6586 kid = kBINOP->op_first; /* get past cmp */
6587 if (kUNOP->op_first->op_type != OP_GV)
6589 kid = kUNOP->op_first; /* get past rv2sv */
6591 if (GvSTASH(gv) != PL_curstash)
6593 if (strEQ(GvNAME(gv), "a"))
6595 else if (strEQ(GvNAME(gv), "b"))
6599 kid = k; /* back to cmp */
6600 if (kBINOP->op_last->op_type != OP_RV2SV)
6602 kid = kBINOP->op_last; /* down to 2nd arg */
6603 if (kUNOP->op_first->op_type != OP_GV)
6605 kid = kUNOP->op_first; /* get past rv2sv */
6607 if (GvSTASH(gv) != PL_curstash
6609 ? strNE(GvNAME(gv), "a")
6610 : strNE(GvNAME(gv), "b")))
6612 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6614 o->op_private |= OPpSORT_REVERSE;
6615 if (k->op_type == OP_NCMP)
6616 o->op_private |= OPpSORT_NUMERIC;
6617 if (k->op_type == OP_I_NCMP)
6618 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6619 kid = cLISTOPo->op_first->op_sibling;
6620 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6621 op_free(kid); /* then delete it */
6625 Perl_ck_split(pTHX_ OP *o)
6629 if (o->op_flags & OPf_STACKED)
6630 return no_fh_allowed(o);
6632 kid = cLISTOPo->op_first;
6633 if (kid->op_type != OP_NULL)
6634 Perl_croak(aTHX_ "panic: ck_split");
6635 kid = kid->op_sibling;
6636 op_free(cLISTOPo->op_first);
6637 cLISTOPo->op_first = kid;
6639 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6640 cLISTOPo->op_last = kid; /* There was only one element previously */
6643 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6644 OP *sibl = kid->op_sibling;
6645 kid->op_sibling = 0;
6646 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6647 if (cLISTOPo->op_first == cLISTOPo->op_last)
6648 cLISTOPo->op_last = kid;
6649 cLISTOPo->op_first = kid;
6650 kid->op_sibling = sibl;
6653 kid->op_type = OP_PUSHRE;
6654 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6657 if (!kid->op_sibling)
6658 append_elem(OP_SPLIT, o, newDEFSVOP());
6660 kid = kid->op_sibling;
6663 if (!kid->op_sibling)
6664 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6666 kid = kid->op_sibling;
6669 if (kid->op_sibling)
6670 return too_many_arguments(o,OP_DESC(o));
6676 Perl_ck_join(pTHX_ OP *o)
6678 if (ckWARN(WARN_SYNTAX)) {
6679 OP *kid = cLISTOPo->op_first->op_sibling;
6680 if (kid && kid->op_type == OP_MATCH) {
6681 char *pmstr = "STRING";
6682 if (PM_GETRE(kPMOP))
6683 pmstr = PM_GETRE(kPMOP)->precomp;
6684 Perl_warner(aTHX_ WARN_SYNTAX,
6685 "/%s/ should probably be written as \"%s\"",
6693 Perl_ck_subr(pTHX_ OP *o)
6695 OP *prev = ((cUNOPo->op_first->op_sibling)
6696 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6697 OP *o2 = prev->op_sibling;
6704 I32 contextclass = 0;
6708 o->op_private |= OPpENTERSUB_HASTARG;
6709 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6710 if (cvop->op_type == OP_RV2CV) {
6712 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6713 op_null(cvop); /* disable rv2cv */
6714 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6715 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6716 GV *gv = cGVOPx_gv(tmpop);
6719 tmpop->op_private |= OPpEARLY_CV;
6720 else if (SvPOK(cv)) {
6721 namegv = CvANON(cv) ? gv : CvGV(cv);
6722 proto = SvPV((SV*)cv, n_a);
6726 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6727 if (o2->op_type == OP_CONST)
6728 o2->op_private &= ~OPpCONST_STRICT;
6729 else if (o2->op_type == OP_LIST) {
6730 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6731 if (o && o->op_type == OP_CONST)
6732 o->op_private &= ~OPpCONST_STRICT;
6735 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6736 if (PERLDB_SUB && PL_curstash != PL_debstash)
6737 o->op_private |= OPpENTERSUB_DB;
6738 while (o2 != cvop) {
6742 return too_many_arguments(o, gv_ename(namegv));
6760 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6762 arg == 1 ? "block or sub {}" : "sub {}",
6763 gv_ename(namegv), o2);
6766 /* '*' allows any scalar type, including bareword */
6769 if (o2->op_type == OP_RV2GV)
6770 goto wrapref; /* autoconvert GLOB -> GLOBref */
6771 else if (o2->op_type == OP_CONST)
6772 o2->op_private &= ~OPpCONST_STRICT;
6773 else if (o2->op_type == OP_ENTERSUB) {
6774 /* accidental subroutine, revert to bareword */
6775 OP *gvop = ((UNOP*)o2)->op_first;
6776 if (gvop && gvop->op_type == OP_NULL) {
6777 gvop = ((UNOP*)gvop)->op_first;
6779 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6782 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6783 (gvop = ((UNOP*)gvop)->op_first) &&
6784 gvop->op_type == OP_GV)
6786 GV *gv = cGVOPx_gv(gvop);
6787 OP *sibling = o2->op_sibling;
6788 SV *n = newSVpvn("",0);
6790 gv_fullname3(n, gv, "");
6791 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6792 sv_chop(n, SvPVX(n)+6);
6793 o2 = newSVOP(OP_CONST, 0, n);
6794 prev->op_sibling = o2;
6795 o2->op_sibling = sibling;
6811 if (contextclass++ == 0) {
6812 e = strchr(proto, ']');
6813 if (!e || e == proto)
6826 while (*--p != '[');
6827 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6828 gv_ename(namegv), o2);
6834 if (o2->op_type == OP_RV2GV)
6837 bad_type(arg, "symbol", gv_ename(namegv), o2);
6840 if (o2->op_type == OP_ENTERSUB)
6843 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6846 if (o2->op_type == OP_RV2SV ||
6847 o2->op_type == OP_PADSV ||
6848 o2->op_type == OP_HELEM ||
6849 o2->op_type == OP_AELEM ||
6850 o2->op_type == OP_THREADSV)
6853 bad_type(arg, "scalar", gv_ename(namegv), o2);
6856 if (o2->op_type == OP_RV2AV ||
6857 o2->op_type == OP_PADAV)
6860 bad_type(arg, "array", gv_ename(namegv), o2);
6863 if (o2->op_type == OP_RV2HV ||
6864 o2->op_type == OP_PADHV)
6867 bad_type(arg, "hash", gv_ename(namegv), o2);
6872 OP* sib = kid->op_sibling;
6873 kid->op_sibling = 0;
6874 o2 = newUNOP(OP_REFGEN, 0, kid);
6875 o2->op_sibling = sib;
6876 prev->op_sibling = o2;
6878 if (contextclass && e) {
6893 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6894 gv_ename(namegv), SvPV((SV*)cv, n_a));
6899 mod(o2, OP_ENTERSUB);
6901 o2 = o2->op_sibling;
6903 if (proto && !optional &&
6904 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6905 return too_few_arguments(o, gv_ename(namegv));
6910 Perl_ck_svconst(pTHX_ OP *o)
6912 SvREADONLY_on(cSVOPo->op_sv);
6917 Perl_ck_trunc(pTHX_ OP *o)
6919 if (o->op_flags & OPf_KIDS) {
6920 SVOP *kid = (SVOP*)cUNOPo->op_first;
6922 if (kid->op_type == OP_NULL)
6923 kid = (SVOP*)kid->op_sibling;
6924 if (kid && kid->op_type == OP_CONST &&
6925 (kid->op_private & OPpCONST_BARE))
6927 o->op_flags |= OPf_SPECIAL;
6928 kid->op_private &= ~OPpCONST_STRICT;
6935 Perl_ck_substr(pTHX_ OP *o)
6938 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6939 OP *kid = cLISTOPo->op_first;
6941 if (kid->op_type == OP_NULL)
6942 kid = kid->op_sibling;
6944 kid->op_flags |= OPf_MOD;
6950 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6953 Perl_peep(pTHX_ register OP *o)
6955 register OP* oldop = 0;
6958 if (!o || o->op_seq)
6962 SAVEVPTR(PL_curcop);
6963 for (; o; o = o->op_next) {
6969 switch (o->op_type) {
6973 PL_curcop = ((COP*)o); /* for warnings */
6974 o->op_seq = PL_op_seqmax++;
6978 if (cSVOPo->op_private & OPpCONST_STRICT)
6979 no_bareword_allowed(o);
6981 /* Relocate sv to the pad for thread safety.
6982 * Despite being a "constant", the SV is written to,
6983 * for reference counts, sv_upgrade() etc. */
6985 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6986 if (SvPADTMP(cSVOPo->op_sv)) {
6987 /* If op_sv is already a PADTMP then it is being used by
6988 * some pad, so make a copy. */
6989 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6990 SvREADONLY_on(PL_curpad[ix]);
6991 SvREFCNT_dec(cSVOPo->op_sv);
6994 SvREFCNT_dec(PL_curpad[ix]);
6995 SvPADTMP_on(cSVOPo->op_sv);
6996 PL_curpad[ix] = cSVOPo->op_sv;
6997 /* XXX I don't know how this isn't readonly already. */
6998 SvREADONLY_on(PL_curpad[ix]);
7000 cSVOPo->op_sv = Nullsv;
7004 o->op_seq = PL_op_seqmax++;
7008 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7009 if (o->op_next->op_private & OPpTARGET_MY) {
7010 if (o->op_flags & OPf_STACKED) /* chained concats */
7011 goto ignore_optimization;
7013 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7014 o->op_targ = o->op_next->op_targ;
7015 o->op_next->op_targ = 0;
7016 o->op_private |= OPpTARGET_MY;
7019 op_null(o->op_next);
7021 ignore_optimization:
7022 o->op_seq = PL_op_seqmax++;
7025 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7026 o->op_seq = PL_op_seqmax++;
7027 break; /* Scalar stub must produce undef. List stub is noop */
7031 if (o->op_targ == OP_NEXTSTATE
7032 || o->op_targ == OP_DBSTATE
7033 || o->op_targ == OP_SETSTATE)
7035 PL_curcop = ((COP*)o);
7037 /* XXX: We avoid setting op_seq here to prevent later calls
7038 to peep() from mistakenly concluding that optimisation
7039 has already occurred. This doesn't fix the real problem,
7040 though (See 20010220.007). AMS 20010719 */
7041 if (oldop && o->op_next) {
7042 oldop->op_next = o->op_next;
7050 if (oldop && o->op_next) {
7051 oldop->op_next = o->op_next;
7054 o->op_seq = PL_op_seqmax++;
7058 if (o->op_next->op_type == OP_RV2SV) {
7059 if (!(o->op_next->op_private & OPpDEREF)) {
7060 op_null(o->op_next);
7061 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7063 o->op_next = o->op_next->op_next;
7064 o->op_type = OP_GVSV;
7065 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7068 else if (o->op_next->op_type == OP_RV2AV) {
7069 OP* pop = o->op_next->op_next;
7071 if (pop && pop->op_type == OP_CONST &&
7072 (PL_op = pop->op_next) &&
7073 pop->op_next->op_type == OP_AELEM &&
7074 !(pop->op_next->op_private &
7075 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7076 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7081 op_null(o->op_next);
7082 op_null(pop->op_next);
7084 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7085 o->op_next = pop->op_next->op_next;
7086 o->op_type = OP_AELEMFAST;
7087 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7088 o->op_private = (U8)i;
7093 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7095 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7096 /* XXX could check prototype here instead of just carping */
7097 SV *sv = sv_newmortal();
7098 gv_efullname3(sv, gv, Nullch);
7099 Perl_warner(aTHX_ WARN_PROTOTYPE,
7100 "%s() called too early to check prototype",
7104 else if (o->op_next->op_type == OP_READLINE
7105 && o->op_next->op_next->op_type == OP_CONCAT
7106 && (o->op_next->op_next->op_flags & OPf_STACKED))
7108 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7109 o->op_type = OP_RCATLINE;
7110 o->op_flags |= OPf_STACKED;
7111 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7112 op_null(o->op_next->op_next);
7113 op_null(o->op_next);
7116 o->op_seq = PL_op_seqmax++;
7127 o->op_seq = PL_op_seqmax++;
7128 while (cLOGOP->op_other->op_type == OP_NULL)
7129 cLOGOP->op_other = cLOGOP->op_other->op_next;
7130 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7135 o->op_seq = PL_op_seqmax++;
7136 while (cLOOP->op_redoop->op_type == OP_NULL)
7137 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7138 peep(cLOOP->op_redoop);
7139 while (cLOOP->op_nextop->op_type == OP_NULL)
7140 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7141 peep(cLOOP->op_nextop);
7142 while (cLOOP->op_lastop->op_type == OP_NULL)
7143 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7144 peep(cLOOP->op_lastop);
7150 o->op_seq = PL_op_seqmax++;
7151 while (cPMOP->op_pmreplstart &&
7152 cPMOP->op_pmreplstart->op_type == OP_NULL)
7153 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7154 peep(cPMOP->op_pmreplstart);
7158 o->op_seq = PL_op_seqmax++;
7159 if (ckWARN(WARN_SYNTAX) && o->op_next
7160 && o->op_next->op_type == OP_NEXTSTATE) {
7161 if (o->op_next->op_sibling &&
7162 o->op_next->op_sibling->op_type != OP_EXIT &&
7163 o->op_next->op_sibling->op_type != OP_WARN &&
7164 o->op_next->op_sibling->op_type != OP_DIE) {
7165 line_t oldline = CopLINE(PL_curcop);
7167 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7168 Perl_warner(aTHX_ WARN_EXEC,
7169 "Statement unlikely to be reached");
7170 Perl_warner(aTHX_ WARN_EXEC,
7171 "\t(Maybe you meant system() when you said exec()?)\n");
7172 CopLINE_set(PL_curcop, oldline);
7181 SV **svp, **indsvp, *sv;
7186 o->op_seq = PL_op_seqmax++;
7188 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7191 /* Make the CONST have a shared SV */
7192 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7193 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7194 key = SvPV(sv, keylen);
7195 lexname = newSVpvn_share(key,
7196 SvUTF8(sv) ? -(I32)keylen : keylen,
7202 if ((o->op_private & (OPpLVAL_INTRO)))
7205 rop = (UNOP*)((BINOP*)o)->op_first;
7206 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7208 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7209 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7211 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7212 if (!fields || !GvHV(*fields))
7214 key = SvPV(*svp, keylen);
7215 indsvp = hv_fetch(GvHV(*fields), key,
7216 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7218 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7219 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7221 ind = SvIV(*indsvp);
7223 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7224 rop->op_type = OP_RV2AV;
7225 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7226 o->op_type = OP_AELEM;
7227 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7229 if (SvREADONLY(*svp))
7231 SvFLAGS(sv) |= (SvFLAGS(*svp)
7232 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7242 SV **svp, **indsvp, *sv;
7246 SVOP *first_key_op, *key_op;
7248 o->op_seq = PL_op_seqmax++;
7249 if ((o->op_private & (OPpLVAL_INTRO))
7250 /* I bet there's always a pushmark... */
7251 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7252 /* hmmm, no optimization if list contains only one key. */
7254 rop = (UNOP*)((LISTOP*)o)->op_last;
7255 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7257 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7258 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7260 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7261 if (!fields || !GvHV(*fields))
7263 /* Again guessing that the pushmark can be jumped over.... */
7264 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7265 ->op_first->op_sibling;
7266 /* Check that the key list contains only constants. */
7267 for (key_op = first_key_op; key_op;
7268 key_op = (SVOP*)key_op->op_sibling)
7269 if (key_op->op_type != OP_CONST)
7273 rop->op_type = OP_RV2AV;
7274 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7275 o->op_type = OP_ASLICE;
7276 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7277 for (key_op = first_key_op; key_op;
7278 key_op = (SVOP*)key_op->op_sibling) {
7279 svp = cSVOPx_svp(key_op);
7280 key = SvPV(*svp, keylen);
7281 indsvp = hv_fetch(GvHV(*fields), key,
7282 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7284 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7285 "in variable %s of type %s",
7286 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7288 ind = SvIV(*indsvp);
7290 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7292 if (SvREADONLY(*svp))
7294 SvFLAGS(sv) |= (SvFLAGS(*svp)
7295 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7303 o->op_seq = PL_op_seqmax++;
7313 char* Perl_custom_op_name(pTHX_ OP* o)
7315 IV index = PTR2IV(o->op_ppaddr);
7319 if (!PL_custom_op_names) /* This probably shouldn't happen */
7320 return PL_op_name[OP_CUSTOM];
7322 keysv = sv_2mortal(newSViv(index));
7324 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7326 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7328 return SvPV_nolen(HeVAL(he));
7331 char* Perl_custom_op_desc(pTHX_ OP* o)
7333 IV index = PTR2IV(o->op_ppaddr);
7337 if (!PL_custom_op_descs)
7338 return PL_op_desc[OP_CUSTOM];
7340 keysv = sv_2mortal(newSViv(index));
7342 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7344 return PL_op_desc[OP_CUSTOM];
7346 return SvPV_nolen(HeVAL(he));
7352 /* Efficient sub that returns a constant scalar value. */
7354 const_sv_xsub(pTHX_ CV* cv)
7359 Perl_croak(aTHX_ "usage: %s::%s()",
7360 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7364 ST(0) = (SV*)XSANY.any_ptr;