3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
47 if ((PL_OpSpace -= sz) < 0) {
48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
63 PL_OpPtr += PERL_SLAB_SIZE;
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
77 S_Slab_Free(pTHX_ void *op)
79 I32 **ptr = (I32 **) op;
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
85 PerlMemShared_free(slab);
86 if (slab == PL_OpSlab) {
93 #define NewOp(m, var, c, type) Newz(m, var, c, type)
94 #define FreeOp(p) Safefree(p)
97 * In the following definition, the ", Nullop" is just to make the compiler
98 * think the expression is of the right type: croak actually does a Siglongjmp.
100 #define CHECKOP(type,o) \
101 ((PL_op_mask && PL_op_mask[type]) \
102 ? ( op_free((OP*)o), \
103 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
105 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
107 #define PAD_MAX 999999999
108 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
111 S_gv_ename(pTHX_ GV *gv)
114 SV* tmpsv = sv_newmortal();
115 gv_efullname3(tmpsv, gv, Nullch);
116 return SvPV(tmpsv,n_a);
120 S_no_fh_allowed(pTHX_ OP *o)
122 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
128 S_too_few_arguments(pTHX_ OP *o, char *name)
130 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
135 S_too_many_arguments(pTHX_ OP *o, char *name)
137 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
142 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
144 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
145 (int)n, name, t, OP_DESC(kid)));
149 S_no_bareword_allowed(pTHX_ OP *o)
151 qerror(Perl_mess(aTHX_
152 "Bareword \"%s\" not allowed while \"strict subs\" in use",
153 SvPV_nolen(cSVOPo_sv)));
156 /* "register" allocation */
159 Perl_pad_allocmy(pTHX_ char *name)
164 if (!(PL_in_my == KEY_our ||
166 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
167 (name[1] == '_' && (int)strlen(name) > 2)))
169 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
170 /* 1999-02-27 mjd@plover.com */
172 p = strchr(name, '\0');
173 /* The next block assumes the buffer is at least 205 chars
174 long. At present, it's always at least 256 chars. */
176 strcpy(name+200, "...");
182 /* Move everything else down one character */
183 for (; p-name > 2; p--)
185 name[2] = toCTRL(name[1]);
188 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
190 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
191 SV **svp = AvARRAY(PL_comppad_name);
192 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
193 PADOFFSET top = AvFILLp(PL_comppad_name);
194 for (off = top; off > PL_comppad_name_floor; off--) {
196 && sv != &PL_sv_undef
197 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
198 && (PL_in_my != KEY_our
199 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
200 && strEQ(name, SvPVX(sv)))
202 Perl_warner(aTHX_ packWARN(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_ packWARN(WARN_MISC),
220 "\"our\" variable %s redeclared", name);
221 Perl_warner(aTHX_ packWARN(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_ packWARN(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_ packWARN(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_ packWARN(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)) {
930 char *s = SvPV(cop->cop_io,len);
931 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
934 SvREFCNT_dec(cop->cop_io);
940 Perl_op_null(pTHX_ OP *o)
942 if (o->op_type == OP_NULL)
945 o->op_targ = o->op_type;
946 o->op_type = OP_NULL;
947 o->op_ppaddr = PL_ppaddr[OP_NULL];
950 /* Contextualizers */
952 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
955 Perl_linklist(pTHX_ OP *o)
962 /* establish postfix order */
963 if (cUNOPo->op_first) {
964 o->op_next = LINKLIST(cUNOPo->op_first);
965 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
967 kid->op_next = LINKLIST(kid->op_sibling);
979 Perl_scalarkids(pTHX_ OP *o)
982 if (o && o->op_flags & OPf_KIDS) {
983 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
990 S_scalarboolean(pTHX_ OP *o)
992 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
993 if (ckWARN(WARN_SYNTAX)) {
994 line_t oldline = CopLINE(PL_curcop);
996 if (PL_copline != NOLINE)
997 CopLINE_set(PL_curcop, PL_copline);
998 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
999 CopLINE_set(PL_curcop, oldline);
1006 Perl_scalar(pTHX_ OP *o)
1010 /* assumes no premature commitment */
1011 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1012 || o->op_type == OP_RETURN)
1017 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1019 switch (o->op_type) {
1021 scalar(cBINOPo->op_first);
1026 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1030 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1031 if (!kPMOP->op_pmreplroot)
1032 deprecate_old("implicit split to @_");
1040 if (o->op_flags & OPf_KIDS) {
1041 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1047 kid = cLISTOPo->op_first;
1049 while ((kid = kid->op_sibling)) {
1050 if (kid->op_sibling)
1055 WITH_THR(PL_curcop = &PL_compiling);
1060 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1061 if (kid->op_sibling)
1066 WITH_THR(PL_curcop = &PL_compiling);
1069 if (ckWARN(WARN_VOID))
1070 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1076 Perl_scalarvoid(pTHX_ OP *o)
1083 if (o->op_type == OP_NEXTSTATE
1084 || o->op_type == OP_SETSTATE
1085 || o->op_type == OP_DBSTATE
1086 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1087 || o->op_targ == OP_SETSTATE
1088 || o->op_targ == OP_DBSTATE)))
1089 PL_curcop = (COP*)o; /* for warning below */
1091 /* assumes no premature commitment */
1092 want = o->op_flags & OPf_WANT;
1093 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1094 || o->op_type == OP_RETURN)
1099 if ((o->op_private & OPpTARGET_MY)
1100 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1102 return scalar(o); /* As if inside SASSIGN */
1105 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1107 switch (o->op_type) {
1109 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1113 if (o->op_flags & OPf_STACKED)
1117 if (o->op_private == 4)
1159 case OP_GETSOCKNAME:
1160 case OP_GETPEERNAME:
1165 case OP_GETPRIORITY:
1188 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1189 useless = OP_DESC(o);
1196 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1197 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1198 useless = "a variable";
1203 if (cSVOPo->op_private & OPpCONST_STRICT)
1204 no_bareword_allowed(o);
1206 if (ckWARN(WARN_VOID)) {
1207 useless = "a constant";
1208 /* the constants 0 and 1 are permitted as they are
1209 conventionally used as dummies in constructs like
1210 1 while some_condition_with_side_effects; */
1211 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1213 else if (SvPOK(sv)) {
1214 /* perl4's way of mixing documentation and code
1215 (before the invention of POD) was based on a
1216 trick to mix nroff and perl code. The trick was
1217 built upon these three nroff macros being used in
1218 void context. The pink camel has the details in
1219 the script wrapman near page 319. */
1220 if (strnEQ(SvPVX(sv), "di", 2) ||
1221 strnEQ(SvPVX(sv), "ds", 2) ||
1222 strnEQ(SvPVX(sv), "ig", 2))
1227 op_null(o); /* don't execute or even remember it */
1231 o->op_type = OP_PREINC; /* pre-increment is faster */
1232 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1236 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1237 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1243 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1248 if (o->op_flags & OPf_STACKED)
1255 if (!(o->op_flags & OPf_KIDS))
1264 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1271 /* all requires must return a boolean value */
1272 o->op_flags &= ~OPf_WANT;
1277 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1278 if (!kPMOP->op_pmreplroot)
1279 deprecate_old("implicit split to @_");
1283 if (useless && ckWARN(WARN_VOID))
1284 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1289 Perl_listkids(pTHX_ OP *o)
1292 if (o && o->op_flags & OPf_KIDS) {
1293 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1300 Perl_list(pTHX_ OP *o)
1304 /* assumes no premature commitment */
1305 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1306 || o->op_type == OP_RETURN)
1311 if ((o->op_private & OPpTARGET_MY)
1312 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1314 return o; /* As if inside SASSIGN */
1317 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1319 switch (o->op_type) {
1322 list(cBINOPo->op_first);
1327 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1335 if (!(o->op_flags & OPf_KIDS))
1337 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1338 list(cBINOPo->op_first);
1339 return gen_constant_list(o);
1346 kid = cLISTOPo->op_first;
1348 while ((kid = kid->op_sibling)) {
1349 if (kid->op_sibling)
1354 WITH_THR(PL_curcop = &PL_compiling);
1358 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1359 if (kid->op_sibling)
1364 WITH_THR(PL_curcop = &PL_compiling);
1367 /* all requires must return a boolean value */
1368 o->op_flags &= ~OPf_WANT;
1375 Perl_scalarseq(pTHX_ OP *o)
1380 if (o->op_type == OP_LINESEQ ||
1381 o->op_type == OP_SCOPE ||
1382 o->op_type == OP_LEAVE ||
1383 o->op_type == OP_LEAVETRY)
1385 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1386 if (kid->op_sibling) {
1390 PL_curcop = &PL_compiling;
1392 o->op_flags &= ~OPf_PARENS;
1393 if (PL_hints & HINT_BLOCK_SCOPE)
1394 o->op_flags |= OPf_PARENS;
1397 o = newOP(OP_STUB, 0);
1402 S_modkids(pTHX_ OP *o, I32 type)
1405 if (o && o->op_flags & OPf_KIDS) {
1406 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1413 Perl_mod(pTHX_ OP *o, I32 type)
1418 if (!o || PL_error_count)
1421 if ((o->op_private & OPpTARGET_MY)
1422 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1427 switch (o->op_type) {
1432 if (!(o->op_private & (OPpCONST_ARYBASE)))
1434 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1435 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1439 SAVEI32(PL_compiling.cop_arybase);
1440 PL_compiling.cop_arybase = 0;
1442 else if (type == OP_REFGEN)
1445 Perl_croak(aTHX_ "That use of $[ is unsupported");
1448 if (o->op_flags & OPf_PARENS)
1452 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1453 !(o->op_flags & OPf_STACKED)) {
1454 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1455 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456 assert(cUNOPo->op_first->op_type == OP_NULL);
1457 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1460 else if (o->op_private & OPpENTERSUB_NOMOD)
1462 else { /* lvalue subroutine call */
1463 o->op_private |= OPpLVAL_INTRO;
1464 PL_modcount = RETURN_UNLIMITED_NUMBER;
1465 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1466 /* Backward compatibility mode: */
1467 o->op_private |= OPpENTERSUB_INARGS;
1470 else { /* Compile-time error message: */
1471 OP *kid = cUNOPo->op_first;
1475 if (kid->op_type == OP_PUSHMARK)
1477 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1479 "panic: unexpected lvalue entersub "
1480 "args: type/targ %ld:%"UVuf,
1481 (long)kid->op_type, (UV)kid->op_targ);
1482 kid = kLISTOP->op_first;
1484 while (kid->op_sibling)
1485 kid = kid->op_sibling;
1486 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1488 if (kid->op_type == OP_METHOD_NAMED
1489 || kid->op_type == OP_METHOD)
1493 NewOp(1101, newop, 1, UNOP);
1494 newop->op_type = OP_RV2CV;
1495 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1496 newop->op_first = Nullop;
1497 newop->op_next = (OP*)newop;
1498 kid->op_sibling = (OP*)newop;
1499 newop->op_private |= OPpLVAL_INTRO;
1503 if (kid->op_type != OP_RV2CV)
1505 "panic: unexpected lvalue entersub "
1506 "entry via type/targ %ld:%"UVuf,
1507 (long)kid->op_type, (UV)kid->op_targ);
1508 kid->op_private |= OPpLVAL_INTRO;
1509 break; /* Postpone until runtime */
1513 kid = kUNOP->op_first;
1514 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1515 kid = kUNOP->op_first;
1516 if (kid->op_type == OP_NULL)
1518 "Unexpected constant lvalue entersub "
1519 "entry via type/targ %ld:%"UVuf,
1520 (long)kid->op_type, (UV)kid->op_targ);
1521 if (kid->op_type != OP_GV) {
1522 /* Restore RV2CV to check lvalueness */
1524 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1525 okid->op_next = kid->op_next;
1526 kid->op_next = okid;
1529 okid->op_next = Nullop;
1530 okid->op_type = OP_RV2CV;
1532 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1533 okid->op_private |= OPpLVAL_INTRO;
1537 cv = GvCV(kGVOP_gv);
1547 /* grep, foreach, subcalls, refgen */
1548 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1550 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1551 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1553 : (o->op_type == OP_ENTERSUB
1554 ? "non-lvalue subroutine call"
1556 type ? PL_op_desc[type] : "local"));
1570 case OP_RIGHT_SHIFT:
1579 if (!(o->op_flags & OPf_STACKED))
1585 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1591 if (!type && cUNOPo->op_first->op_type != OP_GV)
1592 Perl_croak(aTHX_ "Can't localize through a reference");
1593 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1594 PL_modcount = RETURN_UNLIMITED_NUMBER;
1595 return o; /* Treat \(@foo) like ordinary list. */
1599 if (scalar_mod_type(o, type))
1601 ref(cUNOPo->op_first, o->op_type);
1605 if (type == OP_LEAVESUBLV)
1606 o->op_private |= OPpMAYBE_LVSUB;
1612 PL_modcount = RETURN_UNLIMITED_NUMBER;
1615 if (!type && cUNOPo->op_first->op_type != OP_GV)
1616 Perl_croak(aTHX_ "Can't localize through a reference");
1617 ref(cUNOPo->op_first, o->op_type);
1621 PL_hints |= HINT_BLOCK_SCOPE;
1631 PL_modcount = RETURN_UNLIMITED_NUMBER;
1632 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1633 return o; /* Treat \(@foo) like ordinary list. */
1634 if (scalar_mod_type(o, type))
1636 if (type == OP_LEAVESUBLV)
1637 o->op_private |= OPpMAYBE_LVSUB;
1642 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1643 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1646 #ifdef USE_5005THREADS
1648 PL_modcount++; /* XXX ??? */
1650 #endif /* USE_5005THREADS */
1656 if (type != OP_SASSIGN)
1660 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1665 if (type == OP_LEAVESUBLV)
1666 o->op_private |= OPpMAYBE_LVSUB;
1668 pad_free(o->op_targ);
1669 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1670 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1671 if (o->op_flags & OPf_KIDS)
1672 mod(cBINOPo->op_first->op_sibling, type);
1677 ref(cBINOPo->op_first, o->op_type);
1678 if (type == OP_ENTERSUB &&
1679 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1680 o->op_private |= OPpLVAL_DEFER;
1681 if (type == OP_LEAVESUBLV)
1682 o->op_private |= OPpMAYBE_LVSUB;
1690 if (o->op_flags & OPf_KIDS)
1691 mod(cLISTOPo->op_last, type);
1695 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1697 else if (!(o->op_flags & OPf_KIDS))
1699 if (o->op_targ != OP_LIST) {
1700 mod(cBINOPo->op_first, type);
1705 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1710 if (type != OP_LEAVESUBLV)
1712 break; /* mod()ing was handled by ck_return() */
1715 /* [20011101.069] File test operators interpret OPf_REF to mean that
1716 their argument is a filehandle; thus \stat(".") should not set
1718 if (type == OP_REFGEN &&
1719 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1722 if (type != OP_LEAVESUBLV)
1723 o->op_flags |= OPf_MOD;
1725 if (type == OP_AASSIGN || type == OP_SASSIGN)
1726 o->op_flags |= OPf_SPECIAL|OPf_REF;
1728 o->op_private |= OPpLVAL_INTRO;
1729 o->op_flags &= ~OPf_SPECIAL;
1730 PL_hints |= HINT_BLOCK_SCOPE;
1732 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1733 && type != OP_LEAVESUBLV)
1734 o->op_flags |= OPf_REF;
1739 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1743 if (o->op_type == OP_RV2GV)
1767 case OP_RIGHT_SHIFT:
1786 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1788 switch (o->op_type) {
1796 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1809 Perl_refkids(pTHX_ OP *o, I32 type)
1812 if (o && o->op_flags & OPf_KIDS) {
1813 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1820 Perl_ref(pTHX_ OP *o, I32 type)
1824 if (!o || PL_error_count)
1827 switch (o->op_type) {
1829 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1830 !(o->op_flags & OPf_STACKED)) {
1831 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1832 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1833 assert(cUNOPo->op_first->op_type == OP_NULL);
1834 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1835 o->op_flags |= OPf_SPECIAL;
1840 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1844 if (type == OP_DEFINED)
1845 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1846 ref(cUNOPo->op_first, o->op_type);
1849 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1850 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1851 : type == OP_RV2HV ? OPpDEREF_HV
1853 o->op_flags |= OPf_MOD;
1858 o->op_flags |= OPf_MOD; /* XXX ??? */
1863 o->op_flags |= OPf_REF;
1866 if (type == OP_DEFINED)
1867 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1868 ref(cUNOPo->op_first, o->op_type);
1873 o->op_flags |= OPf_REF;
1878 if (!(o->op_flags & OPf_KIDS))
1880 ref(cBINOPo->op_first, type);
1884 ref(cBINOPo->op_first, o->op_type);
1885 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1886 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1887 : type == OP_RV2HV ? OPpDEREF_HV
1889 o->op_flags |= OPf_MOD;
1897 if (!(o->op_flags & OPf_KIDS))
1899 ref(cLISTOPo->op_last, type);
1909 S_dup_attrlist(pTHX_ OP *o)
1913 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1914 * where the first kid is OP_PUSHMARK and the remaining ones
1915 * are OP_CONST. We need to push the OP_CONST values.
1917 if (o->op_type == OP_CONST)
1918 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1920 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1921 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1922 if (o->op_type == OP_CONST)
1923 rop = append_elem(OP_LIST, rop,
1924 newSVOP(OP_CONST, o->op_flags,
1925 SvREFCNT_inc(cSVOPo->op_sv)));
1932 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1936 /* fake up C<use attributes $pkg,$rv,@attrs> */
1937 ENTER; /* need to protect against side-effects of 'use' */
1940 stashsv = newSVpv(HvNAME(stash), 0);
1942 stashsv = &PL_sv_no;
1944 #define ATTRSMODULE "attributes"
1945 #define ATTRSMODULE_PM "attributes.pm"
1949 /* Don't force the C<use> if we don't need it. */
1950 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1951 sizeof(ATTRSMODULE_PM)-1, 0);
1952 if (svp && *svp != &PL_sv_undef)
1953 ; /* already in %INC */
1955 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1956 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1960 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1961 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1963 prepend_elem(OP_LIST,
1964 newSVOP(OP_CONST, 0, stashsv),
1965 prepend_elem(OP_LIST,
1966 newSVOP(OP_CONST, 0,
1968 dup_attrlist(attrs))));
1974 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1976 OP *pack, *imop, *arg;
1982 assert(target->op_type == OP_PADSV ||
1983 target->op_type == OP_PADHV ||
1984 target->op_type == OP_PADAV);
1986 /* Ensure that attributes.pm is loaded. */
1987 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1989 /* Need package name for method call. */
1990 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1992 /* Build up the real arg-list. */
1994 stashsv = newSVpv(HvNAME(stash), 0);
1996 stashsv = &PL_sv_no;
1997 arg = newOP(OP_PADSV, 0);
1998 arg->op_targ = target->op_targ;
1999 arg = prepend_elem(OP_LIST,
2000 newSVOP(OP_CONST, 0, stashsv),
2001 prepend_elem(OP_LIST,
2002 newUNOP(OP_REFGEN, 0,
2003 mod(arg, OP_REFGEN)),
2004 dup_attrlist(attrs)));
2006 /* Fake up a method call to import */
2007 meth = newSVpvn("import", 6);
2008 (void)SvUPGRADE(meth, SVt_PVIV);
2009 (void)SvIOK_on(meth);
2010 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2011 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2012 append_elem(OP_LIST,
2013 prepend_elem(OP_LIST, pack, list(arg)),
2014 newSVOP(OP_METHOD_NAMED, 0, meth)));
2015 imop->op_private |= OPpENTERSUB_NOMOD;
2017 /* Combine the ops. */
2018 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2022 =notfor apidoc apply_attrs_string
2024 Attempts to apply a list of attributes specified by the C<attrstr> and
2025 C<len> arguments to the subroutine identified by the C<cv> argument which
2026 is expected to be associated with the package identified by the C<stashpv>
2027 argument (see L<attributes>). It gets this wrong, though, in that it
2028 does not correctly identify the boundaries of the individual attribute
2029 specifications within C<attrstr>. This is not really intended for the
2030 public API, but has to be listed here for systems such as AIX which
2031 need an explicit export list for symbols. (It's called from XS code
2032 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2033 to respect attribute syntax properly would be welcome.
2039 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2040 char *attrstr, STRLEN len)
2045 len = strlen(attrstr);
2049 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2051 char *sstr = attrstr;
2052 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2053 attrs = append_elem(OP_LIST, attrs,
2054 newSVOP(OP_CONST, 0,
2055 newSVpvn(sstr, attrstr-sstr)));
2059 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2060 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2061 Nullsv, prepend_elem(OP_LIST,
2062 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2063 prepend_elem(OP_LIST,
2064 newSVOP(OP_CONST, 0,
2070 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2075 if (!o || PL_error_count)
2079 if (type == OP_LIST) {
2080 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2081 my_kid(kid, attrs, imopsp);
2082 } else if (type == OP_UNDEF) {
2084 } else if (type == OP_RV2SV || /* "our" declaration */
2086 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2087 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2088 yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
2091 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2093 PL_in_my_stash = Nullhv;
2094 apply_attrs(GvSTASH(gv),
2095 (type == OP_RV2SV ? GvSV(gv) :
2096 type == OP_RV2AV ? (SV*)GvAV(gv) :
2097 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2100 o->op_private |= OPpOUR_INTRO;
2103 else if (type != OP_PADSV &&
2106 type != OP_PUSHMARK)
2108 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2110 PL_in_my == KEY_our ? "our" : "my"));
2113 else if (attrs && type != OP_PUSHMARK) {
2118 PL_in_my_stash = Nullhv;
2120 /* check for C<my Dog $spot> when deciding package */
2121 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2122 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2123 stash = SvSTASH(*namesvp);
2125 stash = PL_curstash;
2126 apply_attrs_my(stash, o, attrs, imopsp);
2128 o->op_flags |= OPf_MOD;
2129 o->op_private |= OPpLVAL_INTRO;
2134 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2137 int maybe_scalar = 0;
2139 if (o->op_flags & OPf_PARENS)
2145 o = my_kid(o, attrs, &rops);
2147 if (maybe_scalar && o->op_type == OP_PADSV) {
2148 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2149 o->op_private |= OPpLVAL_INTRO;
2152 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2155 PL_in_my_stash = Nullhv;
2160 Perl_my(pTHX_ OP *o)
2162 return my_attrs(o, Nullop);
2166 Perl_sawparens(pTHX_ OP *o)
2169 o->op_flags |= OPf_PARENS;
2174 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2178 if (ckWARN(WARN_MISC) &&
2179 (left->op_type == OP_RV2AV ||
2180 left->op_type == OP_RV2HV ||
2181 left->op_type == OP_PADAV ||
2182 left->op_type == OP_PADHV)) {
2183 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2184 right->op_type == OP_TRANS)
2185 ? right->op_type : OP_MATCH];
2186 const char *sample = ((left->op_type == OP_RV2AV ||
2187 left->op_type == OP_PADAV)
2188 ? "@array" : "%hash");
2189 Perl_warner(aTHX_ packWARN(WARN_MISC),
2190 "Applying %s to %s will act on scalar(%s)",
2191 desc, sample, sample);
2194 if (right->op_type == OP_CONST &&
2195 cSVOPx(right)->op_private & OPpCONST_BARE &&
2196 cSVOPx(right)->op_private & OPpCONST_STRICT)
2198 no_bareword_allowed(right);
2201 if (!(right->op_flags & OPf_STACKED) &&
2202 (right->op_type == OP_MATCH ||
2203 right->op_type == OP_SUBST ||
2204 right->op_type == OP_TRANS)) {
2205 right->op_flags |= OPf_STACKED;
2206 if (right->op_type != OP_MATCH &&
2207 ! (right->op_type == OP_TRANS &&
2208 right->op_private & OPpTRANS_IDENTICAL))
2209 left = mod(left, right->op_type);
2210 if (right->op_type == OP_TRANS)
2211 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2213 o = prepend_elem(right->op_type, scalar(left), right);
2215 return newUNOP(OP_NOT, 0, scalar(o));
2219 return bind_match(type, left,
2220 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2224 Perl_invert(pTHX_ OP *o)
2228 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2229 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2233 Perl_scope(pTHX_ OP *o)
2236 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2237 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2238 o->op_type = OP_LEAVE;
2239 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2242 if (o->op_type == OP_LINESEQ) {
2244 o->op_type = OP_SCOPE;
2245 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2246 kid = ((LISTOP*)o)->op_first;
2247 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2251 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2258 Perl_save_hints(pTHX)
2261 SAVESPTR(GvHV(PL_hintgv));
2262 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2263 SAVEFREESV(GvHV(PL_hintgv));
2267 Perl_block_start(pTHX_ int full)
2269 int retval = PL_savestack_ix;
2271 SAVEI32(PL_comppad_name_floor);
2272 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2274 PL_comppad_name_fill = PL_comppad_name_floor;
2275 if (PL_comppad_name_floor < 0)
2276 PL_comppad_name_floor = 0;
2277 SAVEI32(PL_min_intro_pending);
2278 SAVEI32(PL_max_intro_pending);
2279 PL_min_intro_pending = 0;
2280 SAVEI32(PL_comppad_name_fill);
2281 SAVEI32(PL_padix_floor);
2282 PL_padix_floor = PL_padix;
2283 PL_pad_reset_pending = FALSE;
2285 PL_hints &= ~HINT_BLOCK_SCOPE;
2286 SAVESPTR(PL_compiling.cop_warnings);
2287 if (! specialWARN(PL_compiling.cop_warnings)) {
2288 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2289 SAVEFREESV(PL_compiling.cop_warnings) ;
2291 SAVESPTR(PL_compiling.cop_io);
2292 if (! specialCopIO(PL_compiling.cop_io)) {
2293 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2294 SAVEFREESV(PL_compiling.cop_io) ;
2300 Perl_block_end(pTHX_ I32 floor, OP *seq)
2302 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2303 line_t copline = PL_copline;
2304 /* there should be a nextstate in every block */
2305 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2306 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2308 PL_pad_reset_pending = FALSE;
2309 PL_compiling.op_private = PL_hints;
2311 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2312 pad_leavemy(PL_comppad_name_fill);
2320 #ifdef USE_5005THREADS
2321 OP *o = newOP(OP_THREADSV, 0);
2322 o->op_targ = find_threadsv("_");
2325 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2326 #endif /* USE_5005THREADS */
2330 Perl_newPROG(pTHX_ OP *o)
2335 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2336 ((PL_in_eval & EVAL_KEEPERR)
2337 ? OPf_SPECIAL : 0), o);
2338 PL_eval_start = linklist(PL_eval_root);
2339 PL_eval_root->op_private |= OPpREFCOUNTED;
2340 OpREFCNT_set(PL_eval_root, 1);
2341 PL_eval_root->op_next = 0;
2342 CALL_PEEP(PL_eval_start);
2347 PL_main_root = scope(sawparens(scalarvoid(o)));
2348 PL_curcop = &PL_compiling;
2349 PL_main_start = LINKLIST(PL_main_root);
2350 PL_main_root->op_private |= OPpREFCOUNTED;
2351 OpREFCNT_set(PL_main_root, 1);
2352 PL_main_root->op_next = 0;
2353 CALL_PEEP(PL_main_start);
2356 /* Register with debugger */
2358 CV *cv = get_cv("DB::postponed", FALSE);
2362 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2364 call_sv((SV*)cv, G_DISCARD);
2371 Perl_localize(pTHX_ OP *o, I32 lex)
2373 if (o->op_flags & OPf_PARENS)
2376 if (ckWARN(WARN_PARENTHESIS)
2377 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2379 char *s = PL_bufptr;
2381 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2384 if (*s == ';' || *s == '=')
2385 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2386 "Parentheses missing around \"%s\" list",
2387 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2393 o = mod(o, OP_NULL); /* a bit kludgey */
2395 PL_in_my_stash = Nullhv;
2400 Perl_jmaybe(pTHX_ OP *o)
2402 if (o->op_type == OP_LIST) {
2404 #ifdef USE_5005THREADS
2405 o2 = newOP(OP_THREADSV, 0);
2406 o2->op_targ = find_threadsv(";");
2408 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2409 #endif /* USE_5005THREADS */
2410 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2416 Perl_fold_constants(pTHX_ register OP *o)
2419 I32 type = o->op_type;
2422 if (PL_opargs[type] & OA_RETSCALAR)
2424 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2425 o->op_targ = pad_alloc(type, SVs_PADTMP);
2427 /* integerize op, unless it happens to be C<-foo>.
2428 * XXX should pp_i_negate() do magic string negation instead? */
2429 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2430 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2431 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2433 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2436 if (!(PL_opargs[type] & OA_FOLDCONST))
2441 /* XXX might want a ck_negate() for this */
2442 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2454 /* XXX what about the numeric ops? */
2455 if (PL_hints & HINT_LOCALE)
2460 goto nope; /* Don't try to run w/ errors */
2462 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2463 if ((curop->op_type != OP_CONST ||
2464 (curop->op_private & OPpCONST_BARE)) &&
2465 curop->op_type != OP_LIST &&
2466 curop->op_type != OP_SCALAR &&
2467 curop->op_type != OP_NULL &&
2468 curop->op_type != OP_PUSHMARK)
2474 curop = LINKLIST(o);
2478 sv = *(PL_stack_sp--);
2479 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2480 pad_swipe(o->op_targ);
2481 else if (SvTEMP(sv)) { /* grab mortal temp? */
2482 (void)SvREFCNT_inc(sv);
2486 if (type == OP_RV2GV)
2487 return newGVOP(OP_GV, 0, (GV*)sv);
2489 /* try to smush double to int, but don't smush -2.0 to -2 */
2490 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2493 #ifdef PERL_PRESERVE_IVUV
2494 /* Only bother to attempt to fold to IV if
2495 most operators will benefit */
2499 return newSVOP(OP_CONST, 0, sv);
2507 Perl_gen_constant_list(pTHX_ register OP *o)
2510 I32 oldtmps_floor = PL_tmps_floor;
2514 return o; /* Don't attempt to run with errors */
2516 PL_op = curop = LINKLIST(o);
2523 PL_tmps_floor = oldtmps_floor;
2525 o->op_type = OP_RV2AV;
2526 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2527 o->op_seq = 0; /* needs to be revisited in peep() */
2528 curop = ((UNOP*)o)->op_first;
2529 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2536 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2538 if (!o || o->op_type != OP_LIST)
2539 o = newLISTOP(OP_LIST, 0, o, Nullop);
2541 o->op_flags &= ~OPf_WANT;
2543 if (!(PL_opargs[type] & OA_MARK))
2544 op_null(cLISTOPo->op_first);
2547 o->op_ppaddr = PL_ppaddr[type];
2548 o->op_flags |= flags;
2550 o = CHECKOP(type, o);
2551 if (o->op_type != type)
2554 return fold_constants(o);
2557 /* List constructors */
2560 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2568 if (first->op_type != type
2569 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2571 return newLISTOP(type, 0, first, last);
2574 if (first->op_flags & OPf_KIDS)
2575 ((LISTOP*)first)->op_last->op_sibling = last;
2577 first->op_flags |= OPf_KIDS;
2578 ((LISTOP*)first)->op_first = last;
2580 ((LISTOP*)first)->op_last = last;
2585 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2593 if (first->op_type != type)
2594 return prepend_elem(type, (OP*)first, (OP*)last);
2596 if (last->op_type != type)
2597 return append_elem(type, (OP*)first, (OP*)last);
2599 first->op_last->op_sibling = last->op_first;
2600 first->op_last = last->op_last;
2601 first->op_flags |= (last->op_flags & OPf_KIDS);
2609 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2617 if (last->op_type == type) {
2618 if (type == OP_LIST) { /* already a PUSHMARK there */
2619 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2620 ((LISTOP*)last)->op_first->op_sibling = first;
2621 if (!(first->op_flags & OPf_PARENS))
2622 last->op_flags &= ~OPf_PARENS;
2625 if (!(last->op_flags & OPf_KIDS)) {
2626 ((LISTOP*)last)->op_last = first;
2627 last->op_flags |= OPf_KIDS;
2629 first->op_sibling = ((LISTOP*)last)->op_first;
2630 ((LISTOP*)last)->op_first = first;
2632 last->op_flags |= OPf_KIDS;
2636 return newLISTOP(type, 0, first, last);
2642 Perl_newNULLLIST(pTHX)
2644 return newOP(OP_STUB, 0);
2648 Perl_force_list(pTHX_ OP *o)
2650 if (!o || o->op_type != OP_LIST)
2651 o = newLISTOP(OP_LIST, 0, o, Nullop);
2657 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2661 NewOp(1101, listop, 1, LISTOP);
2663 listop->op_type = type;
2664 listop->op_ppaddr = PL_ppaddr[type];
2667 listop->op_flags = flags;
2671 else if (!first && last)
2674 first->op_sibling = last;
2675 listop->op_first = first;
2676 listop->op_last = last;
2677 if (type == OP_LIST) {
2679 pushop = newOP(OP_PUSHMARK, 0);
2680 pushop->op_sibling = first;
2681 listop->op_first = pushop;
2682 listop->op_flags |= OPf_KIDS;
2684 listop->op_last = pushop;
2691 Perl_newOP(pTHX_ I32 type, I32 flags)
2694 NewOp(1101, o, 1, OP);
2696 o->op_ppaddr = PL_ppaddr[type];
2697 o->op_flags = flags;
2700 o->op_private = 0 + (flags >> 8);
2701 if (PL_opargs[type] & OA_RETSCALAR)
2703 if (PL_opargs[type] & OA_TARGET)
2704 o->op_targ = pad_alloc(type, SVs_PADTMP);
2705 return CHECKOP(type, o);
2709 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2714 first = newOP(OP_STUB, 0);
2715 if (PL_opargs[type] & OA_MARK)
2716 first = force_list(first);
2718 NewOp(1101, unop, 1, UNOP);
2719 unop->op_type = type;
2720 unop->op_ppaddr = PL_ppaddr[type];
2721 unop->op_first = first;
2722 unop->op_flags = flags | OPf_KIDS;
2723 unop->op_private = 1 | (flags >> 8);
2724 unop = (UNOP*) CHECKOP(type, unop);
2728 return fold_constants((OP *) unop);
2732 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2735 NewOp(1101, binop, 1, BINOP);
2738 first = newOP(OP_NULL, 0);
2740 binop->op_type = type;
2741 binop->op_ppaddr = PL_ppaddr[type];
2742 binop->op_first = first;
2743 binop->op_flags = flags | OPf_KIDS;
2746 binop->op_private = 1 | (flags >> 8);
2749 binop->op_private = 2 | (flags >> 8);
2750 first->op_sibling = last;
2753 binop = (BINOP*)CHECKOP(type, binop);
2754 if (binop->op_next || binop->op_type != type)
2757 binop->op_last = binop->op_first->op_sibling;
2759 return fold_constants((OP *)binop);
2763 uvcompare(const void *a, const void *b)
2765 if (*((UV *)a) < (*(UV *)b))
2767 if (*((UV *)a) > (*(UV *)b))
2769 if (*((UV *)a+1) < (*(UV *)b+1))
2771 if (*((UV *)a+1) > (*(UV *)b+1))
2777 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2779 SV *tstr = ((SVOP*)expr)->op_sv;
2780 SV *rstr = ((SVOP*)repl)->op_sv;
2783 U8 *t = (U8*)SvPV(tstr, tlen);
2784 U8 *r = (U8*)SvPV(rstr, rlen);
2791 register short *tbl;
2793 PL_hints |= HINT_BLOCK_SCOPE;
2794 complement = o->op_private & OPpTRANS_COMPLEMENT;
2795 del = o->op_private & OPpTRANS_DELETE;
2796 squash = o->op_private & OPpTRANS_SQUASH;
2799 o->op_private |= OPpTRANS_FROM_UTF;
2802 o->op_private |= OPpTRANS_TO_UTF;
2804 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2805 SV* listsv = newSVpvn("# comment\n",10);
2807 U8* tend = t + tlen;
2808 U8* rend = r + rlen;
2822 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2823 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2829 tsave = t = bytes_to_utf8(t, &len);
2832 if (!to_utf && rlen) {
2834 rsave = r = bytes_to_utf8(r, &len);
2838 /* There are several snags with this code on EBCDIC:
2839 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2840 2. scan_const() in toke.c has encoded chars in native encoding which makes
2841 ranges at least in EBCDIC 0..255 range the bottom odd.
2845 U8 tmpbuf[UTF8_MAXLEN+1];
2848 New(1109, cp, 2*tlen, UV);
2850 transv = newSVpvn("",0);
2852 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2854 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2856 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2860 cp[2*i+1] = cp[2*i];
2864 qsort(cp, i, 2*sizeof(UV), uvcompare);
2865 for (j = 0; j < i; j++) {
2867 diff = val - nextmin;
2869 t = uvuni_to_utf8(tmpbuf,nextmin);
2870 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2872 U8 range_mark = UTF_TO_NATIVE(0xff);
2873 t = uvuni_to_utf8(tmpbuf, val - 1);
2874 sv_catpvn(transv, (char *)&range_mark, 1);
2875 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2882 t = uvuni_to_utf8(tmpbuf,nextmin);
2883 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2885 U8 range_mark = UTF_TO_NATIVE(0xff);
2886 sv_catpvn(transv, (char *)&range_mark, 1);
2888 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2889 UNICODE_ALLOW_SUPER);
2890 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2891 t = (U8*)SvPVX(transv);
2892 tlen = SvCUR(transv);
2896 else if (!rlen && !del) {
2897 r = t; rlen = tlen; rend = tend;
2900 if ((!rlen && !del) || t == r ||
2901 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2903 o->op_private |= OPpTRANS_IDENTICAL;
2907 while (t < tend || tfirst <= tlast) {
2908 /* see if we need more "t" chars */
2909 if (tfirst > tlast) {
2910 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2912 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2914 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2921 /* now see if we need more "r" chars */
2922 if (rfirst > rlast) {
2924 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2926 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2928 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2937 rfirst = rlast = 0xffffffff;
2941 /* now see which range will peter our first, if either. */
2942 tdiff = tlast - tfirst;
2943 rdiff = rlast - rfirst;
2950 if (rfirst == 0xffffffff) {
2951 diff = tdiff; /* oops, pretend rdiff is infinite */
2953 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2954 (long)tfirst, (long)tlast);
2956 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2960 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2961 (long)tfirst, (long)(tfirst + diff),
2964 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2965 (long)tfirst, (long)rfirst);
2967 if (rfirst + diff > max)
2968 max = rfirst + diff;
2970 grows = (tfirst < rfirst &&
2971 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2983 else if (max > 0xff)
2988 Safefree(cPVOPo->op_pv);
2989 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2990 SvREFCNT_dec(listsv);
2992 SvREFCNT_dec(transv);
2994 if (!del && havefinal && rlen)
2995 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2996 newSVuv((UV)final), 0);
2999 o->op_private |= OPpTRANS_GROWS;
3011 tbl = (short*)cPVOPo->op_pv;
3013 Zero(tbl, 256, short);
3014 for (i = 0; i < tlen; i++)
3016 for (i = 0, j = 0; i < 256; i++) {
3027 if (i < 128 && r[j] >= 128)
3037 o->op_private |= OPpTRANS_IDENTICAL;
3042 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3043 tbl[0x100] = rlen - j;
3044 for (i=0; i < rlen - j; i++)
3045 tbl[0x101+i] = r[j+i];
3049 if (!rlen && !del) {
3052 o->op_private |= OPpTRANS_IDENTICAL;
3054 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3055 o->op_private |= OPpTRANS_IDENTICAL;
3057 for (i = 0; i < 256; i++)
3059 for (i = 0, j = 0; i < tlen; i++,j++) {
3062 if (tbl[t[i]] == -1)
3068 if (tbl[t[i]] == -1) {
3069 if (t[i] < 128 && r[j] >= 128)
3076 o->op_private |= OPpTRANS_GROWS;
3084 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3088 NewOp(1101, pmop, 1, PMOP);
3089 pmop->op_type = type;
3090 pmop->op_ppaddr = PL_ppaddr[type];
3091 pmop->op_flags = flags;
3092 pmop->op_private = 0 | (flags >> 8);
3094 if (PL_hints & HINT_RE_TAINT)
3095 pmop->op_pmpermflags |= PMf_RETAINT;
3096 if (PL_hints & HINT_LOCALE)
3097 pmop->op_pmpermflags |= PMf_LOCALE;
3098 pmop->op_pmflags = pmop->op_pmpermflags;
3103 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3104 repointer = av_pop((AV*)PL_regex_pad[0]);
3105 pmop->op_pmoffset = SvIV(repointer);
3106 SvREPADTMP_off(repointer);
3107 sv_setiv(repointer,0);
3109 repointer = newSViv(0);
3110 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3111 pmop->op_pmoffset = av_len(PL_regex_padav);
3112 PL_regex_pad = AvARRAY(PL_regex_padav);
3117 /* link into pm list */
3118 if (type != OP_TRANS && PL_curstash) {
3119 pmop->op_pmnext = HvPMROOT(PL_curstash);
3120 HvPMROOT(PL_curstash) = pmop;
3121 PmopSTASH_set(pmop,PL_curstash);
3128 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3132 I32 repl_has_vars = 0;
3134 if (o->op_type == OP_TRANS)
3135 return pmtrans(o, expr, repl);
3137 PL_hints |= HINT_BLOCK_SCOPE;
3140 if (expr->op_type == OP_CONST) {
3142 SV *pat = ((SVOP*)expr)->op_sv;
3143 char *p = SvPV(pat, plen);
3144 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3145 sv_setpvn(pat, "\\s+", 3);
3146 p = SvPV(pat, plen);
3147 pm->op_pmflags |= PMf_SKIPWHITE;
3150 pm->op_pmdynflags |= PMdf_UTF8;
3151 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3152 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3153 pm->op_pmflags |= PMf_WHITE;
3157 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3158 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3160 : OP_REGCMAYBE),0,expr);
3162 NewOp(1101, rcop, 1, LOGOP);
3163 rcop->op_type = OP_REGCOMP;
3164 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3165 rcop->op_first = scalar(expr);
3166 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3167 ? (OPf_SPECIAL | OPf_KIDS)
3169 rcop->op_private = 1;
3172 /* establish postfix order */
3173 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3175 rcop->op_next = expr;
3176 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3179 rcop->op_next = LINKLIST(expr);
3180 expr->op_next = (OP*)rcop;
3183 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3188 if (pm->op_pmflags & PMf_EVAL) {
3190 if (CopLINE(PL_curcop) < PL_multi_end)
3191 CopLINE_set(PL_curcop, PL_multi_end);
3193 #ifdef USE_5005THREADS
3194 else if (repl->op_type == OP_THREADSV
3195 && strchr("&`'123456789+",
3196 PL_threadsv_names[repl->op_targ]))
3200 #endif /* USE_5005THREADS */
3201 else if (repl->op_type == OP_CONST)
3205 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3206 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3207 #ifdef USE_5005THREADS
3208 if (curop->op_type == OP_THREADSV) {
3210 if (strchr("&`'123456789+", curop->op_private))
3214 if (curop->op_type == OP_GV) {
3215 GV *gv = cGVOPx_gv(curop);
3217 if (strchr("&`'123456789+", *GvENAME(gv)))
3220 #endif /* USE_5005THREADS */
3221 else if (curop->op_type == OP_RV2CV)
3223 else if (curop->op_type == OP_RV2SV ||
3224 curop->op_type == OP_RV2AV ||
3225 curop->op_type == OP_RV2HV ||
3226 curop->op_type == OP_RV2GV) {
3227 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3230 else if (curop->op_type == OP_PADSV ||
3231 curop->op_type == OP_PADAV ||
3232 curop->op_type == OP_PADHV ||
3233 curop->op_type == OP_PADANY) {
3236 else if (curop->op_type == OP_PUSHRE)
3237 ; /* Okay here, dangerous in newASSIGNOP */
3247 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3248 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3249 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3250 prepend_elem(o->op_type, scalar(repl), o);
3253 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3254 pm->op_pmflags |= PMf_MAYBE_CONST;
3255 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3257 NewOp(1101, rcop, 1, LOGOP);
3258 rcop->op_type = OP_SUBSTCONT;
3259 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3260 rcop->op_first = scalar(repl);
3261 rcop->op_flags |= OPf_KIDS;
3262 rcop->op_private = 1;
3265 /* establish postfix order */
3266 rcop->op_next = LINKLIST(repl);
3267 repl->op_next = (OP*)rcop;
3269 pm->op_pmreplroot = scalar((OP*)rcop);
3270 pm->op_pmreplstart = LINKLIST(rcop);
3279 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3282 NewOp(1101, svop, 1, SVOP);
3283 svop->op_type = type;
3284 svop->op_ppaddr = PL_ppaddr[type];
3286 svop->op_next = (OP*)svop;
3287 svop->op_flags = flags;
3288 if (PL_opargs[type] & OA_RETSCALAR)
3290 if (PL_opargs[type] & OA_TARGET)
3291 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3292 return CHECKOP(type, svop);
3296 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3299 NewOp(1101, padop, 1, PADOP);
3300 padop->op_type = type;
3301 padop->op_ppaddr = PL_ppaddr[type];
3302 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3303 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3304 PL_curpad[padop->op_padix] = sv;
3306 padop->op_next = (OP*)padop;
3307 padop->op_flags = flags;
3308 if (PL_opargs[type] & OA_RETSCALAR)
3310 if (PL_opargs[type] & OA_TARGET)
3311 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3312 return CHECKOP(type, padop);
3316 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3320 return newPADOP(type, flags, SvREFCNT_inc(gv));
3322 return newSVOP(type, flags, SvREFCNT_inc(gv));
3327 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3330 NewOp(1101, pvop, 1, PVOP);
3331 pvop->op_type = type;
3332 pvop->op_ppaddr = PL_ppaddr[type];
3334 pvop->op_next = (OP*)pvop;
3335 pvop->op_flags = flags;
3336 if (PL_opargs[type] & OA_RETSCALAR)
3338 if (PL_opargs[type] & OA_TARGET)
3339 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3340 return CHECKOP(type, pvop);
3344 Perl_package(pTHX_ OP *o)
3348 save_hptr(&PL_curstash);
3349 save_item(PL_curstname);
3354 name = SvPV(sv, len);
3355 PL_curstash = gv_stashpvn(name,len,TRUE);
3356 sv_setpvn(PL_curstname, name, len);
3360 deprecate("\"package\" with no arguments");
3361 sv_setpv(PL_curstname,"<none>");
3362 PL_curstash = Nullhv;
3364 PL_hints |= HINT_BLOCK_SCOPE;
3365 PL_copline = NOLINE;
3370 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3375 char *packname = Nullch;
3379 if (id->op_type != OP_CONST)
3380 Perl_croak(aTHX_ "Module name must be constant");
3384 if (version != Nullop) {
3385 SV *vesv = ((SVOP*)version)->op_sv;
3387 if (arg == Nullop && !SvNIOKp(vesv)) {
3394 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3395 Perl_croak(aTHX_ "Version number must be constant number");
3397 /* Make copy of id so we don't free it twice */
3398 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3400 /* Fake up a method call to VERSION */
3401 meth = newSVpvn("VERSION",7);
3402 sv_upgrade(meth, SVt_PVIV);
3403 (void)SvIOK_on(meth);
3404 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3405 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3406 append_elem(OP_LIST,
3407 prepend_elem(OP_LIST, pack, list(version)),
3408 newSVOP(OP_METHOD_NAMED, 0, meth)));
3412 /* Fake up an import/unimport */
3413 if (arg && arg->op_type == OP_STUB)
3414 imop = arg; /* no import on explicit () */
3415 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3416 imop = Nullop; /* use 5.0; */
3421 /* Make copy of id so we don't free it twice */
3422 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3424 /* Fake up a method call to import/unimport */
3425 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3426 (void)SvUPGRADE(meth, SVt_PVIV);
3427 (void)SvIOK_on(meth);
3428 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3429 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3430 append_elem(OP_LIST,
3431 prepend_elem(OP_LIST, pack, list(arg)),
3432 newSVOP(OP_METHOD_NAMED, 0, meth)));
3435 if (ckWARN(WARN_MISC) &&
3436 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3437 SvPOK(packsv = ((SVOP*)id)->op_sv))
3439 /* BEGIN will free the ops, so we need to make a copy */
3440 packlen = SvCUR(packsv);
3441 packname = savepvn(SvPVX(packsv), packlen);
3444 /* Fake up the BEGIN {}, which does its thing immediately. */
3446 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3449 append_elem(OP_LINESEQ,
3450 append_elem(OP_LINESEQ,
3451 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3452 newSTATEOP(0, Nullch, veop)),
3453 newSTATEOP(0, Nullch, imop) ));
3456 /* The "did you use incorrect case?" warning used to be here.
3457 * The problem is that on case-insensitive filesystems one
3458 * might get false positives for "use" (and "require"):
3459 * "use Strict" or "require CARP" will work. This causes
3460 * portability problems for the script: in case-strict
3461 * filesystems the script will stop working.
3463 * The "incorrect case" warning checked whether "use Foo"
3464 * imported "Foo" to your namespace, but that is wrong, too:
3465 * there is no requirement nor promise in the language that
3466 * a Foo.pm should or would contain anything in package "Foo".
3468 * There is very little Configure-wise that can be done, either:
3469 * the case-sensitivity of the build filesystem of Perl does not
3470 * help in guessing the case-sensitivity of the runtime environment.
3475 PL_hints |= HINT_BLOCK_SCOPE;
3476 PL_copline = NOLINE;
3481 =head1 Embedding Functions
3483 =for apidoc load_module
3485 Loads the module whose name is pointed to by the string part of name.
3486 Note that the actual module name, not its filename, should be given.
3487 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3488 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3489 (or 0 for no flags). ver, if specified, provides version semantics
3490 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3491 arguments can be used to specify arguments to the module's import()
3492 method, similar to C<use Foo::Bar VERSION LIST>.
3497 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3500 va_start(args, ver);
3501 vload_module(flags, name, ver, &args);
3505 #ifdef PERL_IMPLICIT_CONTEXT
3507 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3511 va_start(args, ver);
3512 vload_module(flags, name, ver, &args);
3518 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3520 OP *modname, *veop, *imop;
3522 modname = newSVOP(OP_CONST, 0, name);
3523 modname->op_private |= OPpCONST_BARE;
3525 veop = newSVOP(OP_CONST, 0, ver);
3529 if (flags & PERL_LOADMOD_NOIMPORT) {
3530 imop = sawparens(newNULLLIST());
3532 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3533 imop = va_arg(*args, OP*);
3538 sv = va_arg(*args, SV*);
3540 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3541 sv = va_arg(*args, SV*);
3545 line_t ocopline = PL_copline;
3546 int oexpect = PL_expect;
3548 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3549 veop, modname, imop);
3550 PL_expect = oexpect;
3551 PL_copline = ocopline;
3556 Perl_dofile(pTHX_ OP *term)
3561 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3562 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3563 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3565 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3566 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3567 append_elem(OP_LIST, term,
3568 scalar(newUNOP(OP_RV2CV, 0,
3573 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3579 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3581 return newBINOP(OP_LSLICE, flags,
3582 list(force_list(subscript)),
3583 list(force_list(listval)) );
3587 S_list_assignment(pTHX_ register OP *o)
3592 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3593 o = cUNOPo->op_first;
3595 if (o->op_type == OP_COND_EXPR) {
3596 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3597 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3602 yyerror("Assignment to both a list and a scalar");
3606 if (o->op_type == OP_LIST &&
3607 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3608 o->op_private & OPpLVAL_INTRO)
3611 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3612 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3613 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3616 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3619 if (o->op_type == OP_RV2SV)
3626 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3631 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3632 return newLOGOP(optype, 0,
3633 mod(scalar(left), optype),
3634 newUNOP(OP_SASSIGN, 0, scalar(right)));
3637 return newBINOP(optype, OPf_STACKED,
3638 mod(scalar(left), optype), scalar(right));
3642 if (list_assignment(left)) {
3646 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3647 left = mod(left, OP_AASSIGN);
3655 curop = list(force_list(left));
3656 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3657 o->op_private = 0 | (flags >> 8);
3658 for (curop = ((LISTOP*)curop)->op_first;
3659 curop; curop = curop->op_sibling)
3661 if (curop->op_type == OP_RV2HV &&
3662 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3663 o->op_private |= OPpASSIGN_HASH;
3667 if (!(left->op_private & OPpLVAL_INTRO)) {
3670 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3671 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3672 if (curop->op_type == OP_GV) {
3673 GV *gv = cGVOPx_gv(curop);
3674 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3676 SvCUR(gv) = PL_generation;
3678 else if (curop->op_type == OP_PADSV ||
3679 curop->op_type == OP_PADAV ||
3680 curop->op_type == OP_PADHV ||
3681 curop->op_type == OP_PADANY) {
3682 SV **svp = AvARRAY(PL_comppad_name);
3683 SV *sv = svp[curop->op_targ];
3684 if (SvCUR(sv) == PL_generation)
3686 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3688 else if (curop->op_type == OP_RV2CV)
3690 else if (curop->op_type == OP_RV2SV ||
3691 curop->op_type == OP_RV2AV ||
3692 curop->op_type == OP_RV2HV ||
3693 curop->op_type == OP_RV2GV) {
3694 if (lastop->op_type != OP_GV) /* funny deref? */
3697 else if (curop->op_type == OP_PUSHRE) {
3698 if (((PMOP*)curop)->op_pmreplroot) {
3700 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3702 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3704 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3706 SvCUR(gv) = PL_generation;
3715 o->op_private |= OPpASSIGN_COMMON;
3717 if (right && right->op_type == OP_SPLIT) {
3719 if ((tmpop = ((LISTOP*)right)->op_first) &&
3720 tmpop->op_type == OP_PUSHRE)
3722 PMOP *pm = (PMOP*)tmpop;
3723 if (left->op_type == OP_RV2AV &&
3724 !(left->op_private & OPpLVAL_INTRO) &&
3725 !(o->op_private & OPpASSIGN_COMMON) )
3727 tmpop = ((UNOP*)left)->op_first;
3728 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3730 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3731 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3733 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3734 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3736 pm->op_pmflags |= PMf_ONCE;
3737 tmpop = cUNOPo->op_first; /* to list (nulled) */
3738 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3739 tmpop->op_sibling = Nullop; /* don't free split */
3740 right->op_next = tmpop->op_next; /* fix starting loc */
3741 op_free(o); /* blow off assign */
3742 right->op_flags &= ~OPf_WANT;
3743 /* "I don't know and I don't care." */
3748 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3749 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3751 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3753 sv_setiv(sv, PL_modcount+1);
3761 right = newOP(OP_UNDEF, 0);
3762 if (right->op_type == OP_READLINE) {
3763 right->op_flags |= OPf_STACKED;
3764 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3767 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3768 o = newBINOP(OP_SASSIGN, flags,
3769 scalar(right), mod(scalar(left), OP_SASSIGN) );
3781 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3783 U32 seq = intro_my();
3786 NewOp(1101, cop, 1, COP);
3787 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3788 cop->op_type = OP_DBSTATE;
3789 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3792 cop->op_type = OP_NEXTSTATE;
3793 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3795 cop->op_flags = flags;
3796 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3798 cop->op_private |= NATIVE_HINTS;
3800 PL_compiling.op_private = cop->op_private;
3801 cop->op_next = (OP*)cop;
3804 cop->cop_label = label;
3805 PL_hints |= HINT_BLOCK_SCOPE;
3808 cop->cop_arybase = PL_curcop->cop_arybase;
3809 if (specialWARN(PL_curcop->cop_warnings))
3810 cop->cop_warnings = PL_curcop->cop_warnings ;
3812 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3813 if (specialCopIO(PL_curcop->cop_io))
3814 cop->cop_io = PL_curcop->cop_io;
3816 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3819 if (PL_copline == NOLINE)
3820 CopLINE_set(cop, CopLINE(PL_curcop));
3822 CopLINE_set(cop, PL_copline);
3823 PL_copline = NOLINE;
3826 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3828 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3830 CopSTASH_set(cop, PL_curstash);
3832 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3833 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3834 if (svp && *svp != &PL_sv_undef ) {
3835 (void)SvIOK_on(*svp);
3836 SvIVX(*svp) = PTR2IV(cop);
3840 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3843 /* "Introduce" my variables to visible status. */
3851 if (! PL_min_intro_pending)
3852 return PL_cop_seqmax;
3854 svp = AvARRAY(PL_comppad_name);
3855 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3856 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3857 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3858 SvNVX(sv) = (NV)PL_cop_seqmax;
3861 PL_min_intro_pending = 0;
3862 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3863 return PL_cop_seqmax++;
3867 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3869 return new_logop(type, flags, &first, &other);
3873 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3877 OP *first = *firstp;
3878 OP *other = *otherp;
3880 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3881 return newBINOP(type, flags, scalar(first), scalar(other));
3883 scalarboolean(first);
3884 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3885 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3886 if (type == OP_AND || type == OP_OR) {
3892 first = *firstp = cUNOPo->op_first;
3894 first->op_next = o->op_next;
3895 cUNOPo->op_first = Nullop;
3899 if (first->op_type == OP_CONST) {
3900 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3901 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3902 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3913 else if (first->op_type == OP_WANTARRAY) {
3919 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3920 OP *k1 = ((UNOP*)first)->op_first;
3921 OP *k2 = k1->op_sibling;
3923 switch (first->op_type)
3926 if (k2 && k2->op_type == OP_READLINE
3927 && (k2->op_flags & OPf_STACKED)
3928 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3930 warnop = k2->op_type;
3935 if (k1->op_type == OP_READDIR
3936 || k1->op_type == OP_GLOB
3937 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3938 || k1->op_type == OP_EACH)
3940 warnop = ((k1->op_type == OP_NULL)
3941 ? k1->op_targ : k1->op_type);
3946 line_t oldline = CopLINE(PL_curcop);
3947 CopLINE_set(PL_curcop, PL_copline);
3948 Perl_warner(aTHX_ packWARN(WARN_MISC),
3949 "Value of %s%s can be \"0\"; test with defined()",
3951 ((warnop == OP_READLINE || warnop == OP_GLOB)
3952 ? " construct" : "() operator"));
3953 CopLINE_set(PL_curcop, oldline);
3960 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3961 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3963 NewOp(1101, logop, 1, LOGOP);
3965 logop->op_type = type;
3966 logop->op_ppaddr = PL_ppaddr[type];
3967 logop->op_first = first;
3968 logop->op_flags = flags | OPf_KIDS;
3969 logop->op_other = LINKLIST(other);
3970 logop->op_private = 1 | (flags >> 8);
3972 /* establish postfix order */
3973 logop->op_next = LINKLIST(first);
3974 first->op_next = (OP*)logop;
3975 first->op_sibling = other;
3977 o = newUNOP(OP_NULL, 0, (OP*)logop);
3984 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3991 return newLOGOP(OP_AND, 0, first, trueop);
3993 return newLOGOP(OP_OR, 0, first, falseop);
3995 scalarboolean(first);
3996 if (first->op_type == OP_CONST) {
3997 if (SvTRUE(((SVOP*)first)->op_sv)) {
4008 else if (first->op_type == OP_WANTARRAY) {
4012 NewOp(1101, logop, 1, LOGOP);
4013 logop->op_type = OP_COND_EXPR;
4014 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4015 logop->op_first = first;
4016 logop->op_flags = flags | OPf_KIDS;
4017 logop->op_private = 1 | (flags >> 8);
4018 logop->op_other = LINKLIST(trueop);
4019 logop->op_next = LINKLIST(falseop);
4022 /* establish postfix order */
4023 start = LINKLIST(first);
4024 first->op_next = (OP*)logop;
4026 first->op_sibling = trueop;
4027 trueop->op_sibling = falseop;
4028 o = newUNOP(OP_NULL, 0, (OP*)logop);
4030 trueop->op_next = falseop->op_next = o;
4037 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4045 NewOp(1101, range, 1, LOGOP);
4047 range->op_type = OP_RANGE;
4048 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4049 range->op_first = left;
4050 range->op_flags = OPf_KIDS;
4051 leftstart = LINKLIST(left);
4052 range->op_other = LINKLIST(right);
4053 range->op_private = 1 | (flags >> 8);
4055 left->op_sibling = right;
4057 range->op_next = (OP*)range;
4058 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4059 flop = newUNOP(OP_FLOP, 0, flip);
4060 o = newUNOP(OP_NULL, 0, flop);
4062 range->op_next = leftstart;
4064 left->op_next = flip;
4065 right->op_next = flop;
4067 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4068 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4069 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4070 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4072 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4073 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4076 if (!flip->op_private || !flop->op_private)
4077 linklist(o); /* blow off optimizer unless constant */
4083 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4087 int once = block && block->op_flags & OPf_SPECIAL &&
4088 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4091 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4092 return block; /* do {} while 0 does once */
4093 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4094 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4095 expr = newUNOP(OP_DEFINED, 0,
4096 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4097 } else if (expr->op_flags & OPf_KIDS) {
4098 OP *k1 = ((UNOP*)expr)->op_first;
4099 OP *k2 = (k1) ? k1->op_sibling : NULL;
4100 switch (expr->op_type) {
4102 if (k2 && k2->op_type == OP_READLINE
4103 && (k2->op_flags & OPf_STACKED)
4104 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4105 expr = newUNOP(OP_DEFINED, 0, expr);
4109 if (k1->op_type == OP_READDIR
4110 || k1->op_type == OP_GLOB
4111 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4112 || k1->op_type == OP_EACH)
4113 expr = newUNOP(OP_DEFINED, 0, expr);
4119 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4120 o = new_logop(OP_AND, 0, &expr, &listop);
4123 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4125 if (once && o != listop)
4126 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4129 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4131 o->op_flags |= flags;
4133 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4138 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4146 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4147 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4148 expr = newUNOP(OP_DEFINED, 0,
4149 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4150 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4151 OP *k1 = ((UNOP*)expr)->op_first;
4152 OP *k2 = (k1) ? k1->op_sibling : NULL;
4153 switch (expr->op_type) {
4155 if (k2 && k2->op_type == OP_READLINE
4156 && (k2->op_flags & OPf_STACKED)
4157 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4158 expr = newUNOP(OP_DEFINED, 0, expr);
4162 if (k1->op_type == OP_READDIR
4163 || k1->op_type == OP_GLOB
4164 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4165 || k1->op_type == OP_EACH)
4166 expr = newUNOP(OP_DEFINED, 0, expr);
4172 block = newOP(OP_NULL, 0);
4174 block = scope(block);
4178 next = LINKLIST(cont);
4181 OP *unstack = newOP(OP_UNSTACK, 0);
4184 cont = append_elem(OP_LINESEQ, cont, unstack);
4185 if ((line_t)whileline != NOLINE) {
4186 PL_copline = whileline;
4187 cont = append_elem(OP_LINESEQ, cont,
4188 newSTATEOP(0, Nullch, Nullop));
4192 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4193 redo = LINKLIST(listop);
4196 PL_copline = whileline;
4198 o = new_logop(OP_AND, 0, &expr, &listop);
4199 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4200 op_free(expr); /* oops, it's a while (0) */
4202 return Nullop; /* listop already freed by new_logop */
4205 ((LISTOP*)listop)->op_last->op_next =
4206 (o == listop ? redo : LINKLIST(o));
4212 NewOp(1101,loop,1,LOOP);
4213 loop->op_type = OP_ENTERLOOP;
4214 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4215 loop->op_private = 0;
4216 loop->op_next = (OP*)loop;
4219 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4221 loop->op_redoop = redo;
4222 loop->op_lastop = o;
4223 o->op_private |= loopflags;
4226 loop->op_nextop = next;
4228 loop->op_nextop = o;
4230 o->op_flags |= flags;
4231 o->op_private |= (flags >> 8);
4236 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4244 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4245 sv->op_type = OP_RV2GV;
4246 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4248 else if (sv->op_type == OP_PADSV) { /* private variable */
4249 padoff = sv->op_targ;
4254 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4255 padoff = sv->op_targ;
4257 iterflags |= OPf_SPECIAL;
4262 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4265 #ifdef USE_5005THREADS
4266 padoff = find_threadsv("_");
4267 iterflags |= OPf_SPECIAL;
4269 sv = newGVOP(OP_GV, 0, PL_defgv);
4272 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4273 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4274 iterflags |= OPf_STACKED;
4276 else if (expr->op_type == OP_NULL &&
4277 (expr->op_flags & OPf_KIDS) &&
4278 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4280 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4281 * set the STACKED flag to indicate that these values are to be
4282 * treated as min/max values by 'pp_iterinit'.
4284 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4285 LOGOP* range = (LOGOP*) flip->op_first;
4286 OP* left = range->op_first;
4287 OP* right = left->op_sibling;
4290 range->op_flags &= ~OPf_KIDS;
4291 range->op_first = Nullop;
4293 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4294 listop->op_first->op_next = range->op_next;
4295 left->op_next = range->op_other;
4296 right->op_next = (OP*)listop;
4297 listop->op_next = listop->op_first;
4300 expr = (OP*)(listop);
4302 iterflags |= OPf_STACKED;
4305 expr = mod(force_list(expr), OP_GREPSTART);
4309 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4310 append_elem(OP_LIST, expr, scalar(sv))));
4311 assert(!loop->op_next);
4312 #ifdef PL_OP_SLAB_ALLOC
4315 NewOp(1234,tmp,1,LOOP);
4316 Copy(loop,tmp,1,LOOP);
4321 Renew(loop, 1, LOOP);
4323 loop->op_targ = padoff;
4324 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4325 PL_copline = forline;
4326 return newSTATEOP(0, label, wop);
4330 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4335 if (type != OP_GOTO || label->op_type == OP_CONST) {
4336 /* "last()" means "last" */
4337 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4338 o = newOP(type, OPf_SPECIAL);
4340 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4341 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4347 if (label->op_type == OP_ENTERSUB)
4348 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4349 o = newUNOP(type, OPf_STACKED, label);
4351 PL_hints |= HINT_BLOCK_SCOPE;
4356 Perl_cv_undef(pTHX_ CV *cv)
4358 #ifdef USE_5005THREADS
4360 MUTEX_DESTROY(CvMUTEXP(cv));
4361 Safefree(CvMUTEXP(cv));
4364 #endif /* USE_5005THREADS */
4367 if (CvFILE(cv) && !CvXSUB(cv)) {
4368 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4369 Safefree(CvFILE(cv));
4374 if (!CvXSUB(cv) && CvROOT(cv)) {
4375 #ifdef USE_5005THREADS
4376 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4377 Perl_croak(aTHX_ "Can't undef active subroutine");
4380 Perl_croak(aTHX_ "Can't undef active subroutine");
4381 #endif /* USE_5005THREADS */
4384 SAVEVPTR(PL_curpad);
4387 op_free(CvROOT(cv));
4388 CvROOT(cv) = Nullop;
4391 SvPOK_off((SV*)cv); /* forget prototype */
4393 /* Since closure prototypes have the same lifetime as the containing
4394 * CV, they don't hold a refcount on the outside CV. This avoids
4395 * the refcount loop between the outer CV (which keeps a refcount to
4396 * the closure prototype in the pad entry for pp_anoncode()) and the
4397 * closure prototype, and the ensuing memory leak. --GSAR */
4398 if (!CvANON(cv) || CvCLONED(cv))
4399 SvREFCNT_dec(CvOUTSIDE(cv));
4400 CvOUTSIDE(cv) = Nullcv;
4402 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4405 if (CvPADLIST(cv)) {
4406 /* may be during global destruction */
4407 if (SvREFCNT(CvPADLIST(cv))) {
4408 I32 i = AvFILLp(CvPADLIST(cv));
4410 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4411 SV* sv = svp ? *svp : Nullsv;
4414 if (sv == (SV*)PL_comppad_name)
4415 PL_comppad_name = Nullav;
4416 else if (sv == (SV*)PL_comppad) {
4417 PL_comppad = Nullav;
4418 PL_curpad = Null(SV**);
4422 SvREFCNT_dec((SV*)CvPADLIST(cv));
4424 CvPADLIST(cv) = Nullav;
4432 #ifdef DEBUG_CLOSURES
4434 S_cv_dump(pTHX_ CV *cv)
4437 CV *outside = CvOUTSIDE(cv);
4438 AV* padlist = CvPADLIST(cv);
4445 PerlIO_printf(Perl_debug_log,
4446 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4448 (CvANON(cv) ? "ANON"
4449 : (cv == PL_main_cv) ? "MAIN"
4450 : CvUNIQUE(cv) ? "UNIQUE"
4451 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4454 : CvANON(outside) ? "ANON"
4455 : (outside == PL_main_cv) ? "MAIN"
4456 : CvUNIQUE(outside) ? "UNIQUE"
4457 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4462 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4463 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4464 pname = AvARRAY(pad_name);
4465 ppad = AvARRAY(pad);
4467 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4468 if (SvPOK(pname[ix]))
4469 PerlIO_printf(Perl_debug_log,
4470 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4471 (int)ix, PTR2UV(ppad[ix]),
4472 SvFAKE(pname[ix]) ? "FAKE " : "",
4474 (IV)I_32(SvNVX(pname[ix])),
4477 #endif /* DEBUGGING */
4479 #endif /* DEBUG_CLOSURES */
4482 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4486 AV* protopadlist = CvPADLIST(proto);
4487 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4488 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4489 SV** pname = AvARRAY(protopad_name);
4490 SV** ppad = AvARRAY(protopad);
4491 I32 fname = AvFILLp(protopad_name);
4492 I32 fpad = AvFILLp(protopad);
4496 assert(!CvUNIQUE(proto));
4500 SAVESPTR(PL_comppad_name);
4501 SAVESPTR(PL_compcv);
4503 cv = PL_compcv = (CV*)NEWSV(1104,0);
4504 sv_upgrade((SV *)cv, SvTYPE(proto));
4505 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4508 #ifdef USE_5005THREADS
4509 New(666, CvMUTEXP(cv), 1, perl_mutex);
4510 MUTEX_INIT(CvMUTEXP(cv));
4512 #endif /* USE_5005THREADS */
4514 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4515 : savepv(CvFILE(proto));
4517 CvFILE(cv) = CvFILE(proto);
4519 CvGV(cv) = CvGV(proto);
4520 CvSTASH(cv) = CvSTASH(proto);
4521 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4522 CvSTART(cv) = CvSTART(proto);
4524 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4527 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4529 PL_comppad_name = newAV();
4530 for (ix = fname; ix >= 0; ix--)
4531 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4533 PL_comppad = newAV();
4535 comppadlist = newAV();
4536 AvREAL_off(comppadlist);
4537 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4538 av_store(comppadlist, 1, (SV*)PL_comppad);
4539 CvPADLIST(cv) = comppadlist;
4540 av_fill(PL_comppad, AvFILLp(protopad));
4541 PL_curpad = AvARRAY(PL_comppad);
4543 av = newAV(); /* will be @_ */
4545 av_store(PL_comppad, 0, (SV*)av);
4546 AvFLAGS(av) = AVf_REIFY;
4548 for (ix = fpad; ix > 0; ix--) {
4549 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4550 if (namesv && namesv != &PL_sv_undef) {
4551 char *name = SvPVX(namesv); /* XXX */
4552 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4553 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4554 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4556 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4558 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4560 else { /* our own lexical */
4563 /* anon code -- we'll come back for it */
4564 sv = SvREFCNT_inc(ppad[ix]);
4566 else if (*name == '@')
4568 else if (*name == '%')
4577 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4578 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4581 SV* sv = NEWSV(0,0);
4587 /* Now that vars are all in place, clone nested closures. */
4589 for (ix = fpad; ix > 0; ix--) {
4590 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4592 && namesv != &PL_sv_undef
4593 && !(SvFLAGS(namesv) & SVf_FAKE)
4594 && *SvPVX(namesv) == '&'
4595 && CvCLONE(ppad[ix]))
4597 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4598 SvREFCNT_dec(ppad[ix]);
4601 PL_curpad[ix] = (SV*)kid;
4605 #ifdef DEBUG_CLOSURES
4606 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4608 PerlIO_printf(Perl_debug_log, " from:\n");
4610 PerlIO_printf(Perl_debug_log, " to:\n");
4617 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4619 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4621 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4628 Perl_cv_clone(pTHX_ CV *proto)
4631 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4632 cv = cv_clone2(proto, CvOUTSIDE(proto));
4633 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4638 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4640 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4641 SV* msg = sv_newmortal();
4645 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4646 sv_setpv(msg, "Prototype mismatch:");
4648 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4650 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4651 sv_catpv(msg, " vs ");
4653 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4655 sv_catpv(msg, "none");
4656 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4660 static void const_sv_xsub(pTHX_ CV* cv);
4664 =head1 Optree Manipulation Functions
4666 =for apidoc cv_const_sv
4668 If C<cv> is a constant sub eligible for inlining. returns the constant
4669 value returned by the sub. Otherwise, returns NULL.
4671 Constant subs can be created with C<newCONSTSUB> or as described in
4672 L<perlsub/"Constant Functions">.
4677 Perl_cv_const_sv(pTHX_ CV *cv)
4679 if (!cv || !CvCONST(cv))
4681 return (SV*)CvXSUBANY(cv).any_ptr;
4685 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4692 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4693 o = cLISTOPo->op_first->op_sibling;
4695 for (; o; o = o->op_next) {
4696 OPCODE type = o->op_type;
4698 if (sv && o->op_next == o)
4700 if (o->op_next != o) {
4701 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4703 if (type == OP_DBSTATE)
4706 if (type == OP_LEAVESUB || type == OP_RETURN)
4710 if (type == OP_CONST && cSVOPo->op_sv)
4712 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4713 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4714 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4718 /* We get here only from cv_clone2() while creating a closure.
4719 Copy the const value here instead of in cv_clone2 so that
4720 SvREADONLY_on doesn't lead to problems when leaving
4725 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4737 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4747 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4751 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4753 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4757 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4763 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4768 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4769 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4770 SV *sv = sv_newmortal();
4771 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4772 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4773 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4778 gv = gv_fetchpv(name ? name : (aname ? aname :
4779 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4780 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4790 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4791 maximum a prototype before. */
4792 if (SvTYPE(gv) > SVt_NULL) {
4793 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4794 && ckWARN_d(WARN_PROTOTYPE))
4796 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4798 cv_ckproto((CV*)gv, NULL, ps);
4801 sv_setpv((SV*)gv, ps);
4803 sv_setiv((SV*)gv, -1);
4804 SvREFCNT_dec(PL_compcv);
4805 cv = PL_compcv = NULL;
4806 PL_sub_generation++;
4810 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4812 #ifdef GV_UNIQUE_CHECK
4813 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4814 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4818 if (!block || !ps || *ps || attrs)
4821 const_sv = op_const_sv(block, Nullcv);
4824 bool exists = CvROOT(cv) || CvXSUB(cv);
4826 #ifdef GV_UNIQUE_CHECK
4827 if (exists && GvUNIQUE(gv)) {
4828 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4832 /* if the subroutine doesn't exist and wasn't pre-declared
4833 * with a prototype, assume it will be AUTOLOADed,
4834 * skipping the prototype check
4836 if (exists || SvPOK(cv))
4837 cv_ckproto(cv, gv, ps);
4838 /* already defined (or promised)? */
4839 if (exists || GvASSUMECV(gv)) {
4840 if (!block && !attrs) {
4841 /* just a "sub foo;" when &foo is already defined */
4842 SAVEFREESV(PL_compcv);
4845 /* ahem, death to those who redefine active sort subs */
4846 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4847 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4849 if (ckWARN(WARN_REDEFINE)
4851 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4853 line_t oldline = CopLINE(PL_curcop);
4854 if (PL_copline != NOLINE)
4855 CopLINE_set(PL_curcop, PL_copline);
4856 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4857 CvCONST(cv) ? "Constant subroutine %s redefined"
4858 : "Subroutine %s redefined", name);
4859 CopLINE_set(PL_curcop, oldline);
4867 SvREFCNT_inc(const_sv);
4869 assert(!CvROOT(cv) && !CvCONST(cv));
4870 sv_setpv((SV*)cv, ""); /* prototype is "" */
4871 CvXSUBANY(cv).any_ptr = const_sv;
4872 CvXSUB(cv) = const_sv_xsub;
4877 cv = newCONSTSUB(NULL, name, const_sv);
4880 SvREFCNT_dec(PL_compcv);
4882 PL_sub_generation++;
4889 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4890 * before we clobber PL_compcv.
4894 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4895 stash = GvSTASH(CvGV(cv));
4896 else if (CvSTASH(cv))
4897 stash = CvSTASH(cv);
4899 stash = PL_curstash;
4902 /* possibly about to re-define existing subr -- ignore old cv */
4903 rcv = (SV*)PL_compcv;
4904 if (name && GvSTASH(gv))
4905 stash = GvSTASH(gv);
4907 stash = PL_curstash;
4909 apply_attrs(stash, rcv, attrs, FALSE);
4911 if (cv) { /* must reuse cv if autoloaded */
4913 /* got here with just attrs -- work done, so bug out */
4914 SAVEFREESV(PL_compcv);
4918 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4919 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4920 CvOUTSIDE(PL_compcv) = 0;
4921 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4922 CvPADLIST(PL_compcv) = 0;
4923 /* inner references to PL_compcv must be fixed up ... */
4925 AV *padlist = CvPADLIST(cv);
4926 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4927 AV *comppad = (AV*)AvARRAY(padlist)[1];
4928 SV **namepad = AvARRAY(comppad_name);
4929 SV **curpad = AvARRAY(comppad);
4930 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4931 SV *namesv = namepad[ix];
4932 if (namesv && namesv != &PL_sv_undef
4933 && *SvPVX(namesv) == '&')
4935 CV *innercv = (CV*)curpad[ix];
4936 if (CvOUTSIDE(innercv) == PL_compcv) {
4937 CvOUTSIDE(innercv) = cv;
4938 if (!CvANON(innercv) || CvCLONED(innercv)) {
4939 (void)SvREFCNT_inc(cv);
4940 SvREFCNT_dec(PL_compcv);
4946 /* ... before we throw it away */
4947 SvREFCNT_dec(PL_compcv);
4948 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4949 ++PL_sub_generation;
4956 PL_sub_generation++;
4960 CvFILE_set_from_cop(cv, PL_curcop);
4961 CvSTASH(cv) = PL_curstash;
4962 #ifdef USE_5005THREADS
4964 if (!CvMUTEXP(cv)) {
4965 New(666, CvMUTEXP(cv), 1, perl_mutex);
4966 MUTEX_INIT(CvMUTEXP(cv));
4968 #endif /* USE_5005THREADS */
4971 sv_setpv((SV*)cv, ps);
4973 if (PL_error_count) {
4977 char *s = strrchr(name, ':');
4979 if (strEQ(s, "BEGIN")) {
4981 "BEGIN not safe after errors--compilation aborted";
4982 if (PL_in_eval & EVAL_KEEPERR)
4983 Perl_croak(aTHX_ not_safe);
4985 /* force display of errors found but not reported */
4986 sv_catpv(ERRSV, not_safe);
4987 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4995 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4996 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4999 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5000 mod(scalarseq(block), OP_LEAVESUBLV));
5003 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5005 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5006 OpREFCNT_set(CvROOT(cv), 1);
5007 CvSTART(cv) = LINKLIST(CvROOT(cv));
5008 CvROOT(cv)->op_next = 0;
5009 CALL_PEEP(CvSTART(cv));
5011 /* now that optimizer has done its work, adjust pad values */
5013 SV **namep = AvARRAY(PL_comppad_name);
5014 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5017 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5020 * The only things that a clonable function needs in its
5021 * pad are references to outer lexicals and anonymous subs.
5022 * The rest are created anew during cloning.
5024 if (!((namesv = namep[ix]) != Nullsv &&
5025 namesv != &PL_sv_undef &&
5027 *SvPVX(namesv) == '&')))
5029 SvREFCNT_dec(PL_curpad[ix]);
5030 PL_curpad[ix] = Nullsv;
5033 assert(!CvCONST(cv));
5034 if (ps && !*ps && op_const_sv(block, cv))
5038 AV *av = newAV(); /* Will be @_ */
5040 av_store(PL_comppad, 0, (SV*)av);
5041 AvFLAGS(av) = AVf_REIFY;
5043 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5044 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5046 if (!SvPADMY(PL_curpad[ix]))
5047 SvPADTMP_on(PL_curpad[ix]);
5051 /* If a potential closure prototype, don't keep a refcount on outer CV.
5052 * This is okay as the lifetime of the prototype is tied to the
5053 * lifetime of the outer CV. Avoids memory leak due to reference
5056 SvREFCNT_dec(CvOUTSIDE(cv));
5058 if (name || aname) {
5060 char *tname = (name ? name : aname);
5062 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5063 SV *sv = NEWSV(0,0);
5064 SV *tmpstr = sv_newmortal();
5065 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5069 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5071 (long)PL_subline, (long)CopLINE(PL_curcop));
5072 gv_efullname3(tmpstr, gv, Nullch);
5073 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5074 hv = GvHVn(db_postponed);
5075 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5076 && (pcv = GvCV(db_postponed)))
5082 call_sv((SV*)pcv, G_DISCARD);
5086 if ((s = strrchr(tname,':')))
5091 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5094 if (strEQ(s, "BEGIN")) {
5095 I32 oldscope = PL_scopestack_ix;
5097 SAVECOPFILE(&PL_compiling);
5098 SAVECOPLINE(&PL_compiling);
5101 PL_beginav = newAV();
5102 DEBUG_x( dump_sub(gv) );
5103 av_push(PL_beginav, (SV*)cv);
5104 GvCV(gv) = 0; /* cv has been hijacked */
5105 call_list(oldscope, PL_beginav);
5107 PL_curcop = &PL_compiling;
5108 PL_compiling.op_private = PL_hints;
5111 else if (strEQ(s, "END") && !PL_error_count) {
5114 DEBUG_x( dump_sub(gv) );
5115 av_unshift(PL_endav, 1);
5116 av_store(PL_endav, 0, (SV*)cv);
5117 GvCV(gv) = 0; /* cv has been hijacked */
5119 else if (strEQ(s, "CHECK") && !PL_error_count) {
5121 PL_checkav = newAV();
5122 DEBUG_x( dump_sub(gv) );
5123 if (PL_main_start && ckWARN(WARN_VOID))
5124 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5125 av_unshift(PL_checkav, 1);
5126 av_store(PL_checkav, 0, (SV*)cv);
5127 GvCV(gv) = 0; /* cv has been hijacked */
5129 else if (strEQ(s, "INIT") && !PL_error_count) {
5131 PL_initav = newAV();
5132 DEBUG_x( dump_sub(gv) );
5133 if (PL_main_start && ckWARN(WARN_VOID))
5134 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5135 av_push(PL_initav, (SV*)cv);
5136 GvCV(gv) = 0; /* cv has been hijacked */
5141 PL_copline = NOLINE;
5146 /* XXX unsafe for threads if eval_owner isn't held */
5148 =for apidoc newCONSTSUB
5150 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5151 eligible for inlining at compile-time.
5157 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5163 SAVECOPLINE(PL_curcop);
5164 CopLINE_set(PL_curcop, PL_copline);
5167 PL_hints &= ~HINT_BLOCK_SCOPE;
5170 SAVESPTR(PL_curstash);
5171 SAVECOPSTASH(PL_curcop);
5172 PL_curstash = stash;
5173 CopSTASH_set(PL_curcop,stash);
5176 cv = newXS(name, const_sv_xsub, __FILE__);
5177 CvXSUBANY(cv).any_ptr = sv;
5179 sv_setpv((SV*)cv, ""); /* prototype is "" */
5187 =for apidoc U||newXS
5189 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5195 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5197 GV *gv = gv_fetchpv(name ? name :
5198 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5199 GV_ADDMULTI, SVt_PVCV);
5202 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5204 /* just a cached method */
5208 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5209 /* already defined (or promised) */
5210 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5211 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5212 line_t oldline = CopLINE(PL_curcop);
5213 if (PL_copline != NOLINE)
5214 CopLINE_set(PL_curcop, PL_copline);
5215 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5216 CvCONST(cv) ? "Constant subroutine %s redefined"
5217 : "Subroutine %s redefined"
5219 CopLINE_set(PL_curcop, oldline);
5226 if (cv) /* must reuse cv if autoloaded */
5229 cv = (CV*)NEWSV(1105,0);
5230 sv_upgrade((SV *)cv, SVt_PVCV);
5234 PL_sub_generation++;
5238 #ifdef USE_5005THREADS
5239 New(666, CvMUTEXP(cv), 1, perl_mutex);
5240 MUTEX_INIT(CvMUTEXP(cv));
5242 #endif /* USE_5005THREADS */
5243 (void)gv_fetchfile(filename);
5244 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5245 an external constant string */
5246 CvXSUB(cv) = subaddr;
5249 char *s = strrchr(name,':');
5255 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5258 if (strEQ(s, "BEGIN")) {
5260 PL_beginav = newAV();
5261 av_push(PL_beginav, (SV*)cv);
5262 GvCV(gv) = 0; /* cv has been hijacked */
5264 else if (strEQ(s, "END")) {
5267 av_unshift(PL_endav, 1);
5268 av_store(PL_endav, 0, (SV*)cv);
5269 GvCV(gv) = 0; /* cv has been hijacked */
5271 else if (strEQ(s, "CHECK")) {
5273 PL_checkav = newAV();
5274 if (PL_main_start && ckWARN(WARN_VOID))
5275 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5276 av_unshift(PL_checkav, 1);
5277 av_store(PL_checkav, 0, (SV*)cv);
5278 GvCV(gv) = 0; /* cv has been hijacked */
5280 else if (strEQ(s, "INIT")) {
5282 PL_initav = newAV();
5283 if (PL_main_start && ckWARN(WARN_VOID))
5284 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5285 av_push(PL_initav, (SV*)cv);
5286 GvCV(gv) = 0; /* cv has been hijacked */
5297 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5306 name = SvPVx(cSVOPo->op_sv, n_a);
5309 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5310 #ifdef GV_UNIQUE_CHECK
5312 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5316 if ((cv = GvFORM(gv))) {
5317 if (ckWARN(WARN_REDEFINE)) {
5318 line_t oldline = CopLINE(PL_curcop);
5319 if (PL_copline != NOLINE)
5320 CopLINE_set(PL_curcop, PL_copline);
5321 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
5322 CopLINE_set(PL_curcop, oldline);
5329 CvFILE_set_from_cop(cv, PL_curcop);
5331 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5332 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5333 SvPADTMP_on(PL_curpad[ix]);
5336 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5337 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5338 OpREFCNT_set(CvROOT(cv), 1);
5339 CvSTART(cv) = LINKLIST(CvROOT(cv));
5340 CvROOT(cv)->op_next = 0;
5341 CALL_PEEP(CvSTART(cv));
5343 PL_copline = NOLINE;
5348 Perl_newANONLIST(pTHX_ OP *o)
5350 return newUNOP(OP_REFGEN, 0,
5351 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5355 Perl_newANONHASH(pTHX_ OP *o)
5357 return newUNOP(OP_REFGEN, 0,
5358 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5362 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5364 return newANONATTRSUB(floor, proto, Nullop, block);
5368 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5370 return newUNOP(OP_REFGEN, 0,
5371 newSVOP(OP_ANONCODE, 0,
5372 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5376 Perl_oopsAV(pTHX_ OP *o)
5378 switch (o->op_type) {
5380 o->op_type = OP_PADAV;
5381 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5382 return ref(o, OP_RV2AV);
5385 o->op_type = OP_RV2AV;
5386 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5391 if (ckWARN_d(WARN_INTERNAL))
5392 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5399 Perl_oopsHV(pTHX_ OP *o)
5401 switch (o->op_type) {
5404 o->op_type = OP_PADHV;
5405 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5406 return ref(o, OP_RV2HV);
5410 o->op_type = OP_RV2HV;
5411 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5416 if (ckWARN_d(WARN_INTERNAL))
5417 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5424 Perl_newAVREF(pTHX_ OP *o)
5426 if (o->op_type == OP_PADANY) {
5427 o->op_type = OP_PADAV;
5428 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5431 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5432 && ckWARN(WARN_DEPRECATED)) {
5433 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5434 "Using an array as a reference is deprecated");
5436 return newUNOP(OP_RV2AV, 0, scalar(o));
5440 Perl_newGVREF(pTHX_ I32 type, OP *o)
5442 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5443 return newUNOP(OP_NULL, 0, o);
5444 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5448 Perl_newHVREF(pTHX_ OP *o)
5450 if (o->op_type == OP_PADANY) {
5451 o->op_type = OP_PADHV;
5452 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5455 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5456 && ckWARN(WARN_DEPRECATED)) {
5457 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5458 "Using a hash as a reference is deprecated");
5460 return newUNOP(OP_RV2HV, 0, scalar(o));
5464 Perl_oopsCV(pTHX_ OP *o)
5466 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5472 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5474 return newUNOP(OP_RV2CV, flags, scalar(o));
5478 Perl_newSVREF(pTHX_ OP *o)
5480 if (o->op_type == OP_PADANY) {
5481 o->op_type = OP_PADSV;
5482 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5485 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5486 o->op_flags |= OPpDONE_SVREF;
5489 return newUNOP(OP_RV2SV, 0, scalar(o));
5492 /* Check routines. */
5495 Perl_ck_anoncode(pTHX_ OP *o)
5500 name = NEWSV(1106,0);
5501 sv_upgrade(name, SVt_PVNV);
5502 sv_setpvn(name, "&", 1);
5505 ix = pad_alloc(o->op_type, SVs_PADMY);
5506 av_store(PL_comppad_name, ix, name);
5507 av_store(PL_comppad, ix, cSVOPo->op_sv);
5508 SvPADMY_on(cSVOPo->op_sv);
5509 cSVOPo->op_sv = Nullsv;
5510 cSVOPo->op_targ = ix;
5515 Perl_ck_bitop(pTHX_ OP *o)
5517 o->op_private = PL_hints;
5522 Perl_ck_concat(pTHX_ OP *o)
5524 if (cUNOPo->op_first->op_type == OP_CONCAT)
5525 o->op_flags |= OPf_STACKED;
5530 Perl_ck_spair(pTHX_ OP *o)
5532 if (o->op_flags & OPf_KIDS) {
5535 OPCODE type = o->op_type;
5536 o = modkids(ck_fun(o), type);
5537 kid = cUNOPo->op_first;
5538 newop = kUNOP->op_first->op_sibling;
5540 (newop->op_sibling ||
5541 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5542 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5543 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5547 op_free(kUNOP->op_first);
5548 kUNOP->op_first = newop;
5550 o->op_ppaddr = PL_ppaddr[++o->op_type];
5555 Perl_ck_delete(pTHX_ OP *o)
5559 if (o->op_flags & OPf_KIDS) {
5560 OP *kid = cUNOPo->op_first;
5561 switch (kid->op_type) {
5563 o->op_flags |= OPf_SPECIAL;
5566 o->op_private |= OPpSLICE;
5569 o->op_flags |= OPf_SPECIAL;
5574 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5583 Perl_ck_die(pTHX_ OP *o)
5586 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5592 Perl_ck_eof(pTHX_ OP *o)
5594 I32 type = o->op_type;
5596 if (o->op_flags & OPf_KIDS) {
5597 if (cLISTOPo->op_first->op_type == OP_STUB) {
5599 o = newUNOP(type, OPf_SPECIAL,
5600 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5608 Perl_ck_eval(pTHX_ OP *o)
5610 PL_hints |= HINT_BLOCK_SCOPE;
5611 if (o->op_flags & OPf_KIDS) {
5612 SVOP *kid = (SVOP*)cUNOPo->op_first;
5615 o->op_flags &= ~OPf_KIDS;
5618 else if (kid->op_type == OP_LINESEQ) {
5621 kid->op_next = o->op_next;
5622 cUNOPo->op_first = 0;
5625 NewOp(1101, enter, 1, LOGOP);
5626 enter->op_type = OP_ENTERTRY;
5627 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5628 enter->op_private = 0;
5630 /* establish postfix order */
5631 enter->op_next = (OP*)enter;
5633 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5634 o->op_type = OP_LEAVETRY;
5635 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5636 enter->op_other = o;
5644 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5646 o->op_targ = (PADOFFSET)PL_hints;
5651 Perl_ck_exit(pTHX_ OP *o)
5654 HV *table = GvHV(PL_hintgv);
5656 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5657 if (svp && *svp && SvTRUE(*svp))
5658 o->op_private |= OPpEXIT_VMSISH;
5660 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5666 Perl_ck_exec(pTHX_ OP *o)
5669 if (o->op_flags & OPf_STACKED) {
5671 kid = cUNOPo->op_first->op_sibling;
5672 if (kid->op_type == OP_RV2GV)
5681 Perl_ck_exists(pTHX_ OP *o)
5684 if (o->op_flags & OPf_KIDS) {
5685 OP *kid = cUNOPo->op_first;
5686 if (kid->op_type == OP_ENTERSUB) {
5687 (void) ref(kid, o->op_type);
5688 if (kid->op_type != OP_RV2CV && !PL_error_count)
5689 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5691 o->op_private |= OPpEXISTS_SUB;
5693 else if (kid->op_type == OP_AELEM)
5694 o->op_flags |= OPf_SPECIAL;
5695 else if (kid->op_type != OP_HELEM)
5696 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5705 Perl_ck_gvconst(pTHX_ register OP *o)
5707 o = fold_constants(o);
5708 if (o->op_type == OP_CONST)
5715 Perl_ck_rvconst(pTHX_ register OP *o)
5717 SVOP *kid = (SVOP*)cUNOPo->op_first;
5719 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5720 if (kid->op_type == OP_CONST) {
5724 SV *kidsv = kid->op_sv;
5727 /* Is it a constant from cv_const_sv()? */
5728 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5729 SV *rsv = SvRV(kidsv);
5730 int svtype = SvTYPE(rsv);
5731 char *badtype = Nullch;
5733 switch (o->op_type) {
5735 if (svtype > SVt_PVMG)
5736 badtype = "a SCALAR";
5739 if (svtype != SVt_PVAV)
5740 badtype = "an ARRAY";
5743 if (svtype != SVt_PVHV) {
5744 if (svtype == SVt_PVAV) { /* pseudohash? */
5745 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5746 if (ksv && SvROK(*ksv)
5747 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5756 if (svtype != SVt_PVCV)
5761 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5764 name = SvPV(kidsv, n_a);
5765 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5766 char *badthing = Nullch;
5767 switch (o->op_type) {
5769 badthing = "a SCALAR";
5772 badthing = "an ARRAY";
5775 badthing = "a HASH";
5780 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5784 * This is a little tricky. We only want to add the symbol if we
5785 * didn't add it in the lexer. Otherwise we get duplicate strict
5786 * warnings. But if we didn't add it in the lexer, we must at
5787 * least pretend like we wanted to add it even if it existed before,
5788 * or we get possible typo warnings. OPpCONST_ENTERED says
5789 * whether the lexer already added THIS instance of this symbol.
5791 iscv = (o->op_type == OP_RV2CV) * 2;
5793 gv = gv_fetchpv(name,
5794 iscv | !(kid->op_private & OPpCONST_ENTERED),
5797 : o->op_type == OP_RV2SV
5799 : o->op_type == OP_RV2AV
5801 : o->op_type == OP_RV2HV
5804 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5806 kid->op_type = OP_GV;
5807 SvREFCNT_dec(kid->op_sv);
5809 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5810 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5811 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5813 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5815 kid->op_sv = SvREFCNT_inc(gv);
5817 kid->op_private = 0;
5818 kid->op_ppaddr = PL_ppaddr[OP_GV];
5825 Perl_ck_ftst(pTHX_ OP *o)
5827 I32 type = o->op_type;
5829 if (o->op_flags & OPf_REF) {
5832 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5833 SVOP *kid = (SVOP*)cUNOPo->op_first;
5835 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5837 OP *newop = newGVOP(type, OPf_REF,
5838 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5845 if (type == OP_FTTTY)
5846 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5849 o = newUNOP(type, 0, newDEFSVOP());
5855 Perl_ck_fun(pTHX_ OP *o)
5861 int type = o->op_type;
5862 register I32 oa = PL_opargs[type] >> OASHIFT;
5864 if (o->op_flags & OPf_STACKED) {
5865 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5868 return no_fh_allowed(o);
5871 if (o->op_flags & OPf_KIDS) {
5873 tokid = &cLISTOPo->op_first;
5874 kid = cLISTOPo->op_first;
5875 if (kid->op_type == OP_PUSHMARK ||
5876 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5878 tokid = &kid->op_sibling;
5879 kid = kid->op_sibling;
5881 if (!kid && PL_opargs[type] & OA_DEFGV)
5882 *tokid = kid = newDEFSVOP();
5886 sibl = kid->op_sibling;
5889 /* list seen where single (scalar) arg expected? */
5890 if (numargs == 1 && !(oa >> 4)
5891 && kid->op_type == OP_LIST && type != OP_SCALAR)
5893 return too_many_arguments(o,PL_op_desc[type]);
5906 if ((type == OP_PUSH || type == OP_UNSHIFT)
5907 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5908 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5909 "Useless use of %s with no values",
5912 if (kid->op_type == OP_CONST &&
5913 (kid->op_private & OPpCONST_BARE))
5915 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5916 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5917 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5918 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5919 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5920 "Array @%s missing the @ in argument %"IVdf" of %s()",
5921 name, (IV)numargs, PL_op_desc[type]);
5924 kid->op_sibling = sibl;
5927 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5928 bad_type(numargs, "array", PL_op_desc[type], kid);
5932 if (kid->op_type == OP_CONST &&
5933 (kid->op_private & OPpCONST_BARE))
5935 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5936 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5937 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5938 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5939 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5940 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5941 name, (IV)numargs, PL_op_desc[type]);
5944 kid->op_sibling = sibl;
5947 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5948 bad_type(numargs, "hash", PL_op_desc[type], kid);
5953 OP *newop = newUNOP(OP_NULL, 0, kid);
5954 kid->op_sibling = 0;
5956 newop->op_next = newop;
5958 kid->op_sibling = sibl;
5963 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5964 if (kid->op_type == OP_CONST &&
5965 (kid->op_private & OPpCONST_BARE))
5967 OP *newop = newGVOP(OP_GV, 0,
5968 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5970 if (kid == cLISTOPo->op_last)
5971 cLISTOPo->op_last = newop;
5975 else if (kid->op_type == OP_READLINE) {
5976 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5977 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5980 I32 flags = OPf_SPECIAL;
5984 /* is this op a FH constructor? */
5985 if (is_handle_constructor(o,numargs)) {
5986 char *name = Nullch;
5990 /* Set a flag to tell rv2gv to vivify
5991 * need to "prove" flag does not mean something
5992 * else already - NI-S 1999/05/07
5995 if (kid->op_type == OP_PADSV) {
5996 SV **namep = av_fetch(PL_comppad_name,
5998 if (namep && *namep)
5999 name = SvPV(*namep, len);
6001 else if (kid->op_type == OP_RV2SV
6002 && kUNOP->op_first->op_type == OP_GV)
6004 GV *gv = cGVOPx_gv(kUNOP->op_first);
6006 len = GvNAMELEN(gv);
6008 else if (kid->op_type == OP_AELEM
6009 || kid->op_type == OP_HELEM)
6011 name = "__ANONIO__";
6017 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6018 namesv = PL_curpad[targ];
6019 (void)SvUPGRADE(namesv, SVt_PV);
6021 sv_setpvn(namesv, "$", 1);
6022 sv_catpvn(namesv, name, len);
6025 kid->op_sibling = 0;
6026 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6027 kid->op_targ = targ;
6028 kid->op_private |= priv;
6030 kid->op_sibling = sibl;
6036 mod(scalar(kid), type);
6040 tokid = &kid->op_sibling;
6041 kid = kid->op_sibling;
6043 o->op_private |= numargs;
6045 return too_many_arguments(o,OP_DESC(o));
6048 else if (PL_opargs[type] & OA_DEFGV) {
6050 return newUNOP(type, 0, newDEFSVOP());
6054 while (oa & OA_OPTIONAL)
6056 if (oa && oa != OA_LIST)
6057 return too_few_arguments(o,OP_DESC(o));
6063 Perl_ck_glob(pTHX_ OP *o)
6068 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6069 append_elem(OP_GLOB, o, newDEFSVOP());
6071 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6072 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6074 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6077 #if !defined(PERL_EXTERNAL_GLOB)
6078 /* XXX this can be tightened up and made more failsafe. */
6082 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6083 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6084 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6085 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6086 GvCV(gv) = GvCV(glob_gv);
6087 SvREFCNT_inc((SV*)GvCV(gv));
6088 GvIMPORTED_CV_on(gv);
6091 #endif /* PERL_EXTERNAL_GLOB */
6093 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6094 append_elem(OP_GLOB, o,
6095 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6096 o->op_type = OP_LIST;
6097 o->op_ppaddr = PL_ppaddr[OP_LIST];
6098 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6099 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6100 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6101 append_elem(OP_LIST, o,
6102 scalar(newUNOP(OP_RV2CV, 0,
6103 newGVOP(OP_GV, 0, gv)))));
6104 o = newUNOP(OP_NULL, 0, ck_subr(o));
6105 o->op_targ = OP_GLOB; /* hint at what it used to be */
6108 gv = newGVgen("main");
6110 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6116 Perl_ck_grep(pTHX_ OP *o)
6120 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6122 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6123 NewOp(1101, gwop, 1, LOGOP);
6125 if (o->op_flags & OPf_STACKED) {
6128 kid = cLISTOPo->op_first->op_sibling;
6129 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6132 kid->op_next = (OP*)gwop;
6133 o->op_flags &= ~OPf_STACKED;
6135 kid = cLISTOPo->op_first->op_sibling;
6136 if (type == OP_MAPWHILE)
6143 kid = cLISTOPo->op_first->op_sibling;
6144 if (kid->op_type != OP_NULL)
6145 Perl_croak(aTHX_ "panic: ck_grep");
6146 kid = kUNOP->op_first;
6148 gwop->op_type = type;
6149 gwop->op_ppaddr = PL_ppaddr[type];
6150 gwop->op_first = listkids(o);
6151 gwop->op_flags |= OPf_KIDS;
6152 gwop->op_private = 1;
6153 gwop->op_other = LINKLIST(kid);
6154 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6155 kid->op_next = (OP*)gwop;
6157 kid = cLISTOPo->op_first->op_sibling;
6158 if (!kid || !kid->op_sibling)
6159 return too_few_arguments(o,OP_DESC(o));
6160 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6161 mod(kid, OP_GREPSTART);
6167 Perl_ck_index(pTHX_ OP *o)
6169 if (o->op_flags & OPf_KIDS) {
6170 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6172 kid = kid->op_sibling; /* get past "big" */
6173 if (kid && kid->op_type == OP_CONST)
6174 fbm_compile(((SVOP*)kid)->op_sv, 0);
6180 Perl_ck_lengthconst(pTHX_ OP *o)
6182 /* XXX length optimization goes here */
6187 Perl_ck_lfun(pTHX_ OP *o)
6189 OPCODE type = o->op_type;
6190 return modkids(ck_fun(o), type);
6194 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6196 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6197 switch (cUNOPo->op_first->op_type) {
6199 /* This is needed for
6200 if (defined %stash::)
6201 to work. Do not break Tk.
6203 break; /* Globals via GV can be undef */
6205 case OP_AASSIGN: /* Is this a good idea? */
6206 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6207 "defined(@array) is deprecated");
6208 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6209 "\t(Maybe you should just omit the defined()?)\n");
6212 /* This is needed for
6213 if (defined %stash::)
6214 to work. Do not break Tk.
6216 break; /* Globals via GV can be undef */
6218 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6219 "defined(%%hash) is deprecated");
6220 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6221 "\t(Maybe you should just omit the defined()?)\n");
6232 Perl_ck_rfun(pTHX_ OP *o)
6234 OPCODE type = o->op_type;
6235 return refkids(ck_fun(o), type);
6239 Perl_ck_listiob(pTHX_ OP *o)
6243 kid = cLISTOPo->op_first;
6246 kid = cLISTOPo->op_first;
6248 if (kid->op_type == OP_PUSHMARK)
6249 kid = kid->op_sibling;
6250 if (kid && o->op_flags & OPf_STACKED)
6251 kid = kid->op_sibling;
6252 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6253 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6254 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6255 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6256 cLISTOPo->op_first->op_sibling = kid;
6257 cLISTOPo->op_last = kid;
6258 kid = kid->op_sibling;
6263 append_elem(o->op_type, o, newDEFSVOP());
6269 Perl_ck_sassign(pTHX_ OP *o)
6271 OP *kid = cLISTOPo->op_first;
6272 /* has a disposable target? */
6273 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6274 && !(kid->op_flags & OPf_STACKED)
6275 /* Cannot steal the second time! */
6276 && !(kid->op_private & OPpTARGET_MY))
6278 OP *kkid = kid->op_sibling;
6280 /* Can just relocate the target. */
6281 if (kkid && kkid->op_type == OP_PADSV
6282 && !(kkid->op_private & OPpLVAL_INTRO))
6284 kid->op_targ = kkid->op_targ;
6286 /* Now we do not need PADSV and SASSIGN. */
6287 kid->op_sibling = o->op_sibling; /* NULL */
6288 cLISTOPo->op_first = NULL;
6291 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6299 Perl_ck_match(pTHX_ OP *o)
6301 o->op_private |= OPpRUNTIME;
6306 Perl_ck_method(pTHX_ OP *o)
6308 OP *kid = cUNOPo->op_first;
6309 if (kid->op_type == OP_CONST) {
6310 SV* sv = kSVOP->op_sv;
6311 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6313 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6314 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6317 kSVOP->op_sv = Nullsv;
6319 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6328 Perl_ck_null(pTHX_ OP *o)
6334 Perl_ck_open(pTHX_ OP *o)
6336 HV *table = GvHV(PL_hintgv);
6340 svp = hv_fetch(table, "open_IN", 7, FALSE);
6342 mode = mode_from_discipline(*svp);
6343 if (mode & O_BINARY)
6344 o->op_private |= OPpOPEN_IN_RAW;
6345 else if (mode & O_TEXT)
6346 o->op_private |= OPpOPEN_IN_CRLF;
6349 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6351 mode = mode_from_discipline(*svp);
6352 if (mode & O_BINARY)
6353 o->op_private |= OPpOPEN_OUT_RAW;
6354 else if (mode & O_TEXT)
6355 o->op_private |= OPpOPEN_OUT_CRLF;
6358 if (o->op_type == OP_BACKTICK)
6364 Perl_ck_repeat(pTHX_ OP *o)
6366 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6367 o->op_private |= OPpREPEAT_DOLIST;
6368 cBINOPo->op_first = force_list(cBINOPo->op_first);
6376 Perl_ck_require(pTHX_ OP *o)
6380 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6381 SVOP *kid = (SVOP*)cUNOPo->op_first;
6383 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6385 for (s = SvPVX(kid->op_sv); *s; s++) {
6386 if (*s == ':' && s[1] == ':') {
6388 Move(s+2, s+1, strlen(s+2)+1, char);
6389 --SvCUR(kid->op_sv);
6392 if (SvREADONLY(kid->op_sv)) {
6393 SvREADONLY_off(kid->op_sv);
6394 sv_catpvn(kid->op_sv, ".pm", 3);
6395 SvREADONLY_on(kid->op_sv);
6398 sv_catpvn(kid->op_sv, ".pm", 3);
6402 /* handle override, if any */
6403 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6404 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6405 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6407 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6408 OP *kid = cUNOPo->op_first;
6409 cUNOPo->op_first = 0;
6411 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6412 append_elem(OP_LIST, kid,
6413 scalar(newUNOP(OP_RV2CV, 0,
6422 Perl_ck_return(pTHX_ OP *o)
6425 if (CvLVALUE(PL_compcv)) {
6426 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6427 mod(kid, OP_LEAVESUBLV);
6434 Perl_ck_retarget(pTHX_ OP *o)
6436 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6443 Perl_ck_select(pTHX_ OP *o)
6446 if (o->op_flags & OPf_KIDS) {
6447 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6448 if (kid && kid->op_sibling) {
6449 o->op_type = OP_SSELECT;
6450 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6452 return fold_constants(o);
6456 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6457 if (kid && kid->op_type == OP_RV2GV)
6458 kid->op_private &= ~HINT_STRICT_REFS;
6463 Perl_ck_shift(pTHX_ OP *o)
6465 I32 type = o->op_type;
6467 if (!(o->op_flags & OPf_KIDS)) {
6471 #ifdef USE_5005THREADS
6472 if (!CvUNIQUE(PL_compcv)) {
6473 argop = newOP(OP_PADAV, OPf_REF);
6474 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6477 argop = newUNOP(OP_RV2AV, 0,
6478 scalar(newGVOP(OP_GV, 0,
6479 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6482 argop = newUNOP(OP_RV2AV, 0,
6483 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6484 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6485 #endif /* USE_5005THREADS */
6486 return newUNOP(type, 0, scalar(argop));
6488 return scalar(modkids(ck_fun(o), type));
6492 Perl_ck_sort(pTHX_ OP *o)
6496 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6498 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6499 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6501 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6503 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6505 if (kid->op_type == OP_SCOPE) {
6509 else if (kid->op_type == OP_LEAVE) {
6510 if (o->op_type == OP_SORT) {
6511 op_null(kid); /* wipe out leave */
6514 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6515 if (k->op_next == kid)
6517 /* don't descend into loops */
6518 else if (k->op_type == OP_ENTERLOOP
6519 || k->op_type == OP_ENTERITER)
6521 k = cLOOPx(k)->op_lastop;
6526 kid->op_next = 0; /* just disconnect the leave */
6527 k = kLISTOP->op_first;
6532 if (o->op_type == OP_SORT) {
6533 /* provide scalar context for comparison function/block */
6539 o->op_flags |= OPf_SPECIAL;
6541 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6544 firstkid = firstkid->op_sibling;
6547 /* provide list context for arguments */
6548 if (o->op_type == OP_SORT)
6555 S_simplify_sort(pTHX_ OP *o)
6557 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6561 if (!(o->op_flags & OPf_STACKED))
6563 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6564 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6565 kid = kUNOP->op_first; /* get past null */
6566 if (kid->op_type != OP_SCOPE)
6568 kid = kLISTOP->op_last; /* get past scope */
6569 switch(kid->op_type) {
6577 k = kid; /* remember this node*/
6578 if (kBINOP->op_first->op_type != OP_RV2SV)
6580 kid = kBINOP->op_first; /* get past cmp */
6581 if (kUNOP->op_first->op_type != OP_GV)
6583 kid = kUNOP->op_first; /* get past rv2sv */
6585 if (GvSTASH(gv) != PL_curstash)
6587 if (strEQ(GvNAME(gv), "a"))
6589 else if (strEQ(GvNAME(gv), "b"))
6593 kid = k; /* back to cmp */
6594 if (kBINOP->op_last->op_type != OP_RV2SV)
6596 kid = kBINOP->op_last; /* down to 2nd arg */
6597 if (kUNOP->op_first->op_type != OP_GV)
6599 kid = kUNOP->op_first; /* get past rv2sv */
6601 if (GvSTASH(gv) != PL_curstash
6603 ? strNE(GvNAME(gv), "a")
6604 : strNE(GvNAME(gv), "b")))
6606 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6608 o->op_private |= OPpSORT_REVERSE;
6609 if (k->op_type == OP_NCMP)
6610 o->op_private |= OPpSORT_NUMERIC;
6611 if (k->op_type == OP_I_NCMP)
6612 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6613 kid = cLISTOPo->op_first->op_sibling;
6614 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6615 op_free(kid); /* then delete it */
6619 Perl_ck_split(pTHX_ OP *o)
6623 if (o->op_flags & OPf_STACKED)
6624 return no_fh_allowed(o);
6626 kid = cLISTOPo->op_first;
6627 if (kid->op_type != OP_NULL)
6628 Perl_croak(aTHX_ "panic: ck_split");
6629 kid = kid->op_sibling;
6630 op_free(cLISTOPo->op_first);
6631 cLISTOPo->op_first = kid;
6633 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6634 cLISTOPo->op_last = kid; /* There was only one element previously */
6637 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6638 OP *sibl = kid->op_sibling;
6639 kid->op_sibling = 0;
6640 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6641 if (cLISTOPo->op_first == cLISTOPo->op_last)
6642 cLISTOPo->op_last = kid;
6643 cLISTOPo->op_first = kid;
6644 kid->op_sibling = sibl;
6647 kid->op_type = OP_PUSHRE;
6648 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6651 if (!kid->op_sibling)
6652 append_elem(OP_SPLIT, o, newDEFSVOP());
6654 kid = kid->op_sibling;
6657 if (!kid->op_sibling)
6658 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6660 kid = kid->op_sibling;
6663 if (kid->op_sibling)
6664 return too_many_arguments(o,OP_DESC(o));
6670 Perl_ck_join(pTHX_ OP *o)
6672 if (ckWARN(WARN_SYNTAX)) {
6673 OP *kid = cLISTOPo->op_first->op_sibling;
6674 if (kid && kid->op_type == OP_MATCH) {
6675 char *pmstr = "STRING";
6676 if (PM_GETRE(kPMOP))
6677 pmstr = PM_GETRE(kPMOP)->precomp;
6678 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6679 "/%s/ should probably be written as \"%s\"",
6687 Perl_ck_subr(pTHX_ OP *o)
6689 OP *prev = ((cUNOPo->op_first->op_sibling)
6690 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6691 OP *o2 = prev->op_sibling;
6698 I32 contextclass = 0;
6702 o->op_private |= OPpENTERSUB_HASTARG;
6703 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6704 if (cvop->op_type == OP_RV2CV) {
6706 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6707 op_null(cvop); /* disable rv2cv */
6708 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6709 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6710 GV *gv = cGVOPx_gv(tmpop);
6713 tmpop->op_private |= OPpEARLY_CV;
6714 else if (SvPOK(cv)) {
6715 namegv = CvANON(cv) ? gv : CvGV(cv);
6716 proto = SvPV((SV*)cv, n_a);
6720 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6721 if (o2->op_type == OP_CONST)
6722 o2->op_private &= ~OPpCONST_STRICT;
6723 else if (o2->op_type == OP_LIST) {
6724 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6725 if (o && o->op_type == OP_CONST)
6726 o->op_private &= ~OPpCONST_STRICT;
6729 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6730 if (PERLDB_SUB && PL_curstash != PL_debstash)
6731 o->op_private |= OPpENTERSUB_DB;
6732 while (o2 != cvop) {
6736 return too_many_arguments(o, gv_ename(namegv));
6754 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6756 arg == 1 ? "block or sub {}" : "sub {}",
6757 gv_ename(namegv), o2);
6760 /* '*' allows any scalar type, including bareword */
6763 if (o2->op_type == OP_RV2GV)
6764 goto wrapref; /* autoconvert GLOB -> GLOBref */
6765 else if (o2->op_type == OP_CONST)
6766 o2->op_private &= ~OPpCONST_STRICT;
6767 else if (o2->op_type == OP_ENTERSUB) {
6768 /* accidental subroutine, revert to bareword */
6769 OP *gvop = ((UNOP*)o2)->op_first;
6770 if (gvop && gvop->op_type == OP_NULL) {
6771 gvop = ((UNOP*)gvop)->op_first;
6773 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6776 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6777 (gvop = ((UNOP*)gvop)->op_first) &&
6778 gvop->op_type == OP_GV)
6780 GV *gv = cGVOPx_gv(gvop);
6781 OP *sibling = o2->op_sibling;
6782 SV *n = newSVpvn("",0);
6784 gv_fullname3(n, gv, "");
6785 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6786 sv_chop(n, SvPVX(n)+6);
6787 o2 = newSVOP(OP_CONST, 0, n);
6788 prev->op_sibling = o2;
6789 o2->op_sibling = sibling;
6805 if (contextclass++ == 0) {
6806 e = strchr(proto, ']');
6807 if (!e || e == proto)
6820 while (*--p != '[');
6821 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6822 gv_ename(namegv), o2);
6828 if (o2->op_type == OP_RV2GV)
6831 bad_type(arg, "symbol", gv_ename(namegv), o2);
6834 if (o2->op_type == OP_ENTERSUB)
6837 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6840 if (o2->op_type == OP_RV2SV ||
6841 o2->op_type == OP_PADSV ||
6842 o2->op_type == OP_HELEM ||
6843 o2->op_type == OP_AELEM ||
6844 o2->op_type == OP_THREADSV)
6847 bad_type(arg, "scalar", gv_ename(namegv), o2);
6850 if (o2->op_type == OP_RV2AV ||
6851 o2->op_type == OP_PADAV)
6854 bad_type(arg, "array", gv_ename(namegv), o2);
6857 if (o2->op_type == OP_RV2HV ||
6858 o2->op_type == OP_PADHV)
6861 bad_type(arg, "hash", gv_ename(namegv), o2);
6866 OP* sib = kid->op_sibling;
6867 kid->op_sibling = 0;
6868 o2 = newUNOP(OP_REFGEN, 0, kid);
6869 o2->op_sibling = sib;
6870 prev->op_sibling = o2;
6872 if (contextclass && e) {
6887 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6888 gv_ename(namegv), SvPV((SV*)cv, n_a));
6893 mod(o2, OP_ENTERSUB);
6895 o2 = o2->op_sibling;
6897 if (proto && !optional &&
6898 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6899 return too_few_arguments(o, gv_ename(namegv));
6904 Perl_ck_svconst(pTHX_ OP *o)
6906 SvREADONLY_on(cSVOPo->op_sv);
6911 Perl_ck_trunc(pTHX_ OP *o)
6913 if (o->op_flags & OPf_KIDS) {
6914 SVOP *kid = (SVOP*)cUNOPo->op_first;
6916 if (kid->op_type == OP_NULL)
6917 kid = (SVOP*)kid->op_sibling;
6918 if (kid && kid->op_type == OP_CONST &&
6919 (kid->op_private & OPpCONST_BARE))
6921 o->op_flags |= OPf_SPECIAL;
6922 kid->op_private &= ~OPpCONST_STRICT;
6929 Perl_ck_substr(pTHX_ OP *o)
6932 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6933 OP *kid = cLISTOPo->op_first;
6935 if (kid->op_type == OP_NULL)
6936 kid = kid->op_sibling;
6938 kid->op_flags |= OPf_MOD;
6944 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6947 Perl_peep(pTHX_ register OP *o)
6949 register OP* oldop = 0;
6952 if (!o || o->op_seq)
6956 SAVEVPTR(PL_curcop);
6957 for (; o; o = o->op_next) {
6963 switch (o->op_type) {
6967 PL_curcop = ((COP*)o); /* for warnings */
6968 o->op_seq = PL_op_seqmax++;
6972 if (cSVOPo->op_private & OPpCONST_STRICT)
6973 no_bareword_allowed(o);
6975 /* Relocate sv to the pad for thread safety.
6976 * Despite being a "constant", the SV is written to,
6977 * for reference counts, sv_upgrade() etc. */
6979 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6980 if (SvPADTMP(cSVOPo->op_sv)) {
6981 /* If op_sv is already a PADTMP then it is being used by
6982 * some pad, so make a copy. */
6983 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6984 SvREADONLY_on(PL_curpad[ix]);
6985 SvREFCNT_dec(cSVOPo->op_sv);
6988 SvREFCNT_dec(PL_curpad[ix]);
6989 SvPADTMP_on(cSVOPo->op_sv);
6990 PL_curpad[ix] = cSVOPo->op_sv;
6991 /* XXX I don't know how this isn't readonly already. */
6992 SvREADONLY_on(PL_curpad[ix]);
6994 cSVOPo->op_sv = Nullsv;
6998 o->op_seq = PL_op_seqmax++;
7002 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7003 if (o->op_next->op_private & OPpTARGET_MY) {
7004 if (o->op_flags & OPf_STACKED) /* chained concats */
7005 goto ignore_optimization;
7007 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7008 o->op_targ = o->op_next->op_targ;
7009 o->op_next->op_targ = 0;
7010 o->op_private |= OPpTARGET_MY;
7013 op_null(o->op_next);
7015 ignore_optimization:
7016 o->op_seq = PL_op_seqmax++;
7019 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7020 o->op_seq = PL_op_seqmax++;
7021 break; /* Scalar stub must produce undef. List stub is noop */
7025 if (o->op_targ == OP_NEXTSTATE
7026 || o->op_targ == OP_DBSTATE
7027 || o->op_targ == OP_SETSTATE)
7029 PL_curcop = ((COP*)o);
7031 /* XXX: We avoid setting op_seq here to prevent later calls
7032 to peep() from mistakenly concluding that optimisation
7033 has already occurred. This doesn't fix the real problem,
7034 though (See 20010220.007). AMS 20010719 */
7035 if (oldop && o->op_next) {
7036 oldop->op_next = o->op_next;
7044 if (oldop && o->op_next) {
7045 oldop->op_next = o->op_next;
7048 o->op_seq = PL_op_seqmax++;
7052 if (o->op_next->op_type == OP_RV2SV) {
7053 if (!(o->op_next->op_private & OPpDEREF)) {
7054 op_null(o->op_next);
7055 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7057 o->op_next = o->op_next->op_next;
7058 o->op_type = OP_GVSV;
7059 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7062 else if (o->op_next->op_type == OP_RV2AV) {
7063 OP* pop = o->op_next->op_next;
7065 if (pop && pop->op_type == OP_CONST &&
7066 (PL_op = pop->op_next) &&
7067 pop->op_next->op_type == OP_AELEM &&
7068 !(pop->op_next->op_private &
7069 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7070 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7075 op_null(o->op_next);
7076 op_null(pop->op_next);
7078 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7079 o->op_next = pop->op_next->op_next;
7080 o->op_type = OP_AELEMFAST;
7081 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7082 o->op_private = (U8)i;
7087 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7089 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7090 /* XXX could check prototype here instead of just carping */
7091 SV *sv = sv_newmortal();
7092 gv_efullname3(sv, gv, Nullch);
7093 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7094 "%s() called too early to check prototype",
7098 else if (o->op_next->op_type == OP_READLINE
7099 && o->op_next->op_next->op_type == OP_CONCAT
7100 && (o->op_next->op_next->op_flags & OPf_STACKED))
7102 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7103 o->op_type = OP_RCATLINE;
7104 o->op_flags |= OPf_STACKED;
7105 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7106 op_null(o->op_next->op_next);
7107 op_null(o->op_next);
7110 o->op_seq = PL_op_seqmax++;
7121 o->op_seq = PL_op_seqmax++;
7122 while (cLOGOP->op_other->op_type == OP_NULL)
7123 cLOGOP->op_other = cLOGOP->op_other->op_next;
7124 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7129 o->op_seq = PL_op_seqmax++;
7130 while (cLOOP->op_redoop->op_type == OP_NULL)
7131 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7132 peep(cLOOP->op_redoop);
7133 while (cLOOP->op_nextop->op_type == OP_NULL)
7134 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7135 peep(cLOOP->op_nextop);
7136 while (cLOOP->op_lastop->op_type == OP_NULL)
7137 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7138 peep(cLOOP->op_lastop);
7144 o->op_seq = PL_op_seqmax++;
7145 while (cPMOP->op_pmreplstart &&
7146 cPMOP->op_pmreplstart->op_type == OP_NULL)
7147 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7148 peep(cPMOP->op_pmreplstart);
7152 o->op_seq = PL_op_seqmax++;
7153 if (ckWARN(WARN_SYNTAX) && o->op_next
7154 && o->op_next->op_type == OP_NEXTSTATE) {
7155 if (o->op_next->op_sibling &&
7156 o->op_next->op_sibling->op_type != OP_EXIT &&
7157 o->op_next->op_sibling->op_type != OP_WARN &&
7158 o->op_next->op_sibling->op_type != OP_DIE) {
7159 line_t oldline = CopLINE(PL_curcop);
7161 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7162 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7163 "Statement unlikely to be reached");
7164 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7165 "\t(Maybe you meant system() when you said exec()?)\n");
7166 CopLINE_set(PL_curcop, oldline);
7175 SV **svp, **indsvp, *sv;
7180 o->op_seq = PL_op_seqmax++;
7182 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7185 /* Make the CONST have a shared SV */
7186 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7187 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7188 key = SvPV(sv, keylen);
7189 lexname = newSVpvn_share(key,
7190 SvUTF8(sv) ? -(I32)keylen : keylen,
7196 if ((o->op_private & (OPpLVAL_INTRO)))
7199 rop = (UNOP*)((BINOP*)o)->op_first;
7200 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7202 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7203 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7205 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7206 if (!fields || !GvHV(*fields))
7208 key = SvPV(*svp, keylen);
7209 indsvp = hv_fetch(GvHV(*fields), key,
7210 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7212 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7213 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7215 ind = SvIV(*indsvp);
7217 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7218 rop->op_type = OP_RV2AV;
7219 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7220 o->op_type = OP_AELEM;
7221 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7223 if (SvREADONLY(*svp))
7225 SvFLAGS(sv) |= (SvFLAGS(*svp)
7226 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7236 SV **svp, **indsvp, *sv;
7240 SVOP *first_key_op, *key_op;
7242 o->op_seq = PL_op_seqmax++;
7243 if ((o->op_private & (OPpLVAL_INTRO))
7244 /* I bet there's always a pushmark... */
7245 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7246 /* hmmm, no optimization if list contains only one key. */
7248 rop = (UNOP*)((LISTOP*)o)->op_last;
7249 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7251 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7252 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7254 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7255 if (!fields || !GvHV(*fields))
7257 /* Again guessing that the pushmark can be jumped over.... */
7258 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7259 ->op_first->op_sibling;
7260 /* Check that the key list contains only constants. */
7261 for (key_op = first_key_op; key_op;
7262 key_op = (SVOP*)key_op->op_sibling)
7263 if (key_op->op_type != OP_CONST)
7267 rop->op_type = OP_RV2AV;
7268 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7269 o->op_type = OP_ASLICE;
7270 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7271 for (key_op = first_key_op; key_op;
7272 key_op = (SVOP*)key_op->op_sibling) {
7273 svp = cSVOPx_svp(key_op);
7274 key = SvPV(*svp, keylen);
7275 indsvp = hv_fetch(GvHV(*fields), key,
7276 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7278 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7279 "in variable %s of type %s",
7280 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7282 ind = SvIV(*indsvp);
7284 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7286 if (SvREADONLY(*svp))
7288 SvFLAGS(sv) |= (SvFLAGS(*svp)
7289 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7297 o->op_seq = PL_op_seqmax++;
7307 char* Perl_custom_op_name(pTHX_ OP* o)
7309 IV index = PTR2IV(o->op_ppaddr);
7313 if (!PL_custom_op_names) /* This probably shouldn't happen */
7314 return PL_op_name[OP_CUSTOM];
7316 keysv = sv_2mortal(newSViv(index));
7318 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7320 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7322 return SvPV_nolen(HeVAL(he));
7325 char* Perl_custom_op_desc(pTHX_ OP* o)
7327 IV index = PTR2IV(o->op_ppaddr);
7331 if (!PL_custom_op_descs)
7332 return PL_op_desc[OP_CUSTOM];
7334 keysv = sv_2mortal(newSViv(index));
7336 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7338 return PL_op_desc[OP_CUSTOM];
7340 return SvPV_nolen(HeVAL(he));
7346 /* Efficient sub that returns a constant scalar value. */
7348 const_sv_xsub(pTHX_ CV* cv)
7353 Perl_croak(aTHX_ "usage: %s::%s()",
7354 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7358 ST(0) = (SV*)XSANY.any_ptr;