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;
882 Safefree(PmopSTASHPV(cPMOPo));
884 /* NOTE: PMOP.op_pmstash is not refcounted */
887 cPMOPo->op_pmreplroot = Nullop;
888 /* we use the "SAFE" version of the PM_ macros here
889 * since sv_clean_all might release some PMOPs
890 * after PL_regex_padav has been cleared
891 * and the clearing of PL_regex_padav needs to
892 * happen before sv_clean_all
894 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
895 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
897 if(PL_regex_pad) { /* We could be in destruction */
898 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
899 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
900 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
907 if (o->op_targ > 0) {
908 pad_free(o->op_targ);
914 S_cop_free(pTHX_ COP* cop)
916 Safefree(cop->cop_label);
918 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
919 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
921 /* NOTE: COP.cop_stash is not refcounted */
922 SvREFCNT_dec(CopFILEGV(cop));
924 if (! specialWARN(cop->cop_warnings))
925 SvREFCNT_dec(cop->cop_warnings);
926 if (! specialCopIO(cop->cop_io))
927 SvREFCNT_dec(cop->cop_io);
931 Perl_op_null(pTHX_ OP *o)
933 if (o->op_type == OP_NULL)
936 o->op_targ = o->op_type;
937 o->op_type = OP_NULL;
938 o->op_ppaddr = PL_ppaddr[OP_NULL];
941 /* Contextualizers */
943 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
946 Perl_linklist(pTHX_ OP *o)
953 /* establish postfix order */
954 if (cUNOPo->op_first) {
955 o->op_next = LINKLIST(cUNOPo->op_first);
956 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
958 kid->op_next = LINKLIST(kid->op_sibling);
970 Perl_scalarkids(pTHX_ OP *o)
973 if (o && o->op_flags & OPf_KIDS) {
974 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
981 S_scalarboolean(pTHX_ OP *o)
983 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
984 if (ckWARN(WARN_SYNTAX)) {
985 line_t oldline = CopLINE(PL_curcop);
987 if (PL_copline != NOLINE)
988 CopLINE_set(PL_curcop, PL_copline);
989 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
990 CopLINE_set(PL_curcop, oldline);
997 Perl_scalar(pTHX_ OP *o)
1001 /* assumes no premature commitment */
1002 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1003 || o->op_type == OP_RETURN)
1008 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1010 switch (o->op_type) {
1012 scalar(cBINOPo->op_first);
1017 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1021 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1022 if (!kPMOP->op_pmreplroot)
1023 deprecate("implicit split to @_");
1031 if (o->op_flags & OPf_KIDS) {
1032 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1038 kid = cLISTOPo->op_first;
1040 while ((kid = kid->op_sibling)) {
1041 if (kid->op_sibling)
1046 WITH_THR(PL_curcop = &PL_compiling);
1051 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1052 if (kid->op_sibling)
1057 WITH_THR(PL_curcop = &PL_compiling);
1060 if (ckWARN(WARN_VOID))
1061 Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
1067 Perl_scalarvoid(pTHX_ OP *o)
1074 if (o->op_type == OP_NEXTSTATE
1075 || o->op_type == OP_SETSTATE
1076 || o->op_type == OP_DBSTATE
1077 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1078 || o->op_targ == OP_SETSTATE
1079 || o->op_targ == OP_DBSTATE)))
1080 PL_curcop = (COP*)o; /* for warning below */
1082 /* assumes no premature commitment */
1083 want = o->op_flags & OPf_WANT;
1084 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1085 || o->op_type == OP_RETURN)
1090 if ((o->op_private & OPpTARGET_MY)
1091 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1093 return scalar(o); /* As if inside SASSIGN */
1096 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1098 switch (o->op_type) {
1100 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1104 if (o->op_flags & OPf_STACKED)
1108 if (o->op_private == 4)
1150 case OP_GETSOCKNAME:
1151 case OP_GETPEERNAME:
1156 case OP_GETPRIORITY:
1179 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1180 useless = OP_DESC(o);
1187 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1188 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1189 useless = "a variable";
1194 if (cSVOPo->op_private & OPpCONST_STRICT)
1195 no_bareword_allowed(o);
1197 if (ckWARN(WARN_VOID)) {
1198 useless = "a constant";
1199 /* the constants 0 and 1 are permitted as they are
1200 conventionally used as dummies in constructs like
1201 1 while some_condition_with_side_effects; */
1202 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1204 else if (SvPOK(sv)) {
1205 /* perl4's way of mixing documentation and code
1206 (before the invention of POD) was based on a
1207 trick to mix nroff and perl code. The trick was
1208 built upon these three nroff macros being used in
1209 void context. The pink camel has the details in
1210 the script wrapman near page 319. */
1211 if (strnEQ(SvPVX(sv), "di", 2) ||
1212 strnEQ(SvPVX(sv), "ds", 2) ||
1213 strnEQ(SvPVX(sv), "ig", 2))
1218 op_null(o); /* don't execute or even remember it */
1222 o->op_type = OP_PREINC; /* pre-increment is faster */
1223 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1227 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1228 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1234 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1239 if (o->op_flags & OPf_STACKED)
1246 if (!(o->op_flags & OPf_KIDS))
1255 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1262 /* all requires must return a boolean value */
1263 o->op_flags &= ~OPf_WANT;
1268 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1269 if (!kPMOP->op_pmreplroot)
1270 deprecate("implicit split to @_");
1274 if (useless && ckWARN(WARN_VOID))
1275 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1280 Perl_listkids(pTHX_ OP *o)
1283 if (o && o->op_flags & OPf_KIDS) {
1284 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1291 Perl_list(pTHX_ OP *o)
1295 /* assumes no premature commitment */
1296 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1297 || o->op_type == OP_RETURN)
1302 if ((o->op_private & OPpTARGET_MY)
1303 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1305 return o; /* As if inside SASSIGN */
1308 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1310 switch (o->op_type) {
1313 list(cBINOPo->op_first);
1318 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1326 if (!(o->op_flags & OPf_KIDS))
1328 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1329 list(cBINOPo->op_first);
1330 return gen_constant_list(o);
1337 kid = cLISTOPo->op_first;
1339 while ((kid = kid->op_sibling)) {
1340 if (kid->op_sibling)
1345 WITH_THR(PL_curcop = &PL_compiling);
1349 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1350 if (kid->op_sibling)
1355 WITH_THR(PL_curcop = &PL_compiling);
1358 /* all requires must return a boolean value */
1359 o->op_flags &= ~OPf_WANT;
1366 Perl_scalarseq(pTHX_ OP *o)
1371 if (o->op_type == OP_LINESEQ ||
1372 o->op_type == OP_SCOPE ||
1373 o->op_type == OP_LEAVE ||
1374 o->op_type == OP_LEAVETRY)
1376 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1377 if (kid->op_sibling) {
1381 PL_curcop = &PL_compiling;
1383 o->op_flags &= ~OPf_PARENS;
1384 if (PL_hints & HINT_BLOCK_SCOPE)
1385 o->op_flags |= OPf_PARENS;
1388 o = newOP(OP_STUB, 0);
1393 S_modkids(pTHX_ OP *o, I32 type)
1396 if (o && o->op_flags & OPf_KIDS) {
1397 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1404 Perl_mod(pTHX_ OP *o, I32 type)
1409 if (!o || PL_error_count)
1412 if ((o->op_private & OPpTARGET_MY)
1413 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1418 switch (o->op_type) {
1423 if (!(o->op_private & (OPpCONST_ARYBASE)))
1425 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1426 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1430 SAVEI32(PL_compiling.cop_arybase);
1431 PL_compiling.cop_arybase = 0;
1433 else if (type == OP_REFGEN)
1436 Perl_croak(aTHX_ "That use of $[ is unsupported");
1439 if (o->op_flags & OPf_PARENS)
1443 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1444 !(o->op_flags & OPf_STACKED)) {
1445 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1446 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1447 assert(cUNOPo->op_first->op_type == OP_NULL);
1448 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1451 else if (o->op_private & OPpENTERSUB_NOMOD)
1453 else { /* lvalue subroutine call */
1454 o->op_private |= OPpLVAL_INTRO;
1455 PL_modcount = RETURN_UNLIMITED_NUMBER;
1456 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1457 /* Backward compatibility mode: */
1458 o->op_private |= OPpENTERSUB_INARGS;
1461 else { /* Compile-time error message: */
1462 OP *kid = cUNOPo->op_first;
1466 if (kid->op_type == OP_PUSHMARK)
1468 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1470 "panic: unexpected lvalue entersub "
1471 "args: type/targ %ld:%"UVuf,
1472 (long)kid->op_type, (UV)kid->op_targ);
1473 kid = kLISTOP->op_first;
1475 while (kid->op_sibling)
1476 kid = kid->op_sibling;
1477 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1479 if (kid->op_type == OP_METHOD_NAMED
1480 || kid->op_type == OP_METHOD)
1484 NewOp(1101, newop, 1, UNOP);
1485 newop->op_type = OP_RV2CV;
1486 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1487 newop->op_first = Nullop;
1488 newop->op_next = (OP*)newop;
1489 kid->op_sibling = (OP*)newop;
1490 newop->op_private |= OPpLVAL_INTRO;
1494 if (kid->op_type != OP_RV2CV)
1496 "panic: unexpected lvalue entersub "
1497 "entry via type/targ %ld:%"UVuf,
1498 (long)kid->op_type, (UV)kid->op_targ);
1499 kid->op_private |= OPpLVAL_INTRO;
1500 break; /* Postpone until runtime */
1504 kid = kUNOP->op_first;
1505 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1506 kid = kUNOP->op_first;
1507 if (kid->op_type == OP_NULL)
1509 "Unexpected constant lvalue entersub "
1510 "entry via type/targ %ld:%"UVuf,
1511 (long)kid->op_type, (UV)kid->op_targ);
1512 if (kid->op_type != OP_GV) {
1513 /* Restore RV2CV to check lvalueness */
1515 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1516 okid->op_next = kid->op_next;
1517 kid->op_next = okid;
1520 okid->op_next = Nullop;
1521 okid->op_type = OP_RV2CV;
1523 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1524 okid->op_private |= OPpLVAL_INTRO;
1528 cv = GvCV(kGVOP_gv);
1538 /* grep, foreach, subcalls, refgen */
1539 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1541 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1542 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1544 : (o->op_type == OP_ENTERSUB
1545 ? "non-lvalue subroutine call"
1547 type ? PL_op_desc[type] : "local"));
1561 case OP_RIGHT_SHIFT:
1570 if (!(o->op_flags & OPf_STACKED))
1576 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1582 if (!type && cUNOPo->op_first->op_type != OP_GV)
1583 Perl_croak(aTHX_ "Can't localize through a reference");
1584 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1585 PL_modcount = RETURN_UNLIMITED_NUMBER;
1586 return o; /* Treat \(@foo) like ordinary list. */
1590 if (scalar_mod_type(o, type))
1592 ref(cUNOPo->op_first, o->op_type);
1596 if (type == OP_LEAVESUBLV)
1597 o->op_private |= OPpMAYBE_LVSUB;
1603 PL_modcount = RETURN_UNLIMITED_NUMBER;
1606 if (!type && cUNOPo->op_first->op_type != OP_GV)
1607 Perl_croak(aTHX_ "Can't localize through a reference");
1608 ref(cUNOPo->op_first, o->op_type);
1612 PL_hints |= HINT_BLOCK_SCOPE;
1622 PL_modcount = RETURN_UNLIMITED_NUMBER;
1623 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1624 return o; /* Treat \(@foo) like ordinary list. */
1625 if (scalar_mod_type(o, type))
1627 if (type == OP_LEAVESUBLV)
1628 o->op_private |= OPpMAYBE_LVSUB;
1633 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1634 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1637 #ifdef USE_5005THREADS
1639 PL_modcount++; /* XXX ??? */
1641 #endif /* USE_5005THREADS */
1647 if (type != OP_SASSIGN)
1651 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1656 if (type == OP_LEAVESUBLV)
1657 o->op_private |= OPpMAYBE_LVSUB;
1659 pad_free(o->op_targ);
1660 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1661 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1662 if (o->op_flags & OPf_KIDS)
1663 mod(cBINOPo->op_first->op_sibling, type);
1668 ref(cBINOPo->op_first, o->op_type);
1669 if (type == OP_ENTERSUB &&
1670 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1671 o->op_private |= OPpLVAL_DEFER;
1672 if (type == OP_LEAVESUBLV)
1673 o->op_private |= OPpMAYBE_LVSUB;
1681 if (o->op_flags & OPf_KIDS)
1682 mod(cLISTOPo->op_last, type);
1686 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1688 else if (!(o->op_flags & OPf_KIDS))
1690 if (o->op_targ != OP_LIST) {
1691 mod(cBINOPo->op_first, type);
1696 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1701 if (type != OP_LEAVESUBLV)
1703 break; /* mod()ing was handled by ck_return() */
1706 /* [20011101.069] File test operators interpret OPf_REF to mean that
1707 their argument is a filehandle; thus \stat(".") should not set
1709 if (type == OP_REFGEN &&
1710 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1713 if (type != OP_LEAVESUBLV)
1714 o->op_flags |= OPf_MOD;
1716 if (type == OP_AASSIGN || type == OP_SASSIGN)
1717 o->op_flags |= OPf_SPECIAL|OPf_REF;
1719 o->op_private |= OPpLVAL_INTRO;
1720 o->op_flags &= ~OPf_SPECIAL;
1721 PL_hints |= HINT_BLOCK_SCOPE;
1723 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1724 && type != OP_LEAVESUBLV)
1725 o->op_flags |= OPf_REF;
1730 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1734 if (o->op_type == OP_RV2GV)
1758 case OP_RIGHT_SHIFT:
1777 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1779 switch (o->op_type) {
1787 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1800 Perl_refkids(pTHX_ OP *o, I32 type)
1803 if (o && o->op_flags & OPf_KIDS) {
1804 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1811 Perl_ref(pTHX_ OP *o, I32 type)
1815 if (!o || PL_error_count)
1818 switch (o->op_type) {
1820 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1821 !(o->op_flags & OPf_STACKED)) {
1822 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1823 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1824 assert(cUNOPo->op_first->op_type == OP_NULL);
1825 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1826 o->op_flags |= OPf_SPECIAL;
1831 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1835 if (type == OP_DEFINED)
1836 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1837 ref(cUNOPo->op_first, o->op_type);
1840 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1841 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1842 : type == OP_RV2HV ? OPpDEREF_HV
1844 o->op_flags |= OPf_MOD;
1849 o->op_flags |= OPf_MOD; /* XXX ??? */
1854 o->op_flags |= OPf_REF;
1857 if (type == OP_DEFINED)
1858 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1859 ref(cUNOPo->op_first, o->op_type);
1864 o->op_flags |= OPf_REF;
1869 if (!(o->op_flags & OPf_KIDS))
1871 ref(cBINOPo->op_first, type);
1875 ref(cBINOPo->op_first, o->op_type);
1876 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1877 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1878 : type == OP_RV2HV ? OPpDEREF_HV
1880 o->op_flags |= OPf_MOD;
1888 if (!(o->op_flags & OPf_KIDS))
1890 ref(cLISTOPo->op_last, type);
1900 S_dup_attrlist(pTHX_ OP *o)
1904 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1905 * where the first kid is OP_PUSHMARK and the remaining ones
1906 * are OP_CONST. We need to push the OP_CONST values.
1908 if (o->op_type == OP_CONST)
1909 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1911 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1912 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1913 if (o->op_type == OP_CONST)
1914 rop = append_elem(OP_LIST, rop,
1915 newSVOP(OP_CONST, o->op_flags,
1916 SvREFCNT_inc(cSVOPo->op_sv)));
1923 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1927 /* fake up C<use attributes $pkg,$rv,@attrs> */
1928 ENTER; /* need to protect against side-effects of 'use' */
1931 stashsv = newSVpv(HvNAME(stash), 0);
1933 stashsv = &PL_sv_no;
1935 #define ATTRSMODULE "attributes"
1936 #define ATTRSMODULE_PM "attributes.pm"
1940 /* Don't force the C<use> if we don't need it. */
1941 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1942 sizeof(ATTRSMODULE_PM)-1, 0);
1943 if (svp && *svp != &PL_sv_undef)
1944 ; /* already in %INC */
1946 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1947 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1951 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1952 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1954 prepend_elem(OP_LIST,
1955 newSVOP(OP_CONST, 0, stashsv),
1956 prepend_elem(OP_LIST,
1957 newSVOP(OP_CONST, 0,
1959 dup_attrlist(attrs))));
1965 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1967 OP *pack, *imop, *arg;
1973 assert(target->op_type == OP_PADSV ||
1974 target->op_type == OP_PADHV ||
1975 target->op_type == OP_PADAV);
1977 /* Ensure that attributes.pm is loaded. */
1978 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1980 /* Need package name for method call. */
1981 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1983 /* Build up the real arg-list. */
1985 stashsv = newSVpv(HvNAME(stash), 0);
1987 stashsv = &PL_sv_no;
1988 arg = newOP(OP_PADSV, 0);
1989 arg->op_targ = target->op_targ;
1990 arg = prepend_elem(OP_LIST,
1991 newSVOP(OP_CONST, 0, stashsv),
1992 prepend_elem(OP_LIST,
1993 newUNOP(OP_REFGEN, 0,
1994 mod(arg, OP_REFGEN)),
1995 dup_attrlist(attrs)));
1997 /* Fake up a method call to import */
1998 meth = newSVpvn("import", 6);
1999 (void)SvUPGRADE(meth, SVt_PVIV);
2000 (void)SvIOK_on(meth);
2001 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2002 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2003 append_elem(OP_LIST,
2004 prepend_elem(OP_LIST, pack, list(arg)),
2005 newSVOP(OP_METHOD_NAMED, 0, meth)));
2006 imop->op_private |= OPpENTERSUB_NOMOD;
2008 /* Combine the ops. */
2009 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2013 =notfor apidoc apply_attrs_string
2015 Attempts to apply a list of attributes specified by the C<attrstr> and
2016 C<len> arguments to the subroutine identified by the C<cv> argument which
2017 is expected to be associated with the package identified by the C<stashpv>
2018 argument (see L<attributes>). It gets this wrong, though, in that it
2019 does not correctly identify the boundaries of the individual attribute
2020 specifications within C<attrstr>. This is not really intended for the
2021 public API, but has to be listed here for systems such as AIX which
2022 need an explicit export list for symbols. (It's called from XS code
2023 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2024 to respect attribute syntax properly would be welcome.
2030 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2031 char *attrstr, STRLEN len)
2036 len = strlen(attrstr);
2040 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2042 char *sstr = attrstr;
2043 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2044 attrs = append_elem(OP_LIST, attrs,
2045 newSVOP(OP_CONST, 0,
2046 newSVpvn(sstr, attrstr-sstr)));
2050 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2051 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2052 Nullsv, prepend_elem(OP_LIST,
2053 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2054 prepend_elem(OP_LIST,
2055 newSVOP(OP_CONST, 0,
2061 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2066 if (!o || PL_error_count)
2070 if (type == OP_LIST) {
2071 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2072 my_kid(kid, attrs, imopsp);
2073 } else if (type == OP_UNDEF) {
2075 } else if (type == OP_RV2SV || /* "our" declaration */
2077 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2078 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2079 yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
2082 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2084 PL_in_my_stash = Nullhv;
2085 apply_attrs(GvSTASH(gv),
2086 (type == OP_RV2SV ? GvSV(gv) :
2087 type == OP_RV2AV ? (SV*)GvAV(gv) :
2088 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2091 o->op_private |= OPpOUR_INTRO;
2094 else if (type != OP_PADSV &&
2097 type != OP_PUSHMARK)
2099 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2101 PL_in_my == KEY_our ? "our" : "my"));
2104 else if (attrs && type != OP_PUSHMARK) {
2109 PL_in_my_stash = Nullhv;
2111 /* check for C<my Dog $spot> when deciding package */
2112 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2113 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2114 stash = SvSTASH(*namesvp);
2116 stash = PL_curstash;
2117 apply_attrs_my(stash, o, attrs, imopsp);
2119 o->op_flags |= OPf_MOD;
2120 o->op_private |= OPpLVAL_INTRO;
2125 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2128 int maybe_scalar = 0;
2130 if (o->op_flags & OPf_PARENS)
2136 o = my_kid(o, attrs, &rops);
2138 if (maybe_scalar && o->op_type == OP_PADSV) {
2139 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2140 o->op_private |= OPpLVAL_INTRO;
2143 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2146 PL_in_my_stash = Nullhv;
2151 Perl_my(pTHX_ OP *o)
2153 return my_attrs(o, Nullop);
2157 Perl_sawparens(pTHX_ OP *o)
2160 o->op_flags |= OPf_PARENS;
2165 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2169 if (ckWARN(WARN_MISC) &&
2170 (left->op_type == OP_RV2AV ||
2171 left->op_type == OP_RV2HV ||
2172 left->op_type == OP_PADAV ||
2173 left->op_type == OP_PADHV)) {
2174 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2175 right->op_type == OP_TRANS)
2176 ? right->op_type : OP_MATCH];
2177 const char *sample = ((left->op_type == OP_RV2AV ||
2178 left->op_type == OP_PADAV)
2179 ? "@array" : "%hash");
2180 Perl_warner(aTHX_ WARN_MISC,
2181 "Applying %s to %s will act on scalar(%s)",
2182 desc, sample, sample);
2185 if (right->op_type == OP_CONST &&
2186 cSVOPx(right)->op_private & OPpCONST_BARE &&
2187 cSVOPx(right)->op_private & OPpCONST_STRICT)
2189 no_bareword_allowed(right);
2192 if (!(right->op_flags & OPf_STACKED) &&
2193 (right->op_type == OP_MATCH ||
2194 right->op_type == OP_SUBST ||
2195 right->op_type == OP_TRANS)) {
2196 right->op_flags |= OPf_STACKED;
2197 if (right->op_type != OP_MATCH &&
2198 ! (right->op_type == OP_TRANS &&
2199 right->op_private & OPpTRANS_IDENTICAL))
2200 left = mod(left, right->op_type);
2201 if (right->op_type == OP_TRANS)
2202 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2204 o = prepend_elem(right->op_type, scalar(left), right);
2206 return newUNOP(OP_NOT, 0, scalar(o));
2210 return bind_match(type, left,
2211 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2215 Perl_invert(pTHX_ OP *o)
2219 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2220 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2224 Perl_scope(pTHX_ OP *o)
2227 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2228 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2229 o->op_type = OP_LEAVE;
2230 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2233 if (o->op_type == OP_LINESEQ) {
2235 o->op_type = OP_SCOPE;
2236 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2237 kid = ((LISTOP*)o)->op_first;
2238 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2242 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2249 Perl_save_hints(pTHX)
2252 SAVESPTR(GvHV(PL_hintgv));
2253 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2254 SAVEFREESV(GvHV(PL_hintgv));
2258 Perl_block_start(pTHX_ int full)
2260 int retval = PL_savestack_ix;
2262 SAVEI32(PL_comppad_name_floor);
2263 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2265 PL_comppad_name_fill = PL_comppad_name_floor;
2266 if (PL_comppad_name_floor < 0)
2267 PL_comppad_name_floor = 0;
2268 SAVEI32(PL_min_intro_pending);
2269 SAVEI32(PL_max_intro_pending);
2270 PL_min_intro_pending = 0;
2271 SAVEI32(PL_comppad_name_fill);
2272 SAVEI32(PL_padix_floor);
2273 PL_padix_floor = PL_padix;
2274 PL_pad_reset_pending = FALSE;
2276 PL_hints &= ~HINT_BLOCK_SCOPE;
2277 SAVESPTR(PL_compiling.cop_warnings);
2278 if (! specialWARN(PL_compiling.cop_warnings)) {
2279 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2280 SAVEFREESV(PL_compiling.cop_warnings) ;
2282 SAVESPTR(PL_compiling.cop_io);
2283 if (! specialCopIO(PL_compiling.cop_io)) {
2284 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2285 SAVEFREESV(PL_compiling.cop_io) ;
2291 Perl_block_end(pTHX_ I32 floor, OP *seq)
2293 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2294 line_t copline = PL_copline;
2295 /* there should be a nextstate in every block */
2296 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2297 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2299 PL_pad_reset_pending = FALSE;
2300 PL_compiling.op_private = PL_hints;
2302 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2303 pad_leavemy(PL_comppad_name_fill);
2311 #ifdef USE_5005THREADS
2312 OP *o = newOP(OP_THREADSV, 0);
2313 o->op_targ = find_threadsv("_");
2316 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2317 #endif /* USE_5005THREADS */
2321 Perl_newPROG(pTHX_ OP *o)
2326 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2327 ((PL_in_eval & EVAL_KEEPERR)
2328 ? OPf_SPECIAL : 0), o);
2329 PL_eval_start = linklist(PL_eval_root);
2330 PL_eval_root->op_private |= OPpREFCOUNTED;
2331 OpREFCNT_set(PL_eval_root, 1);
2332 PL_eval_root->op_next = 0;
2333 CALL_PEEP(PL_eval_start);
2338 PL_main_root = scope(sawparens(scalarvoid(o)));
2339 PL_curcop = &PL_compiling;
2340 PL_main_start = LINKLIST(PL_main_root);
2341 PL_main_root->op_private |= OPpREFCOUNTED;
2342 OpREFCNT_set(PL_main_root, 1);
2343 PL_main_root->op_next = 0;
2344 CALL_PEEP(PL_main_start);
2347 /* Register with debugger */
2349 CV *cv = get_cv("DB::postponed", FALSE);
2353 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2355 call_sv((SV*)cv, G_DISCARD);
2362 Perl_localize(pTHX_ OP *o, I32 lex)
2364 if (o->op_flags & OPf_PARENS)
2367 if (ckWARN(WARN_PARENTHESIS)
2368 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2370 char *s = PL_bufptr;
2372 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2375 if (*s == ';' || *s == '=')
2376 Perl_warner(aTHX_ WARN_PARENTHESIS,
2377 "Parentheses missing around \"%s\" list",
2378 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2384 o = mod(o, OP_NULL); /* a bit kludgey */
2386 PL_in_my_stash = Nullhv;
2391 Perl_jmaybe(pTHX_ OP *o)
2393 if (o->op_type == OP_LIST) {
2395 #ifdef USE_5005THREADS
2396 o2 = newOP(OP_THREADSV, 0);
2397 o2->op_targ = find_threadsv(";");
2399 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2400 #endif /* USE_5005THREADS */
2401 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2407 Perl_fold_constants(pTHX_ register OP *o)
2410 I32 type = o->op_type;
2413 if (PL_opargs[type] & OA_RETSCALAR)
2415 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2416 o->op_targ = pad_alloc(type, SVs_PADTMP);
2418 /* integerize op, unless it happens to be C<-foo>.
2419 * XXX should pp_i_negate() do magic string negation instead? */
2420 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2421 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2422 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2424 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2427 if (!(PL_opargs[type] & OA_FOLDCONST))
2432 /* XXX might want a ck_negate() for this */
2433 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2445 /* XXX what about the numeric ops? */
2446 if (PL_hints & HINT_LOCALE)
2451 goto nope; /* Don't try to run w/ errors */
2453 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2454 if ((curop->op_type != OP_CONST ||
2455 (curop->op_private & OPpCONST_BARE)) &&
2456 curop->op_type != OP_LIST &&
2457 curop->op_type != OP_SCALAR &&
2458 curop->op_type != OP_NULL &&
2459 curop->op_type != OP_PUSHMARK)
2465 curop = LINKLIST(o);
2469 sv = *(PL_stack_sp--);
2470 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2471 pad_swipe(o->op_targ);
2472 else if (SvTEMP(sv)) { /* grab mortal temp? */
2473 (void)SvREFCNT_inc(sv);
2477 if (type == OP_RV2GV)
2478 return newGVOP(OP_GV, 0, (GV*)sv);
2480 /* try to smush double to int, but don't smush -2.0 to -2 */
2481 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2484 #ifdef PERL_PRESERVE_IVUV
2485 /* Only bother to attempt to fold to IV if
2486 most operators will benefit */
2490 return newSVOP(OP_CONST, 0, sv);
2494 if (!(PL_opargs[type] & OA_OTHERINT))
2497 if (!(PL_hints & HINT_INTEGER)) {
2498 if (type == OP_MODULO
2499 || type == OP_DIVIDE
2500 || !(o->op_flags & OPf_KIDS))
2505 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2506 if (curop->op_type == OP_CONST) {
2507 if (SvIOK(((SVOP*)curop)->op_sv))
2511 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2515 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2522 Perl_gen_constant_list(pTHX_ register OP *o)
2525 I32 oldtmps_floor = PL_tmps_floor;
2529 return o; /* Don't attempt to run with errors */
2531 PL_op = curop = LINKLIST(o);
2538 PL_tmps_floor = oldtmps_floor;
2540 o->op_type = OP_RV2AV;
2541 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2542 curop = ((UNOP*)o)->op_first;
2543 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2550 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2552 if (!o || o->op_type != OP_LIST)
2553 o = newLISTOP(OP_LIST, 0, o, Nullop);
2555 o->op_flags &= ~OPf_WANT;
2557 if (!(PL_opargs[type] & OA_MARK))
2558 op_null(cLISTOPo->op_first);
2561 o->op_ppaddr = PL_ppaddr[type];
2562 o->op_flags |= flags;
2564 o = CHECKOP(type, o);
2565 if (o->op_type != type)
2568 return fold_constants(o);
2571 /* List constructors */
2574 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2582 if (first->op_type != type
2583 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2585 return newLISTOP(type, 0, first, last);
2588 if (first->op_flags & OPf_KIDS)
2589 ((LISTOP*)first)->op_last->op_sibling = last;
2591 first->op_flags |= OPf_KIDS;
2592 ((LISTOP*)first)->op_first = last;
2594 ((LISTOP*)first)->op_last = last;
2599 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2607 if (first->op_type != type)
2608 return prepend_elem(type, (OP*)first, (OP*)last);
2610 if (last->op_type != type)
2611 return append_elem(type, (OP*)first, (OP*)last);
2613 first->op_last->op_sibling = last->op_first;
2614 first->op_last = last->op_last;
2615 first->op_flags |= (last->op_flags & OPf_KIDS);
2623 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2631 if (last->op_type == type) {
2632 if (type == OP_LIST) { /* already a PUSHMARK there */
2633 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2634 ((LISTOP*)last)->op_first->op_sibling = first;
2635 if (!(first->op_flags & OPf_PARENS))
2636 last->op_flags &= ~OPf_PARENS;
2639 if (!(last->op_flags & OPf_KIDS)) {
2640 ((LISTOP*)last)->op_last = first;
2641 last->op_flags |= OPf_KIDS;
2643 first->op_sibling = ((LISTOP*)last)->op_first;
2644 ((LISTOP*)last)->op_first = first;
2646 last->op_flags |= OPf_KIDS;
2650 return newLISTOP(type, 0, first, last);
2656 Perl_newNULLLIST(pTHX)
2658 return newOP(OP_STUB, 0);
2662 Perl_force_list(pTHX_ OP *o)
2664 if (!o || o->op_type != OP_LIST)
2665 o = newLISTOP(OP_LIST, 0, o, Nullop);
2671 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2675 NewOp(1101, listop, 1, LISTOP);
2677 listop->op_type = type;
2678 listop->op_ppaddr = PL_ppaddr[type];
2681 listop->op_flags = flags;
2685 else if (!first && last)
2688 first->op_sibling = last;
2689 listop->op_first = first;
2690 listop->op_last = last;
2691 if (type == OP_LIST) {
2693 pushop = newOP(OP_PUSHMARK, 0);
2694 pushop->op_sibling = first;
2695 listop->op_first = pushop;
2696 listop->op_flags |= OPf_KIDS;
2698 listop->op_last = pushop;
2705 Perl_newOP(pTHX_ I32 type, I32 flags)
2708 NewOp(1101, o, 1, OP);
2710 o->op_ppaddr = PL_ppaddr[type];
2711 o->op_flags = flags;
2714 o->op_private = 0 + (flags >> 8);
2715 if (PL_opargs[type] & OA_RETSCALAR)
2717 if (PL_opargs[type] & OA_TARGET)
2718 o->op_targ = pad_alloc(type, SVs_PADTMP);
2719 return CHECKOP(type, o);
2723 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2728 first = newOP(OP_STUB, 0);
2729 if (PL_opargs[type] & OA_MARK)
2730 first = force_list(first);
2732 NewOp(1101, unop, 1, UNOP);
2733 unop->op_type = type;
2734 unop->op_ppaddr = PL_ppaddr[type];
2735 unop->op_first = first;
2736 unop->op_flags = flags | OPf_KIDS;
2737 unop->op_private = 1 | (flags >> 8);
2738 unop = (UNOP*) CHECKOP(type, unop);
2742 return fold_constants((OP *) unop);
2746 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2749 NewOp(1101, binop, 1, BINOP);
2752 first = newOP(OP_NULL, 0);
2754 binop->op_type = type;
2755 binop->op_ppaddr = PL_ppaddr[type];
2756 binop->op_first = first;
2757 binop->op_flags = flags | OPf_KIDS;
2760 binop->op_private = 1 | (flags >> 8);
2763 binop->op_private = 2 | (flags >> 8);
2764 first->op_sibling = last;
2767 binop = (BINOP*)CHECKOP(type, binop);
2768 if (binop->op_next || binop->op_type != type)
2771 binop->op_last = binop->op_first->op_sibling;
2773 return fold_constants((OP *)binop);
2777 uvcompare(const void *a, const void *b)
2779 if (*((UV *)a) < (*(UV *)b))
2781 if (*((UV *)a) > (*(UV *)b))
2783 if (*((UV *)a+1) < (*(UV *)b+1))
2785 if (*((UV *)a+1) > (*(UV *)b+1))
2791 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2793 SV *tstr = ((SVOP*)expr)->op_sv;
2794 SV *rstr = ((SVOP*)repl)->op_sv;
2797 U8 *t = (U8*)SvPV(tstr, tlen);
2798 U8 *r = (U8*)SvPV(rstr, rlen);
2805 register short *tbl;
2807 PL_hints |= HINT_BLOCK_SCOPE;
2808 complement = o->op_private & OPpTRANS_COMPLEMENT;
2809 del = o->op_private & OPpTRANS_DELETE;
2810 squash = o->op_private & OPpTRANS_SQUASH;
2813 o->op_private |= OPpTRANS_FROM_UTF;
2816 o->op_private |= OPpTRANS_TO_UTF;
2818 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2819 SV* listsv = newSVpvn("# comment\n",10);
2821 U8* tend = t + tlen;
2822 U8* rend = r + rlen;
2836 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2837 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2843 tsave = t = bytes_to_utf8(t, &len);
2846 if (!to_utf && rlen) {
2848 rsave = r = bytes_to_utf8(r, &len);
2852 /* There are several snags with this code on EBCDIC:
2853 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2854 2. scan_const() in toke.c has encoded chars in native encoding which makes
2855 ranges at least in EBCDIC 0..255 range the bottom odd.
2859 U8 tmpbuf[UTF8_MAXLEN+1];
2862 New(1109, cp, 2*tlen, UV);
2864 transv = newSVpvn("",0);
2866 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2868 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2870 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2874 cp[2*i+1] = cp[2*i];
2878 qsort(cp, i, 2*sizeof(UV), uvcompare);
2879 for (j = 0; j < i; j++) {
2881 diff = val - nextmin;
2883 t = uvuni_to_utf8(tmpbuf,nextmin);
2884 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2886 U8 range_mark = UTF_TO_NATIVE(0xff);
2887 t = uvuni_to_utf8(tmpbuf, val - 1);
2888 sv_catpvn(transv, (char *)&range_mark, 1);
2889 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2896 t = uvuni_to_utf8(tmpbuf,nextmin);
2897 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2899 U8 range_mark = UTF_TO_NATIVE(0xff);
2900 sv_catpvn(transv, (char *)&range_mark, 1);
2902 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2903 UNICODE_ALLOW_SUPER);
2904 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2905 t = (U8*)SvPVX(transv);
2906 tlen = SvCUR(transv);
2910 else if (!rlen && !del) {
2911 r = t; rlen = tlen; rend = tend;
2914 if ((!rlen && !del) || t == r ||
2915 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2917 o->op_private |= OPpTRANS_IDENTICAL;
2921 while (t < tend || tfirst <= tlast) {
2922 /* see if we need more "t" chars */
2923 if (tfirst > tlast) {
2924 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2926 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2928 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2935 /* now see if we need more "r" chars */
2936 if (rfirst > rlast) {
2938 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2940 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2942 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2951 rfirst = rlast = 0xffffffff;
2955 /* now see which range will peter our first, if either. */
2956 tdiff = tlast - tfirst;
2957 rdiff = rlast - rfirst;
2964 if (rfirst == 0xffffffff) {
2965 diff = tdiff; /* oops, pretend rdiff is infinite */
2967 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2968 (long)tfirst, (long)tlast);
2970 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2975 (long)tfirst, (long)(tfirst + diff),
2978 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2979 (long)tfirst, (long)rfirst);
2981 if (rfirst + diff > max)
2982 max = rfirst + diff;
2984 grows = (tfirst < rfirst &&
2985 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2997 else if (max > 0xff)
3002 Safefree(cPVOPo->op_pv);
3003 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3004 SvREFCNT_dec(listsv);
3006 SvREFCNT_dec(transv);
3008 if (!del && havefinal && rlen)
3009 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3010 newSVuv((UV)final), 0);
3013 o->op_private |= OPpTRANS_GROWS;
3025 tbl = (short*)cPVOPo->op_pv;
3027 Zero(tbl, 256, short);
3028 for (i = 0; i < tlen; i++)
3030 for (i = 0, j = 0; i < 256; i++) {
3041 if (i < 128 && r[j] >= 128)
3051 o->op_private |= OPpTRANS_IDENTICAL;
3056 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3057 tbl[0x100] = rlen - j;
3058 for (i=0; i < rlen - j; i++)
3059 tbl[0x101+i] = r[j+i];
3063 if (!rlen && !del) {
3066 o->op_private |= OPpTRANS_IDENTICAL;
3068 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3069 o->op_private |= OPpTRANS_IDENTICAL;
3071 for (i = 0; i < 256; i++)
3073 for (i = 0, j = 0; i < tlen; i++,j++) {
3076 if (tbl[t[i]] == -1)
3082 if (tbl[t[i]] == -1) {
3083 if (t[i] < 128 && r[j] >= 128)
3090 o->op_private |= OPpTRANS_GROWS;
3098 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3102 NewOp(1101, pmop, 1, PMOP);
3103 pmop->op_type = type;
3104 pmop->op_ppaddr = PL_ppaddr[type];
3105 pmop->op_flags = flags;
3106 pmop->op_private = 0 | (flags >> 8);
3108 if (PL_hints & HINT_RE_TAINT)
3109 pmop->op_pmpermflags |= PMf_RETAINT;
3110 if (PL_hints & HINT_LOCALE)
3111 pmop->op_pmpermflags |= PMf_LOCALE;
3112 pmop->op_pmflags = pmop->op_pmpermflags;
3117 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3118 repointer = av_pop((AV*)PL_regex_pad[0]);
3119 pmop->op_pmoffset = SvIV(repointer);
3120 SvREPADTMP_off(repointer);
3121 sv_setiv(repointer,0);
3123 repointer = newSViv(0);
3124 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3125 pmop->op_pmoffset = av_len(PL_regex_padav);
3126 PL_regex_pad = AvARRAY(PL_regex_padav);
3131 /* link into pm list */
3132 if (type != OP_TRANS && PL_curstash) {
3133 pmop->op_pmnext = HvPMROOT(PL_curstash);
3134 HvPMROOT(PL_curstash) = pmop;
3135 PmopSTASH_set(pmop,PL_curstash);
3142 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3146 I32 repl_has_vars = 0;
3148 if (o->op_type == OP_TRANS)
3149 return pmtrans(o, expr, repl);
3151 PL_hints |= HINT_BLOCK_SCOPE;
3154 if (expr->op_type == OP_CONST) {
3156 SV *pat = ((SVOP*)expr)->op_sv;
3157 char *p = SvPV(pat, plen);
3158 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3159 sv_setpvn(pat, "\\s+", 3);
3160 p = SvPV(pat, plen);
3161 pm->op_pmflags |= PMf_SKIPWHITE;
3164 pm->op_pmdynflags |= PMdf_UTF8;
3165 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3166 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3167 pm->op_pmflags |= PMf_WHITE;
3171 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3172 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3174 : OP_REGCMAYBE),0,expr);
3176 NewOp(1101, rcop, 1, LOGOP);
3177 rcop->op_type = OP_REGCOMP;
3178 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3179 rcop->op_first = scalar(expr);
3180 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3181 ? (OPf_SPECIAL | OPf_KIDS)
3183 rcop->op_private = 1;
3186 /* establish postfix order */
3187 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3189 rcop->op_next = expr;
3190 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3193 rcop->op_next = LINKLIST(expr);
3194 expr->op_next = (OP*)rcop;
3197 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3202 if (pm->op_pmflags & PMf_EVAL) {
3204 if (CopLINE(PL_curcop) < PL_multi_end)
3205 CopLINE_set(PL_curcop, PL_multi_end);
3207 #ifdef USE_5005THREADS
3208 else if (repl->op_type == OP_THREADSV
3209 && strchr("&`'123456789+",
3210 PL_threadsv_names[repl->op_targ]))
3214 #endif /* USE_5005THREADS */
3215 else if (repl->op_type == OP_CONST)
3219 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3220 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3221 #ifdef USE_5005THREADS
3222 if (curop->op_type == OP_THREADSV) {
3224 if (strchr("&`'123456789+", curop->op_private))
3228 if (curop->op_type == OP_GV) {
3229 GV *gv = cGVOPx_gv(curop);
3231 if (strchr("&`'123456789+", *GvENAME(gv)))
3234 #endif /* USE_5005THREADS */
3235 else if (curop->op_type == OP_RV2CV)
3237 else if (curop->op_type == OP_RV2SV ||
3238 curop->op_type == OP_RV2AV ||
3239 curop->op_type == OP_RV2HV ||
3240 curop->op_type == OP_RV2GV) {
3241 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3244 else if (curop->op_type == OP_PADSV ||
3245 curop->op_type == OP_PADAV ||
3246 curop->op_type == OP_PADHV ||
3247 curop->op_type == OP_PADANY) {
3250 else if (curop->op_type == OP_PUSHRE)
3251 ; /* Okay here, dangerous in newASSIGNOP */
3261 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3262 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3263 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3264 prepend_elem(o->op_type, scalar(repl), o);
3267 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3268 pm->op_pmflags |= PMf_MAYBE_CONST;
3269 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3271 NewOp(1101, rcop, 1, LOGOP);
3272 rcop->op_type = OP_SUBSTCONT;
3273 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3274 rcop->op_first = scalar(repl);
3275 rcop->op_flags |= OPf_KIDS;
3276 rcop->op_private = 1;
3279 /* establish postfix order */
3280 rcop->op_next = LINKLIST(repl);
3281 repl->op_next = (OP*)rcop;
3283 pm->op_pmreplroot = scalar((OP*)rcop);
3284 pm->op_pmreplstart = LINKLIST(rcop);
3293 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3296 NewOp(1101, svop, 1, SVOP);
3297 svop->op_type = type;
3298 svop->op_ppaddr = PL_ppaddr[type];
3300 svop->op_next = (OP*)svop;
3301 svop->op_flags = flags;
3302 if (PL_opargs[type] & OA_RETSCALAR)
3304 if (PL_opargs[type] & OA_TARGET)
3305 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3306 return CHECKOP(type, svop);
3310 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3313 NewOp(1101, padop, 1, PADOP);
3314 padop->op_type = type;
3315 padop->op_ppaddr = PL_ppaddr[type];
3316 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3317 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3318 PL_curpad[padop->op_padix] = sv;
3320 padop->op_next = (OP*)padop;
3321 padop->op_flags = flags;
3322 if (PL_opargs[type] & OA_RETSCALAR)
3324 if (PL_opargs[type] & OA_TARGET)
3325 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3326 return CHECKOP(type, padop);
3330 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3334 return newPADOP(type, flags, SvREFCNT_inc(gv));
3336 return newSVOP(type, flags, SvREFCNT_inc(gv));
3341 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3344 NewOp(1101, pvop, 1, PVOP);
3345 pvop->op_type = type;
3346 pvop->op_ppaddr = PL_ppaddr[type];
3348 pvop->op_next = (OP*)pvop;
3349 pvop->op_flags = flags;
3350 if (PL_opargs[type] & OA_RETSCALAR)
3352 if (PL_opargs[type] & OA_TARGET)
3353 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3354 return CHECKOP(type, pvop);
3358 Perl_package(pTHX_ OP *o)
3362 save_hptr(&PL_curstash);
3363 save_item(PL_curstname);
3368 name = SvPV(sv, len);
3369 PL_curstash = gv_stashpvn(name,len,TRUE);
3370 sv_setpvn(PL_curstname, name, len);
3374 deprecate("\"package\" with no arguments");
3375 sv_setpv(PL_curstname,"<none>");
3376 PL_curstash = Nullhv;
3378 PL_hints |= HINT_BLOCK_SCOPE;
3379 PL_copline = NOLINE;
3384 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3389 char *packname = Nullch;
3393 if (id->op_type != OP_CONST)
3394 Perl_croak(aTHX_ "Module name must be constant");
3398 if (version != Nullop) {
3399 SV *vesv = ((SVOP*)version)->op_sv;
3401 if (arg == Nullop && !SvNIOKp(vesv)) {
3408 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3409 Perl_croak(aTHX_ "Version number must be constant number");
3411 /* Make copy of id so we don't free it twice */
3412 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3414 /* Fake up a method call to VERSION */
3415 meth = newSVpvn("VERSION",7);
3416 sv_upgrade(meth, SVt_PVIV);
3417 (void)SvIOK_on(meth);
3418 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3419 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3420 append_elem(OP_LIST,
3421 prepend_elem(OP_LIST, pack, list(version)),
3422 newSVOP(OP_METHOD_NAMED, 0, meth)));
3426 /* Fake up an import/unimport */
3427 if (arg && arg->op_type == OP_STUB)
3428 imop = arg; /* no import on explicit () */
3429 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3430 imop = Nullop; /* use 5.0; */
3435 /* Make copy of id so we don't free it twice */
3436 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3438 /* Fake up a method call to import/unimport */
3439 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3440 (void)SvUPGRADE(meth, SVt_PVIV);
3441 (void)SvIOK_on(meth);
3442 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3443 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3444 append_elem(OP_LIST,
3445 prepend_elem(OP_LIST, pack, list(arg)),
3446 newSVOP(OP_METHOD_NAMED, 0, meth)));
3449 if (ckWARN(WARN_MISC) &&
3450 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3451 SvPOK(packsv = ((SVOP*)id)->op_sv))
3453 /* BEGIN will free the ops, so we need to make a copy */
3454 packlen = SvCUR(packsv);
3455 packname = savepvn(SvPVX(packsv), packlen);
3458 /* Fake up the BEGIN {}, which does its thing immediately. */
3460 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3463 append_elem(OP_LINESEQ,
3464 append_elem(OP_LINESEQ,
3465 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3466 newSTATEOP(0, Nullch, veop)),
3467 newSTATEOP(0, Nullch, imop) ));
3470 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3471 Perl_warner(aTHX_ WARN_MISC,
3472 "Package `%s' not found "
3473 "(did you use the incorrect case?)", packname);
3478 PL_hints |= HINT_BLOCK_SCOPE;
3479 PL_copline = NOLINE;
3484 =head1 Embedding Functions
3486 =for apidoc load_module
3488 Loads the module whose name is pointed to by the string part of name.
3489 Note that the actual module name, not its filename, should be given.
3490 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3491 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3492 (or 0 for no flags). ver, if specified, provides version semantics
3493 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3494 arguments can be used to specify arguments to the module's import()
3495 method, similar to C<use Foo::Bar VERSION LIST>.
3500 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3503 va_start(args, ver);
3504 vload_module(flags, name, ver, &args);
3508 #ifdef PERL_IMPLICIT_CONTEXT
3510 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3514 va_start(args, ver);
3515 vload_module(flags, name, ver, &args);
3521 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3523 OP *modname, *veop, *imop;
3525 modname = newSVOP(OP_CONST, 0, name);
3526 modname->op_private |= OPpCONST_BARE;
3528 veop = newSVOP(OP_CONST, 0, ver);
3532 if (flags & PERL_LOADMOD_NOIMPORT) {
3533 imop = sawparens(newNULLLIST());
3535 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3536 imop = va_arg(*args, OP*);
3541 sv = va_arg(*args, SV*);
3543 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3544 sv = va_arg(*args, SV*);
3548 line_t ocopline = PL_copline;
3549 int oexpect = PL_expect;
3551 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3552 veop, modname, imop);
3553 PL_expect = oexpect;
3554 PL_copline = ocopline;
3559 Perl_dofile(pTHX_ OP *term)
3564 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3565 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3566 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3568 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3569 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3570 append_elem(OP_LIST, term,
3571 scalar(newUNOP(OP_RV2CV, 0,
3576 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3582 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3584 return newBINOP(OP_LSLICE, flags,
3585 list(force_list(subscript)),
3586 list(force_list(listval)) );
3590 S_list_assignment(pTHX_ register OP *o)
3595 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3596 o = cUNOPo->op_first;
3598 if (o->op_type == OP_COND_EXPR) {
3599 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3600 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3605 yyerror("Assignment to both a list and a scalar");
3609 if (o->op_type == OP_LIST &&
3610 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3611 o->op_private & OPpLVAL_INTRO)
3614 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3615 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3616 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3619 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3622 if (o->op_type == OP_RV2SV)
3629 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3634 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3635 return newLOGOP(optype, 0,
3636 mod(scalar(left), optype),
3637 newUNOP(OP_SASSIGN, 0, scalar(right)));
3640 return newBINOP(optype, OPf_STACKED,
3641 mod(scalar(left), optype), scalar(right));
3645 if (list_assignment(left)) {
3649 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3650 left = mod(left, OP_AASSIGN);
3658 curop = list(force_list(left));
3659 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3660 o->op_private = 0 | (flags >> 8);
3661 for (curop = ((LISTOP*)curop)->op_first;
3662 curop; curop = curop->op_sibling)
3664 if (curop->op_type == OP_RV2HV &&
3665 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3666 o->op_private |= OPpASSIGN_HASH;
3670 if (!(left->op_private & OPpLVAL_INTRO)) {
3673 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3674 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3675 if (curop->op_type == OP_GV) {
3676 GV *gv = cGVOPx_gv(curop);
3677 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3679 SvCUR(gv) = PL_generation;
3681 else if (curop->op_type == OP_PADSV ||
3682 curop->op_type == OP_PADAV ||
3683 curop->op_type == OP_PADHV ||
3684 curop->op_type == OP_PADANY) {
3685 SV **svp = AvARRAY(PL_comppad_name);
3686 SV *sv = svp[curop->op_targ];
3687 if (SvCUR(sv) == PL_generation)
3689 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3691 else if (curop->op_type == OP_RV2CV)
3693 else if (curop->op_type == OP_RV2SV ||
3694 curop->op_type == OP_RV2AV ||
3695 curop->op_type == OP_RV2HV ||
3696 curop->op_type == OP_RV2GV) {
3697 if (lastop->op_type != OP_GV) /* funny deref? */
3700 else if (curop->op_type == OP_PUSHRE) {
3701 if (((PMOP*)curop)->op_pmreplroot) {
3703 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3705 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3707 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3709 SvCUR(gv) = PL_generation;
3718 o->op_private |= OPpASSIGN_COMMON;
3720 if (right && right->op_type == OP_SPLIT) {
3722 if ((tmpop = ((LISTOP*)right)->op_first) &&
3723 tmpop->op_type == OP_PUSHRE)
3725 PMOP *pm = (PMOP*)tmpop;
3726 if (left->op_type == OP_RV2AV &&
3727 !(left->op_private & OPpLVAL_INTRO) &&
3728 !(o->op_private & OPpASSIGN_COMMON) )
3730 tmpop = ((UNOP*)left)->op_first;
3731 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3733 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3734 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3736 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3737 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3739 pm->op_pmflags |= PMf_ONCE;
3740 tmpop = cUNOPo->op_first; /* to list (nulled) */
3741 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3742 tmpop->op_sibling = Nullop; /* don't free split */
3743 right->op_next = tmpop->op_next; /* fix starting loc */
3744 op_free(o); /* blow off assign */
3745 right->op_flags &= ~OPf_WANT;
3746 /* "I don't know and I don't care." */
3751 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3752 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3754 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3756 sv_setiv(sv, PL_modcount+1);
3764 right = newOP(OP_UNDEF, 0);
3765 if (right->op_type == OP_READLINE) {
3766 right->op_flags |= OPf_STACKED;
3767 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3770 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3771 o = newBINOP(OP_SASSIGN, flags,
3772 scalar(right), mod(scalar(left), OP_SASSIGN) );
3784 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3786 U32 seq = intro_my();
3789 NewOp(1101, cop, 1, COP);
3790 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3791 cop->op_type = OP_DBSTATE;
3792 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3795 cop->op_type = OP_NEXTSTATE;
3796 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3798 cop->op_flags = flags;
3799 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3801 cop->op_private |= NATIVE_HINTS;
3803 PL_compiling.op_private = cop->op_private;
3804 cop->op_next = (OP*)cop;
3807 cop->cop_label = label;
3808 PL_hints |= HINT_BLOCK_SCOPE;
3811 cop->cop_arybase = PL_curcop->cop_arybase;
3812 if (specialWARN(PL_curcop->cop_warnings))
3813 cop->cop_warnings = PL_curcop->cop_warnings ;
3815 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3816 if (specialCopIO(PL_curcop->cop_io))
3817 cop->cop_io = PL_curcop->cop_io;
3819 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3822 if (PL_copline == NOLINE)
3823 CopLINE_set(cop, CopLINE(PL_curcop));
3825 CopLINE_set(cop, PL_copline);
3826 PL_copline = NOLINE;
3829 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3831 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3833 CopSTASH_set(cop, PL_curstash);
3835 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3836 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3837 if (svp && *svp != &PL_sv_undef ) {
3838 (void)SvIOK_on(*svp);
3839 SvIVX(*svp) = PTR2IV(cop);
3843 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3846 /* "Introduce" my variables to visible status. */
3854 if (! PL_min_intro_pending)
3855 return PL_cop_seqmax;
3857 svp = AvARRAY(PL_comppad_name);
3858 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3859 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3860 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3861 SvNVX(sv) = (NV)PL_cop_seqmax;
3864 PL_min_intro_pending = 0;
3865 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3866 return PL_cop_seqmax++;
3870 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3872 return new_logop(type, flags, &first, &other);
3876 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3880 OP *first = *firstp;
3881 OP *other = *otherp;
3883 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3884 return newBINOP(type, flags, scalar(first), scalar(other));
3886 scalarboolean(first);
3887 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3888 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3889 if (type == OP_AND || type == OP_OR) {
3895 first = *firstp = cUNOPo->op_first;
3897 first->op_next = o->op_next;
3898 cUNOPo->op_first = Nullop;
3902 if (first->op_type == OP_CONST) {
3903 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3904 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3905 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3916 else if (first->op_type == OP_WANTARRAY) {
3922 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3923 OP *k1 = ((UNOP*)first)->op_first;
3924 OP *k2 = k1->op_sibling;
3926 switch (first->op_type)
3929 if (k2 && k2->op_type == OP_READLINE
3930 && (k2->op_flags & OPf_STACKED)
3931 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3933 warnop = k2->op_type;
3938 if (k1->op_type == OP_READDIR
3939 || k1->op_type == OP_GLOB
3940 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3941 || k1->op_type == OP_EACH)
3943 warnop = ((k1->op_type == OP_NULL)
3944 ? k1->op_targ : k1->op_type);
3949 line_t oldline = CopLINE(PL_curcop);
3950 CopLINE_set(PL_curcop, PL_copline);
3951 Perl_warner(aTHX_ WARN_MISC,
3952 "Value of %s%s can be \"0\"; test with defined()",
3954 ((warnop == OP_READLINE || warnop == OP_GLOB)
3955 ? " construct" : "() operator"));
3956 CopLINE_set(PL_curcop, oldline);
3963 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3964 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3966 NewOp(1101, logop, 1, LOGOP);
3968 logop->op_type = type;
3969 logop->op_ppaddr = PL_ppaddr[type];
3970 logop->op_first = first;
3971 logop->op_flags = flags | OPf_KIDS;
3972 logop->op_other = LINKLIST(other);
3973 logop->op_private = 1 | (flags >> 8);
3975 /* establish postfix order */
3976 logop->op_next = LINKLIST(first);
3977 first->op_next = (OP*)logop;
3978 first->op_sibling = other;
3980 o = newUNOP(OP_NULL, 0, (OP*)logop);
3987 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3994 return newLOGOP(OP_AND, 0, first, trueop);
3996 return newLOGOP(OP_OR, 0, first, falseop);
3998 scalarboolean(first);
3999 if (first->op_type == OP_CONST) {
4000 if (SvTRUE(((SVOP*)first)->op_sv)) {
4011 else if (first->op_type == OP_WANTARRAY) {
4015 NewOp(1101, logop, 1, LOGOP);
4016 logop->op_type = OP_COND_EXPR;
4017 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4018 logop->op_first = first;
4019 logop->op_flags = flags | OPf_KIDS;
4020 logop->op_private = 1 | (flags >> 8);
4021 logop->op_other = LINKLIST(trueop);
4022 logop->op_next = LINKLIST(falseop);
4025 /* establish postfix order */
4026 start = LINKLIST(first);
4027 first->op_next = (OP*)logop;
4029 first->op_sibling = trueop;
4030 trueop->op_sibling = falseop;
4031 o = newUNOP(OP_NULL, 0, (OP*)logop);
4033 trueop->op_next = falseop->op_next = o;
4040 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4048 NewOp(1101, range, 1, LOGOP);
4050 range->op_type = OP_RANGE;
4051 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4052 range->op_first = left;
4053 range->op_flags = OPf_KIDS;
4054 leftstart = LINKLIST(left);
4055 range->op_other = LINKLIST(right);
4056 range->op_private = 1 | (flags >> 8);
4058 left->op_sibling = right;
4060 range->op_next = (OP*)range;
4061 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4062 flop = newUNOP(OP_FLOP, 0, flip);
4063 o = newUNOP(OP_NULL, 0, flop);
4065 range->op_next = leftstart;
4067 left->op_next = flip;
4068 right->op_next = flop;
4070 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4071 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4072 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4073 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4075 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4076 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4079 if (!flip->op_private || !flop->op_private)
4080 linklist(o); /* blow off optimizer unless constant */
4086 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4090 int once = block && block->op_flags & OPf_SPECIAL &&
4091 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4094 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4095 return block; /* do {} while 0 does once */
4096 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4097 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4098 expr = newUNOP(OP_DEFINED, 0,
4099 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4100 } else if (expr->op_flags & OPf_KIDS) {
4101 OP *k1 = ((UNOP*)expr)->op_first;
4102 OP *k2 = (k1) ? k1->op_sibling : NULL;
4103 switch (expr->op_type) {
4105 if (k2 && k2->op_type == OP_READLINE
4106 && (k2->op_flags & OPf_STACKED)
4107 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4108 expr = newUNOP(OP_DEFINED, 0, expr);
4112 if (k1->op_type == OP_READDIR
4113 || k1->op_type == OP_GLOB
4114 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4115 || k1->op_type == OP_EACH)
4116 expr = newUNOP(OP_DEFINED, 0, expr);
4122 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4123 o = new_logop(OP_AND, 0, &expr, &listop);
4126 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4128 if (once && o != listop)
4129 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4132 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4134 o->op_flags |= flags;
4136 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4141 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4149 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4150 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4151 expr = newUNOP(OP_DEFINED, 0,
4152 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4153 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4154 OP *k1 = ((UNOP*)expr)->op_first;
4155 OP *k2 = (k1) ? k1->op_sibling : NULL;
4156 switch (expr->op_type) {
4158 if (k2 && k2->op_type == OP_READLINE
4159 && (k2->op_flags & OPf_STACKED)
4160 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4161 expr = newUNOP(OP_DEFINED, 0, expr);
4165 if (k1->op_type == OP_READDIR
4166 || k1->op_type == OP_GLOB
4167 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4168 || k1->op_type == OP_EACH)
4169 expr = newUNOP(OP_DEFINED, 0, expr);
4175 block = newOP(OP_NULL, 0);
4177 block = scope(block);
4181 next = LINKLIST(cont);
4184 OP *unstack = newOP(OP_UNSTACK, 0);
4187 cont = append_elem(OP_LINESEQ, cont, unstack);
4188 if ((line_t)whileline != NOLINE) {
4189 PL_copline = whileline;
4190 cont = append_elem(OP_LINESEQ, cont,
4191 newSTATEOP(0, Nullch, Nullop));
4195 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4196 redo = LINKLIST(listop);
4199 PL_copline = whileline;
4201 o = new_logop(OP_AND, 0, &expr, &listop);
4202 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4203 op_free(expr); /* oops, it's a while (0) */
4205 return Nullop; /* listop already freed by new_logop */
4208 ((LISTOP*)listop)->op_last->op_next =
4209 (o == listop ? redo : LINKLIST(o));
4215 NewOp(1101,loop,1,LOOP);
4216 loop->op_type = OP_ENTERLOOP;
4217 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4218 loop->op_private = 0;
4219 loop->op_next = (OP*)loop;
4222 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4224 loop->op_redoop = redo;
4225 loop->op_lastop = o;
4226 o->op_private |= loopflags;
4229 loop->op_nextop = next;
4231 loop->op_nextop = o;
4233 o->op_flags |= flags;
4234 o->op_private |= (flags >> 8);
4239 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4247 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4248 sv->op_type = OP_RV2GV;
4249 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4251 else if (sv->op_type == OP_PADSV) { /* private variable */
4252 padoff = sv->op_targ;
4257 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4258 padoff = sv->op_targ;
4260 iterflags |= OPf_SPECIAL;
4265 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4268 #ifdef USE_5005THREADS
4269 padoff = find_threadsv("_");
4270 iterflags |= OPf_SPECIAL;
4272 sv = newGVOP(OP_GV, 0, PL_defgv);
4275 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4276 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4277 iterflags |= OPf_STACKED;
4279 else if (expr->op_type == OP_NULL &&
4280 (expr->op_flags & OPf_KIDS) &&
4281 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4283 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4284 * set the STACKED flag to indicate that these values are to be
4285 * treated as min/max values by 'pp_iterinit'.
4287 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4288 LOGOP* range = (LOGOP*) flip->op_first;
4289 OP* left = range->op_first;
4290 OP* right = left->op_sibling;
4293 range->op_flags &= ~OPf_KIDS;
4294 range->op_first = Nullop;
4296 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4297 listop->op_first->op_next = range->op_next;
4298 left->op_next = range->op_other;
4299 right->op_next = (OP*)listop;
4300 listop->op_next = listop->op_first;
4303 expr = (OP*)(listop);
4305 iterflags |= OPf_STACKED;
4308 expr = mod(force_list(expr), OP_GREPSTART);
4312 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4313 append_elem(OP_LIST, expr, scalar(sv))));
4314 assert(!loop->op_next);
4315 #ifdef PL_OP_SLAB_ALLOC
4318 NewOp(1234,tmp,1,LOOP);
4319 Copy(loop,tmp,1,LOOP);
4324 Renew(loop, 1, LOOP);
4326 loop->op_targ = padoff;
4327 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4328 PL_copline = forline;
4329 return newSTATEOP(0, label, wop);
4333 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4338 if (type != OP_GOTO || label->op_type == OP_CONST) {
4339 /* "last()" means "last" */
4340 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4341 o = newOP(type, OPf_SPECIAL);
4343 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4344 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4350 if (label->op_type == OP_ENTERSUB)
4351 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4352 o = newUNOP(type, OPf_STACKED, label);
4354 PL_hints |= HINT_BLOCK_SCOPE;
4359 Perl_cv_undef(pTHX_ CV *cv)
4361 #ifdef USE_5005THREADS
4363 MUTEX_DESTROY(CvMUTEXP(cv));
4364 Safefree(CvMUTEXP(cv));
4367 #endif /* USE_5005THREADS */
4370 if (CvFILE(cv) && !CvXSUB(cv)) {
4371 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4372 Safefree(CvFILE(cv));
4377 if (!CvXSUB(cv) && CvROOT(cv)) {
4378 #ifdef USE_5005THREADS
4379 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4380 Perl_croak(aTHX_ "Can't undef active subroutine");
4383 Perl_croak(aTHX_ "Can't undef active subroutine");
4384 #endif /* USE_5005THREADS */
4387 SAVEVPTR(PL_curpad);
4390 op_free(CvROOT(cv));
4391 CvROOT(cv) = Nullop;
4394 SvPOK_off((SV*)cv); /* forget prototype */
4396 /* Since closure prototypes have the same lifetime as the containing
4397 * CV, they don't hold a refcount on the outside CV. This avoids
4398 * the refcount loop between the outer CV (which keeps a refcount to
4399 * the closure prototype in the pad entry for pp_anoncode()) and the
4400 * closure prototype, and the ensuing memory leak. --GSAR */
4401 if (!CvANON(cv) || CvCLONED(cv))
4402 SvREFCNT_dec(CvOUTSIDE(cv));
4403 CvOUTSIDE(cv) = Nullcv;
4405 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4408 if (CvPADLIST(cv)) {
4409 /* may be during global destruction */
4410 if (SvREFCNT(CvPADLIST(cv))) {
4411 I32 i = AvFILLp(CvPADLIST(cv));
4413 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4414 SV* sv = svp ? *svp : Nullsv;
4417 if (sv == (SV*)PL_comppad_name)
4418 PL_comppad_name = Nullav;
4419 else if (sv == (SV*)PL_comppad) {
4420 PL_comppad = Nullav;
4421 PL_curpad = Null(SV**);
4425 SvREFCNT_dec((SV*)CvPADLIST(cv));
4427 CvPADLIST(cv) = Nullav;
4435 #ifdef DEBUG_CLOSURES
4437 S_cv_dump(pTHX_ CV *cv)
4440 CV *outside = CvOUTSIDE(cv);
4441 AV* padlist = CvPADLIST(cv);
4448 PerlIO_printf(Perl_debug_log,
4449 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4451 (CvANON(cv) ? "ANON"
4452 : (cv == PL_main_cv) ? "MAIN"
4453 : CvUNIQUE(cv) ? "UNIQUE"
4454 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4457 : CvANON(outside) ? "ANON"
4458 : (outside == PL_main_cv) ? "MAIN"
4459 : CvUNIQUE(outside) ? "UNIQUE"
4460 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4465 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4466 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4467 pname = AvARRAY(pad_name);
4468 ppad = AvARRAY(pad);
4470 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4471 if (SvPOK(pname[ix]))
4472 PerlIO_printf(Perl_debug_log,
4473 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4474 (int)ix, PTR2UV(ppad[ix]),
4475 SvFAKE(pname[ix]) ? "FAKE " : "",
4477 (IV)I_32(SvNVX(pname[ix])),
4480 #endif /* DEBUGGING */
4482 #endif /* DEBUG_CLOSURES */
4485 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4489 AV* protopadlist = CvPADLIST(proto);
4490 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4491 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4492 SV** pname = AvARRAY(protopad_name);
4493 SV** ppad = AvARRAY(protopad);
4494 I32 fname = AvFILLp(protopad_name);
4495 I32 fpad = AvFILLp(protopad);
4499 assert(!CvUNIQUE(proto));
4503 SAVESPTR(PL_comppad_name);
4504 SAVESPTR(PL_compcv);
4506 cv = PL_compcv = (CV*)NEWSV(1104,0);
4507 sv_upgrade((SV *)cv, SvTYPE(proto));
4508 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4511 #ifdef USE_5005THREADS
4512 New(666, CvMUTEXP(cv), 1, perl_mutex);
4513 MUTEX_INIT(CvMUTEXP(cv));
4515 #endif /* USE_5005THREADS */
4517 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4518 : savepv(CvFILE(proto));
4520 CvFILE(cv) = CvFILE(proto);
4522 CvGV(cv) = CvGV(proto);
4523 CvSTASH(cv) = CvSTASH(proto);
4524 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4525 CvSTART(cv) = CvSTART(proto);
4527 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4530 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4532 PL_comppad_name = newAV();
4533 for (ix = fname; ix >= 0; ix--)
4534 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4536 PL_comppad = newAV();
4538 comppadlist = newAV();
4539 AvREAL_off(comppadlist);
4540 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4541 av_store(comppadlist, 1, (SV*)PL_comppad);
4542 CvPADLIST(cv) = comppadlist;
4543 av_fill(PL_comppad, AvFILLp(protopad));
4544 PL_curpad = AvARRAY(PL_comppad);
4546 av = newAV(); /* will be @_ */
4548 av_store(PL_comppad, 0, (SV*)av);
4549 AvFLAGS(av) = AVf_REIFY;
4551 for (ix = fpad; ix > 0; ix--) {
4552 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4553 if (namesv && namesv != &PL_sv_undef) {
4554 char *name = SvPVX(namesv); /* XXX */
4555 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4556 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4557 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4559 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4561 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4563 else { /* our own lexical */
4566 /* anon code -- we'll come back for it */
4567 sv = SvREFCNT_inc(ppad[ix]);
4569 else if (*name == '@')
4571 else if (*name == '%')
4580 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4581 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4584 SV* sv = NEWSV(0,0);
4590 /* Now that vars are all in place, clone nested closures. */
4592 for (ix = fpad; ix > 0; ix--) {
4593 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4595 && namesv != &PL_sv_undef
4596 && !(SvFLAGS(namesv) & SVf_FAKE)
4597 && *SvPVX(namesv) == '&'
4598 && CvCLONE(ppad[ix]))
4600 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4601 SvREFCNT_dec(ppad[ix]);
4604 PL_curpad[ix] = (SV*)kid;
4608 #ifdef DEBUG_CLOSURES
4609 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4611 PerlIO_printf(Perl_debug_log, " from:\n");
4613 PerlIO_printf(Perl_debug_log, " to:\n");
4620 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4622 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4624 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4631 Perl_cv_clone(pTHX_ CV *proto)
4634 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4635 cv = cv_clone2(proto, CvOUTSIDE(proto));
4636 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4641 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4643 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4644 SV* msg = sv_newmortal();
4648 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4649 sv_setpv(msg, "Prototype mismatch:");
4651 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4653 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4654 sv_catpv(msg, " vs ");
4656 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4658 sv_catpv(msg, "none");
4659 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4663 static void const_sv_xsub(pTHX_ CV* cv);
4667 =head1 Optree Manipulation Functions
4669 =for apidoc cv_const_sv
4671 If C<cv> is a constant sub eligible for inlining. returns the constant
4672 value returned by the sub. Otherwise, returns NULL.
4674 Constant subs can be created with C<newCONSTSUB> or as described in
4675 L<perlsub/"Constant Functions">.
4680 Perl_cv_const_sv(pTHX_ CV *cv)
4682 if (!cv || !CvCONST(cv))
4684 return (SV*)CvXSUBANY(cv).any_ptr;
4688 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4695 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4696 o = cLISTOPo->op_first->op_sibling;
4698 for (; o; o = o->op_next) {
4699 OPCODE type = o->op_type;
4701 if (sv && o->op_next == o)
4703 if (o->op_next != o) {
4704 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4706 if (type == OP_DBSTATE)
4709 if (type == OP_LEAVESUB || type == OP_RETURN)
4713 if (type == OP_CONST && cSVOPo->op_sv)
4715 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4716 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4717 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4721 /* We get here only from cv_clone2() while creating a closure.
4722 Copy the const value here instead of in cv_clone2 so that
4723 SvREADONLY_on doesn't lead to problems when leaving
4728 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4740 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4750 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4754 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4756 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4760 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4766 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4771 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4772 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4773 SV *sv = sv_newmortal();
4774 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4775 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4780 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4781 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4791 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4792 maximum a prototype before. */
4793 if (SvTYPE(gv) > SVt_NULL) {
4794 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4795 && ckWARN_d(WARN_PROTOTYPE))
4797 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4799 cv_ckproto((CV*)gv, NULL, ps);
4802 sv_setpv((SV*)gv, ps);
4804 sv_setiv((SV*)gv, -1);
4805 SvREFCNT_dec(PL_compcv);
4806 cv = PL_compcv = NULL;
4807 PL_sub_generation++;
4811 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4813 #ifdef GV_UNIQUE_CHECK
4814 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4815 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4819 if (!block || !ps || *ps || attrs)
4822 const_sv = op_const_sv(block, Nullcv);
4825 bool exists = CvROOT(cv) || CvXSUB(cv);
4827 #ifdef GV_UNIQUE_CHECK
4828 if (exists && GvUNIQUE(gv)) {
4829 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4833 /* if the subroutine doesn't exist and wasn't pre-declared
4834 * with a prototype, assume it will be AUTOLOADed,
4835 * skipping the prototype check
4837 if (exists || SvPOK(cv))
4838 cv_ckproto(cv, gv, ps);
4839 /* already defined (or promised)? */
4840 if (exists || GvASSUMECV(gv)) {
4841 if (!block && !attrs) {
4842 /* just a "sub foo;" when &foo is already defined */
4843 SAVEFREESV(PL_compcv);
4846 /* ahem, death to those who redefine active sort subs */
4847 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4848 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4850 if (ckWARN(WARN_REDEFINE)
4852 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4854 line_t oldline = CopLINE(PL_curcop);
4855 if (PL_copline != NOLINE)
4856 CopLINE_set(PL_curcop, PL_copline);
4857 Perl_warner(aTHX_ WARN_REDEFINE,
4858 CvCONST(cv) ? "Constant subroutine %s redefined"
4859 : "Subroutine %s redefined", name);
4860 CopLINE_set(PL_curcop, oldline);
4868 SvREFCNT_inc(const_sv);
4870 assert(!CvROOT(cv) && !CvCONST(cv));
4871 sv_setpv((SV*)cv, ""); /* prototype is "" */
4872 CvXSUBANY(cv).any_ptr = const_sv;
4873 CvXSUB(cv) = const_sv_xsub;
4878 cv = newCONSTSUB(NULL, name, const_sv);
4881 SvREFCNT_dec(PL_compcv);
4883 PL_sub_generation++;
4890 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4891 * before we clobber PL_compcv.
4895 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4896 stash = GvSTASH(CvGV(cv));
4897 else if (CvSTASH(cv))
4898 stash = CvSTASH(cv);
4900 stash = PL_curstash;
4903 /* possibly about to re-define existing subr -- ignore old cv */
4904 rcv = (SV*)PL_compcv;
4905 if (name && GvSTASH(gv))
4906 stash = GvSTASH(gv);
4908 stash = PL_curstash;
4910 apply_attrs(stash, rcv, attrs, FALSE);
4912 if (cv) { /* must reuse cv if autoloaded */
4914 /* got here with just attrs -- work done, so bug out */
4915 SAVEFREESV(PL_compcv);
4919 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4920 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4921 CvOUTSIDE(PL_compcv) = 0;
4922 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4923 CvPADLIST(PL_compcv) = 0;
4924 /* inner references to PL_compcv must be fixed up ... */
4926 AV *padlist = CvPADLIST(cv);
4927 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4928 AV *comppad = (AV*)AvARRAY(padlist)[1];
4929 SV **namepad = AvARRAY(comppad_name);
4930 SV **curpad = AvARRAY(comppad);
4931 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4932 SV *namesv = namepad[ix];
4933 if (namesv && namesv != &PL_sv_undef
4934 && *SvPVX(namesv) == '&')
4936 CV *innercv = (CV*)curpad[ix];
4937 if (CvOUTSIDE(innercv) == PL_compcv) {
4938 CvOUTSIDE(innercv) = cv;
4939 if (!CvANON(innercv) || CvCLONED(innercv)) {
4940 (void)SvREFCNT_inc(cv);
4941 SvREFCNT_dec(PL_compcv);
4947 /* ... before we throw it away */
4948 SvREFCNT_dec(PL_compcv);
4949 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4950 ++PL_sub_generation;
4957 PL_sub_generation++;
4961 CvFILE_set_from_cop(cv, PL_curcop);
4962 CvSTASH(cv) = PL_curstash;
4963 #ifdef USE_5005THREADS
4965 if (!CvMUTEXP(cv)) {
4966 New(666, CvMUTEXP(cv), 1, perl_mutex);
4967 MUTEX_INIT(CvMUTEXP(cv));
4969 #endif /* USE_5005THREADS */
4972 sv_setpv((SV*)cv, ps);
4974 if (PL_error_count) {
4978 char *s = strrchr(name, ':');
4980 if (strEQ(s, "BEGIN")) {
4982 "BEGIN not safe after errors--compilation aborted";
4983 if (PL_in_eval & EVAL_KEEPERR)
4984 Perl_croak(aTHX_ not_safe);
4986 /* force display of errors found but not reported */
4987 sv_catpv(ERRSV, not_safe);
4988 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4996 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4997 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5000 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5001 mod(scalarseq(block), OP_LEAVESUBLV));
5004 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5006 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5007 OpREFCNT_set(CvROOT(cv), 1);
5008 CvSTART(cv) = LINKLIST(CvROOT(cv));
5009 CvROOT(cv)->op_next = 0;
5010 CALL_PEEP(CvSTART(cv));
5012 /* now that optimizer has done its work, adjust pad values */
5014 SV **namep = AvARRAY(PL_comppad_name);
5015 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5018 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5021 * The only things that a clonable function needs in its
5022 * pad are references to outer lexicals and anonymous subs.
5023 * The rest are created anew during cloning.
5025 if (!((namesv = namep[ix]) != Nullsv &&
5026 namesv != &PL_sv_undef &&
5028 *SvPVX(namesv) == '&')))
5030 SvREFCNT_dec(PL_curpad[ix]);
5031 PL_curpad[ix] = Nullsv;
5034 assert(!CvCONST(cv));
5035 if (ps && !*ps && op_const_sv(block, cv))
5039 AV *av = newAV(); /* Will be @_ */
5041 av_store(PL_comppad, 0, (SV*)av);
5042 AvFLAGS(av) = AVf_REIFY;
5044 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5045 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5047 if (!SvPADMY(PL_curpad[ix]))
5048 SvPADTMP_on(PL_curpad[ix]);
5052 /* If a potential closure prototype, don't keep a refcount on outer CV.
5053 * This is okay as the lifetime of the prototype is tied to the
5054 * lifetime of the outer CV. Avoids memory leak due to reference
5057 SvREFCNT_dec(CvOUTSIDE(cv));
5059 if (name || aname) {
5061 char *tname = (name ? name : aname);
5063 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5064 SV *sv = NEWSV(0,0);
5065 SV *tmpstr = sv_newmortal();
5066 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5070 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5072 (long)PL_subline, (long)CopLINE(PL_curcop));
5073 gv_efullname3(tmpstr, gv, Nullch);
5074 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5075 hv = GvHVn(db_postponed);
5076 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5077 && (pcv = GvCV(db_postponed)))
5083 call_sv((SV*)pcv, G_DISCARD);
5087 if ((s = strrchr(tname,':')))
5092 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5095 if (strEQ(s, "BEGIN")) {
5096 I32 oldscope = PL_scopestack_ix;
5098 SAVECOPFILE(&PL_compiling);
5099 SAVECOPLINE(&PL_compiling);
5102 PL_beginav = newAV();
5103 DEBUG_x( dump_sub(gv) );
5104 av_push(PL_beginav, (SV*)cv);
5105 GvCV(gv) = 0; /* cv has been hijacked */
5106 call_list(oldscope, PL_beginav);
5108 PL_curcop = &PL_compiling;
5109 PL_compiling.op_private = PL_hints;
5112 else if (strEQ(s, "END") && !PL_error_count) {
5115 DEBUG_x( dump_sub(gv) );
5116 av_unshift(PL_endav, 1);
5117 av_store(PL_endav, 0, (SV*)cv);
5118 GvCV(gv) = 0; /* cv has been hijacked */
5120 else if (strEQ(s, "CHECK") && !PL_error_count) {
5122 PL_checkav = newAV();
5123 DEBUG_x( dump_sub(gv) );
5124 if (PL_main_start && ckWARN(WARN_VOID))
5125 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5126 av_unshift(PL_checkav, 1);
5127 av_store(PL_checkav, 0, (SV*)cv);
5128 GvCV(gv) = 0; /* cv has been hijacked */
5130 else if (strEQ(s, "INIT") && !PL_error_count) {
5132 PL_initav = newAV();
5133 DEBUG_x( dump_sub(gv) );
5134 if (PL_main_start && ckWARN(WARN_VOID))
5135 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5136 av_push(PL_initav, (SV*)cv);
5137 GvCV(gv) = 0; /* cv has been hijacked */
5142 PL_copline = NOLINE;
5147 /* XXX unsafe for threads if eval_owner isn't held */
5149 =for apidoc newCONSTSUB
5151 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5152 eligible for inlining at compile-time.
5158 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5164 SAVECOPLINE(PL_curcop);
5165 CopLINE_set(PL_curcop, PL_copline);
5168 PL_hints &= ~HINT_BLOCK_SCOPE;
5171 SAVESPTR(PL_curstash);
5172 SAVECOPSTASH(PL_curcop);
5173 PL_curstash = stash;
5175 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5177 CopSTASH(PL_curcop) = stash;
5181 cv = newXS(name, const_sv_xsub, __FILE__);
5182 CvXSUBANY(cv).any_ptr = sv;
5184 sv_setpv((SV*)cv, ""); /* prototype is "" */
5192 =for apidoc U||newXS
5194 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5200 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5202 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5205 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5207 /* just a cached method */
5211 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5212 /* already defined (or promised) */
5213 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5214 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5215 line_t oldline = CopLINE(PL_curcop);
5216 if (PL_copline != NOLINE)
5217 CopLINE_set(PL_curcop, PL_copline);
5218 Perl_warner(aTHX_ WARN_REDEFINE,
5219 CvCONST(cv) ? "Constant subroutine %s redefined"
5220 : "Subroutine %s redefined"
5222 CopLINE_set(PL_curcop, oldline);
5229 if (cv) /* must reuse cv if autoloaded */
5232 cv = (CV*)NEWSV(1105,0);
5233 sv_upgrade((SV *)cv, SVt_PVCV);
5237 PL_sub_generation++;
5241 #ifdef USE_5005THREADS
5242 New(666, CvMUTEXP(cv), 1, perl_mutex);
5243 MUTEX_INIT(CvMUTEXP(cv));
5245 #endif /* USE_5005THREADS */
5246 (void)gv_fetchfile(filename);
5247 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5248 an external constant string */
5249 CvXSUB(cv) = subaddr;
5252 char *s = strrchr(name,':');
5258 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5261 if (strEQ(s, "BEGIN")) {
5263 PL_beginav = newAV();
5264 av_push(PL_beginav, (SV*)cv);
5265 GvCV(gv) = 0; /* cv has been hijacked */
5267 else if (strEQ(s, "END")) {
5270 av_unshift(PL_endav, 1);
5271 av_store(PL_endav, 0, (SV*)cv);
5272 GvCV(gv) = 0; /* cv has been hijacked */
5274 else if (strEQ(s, "CHECK")) {
5276 PL_checkav = newAV();
5277 if (PL_main_start && ckWARN(WARN_VOID))
5278 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5279 av_unshift(PL_checkav, 1);
5280 av_store(PL_checkav, 0, (SV*)cv);
5281 GvCV(gv) = 0; /* cv has been hijacked */
5283 else if (strEQ(s, "INIT")) {
5285 PL_initav = newAV();
5286 if (PL_main_start && ckWARN(WARN_VOID))
5287 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5288 av_push(PL_initav, (SV*)cv);
5289 GvCV(gv) = 0; /* cv has been hijacked */
5300 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5309 name = SvPVx(cSVOPo->op_sv, n_a);
5312 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5313 #ifdef GV_UNIQUE_CHECK
5315 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5319 if ((cv = GvFORM(gv))) {
5320 if (ckWARN(WARN_REDEFINE)) {
5321 line_t oldline = CopLINE(PL_curcop);
5322 if (PL_copline != NOLINE)
5323 CopLINE_set(PL_curcop, PL_copline);
5324 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5325 CopLINE_set(PL_curcop, oldline);
5332 CvFILE_set_from_cop(cv, PL_curcop);
5334 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5335 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5336 SvPADTMP_on(PL_curpad[ix]);
5339 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5340 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5341 OpREFCNT_set(CvROOT(cv), 1);
5342 CvSTART(cv) = LINKLIST(CvROOT(cv));
5343 CvROOT(cv)->op_next = 0;
5344 CALL_PEEP(CvSTART(cv));
5346 PL_copline = NOLINE;
5351 Perl_newANONLIST(pTHX_ OP *o)
5353 return newUNOP(OP_REFGEN, 0,
5354 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5358 Perl_newANONHASH(pTHX_ OP *o)
5360 return newUNOP(OP_REFGEN, 0,
5361 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5365 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5367 return newANONATTRSUB(floor, proto, Nullop, block);
5371 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5373 return newUNOP(OP_REFGEN, 0,
5374 newSVOP(OP_ANONCODE, 0,
5375 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5379 Perl_oopsAV(pTHX_ OP *o)
5381 switch (o->op_type) {
5383 o->op_type = OP_PADAV;
5384 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5385 return ref(o, OP_RV2AV);
5388 o->op_type = OP_RV2AV;
5389 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5394 if (ckWARN_d(WARN_INTERNAL))
5395 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5402 Perl_oopsHV(pTHX_ OP *o)
5404 switch (o->op_type) {
5407 o->op_type = OP_PADHV;
5408 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5409 return ref(o, OP_RV2HV);
5413 o->op_type = OP_RV2HV;
5414 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5419 if (ckWARN_d(WARN_INTERNAL))
5420 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5427 Perl_newAVREF(pTHX_ OP *o)
5429 if (o->op_type == OP_PADANY) {
5430 o->op_type = OP_PADAV;
5431 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5434 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5435 && ckWARN(WARN_DEPRECATED)) {
5436 Perl_warner(aTHX_ WARN_DEPRECATED,
5437 "Using an array as a reference is deprecated");
5439 return newUNOP(OP_RV2AV, 0, scalar(o));
5443 Perl_newGVREF(pTHX_ I32 type, OP *o)
5445 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5446 return newUNOP(OP_NULL, 0, o);
5447 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5451 Perl_newHVREF(pTHX_ OP *o)
5453 if (o->op_type == OP_PADANY) {
5454 o->op_type = OP_PADHV;
5455 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5458 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5459 && ckWARN(WARN_DEPRECATED)) {
5460 Perl_warner(aTHX_ WARN_DEPRECATED,
5461 "Using a hash as a reference is deprecated");
5463 return newUNOP(OP_RV2HV, 0, scalar(o));
5467 Perl_oopsCV(pTHX_ OP *o)
5469 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5475 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5477 return newUNOP(OP_RV2CV, flags, scalar(o));
5481 Perl_newSVREF(pTHX_ OP *o)
5483 if (o->op_type == OP_PADANY) {
5484 o->op_type = OP_PADSV;
5485 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5488 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5489 o->op_flags |= OPpDONE_SVREF;
5492 return newUNOP(OP_RV2SV, 0, scalar(o));
5495 /* Check routines. */
5498 Perl_ck_anoncode(pTHX_ OP *o)
5503 name = NEWSV(1106,0);
5504 sv_upgrade(name, SVt_PVNV);
5505 sv_setpvn(name, "&", 1);
5508 ix = pad_alloc(o->op_type, SVs_PADMY);
5509 av_store(PL_comppad_name, ix, name);
5510 av_store(PL_comppad, ix, cSVOPo->op_sv);
5511 SvPADMY_on(cSVOPo->op_sv);
5512 cSVOPo->op_sv = Nullsv;
5513 cSVOPo->op_targ = ix;
5518 Perl_ck_bitop(pTHX_ OP *o)
5520 o->op_private = PL_hints;
5525 Perl_ck_concat(pTHX_ OP *o)
5527 if (cUNOPo->op_first->op_type == OP_CONCAT)
5528 o->op_flags |= OPf_STACKED;
5533 Perl_ck_spair(pTHX_ OP *o)
5535 if (o->op_flags & OPf_KIDS) {
5538 OPCODE type = o->op_type;
5539 o = modkids(ck_fun(o), type);
5540 kid = cUNOPo->op_first;
5541 newop = kUNOP->op_first->op_sibling;
5543 (newop->op_sibling ||
5544 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5545 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5546 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5550 op_free(kUNOP->op_first);
5551 kUNOP->op_first = newop;
5553 o->op_ppaddr = PL_ppaddr[++o->op_type];
5558 Perl_ck_delete(pTHX_ OP *o)
5562 if (o->op_flags & OPf_KIDS) {
5563 OP *kid = cUNOPo->op_first;
5564 switch (kid->op_type) {
5566 o->op_flags |= OPf_SPECIAL;
5569 o->op_private |= OPpSLICE;
5572 o->op_flags |= OPf_SPECIAL;
5577 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5586 Perl_ck_die(pTHX_ OP *o)
5589 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5595 Perl_ck_eof(pTHX_ OP *o)
5597 I32 type = o->op_type;
5599 if (o->op_flags & OPf_KIDS) {
5600 if (cLISTOPo->op_first->op_type == OP_STUB) {
5602 o = newUNOP(type, OPf_SPECIAL,
5603 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5611 Perl_ck_eval(pTHX_ OP *o)
5613 PL_hints |= HINT_BLOCK_SCOPE;
5614 if (o->op_flags & OPf_KIDS) {
5615 SVOP *kid = (SVOP*)cUNOPo->op_first;
5618 o->op_flags &= ~OPf_KIDS;
5621 else if (kid->op_type == OP_LINESEQ) {
5624 kid->op_next = o->op_next;
5625 cUNOPo->op_first = 0;
5628 NewOp(1101, enter, 1, LOGOP);
5629 enter->op_type = OP_ENTERTRY;
5630 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5631 enter->op_private = 0;
5633 /* establish postfix order */
5634 enter->op_next = (OP*)enter;
5636 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5637 o->op_type = OP_LEAVETRY;
5638 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5639 enter->op_other = o;
5647 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5649 o->op_targ = (PADOFFSET)PL_hints;
5654 Perl_ck_exit(pTHX_ OP *o)
5657 HV *table = GvHV(PL_hintgv);
5659 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5660 if (svp && *svp && SvTRUE(*svp))
5661 o->op_private |= OPpEXIT_VMSISH;
5663 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5669 Perl_ck_exec(pTHX_ OP *o)
5672 if (o->op_flags & OPf_STACKED) {
5674 kid = cUNOPo->op_first->op_sibling;
5675 if (kid->op_type == OP_RV2GV)
5684 Perl_ck_exists(pTHX_ OP *o)
5687 if (o->op_flags & OPf_KIDS) {
5688 OP *kid = cUNOPo->op_first;
5689 if (kid->op_type == OP_ENTERSUB) {
5690 (void) ref(kid, o->op_type);
5691 if (kid->op_type != OP_RV2CV && !PL_error_count)
5692 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5694 o->op_private |= OPpEXISTS_SUB;
5696 else if (kid->op_type == OP_AELEM)
5697 o->op_flags |= OPf_SPECIAL;
5698 else if (kid->op_type != OP_HELEM)
5699 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5708 Perl_ck_gvconst(pTHX_ register OP *o)
5710 o = fold_constants(o);
5711 if (o->op_type == OP_CONST)
5718 Perl_ck_rvconst(pTHX_ register OP *o)
5720 SVOP *kid = (SVOP*)cUNOPo->op_first;
5722 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5723 if (kid->op_type == OP_CONST) {
5727 SV *kidsv = kid->op_sv;
5730 /* Is it a constant from cv_const_sv()? */
5731 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5732 SV *rsv = SvRV(kidsv);
5733 int svtype = SvTYPE(rsv);
5734 char *badtype = Nullch;
5736 switch (o->op_type) {
5738 if (svtype > SVt_PVMG)
5739 badtype = "a SCALAR";
5742 if (svtype != SVt_PVAV)
5743 badtype = "an ARRAY";
5746 if (svtype != SVt_PVHV) {
5747 if (svtype == SVt_PVAV) { /* pseudohash? */
5748 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5749 if (ksv && SvROK(*ksv)
5750 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5759 if (svtype != SVt_PVCV)
5764 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5767 name = SvPV(kidsv, n_a);
5768 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5769 char *badthing = Nullch;
5770 switch (o->op_type) {
5772 badthing = "a SCALAR";
5775 badthing = "an ARRAY";
5778 badthing = "a HASH";
5783 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5787 * This is a little tricky. We only want to add the symbol if we
5788 * didn't add it in the lexer. Otherwise we get duplicate strict
5789 * warnings. But if we didn't add it in the lexer, we must at
5790 * least pretend like we wanted to add it even if it existed before,
5791 * or we get possible typo warnings. OPpCONST_ENTERED says
5792 * whether the lexer already added THIS instance of this symbol.
5794 iscv = (o->op_type == OP_RV2CV) * 2;
5796 gv = gv_fetchpv(name,
5797 iscv | !(kid->op_private & OPpCONST_ENTERED),
5800 : o->op_type == OP_RV2SV
5802 : o->op_type == OP_RV2AV
5804 : o->op_type == OP_RV2HV
5807 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5809 kid->op_type = OP_GV;
5810 SvREFCNT_dec(kid->op_sv);
5812 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5813 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5814 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5816 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5818 kid->op_sv = SvREFCNT_inc(gv);
5820 kid->op_private = 0;
5821 kid->op_ppaddr = PL_ppaddr[OP_GV];
5828 Perl_ck_ftst(pTHX_ OP *o)
5830 I32 type = o->op_type;
5832 if (o->op_flags & OPf_REF) {
5835 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5836 SVOP *kid = (SVOP*)cUNOPo->op_first;
5838 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5840 OP *newop = newGVOP(type, OPf_REF,
5841 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5848 if (type == OP_FTTTY)
5849 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5852 o = newUNOP(type, 0, newDEFSVOP());
5858 Perl_ck_fun(pTHX_ OP *o)
5864 int type = o->op_type;
5865 register I32 oa = PL_opargs[type] >> OASHIFT;
5867 if (o->op_flags & OPf_STACKED) {
5868 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5871 return no_fh_allowed(o);
5874 if (o->op_flags & OPf_KIDS) {
5876 tokid = &cLISTOPo->op_first;
5877 kid = cLISTOPo->op_first;
5878 if (kid->op_type == OP_PUSHMARK ||
5879 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5881 tokid = &kid->op_sibling;
5882 kid = kid->op_sibling;
5884 if (!kid && PL_opargs[type] & OA_DEFGV)
5885 *tokid = kid = newDEFSVOP();
5889 sibl = kid->op_sibling;
5892 /* list seen where single (scalar) arg expected? */
5893 if (numargs == 1 && !(oa >> 4)
5894 && kid->op_type == OP_LIST && type != OP_SCALAR)
5896 return too_many_arguments(o,PL_op_desc[type]);
5909 if ((type == OP_PUSH || type == OP_UNSHIFT)
5910 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5911 Perl_warner(aTHX_ WARN_SYNTAX,
5912 "Useless use of %s with no values",
5915 if (kid->op_type == OP_CONST &&
5916 (kid->op_private & OPpCONST_BARE))
5918 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5919 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5920 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5921 if (ckWARN(WARN_DEPRECATED))
5922 Perl_warner(aTHX_ WARN_DEPRECATED,
5923 "Array @%s missing the @ in argument %"IVdf" of %s()",
5924 name, (IV)numargs, PL_op_desc[type]);
5927 kid->op_sibling = sibl;
5930 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5931 bad_type(numargs, "array", PL_op_desc[type], kid);
5935 if (kid->op_type == OP_CONST &&
5936 (kid->op_private & OPpCONST_BARE))
5938 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5939 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5940 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5941 if (ckWARN(WARN_DEPRECATED))
5942 Perl_warner(aTHX_ WARN_DEPRECATED,
5943 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5944 name, (IV)numargs, PL_op_desc[type]);
5947 kid->op_sibling = sibl;
5950 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5951 bad_type(numargs, "hash", PL_op_desc[type], kid);
5956 OP *newop = newUNOP(OP_NULL, 0, kid);
5957 kid->op_sibling = 0;
5959 newop->op_next = newop;
5961 kid->op_sibling = sibl;
5966 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5967 if (kid->op_type == OP_CONST &&
5968 (kid->op_private & OPpCONST_BARE))
5970 OP *newop = newGVOP(OP_GV, 0,
5971 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5973 if (kid == cLISTOPo->op_last)
5974 cLISTOPo->op_last = newop;
5978 else if (kid->op_type == OP_READLINE) {
5979 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5980 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5983 I32 flags = OPf_SPECIAL;
5987 /* is this op a FH constructor? */
5988 if (is_handle_constructor(o,numargs)) {
5989 char *name = Nullch;
5993 /* Set a flag to tell rv2gv to vivify
5994 * need to "prove" flag does not mean something
5995 * else already - NI-S 1999/05/07
5998 if (kid->op_type == OP_PADSV) {
5999 SV **namep = av_fetch(PL_comppad_name,
6001 if (namep && *namep)
6002 name = SvPV(*namep, len);
6004 else if (kid->op_type == OP_RV2SV
6005 && kUNOP->op_first->op_type == OP_GV)
6007 GV *gv = cGVOPx_gv(kUNOP->op_first);
6009 len = GvNAMELEN(gv);
6011 else if (kid->op_type == OP_AELEM
6012 || kid->op_type == OP_HELEM)
6014 name = "__ANONIO__";
6020 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6021 namesv = PL_curpad[targ];
6022 (void)SvUPGRADE(namesv, SVt_PV);
6024 sv_setpvn(namesv, "$", 1);
6025 sv_catpvn(namesv, name, len);
6028 kid->op_sibling = 0;
6029 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6030 kid->op_targ = targ;
6031 kid->op_private |= priv;
6033 kid->op_sibling = sibl;
6039 mod(scalar(kid), type);
6043 tokid = &kid->op_sibling;
6044 kid = kid->op_sibling;
6046 o->op_private |= numargs;
6048 return too_many_arguments(o,OP_DESC(o));
6051 else if (PL_opargs[type] & OA_DEFGV) {
6053 return newUNOP(type, 0, newDEFSVOP());
6057 while (oa & OA_OPTIONAL)
6059 if (oa && oa != OA_LIST)
6060 return too_few_arguments(o,OP_DESC(o));
6066 Perl_ck_glob(pTHX_ OP *o)
6071 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6072 append_elem(OP_GLOB, o, newDEFSVOP());
6074 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6075 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6077 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6080 #if !defined(PERL_EXTERNAL_GLOB)
6081 /* XXX this can be tightened up and made more failsafe. */
6085 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
6087 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6088 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6089 GvCV(gv) = GvCV(glob_gv);
6090 SvREFCNT_inc((SV*)GvCV(gv));
6091 GvIMPORTED_CV_on(gv);
6094 #endif /* PERL_EXTERNAL_GLOB */
6096 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6097 append_elem(OP_GLOB, o,
6098 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6099 o->op_type = OP_LIST;
6100 o->op_ppaddr = PL_ppaddr[OP_LIST];
6101 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6102 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6103 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6104 append_elem(OP_LIST, o,
6105 scalar(newUNOP(OP_RV2CV, 0,
6106 newGVOP(OP_GV, 0, gv)))));
6107 o = newUNOP(OP_NULL, 0, ck_subr(o));
6108 o->op_targ = OP_GLOB; /* hint at what it used to be */
6111 gv = newGVgen("main");
6113 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6119 Perl_ck_grep(pTHX_ OP *o)
6123 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6125 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6126 NewOp(1101, gwop, 1, LOGOP);
6128 if (o->op_flags & OPf_STACKED) {
6131 kid = cLISTOPo->op_first->op_sibling;
6132 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6135 kid->op_next = (OP*)gwop;
6136 o->op_flags &= ~OPf_STACKED;
6138 kid = cLISTOPo->op_first->op_sibling;
6139 if (type == OP_MAPWHILE)
6146 kid = cLISTOPo->op_first->op_sibling;
6147 if (kid->op_type != OP_NULL)
6148 Perl_croak(aTHX_ "panic: ck_grep");
6149 kid = kUNOP->op_first;
6151 gwop->op_type = type;
6152 gwop->op_ppaddr = PL_ppaddr[type];
6153 gwop->op_first = listkids(o);
6154 gwop->op_flags |= OPf_KIDS;
6155 gwop->op_private = 1;
6156 gwop->op_other = LINKLIST(kid);
6157 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6158 kid->op_next = (OP*)gwop;
6160 kid = cLISTOPo->op_first->op_sibling;
6161 if (!kid || !kid->op_sibling)
6162 return too_few_arguments(o,OP_DESC(o));
6163 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6164 mod(kid, OP_GREPSTART);
6170 Perl_ck_index(pTHX_ OP *o)
6172 if (o->op_flags & OPf_KIDS) {
6173 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6175 kid = kid->op_sibling; /* get past "big" */
6176 if (kid && kid->op_type == OP_CONST)
6177 fbm_compile(((SVOP*)kid)->op_sv, 0);
6183 Perl_ck_lengthconst(pTHX_ OP *o)
6185 /* XXX length optimization goes here */
6190 Perl_ck_lfun(pTHX_ OP *o)
6192 OPCODE type = o->op_type;
6193 return modkids(ck_fun(o), type);
6197 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6199 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6200 switch (cUNOPo->op_first->op_type) {
6202 /* This is needed for
6203 if (defined %stash::)
6204 to work. Do not break Tk.
6206 break; /* Globals via GV can be undef */
6208 case OP_AASSIGN: /* Is this a good idea? */
6209 Perl_warner(aTHX_ WARN_DEPRECATED,
6210 "defined(@array) is deprecated");
6211 Perl_warner(aTHX_ WARN_DEPRECATED,
6212 "\t(Maybe you should just omit the defined()?)\n");
6215 /* This is needed for
6216 if (defined %stash::)
6217 to work. Do not break Tk.
6219 break; /* Globals via GV can be undef */
6221 Perl_warner(aTHX_ WARN_DEPRECATED,
6222 "defined(%%hash) is deprecated");
6223 Perl_warner(aTHX_ WARN_DEPRECATED,
6224 "\t(Maybe you should just omit the defined()?)\n");
6235 Perl_ck_rfun(pTHX_ OP *o)
6237 OPCODE type = o->op_type;
6238 return refkids(ck_fun(o), type);
6242 Perl_ck_listiob(pTHX_ OP *o)
6246 kid = cLISTOPo->op_first;
6249 kid = cLISTOPo->op_first;
6251 if (kid->op_type == OP_PUSHMARK)
6252 kid = kid->op_sibling;
6253 if (kid && o->op_flags & OPf_STACKED)
6254 kid = kid->op_sibling;
6255 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6256 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6257 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6258 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6259 cLISTOPo->op_first->op_sibling = kid;
6260 cLISTOPo->op_last = kid;
6261 kid = kid->op_sibling;
6266 append_elem(o->op_type, o, newDEFSVOP());
6272 Perl_ck_sassign(pTHX_ OP *o)
6274 OP *kid = cLISTOPo->op_first;
6275 /* has a disposable target? */
6276 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6277 && !(kid->op_flags & OPf_STACKED)
6278 /* Cannot steal the second time! */
6279 && !(kid->op_private & OPpTARGET_MY))
6281 OP *kkid = kid->op_sibling;
6283 /* Can just relocate the target. */
6284 if (kkid && kkid->op_type == OP_PADSV
6285 && !(kkid->op_private & OPpLVAL_INTRO))
6287 kid->op_targ = kkid->op_targ;
6289 /* Now we do not need PADSV and SASSIGN. */
6290 kid->op_sibling = o->op_sibling; /* NULL */
6291 cLISTOPo->op_first = NULL;
6294 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6302 Perl_ck_match(pTHX_ OP *o)
6304 o->op_private |= OPpRUNTIME;
6309 Perl_ck_method(pTHX_ OP *o)
6311 OP *kid = cUNOPo->op_first;
6312 if (kid->op_type == OP_CONST) {
6313 SV* sv = kSVOP->op_sv;
6314 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6316 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6317 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6320 kSVOP->op_sv = Nullsv;
6322 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6331 Perl_ck_null(pTHX_ OP *o)
6337 Perl_ck_open(pTHX_ OP *o)
6339 HV *table = GvHV(PL_hintgv);
6343 svp = hv_fetch(table, "open_IN", 7, FALSE);
6345 mode = mode_from_discipline(*svp);
6346 if (mode & O_BINARY)
6347 o->op_private |= OPpOPEN_IN_RAW;
6348 else if (mode & O_TEXT)
6349 o->op_private |= OPpOPEN_IN_CRLF;
6352 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6354 mode = mode_from_discipline(*svp);
6355 if (mode & O_BINARY)
6356 o->op_private |= OPpOPEN_OUT_RAW;
6357 else if (mode & O_TEXT)
6358 o->op_private |= OPpOPEN_OUT_CRLF;
6361 if (o->op_type == OP_BACKTICK)
6367 Perl_ck_repeat(pTHX_ OP *o)
6369 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6370 o->op_private |= OPpREPEAT_DOLIST;
6371 cBINOPo->op_first = force_list(cBINOPo->op_first);
6379 Perl_ck_require(pTHX_ OP *o)
6383 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6384 SVOP *kid = (SVOP*)cUNOPo->op_first;
6386 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6388 for (s = SvPVX(kid->op_sv); *s; s++) {
6389 if (*s == ':' && s[1] == ':') {
6391 Move(s+2, s+1, strlen(s+2)+1, char);
6392 --SvCUR(kid->op_sv);
6395 if (SvREADONLY(kid->op_sv)) {
6396 SvREADONLY_off(kid->op_sv);
6397 sv_catpvn(kid->op_sv, ".pm", 3);
6398 SvREADONLY_on(kid->op_sv);
6401 sv_catpvn(kid->op_sv, ".pm", 3);
6405 /* handle override, if any */
6406 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6407 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6408 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6410 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6411 OP *kid = cUNOPo->op_first;
6412 cUNOPo->op_first = 0;
6414 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6415 append_elem(OP_LIST, kid,
6416 scalar(newUNOP(OP_RV2CV, 0,
6425 Perl_ck_return(pTHX_ OP *o)
6428 if (CvLVALUE(PL_compcv)) {
6429 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6430 mod(kid, OP_LEAVESUBLV);
6437 Perl_ck_retarget(pTHX_ OP *o)
6439 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6446 Perl_ck_select(pTHX_ OP *o)
6449 if (o->op_flags & OPf_KIDS) {
6450 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6451 if (kid && kid->op_sibling) {
6452 o->op_type = OP_SSELECT;
6453 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6455 return fold_constants(o);
6459 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6460 if (kid && kid->op_type == OP_RV2GV)
6461 kid->op_private &= ~HINT_STRICT_REFS;
6466 Perl_ck_shift(pTHX_ OP *o)
6468 I32 type = o->op_type;
6470 if (!(o->op_flags & OPf_KIDS)) {
6474 #ifdef USE_5005THREADS
6475 if (!CvUNIQUE(PL_compcv)) {
6476 argop = newOP(OP_PADAV, OPf_REF);
6477 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6480 argop = newUNOP(OP_RV2AV, 0,
6481 scalar(newGVOP(OP_GV, 0,
6482 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6485 argop = newUNOP(OP_RV2AV, 0,
6486 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6487 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6488 #endif /* USE_5005THREADS */
6489 return newUNOP(type, 0, scalar(argop));
6491 return scalar(modkids(ck_fun(o), type));
6495 Perl_ck_sort(pTHX_ OP *o)
6499 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6501 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6502 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6504 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6506 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6508 if (kid->op_type == OP_SCOPE) {
6512 else if (kid->op_type == OP_LEAVE) {
6513 if (o->op_type == OP_SORT) {
6514 op_null(kid); /* wipe out leave */
6517 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6518 if (k->op_next == kid)
6520 /* don't descend into loops */
6521 else if (k->op_type == OP_ENTERLOOP
6522 || k->op_type == OP_ENTERITER)
6524 k = cLOOPx(k)->op_lastop;
6529 kid->op_next = 0; /* just disconnect the leave */
6530 k = kLISTOP->op_first;
6535 if (o->op_type == OP_SORT) {
6536 /* provide scalar context for comparison function/block */
6542 o->op_flags |= OPf_SPECIAL;
6544 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6547 firstkid = firstkid->op_sibling;
6550 /* provide list context for arguments */
6551 if (o->op_type == OP_SORT)
6558 S_simplify_sort(pTHX_ OP *o)
6560 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6564 if (!(o->op_flags & OPf_STACKED))
6566 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6567 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6568 kid = kUNOP->op_first; /* get past null */
6569 if (kid->op_type != OP_SCOPE)
6571 kid = kLISTOP->op_last; /* get past scope */
6572 switch(kid->op_type) {
6580 k = kid; /* remember this node*/
6581 if (kBINOP->op_first->op_type != OP_RV2SV)
6583 kid = kBINOP->op_first; /* get past cmp */
6584 if (kUNOP->op_first->op_type != OP_GV)
6586 kid = kUNOP->op_first; /* get past rv2sv */
6588 if (GvSTASH(gv) != PL_curstash)
6590 if (strEQ(GvNAME(gv), "a"))
6592 else if (strEQ(GvNAME(gv), "b"))
6596 kid = k; /* back to cmp */
6597 if (kBINOP->op_last->op_type != OP_RV2SV)
6599 kid = kBINOP->op_last; /* down to 2nd arg */
6600 if (kUNOP->op_first->op_type != OP_GV)
6602 kid = kUNOP->op_first; /* get past rv2sv */
6604 if (GvSTASH(gv) != PL_curstash
6606 ? strNE(GvNAME(gv), "a")
6607 : strNE(GvNAME(gv), "b")))
6609 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6611 o->op_private |= OPpSORT_REVERSE;
6612 if (k->op_type == OP_NCMP)
6613 o->op_private |= OPpSORT_NUMERIC;
6614 if (k->op_type == OP_I_NCMP)
6615 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6616 kid = cLISTOPo->op_first->op_sibling;
6617 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6618 op_free(kid); /* then delete it */
6622 Perl_ck_split(pTHX_ OP *o)
6626 if (o->op_flags & OPf_STACKED)
6627 return no_fh_allowed(o);
6629 kid = cLISTOPo->op_first;
6630 if (kid->op_type != OP_NULL)
6631 Perl_croak(aTHX_ "panic: ck_split");
6632 kid = kid->op_sibling;
6633 op_free(cLISTOPo->op_first);
6634 cLISTOPo->op_first = kid;
6636 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6637 cLISTOPo->op_last = kid; /* There was only one element previously */
6640 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6641 OP *sibl = kid->op_sibling;
6642 kid->op_sibling = 0;
6643 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6644 if (cLISTOPo->op_first == cLISTOPo->op_last)
6645 cLISTOPo->op_last = kid;
6646 cLISTOPo->op_first = kid;
6647 kid->op_sibling = sibl;
6650 kid->op_type = OP_PUSHRE;
6651 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6654 if (!kid->op_sibling)
6655 append_elem(OP_SPLIT, o, newDEFSVOP());
6657 kid = kid->op_sibling;
6660 if (!kid->op_sibling)
6661 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6663 kid = kid->op_sibling;
6666 if (kid->op_sibling)
6667 return too_many_arguments(o,OP_DESC(o));
6673 Perl_ck_join(pTHX_ OP *o)
6675 if (ckWARN(WARN_SYNTAX)) {
6676 OP *kid = cLISTOPo->op_first->op_sibling;
6677 if (kid && kid->op_type == OP_MATCH) {
6678 char *pmstr = "STRING";
6679 if (PM_GETRE(kPMOP))
6680 pmstr = PM_GETRE(kPMOP)->precomp;
6681 Perl_warner(aTHX_ WARN_SYNTAX,
6682 "/%s/ should probably be written as \"%s\"",
6690 Perl_ck_subr(pTHX_ OP *o)
6692 OP *prev = ((cUNOPo->op_first->op_sibling)
6693 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6694 OP *o2 = prev->op_sibling;
6701 I32 contextclass = 0;
6705 o->op_private |= OPpENTERSUB_HASTARG;
6706 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6707 if (cvop->op_type == OP_RV2CV) {
6709 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6710 op_null(cvop); /* disable rv2cv */
6711 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6712 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6713 GV *gv = cGVOPx_gv(tmpop);
6716 tmpop->op_private |= OPpEARLY_CV;
6717 else if (SvPOK(cv)) {
6718 namegv = CvANON(cv) ? gv : CvGV(cv);
6719 proto = SvPV((SV*)cv, n_a);
6723 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6724 if (o2->op_type == OP_CONST)
6725 o2->op_private &= ~OPpCONST_STRICT;
6726 else if (o2->op_type == OP_LIST) {
6727 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6728 if (o && o->op_type == OP_CONST)
6729 o->op_private &= ~OPpCONST_STRICT;
6732 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6733 if (PERLDB_SUB && PL_curstash != PL_debstash)
6734 o->op_private |= OPpENTERSUB_DB;
6735 while (o2 != cvop) {
6739 return too_many_arguments(o, gv_ename(namegv));
6757 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6759 arg == 1 ? "block or sub {}" : "sub {}",
6760 gv_ename(namegv), o2);
6763 /* '*' allows any scalar type, including bareword */
6766 if (o2->op_type == OP_RV2GV)
6767 goto wrapref; /* autoconvert GLOB -> GLOBref */
6768 else if (o2->op_type == OP_CONST)
6769 o2->op_private &= ~OPpCONST_STRICT;
6770 else if (o2->op_type == OP_ENTERSUB) {
6771 /* accidental subroutine, revert to bareword */
6772 OP *gvop = ((UNOP*)o2)->op_first;
6773 if (gvop && gvop->op_type == OP_NULL) {
6774 gvop = ((UNOP*)gvop)->op_first;
6776 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6779 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6780 (gvop = ((UNOP*)gvop)->op_first) &&
6781 gvop->op_type == OP_GV)
6783 GV *gv = cGVOPx_gv(gvop);
6784 OP *sibling = o2->op_sibling;
6785 SV *n = newSVpvn("",0);
6787 gv_fullname3(n, gv, "");
6788 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6789 sv_chop(n, SvPVX(n)+6);
6790 o2 = newSVOP(OP_CONST, 0, n);
6791 prev->op_sibling = o2;
6792 o2->op_sibling = sibling;
6808 if (contextclass++ == 0) {
6809 e = strchr(proto, ']');
6810 if (!e || e == proto)
6823 while (*--p != '[');
6824 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6825 gv_ename(namegv), o2);
6831 if (o2->op_type == OP_RV2GV)
6834 bad_type(arg, "symbol", gv_ename(namegv), o2);
6837 if (o2->op_type == OP_ENTERSUB)
6840 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6843 if (o2->op_type == OP_RV2SV ||
6844 o2->op_type == OP_PADSV ||
6845 o2->op_type == OP_HELEM ||
6846 o2->op_type == OP_AELEM ||
6847 o2->op_type == OP_THREADSV)
6850 bad_type(arg, "scalar", gv_ename(namegv), o2);
6853 if (o2->op_type == OP_RV2AV ||
6854 o2->op_type == OP_PADAV)
6857 bad_type(arg, "array", gv_ename(namegv), o2);
6860 if (o2->op_type == OP_RV2HV ||
6861 o2->op_type == OP_PADHV)
6864 bad_type(arg, "hash", gv_ename(namegv), o2);
6869 OP* sib = kid->op_sibling;
6870 kid->op_sibling = 0;
6871 o2 = newUNOP(OP_REFGEN, 0, kid);
6872 o2->op_sibling = sib;
6873 prev->op_sibling = o2;
6875 if (contextclass && e) {
6890 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6891 gv_ename(namegv), SvPV((SV*)cv, n_a));
6896 mod(o2, OP_ENTERSUB);
6898 o2 = o2->op_sibling;
6900 if (proto && !optional &&
6901 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6902 return too_few_arguments(o, gv_ename(namegv));
6907 Perl_ck_svconst(pTHX_ OP *o)
6909 SvREADONLY_on(cSVOPo->op_sv);
6914 Perl_ck_trunc(pTHX_ OP *o)
6916 if (o->op_flags & OPf_KIDS) {
6917 SVOP *kid = (SVOP*)cUNOPo->op_first;
6919 if (kid->op_type == OP_NULL)
6920 kid = (SVOP*)kid->op_sibling;
6921 if (kid && kid->op_type == OP_CONST &&
6922 (kid->op_private & OPpCONST_BARE))
6924 o->op_flags |= OPf_SPECIAL;
6925 kid->op_private &= ~OPpCONST_STRICT;
6932 Perl_ck_substr(pTHX_ OP *o)
6935 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6936 OP *kid = cLISTOPo->op_first;
6938 if (kid->op_type == OP_NULL)
6939 kid = kid->op_sibling;
6941 kid->op_flags |= OPf_MOD;
6947 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6950 Perl_peep(pTHX_ register OP *o)
6952 register OP* oldop = 0;
6955 if (!o || o->op_seq)
6959 SAVEVPTR(PL_curcop);
6960 for (; o; o = o->op_next) {
6966 switch (o->op_type) {
6970 PL_curcop = ((COP*)o); /* for warnings */
6971 o->op_seq = PL_op_seqmax++;
6975 if (cSVOPo->op_private & OPpCONST_STRICT)
6976 no_bareword_allowed(o);
6978 /* Relocate sv to the pad for thread safety.
6979 * Despite being a "constant", the SV is written to,
6980 * for reference counts, sv_upgrade() etc. */
6982 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6983 if (SvPADTMP(cSVOPo->op_sv)) {
6984 /* If op_sv is already a PADTMP then it is being used by
6985 * some pad, so make a copy. */
6986 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6987 SvREADONLY_on(PL_curpad[ix]);
6988 SvREFCNT_dec(cSVOPo->op_sv);
6991 SvREFCNT_dec(PL_curpad[ix]);
6992 SvPADTMP_on(cSVOPo->op_sv);
6993 PL_curpad[ix] = cSVOPo->op_sv;
6994 /* XXX I don't know how this isn't readonly already. */
6995 SvREADONLY_on(PL_curpad[ix]);
6997 cSVOPo->op_sv = Nullsv;
7001 o->op_seq = PL_op_seqmax++;
7005 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7006 if (o->op_next->op_private & OPpTARGET_MY) {
7007 if (o->op_flags & OPf_STACKED) /* chained concats */
7008 goto ignore_optimization;
7010 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7011 o->op_targ = o->op_next->op_targ;
7012 o->op_next->op_targ = 0;
7013 o->op_private |= OPpTARGET_MY;
7016 op_null(o->op_next);
7018 ignore_optimization:
7019 o->op_seq = PL_op_seqmax++;
7022 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7023 o->op_seq = PL_op_seqmax++;
7024 break; /* Scalar stub must produce undef. List stub is noop */
7028 if (o->op_targ == OP_NEXTSTATE
7029 || o->op_targ == OP_DBSTATE
7030 || o->op_targ == OP_SETSTATE)
7032 PL_curcop = ((COP*)o);
7034 /* XXX: We avoid setting op_seq here to prevent later calls
7035 to peep() from mistakenly concluding that optimisation
7036 has already occurred. This doesn't fix the real problem,
7037 though (See 20010220.007). AMS 20010719 */
7038 if (oldop && o->op_next) {
7039 oldop->op_next = o->op_next;
7047 if (oldop && o->op_next) {
7048 oldop->op_next = o->op_next;
7051 o->op_seq = PL_op_seqmax++;
7055 if (o->op_next->op_type == OP_RV2SV) {
7056 if (!(o->op_next->op_private & OPpDEREF)) {
7057 op_null(o->op_next);
7058 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7060 o->op_next = o->op_next->op_next;
7061 o->op_type = OP_GVSV;
7062 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7065 else if (o->op_next->op_type == OP_RV2AV) {
7066 OP* pop = o->op_next->op_next;
7068 if (pop && pop->op_type == OP_CONST &&
7069 (PL_op = pop->op_next) &&
7070 pop->op_next->op_type == OP_AELEM &&
7071 !(pop->op_next->op_private &
7072 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7073 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7078 op_null(o->op_next);
7079 op_null(pop->op_next);
7081 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7082 o->op_next = pop->op_next->op_next;
7083 o->op_type = OP_AELEMFAST;
7084 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7085 o->op_private = (U8)i;
7090 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7092 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7093 /* XXX could check prototype here instead of just carping */
7094 SV *sv = sv_newmortal();
7095 gv_efullname3(sv, gv, Nullch);
7096 Perl_warner(aTHX_ WARN_PROTOTYPE,
7097 "%s() called too early to check prototype",
7101 else if (o->op_next->op_type == OP_READLINE
7102 && o->op_next->op_next->op_type == OP_CONCAT
7103 && (o->op_next->op_next->op_flags & OPf_STACKED))
7105 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7106 o->op_type = OP_RCATLINE;
7107 o->op_flags |= OPf_STACKED;
7108 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7109 op_null(o->op_next->op_next);
7110 op_null(o->op_next);
7113 o->op_seq = PL_op_seqmax++;
7124 o->op_seq = PL_op_seqmax++;
7125 while (cLOGOP->op_other->op_type == OP_NULL)
7126 cLOGOP->op_other = cLOGOP->op_other->op_next;
7127 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7132 o->op_seq = PL_op_seqmax++;
7133 while (cLOOP->op_redoop->op_type == OP_NULL)
7134 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7135 peep(cLOOP->op_redoop);
7136 while (cLOOP->op_nextop->op_type == OP_NULL)
7137 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7138 peep(cLOOP->op_nextop);
7139 while (cLOOP->op_lastop->op_type == OP_NULL)
7140 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7141 peep(cLOOP->op_lastop);
7147 o->op_seq = PL_op_seqmax++;
7148 while (cPMOP->op_pmreplstart &&
7149 cPMOP->op_pmreplstart->op_type == OP_NULL)
7150 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7151 peep(cPMOP->op_pmreplstart);
7155 o->op_seq = PL_op_seqmax++;
7156 if (ckWARN(WARN_SYNTAX) && o->op_next
7157 && o->op_next->op_type == OP_NEXTSTATE) {
7158 if (o->op_next->op_sibling &&
7159 o->op_next->op_sibling->op_type != OP_EXIT &&
7160 o->op_next->op_sibling->op_type != OP_WARN &&
7161 o->op_next->op_sibling->op_type != OP_DIE) {
7162 line_t oldline = CopLINE(PL_curcop);
7164 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7165 Perl_warner(aTHX_ WARN_EXEC,
7166 "Statement unlikely to be reached");
7167 Perl_warner(aTHX_ WARN_EXEC,
7168 "\t(Maybe you meant system() when you said exec()?)\n");
7169 CopLINE_set(PL_curcop, oldline);
7178 SV **svp, **indsvp, *sv;
7183 o->op_seq = PL_op_seqmax++;
7185 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7188 /* Make the CONST have a shared SV */
7189 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7190 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7191 key = SvPV(sv, keylen);
7192 lexname = newSVpvn_share(key,
7193 SvUTF8(sv) ? -(I32)keylen : keylen,
7199 if ((o->op_private & (OPpLVAL_INTRO)))
7202 rop = (UNOP*)((BINOP*)o)->op_first;
7203 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7205 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7206 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7208 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7209 if (!fields || !GvHV(*fields))
7211 key = SvPV(*svp, keylen);
7212 indsvp = hv_fetch(GvHV(*fields), key,
7213 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7215 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7216 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7218 ind = SvIV(*indsvp);
7220 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7221 rop->op_type = OP_RV2AV;
7222 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7223 o->op_type = OP_AELEM;
7224 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7226 if (SvREADONLY(*svp))
7228 SvFLAGS(sv) |= (SvFLAGS(*svp)
7229 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7239 SV **svp, **indsvp, *sv;
7243 SVOP *first_key_op, *key_op;
7245 o->op_seq = PL_op_seqmax++;
7246 if ((o->op_private & (OPpLVAL_INTRO))
7247 /* I bet there's always a pushmark... */
7248 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7249 /* hmmm, no optimization if list contains only one key. */
7251 rop = (UNOP*)((LISTOP*)o)->op_last;
7252 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7254 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7255 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7257 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7258 if (!fields || !GvHV(*fields))
7260 /* Again guessing that the pushmark can be jumped over.... */
7261 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7262 ->op_first->op_sibling;
7263 /* Check that the key list contains only constants. */
7264 for (key_op = first_key_op; key_op;
7265 key_op = (SVOP*)key_op->op_sibling)
7266 if (key_op->op_type != OP_CONST)
7270 rop->op_type = OP_RV2AV;
7271 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7272 o->op_type = OP_ASLICE;
7273 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7274 for (key_op = first_key_op; key_op;
7275 key_op = (SVOP*)key_op->op_sibling) {
7276 svp = cSVOPx_svp(key_op);
7277 key = SvPV(*svp, keylen);
7278 indsvp = hv_fetch(GvHV(*fields), key,
7279 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7281 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7282 "in variable %s of type %s",
7283 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7285 ind = SvIV(*indsvp);
7287 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7289 if (SvREADONLY(*svp))
7291 SvFLAGS(sv) |= (SvFLAGS(*svp)
7292 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7300 o->op_seq = PL_op_seqmax++;
7310 char* Perl_custom_op_name(pTHX_ OP* o)
7312 IV index = PTR2IV(o->op_ppaddr);
7316 if (!PL_custom_op_names) /* This probably shouldn't happen */
7317 return PL_op_name[OP_CUSTOM];
7319 keysv = sv_2mortal(newSViv(index));
7321 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7323 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7325 return SvPV_nolen(HeVAL(he));
7328 char* Perl_custom_op_desc(pTHX_ OP* o)
7330 IV index = PTR2IV(o->op_ppaddr);
7334 if (!PL_custom_op_descs)
7335 return PL_op_desc[OP_CUSTOM];
7337 keysv = sv_2mortal(newSViv(index));
7339 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7341 return PL_op_desc[OP_CUSTOM];
7343 return SvPV_nolen(HeVAL(he));
7349 /* Efficient sub that returns a constant scalar value. */
7351 const_sv_xsub(pTHX_ CV* cv)
7356 Perl_croak(aTHX_ "usage: %s::%s()",
7357 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7361 ST(0) = (SV*)XSANY.any_ptr;