3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
40 /* Add an overhead for pointer to slab and round up as a number of IVs */
41 sz = (sz + 2*sizeof(IV) -1)/sizeof(IV);
42 if ((PL_OpSpace -= sz) < 0) {
43 PL_OpSlab = (IV *) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(IV));
47 Zero(PL_OpSlab,PERL_SLAB_SIZE,IV);
48 /* We reserve the 0'th word as a use count */
49 PL_OpSpace = PERL_SLAB_SIZE - 1 - sz;
50 /* Allocation pointer starts at the top.
51 Theory: because we build leaves before trunk allocating at end
52 means that at run time access is cache friendly upward
54 PL_OpPtr = (IV **) &PL_OpSlab[PERL_SLAB_SIZE];
56 assert( PL_OpSpace >= 0 );
57 /* Move the allocation pointer down */
59 assert( PL_OpPtr > (IV **) PL_OpSlab );
60 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
61 (*PL_OpSlab)++; /* Increment use count of slab */
62 assert( (IV *) (PL_OpPtr+sz) <= (PL_OpSlab + PERL_SLAB_SIZE) );
63 assert( *PL_OpSlab > 0 );
64 return (void *)(PL_OpPtr + 1);
68 S_Slab_Free(pTHX_ void *op)
70 IV **ptr = (IV **) op;
72 assert( ptr-1 > (IV **) slab );
73 assert( (IV *) ptr < (slab + PERL_SLAB_SIZE) );
76 PerlMemShared_free(slab);
77 if (slab == PL_OpSlab) {
84 #define NewOp(m, var, c, type) Newz(m, var, c, type)
85 #define FreeOp(p) SafeFree(p)
88 * In the following definition, the ", Nullop" is just to make the compiler
89 * think the expression is of the right type: croak actually does a Siglongjmp.
91 #define CHECKOP(type,o) \
92 ((PL_op_mask && PL_op_mask[type]) \
93 ? ( op_free((OP*)o), \
94 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
96 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
98 #define PAD_MAX 999999999
99 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
102 S_gv_ename(pTHX_ GV *gv)
105 SV* tmpsv = sv_newmortal();
106 gv_efullname3(tmpsv, gv, Nullch);
107 return SvPV(tmpsv,n_a);
111 S_no_fh_allowed(pTHX_ OP *o)
113 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
119 S_too_few_arguments(pTHX_ OP *o, char *name)
121 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
126 S_too_many_arguments(pTHX_ OP *o, char *name)
128 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
133 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
135 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
136 (int)n, name, t, OP_DESC(kid)));
140 S_no_bareword_allowed(pTHX_ OP *o)
142 qerror(Perl_mess(aTHX_
143 "Bareword \"%s\" not allowed while \"strict subs\" in use",
144 SvPV_nolen(cSVOPo_sv)));
147 /* "register" allocation */
150 Perl_pad_allocmy(pTHX_ char *name)
155 if (!(PL_in_my == KEY_our ||
157 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
158 (name[1] == '_' && (int)strlen(name) > 2)))
160 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
161 /* 1999-02-27 mjd@plover.com */
163 p = strchr(name, '\0');
164 /* The next block assumes the buffer is at least 205 chars
165 long. At present, it's always at least 256 chars. */
167 strcpy(name+200, "...");
173 /* Move everything else down one character */
174 for (; p-name > 2; p--)
176 name[2] = toCTRL(name[1]);
179 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
181 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
182 SV **svp = AvARRAY(PL_comppad_name);
183 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
184 PADOFFSET top = AvFILLp(PL_comppad_name);
185 for (off = top; off > PL_comppad_name_floor; off--) {
187 && sv != &PL_sv_undef
188 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
189 && (PL_in_my != KEY_our
190 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
191 && strEQ(name, SvPVX(sv)))
193 Perl_warner(aTHX_ WARN_MISC,
194 "\"%s\" variable %s masks earlier declaration in same %s",
195 (PL_in_my == KEY_our ? "our" : "my"),
197 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
202 if (PL_in_my == KEY_our) {
205 && sv != &PL_sv_undef
206 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
207 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
208 && strEQ(name, SvPVX(sv)))
210 Perl_warner(aTHX_ WARN_MISC,
211 "\"our\" variable %s redeclared", name);
212 Perl_warner(aTHX_ WARN_MISC,
213 "\t(Did you mean \"local\" instead of \"our\"?)\n");
216 } while ( off-- > 0 );
219 off = pad_alloc(OP_PADSV, SVs_PADMY);
221 sv_upgrade(sv, SVt_PVNV);
223 if (PL_in_my_stash) {
225 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
226 name, PL_in_my == KEY_our ? "our" : "my"));
227 SvFLAGS(sv) |= SVpad_TYPED;
228 (void)SvUPGRADE(sv, SVt_PVMG);
229 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
231 if (PL_in_my == KEY_our) {
232 (void)SvUPGRADE(sv, SVt_PVGV);
233 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
234 SvFLAGS(sv) |= SVpad_OUR;
236 av_store(PL_comppad_name, off, sv);
237 SvNVX(sv) = (NV)PAD_MAX;
238 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
239 if (!PL_min_intro_pending)
240 PL_min_intro_pending = off;
241 PL_max_intro_pending = off;
243 av_store(PL_comppad, off, (SV*)newAV());
244 else if (*name == '%')
245 av_store(PL_comppad, off, (SV*)newHV());
246 SvPADMY_on(PL_curpad[off]);
251 S_pad_addlex(pTHX_ SV *proto_namesv)
253 SV *namesv = NEWSV(1103,0);
254 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
255 sv_upgrade(namesv, SVt_PVNV);
256 sv_setpv(namesv, SvPVX(proto_namesv));
257 av_store(PL_comppad_name, newoff, namesv);
258 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
259 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
260 SvFAKE_on(namesv); /* A ref, not a real var */
261 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
262 SvFLAGS(namesv) |= SVpad_OUR;
263 (void)SvUPGRADE(namesv, SVt_PVGV);
264 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
266 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
267 SvFLAGS(namesv) |= SVpad_TYPED;
268 (void)SvUPGRADE(namesv, SVt_PVMG);
269 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
274 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
277 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
278 I32 cx_ix, I32 saweval, U32 flags)
284 register PERL_CONTEXT *cx;
286 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
287 AV *curlist = CvPADLIST(cv);
288 SV **svp = av_fetch(curlist, 0, FALSE);
291 if (!svp || *svp == &PL_sv_undef)
294 svp = AvARRAY(curname);
295 for (off = AvFILLp(curname); off > 0; off--) {
296 if ((sv = svp[off]) &&
297 sv != &PL_sv_undef &&
299 seq > I_32(SvNVX(sv)) &&
300 strEQ(SvPVX(sv), name))
311 return 0; /* don't clone from inactive stack frame */
315 oldpad = (AV*)AvARRAY(curlist)[depth];
316 oldsv = *av_fetch(oldpad, off, TRUE);
317 if (!newoff) { /* Not a mere clone operation. */
318 newoff = pad_addlex(sv);
319 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
320 /* "It's closures all the way down." */
321 CvCLONE_on(PL_compcv);
323 if (CvANON(PL_compcv))
324 oldsv = Nullsv; /* no need to keep ref */
329 bcv && bcv != cv && !CvCLONE(bcv);
330 bcv = CvOUTSIDE(bcv))
333 /* install the missing pad entry in intervening
334 * nested subs and mark them cloneable.
335 * XXX fix pad_foo() to not use globals */
336 AV *ocomppad_name = PL_comppad_name;
337 AV *ocomppad = PL_comppad;
338 SV **ocurpad = PL_curpad;
339 AV *padlist = CvPADLIST(bcv);
340 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
341 PL_comppad = (AV*)AvARRAY(padlist)[1];
342 PL_curpad = AvARRAY(PL_comppad);
344 PL_comppad_name = ocomppad_name;
345 PL_comppad = ocomppad;
350 if (ckWARN(WARN_CLOSURE)
351 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
353 Perl_warner(aTHX_ WARN_CLOSURE,
354 "Variable \"%s\" may be unavailable",
362 else if (!CvUNIQUE(PL_compcv)) {
363 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
364 && !(SvFLAGS(sv) & SVpad_OUR))
366 Perl_warner(aTHX_ WARN_CLOSURE,
367 "Variable \"%s\" will not stay shared", name);
371 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
377 if (flags & FINDLEX_NOSEARCH)
380 /* Nothing in current lexical context--try eval's context, if any.
381 * This is necessary to let the perldb get at lexically scoped variables.
382 * XXX This will also probably interact badly with eval tree caching.
385 for (i = cx_ix; i >= 0; i--) {
387 switch (CxTYPE(cx)) {
389 if (i == 0 && saweval) {
390 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
394 switch (cx->blk_eval.old_op_type) {
396 if (CxREALEVAL(cx)) {
399 seq = cxstack[i].blk_oldcop->cop_seq;
400 startcv = cxstack[i].blk_eval.cv;
401 if (startcv && CvOUTSIDE(startcv)) {
402 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
404 if (off) /* continue looking if not found here */
411 /* require/do must have their own scope */
420 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
421 saweval = i; /* so we know where we were called from */
422 seq = cxstack[i].blk_oldcop->cop_seq;
425 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
433 Perl_pad_findmy(pTHX_ char *name)
438 SV **svp = AvARRAY(PL_comppad_name);
439 U32 seq = PL_cop_seqmax;
443 #ifdef USE_5005THREADS
445 * Special case to get lexical (and hence per-thread) @_.
446 * XXX I need to find out how to tell at parse-time whether use
447 * of @_ should refer to a lexical (from a sub) or defgv (global
448 * scope and maybe weird sub-ish things like formats). See
449 * startsub in perly.y. It's possible that @_ could be lexical
450 * (at least from subs) even in non-threaded perl.
452 if (strEQ(name, "@_"))
453 return 0; /* success. (NOT_IN_PAD indicates failure) */
454 #endif /* USE_5005THREADS */
456 /* The one we're looking for is probably just before comppad_name_fill. */
457 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
458 if ((sv = svp[off]) &&
459 sv != &PL_sv_undef &&
462 seq > I_32(SvNVX(sv)))) &&
463 strEQ(SvPVX(sv), name))
465 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
466 return (PADOFFSET)off;
467 pendoff = off; /* this pending def. will override import */
471 outside = CvOUTSIDE(PL_compcv);
473 /* Check if if we're compiling an eval'', and adjust seq to be the
474 * eval's seq number. This depends on eval'' having a non-null
475 * CvOUTSIDE() while it is being compiled. The eval'' itself is
476 * identified by CvEVAL being true and CvGV being null. */
477 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
478 cx = &cxstack[cxstack_ix];
480 seq = cx->blk_oldcop->cop_seq;
483 /* See if it's in a nested scope */
484 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
486 /* If there is a pending local definition, this new alias must die */
488 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
489 return off; /* pad_findlex returns 0 for failure...*/
491 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
495 Perl_pad_leavemy(pTHX_ I32 fill)
498 SV **svp = AvARRAY(PL_comppad_name);
500 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
501 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
502 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
503 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
506 /* "Deintroduce" my variables that are leaving with this scope. */
507 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
508 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
509 SvIVX(sv) = PL_cop_seqmax;
514 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
519 if (AvARRAY(PL_comppad) != PL_curpad)
520 Perl_croak(aTHX_ "panic: pad_alloc");
521 if (PL_pad_reset_pending)
523 if (tmptype & SVs_PADMY) {
525 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
526 } while (SvPADBUSY(sv)); /* need a fresh one */
527 retval = AvFILLp(PL_comppad);
530 SV **names = AvARRAY(PL_comppad_name);
531 SSize_t names_fill = AvFILLp(PL_comppad_name);
534 * "foreach" index vars temporarily become aliases to non-"my"
535 * values. Thus we must skip, not just pad values that are
536 * marked as current pad values, but also those with names.
538 if (++PL_padix <= names_fill &&
539 (sv = names[PL_padix]) && sv != &PL_sv_undef)
541 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
542 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
543 !IS_PADGV(sv) && !IS_PADCONST(sv))
548 SvFLAGS(sv) |= tmptype;
549 PL_curpad = AvARRAY(PL_comppad);
550 #ifdef USE_5005THREADS
551 DEBUG_X(PerlIO_printf(Perl_debug_log,
552 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
553 PTR2UV(thr), PTR2UV(PL_curpad),
554 (long) retval, PL_op_name[optype]));
556 DEBUG_X(PerlIO_printf(Perl_debug_log,
557 "Pad 0x%"UVxf" alloc %ld for %s\n",
559 (long) retval, PL_op_name[optype]));
560 #endif /* USE_5005THREADS */
561 return (PADOFFSET)retval;
565 Perl_pad_sv(pTHX_ PADOFFSET po)
567 #ifdef USE_5005THREADS
568 DEBUG_X(PerlIO_printf(Perl_debug_log,
569 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
570 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
573 Perl_croak(aTHX_ "panic: pad_sv po");
574 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
575 PTR2UV(PL_curpad), (IV)po));
576 #endif /* USE_5005THREADS */
577 return PL_curpad[po]; /* eventually we'll turn this into a macro */
581 Perl_pad_free(pTHX_ PADOFFSET po)
585 if (AvARRAY(PL_comppad) != PL_curpad)
586 Perl_croak(aTHX_ "panic: pad_free curpad");
588 Perl_croak(aTHX_ "panic: pad_free po");
589 #ifdef USE_5005THREADS
590 DEBUG_X(PerlIO_printf(Perl_debug_log,
591 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
592 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
594 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
595 PTR2UV(PL_curpad), (IV)po));
596 #endif /* USE_5005THREADS */
597 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
598 SvPADTMP_off(PL_curpad[po]);
600 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
603 if ((I32)po < PL_padix)
608 Perl_pad_swipe(pTHX_ PADOFFSET po)
610 if (AvARRAY(PL_comppad) != PL_curpad)
611 Perl_croak(aTHX_ "panic: pad_swipe curpad");
613 Perl_croak(aTHX_ "panic: pad_swipe po");
614 #ifdef USE_5005THREADS
615 DEBUG_X(PerlIO_printf(Perl_debug_log,
616 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
617 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
619 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
620 PTR2UV(PL_curpad), (IV)po));
621 #endif /* USE_5005THREADS */
622 SvPADTMP_off(PL_curpad[po]);
623 PL_curpad[po] = NEWSV(1107,0);
624 SvPADTMP_on(PL_curpad[po]);
625 if ((I32)po < PL_padix)
629 /* XXX pad_reset() is currently disabled because it results in serious bugs.
630 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
631 * on the stack by OPs that use them, there are several ways to get an alias
632 * to a shared TARG. Such an alias will change randomly and unpredictably.
633 * We avoid doing this until we can think of a Better Way.
638 #ifdef USE_BROKEN_PAD_RESET
641 if (AvARRAY(PL_comppad) != PL_curpad)
642 Perl_croak(aTHX_ "panic: pad_reset curpad");
643 #ifdef USE_5005THREADS
644 DEBUG_X(PerlIO_printf(Perl_debug_log,
645 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
646 PTR2UV(thr), PTR2UV(PL_curpad)));
648 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
650 #endif /* USE_5005THREADS */
651 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
652 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
653 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
654 SvPADTMP_off(PL_curpad[po]);
656 PL_padix = PL_padix_floor;
659 PL_pad_reset_pending = FALSE;
662 #ifdef USE_5005THREADS
663 /* find_threadsv is not reentrant */
665 Perl_find_threadsv(pTHX_ const char *name)
670 /* We currently only handle names of a single character */
671 p = strchr(PL_threadsv_names, *name);
674 key = p - PL_threadsv_names;
675 MUTEX_LOCK(&thr->mutex);
676 svp = av_fetch(thr->threadsv, key, FALSE);
678 MUTEX_UNLOCK(&thr->mutex);
680 SV *sv = NEWSV(0, 0);
681 av_store(thr->threadsv, key, sv);
682 thr->threadsvp = AvARRAY(thr->threadsv);
683 MUTEX_UNLOCK(&thr->mutex);
685 * Some magic variables used to be automagically initialised
686 * in gv_fetchpv. Those which are now per-thread magicals get
687 * initialised here instead.
693 sv_setpv(sv, "\034");
694 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
699 PL_sawampersand = TRUE;
713 /* XXX %! tied to Errno.pm needs to be added here.
714 * See gv_fetchpv(). */
718 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
720 DEBUG_S(PerlIO_printf(Perl_error_log,
721 "find_threadsv: new SV %p for $%s%c\n",
722 sv, (*name < 32) ? "^" : "",
723 (*name < 32) ? toCTRL(*name) : *name));
727 #endif /* USE_5005THREADS */
732 Perl_op_free(pTHX_ OP *o)
734 register OP *kid, *nextkid;
737 if (!o || o->op_seq == (U16)-1)
740 if (o->op_private & OPpREFCOUNTED) {
741 switch (o->op_type) {
749 if (OpREFCNT_dec(o)) {
760 if (o->op_flags & OPf_KIDS) {
761 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
762 nextkid = kid->op_sibling; /* Get before next freeing kid */
770 /* COP* is not cleared by op_clear() so that we may track line
771 * numbers etc even after null() */
772 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
780 Perl_op_clear(pTHX_ OP *o)
783 switch (o->op_type) {
784 case OP_NULL: /* Was holding old type, if any. */
785 case OP_ENTEREVAL: /* Was holding hints. */
786 #ifdef USE_5005THREADS
787 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
791 #ifdef USE_5005THREADS
793 if (!(o->op_flags & OPf_SPECIAL))
796 #endif /* USE_5005THREADS */
798 if (!(o->op_flags & OPf_REF)
799 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
806 if (cPADOPo->op_padix > 0) {
809 pad_swipe(cPADOPo->op_padix);
810 /* No GvIN_PAD_off(gv) here, because other references may still
811 * exist on the pad */
814 cPADOPo->op_padix = 0;
817 SvREFCNT_dec(cSVOPo->op_sv);
818 cSVOPo->op_sv = Nullsv;
821 case OP_METHOD_NAMED:
823 SvREFCNT_dec(cSVOPo->op_sv);
824 cSVOPo->op_sv = Nullsv;
830 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
834 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
835 SvREFCNT_dec(cSVOPo->op_sv);
836 cSVOPo->op_sv = Nullsv;
839 Safefree(cPVOPo->op_pv);
840 cPVOPo->op_pv = Nullch;
844 op_free(cPMOPo->op_pmreplroot);
848 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
850 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
851 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
852 /* No GvIN_PAD_off(gv) here, because other references may still
853 * exist on the pad */
858 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
865 HV *pmstash = PmopSTASH(cPMOPo);
866 if (pmstash && SvREFCNT(pmstash)) {
867 PMOP *pmop = HvPMROOT(pmstash);
868 PMOP *lastpmop = NULL;
870 if (cPMOPo == pmop) {
872 lastpmop->op_pmnext = pmop->op_pmnext;
874 HvPMROOT(pmstash) = pmop->op_pmnext;
878 pmop = pmop->op_pmnext;
881 PmopSTASH_free(cPMOPo);
883 cPMOPo->op_pmreplroot = Nullop;
884 /* we use the "SAFE" version of the PM_ macros here
885 * since sv_clean_all might release some PMOPs
886 * after PL_regex_padav has been cleared
887 * and the clearing of PL_regex_padav needs to
888 * happen before sv_clean_all
890 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
891 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
893 if(PL_regex_pad) { /* We could be in destruction */
894 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
895 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
896 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
903 if (o->op_targ > 0) {
904 pad_free(o->op_targ);
910 S_cop_free(pTHX_ COP* cop)
912 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
915 if (! specialWARN(cop->cop_warnings))
916 SvREFCNT_dec(cop->cop_warnings);
917 if (! specialCopIO(cop->cop_io)) {
920 char *s = SvPV(cop->cop_io,len);
921 Perl_warn(aTHX_ "io='%.*s'",(int) len,s);
923 SvREFCNT_dec(cop->cop_io);
929 Perl_op_null(pTHX_ OP *o)
931 if (o->op_type == OP_NULL)
934 o->op_targ = o->op_type;
935 o->op_type = OP_NULL;
936 o->op_ppaddr = PL_ppaddr[OP_NULL];
939 /* Contextualizers */
941 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
944 Perl_linklist(pTHX_ OP *o)
951 /* establish postfix order */
952 if (cUNOPo->op_first) {
953 o->op_next = LINKLIST(cUNOPo->op_first);
954 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
956 kid->op_next = LINKLIST(kid->op_sibling);
968 Perl_scalarkids(pTHX_ OP *o)
971 if (o && o->op_flags & OPf_KIDS) {
972 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
979 S_scalarboolean(pTHX_ OP *o)
981 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
982 if (ckWARN(WARN_SYNTAX)) {
983 line_t oldline = CopLINE(PL_curcop);
985 if (PL_copline != NOLINE)
986 CopLINE_set(PL_curcop, PL_copline);
987 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
988 CopLINE_set(PL_curcop, oldline);
995 Perl_scalar(pTHX_ OP *o)
999 /* assumes no premature commitment */
1000 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1001 || o->op_type == OP_RETURN)
1006 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1008 switch (o->op_type) {
1010 scalar(cBINOPo->op_first);
1015 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1019 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1020 if (!kPMOP->op_pmreplroot)
1021 deprecate("implicit split to @_");
1029 if (o->op_flags & OPf_KIDS) {
1030 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1036 kid = cLISTOPo->op_first;
1038 while ((kid = kid->op_sibling)) {
1039 if (kid->op_sibling)
1044 WITH_THR(PL_curcop = &PL_compiling);
1049 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1050 if (kid->op_sibling)
1055 WITH_THR(PL_curcop = &PL_compiling);
1058 if (ckWARN(WARN_VOID))
1059 Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
1065 Perl_scalarvoid(pTHX_ OP *o)
1072 if (o->op_type == OP_NEXTSTATE
1073 || o->op_type == OP_SETSTATE
1074 || o->op_type == OP_DBSTATE
1075 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1076 || o->op_targ == OP_SETSTATE
1077 || o->op_targ == OP_DBSTATE)))
1078 PL_curcop = (COP*)o; /* for warning below */
1080 /* assumes no premature commitment */
1081 want = o->op_flags & OPf_WANT;
1082 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1083 || o->op_type == OP_RETURN)
1088 if ((o->op_private & OPpTARGET_MY)
1089 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1091 return scalar(o); /* As if inside SASSIGN */
1094 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1096 switch (o->op_type) {
1098 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1102 if (o->op_flags & OPf_STACKED)
1106 if (o->op_private == 4)
1148 case OP_GETSOCKNAME:
1149 case OP_GETPEERNAME:
1154 case OP_GETPRIORITY:
1177 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1178 useless = OP_DESC(o);
1185 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1186 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1187 useless = "a variable";
1192 if (cSVOPo->op_private & OPpCONST_STRICT)
1193 no_bareword_allowed(o);
1195 if (ckWARN(WARN_VOID)) {
1196 useless = "a constant";
1197 /* the constants 0 and 1 are permitted as they are
1198 conventionally used as dummies in constructs like
1199 1 while some_condition_with_side_effects; */
1200 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1202 else if (SvPOK(sv)) {
1203 /* perl4's way of mixing documentation and code
1204 (before the invention of POD) was based on a
1205 trick to mix nroff and perl code. The trick was
1206 built upon these three nroff macros being used in
1207 void context. The pink camel has the details in
1208 the script wrapman near page 319. */
1209 if (strnEQ(SvPVX(sv), "di", 2) ||
1210 strnEQ(SvPVX(sv), "ds", 2) ||
1211 strnEQ(SvPVX(sv), "ig", 2))
1216 op_null(o); /* don't execute or even remember it */
1220 o->op_type = OP_PREINC; /* pre-increment is faster */
1221 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1225 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1226 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1232 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1237 if (o->op_flags & OPf_STACKED)
1244 if (!(o->op_flags & OPf_KIDS))
1253 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1260 /* all requires must return a boolean value */
1261 o->op_flags &= ~OPf_WANT;
1266 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1267 if (!kPMOP->op_pmreplroot)
1268 deprecate("implicit split to @_");
1272 if (useless && ckWARN(WARN_VOID))
1273 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1278 Perl_listkids(pTHX_ OP *o)
1281 if (o && o->op_flags & OPf_KIDS) {
1282 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1289 Perl_list(pTHX_ OP *o)
1293 /* assumes no premature commitment */
1294 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1295 || o->op_type == OP_RETURN)
1300 if ((o->op_private & OPpTARGET_MY)
1301 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1303 return o; /* As if inside SASSIGN */
1306 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1308 switch (o->op_type) {
1311 list(cBINOPo->op_first);
1316 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1324 if (!(o->op_flags & OPf_KIDS))
1326 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1327 list(cBINOPo->op_first);
1328 return gen_constant_list(o);
1335 kid = cLISTOPo->op_first;
1337 while ((kid = kid->op_sibling)) {
1338 if (kid->op_sibling)
1343 WITH_THR(PL_curcop = &PL_compiling);
1347 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1348 if (kid->op_sibling)
1353 WITH_THR(PL_curcop = &PL_compiling);
1356 /* all requires must return a boolean value */
1357 o->op_flags &= ~OPf_WANT;
1364 Perl_scalarseq(pTHX_ OP *o)
1369 if (o->op_type == OP_LINESEQ ||
1370 o->op_type == OP_SCOPE ||
1371 o->op_type == OP_LEAVE ||
1372 o->op_type == OP_LEAVETRY)
1374 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1375 if (kid->op_sibling) {
1379 PL_curcop = &PL_compiling;
1381 o->op_flags &= ~OPf_PARENS;
1382 if (PL_hints & HINT_BLOCK_SCOPE)
1383 o->op_flags |= OPf_PARENS;
1386 o = newOP(OP_STUB, 0);
1391 S_modkids(pTHX_ OP *o, I32 type)
1394 if (o && o->op_flags & OPf_KIDS) {
1395 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1402 Perl_mod(pTHX_ OP *o, I32 type)
1407 if (!o || PL_error_count)
1410 if ((o->op_private & OPpTARGET_MY)
1411 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1416 switch (o->op_type) {
1421 if (!(o->op_private & (OPpCONST_ARYBASE)))
1423 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1424 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1428 SAVEI32(PL_compiling.cop_arybase);
1429 PL_compiling.cop_arybase = 0;
1431 else if (type == OP_REFGEN)
1434 Perl_croak(aTHX_ "That use of $[ is unsupported");
1437 if (o->op_flags & OPf_PARENS)
1441 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1442 !(o->op_flags & OPf_STACKED)) {
1443 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1444 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1445 assert(cUNOPo->op_first->op_type == OP_NULL);
1446 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1449 else if (o->op_private & OPpENTERSUB_NOMOD)
1451 else { /* lvalue subroutine call */
1452 o->op_private |= OPpLVAL_INTRO;
1453 PL_modcount = RETURN_UNLIMITED_NUMBER;
1454 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1455 /* Backward compatibility mode: */
1456 o->op_private |= OPpENTERSUB_INARGS;
1459 else { /* Compile-time error message: */
1460 OP *kid = cUNOPo->op_first;
1464 if (kid->op_type == OP_PUSHMARK)
1466 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1468 "panic: unexpected lvalue entersub "
1469 "args: type/targ %ld:%"UVuf,
1470 (long)kid->op_type, (UV)kid->op_targ);
1471 kid = kLISTOP->op_first;
1473 while (kid->op_sibling)
1474 kid = kid->op_sibling;
1475 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1477 if (kid->op_type == OP_METHOD_NAMED
1478 || kid->op_type == OP_METHOD)
1482 NewOp(1101, newop, 1, UNOP);
1483 newop->op_type = OP_RV2CV;
1484 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1485 newop->op_first = Nullop;
1486 newop->op_next = (OP*)newop;
1487 kid->op_sibling = (OP*)newop;
1488 newop->op_private |= OPpLVAL_INTRO;
1492 if (kid->op_type != OP_RV2CV)
1494 "panic: unexpected lvalue entersub "
1495 "entry via type/targ %ld:%"UVuf,
1496 (long)kid->op_type, (UV)kid->op_targ);
1497 kid->op_private |= OPpLVAL_INTRO;
1498 break; /* Postpone until runtime */
1502 kid = kUNOP->op_first;
1503 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1504 kid = kUNOP->op_first;
1505 if (kid->op_type == OP_NULL)
1507 "Unexpected constant lvalue entersub "
1508 "entry via type/targ %ld:%"UVuf,
1509 (long)kid->op_type, (UV)kid->op_targ);
1510 if (kid->op_type != OP_GV) {
1511 /* Restore RV2CV to check lvalueness */
1513 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1514 okid->op_next = kid->op_next;
1515 kid->op_next = okid;
1518 okid->op_next = Nullop;
1519 okid->op_type = OP_RV2CV;
1521 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1522 okid->op_private |= OPpLVAL_INTRO;
1526 cv = GvCV(kGVOP_gv);
1536 /* grep, foreach, subcalls, refgen */
1537 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1539 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1540 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1542 : (o->op_type == OP_ENTERSUB
1543 ? "non-lvalue subroutine call"
1545 type ? PL_op_desc[type] : "local"));
1559 case OP_RIGHT_SHIFT:
1568 if (!(o->op_flags & OPf_STACKED))
1574 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1580 if (!type && cUNOPo->op_first->op_type != OP_GV)
1581 Perl_croak(aTHX_ "Can't localize through a reference");
1582 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1583 PL_modcount = RETURN_UNLIMITED_NUMBER;
1584 return o; /* Treat \(@foo) like ordinary list. */
1588 if (scalar_mod_type(o, type))
1590 ref(cUNOPo->op_first, o->op_type);
1594 if (type == OP_LEAVESUBLV)
1595 o->op_private |= OPpMAYBE_LVSUB;
1601 PL_modcount = RETURN_UNLIMITED_NUMBER;
1604 if (!type && cUNOPo->op_first->op_type != OP_GV)
1605 Perl_croak(aTHX_ "Can't localize through a reference");
1606 ref(cUNOPo->op_first, o->op_type);
1610 PL_hints |= HINT_BLOCK_SCOPE;
1620 PL_modcount = RETURN_UNLIMITED_NUMBER;
1621 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1622 return o; /* Treat \(@foo) like ordinary list. */
1623 if (scalar_mod_type(o, type))
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1631 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1632 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1635 #ifdef USE_5005THREADS
1637 PL_modcount++; /* XXX ??? */
1639 #endif /* USE_5005THREADS */
1645 if (type != OP_SASSIGN)
1649 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1654 if (type == OP_LEAVESUBLV)
1655 o->op_private |= OPpMAYBE_LVSUB;
1657 pad_free(o->op_targ);
1658 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1659 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1660 if (o->op_flags & OPf_KIDS)
1661 mod(cBINOPo->op_first->op_sibling, type);
1666 ref(cBINOPo->op_first, o->op_type);
1667 if (type == OP_ENTERSUB &&
1668 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1669 o->op_private |= OPpLVAL_DEFER;
1670 if (type == OP_LEAVESUBLV)
1671 o->op_private |= OPpMAYBE_LVSUB;
1679 if (o->op_flags & OPf_KIDS)
1680 mod(cLISTOPo->op_last, type);
1684 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1686 else if (!(o->op_flags & OPf_KIDS))
1688 if (o->op_targ != OP_LIST) {
1689 mod(cBINOPo->op_first, type);
1694 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1699 if (type != OP_LEAVESUBLV)
1701 break; /* mod()ing was handled by ck_return() */
1704 /* [20011101.069] File test operators interpret OPf_REF to mean that
1705 their argument is a filehandle; thus \stat(".") should not set
1707 if (type == OP_REFGEN &&
1708 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1711 if (type != OP_LEAVESUBLV)
1712 o->op_flags |= OPf_MOD;
1714 if (type == OP_AASSIGN || type == OP_SASSIGN)
1715 o->op_flags |= OPf_SPECIAL|OPf_REF;
1717 o->op_private |= OPpLVAL_INTRO;
1718 o->op_flags &= ~OPf_SPECIAL;
1719 PL_hints |= HINT_BLOCK_SCOPE;
1721 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1722 && type != OP_LEAVESUBLV)
1723 o->op_flags |= OPf_REF;
1728 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1732 if (o->op_type == OP_RV2GV)
1756 case OP_RIGHT_SHIFT:
1775 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1777 switch (o->op_type) {
1785 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1798 Perl_refkids(pTHX_ OP *o, I32 type)
1801 if (o && o->op_flags & OPf_KIDS) {
1802 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1809 Perl_ref(pTHX_ OP *o, I32 type)
1813 if (!o || PL_error_count)
1816 switch (o->op_type) {
1818 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1819 !(o->op_flags & OPf_STACKED)) {
1820 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1821 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1822 assert(cUNOPo->op_first->op_type == OP_NULL);
1823 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1824 o->op_flags |= OPf_SPECIAL;
1829 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1833 if (type == OP_DEFINED)
1834 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1835 ref(cUNOPo->op_first, o->op_type);
1838 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1839 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1840 : type == OP_RV2HV ? OPpDEREF_HV
1842 o->op_flags |= OPf_MOD;
1847 o->op_flags |= OPf_MOD; /* XXX ??? */
1852 o->op_flags |= OPf_REF;
1855 if (type == OP_DEFINED)
1856 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1857 ref(cUNOPo->op_first, o->op_type);
1862 o->op_flags |= OPf_REF;
1867 if (!(o->op_flags & OPf_KIDS))
1869 ref(cBINOPo->op_first, type);
1873 ref(cBINOPo->op_first, o->op_type);
1874 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1875 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1876 : type == OP_RV2HV ? OPpDEREF_HV
1878 o->op_flags |= OPf_MOD;
1886 if (!(o->op_flags & OPf_KIDS))
1888 ref(cLISTOPo->op_last, type);
1898 S_dup_attrlist(pTHX_ OP *o)
1902 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1903 * where the first kid is OP_PUSHMARK and the remaining ones
1904 * are OP_CONST. We need to push the OP_CONST values.
1906 if (o->op_type == OP_CONST)
1907 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1909 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1910 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1911 if (o->op_type == OP_CONST)
1912 rop = append_elem(OP_LIST, rop,
1913 newSVOP(OP_CONST, o->op_flags,
1914 SvREFCNT_inc(cSVOPo->op_sv)));
1921 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1925 /* fake up C<use attributes $pkg,$rv,@attrs> */
1926 ENTER; /* need to protect against side-effects of 'use' */
1929 stashsv = newSVpv(HvNAME(stash), 0);
1931 stashsv = &PL_sv_no;
1933 #define ATTRSMODULE "attributes"
1934 #define ATTRSMODULE_PM "attributes.pm"
1938 /* Don't force the C<use> if we don't need it. */
1939 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1940 sizeof(ATTRSMODULE_PM)-1, 0);
1941 if (svp && *svp != &PL_sv_undef)
1942 ; /* already in %INC */
1944 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1945 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1949 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1950 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1952 prepend_elem(OP_LIST,
1953 newSVOP(OP_CONST, 0, stashsv),
1954 prepend_elem(OP_LIST,
1955 newSVOP(OP_CONST, 0,
1957 dup_attrlist(attrs))));
1963 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1965 OP *pack, *imop, *arg;
1971 assert(target->op_type == OP_PADSV ||
1972 target->op_type == OP_PADHV ||
1973 target->op_type == OP_PADAV);
1975 /* Ensure that attributes.pm is loaded. */
1976 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1978 /* Need package name for method call. */
1979 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1981 /* Build up the real arg-list. */
1983 stashsv = newSVpv(HvNAME(stash), 0);
1985 stashsv = &PL_sv_no;
1986 arg = newOP(OP_PADSV, 0);
1987 arg->op_targ = target->op_targ;
1988 arg = prepend_elem(OP_LIST,
1989 newSVOP(OP_CONST, 0, stashsv),
1990 prepend_elem(OP_LIST,
1991 newUNOP(OP_REFGEN, 0,
1992 mod(arg, OP_REFGEN)),
1993 dup_attrlist(attrs)));
1995 /* Fake up a method call to import */
1996 meth = newSVpvn("import", 6);
1997 (void)SvUPGRADE(meth, SVt_PVIV);
1998 (void)SvIOK_on(meth);
1999 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2000 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2001 append_elem(OP_LIST,
2002 prepend_elem(OP_LIST, pack, list(arg)),
2003 newSVOP(OP_METHOD_NAMED, 0, meth)));
2004 imop->op_private |= OPpENTERSUB_NOMOD;
2006 /* Combine the ops. */
2007 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2011 =notfor apidoc apply_attrs_string
2013 Attempts to apply a list of attributes specified by the C<attrstr> and
2014 C<len> arguments to the subroutine identified by the C<cv> argument which
2015 is expected to be associated with the package identified by the C<stashpv>
2016 argument (see L<attributes>). It gets this wrong, though, in that it
2017 does not correctly identify the boundaries of the individual attribute
2018 specifications within C<attrstr>. This is not really intended for the
2019 public API, but has to be listed here for systems such as AIX which
2020 need an explicit export list for symbols. (It's called from XS code
2021 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2022 to respect attribute syntax properly would be welcome.
2028 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2029 char *attrstr, STRLEN len)
2034 len = strlen(attrstr);
2038 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2040 char *sstr = attrstr;
2041 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2042 attrs = append_elem(OP_LIST, attrs,
2043 newSVOP(OP_CONST, 0,
2044 newSVpvn(sstr, attrstr-sstr)));
2048 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2049 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2050 Nullsv, prepend_elem(OP_LIST,
2051 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2052 prepend_elem(OP_LIST,
2053 newSVOP(OP_CONST, 0,
2059 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2064 if (!o || PL_error_count)
2068 if (type == OP_LIST) {
2069 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2070 my_kid(kid, attrs, imopsp);
2071 } else if (type == OP_UNDEF) {
2073 } else if (type == OP_RV2SV || /* "our" declaration */
2075 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2076 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2077 yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
2080 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2082 PL_in_my_stash = Nullhv;
2083 apply_attrs(GvSTASH(gv),
2084 (type == OP_RV2SV ? GvSV(gv) :
2085 type == OP_RV2AV ? (SV*)GvAV(gv) :
2086 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2089 o->op_private |= OPpOUR_INTRO;
2092 else if (type != OP_PADSV &&
2095 type != OP_PUSHMARK)
2097 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2099 PL_in_my == KEY_our ? "our" : "my"));
2102 else if (attrs && type != OP_PUSHMARK) {
2107 PL_in_my_stash = Nullhv;
2109 /* check for C<my Dog $spot> when deciding package */
2110 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2111 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2112 stash = SvSTASH(*namesvp);
2114 stash = PL_curstash;
2115 apply_attrs_my(stash, o, attrs, imopsp);
2117 o->op_flags |= OPf_MOD;
2118 o->op_private |= OPpLVAL_INTRO;
2123 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2126 int maybe_scalar = 0;
2128 if (o->op_flags & OPf_PARENS)
2134 o = my_kid(o, attrs, &rops);
2136 if (maybe_scalar && o->op_type == OP_PADSV) {
2137 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2138 o->op_private |= OPpLVAL_INTRO;
2141 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2144 PL_in_my_stash = Nullhv;
2149 Perl_my(pTHX_ OP *o)
2151 return my_attrs(o, Nullop);
2155 Perl_sawparens(pTHX_ OP *o)
2158 o->op_flags |= OPf_PARENS;
2163 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2167 if (ckWARN(WARN_MISC) &&
2168 (left->op_type == OP_RV2AV ||
2169 left->op_type == OP_RV2HV ||
2170 left->op_type == OP_PADAV ||
2171 left->op_type == OP_PADHV)) {
2172 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2173 right->op_type == OP_TRANS)
2174 ? right->op_type : OP_MATCH];
2175 const char *sample = ((left->op_type == OP_RV2AV ||
2176 left->op_type == OP_PADAV)
2177 ? "@array" : "%hash");
2178 Perl_warner(aTHX_ WARN_MISC,
2179 "Applying %s to %s will act on scalar(%s)",
2180 desc, sample, sample);
2183 if (right->op_type == OP_CONST &&
2184 cSVOPx(right)->op_private & OPpCONST_BARE &&
2185 cSVOPx(right)->op_private & OPpCONST_STRICT)
2187 no_bareword_allowed(right);
2190 if (!(right->op_flags & OPf_STACKED) &&
2191 (right->op_type == OP_MATCH ||
2192 right->op_type == OP_SUBST ||
2193 right->op_type == OP_TRANS)) {
2194 right->op_flags |= OPf_STACKED;
2195 if (right->op_type != OP_MATCH &&
2196 ! (right->op_type == OP_TRANS &&
2197 right->op_private & OPpTRANS_IDENTICAL))
2198 left = mod(left, right->op_type);
2199 if (right->op_type == OP_TRANS)
2200 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2202 o = prepend_elem(right->op_type, scalar(left), right);
2204 return newUNOP(OP_NOT, 0, scalar(o));
2208 return bind_match(type, left,
2209 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2213 Perl_invert(pTHX_ OP *o)
2217 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2218 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2222 Perl_scope(pTHX_ OP *o)
2225 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2226 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2227 o->op_type = OP_LEAVE;
2228 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2231 if (o->op_type == OP_LINESEQ) {
2233 o->op_type = OP_SCOPE;
2234 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2235 kid = ((LISTOP*)o)->op_first;
2236 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2240 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2247 Perl_save_hints(pTHX)
2250 SAVESPTR(GvHV(PL_hintgv));
2251 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2252 SAVEFREESV(GvHV(PL_hintgv));
2256 Perl_block_start(pTHX_ int full)
2258 int retval = PL_savestack_ix;
2260 SAVEI32(PL_comppad_name_floor);
2261 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2263 PL_comppad_name_fill = PL_comppad_name_floor;
2264 if (PL_comppad_name_floor < 0)
2265 PL_comppad_name_floor = 0;
2266 SAVEI32(PL_min_intro_pending);
2267 SAVEI32(PL_max_intro_pending);
2268 PL_min_intro_pending = 0;
2269 SAVEI32(PL_comppad_name_fill);
2270 SAVEI32(PL_padix_floor);
2271 PL_padix_floor = PL_padix;
2272 PL_pad_reset_pending = FALSE;
2274 PL_hints &= ~HINT_BLOCK_SCOPE;
2275 SAVESPTR(PL_compiling.cop_warnings);
2276 if (! specialWARN(PL_compiling.cop_warnings)) {
2277 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2278 SAVEFREESV(PL_compiling.cop_warnings) ;
2280 SAVESPTR(PL_compiling.cop_io);
2281 if (! specialCopIO(PL_compiling.cop_io)) {
2282 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2283 SAVEFREESV(PL_compiling.cop_io) ;
2289 Perl_block_end(pTHX_ I32 floor, OP *seq)
2291 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2292 line_t copline = PL_copline;
2293 /* there should be a nextstate in every block */
2294 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2295 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2297 PL_pad_reset_pending = FALSE;
2298 PL_compiling.op_private = PL_hints;
2300 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2301 pad_leavemy(PL_comppad_name_fill);
2309 #ifdef USE_5005THREADS
2310 OP *o = newOP(OP_THREADSV, 0);
2311 o->op_targ = find_threadsv("_");
2314 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2315 #endif /* USE_5005THREADS */
2319 Perl_newPROG(pTHX_ OP *o)
2324 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2325 ((PL_in_eval & EVAL_KEEPERR)
2326 ? OPf_SPECIAL : 0), o);
2327 PL_eval_start = linklist(PL_eval_root);
2328 PL_eval_root->op_private |= OPpREFCOUNTED;
2329 OpREFCNT_set(PL_eval_root, 1);
2330 PL_eval_root->op_next = 0;
2331 CALL_PEEP(PL_eval_start);
2336 PL_main_root = scope(sawparens(scalarvoid(o)));
2337 PL_curcop = &PL_compiling;
2338 PL_main_start = LINKLIST(PL_main_root);
2339 PL_main_root->op_private |= OPpREFCOUNTED;
2340 OpREFCNT_set(PL_main_root, 1);
2341 PL_main_root->op_next = 0;
2342 CALL_PEEP(PL_main_start);
2345 /* Register with debugger */
2347 CV *cv = get_cv("DB::postponed", FALSE);
2351 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2353 call_sv((SV*)cv, G_DISCARD);
2360 Perl_localize(pTHX_ OP *o, I32 lex)
2362 if (o->op_flags & OPf_PARENS)
2365 if (ckWARN(WARN_PARENTHESIS)
2366 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2368 char *s = PL_bufptr;
2370 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2373 if (*s == ';' || *s == '=')
2374 Perl_warner(aTHX_ WARN_PARENTHESIS,
2375 "Parentheses missing around \"%s\" list",
2376 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2382 o = mod(o, OP_NULL); /* a bit kludgey */
2384 PL_in_my_stash = Nullhv;
2389 Perl_jmaybe(pTHX_ OP *o)
2391 if (o->op_type == OP_LIST) {
2393 #ifdef USE_5005THREADS
2394 o2 = newOP(OP_THREADSV, 0);
2395 o2->op_targ = find_threadsv(";");
2397 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2398 #endif /* USE_5005THREADS */
2399 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2405 Perl_fold_constants(pTHX_ register OP *o)
2408 I32 type = o->op_type;
2411 if (PL_opargs[type] & OA_RETSCALAR)
2413 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2414 o->op_targ = pad_alloc(type, SVs_PADTMP);
2416 /* integerize op, unless it happens to be C<-foo>.
2417 * XXX should pp_i_negate() do magic string negation instead? */
2418 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2419 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2420 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2422 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2425 if (!(PL_opargs[type] & OA_FOLDCONST))
2430 /* XXX might want a ck_negate() for this */
2431 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2443 /* XXX what about the numeric ops? */
2444 if (PL_hints & HINT_LOCALE)
2449 goto nope; /* Don't try to run w/ errors */
2451 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2452 if ((curop->op_type != OP_CONST ||
2453 (curop->op_private & OPpCONST_BARE)) &&
2454 curop->op_type != OP_LIST &&
2455 curop->op_type != OP_SCALAR &&
2456 curop->op_type != OP_NULL &&
2457 curop->op_type != OP_PUSHMARK)
2463 curop = LINKLIST(o);
2467 sv = *(PL_stack_sp--);
2468 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2469 pad_swipe(o->op_targ);
2470 else if (SvTEMP(sv)) { /* grab mortal temp? */
2471 (void)SvREFCNT_inc(sv);
2475 if (type == OP_RV2GV)
2476 return newGVOP(OP_GV, 0, (GV*)sv);
2478 /* try to smush double to int, but don't smush -2.0 to -2 */
2479 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2482 #ifdef PERL_PRESERVE_IVUV
2483 /* Only bother to attempt to fold to IV if
2484 most operators will benefit */
2488 return newSVOP(OP_CONST, 0, sv);
2492 if (!(PL_opargs[type] & OA_OTHERINT))
2495 if (!(PL_hints & HINT_INTEGER)) {
2496 if (type == OP_MODULO
2497 || type == OP_DIVIDE
2498 || !(o->op_flags & OPf_KIDS))
2503 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2504 if (curop->op_type == OP_CONST) {
2505 if (SvIOK(((SVOP*)curop)->op_sv))
2509 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2513 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2520 Perl_gen_constant_list(pTHX_ register OP *o)
2523 I32 oldtmps_floor = PL_tmps_floor;
2527 return o; /* Don't attempt to run with errors */
2529 PL_op = curop = LINKLIST(o);
2536 PL_tmps_floor = oldtmps_floor;
2538 o->op_type = OP_RV2AV;
2539 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2540 curop = ((UNOP*)o)->op_first;
2541 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2548 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2550 if (!o || o->op_type != OP_LIST)
2551 o = newLISTOP(OP_LIST, 0, o, Nullop);
2553 o->op_flags &= ~OPf_WANT;
2555 if (!(PL_opargs[type] & OA_MARK))
2556 op_null(cLISTOPo->op_first);
2559 o->op_ppaddr = PL_ppaddr[type];
2560 o->op_flags |= flags;
2562 o = CHECKOP(type, o);
2563 if (o->op_type != type)
2566 return fold_constants(o);
2569 /* List constructors */
2572 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2580 if (first->op_type != type
2581 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2583 return newLISTOP(type, 0, first, last);
2586 if (first->op_flags & OPf_KIDS)
2587 ((LISTOP*)first)->op_last->op_sibling = last;
2589 first->op_flags |= OPf_KIDS;
2590 ((LISTOP*)first)->op_first = last;
2592 ((LISTOP*)first)->op_last = last;
2597 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2605 if (first->op_type != type)
2606 return prepend_elem(type, (OP*)first, (OP*)last);
2608 if (last->op_type != type)
2609 return append_elem(type, (OP*)first, (OP*)last);
2611 first->op_last->op_sibling = last->op_first;
2612 first->op_last = last->op_last;
2613 first->op_flags |= (last->op_flags & OPf_KIDS);
2621 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2629 if (last->op_type == type) {
2630 if (type == OP_LIST) { /* already a PUSHMARK there */
2631 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2632 ((LISTOP*)last)->op_first->op_sibling = first;
2633 if (!(first->op_flags & OPf_PARENS))
2634 last->op_flags &= ~OPf_PARENS;
2637 if (!(last->op_flags & OPf_KIDS)) {
2638 ((LISTOP*)last)->op_last = first;
2639 last->op_flags |= OPf_KIDS;
2641 first->op_sibling = ((LISTOP*)last)->op_first;
2642 ((LISTOP*)last)->op_first = first;
2644 last->op_flags |= OPf_KIDS;
2648 return newLISTOP(type, 0, first, last);
2654 Perl_newNULLLIST(pTHX)
2656 return newOP(OP_STUB, 0);
2660 Perl_force_list(pTHX_ OP *o)
2662 if (!o || o->op_type != OP_LIST)
2663 o = newLISTOP(OP_LIST, 0, o, Nullop);
2669 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2673 NewOp(1101, listop, 1, LISTOP);
2675 listop->op_type = type;
2676 listop->op_ppaddr = PL_ppaddr[type];
2679 listop->op_flags = flags;
2683 else if (!first && last)
2686 first->op_sibling = last;
2687 listop->op_first = first;
2688 listop->op_last = last;
2689 if (type == OP_LIST) {
2691 pushop = newOP(OP_PUSHMARK, 0);
2692 pushop->op_sibling = first;
2693 listop->op_first = pushop;
2694 listop->op_flags |= OPf_KIDS;
2696 listop->op_last = pushop;
2703 Perl_newOP(pTHX_ I32 type, I32 flags)
2706 NewOp(1101, o, 1, OP);
2708 o->op_ppaddr = PL_ppaddr[type];
2709 o->op_flags = flags;
2712 o->op_private = 0 + (flags >> 8);
2713 if (PL_opargs[type] & OA_RETSCALAR)
2715 if (PL_opargs[type] & OA_TARGET)
2716 o->op_targ = pad_alloc(type, SVs_PADTMP);
2717 return CHECKOP(type, o);
2721 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2726 first = newOP(OP_STUB, 0);
2727 if (PL_opargs[type] & OA_MARK)
2728 first = force_list(first);
2730 NewOp(1101, unop, 1, UNOP);
2731 unop->op_type = type;
2732 unop->op_ppaddr = PL_ppaddr[type];
2733 unop->op_first = first;
2734 unop->op_flags = flags | OPf_KIDS;
2735 unop->op_private = 1 | (flags >> 8);
2736 unop = (UNOP*) CHECKOP(type, unop);
2740 return fold_constants((OP *) unop);
2744 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2747 NewOp(1101, binop, 1, BINOP);
2750 first = newOP(OP_NULL, 0);
2752 binop->op_type = type;
2753 binop->op_ppaddr = PL_ppaddr[type];
2754 binop->op_first = first;
2755 binop->op_flags = flags | OPf_KIDS;
2758 binop->op_private = 1 | (flags >> 8);
2761 binop->op_private = 2 | (flags >> 8);
2762 first->op_sibling = last;
2765 binop = (BINOP*)CHECKOP(type, binop);
2766 if (binop->op_next || binop->op_type != type)
2769 binop->op_last = binop->op_first->op_sibling;
2771 return fold_constants((OP *)binop);
2775 uvcompare(const void *a, const void *b)
2777 if (*((UV *)a) < (*(UV *)b))
2779 if (*((UV *)a) > (*(UV *)b))
2781 if (*((UV *)a+1) < (*(UV *)b+1))
2783 if (*((UV *)a+1) > (*(UV *)b+1))
2789 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2791 SV *tstr = ((SVOP*)expr)->op_sv;
2792 SV *rstr = ((SVOP*)repl)->op_sv;
2795 U8 *t = (U8*)SvPV(tstr, tlen);
2796 U8 *r = (U8*)SvPV(rstr, rlen);
2803 register short *tbl;
2805 PL_hints |= HINT_BLOCK_SCOPE;
2806 complement = o->op_private & OPpTRANS_COMPLEMENT;
2807 del = o->op_private & OPpTRANS_DELETE;
2808 squash = o->op_private & OPpTRANS_SQUASH;
2811 o->op_private |= OPpTRANS_FROM_UTF;
2814 o->op_private |= OPpTRANS_TO_UTF;
2816 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2817 SV* listsv = newSVpvn("# comment\n",10);
2819 U8* tend = t + tlen;
2820 U8* rend = r + rlen;
2834 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2835 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2841 tsave = t = bytes_to_utf8(t, &len);
2844 if (!to_utf && rlen) {
2846 rsave = r = bytes_to_utf8(r, &len);
2850 /* There are several snags with this code on EBCDIC:
2851 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2852 2. scan_const() in toke.c has encoded chars in native encoding which makes
2853 ranges at least in EBCDIC 0..255 range the bottom odd.
2857 U8 tmpbuf[UTF8_MAXLEN+1];
2860 New(1109, cp, 2*tlen, UV);
2862 transv = newSVpvn("",0);
2864 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2866 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2868 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2872 cp[2*i+1] = cp[2*i];
2876 qsort(cp, i, 2*sizeof(UV), uvcompare);
2877 for (j = 0; j < i; j++) {
2879 diff = val - nextmin;
2881 t = uvuni_to_utf8(tmpbuf,nextmin);
2882 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2884 U8 range_mark = UTF_TO_NATIVE(0xff);
2885 t = uvuni_to_utf8(tmpbuf, val - 1);
2886 sv_catpvn(transv, (char *)&range_mark, 1);
2887 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2894 t = uvuni_to_utf8(tmpbuf,nextmin);
2895 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2897 U8 range_mark = UTF_TO_NATIVE(0xff);
2898 sv_catpvn(transv, (char *)&range_mark, 1);
2900 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2901 UNICODE_ALLOW_SUPER);
2902 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2903 t = (U8*)SvPVX(transv);
2904 tlen = SvCUR(transv);
2908 else if (!rlen && !del) {
2909 r = t; rlen = tlen; rend = tend;
2912 if ((!rlen && !del) || t == r ||
2913 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2915 o->op_private |= OPpTRANS_IDENTICAL;
2919 while (t < tend || tfirst <= tlast) {
2920 /* see if we need more "t" chars */
2921 if (tfirst > tlast) {
2922 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2924 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2926 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2933 /* now see if we need more "r" chars */
2934 if (rfirst > rlast) {
2936 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2938 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2940 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2949 rfirst = rlast = 0xffffffff;
2953 /* now see which range will peter our first, if either. */
2954 tdiff = tlast - tfirst;
2955 rdiff = rlast - rfirst;
2962 if (rfirst == 0xffffffff) {
2963 diff = tdiff; /* oops, pretend rdiff is infinite */
2965 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2966 (long)tfirst, (long)tlast);
2968 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2972 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2973 (long)tfirst, (long)(tfirst + diff),
2976 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2977 (long)tfirst, (long)rfirst);
2979 if (rfirst + diff > max)
2980 max = rfirst + diff;
2982 grows = (tfirst < rfirst &&
2983 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2995 else if (max > 0xff)
3000 Safefree(cPVOPo->op_pv);
3001 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3002 SvREFCNT_dec(listsv);
3004 SvREFCNT_dec(transv);
3006 if (!del && havefinal && rlen)
3007 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3008 newSVuv((UV)final), 0);
3011 o->op_private |= OPpTRANS_GROWS;
3023 tbl = (short*)cPVOPo->op_pv;
3025 Zero(tbl, 256, short);
3026 for (i = 0; i < tlen; i++)
3028 for (i = 0, j = 0; i < 256; i++) {
3039 if (i < 128 && r[j] >= 128)
3049 o->op_private |= OPpTRANS_IDENTICAL;
3054 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3055 tbl[0x100] = rlen - j;
3056 for (i=0; i < rlen - j; i++)
3057 tbl[0x101+i] = r[j+i];
3061 if (!rlen && !del) {
3064 o->op_private |= OPpTRANS_IDENTICAL;
3066 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3067 o->op_private |= OPpTRANS_IDENTICAL;
3069 for (i = 0; i < 256; i++)
3071 for (i = 0, j = 0; i < tlen; i++,j++) {
3074 if (tbl[t[i]] == -1)
3080 if (tbl[t[i]] == -1) {
3081 if (t[i] < 128 && r[j] >= 128)
3088 o->op_private |= OPpTRANS_GROWS;
3096 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3100 NewOp(1101, pmop, 1, PMOP);
3101 pmop->op_type = type;
3102 pmop->op_ppaddr = PL_ppaddr[type];
3103 pmop->op_flags = flags;
3104 pmop->op_private = 0 | (flags >> 8);
3106 if (PL_hints & HINT_RE_TAINT)
3107 pmop->op_pmpermflags |= PMf_RETAINT;
3108 if (PL_hints & HINT_LOCALE)
3109 pmop->op_pmpermflags |= PMf_LOCALE;
3110 pmop->op_pmflags = pmop->op_pmpermflags;
3115 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3116 repointer = av_pop((AV*)PL_regex_pad[0]);
3117 pmop->op_pmoffset = SvIV(repointer);
3118 SvREPADTMP_off(repointer);
3119 sv_setiv(repointer,0);
3121 repointer = newSViv(0);
3122 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3123 pmop->op_pmoffset = av_len(PL_regex_padav);
3124 PL_regex_pad = AvARRAY(PL_regex_padav);
3129 /* link into pm list */
3130 if (type != OP_TRANS && PL_curstash) {
3131 pmop->op_pmnext = HvPMROOT(PL_curstash);
3132 HvPMROOT(PL_curstash) = pmop;
3133 PmopSTASH_set(pmop,PL_curstash);
3140 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3144 I32 repl_has_vars = 0;
3146 if (o->op_type == OP_TRANS)
3147 return pmtrans(o, expr, repl);
3149 PL_hints |= HINT_BLOCK_SCOPE;
3152 if (expr->op_type == OP_CONST) {
3154 SV *pat = ((SVOP*)expr)->op_sv;
3155 char *p = SvPV(pat, plen);
3156 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3157 sv_setpvn(pat, "\\s+", 3);
3158 p = SvPV(pat, plen);
3159 pm->op_pmflags |= PMf_SKIPWHITE;
3162 pm->op_pmdynflags |= PMdf_UTF8;
3163 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3164 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3165 pm->op_pmflags |= PMf_WHITE;
3169 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3170 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3172 : OP_REGCMAYBE),0,expr);
3174 NewOp(1101, rcop, 1, LOGOP);
3175 rcop->op_type = OP_REGCOMP;
3176 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3177 rcop->op_first = scalar(expr);
3178 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3179 ? (OPf_SPECIAL | OPf_KIDS)
3181 rcop->op_private = 1;
3184 /* establish postfix order */
3185 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3187 rcop->op_next = expr;
3188 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3191 rcop->op_next = LINKLIST(expr);
3192 expr->op_next = (OP*)rcop;
3195 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3200 if (pm->op_pmflags & PMf_EVAL) {
3202 if (CopLINE(PL_curcop) < PL_multi_end)
3203 CopLINE_set(PL_curcop, PL_multi_end);
3205 #ifdef USE_5005THREADS
3206 else if (repl->op_type == OP_THREADSV
3207 && strchr("&`'123456789+",
3208 PL_threadsv_names[repl->op_targ]))
3212 #endif /* USE_5005THREADS */
3213 else if (repl->op_type == OP_CONST)
3217 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3218 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3219 #ifdef USE_5005THREADS
3220 if (curop->op_type == OP_THREADSV) {
3222 if (strchr("&`'123456789+", curop->op_private))
3226 if (curop->op_type == OP_GV) {
3227 GV *gv = cGVOPx_gv(curop);
3229 if (strchr("&`'123456789+", *GvENAME(gv)))
3232 #endif /* USE_5005THREADS */
3233 else if (curop->op_type == OP_RV2CV)
3235 else if (curop->op_type == OP_RV2SV ||
3236 curop->op_type == OP_RV2AV ||
3237 curop->op_type == OP_RV2HV ||
3238 curop->op_type == OP_RV2GV) {
3239 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3242 else if (curop->op_type == OP_PADSV ||
3243 curop->op_type == OP_PADAV ||
3244 curop->op_type == OP_PADHV ||
3245 curop->op_type == OP_PADANY) {
3248 else if (curop->op_type == OP_PUSHRE)
3249 ; /* Okay here, dangerous in newASSIGNOP */
3259 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3260 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3261 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3262 prepend_elem(o->op_type, scalar(repl), o);
3265 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3266 pm->op_pmflags |= PMf_MAYBE_CONST;
3267 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3269 NewOp(1101, rcop, 1, LOGOP);
3270 rcop->op_type = OP_SUBSTCONT;
3271 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3272 rcop->op_first = scalar(repl);
3273 rcop->op_flags |= OPf_KIDS;
3274 rcop->op_private = 1;
3277 /* establish postfix order */
3278 rcop->op_next = LINKLIST(repl);
3279 repl->op_next = (OP*)rcop;
3281 pm->op_pmreplroot = scalar((OP*)rcop);
3282 pm->op_pmreplstart = LINKLIST(rcop);
3291 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3294 NewOp(1101, svop, 1, SVOP);
3295 svop->op_type = type;
3296 svop->op_ppaddr = PL_ppaddr[type];
3298 svop->op_next = (OP*)svop;
3299 svop->op_flags = flags;
3300 if (PL_opargs[type] & OA_RETSCALAR)
3302 if (PL_opargs[type] & OA_TARGET)
3303 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3304 return CHECKOP(type, svop);
3308 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3311 NewOp(1101, padop, 1, PADOP);
3312 padop->op_type = type;
3313 padop->op_ppaddr = PL_ppaddr[type];
3314 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3315 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3316 PL_curpad[padop->op_padix] = sv;
3318 padop->op_next = (OP*)padop;
3319 padop->op_flags = flags;
3320 if (PL_opargs[type] & OA_RETSCALAR)
3322 if (PL_opargs[type] & OA_TARGET)
3323 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3324 return CHECKOP(type, padop);
3328 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3332 return newPADOP(type, flags, SvREFCNT_inc(gv));
3334 return newSVOP(type, flags, SvREFCNT_inc(gv));
3339 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3342 NewOp(1101, pvop, 1, PVOP);
3343 pvop->op_type = type;
3344 pvop->op_ppaddr = PL_ppaddr[type];
3346 pvop->op_next = (OP*)pvop;
3347 pvop->op_flags = flags;
3348 if (PL_opargs[type] & OA_RETSCALAR)
3350 if (PL_opargs[type] & OA_TARGET)
3351 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3352 return CHECKOP(type, pvop);
3356 Perl_package(pTHX_ OP *o)
3360 save_hptr(&PL_curstash);
3361 save_item(PL_curstname);
3366 name = SvPV(sv, len);
3367 PL_curstash = gv_stashpvn(name,len,TRUE);
3368 sv_setpvn(PL_curstname, name, len);
3372 deprecate("\"package\" with no arguments");
3373 sv_setpv(PL_curstname,"<none>");
3374 PL_curstash = Nullhv;
3376 PL_hints |= HINT_BLOCK_SCOPE;
3377 PL_copline = NOLINE;
3382 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3387 char *packname = Nullch;
3391 if (id->op_type != OP_CONST)
3392 Perl_croak(aTHX_ "Module name must be constant");
3396 if (version != Nullop) {
3397 SV *vesv = ((SVOP*)version)->op_sv;
3399 if (arg == Nullop && !SvNIOKp(vesv)) {
3406 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3407 Perl_croak(aTHX_ "Version number must be constant number");
3409 /* Make copy of id so we don't free it twice */
3410 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3412 /* Fake up a method call to VERSION */
3413 meth = newSVpvn("VERSION",7);
3414 sv_upgrade(meth, SVt_PVIV);
3415 (void)SvIOK_on(meth);
3416 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3417 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3418 append_elem(OP_LIST,
3419 prepend_elem(OP_LIST, pack, list(version)),
3420 newSVOP(OP_METHOD_NAMED, 0, meth)));
3424 /* Fake up an import/unimport */
3425 if (arg && arg->op_type == OP_STUB)
3426 imop = arg; /* no import on explicit () */
3427 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3428 imop = Nullop; /* use 5.0; */
3433 /* Make copy of id so we don't free it twice */
3434 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3436 /* Fake up a method call to import/unimport */
3437 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3438 (void)SvUPGRADE(meth, SVt_PVIV);
3439 (void)SvIOK_on(meth);
3440 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3441 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3442 append_elem(OP_LIST,
3443 prepend_elem(OP_LIST, pack, list(arg)),
3444 newSVOP(OP_METHOD_NAMED, 0, meth)));
3447 if (ckWARN(WARN_MISC) &&
3448 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3449 SvPOK(packsv = ((SVOP*)id)->op_sv))
3451 /* BEGIN will free the ops, so we need to make a copy */
3452 packlen = SvCUR(packsv);
3453 packname = savepvn(SvPVX(packsv), packlen);
3456 /* Fake up the BEGIN {}, which does its thing immediately. */
3458 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3461 append_elem(OP_LINESEQ,
3462 append_elem(OP_LINESEQ,
3463 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3464 newSTATEOP(0, Nullch, veop)),
3465 newSTATEOP(0, Nullch, imop) ));
3468 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3469 Perl_warner(aTHX_ WARN_MISC,
3470 "Package `%s' not found "
3471 "(did you use the incorrect case?)", packname);
3476 PL_hints |= HINT_BLOCK_SCOPE;
3477 PL_copline = NOLINE;
3482 =head1 Embedding Functions
3484 =for apidoc load_module
3486 Loads the module whose name is pointed to by the string part of name.
3487 Note that the actual module name, not its filename, should be given.
3488 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3489 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3490 (or 0 for no flags). ver, if specified, provides version semantics
3491 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3492 arguments can be used to specify arguments to the module's import()
3493 method, similar to C<use Foo::Bar VERSION LIST>.
3498 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3501 va_start(args, ver);
3502 vload_module(flags, name, ver, &args);
3506 #ifdef PERL_IMPLICIT_CONTEXT
3508 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3512 va_start(args, ver);
3513 vload_module(flags, name, ver, &args);
3519 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3521 OP *modname, *veop, *imop;
3523 modname = newSVOP(OP_CONST, 0, name);
3524 modname->op_private |= OPpCONST_BARE;
3526 veop = newSVOP(OP_CONST, 0, ver);
3530 if (flags & PERL_LOADMOD_NOIMPORT) {
3531 imop = sawparens(newNULLLIST());
3533 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3534 imop = va_arg(*args, OP*);
3539 sv = va_arg(*args, SV*);
3541 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3542 sv = va_arg(*args, SV*);
3546 line_t ocopline = PL_copline;
3547 int oexpect = PL_expect;
3549 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3550 veop, modname, imop);
3551 PL_expect = oexpect;
3552 PL_copline = ocopline;
3557 Perl_dofile(pTHX_ OP *term)
3562 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3563 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3564 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3566 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3567 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3568 append_elem(OP_LIST, term,
3569 scalar(newUNOP(OP_RV2CV, 0,
3574 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3580 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3582 return newBINOP(OP_LSLICE, flags,
3583 list(force_list(subscript)),
3584 list(force_list(listval)) );
3588 S_list_assignment(pTHX_ register OP *o)
3593 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3594 o = cUNOPo->op_first;
3596 if (o->op_type == OP_COND_EXPR) {
3597 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3598 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3603 yyerror("Assignment to both a list and a scalar");
3607 if (o->op_type == OP_LIST &&
3608 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3609 o->op_private & OPpLVAL_INTRO)
3612 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3613 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3614 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3617 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3620 if (o->op_type == OP_RV2SV)
3627 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3632 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3633 return newLOGOP(optype, 0,
3634 mod(scalar(left), optype),
3635 newUNOP(OP_SASSIGN, 0, scalar(right)));
3638 return newBINOP(optype, OPf_STACKED,
3639 mod(scalar(left), optype), scalar(right));
3643 if (list_assignment(left)) {
3647 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3648 left = mod(left, OP_AASSIGN);
3656 curop = list(force_list(left));
3657 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3658 o->op_private = 0 | (flags >> 8);
3659 for (curop = ((LISTOP*)curop)->op_first;
3660 curop; curop = curop->op_sibling)
3662 if (curop->op_type == OP_RV2HV &&
3663 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3664 o->op_private |= OPpASSIGN_HASH;
3668 if (!(left->op_private & OPpLVAL_INTRO)) {
3671 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3672 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3673 if (curop->op_type == OP_GV) {
3674 GV *gv = cGVOPx_gv(curop);
3675 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3677 SvCUR(gv) = PL_generation;
3679 else if (curop->op_type == OP_PADSV ||
3680 curop->op_type == OP_PADAV ||
3681 curop->op_type == OP_PADHV ||
3682 curop->op_type == OP_PADANY) {
3683 SV **svp = AvARRAY(PL_comppad_name);
3684 SV *sv = svp[curop->op_targ];
3685 if (SvCUR(sv) == PL_generation)
3687 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3689 else if (curop->op_type == OP_RV2CV)
3691 else if (curop->op_type == OP_RV2SV ||
3692 curop->op_type == OP_RV2AV ||
3693 curop->op_type == OP_RV2HV ||
3694 curop->op_type == OP_RV2GV) {
3695 if (lastop->op_type != OP_GV) /* funny deref? */
3698 else if (curop->op_type == OP_PUSHRE) {
3699 if (((PMOP*)curop)->op_pmreplroot) {
3701 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3703 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3705 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3707 SvCUR(gv) = PL_generation;
3716 o->op_private |= OPpASSIGN_COMMON;
3718 if (right && right->op_type == OP_SPLIT) {
3720 if ((tmpop = ((LISTOP*)right)->op_first) &&
3721 tmpop->op_type == OP_PUSHRE)
3723 PMOP *pm = (PMOP*)tmpop;
3724 if (left->op_type == OP_RV2AV &&
3725 !(left->op_private & OPpLVAL_INTRO) &&
3726 !(o->op_private & OPpASSIGN_COMMON) )
3728 tmpop = ((UNOP*)left)->op_first;
3729 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3731 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3732 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3734 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3735 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3737 pm->op_pmflags |= PMf_ONCE;
3738 tmpop = cUNOPo->op_first; /* to list (nulled) */
3739 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3740 tmpop->op_sibling = Nullop; /* don't free split */
3741 right->op_next = tmpop->op_next; /* fix starting loc */
3742 op_free(o); /* blow off assign */
3743 right->op_flags &= ~OPf_WANT;
3744 /* "I don't know and I don't care." */
3749 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3750 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3752 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3754 sv_setiv(sv, PL_modcount+1);
3762 right = newOP(OP_UNDEF, 0);
3763 if (right->op_type == OP_READLINE) {
3764 right->op_flags |= OPf_STACKED;
3765 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3768 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3769 o = newBINOP(OP_SASSIGN, flags,
3770 scalar(right), mod(scalar(left), OP_SASSIGN) );
3782 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3784 U32 seq = intro_my();
3787 NewOp(1101, cop, 1, COP);
3788 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3789 cop->op_type = OP_DBSTATE;
3790 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3793 cop->op_type = OP_NEXTSTATE;
3794 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3796 cop->op_flags = flags;
3797 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3799 cop->op_private |= NATIVE_HINTS;
3801 PL_compiling.op_private = cop->op_private;
3802 cop->op_next = (OP*)cop;
3805 cop->cop_label = label;
3806 PL_hints |= HINT_BLOCK_SCOPE;
3809 cop->cop_arybase = PL_curcop->cop_arybase;
3810 if (specialWARN(PL_curcop->cop_warnings))
3811 cop->cop_warnings = PL_curcop->cop_warnings ;
3813 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3814 if (specialCopIO(PL_curcop->cop_io))
3815 cop->cop_io = PL_curcop->cop_io;
3817 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3820 if (PL_copline == NOLINE)
3821 CopLINE_set(cop, CopLINE(PL_curcop));
3823 CopLINE_set(cop, PL_copline);
3824 PL_copline = NOLINE;
3827 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3829 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3831 CopSTASH_set(cop, PL_curstash);
3833 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3834 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3835 if (svp && *svp != &PL_sv_undef ) {
3836 (void)SvIOK_on(*svp);
3837 SvIVX(*svp) = PTR2IV(cop);
3841 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3844 /* "Introduce" my variables to visible status. */
3852 if (! PL_min_intro_pending)
3853 return PL_cop_seqmax;
3855 svp = AvARRAY(PL_comppad_name);
3856 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3857 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3858 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3859 SvNVX(sv) = (NV)PL_cop_seqmax;
3862 PL_min_intro_pending = 0;
3863 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3864 return PL_cop_seqmax++;
3868 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3870 return new_logop(type, flags, &first, &other);
3874 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3878 OP *first = *firstp;
3879 OP *other = *otherp;
3881 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3882 return newBINOP(type, flags, scalar(first), scalar(other));
3884 scalarboolean(first);
3885 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3886 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3887 if (type == OP_AND || type == OP_OR) {
3893 first = *firstp = cUNOPo->op_first;
3895 first->op_next = o->op_next;
3896 cUNOPo->op_first = Nullop;
3900 if (first->op_type == OP_CONST) {
3901 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3902 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3903 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3914 else if (first->op_type == OP_WANTARRAY) {
3920 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3921 OP *k1 = ((UNOP*)first)->op_first;
3922 OP *k2 = k1->op_sibling;
3924 switch (first->op_type)
3927 if (k2 && k2->op_type == OP_READLINE
3928 && (k2->op_flags & OPf_STACKED)
3929 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3931 warnop = k2->op_type;
3936 if (k1->op_type == OP_READDIR
3937 || k1->op_type == OP_GLOB
3938 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3939 || k1->op_type == OP_EACH)
3941 warnop = ((k1->op_type == OP_NULL)
3942 ? k1->op_targ : k1->op_type);
3947 line_t oldline = CopLINE(PL_curcop);
3948 CopLINE_set(PL_curcop, PL_copline);
3949 Perl_warner(aTHX_ WARN_MISC,
3950 "Value of %s%s can be \"0\"; test with defined()",
3952 ((warnop == OP_READLINE || warnop == OP_GLOB)
3953 ? " construct" : "() operator"));
3954 CopLINE_set(PL_curcop, oldline);
3961 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3962 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3964 NewOp(1101, logop, 1, LOGOP);
3966 logop->op_type = type;
3967 logop->op_ppaddr = PL_ppaddr[type];
3968 logop->op_first = first;
3969 logop->op_flags = flags | OPf_KIDS;
3970 logop->op_other = LINKLIST(other);
3971 logop->op_private = 1 | (flags >> 8);
3973 /* establish postfix order */
3974 logop->op_next = LINKLIST(first);
3975 first->op_next = (OP*)logop;
3976 first->op_sibling = other;
3978 o = newUNOP(OP_NULL, 0, (OP*)logop);
3985 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3992 return newLOGOP(OP_AND, 0, first, trueop);
3994 return newLOGOP(OP_OR, 0, first, falseop);
3996 scalarboolean(first);
3997 if (first->op_type == OP_CONST) {
3998 if (SvTRUE(((SVOP*)first)->op_sv)) {
4009 else if (first->op_type == OP_WANTARRAY) {
4013 NewOp(1101, logop, 1, LOGOP);
4014 logop->op_type = OP_COND_EXPR;
4015 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4016 logop->op_first = first;
4017 logop->op_flags = flags | OPf_KIDS;
4018 logop->op_private = 1 | (flags >> 8);
4019 logop->op_other = LINKLIST(trueop);
4020 logop->op_next = LINKLIST(falseop);
4023 /* establish postfix order */
4024 start = LINKLIST(first);
4025 first->op_next = (OP*)logop;
4027 first->op_sibling = trueop;
4028 trueop->op_sibling = falseop;
4029 o = newUNOP(OP_NULL, 0, (OP*)logop);
4031 trueop->op_next = falseop->op_next = o;
4038 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4046 NewOp(1101, range, 1, LOGOP);
4048 range->op_type = OP_RANGE;
4049 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4050 range->op_first = left;
4051 range->op_flags = OPf_KIDS;
4052 leftstart = LINKLIST(left);
4053 range->op_other = LINKLIST(right);
4054 range->op_private = 1 | (flags >> 8);
4056 left->op_sibling = right;
4058 range->op_next = (OP*)range;
4059 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4060 flop = newUNOP(OP_FLOP, 0, flip);
4061 o = newUNOP(OP_NULL, 0, flop);
4063 range->op_next = leftstart;
4065 left->op_next = flip;
4066 right->op_next = flop;
4068 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4069 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4070 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4071 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4073 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4074 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4077 if (!flip->op_private || !flop->op_private)
4078 linklist(o); /* blow off optimizer unless constant */
4084 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4088 int once = block && block->op_flags & OPf_SPECIAL &&
4089 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4092 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4093 return block; /* do {} while 0 does once */
4094 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4095 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4096 expr = newUNOP(OP_DEFINED, 0,
4097 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4098 } else if (expr->op_flags & OPf_KIDS) {
4099 OP *k1 = ((UNOP*)expr)->op_first;
4100 OP *k2 = (k1) ? k1->op_sibling : NULL;
4101 switch (expr->op_type) {
4103 if (k2 && k2->op_type == OP_READLINE
4104 && (k2->op_flags & OPf_STACKED)
4105 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4106 expr = newUNOP(OP_DEFINED, 0, expr);
4110 if (k1->op_type == OP_READDIR
4111 || k1->op_type == OP_GLOB
4112 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4113 || k1->op_type == OP_EACH)
4114 expr = newUNOP(OP_DEFINED, 0, expr);
4120 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4121 o = new_logop(OP_AND, 0, &expr, &listop);
4124 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4126 if (once && o != listop)
4127 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4130 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4132 o->op_flags |= flags;
4134 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4139 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4147 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4148 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4149 expr = newUNOP(OP_DEFINED, 0,
4150 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4151 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4152 OP *k1 = ((UNOP*)expr)->op_first;
4153 OP *k2 = (k1) ? k1->op_sibling : NULL;
4154 switch (expr->op_type) {
4156 if (k2 && k2->op_type == OP_READLINE
4157 && (k2->op_flags & OPf_STACKED)
4158 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4159 expr = newUNOP(OP_DEFINED, 0, expr);
4163 if (k1->op_type == OP_READDIR
4164 || k1->op_type == OP_GLOB
4165 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4166 || k1->op_type == OP_EACH)
4167 expr = newUNOP(OP_DEFINED, 0, expr);
4173 block = newOP(OP_NULL, 0);
4175 block = scope(block);
4179 next = LINKLIST(cont);
4182 OP *unstack = newOP(OP_UNSTACK, 0);
4185 cont = append_elem(OP_LINESEQ, cont, unstack);
4186 if ((line_t)whileline != NOLINE) {
4187 PL_copline = whileline;
4188 cont = append_elem(OP_LINESEQ, cont,
4189 newSTATEOP(0, Nullch, Nullop));
4193 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4194 redo = LINKLIST(listop);
4197 PL_copline = whileline;
4199 o = new_logop(OP_AND, 0, &expr, &listop);
4200 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4201 op_free(expr); /* oops, it's a while (0) */
4203 return Nullop; /* listop already freed by new_logop */
4206 ((LISTOP*)listop)->op_last->op_next =
4207 (o == listop ? redo : LINKLIST(o));
4213 NewOp(1101,loop,1,LOOP);
4214 loop->op_type = OP_ENTERLOOP;
4215 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4216 loop->op_private = 0;
4217 loop->op_next = (OP*)loop;
4220 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4222 loop->op_redoop = redo;
4223 loop->op_lastop = o;
4224 o->op_private |= loopflags;
4227 loop->op_nextop = next;
4229 loop->op_nextop = o;
4231 o->op_flags |= flags;
4232 o->op_private |= (flags >> 8);
4237 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4245 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4246 sv->op_type = OP_RV2GV;
4247 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4249 else if (sv->op_type == OP_PADSV) { /* private variable */
4250 padoff = sv->op_targ;
4255 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4256 padoff = sv->op_targ;
4258 iterflags |= OPf_SPECIAL;
4263 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4266 #ifdef USE_5005THREADS
4267 padoff = find_threadsv("_");
4268 iterflags |= OPf_SPECIAL;
4270 sv = newGVOP(OP_GV, 0, PL_defgv);
4273 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4274 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4275 iterflags |= OPf_STACKED;
4277 else if (expr->op_type == OP_NULL &&
4278 (expr->op_flags & OPf_KIDS) &&
4279 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4281 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4282 * set the STACKED flag to indicate that these values are to be
4283 * treated as min/max values by 'pp_iterinit'.
4285 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4286 LOGOP* range = (LOGOP*) flip->op_first;
4287 OP* left = range->op_first;
4288 OP* right = left->op_sibling;
4291 range->op_flags &= ~OPf_KIDS;
4292 range->op_first = Nullop;
4294 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4295 listop->op_first->op_next = range->op_next;
4296 left->op_next = range->op_other;
4297 right->op_next = (OP*)listop;
4298 listop->op_next = listop->op_first;
4301 expr = (OP*)(listop);
4303 iterflags |= OPf_STACKED;
4306 expr = mod(force_list(expr), OP_GREPSTART);
4310 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4311 append_elem(OP_LIST, expr, scalar(sv))));
4312 assert(!loop->op_next);
4313 #ifdef PL_OP_SLAB_ALLOC
4316 NewOp(1234,tmp,1,LOOP);
4317 Copy(loop,tmp,1,LOOP);
4322 Renew(loop, 1, LOOP);
4324 loop->op_targ = padoff;
4325 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4326 PL_copline = forline;
4327 return newSTATEOP(0, label, wop);
4331 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4336 if (type != OP_GOTO || label->op_type == OP_CONST) {
4337 /* "last()" means "last" */
4338 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4339 o = newOP(type, OPf_SPECIAL);
4341 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4342 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4348 if (label->op_type == OP_ENTERSUB)
4349 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4350 o = newUNOP(type, OPf_STACKED, label);
4352 PL_hints |= HINT_BLOCK_SCOPE;
4357 Perl_cv_undef(pTHX_ CV *cv)
4359 #ifdef USE_5005THREADS
4361 MUTEX_DESTROY(CvMUTEXP(cv));
4362 Safefree(CvMUTEXP(cv));
4365 #endif /* USE_5005THREADS */
4368 if (CvFILE(cv) && !CvXSUB(cv)) {
4369 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4370 Safefree(CvFILE(cv));
4375 if (!CvXSUB(cv) && CvROOT(cv)) {
4376 #ifdef USE_5005THREADS
4377 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4378 Perl_croak(aTHX_ "Can't undef active subroutine");
4381 Perl_croak(aTHX_ "Can't undef active subroutine");
4382 #endif /* USE_5005THREADS */
4385 SAVEVPTR(PL_curpad);
4388 op_free(CvROOT(cv));
4389 CvROOT(cv) = Nullop;
4392 SvPOK_off((SV*)cv); /* forget prototype */
4394 /* Since closure prototypes have the same lifetime as the containing
4395 * CV, they don't hold a refcount on the outside CV. This avoids
4396 * the refcount loop between the outer CV (which keeps a refcount to
4397 * the closure prototype in the pad entry for pp_anoncode()) and the
4398 * closure prototype, and the ensuing memory leak. --GSAR */
4399 if (!CvANON(cv) || CvCLONED(cv))
4400 SvREFCNT_dec(CvOUTSIDE(cv));
4401 CvOUTSIDE(cv) = Nullcv;
4403 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4406 if (CvPADLIST(cv)) {
4407 /* may be during global destruction */
4408 if (SvREFCNT(CvPADLIST(cv))) {
4409 I32 i = AvFILLp(CvPADLIST(cv));
4411 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4412 SV* sv = svp ? *svp : Nullsv;
4415 if (sv == (SV*)PL_comppad_name)
4416 PL_comppad_name = Nullav;
4417 else if (sv == (SV*)PL_comppad) {
4418 PL_comppad = Nullav;
4419 PL_curpad = Null(SV**);
4423 SvREFCNT_dec((SV*)CvPADLIST(cv));
4425 CvPADLIST(cv) = Nullav;
4433 #ifdef DEBUG_CLOSURES
4435 S_cv_dump(pTHX_ CV *cv)
4438 CV *outside = CvOUTSIDE(cv);
4439 AV* padlist = CvPADLIST(cv);
4446 PerlIO_printf(Perl_debug_log,
4447 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4449 (CvANON(cv) ? "ANON"
4450 : (cv == PL_main_cv) ? "MAIN"
4451 : CvUNIQUE(cv) ? "UNIQUE"
4452 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4455 : CvANON(outside) ? "ANON"
4456 : (outside == PL_main_cv) ? "MAIN"
4457 : CvUNIQUE(outside) ? "UNIQUE"
4458 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4463 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4464 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4465 pname = AvARRAY(pad_name);
4466 ppad = AvARRAY(pad);
4468 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4469 if (SvPOK(pname[ix]))
4470 PerlIO_printf(Perl_debug_log,
4471 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4472 (int)ix, PTR2UV(ppad[ix]),
4473 SvFAKE(pname[ix]) ? "FAKE " : "",
4475 (IV)I_32(SvNVX(pname[ix])),
4478 #endif /* DEBUGGING */
4480 #endif /* DEBUG_CLOSURES */
4483 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4487 AV* protopadlist = CvPADLIST(proto);
4488 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4489 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4490 SV** pname = AvARRAY(protopad_name);
4491 SV** ppad = AvARRAY(protopad);
4492 I32 fname = AvFILLp(protopad_name);
4493 I32 fpad = AvFILLp(protopad);
4497 assert(!CvUNIQUE(proto));
4501 SAVESPTR(PL_comppad_name);
4502 SAVESPTR(PL_compcv);
4504 cv = PL_compcv = (CV*)NEWSV(1104,0);
4505 sv_upgrade((SV *)cv, SvTYPE(proto));
4506 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4509 #ifdef USE_5005THREADS
4510 New(666, CvMUTEXP(cv), 1, perl_mutex);
4511 MUTEX_INIT(CvMUTEXP(cv));
4513 #endif /* USE_5005THREADS */
4515 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4516 : savepv(CvFILE(proto));
4518 CvFILE(cv) = CvFILE(proto);
4520 CvGV(cv) = CvGV(proto);
4521 CvSTASH(cv) = CvSTASH(proto);
4522 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4523 CvSTART(cv) = CvSTART(proto);
4525 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4528 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4530 PL_comppad_name = newAV();
4531 for (ix = fname; ix >= 0; ix--)
4532 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4534 PL_comppad = newAV();
4536 comppadlist = newAV();
4537 AvREAL_off(comppadlist);
4538 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4539 av_store(comppadlist, 1, (SV*)PL_comppad);
4540 CvPADLIST(cv) = comppadlist;
4541 av_fill(PL_comppad, AvFILLp(protopad));
4542 PL_curpad = AvARRAY(PL_comppad);
4544 av = newAV(); /* will be @_ */
4546 av_store(PL_comppad, 0, (SV*)av);
4547 AvFLAGS(av) = AVf_REIFY;
4549 for (ix = fpad; ix > 0; ix--) {
4550 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4551 if (namesv && namesv != &PL_sv_undef) {
4552 char *name = SvPVX(namesv); /* XXX */
4553 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4554 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4555 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4557 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4559 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4561 else { /* our own lexical */
4564 /* anon code -- we'll come back for it */
4565 sv = SvREFCNT_inc(ppad[ix]);
4567 else if (*name == '@')
4569 else if (*name == '%')
4578 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4579 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4582 SV* sv = NEWSV(0,0);
4588 /* Now that vars are all in place, clone nested closures. */
4590 for (ix = fpad; ix > 0; ix--) {
4591 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4593 && namesv != &PL_sv_undef
4594 && !(SvFLAGS(namesv) & SVf_FAKE)
4595 && *SvPVX(namesv) == '&'
4596 && CvCLONE(ppad[ix]))
4598 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4599 SvREFCNT_dec(ppad[ix]);
4602 PL_curpad[ix] = (SV*)kid;
4606 #ifdef DEBUG_CLOSURES
4607 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4609 PerlIO_printf(Perl_debug_log, " from:\n");
4611 PerlIO_printf(Perl_debug_log, " to:\n");
4618 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4620 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4622 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4629 Perl_cv_clone(pTHX_ CV *proto)
4632 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4633 cv = cv_clone2(proto, CvOUTSIDE(proto));
4634 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4639 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4641 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4642 SV* msg = sv_newmortal();
4646 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4647 sv_setpv(msg, "Prototype mismatch:");
4649 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4651 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4652 sv_catpv(msg, " vs ");
4654 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4656 sv_catpv(msg, "none");
4657 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4661 static void const_sv_xsub(pTHX_ CV* cv);
4665 =head1 Optree Manipulation Functions
4667 =for apidoc cv_const_sv
4669 If C<cv> is a constant sub eligible for inlining. returns the constant
4670 value returned by the sub. Otherwise, returns NULL.
4672 Constant subs can be created with C<newCONSTSUB> or as described in
4673 L<perlsub/"Constant Functions">.
4678 Perl_cv_const_sv(pTHX_ CV *cv)
4680 if (!cv || !CvCONST(cv))
4682 return (SV*)CvXSUBANY(cv).any_ptr;
4686 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4693 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4694 o = cLISTOPo->op_first->op_sibling;
4696 for (; o; o = o->op_next) {
4697 OPCODE type = o->op_type;
4699 if (sv && o->op_next == o)
4701 if (o->op_next != o) {
4702 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4704 if (type == OP_DBSTATE)
4707 if (type == OP_LEAVESUB || type == OP_RETURN)
4711 if (type == OP_CONST && cSVOPo->op_sv)
4713 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4714 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4715 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4719 /* We get here only from cv_clone2() while creating a closure.
4720 Copy the const value here instead of in cv_clone2 so that
4721 SvREADONLY_on doesn't lead to problems when leaving
4726 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4738 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4748 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4752 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4754 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4758 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4764 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4769 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4770 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4771 SV *sv = sv_newmortal();
4772 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4773 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4778 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4779 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),