3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
47 if ((PL_OpSpace -= sz) < 0) {
48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
63 PL_OpPtr += PERL_SLAB_SIZE;
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
77 S_Slab_Free(pTHX_ void *op)
79 I32 **ptr = (I32 **) op;
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
86 #define PerlMemShared PerlMem
89 PerlMemShared_free(slab);
90 if (slab == PL_OpSlab) {
97 #define NewOp(m, var, c, type) Newz(m, var, c, type)
98 #define FreeOp(p) Safefree(p)
101 * In the following definition, the ", Nullop" is just to make the compiler
102 * think the expression is of the right type: croak actually does a Siglongjmp.
104 #define CHECKOP(type,o) \
105 ((PL_op_mask && PL_op_mask[type]) \
106 ? ( op_free((OP*)o), \
107 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
109 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
111 #define PAD_MAX 999999999
112 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
115 S_gv_ename(pTHX_ GV *gv)
118 SV* tmpsv = sv_newmortal();
119 gv_efullname3(tmpsv, gv, Nullch);
120 return SvPV(tmpsv,n_a);
124 S_no_fh_allowed(pTHX_ OP *o)
126 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
132 S_too_few_arguments(pTHX_ OP *o, char *name)
134 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
139 S_too_many_arguments(pTHX_ OP *o, char *name)
141 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
146 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
148 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
149 (int)n, name, t, OP_DESC(kid)));
153 S_no_bareword_allowed(pTHX_ OP *o)
155 qerror(Perl_mess(aTHX_
156 "Bareword \"%s\" not allowed while \"strict subs\" in use",
157 SvPV_nolen(cSVOPo_sv)));
160 /* "register" allocation */
163 Perl_pad_allocmy(pTHX_ char *name)
168 if (!(PL_in_my == KEY_our ||
170 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
171 (name[1] == '_' && (int)strlen(name) > 2)))
173 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
174 /* 1999-02-27 mjd@plover.com */
176 p = strchr(name, '\0');
177 /* The next block assumes the buffer is at least 205 chars
178 long. At present, it's always at least 256 chars. */
180 strcpy(name+200, "...");
186 /* Move everything else down one character */
187 for (; p-name > 2; p--)
189 name[2] = toCTRL(name[1]);
192 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
194 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
195 SV **svp = AvARRAY(PL_comppad_name);
196 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
197 PADOFFSET top = AvFILLp(PL_comppad_name);
198 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
200 && sv != &PL_sv_undef
201 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
202 && (PL_in_my != KEY_our
203 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
204 && strEQ(name, SvPVX(sv)))
206 Perl_warner(aTHX_ packWARN(WARN_MISC),
207 "\"%s\" variable %s masks earlier declaration in same %s",
208 (PL_in_my == KEY_our ? "our" : "my"),
210 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
215 if (PL_in_my == KEY_our) {
218 && sv != &PL_sv_undef
219 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
220 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
221 && strEQ(name, SvPVX(sv)))
223 Perl_warner(aTHX_ packWARN(WARN_MISC),
224 "\"our\" variable %s redeclared", name);
225 Perl_warner(aTHX_ packWARN(WARN_MISC),
226 "\t(Did you mean \"local\" instead of \"our\"?)\n");
229 } while ( off-- > 0 );
232 off = pad_alloc(OP_PADSV, SVs_PADMY);
234 sv_upgrade(sv, SVt_PVNV);
236 if (PL_in_my_stash) {
238 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
239 name, PL_in_my == KEY_our ? "our" : "my"));
240 SvFLAGS(sv) |= SVpad_TYPED;
241 (void)SvUPGRADE(sv, SVt_PVMG);
242 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
244 if (PL_in_my == KEY_our) {
245 (void)SvUPGRADE(sv, SVt_PVGV);
246 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
247 SvFLAGS(sv) |= SVpad_OUR;
249 av_store(PL_comppad_name, off, sv);
250 SvNVX(sv) = (NV)PAD_MAX;
251 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
252 if (!PL_min_intro_pending)
253 PL_min_intro_pending = off;
254 PL_max_intro_pending = off;
256 av_store(PL_comppad, off, (SV*)newAV());
257 else if (*name == '%')
258 av_store(PL_comppad, off, (SV*)newHV());
259 SvPADMY_on(PL_curpad[off]);
264 S_pad_addlex(pTHX_ SV *proto_namesv)
266 SV *namesv = NEWSV(1103,0);
267 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
268 sv_upgrade(namesv, SVt_PVNV);
269 sv_setpv(namesv, SvPVX(proto_namesv));
270 av_store(PL_comppad_name, newoff, namesv);
271 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
272 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
273 SvFAKE_on(namesv); /* A ref, not a real var */
274 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
275 SvFLAGS(namesv) |= SVpad_OUR;
276 (void)SvUPGRADE(namesv, SVt_PVGV);
277 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
279 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
280 SvFLAGS(namesv) |= SVpad_TYPED;
281 (void)SvUPGRADE(namesv, SVt_PVMG);
282 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
287 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
290 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
291 I32 cx_ix, I32 saweval, U32 flags)
297 register PERL_CONTEXT *cx;
299 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
300 AV *curlist = CvPADLIST(cv);
301 SV **svp = av_fetch(curlist, 0, FALSE);
304 if (!svp || *svp == &PL_sv_undef)
307 svp = AvARRAY(curname);
308 for (off = AvFILLp(curname); off > 0; off--) {
309 if ((sv = svp[off]) &&
310 sv != &PL_sv_undef &&
311 seq <= (U32)SvIVX(sv) &&
312 seq > (U32)I_32(SvNVX(sv)) &&
313 strEQ(SvPVX(sv), name))
324 return 0; /* don't clone from inactive stack frame */
328 oldpad = (AV*)AvARRAY(curlist)[depth];
329 oldsv = *av_fetch(oldpad, off, TRUE);
330 if (!newoff) { /* Not a mere clone operation. */
331 newoff = pad_addlex(sv);
332 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
333 /* "It's closures all the way down." */
334 CvCLONE_on(PL_compcv);
336 if (CvANON(PL_compcv))
337 oldsv = Nullsv; /* no need to keep ref */
342 bcv && bcv != cv && !CvCLONE(bcv);
343 bcv = CvOUTSIDE(bcv))
346 /* install the missing pad entry in intervening
347 * nested subs and mark them cloneable.
348 * XXX fix pad_foo() to not use globals */
349 AV *ocomppad_name = PL_comppad_name;
350 AV *ocomppad = PL_comppad;
351 SV **ocurpad = PL_curpad;
352 AV *padlist = CvPADLIST(bcv);
353 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
354 PL_comppad = (AV*)AvARRAY(padlist)[1];
355 PL_curpad = AvARRAY(PL_comppad);
357 PL_comppad_name = ocomppad_name;
358 PL_comppad = ocomppad;
363 if (ckWARN(WARN_CLOSURE)
364 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
366 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
367 "Variable \"%s\" may be unavailable",
375 else if (!CvUNIQUE(PL_compcv)) {
376 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
377 && !(SvFLAGS(sv) & SVpad_OUR))
379 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
380 "Variable \"%s\" will not stay shared", name);
384 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
390 if (flags & FINDLEX_NOSEARCH)
393 /* Nothing in current lexical context--try eval's context, if any.
394 * This is necessary to let the perldb get at lexically scoped variables.
395 * XXX This will also probably interact badly with eval tree caching.
398 for (i = cx_ix; i >= 0; i--) {
400 switch (CxTYPE(cx)) {
402 if (i == 0 && saweval) {
403 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
407 switch (cx->blk_eval.old_op_type) {
409 if (CxREALEVAL(cx)) {
412 seq = cxstack[i].blk_oldcop->cop_seq;
413 startcv = cxstack[i].blk_eval.cv;
414 if (startcv && CvOUTSIDE(startcv)) {
415 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
417 if (off) /* continue looking if not found here */
424 /* require/do must have their own scope */
433 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
434 saweval = i; /* so we know where we were called from */
435 seq = cxstack[i].blk_oldcop->cop_seq;
438 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
446 Perl_pad_findmy(pTHX_ char *name)
451 SV **svp = AvARRAY(PL_comppad_name);
452 U32 seq = PL_cop_seqmax;
456 #ifdef USE_5005THREADS
458 * Special case to get lexical (and hence per-thread) @_.
459 * XXX I need to find out how to tell at parse-time whether use
460 * of @_ should refer to a lexical (from a sub) or defgv (global
461 * scope and maybe weird sub-ish things like formats). See
462 * startsub in perly.y. It's possible that @_ could be lexical
463 * (at least from subs) even in non-threaded perl.
465 if (strEQ(name, "@_"))
466 return 0; /* success. (NOT_IN_PAD indicates failure) */
467 #endif /* USE_5005THREADS */
469 /* The one we're looking for is probably just before comppad_name_fill. */
470 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
471 if ((sv = svp[off]) &&
472 sv != &PL_sv_undef &&
474 (seq <= (U32)SvIVX(sv) &&
475 seq > (U32)I_32(SvNVX(sv)))) &&
476 strEQ(SvPVX(sv), name))
478 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
479 return (PADOFFSET)off;
480 pendoff = off; /* this pending def. will override import */
484 outside = CvOUTSIDE(PL_compcv);
486 /* Check if if we're compiling an eval'', and adjust seq to be the
487 * eval's seq number. This depends on eval'' having a non-null
488 * CvOUTSIDE() while it is being compiled. The eval'' itself is
489 * identified by CvEVAL being true and CvGV being null. */
490 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
491 cx = &cxstack[cxstack_ix];
493 seq = cx->blk_oldcop->cop_seq;
496 /* See if it's in a nested scope */
497 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
499 /* If there is a pending local definition, this new alias must die */
501 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
502 return off; /* pad_findlex returns 0 for failure...*/
504 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
508 Perl_pad_leavemy(pTHX_ I32 fill)
511 SV **svp = AvARRAY(PL_comppad_name);
513 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
514 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
515 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
516 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "%s never introduced", SvPVX(sv));
519 /* "Deintroduce" my variables that are leaving with this scope. */
520 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
521 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
522 SvIVX(sv) = PL_cop_seqmax;
527 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
532 if (AvARRAY(PL_comppad) != PL_curpad)
533 Perl_croak(aTHX_ "panic: pad_alloc");
534 if (PL_pad_reset_pending)
536 if (tmptype & SVs_PADMY) {
538 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
539 } while (SvPADBUSY(sv)); /* need a fresh one */
540 retval = AvFILLp(PL_comppad);
543 SV **names = AvARRAY(PL_comppad_name);
544 SSize_t names_fill = AvFILLp(PL_comppad_name);
547 * "foreach" index vars temporarily become aliases to non-"my"
548 * values. Thus we must skip, not just pad values that are
549 * marked as current pad values, but also those with names.
551 if (++PL_padix <= names_fill &&
552 (sv = names[PL_padix]) && sv != &PL_sv_undef)
554 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
555 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
556 !IS_PADGV(sv) && !IS_PADCONST(sv))
561 SvFLAGS(sv) |= tmptype;
562 PL_curpad = AvARRAY(PL_comppad);
563 #ifdef USE_5005THREADS
564 DEBUG_X(PerlIO_printf(Perl_debug_log,
565 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
566 PTR2UV(thr), PTR2UV(PL_curpad),
567 (long) retval, PL_op_name[optype]));
569 DEBUG_X(PerlIO_printf(Perl_debug_log,
570 "Pad 0x%"UVxf" alloc %ld for %s\n",
572 (long) retval, PL_op_name[optype]));
573 #endif /* USE_5005THREADS */
574 return (PADOFFSET)retval;
578 Perl_pad_sv(pTHX_ PADOFFSET po)
580 #ifdef USE_5005THREADS
581 DEBUG_X(PerlIO_printf(Perl_debug_log,
582 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
583 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
586 Perl_croak(aTHX_ "panic: pad_sv po");
587 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
588 PTR2UV(PL_curpad), (IV)po));
589 #endif /* USE_5005THREADS */
590 return PL_curpad[po]; /* eventually we'll turn this into a macro */
594 Perl_pad_free(pTHX_ PADOFFSET po)
598 if (AvARRAY(PL_comppad) != PL_curpad)
599 Perl_croak(aTHX_ "panic: pad_free curpad");
601 Perl_croak(aTHX_ "panic: pad_free po");
602 #ifdef USE_5005THREADS
603 DEBUG_X(PerlIO_printf(Perl_debug_log,
604 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
605 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
607 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
608 PTR2UV(PL_curpad), (IV)po));
609 #endif /* USE_5005THREADS */
610 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
611 SvPADTMP_off(PL_curpad[po]);
613 #ifdef PERL_COPY_ON_WRITE
614 if (SvIsCOW(PL_curpad[po])) {
615 sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
618 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
621 if ((I32)po < PL_padix)
626 Perl_pad_swipe(pTHX_ PADOFFSET po)
628 if (AvARRAY(PL_comppad) != PL_curpad)
629 Perl_croak(aTHX_ "panic: pad_swipe curpad");
631 Perl_croak(aTHX_ "panic: pad_swipe po");
632 #ifdef USE_5005THREADS
633 DEBUG_X(PerlIO_printf(Perl_debug_log,
634 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
635 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
637 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
638 PTR2UV(PL_curpad), (IV)po));
639 #endif /* USE_5005THREADS */
640 SvPADTMP_off(PL_curpad[po]);
641 PL_curpad[po] = NEWSV(1107,0);
642 SvPADTMP_on(PL_curpad[po]);
643 if ((I32)po < PL_padix)
647 /* XXX pad_reset() is currently disabled because it results in serious bugs.
648 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
649 * on the stack by OPs that use them, there are several ways to get an alias
650 * to a shared TARG. Such an alias will change randomly and unpredictably.
651 * We avoid doing this until we can think of a Better Way.
656 #ifdef USE_BROKEN_PAD_RESET
659 if (AvARRAY(PL_comppad) != PL_curpad)
660 Perl_croak(aTHX_ "panic: pad_reset curpad");
661 #ifdef USE_5005THREADS
662 DEBUG_X(PerlIO_printf(Perl_debug_log,
663 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
664 PTR2UV(thr), PTR2UV(PL_curpad)));
666 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
668 #endif /* USE_5005THREADS */
669 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
670 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
671 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
672 SvPADTMP_off(PL_curpad[po]);
674 PL_padix = PL_padix_floor;
677 PL_pad_reset_pending = FALSE;
680 #ifdef USE_5005THREADS
681 /* find_threadsv is not reentrant */
683 Perl_find_threadsv(pTHX_ const char *name)
688 /* We currently only handle names of a single character */
689 p = strchr(PL_threadsv_names, *name);
692 key = p - PL_threadsv_names;
693 MUTEX_LOCK(&thr->mutex);
694 svp = av_fetch(thr->threadsv, key, FALSE);
696 MUTEX_UNLOCK(&thr->mutex);
698 SV *sv = NEWSV(0, 0);
699 av_store(thr->threadsv, key, sv);
700 thr->threadsvp = AvARRAY(thr->threadsv);
701 MUTEX_UNLOCK(&thr->mutex);
703 * Some magic variables used to be automagically initialised
704 * in gv_fetchpv. Those which are now per-thread magicals get
705 * initialised here instead.
711 sv_setpv(sv, "\034");
712 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
717 PL_sawampersand = TRUE;
731 /* XXX %! tied to Errno.pm needs to be added here.
732 * See gv_fetchpv(). */
736 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
738 DEBUG_S(PerlIO_printf(Perl_error_log,
739 "find_threadsv: new SV %p for $%s%c\n",
740 sv, (*name < 32) ? "^" : "",
741 (*name < 32) ? toCTRL(*name) : *name));
745 #endif /* USE_5005THREADS */
750 Perl_op_free(pTHX_ OP *o)
752 register OP *kid, *nextkid;
755 if (!o || o->op_seq == (U16)-1)
758 if (o->op_private & OPpREFCOUNTED) {
759 switch (o->op_type) {
767 if (OpREFCNT_dec(o)) {
778 if (o->op_flags & OPf_KIDS) {
779 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
780 nextkid = kid->op_sibling; /* Get before next freeing kid */
786 type = (OPCODE)o->op_targ;
788 /* COP* is not cleared by op_clear() so that we may track line
789 * numbers etc even after null() */
790 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
798 Perl_op_clear(pTHX_ OP *o)
801 switch (o->op_type) {
802 case OP_NULL: /* Was holding old type, if any. */
803 case OP_ENTEREVAL: /* Was holding hints. */
804 #ifdef USE_5005THREADS
805 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
809 #ifdef USE_5005THREADS
811 if (!(o->op_flags & OPf_SPECIAL))
814 #endif /* USE_5005THREADS */
816 if (!(o->op_flags & OPf_REF)
817 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
824 if (cPADOPo->op_padix > 0) {
827 pad_swipe(cPADOPo->op_padix);
828 /* No GvIN_PAD_off(gv) here, because other references may still
829 * exist on the pad */
832 cPADOPo->op_padix = 0;
835 SvREFCNT_dec(cSVOPo->op_sv);
836 cSVOPo->op_sv = Nullsv;
839 case OP_METHOD_NAMED:
841 SvREFCNT_dec(cSVOPo->op_sv);
842 cSVOPo->op_sv = Nullsv;
848 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
852 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
853 SvREFCNT_dec(cSVOPo->op_sv);
854 cSVOPo->op_sv = Nullsv;
857 Safefree(cPVOPo->op_pv);
858 cPVOPo->op_pv = Nullch;
862 op_free(cPMOPo->op_pmreplroot);
866 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
868 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
869 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
870 /* No GvIN_PAD_off(gv) here, because other references may still
871 * exist on the pad */
876 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
883 HV *pmstash = PmopSTASH(cPMOPo);
884 if (pmstash && SvREFCNT(pmstash)) {
885 PMOP *pmop = HvPMROOT(pmstash);
886 PMOP *lastpmop = NULL;
888 if (cPMOPo == pmop) {
890 lastpmop->op_pmnext = pmop->op_pmnext;
892 HvPMROOT(pmstash) = pmop->op_pmnext;
896 pmop = pmop->op_pmnext;
899 PmopSTASH_free(cPMOPo);
901 cPMOPo->op_pmreplroot = Nullop;
902 /* we use the "SAFE" version of the PM_ macros here
903 * since sv_clean_all might release some PMOPs
904 * after PL_regex_padav has been cleared
905 * and the clearing of PL_regex_padav needs to
906 * happen before sv_clean_all
908 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
909 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
911 if(PL_regex_pad) { /* We could be in destruction */
912 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
913 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
914 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
921 if (o->op_targ > 0) {
922 pad_free(o->op_targ);
928 S_cop_free(pTHX_ COP* cop)
930 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
933 if (! specialWARN(cop->cop_warnings))
934 SvREFCNT_dec(cop->cop_warnings);
935 if (! specialCopIO(cop->cop_io)) {
939 char *s = SvPV(cop->cop_io,len);
940 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
943 SvREFCNT_dec(cop->cop_io);
949 Perl_op_null(pTHX_ OP *o)
951 if (o->op_type == OP_NULL)
954 o->op_targ = o->op_type;
955 o->op_type = OP_NULL;
956 o->op_ppaddr = PL_ppaddr[OP_NULL];
959 /* Contextualizers */
961 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
964 Perl_linklist(pTHX_ OP *o)
971 /* establish postfix order */
972 if (cUNOPo->op_first) {
973 o->op_next = LINKLIST(cUNOPo->op_first);
974 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
976 kid->op_next = LINKLIST(kid->op_sibling);
988 Perl_scalarkids(pTHX_ OP *o)
991 if (o && o->op_flags & OPf_KIDS) {
992 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
999 S_scalarboolean(pTHX_ OP *o)
1001 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
1002 if (ckWARN(WARN_SYNTAX)) {
1003 line_t oldline = CopLINE(PL_curcop);
1005 if (PL_copline != NOLINE)
1006 CopLINE_set(PL_curcop, PL_copline);
1007 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1008 CopLINE_set(PL_curcop, oldline);
1015 Perl_scalar(pTHX_ OP *o)
1019 /* assumes no premature commitment */
1020 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1021 || o->op_type == OP_RETURN)
1026 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1028 switch (o->op_type) {
1030 scalar(cBINOPo->op_first);
1035 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1039 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1040 if (!kPMOP->op_pmreplroot)
1041 deprecate_old("implicit split to @_");
1049 if (o->op_flags & OPf_KIDS) {
1050 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1056 kid = cLISTOPo->op_first;
1058 while ((kid = kid->op_sibling)) {
1059 if (kid->op_sibling)
1064 WITH_THR(PL_curcop = &PL_compiling);
1069 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1070 if (kid->op_sibling)
1075 WITH_THR(PL_curcop = &PL_compiling);
1078 if (ckWARN(WARN_VOID))
1079 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1085 Perl_scalarvoid(pTHX_ OP *o)
1092 if (o->op_type == OP_NEXTSTATE
1093 || o->op_type == OP_SETSTATE
1094 || o->op_type == OP_DBSTATE
1095 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1096 || o->op_targ == OP_SETSTATE
1097 || o->op_targ == OP_DBSTATE)))
1098 PL_curcop = (COP*)o; /* for warning below */
1100 /* assumes no premature commitment */
1101 want = o->op_flags & OPf_WANT;
1102 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1103 || o->op_type == OP_RETURN)
1108 if ((o->op_private & OPpTARGET_MY)
1109 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1111 return scalar(o); /* As if inside SASSIGN */
1114 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1116 switch (o->op_type) {
1118 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1122 if (o->op_flags & OPf_STACKED)
1126 if (o->op_private == 4)
1168 case OP_GETSOCKNAME:
1169 case OP_GETPEERNAME:
1174 case OP_GETPRIORITY:
1197 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1198 useless = OP_DESC(o);
1205 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1206 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1207 useless = "a variable";
1212 if (cSVOPo->op_private & OPpCONST_STRICT)
1213 no_bareword_allowed(o);
1215 if (ckWARN(WARN_VOID)) {
1216 useless = "a constant";
1217 /* the constants 0 and 1 are permitted as they are
1218 conventionally used as dummies in constructs like
1219 1 while some_condition_with_side_effects; */
1220 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1222 else if (SvPOK(sv)) {
1223 /* perl4's way of mixing documentation and code
1224 (before the invention of POD) was based on a
1225 trick to mix nroff and perl code. The trick was
1226 built upon these three nroff macros being used in
1227 void context. The pink camel has the details in
1228 the script wrapman near page 319. */
1229 if (strnEQ(SvPVX(sv), "di", 2) ||
1230 strnEQ(SvPVX(sv), "ds", 2) ||
1231 strnEQ(SvPVX(sv), "ig", 2))
1236 op_null(o); /* don't execute or even remember it */
1240 o->op_type = OP_PREINC; /* pre-increment is faster */
1241 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1245 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1246 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1253 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1258 if (o->op_flags & OPf_STACKED)
1265 if (!(o->op_flags & OPf_KIDS))
1274 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1281 /* all requires must return a boolean value */
1282 o->op_flags &= ~OPf_WANT;
1287 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1288 if (!kPMOP->op_pmreplroot)
1289 deprecate_old("implicit split to @_");
1293 if (useless && ckWARN(WARN_VOID))
1294 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1299 Perl_listkids(pTHX_ OP *o)
1302 if (o && o->op_flags & OPf_KIDS) {
1303 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1310 Perl_list(pTHX_ OP *o)
1314 /* assumes no premature commitment */
1315 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1316 || o->op_type == OP_RETURN)
1321 if ((o->op_private & OPpTARGET_MY)
1322 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1324 return o; /* As if inside SASSIGN */
1327 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1329 switch (o->op_type) {
1332 list(cBINOPo->op_first);
1337 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1345 if (!(o->op_flags & OPf_KIDS))
1347 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1348 list(cBINOPo->op_first);
1349 return gen_constant_list(o);
1356 kid = cLISTOPo->op_first;
1358 while ((kid = kid->op_sibling)) {
1359 if (kid->op_sibling)
1364 WITH_THR(PL_curcop = &PL_compiling);
1368 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1369 if (kid->op_sibling)
1374 WITH_THR(PL_curcop = &PL_compiling);
1377 /* all requires must return a boolean value */
1378 o->op_flags &= ~OPf_WANT;
1385 Perl_scalarseq(pTHX_ OP *o)
1390 if (o->op_type == OP_LINESEQ ||
1391 o->op_type == OP_SCOPE ||
1392 o->op_type == OP_LEAVE ||
1393 o->op_type == OP_LEAVETRY)
1395 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1396 if (kid->op_sibling) {
1400 PL_curcop = &PL_compiling;
1402 o->op_flags &= ~OPf_PARENS;
1403 if (PL_hints & HINT_BLOCK_SCOPE)
1404 o->op_flags |= OPf_PARENS;
1407 o = newOP(OP_STUB, 0);
1412 S_modkids(pTHX_ OP *o, I32 type)
1415 if (o && o->op_flags & OPf_KIDS) {
1416 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1423 Perl_mod(pTHX_ OP *o, I32 type)
1428 if (!o || PL_error_count)
1431 if ((o->op_private & OPpTARGET_MY)
1432 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1437 switch (o->op_type) {
1442 if (!(o->op_private & (OPpCONST_ARYBASE)))
1444 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1445 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1449 SAVEI32(PL_compiling.cop_arybase);
1450 PL_compiling.cop_arybase = 0;
1452 else if (type == OP_REFGEN)
1455 Perl_croak(aTHX_ "That use of $[ is unsupported");
1458 if (o->op_flags & OPf_PARENS)
1462 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1463 !(o->op_flags & OPf_STACKED)) {
1464 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1465 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1466 assert(cUNOPo->op_first->op_type == OP_NULL);
1467 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1470 else if (o->op_private & OPpENTERSUB_NOMOD)
1472 else { /* lvalue subroutine call */
1473 o->op_private |= OPpLVAL_INTRO;
1474 PL_modcount = RETURN_UNLIMITED_NUMBER;
1475 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1476 /* Backward compatibility mode: */
1477 o->op_private |= OPpENTERSUB_INARGS;
1480 else { /* Compile-time error message: */
1481 OP *kid = cUNOPo->op_first;
1485 if (kid->op_type == OP_PUSHMARK)
1487 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1489 "panic: unexpected lvalue entersub "
1490 "args: type/targ %ld:%"UVuf,
1491 (long)kid->op_type, (UV)kid->op_targ);
1492 kid = kLISTOP->op_first;
1494 while (kid->op_sibling)
1495 kid = kid->op_sibling;
1496 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1498 if (kid->op_type == OP_METHOD_NAMED
1499 || kid->op_type == OP_METHOD)
1503 NewOp(1101, newop, 1, UNOP);
1504 newop->op_type = OP_RV2CV;
1505 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1506 newop->op_first = Nullop;
1507 newop->op_next = (OP*)newop;
1508 kid->op_sibling = (OP*)newop;
1509 newop->op_private |= OPpLVAL_INTRO;
1513 if (kid->op_type != OP_RV2CV)
1515 "panic: unexpected lvalue entersub "
1516 "entry via type/targ %ld:%"UVuf,
1517 (long)kid->op_type, (UV)kid->op_targ);
1518 kid->op_private |= OPpLVAL_INTRO;
1519 break; /* Postpone until runtime */
1523 kid = kUNOP->op_first;
1524 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1525 kid = kUNOP->op_first;
1526 if (kid->op_type == OP_NULL)
1528 "Unexpected constant lvalue entersub "
1529 "entry via type/targ %ld:%"UVuf,
1530 (long)kid->op_type, (UV)kid->op_targ);
1531 if (kid->op_type != OP_GV) {
1532 /* Restore RV2CV to check lvalueness */
1534 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1535 okid->op_next = kid->op_next;
1536 kid->op_next = okid;
1539 okid->op_next = Nullop;
1540 okid->op_type = OP_RV2CV;
1542 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1543 okid->op_private |= OPpLVAL_INTRO;
1547 cv = GvCV(kGVOP_gv);
1557 /* grep, foreach, subcalls, refgen */
1558 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1560 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1561 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1563 : (o->op_type == OP_ENTERSUB
1564 ? "non-lvalue subroutine call"
1566 type ? PL_op_desc[type] : "local"));
1580 case OP_RIGHT_SHIFT:
1589 if (!(o->op_flags & OPf_STACKED))
1595 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1601 if (!type && cUNOPo->op_first->op_type != OP_GV)
1602 Perl_croak(aTHX_ "Can't localize through a reference");
1603 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1604 PL_modcount = RETURN_UNLIMITED_NUMBER;
1605 return o; /* Treat \(@foo) like ordinary list. */
1609 if (scalar_mod_type(o, type))
1611 ref(cUNOPo->op_first, o->op_type);
1615 if (type == OP_LEAVESUBLV)
1616 o->op_private |= OPpMAYBE_LVSUB;
1621 PL_modcount = RETURN_UNLIMITED_NUMBER;
1624 if (!type && cUNOPo->op_first->op_type != OP_GV)
1625 Perl_croak(aTHX_ "Can't localize through a reference");
1626 ref(cUNOPo->op_first, o->op_type);
1630 PL_hints |= HINT_BLOCK_SCOPE;
1641 PL_modcount = RETURN_UNLIMITED_NUMBER;
1642 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1643 return o; /* Treat \(@foo) like ordinary list. */
1644 if (scalar_mod_type(o, type))
1646 if (type == OP_LEAVESUBLV)
1647 o->op_private |= OPpMAYBE_LVSUB;
1652 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1653 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1656 #ifdef USE_5005THREADS
1658 PL_modcount++; /* XXX ??? */
1660 #endif /* USE_5005THREADS */
1666 if (type != OP_SASSIGN)
1670 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1675 if (type == OP_LEAVESUBLV)
1676 o->op_private |= OPpMAYBE_LVSUB;
1678 pad_free(o->op_targ);
1679 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1680 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1681 if (o->op_flags & OPf_KIDS)
1682 mod(cBINOPo->op_first->op_sibling, type);
1687 ref(cBINOPo->op_first, o->op_type);
1688 if (type == OP_ENTERSUB &&
1689 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1690 o->op_private |= OPpLVAL_DEFER;
1691 if (type == OP_LEAVESUBLV)
1692 o->op_private |= OPpMAYBE_LVSUB;
1700 if (o->op_flags & OPf_KIDS)
1701 mod(cLISTOPo->op_last, type);
1705 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1707 else if (!(o->op_flags & OPf_KIDS))
1709 if (o->op_targ != OP_LIST) {
1710 mod(cBINOPo->op_first, type);
1715 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1720 if (type != OP_LEAVESUBLV)
1722 break; /* mod()ing was handled by ck_return() */
1725 /* [20011101.069] File test operators interpret OPf_REF to mean that
1726 their argument is a filehandle; thus \stat(".") should not set
1728 if (type == OP_REFGEN &&
1729 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1732 if (type != OP_LEAVESUBLV)
1733 o->op_flags |= OPf_MOD;
1735 if (type == OP_AASSIGN || type == OP_SASSIGN)
1736 o->op_flags |= OPf_SPECIAL|OPf_REF;
1738 o->op_private |= OPpLVAL_INTRO;
1739 o->op_flags &= ~OPf_SPECIAL;
1740 PL_hints |= HINT_BLOCK_SCOPE;
1742 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1743 && type != OP_LEAVESUBLV)
1744 o->op_flags |= OPf_REF;
1749 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1753 if (o->op_type == OP_RV2GV)
1777 case OP_RIGHT_SHIFT:
1796 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1798 switch (o->op_type) {
1806 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1819 Perl_refkids(pTHX_ OP *o, I32 type)
1822 if (o && o->op_flags & OPf_KIDS) {
1823 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1830 Perl_ref(pTHX_ OP *o, I32 type)
1834 if (!o || PL_error_count)
1837 switch (o->op_type) {
1839 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1840 !(o->op_flags & OPf_STACKED)) {
1841 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1842 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1843 assert(cUNOPo->op_first->op_type == OP_NULL);
1844 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1845 o->op_flags |= OPf_SPECIAL;
1850 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1854 if (type == OP_DEFINED)
1855 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1856 ref(cUNOPo->op_first, o->op_type);
1859 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1860 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1861 : type == OP_RV2HV ? OPpDEREF_HV
1863 o->op_flags |= OPf_MOD;
1868 o->op_flags |= OPf_MOD; /* XXX ??? */
1873 o->op_flags |= OPf_REF;
1876 if (type == OP_DEFINED)
1877 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1878 ref(cUNOPo->op_first, o->op_type);
1883 o->op_flags |= OPf_REF;
1888 if (!(o->op_flags & OPf_KIDS))
1890 ref(cBINOPo->op_first, type);
1894 ref(cBINOPo->op_first, o->op_type);
1895 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1896 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1897 : type == OP_RV2HV ? OPpDEREF_HV
1899 o->op_flags |= OPf_MOD;
1907 if (!(o->op_flags & OPf_KIDS))
1909 ref(cLISTOPo->op_last, type);
1919 S_dup_attrlist(pTHX_ OP *o)
1923 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1924 * where the first kid is OP_PUSHMARK and the remaining ones
1925 * are OP_CONST. We need to push the OP_CONST values.
1927 if (o->op_type == OP_CONST)
1928 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1930 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1931 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1932 if (o->op_type == OP_CONST)
1933 rop = append_elem(OP_LIST, rop,
1934 newSVOP(OP_CONST, o->op_flags,
1935 SvREFCNT_inc(cSVOPo->op_sv)));
1942 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1946 /* fake up C<use attributes $pkg,$rv,@attrs> */
1947 ENTER; /* need to protect against side-effects of 'use' */
1950 stashsv = newSVpv(HvNAME(stash), 0);
1952 stashsv = &PL_sv_no;
1954 #define ATTRSMODULE "attributes"
1955 #define ATTRSMODULE_PM "attributes.pm"
1959 /* Don't force the C<use> if we don't need it. */
1960 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1961 sizeof(ATTRSMODULE_PM)-1, 0);
1962 if (svp && *svp != &PL_sv_undef)
1963 ; /* already in %INC */
1965 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1966 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1970 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1971 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1973 prepend_elem(OP_LIST,
1974 newSVOP(OP_CONST, 0, stashsv),
1975 prepend_elem(OP_LIST,
1976 newSVOP(OP_CONST, 0,
1978 dup_attrlist(attrs))));
1984 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1986 OP *pack, *imop, *arg;
1992 assert(target->op_type == OP_PADSV ||
1993 target->op_type == OP_PADHV ||
1994 target->op_type == OP_PADAV);
1996 /* Ensure that attributes.pm is loaded. */
1997 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1999 /* Need package name for method call. */
2000 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
2002 /* Build up the real arg-list. */
2004 stashsv = newSVpv(HvNAME(stash), 0);
2006 stashsv = &PL_sv_no;
2007 arg = newOP(OP_PADSV, 0);
2008 arg->op_targ = target->op_targ;
2009 arg = prepend_elem(OP_LIST,
2010 newSVOP(OP_CONST, 0, stashsv),
2011 prepend_elem(OP_LIST,
2012 newUNOP(OP_REFGEN, 0,
2013 mod(arg, OP_REFGEN)),
2014 dup_attrlist(attrs)));
2016 /* Fake up a method call to import */
2017 meth = newSVpvn("import", 6);
2018 (void)SvUPGRADE(meth, SVt_PVIV);
2019 (void)SvIOK_on(meth);
2020 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2021 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2022 append_elem(OP_LIST,
2023 prepend_elem(OP_LIST, pack, list(arg)),
2024 newSVOP(OP_METHOD_NAMED, 0, meth)));
2025 imop->op_private |= OPpENTERSUB_NOMOD;
2027 /* Combine the ops. */
2028 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2032 =notfor apidoc apply_attrs_string
2034 Attempts to apply a list of attributes specified by the C<attrstr> and
2035 C<len> arguments to the subroutine identified by the C<cv> argument which
2036 is expected to be associated with the package identified by the C<stashpv>
2037 argument (see L<attributes>). It gets this wrong, though, in that it
2038 does not correctly identify the boundaries of the individual attribute
2039 specifications within C<attrstr>. This is not really intended for the
2040 public API, but has to be listed here for systems such as AIX which
2041 need an explicit export list for symbols. (It's called from XS code
2042 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2043 to respect attribute syntax properly would be welcome.
2049 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2050 char *attrstr, STRLEN len)
2055 len = strlen(attrstr);
2059 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2061 char *sstr = attrstr;
2062 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2063 attrs = append_elem(OP_LIST, attrs,
2064 newSVOP(OP_CONST, 0,
2065 newSVpvn(sstr, attrstr-sstr)));
2069 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2070 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2071 Nullsv, prepend_elem(OP_LIST,
2072 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2073 prepend_elem(OP_LIST,
2074 newSVOP(OP_CONST, 0,
2080 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2085 if (!o || PL_error_count)
2089 if (type == OP_LIST) {
2090 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2091 my_kid(kid, attrs, imopsp);
2092 } else if (type == OP_UNDEF) {
2094 } else if (type == OP_RV2SV || /* "our" declaration */
2096 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2097 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2098 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
2099 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
2101 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2103 PL_in_my_stash = Nullhv;
2104 apply_attrs(GvSTASH(gv),
2105 (type == OP_RV2SV ? GvSV(gv) :
2106 type == OP_RV2AV ? (SV*)GvAV(gv) :
2107 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2110 o->op_private |= OPpOUR_INTRO;
2113 else if (type != OP_PADSV &&
2116 type != OP_PUSHMARK)
2118 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2120 PL_in_my == KEY_our ? "our" : "my"));
2123 else if (attrs && type != OP_PUSHMARK) {
2128 PL_in_my_stash = Nullhv;
2130 /* check for C<my Dog $spot> when deciding package */
2131 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2132 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2133 stash = SvSTASH(*namesvp);
2135 stash = PL_curstash;
2136 apply_attrs_my(stash, o, attrs, imopsp);
2138 o->op_flags |= OPf_MOD;
2139 o->op_private |= OPpLVAL_INTRO;
2144 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2147 int maybe_scalar = 0;
2149 if (o->op_flags & OPf_PARENS)
2155 o = my_kid(o, attrs, &rops);
2157 if (maybe_scalar && o->op_type == OP_PADSV) {
2158 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2159 o->op_private |= OPpLVAL_INTRO;
2162 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2165 PL_in_my_stash = Nullhv;
2170 Perl_my(pTHX_ OP *o)
2172 return my_attrs(o, Nullop);
2176 Perl_sawparens(pTHX_ OP *o)
2179 o->op_flags |= OPf_PARENS;
2184 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2188 if (ckWARN(WARN_MISC) &&
2189 (left->op_type == OP_RV2AV ||
2190 left->op_type == OP_RV2HV ||
2191 left->op_type == OP_PADAV ||
2192 left->op_type == OP_PADHV)) {
2193 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2194 right->op_type == OP_TRANS)
2195 ? right->op_type : OP_MATCH];
2196 const char *sample = ((left->op_type == OP_RV2AV ||
2197 left->op_type == OP_PADAV)
2198 ? "@array" : "%hash");
2199 Perl_warner(aTHX_ packWARN(WARN_MISC),
2200 "Applying %s to %s will act on scalar(%s)",
2201 desc, sample, sample);
2204 if (right->op_type == OP_CONST &&
2205 cSVOPx(right)->op_private & OPpCONST_BARE &&
2206 cSVOPx(right)->op_private & OPpCONST_STRICT)
2208 no_bareword_allowed(right);
2211 if (!(right->op_flags & OPf_STACKED) &&
2212 (right->op_type == OP_MATCH ||
2213 right->op_type == OP_SUBST ||
2214 right->op_type == OP_TRANS)) {
2215 right->op_flags |= OPf_STACKED;
2216 if (right->op_type != OP_MATCH &&
2217 ! (right->op_type == OP_TRANS &&
2218 right->op_private & OPpTRANS_IDENTICAL))
2219 left = mod(left, right->op_type);
2220 if (right->op_type == OP_TRANS)
2221 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2223 o = prepend_elem(right->op_type, scalar(left), right);
2225 return newUNOP(OP_NOT, 0, scalar(o));
2229 return bind_match(type, left,
2230 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2234 Perl_invert(pTHX_ OP *o)
2238 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2239 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2243 Perl_scope(pTHX_ OP *o)
2246 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2247 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2248 o->op_type = OP_LEAVE;
2249 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2252 if (o->op_type == OP_LINESEQ) {
2254 o->op_type = OP_SCOPE;
2255 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2256 kid = ((LISTOP*)o)->op_first;
2257 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2261 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2268 Perl_save_hints(pTHX)
2271 SAVESPTR(GvHV(PL_hintgv));
2272 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2273 SAVEFREESV(GvHV(PL_hintgv));
2277 Perl_block_start(pTHX_ int full)
2279 int retval = PL_savestack_ix;
2281 SAVEI32(PL_comppad_name_floor);
2282 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2284 PL_comppad_name_fill = PL_comppad_name_floor;
2285 if (PL_comppad_name_floor < 0)
2286 PL_comppad_name_floor = 0;
2287 SAVEI32(PL_min_intro_pending);
2288 SAVEI32(PL_max_intro_pending);
2289 PL_min_intro_pending = 0;
2290 SAVEI32(PL_comppad_name_fill);
2291 SAVEI32(PL_padix_floor);
2292 PL_padix_floor = PL_padix;
2293 PL_pad_reset_pending = FALSE;
2295 PL_hints &= ~HINT_BLOCK_SCOPE;
2296 SAVESPTR(PL_compiling.cop_warnings);
2297 if (! specialWARN(PL_compiling.cop_warnings)) {
2298 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2299 SAVEFREESV(PL_compiling.cop_warnings) ;
2301 SAVESPTR(PL_compiling.cop_io);
2302 if (! specialCopIO(PL_compiling.cop_io)) {
2303 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2304 SAVEFREESV(PL_compiling.cop_io) ;
2310 Perl_block_end(pTHX_ I32 floor, OP *seq)
2312 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2313 line_t copline = PL_copline;
2314 /* there should be a nextstate in every block */
2315 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2316 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2318 PL_pad_reset_pending = FALSE;
2319 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2321 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2322 pad_leavemy(PL_comppad_name_fill);
2330 #ifdef USE_5005THREADS
2331 OP *o = newOP(OP_THREADSV, 0);
2332 o->op_targ = find_threadsv("_");
2335 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2336 #endif /* USE_5005THREADS */
2340 Perl_newPROG(pTHX_ OP *o)
2345 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2346 ((PL_in_eval & EVAL_KEEPERR)
2347 ? OPf_SPECIAL : 0), o);
2348 PL_eval_start = linklist(PL_eval_root);
2349 PL_eval_root->op_private |= OPpREFCOUNTED;
2350 OpREFCNT_set(PL_eval_root, 1);
2351 PL_eval_root->op_next = 0;
2352 CALL_PEEP(PL_eval_start);
2357 PL_main_root = scope(sawparens(scalarvoid(o)));
2358 PL_curcop = &PL_compiling;
2359 PL_main_start = LINKLIST(PL_main_root);
2360 PL_main_root->op_private |= OPpREFCOUNTED;
2361 OpREFCNT_set(PL_main_root, 1);
2362 PL_main_root->op_next = 0;
2363 CALL_PEEP(PL_main_start);
2366 /* Register with debugger */
2368 CV *cv = get_cv("DB::postponed", FALSE);
2372 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2374 call_sv((SV*)cv, G_DISCARD);
2381 Perl_localize(pTHX_ OP *o, I32 lex)
2383 if (o->op_flags & OPf_PARENS)
2386 if (ckWARN(WARN_PARENTHESIS)
2387 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2389 char *s = PL_bufptr;
2391 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2394 if (*s == ';' || *s == '=')
2395 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2396 "Parentheses missing around \"%s\" list",
2397 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2403 o = mod(o, OP_NULL); /* a bit kludgey */
2405 PL_in_my_stash = Nullhv;
2410 Perl_jmaybe(pTHX_ OP *o)
2412 if (o->op_type == OP_LIST) {
2414 #ifdef USE_5005THREADS
2415 o2 = newOP(OP_THREADSV, 0);
2416 o2->op_targ = find_threadsv(";");
2418 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2419 #endif /* USE_5005THREADS */
2420 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2426 Perl_fold_constants(pTHX_ register OP *o)
2429 I32 type = o->op_type;
2432 if (PL_opargs[type] & OA_RETSCALAR)
2434 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2435 o->op_targ = pad_alloc(type, SVs_PADTMP);
2437 /* integerize op, unless it happens to be C<-foo>.
2438 * XXX should pp_i_negate() do magic string negation instead? */
2439 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2440 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2441 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2443 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2446 if (!(PL_opargs[type] & OA_FOLDCONST))
2451 /* XXX might want a ck_negate() for this */
2452 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2464 /* XXX what about the numeric ops? */
2465 if (PL_hints & HINT_LOCALE)
2470 goto nope; /* Don't try to run w/ errors */
2472 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2473 if ((curop->op_type != OP_CONST ||
2474 (curop->op_private & OPpCONST_BARE)) &&
2475 curop->op_type != OP_LIST &&
2476 curop->op_type != OP_SCALAR &&
2477 curop->op_type != OP_NULL &&
2478 curop->op_type != OP_PUSHMARK)
2484 curop = LINKLIST(o);
2488 sv = *(PL_stack_sp--);
2489 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2490 pad_swipe(o->op_targ);
2491 else if (SvTEMP(sv)) { /* grab mortal temp? */
2492 (void)SvREFCNT_inc(sv);
2496 if (type == OP_RV2GV)
2497 return newGVOP(OP_GV, 0, (GV*)sv);
2499 /* try to smush double to int, but don't smush -2.0 to -2 */
2500 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2503 #ifdef PERL_PRESERVE_IVUV
2504 /* Only bother to attempt to fold to IV if
2505 most operators will benefit */
2509 return newSVOP(OP_CONST, 0, sv);
2517 Perl_gen_constant_list(pTHX_ register OP *o)
2520 I32 oldtmps_floor = PL_tmps_floor;
2524 return o; /* Don't attempt to run with errors */
2526 PL_op = curop = LINKLIST(o);
2533 PL_tmps_floor = oldtmps_floor;
2535 o->op_type = OP_RV2AV;
2536 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2537 o->op_seq = 0; /* needs to be revisited in peep() */
2538 curop = ((UNOP*)o)->op_first;
2539 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2546 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2548 if (!o || o->op_type != OP_LIST)
2549 o = newLISTOP(OP_LIST, 0, o, Nullop);
2551 o->op_flags &= ~OPf_WANT;
2553 if (!(PL_opargs[type] & OA_MARK))
2554 op_null(cLISTOPo->op_first);
2556 o->op_type = (OPCODE)type;
2557 o->op_ppaddr = PL_ppaddr[type];
2558 o->op_flags |= flags;
2560 o = CHECKOP(type, o);
2561 if (o->op_type != type)
2564 return fold_constants(o);
2567 /* List constructors */
2570 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2578 if (first->op_type != type
2579 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2581 return newLISTOP(type, 0, first, last);
2584 if (first->op_flags & OPf_KIDS)
2585 ((LISTOP*)first)->op_last->op_sibling = last;
2587 first->op_flags |= OPf_KIDS;
2588 ((LISTOP*)first)->op_first = last;
2590 ((LISTOP*)first)->op_last = last;
2595 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2603 if (first->op_type != type)
2604 return prepend_elem(type, (OP*)first, (OP*)last);
2606 if (last->op_type != type)
2607 return append_elem(type, (OP*)first, (OP*)last);
2609 first->op_last->op_sibling = last->op_first;
2610 first->op_last = last->op_last;
2611 first->op_flags |= (last->op_flags & OPf_KIDS);
2619 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2627 if (last->op_type == type) {
2628 if (type == OP_LIST) { /* already a PUSHMARK there */
2629 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2630 ((LISTOP*)last)->op_first->op_sibling = first;
2631 if (!(first->op_flags & OPf_PARENS))
2632 last->op_flags &= ~OPf_PARENS;
2635 if (!(last->op_flags & OPf_KIDS)) {
2636 ((LISTOP*)last)->op_last = first;
2637 last->op_flags |= OPf_KIDS;
2639 first->op_sibling = ((LISTOP*)last)->op_first;
2640 ((LISTOP*)last)->op_first = first;
2642 last->op_flags |= OPf_KIDS;
2646 return newLISTOP(type, 0, first, last);
2652 Perl_newNULLLIST(pTHX)
2654 return newOP(OP_STUB, 0);
2658 Perl_force_list(pTHX_ OP *o)
2660 if (!o || o->op_type != OP_LIST)
2661 o = newLISTOP(OP_LIST, 0, o, Nullop);
2667 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2671 NewOp(1101, listop, 1, LISTOP);
2673 listop->op_type = (OPCODE)type;
2674 listop->op_ppaddr = PL_ppaddr[type];
2677 listop->op_flags = (U8)flags;
2681 else if (!first && last)
2684 first->op_sibling = last;
2685 listop->op_first = first;
2686 listop->op_last = last;
2687 if (type == OP_LIST) {
2689 pushop = newOP(OP_PUSHMARK, 0);
2690 pushop->op_sibling = first;
2691 listop->op_first = pushop;
2692 listop->op_flags |= OPf_KIDS;
2694 listop->op_last = pushop;
2701 Perl_newOP(pTHX_ I32 type, I32 flags)
2704 NewOp(1101, o, 1, OP);
2705 o->op_type = (OPCODE)type;
2706 o->op_ppaddr = PL_ppaddr[type];
2707 o->op_flags = (U8)flags;
2710 o->op_private = (U8)(0 | (flags >> 8));
2711 if (PL_opargs[type] & OA_RETSCALAR)
2713 if (PL_opargs[type] & OA_TARGET)
2714 o->op_targ = pad_alloc(type, SVs_PADTMP);
2715 return CHECKOP(type, o);
2719 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2724 first = newOP(OP_STUB, 0);
2725 if (PL_opargs[type] & OA_MARK)
2726 first = force_list(first);
2728 NewOp(1101, unop, 1, UNOP);
2729 unop->op_type = (OPCODE)type;
2730 unop->op_ppaddr = PL_ppaddr[type];
2731 unop->op_first = first;
2732 unop->op_flags = flags | OPf_KIDS;
2733 unop->op_private = (U8)(1 | (flags >> 8));
2734 unop = (UNOP*) CHECKOP(type, unop);
2738 return fold_constants((OP *) unop);
2742 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2745 NewOp(1101, binop, 1, BINOP);
2748 first = newOP(OP_NULL, 0);
2750 binop->op_type = (OPCODE)type;
2751 binop->op_ppaddr = PL_ppaddr[type];
2752 binop->op_first = first;
2753 binop->op_flags = flags | OPf_KIDS;
2756 binop->op_private = (U8)(1 | (flags >> 8));
2759 binop->op_private = (U8)(2 | (flags >> 8));
2760 first->op_sibling = last;
2763 binop = (BINOP*)CHECKOP(type, binop);
2764 if (binop->op_next || binop->op_type != (OPCODE)type)
2767 binop->op_last = binop->op_first->op_sibling;
2769 return fold_constants((OP *)binop);
2773 uvcompare(const void *a, const void *b)
2775 if (*((UV *)a) < (*(UV *)b))
2777 if (*((UV *)a) > (*(UV *)b))
2779 if (*((UV *)a+1) < (*(UV *)b+1))
2781 if (*((UV *)a+1) > (*(UV *)b+1))
2787 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2789 SV *tstr = ((SVOP*)expr)->op_sv;
2790 SV *rstr = ((SVOP*)repl)->op_sv;
2793 U8 *t = (U8*)SvPV(tstr, tlen);
2794 U8 *r = (U8*)SvPV(rstr, rlen);
2801 register short *tbl;
2803 PL_hints |= HINT_BLOCK_SCOPE;
2804 complement = o->op_private & OPpTRANS_COMPLEMENT;
2805 del = o->op_private & OPpTRANS_DELETE;
2806 squash = o->op_private & OPpTRANS_SQUASH;
2809 o->op_private |= OPpTRANS_FROM_UTF;
2812 o->op_private |= OPpTRANS_TO_UTF;
2814 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2815 SV* listsv = newSVpvn("# comment\n",10);
2817 U8* tend = t + tlen;
2818 U8* rend = r + rlen;
2832 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2833 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2839 tsave = t = bytes_to_utf8(t, &len);
2842 if (!to_utf && rlen) {
2844 rsave = r = bytes_to_utf8(r, &len);
2848 /* There are several snags with this code on EBCDIC:
2849 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2850 2. scan_const() in toke.c has encoded chars in native encoding which makes
2851 ranges at least in EBCDIC 0..255 range the bottom odd.
2855 U8 tmpbuf[UTF8_MAXLEN+1];
2858 New(1109, cp, 2*tlen, UV);
2860 transv = newSVpvn("",0);
2862 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2864 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2866 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2870 cp[2*i+1] = cp[2*i];
2874 qsort(cp, i, 2*sizeof(UV), uvcompare);
2875 for (j = 0; j < i; j++) {
2877 diff = val - nextmin;
2879 t = uvuni_to_utf8(tmpbuf,nextmin);
2880 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2882 U8 range_mark = UTF_TO_NATIVE(0xff);
2883 t = uvuni_to_utf8(tmpbuf, val - 1);
2884 sv_catpvn(transv, (char *)&range_mark, 1);
2885 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2892 t = uvuni_to_utf8(tmpbuf,nextmin);
2893 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2895 U8 range_mark = UTF_TO_NATIVE(0xff);
2896 sv_catpvn(transv, (char *)&range_mark, 1);
2898 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2899 UNICODE_ALLOW_SUPER);
2900 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2901 t = (U8*)SvPVX(transv);
2902 tlen = SvCUR(transv);
2906 else if (!rlen && !del) {
2907 r = t; rlen = tlen; rend = tend;
2910 if ((!rlen && !del) || t == r ||
2911 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2913 o->op_private |= OPpTRANS_IDENTICAL;
2917 while (t < tend || tfirst <= tlast) {
2918 /* see if we need more "t" chars */
2919 if (tfirst > tlast) {
2920 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2922 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2924 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2931 /* now see if we need more "r" chars */
2932 if (rfirst > rlast) {
2934 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2936 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2938 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2947 rfirst = rlast = 0xffffffff;
2951 /* now see which range will peter our first, if either. */
2952 tdiff = tlast - tfirst;
2953 rdiff = rlast - rfirst;
2960 if (rfirst == 0xffffffff) {
2961 diff = tdiff; /* oops, pretend rdiff is infinite */
2963 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2964 (long)tfirst, (long)tlast);
2966 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2970 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2971 (long)tfirst, (long)(tfirst + diff),
2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2975 (long)tfirst, (long)rfirst);
2977 if (rfirst + diff > max)
2978 max = rfirst + diff;
2980 grows = (tfirst < rfirst &&
2981 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2993 else if (max > 0xff)
2998 Safefree(cPVOPo->op_pv);
2999 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3000 SvREFCNT_dec(listsv);
3002 SvREFCNT_dec(transv);
3004 if (!del && havefinal && rlen)
3005 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3006 newSVuv((UV)final), 0);
3009 o->op_private |= OPpTRANS_GROWS;
3021 tbl = (short*)cPVOPo->op_pv;
3023 Zero(tbl, 256, short);
3024 for (i = 0; i < (I32)tlen; i++)
3026 for (i = 0, j = 0; i < 256; i++) {
3028 if (j >= (I32)rlen) {
3037 if (i < 128 && r[j] >= 128)
3047 o->op_private |= OPpTRANS_IDENTICAL;
3049 else if (j >= (I32)rlen)
3052 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3053 tbl[0x100] = rlen - j;
3054 for (i=0; i < (I32)rlen - j; i++)
3055 tbl[0x101+i] = r[j+i];
3059 if (!rlen && !del) {
3062 o->op_private |= OPpTRANS_IDENTICAL;
3064 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3065 o->op_private |= OPpTRANS_IDENTICAL;
3067 for (i = 0; i < 256; i++)
3069 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3070 if (j >= (I32)rlen) {
3072 if (tbl[t[i]] == -1)
3078 if (tbl[t[i]] == -1) {
3079 if (t[i] < 128 && r[j] >= 128)
3086 o->op_private |= OPpTRANS_GROWS;
3094 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3098 NewOp(1101, pmop, 1, PMOP);
3099 pmop->op_type = (OPCODE)type;
3100 pmop->op_ppaddr = PL_ppaddr[type];
3101 pmop->op_flags = (U8)flags;
3102 pmop->op_private = (U8)(0 | (flags >> 8));
3104 if (PL_hints & HINT_RE_TAINT)
3105 pmop->op_pmpermflags |= PMf_RETAINT;
3106 if (PL_hints & HINT_LOCALE)
3107 pmop->op_pmpermflags |= PMf_LOCALE;
3108 pmop->op_pmflags = pmop->op_pmpermflags;
3113 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3114 repointer = av_pop((AV*)PL_regex_pad[0]);
3115 pmop->op_pmoffset = SvIV(repointer);
3116 SvREPADTMP_off(repointer);
3117 sv_setiv(repointer,0);
3119 repointer = newSViv(0);
3120 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3121 pmop->op_pmoffset = av_len(PL_regex_padav);
3122 PL_regex_pad = AvARRAY(PL_regex_padav);
3127 /* link into pm list */
3128 if (type != OP_TRANS && PL_curstash) {
3129 pmop->op_pmnext = HvPMROOT(PL_curstash);
3130 HvPMROOT(PL_curstash) = pmop;
3131 PmopSTASH_set(pmop,PL_curstash);
3138 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3142 I32 repl_has_vars = 0;
3144 if (o->op_type == OP_TRANS)
3145 return pmtrans(o, expr, repl);
3147 PL_hints |= HINT_BLOCK_SCOPE;
3150 if (expr->op_type == OP_CONST) {
3152 SV *pat = ((SVOP*)expr)->op_sv;
3153 char *p = SvPV(pat, plen);
3154 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3155 sv_setpvn(pat, "\\s+", 3);
3156 p = SvPV(pat, plen);
3157 pm->op_pmflags |= PMf_SKIPWHITE;
3160 pm->op_pmdynflags |= PMdf_UTF8;
3161 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3162 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3163 pm->op_pmflags |= PMf_WHITE;
3167 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3168 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3170 : OP_REGCMAYBE),0,expr);
3172 NewOp(1101, rcop, 1, LOGOP);
3173 rcop->op_type = OP_REGCOMP;
3174 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3175 rcop->op_first = scalar(expr);
3176 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3177 ? (OPf_SPECIAL | OPf_KIDS)
3179 rcop->op_private = 1;
3182 /* establish postfix order */
3183 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3185 rcop->op_next = expr;
3186 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3189 rcop->op_next = LINKLIST(expr);
3190 expr->op_next = (OP*)rcop;
3193 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3198 if (pm->op_pmflags & PMf_EVAL) {
3200 if (CopLINE(PL_curcop) < PL_multi_end)
3201 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3203 #ifdef USE_5005THREADS
3204 else if (repl->op_type == OP_THREADSV
3205 && strchr("&`'123456789+",
3206 PL_threadsv_names[repl->op_targ]))
3210 #endif /* USE_5005THREADS */
3211 else if (repl->op_type == OP_CONST)
3215 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3216 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3217 #ifdef USE_5005THREADS
3218 if (curop->op_type == OP_THREADSV) {
3220 if (strchr("&`'123456789+", curop->op_private))
3224 if (curop->op_type == OP_GV) {
3225 GV *gv = cGVOPx_gv(curop);
3227 if (strchr("&`'123456789+", *GvENAME(gv)))
3230 #endif /* USE_5005THREADS */
3231 else if (curop->op_type == OP_RV2CV)
3233 else if (curop->op_type == OP_RV2SV ||
3234 curop->op_type == OP_RV2AV ||
3235 curop->op_type == OP_RV2HV ||
3236 curop->op_type == OP_RV2GV) {
3237 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3240 else if (curop->op_type == OP_PADSV ||
3241 curop->op_type == OP_PADAV ||
3242 curop->op_type == OP_PADHV ||
3243 curop->op_type == OP_PADANY) {
3246 else if (curop->op_type == OP_PUSHRE)
3247 ; /* Okay here, dangerous in newASSIGNOP */
3257 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3258 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3259 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3260 prepend_elem(o->op_type, scalar(repl), o);
3263 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3264 pm->op_pmflags |= PMf_MAYBE_CONST;
3265 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3267 NewOp(1101, rcop, 1, LOGOP);
3268 rcop->op_type = OP_SUBSTCONT;
3269 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3270 rcop->op_first = scalar(repl);
3271 rcop->op_flags |= OPf_KIDS;
3272 rcop->op_private = 1;
3275 /* establish postfix order */
3276 rcop->op_next = LINKLIST(repl);
3277 repl->op_next = (OP*)rcop;
3279 pm->op_pmreplroot = scalar((OP*)rcop);
3280 pm->op_pmreplstart = LINKLIST(rcop);
3289 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3292 NewOp(1101, svop, 1, SVOP);
3293 svop->op_type = (OPCODE)type;
3294 svop->op_ppaddr = PL_ppaddr[type];
3296 svop->op_next = (OP*)svop;
3297 svop->op_flags = (U8)flags;
3298 if (PL_opargs[type] & OA_RETSCALAR)
3300 if (PL_opargs[type] & OA_TARGET)
3301 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3302 return CHECKOP(type, svop);
3306 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3309 NewOp(1101, padop, 1, PADOP);
3310 padop->op_type = (OPCODE)type;
3311 padop->op_ppaddr = PL_ppaddr[type];
3312 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3313 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3314 PL_curpad[padop->op_padix] = sv;
3316 padop->op_next = (OP*)padop;
3317 padop->op_flags = (U8)flags;
3318 if (PL_opargs[type] & OA_RETSCALAR)
3320 if (PL_opargs[type] & OA_TARGET)
3321 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3322 return CHECKOP(type, padop);
3326 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3330 return newPADOP(type, flags, SvREFCNT_inc(gv));
3332 return newSVOP(type, flags, SvREFCNT_inc(gv));
3337 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3340 NewOp(1101, pvop, 1, PVOP);
3341 pvop->op_type = (OPCODE)type;
3342 pvop->op_ppaddr = PL_ppaddr[type];
3344 pvop->op_next = (OP*)pvop;
3345 pvop->op_flags = (U8)flags;
3346 if (PL_opargs[type] & OA_RETSCALAR)
3348 if (PL_opargs[type] & OA_TARGET)
3349 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3350 return CHECKOP(type, pvop);
3354 Perl_package(pTHX_ OP *o)
3358 save_hptr(&PL_curstash);
3359 save_item(PL_curstname);
3364 name = SvPV(sv, len);
3365 PL_curstash = gv_stashpvn(name,len,TRUE);
3366 sv_setpvn(PL_curstname, name, len);
3370 deprecate("\"package\" with no arguments");
3371 sv_setpv(PL_curstname,"<none>");
3372 PL_curstash = Nullhv;
3374 PL_hints |= HINT_BLOCK_SCOPE;
3375 PL_copline = NOLINE;
3380 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3386 if (id->op_type != OP_CONST)
3387 Perl_croak(aTHX_ "Module name must be constant");
3391 if (version != Nullop) {
3392 SV *vesv = ((SVOP*)version)->op_sv;
3394 if (arg == Nullop && !SvNIOKp(vesv)) {
3401 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3402 Perl_croak(aTHX_ "Version number must be constant number");
3404 /* Make copy of id so we don't free it twice */
3405 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3407 /* Fake up a method call to VERSION */
3408 meth = newSVpvn("VERSION",7);
3409 sv_upgrade(meth, SVt_PVIV);
3410 (void)SvIOK_on(meth);
3411 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3412 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3413 append_elem(OP_LIST,
3414 prepend_elem(OP_LIST, pack, list(version)),
3415 newSVOP(OP_METHOD_NAMED, 0, meth)));
3419 /* Fake up an import/unimport */
3420 if (arg && arg->op_type == OP_STUB)
3421 imop = arg; /* no import on explicit () */
3422 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3423 imop = Nullop; /* use 5.0; */
3428 /* Make copy of id so we don't free it twice */
3429 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3431 /* Fake up a method call to import/unimport */
3432 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3433 (void)SvUPGRADE(meth, SVt_PVIV);
3434 (void)SvIOK_on(meth);
3435 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3436 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3437 append_elem(OP_LIST,
3438 prepend_elem(OP_LIST, pack, list(arg)),
3439 newSVOP(OP_METHOD_NAMED, 0, meth)));
3442 /* Fake up the BEGIN {}, which does its thing immediately. */
3444 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3447 append_elem(OP_LINESEQ,
3448 append_elem(OP_LINESEQ,
3449 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3450 newSTATEOP(0, Nullch, veop)),
3451 newSTATEOP(0, Nullch, imop) ));
3453 /* The "did you use incorrect case?" warning used to be here.
3454 * The problem is that on case-insensitive filesystems one
3455 * might get false positives for "use" (and "require"):
3456 * "use Strict" or "require CARP" will work. This causes
3457 * portability problems for the script: in case-strict
3458 * filesystems the script will stop working.
3460 * The "incorrect case" warning checked whether "use Foo"
3461 * imported "Foo" to your namespace, but that is wrong, too:
3462 * there is no requirement nor promise in the language that
3463 * a Foo.pm should or would contain anything in package "Foo".
3465 * There is very little Configure-wise that can be done, either:
3466 * the case-sensitivity of the build filesystem of Perl does not
3467 * help in guessing the case-sensitivity of the runtime environment.
3470 PL_hints |= HINT_BLOCK_SCOPE;
3471 PL_copline = NOLINE;
3476 =head1 Embedding Functions
3478 =for apidoc load_module
3480 Loads the module whose name is pointed to by the string part of name.
3481 Note that the actual module name, not its filename, should be given.
3482 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3483 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3484 (or 0 for no flags). ver, if specified, provides version semantics
3485 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3486 arguments can be used to specify arguments to the module's import()
3487 method, similar to C<use Foo::Bar VERSION LIST>.
3492 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3495 va_start(args, ver);
3496 vload_module(flags, name, ver, &args);
3500 #ifdef PERL_IMPLICIT_CONTEXT
3502 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3506 va_start(args, ver);
3507 vload_module(flags, name, ver, &args);
3513 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3515 OP *modname, *veop, *imop;
3517 modname = newSVOP(OP_CONST, 0, name);
3518 modname->op_private |= OPpCONST_BARE;
3520 veop = newSVOP(OP_CONST, 0, ver);
3524 if (flags & PERL_LOADMOD_NOIMPORT) {
3525 imop = sawparens(newNULLLIST());
3527 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3528 imop = va_arg(*args, OP*);
3533 sv = va_arg(*args, SV*);
3535 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3536 sv = va_arg(*args, SV*);
3540 line_t ocopline = PL_copline;
3541 int oexpect = PL_expect;
3543 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3544 veop, modname, imop);
3545 PL_expect = oexpect;
3546 PL_copline = ocopline;
3551 Perl_dofile(pTHX_ OP *term)
3556 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3557 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3558 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3560 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3561 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3562 append_elem(OP_LIST, term,
3563 scalar(newUNOP(OP_RV2CV, 0,
3568 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3574 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3576 return newBINOP(OP_LSLICE, flags,
3577 list(force_list(subscript)),
3578 list(force_list(listval)) );
3582 S_list_assignment(pTHX_ register OP *o)
3587 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3588 o = cUNOPo->op_first;
3590 if (o->op_type == OP_COND_EXPR) {
3591 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3592 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3597 yyerror("Assignment to both a list and a scalar");
3601 if (o->op_type == OP_LIST &&
3602 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3603 o->op_private & OPpLVAL_INTRO)
3606 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3607 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3608 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3611 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3614 if (o->op_type == OP_RV2SV)
3621 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3626 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3627 return newLOGOP(optype, 0,
3628 mod(scalar(left), optype),
3629 newUNOP(OP_SASSIGN, 0, scalar(right)));
3632 return newBINOP(optype, OPf_STACKED,
3633 mod(scalar(left), optype), scalar(right));
3637 if (list_assignment(left)) {
3641 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3642 left = mod(left, OP_AASSIGN);
3650 curop = list(force_list(left));
3651 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3652 o->op_private = (U8)(0 | (flags >> 8));
3653 if (!(left->op_private & OPpLVAL_INTRO)) {
3656 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3657 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3658 if (curop->op_type == OP_GV) {
3659 GV *gv = cGVOPx_gv(curop);
3660 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3662 SvCUR(gv) = PL_generation;
3664 else if (curop->op_type == OP_PADSV ||
3665 curop->op_type == OP_PADAV ||
3666 curop->op_type == OP_PADHV ||
3667 curop->op_type == OP_PADANY) {
3668 SV **svp = AvARRAY(PL_comppad_name);
3669 SV *sv = svp[curop->op_targ];
3670 if ((int)SvCUR(sv) == PL_generation)
3672 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3674 else if (curop->op_type == OP_RV2CV)
3676 else if (curop->op_type == OP_RV2SV ||
3677 curop->op_type == OP_RV2AV ||
3678 curop->op_type == OP_RV2HV ||
3679 curop->op_type == OP_RV2GV) {
3680 if (lastop->op_type != OP_GV) /* funny deref? */
3683 else if (curop->op_type == OP_PUSHRE) {
3684 if (((PMOP*)curop)->op_pmreplroot) {
3686 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3688 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3690 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3692 SvCUR(gv) = PL_generation;
3701 o->op_private |= OPpASSIGN_COMMON;
3703 if (right && right->op_type == OP_SPLIT) {
3705 if ((tmpop = ((LISTOP*)right)->op_first) &&
3706 tmpop->op_type == OP_PUSHRE)
3708 PMOP *pm = (PMOP*)tmpop;
3709 if (left->op_type == OP_RV2AV &&
3710 !(left->op_private & OPpLVAL_INTRO) &&
3711 !(o->op_private & OPpASSIGN_COMMON) )
3713 tmpop = ((UNOP*)left)->op_first;
3714 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3716 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3717 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3719 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3720 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3722 pm->op_pmflags |= PMf_ONCE;
3723 tmpop = cUNOPo->op_first; /* to list (nulled) */
3724 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3725 tmpop->op_sibling = Nullop; /* don't free split */
3726 right->op_next = tmpop->op_next; /* fix starting loc */
3727 op_free(o); /* blow off assign */
3728 right->op_flags &= ~OPf_WANT;
3729 /* "I don't know and I don't care." */
3734 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3735 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3737 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3739 sv_setiv(sv, PL_modcount+1);
3747 right = newOP(OP_UNDEF, 0);
3748 if (right->op_type == OP_READLINE) {
3749 right->op_flags |= OPf_STACKED;
3750 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3753 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3754 o = newBINOP(OP_SASSIGN, flags,
3755 scalar(right), mod(scalar(left), OP_SASSIGN) );
3767 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3769 U32 seq = intro_my();
3772 NewOp(1101, cop, 1, COP);
3773 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3774 cop->op_type = OP_DBSTATE;
3775 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3778 cop->op_type = OP_NEXTSTATE;
3779 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3781 cop->op_flags = (U8)flags;
3782 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3784 cop->op_private |= NATIVE_HINTS;
3786 PL_compiling.op_private = cop->op_private;
3787 cop->op_next = (OP*)cop;
3790 cop->cop_label = label;
3791 PL_hints |= HINT_BLOCK_SCOPE;
3794 cop->cop_arybase = PL_curcop->cop_arybase;
3795 if (specialWARN(PL_curcop->cop_warnings))
3796 cop->cop_warnings = PL_curcop->cop_warnings ;
3798 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3799 if (specialCopIO(PL_curcop->cop_io))
3800 cop->cop_io = PL_curcop->cop_io;
3802 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3805 if (PL_copline == NOLINE)
3806 CopLINE_set(cop, CopLINE(PL_curcop));
3808 CopLINE_set(cop, PL_copline);
3809 PL_copline = NOLINE;
3812 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3814 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3816 CopSTASH_set(cop, PL_curstash);
3818 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3819 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3820 if (svp && *svp != &PL_sv_undef ) {
3821 (void)SvIOK_on(*svp);
3822 SvIVX(*svp) = PTR2IV(cop);
3826 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3829 /* "Introduce" my variables to visible status. */
3837 if (! PL_min_intro_pending)
3838 return PL_cop_seqmax;
3840 svp = AvARRAY(PL_comppad_name);
3841 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3842 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3843 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3844 SvNVX(sv) = (NV)PL_cop_seqmax;
3847 PL_min_intro_pending = 0;
3848 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3849 return PL_cop_seqmax++;
3853 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3855 return new_logop(type, flags, &first, &other);
3859 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3863 OP *first = *firstp;
3864 OP *other = *otherp;
3866 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3867 return newBINOP(type, flags, scalar(first), scalar(other));
3869 scalarboolean(first);
3870 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3871 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3872 if (type == OP_AND || type == OP_OR) {
3878 first = *firstp = cUNOPo->op_first;
3880 first->op_next = o->op_next;
3881 cUNOPo->op_first = Nullop;
3885 if (first->op_type == OP_CONST) {
3886 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3887 if (first->op_private & OPpCONST_BARE)
3888 no_bareword_allowed(first);
3890 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3892 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3903 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3904 OP *k1 = ((UNOP*)first)->op_first;
3905 OP *k2 = k1->op_sibling;
3907 switch (first->op_type)
3910 if (k2 && k2->op_type == OP_READLINE
3911 && (k2->op_flags & OPf_STACKED)
3912 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3914 warnop = k2->op_type;
3919 if (k1->op_type == OP_READDIR
3920 || k1->op_type == OP_GLOB
3921 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3922 || k1->op_type == OP_EACH)
3924 warnop = ((k1->op_type == OP_NULL)
3925 ? (OPCODE)k1->op_targ : k1->op_type);
3930 line_t oldline = CopLINE(PL_curcop);
3931 CopLINE_set(PL_curcop, PL_copline);
3932 Perl_warner(aTHX_ packWARN(WARN_MISC),
3933 "Value of %s%s can be \"0\"; test with defined()",
3935 ((warnop == OP_READLINE || warnop == OP_GLOB)
3936 ? " construct" : "() operator"));
3937 CopLINE_set(PL_curcop, oldline);
3944 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3945 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3947 NewOp(1101, logop, 1, LOGOP);
3949 logop->op_type = (OPCODE)type;
3950 logop->op_ppaddr = PL_ppaddr[type];
3951 logop->op_first = first;
3952 logop->op_flags = flags | OPf_KIDS;
3953 logop->op_other = LINKLIST(other);
3954 logop->op_private = (U8)(1 | (flags >> 8));
3956 /* establish postfix order */
3957 logop->op_next = LINKLIST(first);
3958 first->op_next = (OP*)logop;
3959 first->op_sibling = other;
3961 o = newUNOP(OP_NULL, 0, (OP*)logop);
3968 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3975 return newLOGOP(OP_AND, 0, first, trueop);
3977 return newLOGOP(OP_OR, 0, first, falseop);
3979 scalarboolean(first);
3980 if (first->op_type == OP_CONST) {
3981 if (first->op_private & OPpCONST_BARE &&
3982 first->op_private & OPpCONST_STRICT) {
3983 no_bareword_allowed(first);
3985 if (SvTRUE(((SVOP*)first)->op_sv)) {
3996 NewOp(1101, logop, 1, LOGOP);
3997 logop->op_type = OP_COND_EXPR;
3998 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3999 logop->op_first = first;
4000 logop->op_flags = flags | OPf_KIDS;
4001 logop->op_private = (U8)(1 | (flags >> 8));
4002 logop->op_other = LINKLIST(trueop);
4003 logop->op_next = LINKLIST(falseop);
4006 /* establish postfix order */
4007 start = LINKLIST(first);
4008 first->op_next = (OP*)logop;
4010 first->op_sibling = trueop;
4011 trueop->op_sibling = falseop;
4012 o = newUNOP(OP_NULL, 0, (OP*)logop);
4014 trueop->op_next = falseop->op_next = o;
4021 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4029 NewOp(1101, range, 1, LOGOP);
4031 range->op_type = OP_RANGE;
4032 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4033 range->op_first = left;
4034 range->op_flags = OPf_KIDS;
4035 leftstart = LINKLIST(left);
4036 range->op_other = LINKLIST(right);
4037 range->op_private = (U8)(1 | (flags >> 8));
4039 left->op_sibling = right;
4041 range->op_next = (OP*)range;
4042 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4043 flop = newUNOP(OP_FLOP, 0, flip);
4044 o = newUNOP(OP_NULL, 0, flop);
4046 range->op_next = leftstart;
4048 left->op_next = flip;
4049 right->op_next = flop;
4051 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4052 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4053 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4054 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4056 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4057 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4060 if (!flip->op_private || !flop->op_private)
4061 linklist(o); /* blow off optimizer unless constant */
4067 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4071 int once = block && block->op_flags & OPf_SPECIAL &&
4072 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4075 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4076 return block; /* do {} while 0 does once */
4077 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4078 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4079 expr = newUNOP(OP_DEFINED, 0,
4080 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4081 } else if (expr->op_flags & OPf_KIDS) {
4082 OP *k1 = ((UNOP*)expr)->op_first;
4083 OP *k2 = (k1) ? k1->op_sibling : NULL;
4084 switch (expr->op_type) {
4086 if (k2 && k2->op_type == OP_READLINE
4087 && (k2->op_flags & OPf_STACKED)
4088 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4089 expr = newUNOP(OP_DEFINED, 0, expr);
4093 if (k1->op_type == OP_READDIR
4094 || k1->op_type == OP_GLOB
4095 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4096 || k1->op_type == OP_EACH)
4097 expr = newUNOP(OP_DEFINED, 0, expr);
4103 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4104 o = new_logop(OP_AND, 0, &expr, &listop);
4107 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4109 if (once && o != listop)
4110 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4113 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4115 o->op_flags |= flags;
4117 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4122 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4130 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4131 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4132 expr = newUNOP(OP_DEFINED, 0,
4133 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4134 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4135 OP *k1 = ((UNOP*)expr)->op_first;
4136 OP *k2 = (k1) ? k1->op_sibling : NULL;
4137 switch (expr->op_type) {
4139 if (k2 && k2->op_type == OP_READLINE
4140 && (k2->op_flags & OPf_STACKED)
4141 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4142 expr = newUNOP(OP_DEFINED, 0, expr);
4146 if (k1->op_type == OP_READDIR
4147 || k1->op_type == OP_GLOB
4148 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4149 || k1->op_type == OP_EACH)
4150 expr = newUNOP(OP_DEFINED, 0, expr);
4156 block = newOP(OP_NULL, 0);
4158 block = scope(block);
4162 next = LINKLIST(cont);
4165 OP *unstack = newOP(OP_UNSTACK, 0);
4168 cont = append_elem(OP_LINESEQ, cont, unstack);
4169 if ((line_t)whileline != NOLINE) {
4170 PL_copline = (line_t)whileline;
4171 cont = append_elem(OP_LINESEQ, cont,
4172 newSTATEOP(0, Nullch, Nullop));
4176 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4177 redo = LINKLIST(listop);
4180 PL_copline = (line_t)whileline;
4182 o = new_logop(OP_AND, 0, &expr, &listop);
4183 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4184 op_free(expr); /* oops, it's a while (0) */
4186 return Nullop; /* listop already freed by new_logop */
4189 ((LISTOP*)listop)->op_last->op_next =
4190 (o == listop ? redo : LINKLIST(o));
4196 NewOp(1101,loop,1,LOOP);
4197 loop->op_type = OP_ENTERLOOP;
4198 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4199 loop->op_private = 0;
4200 loop->op_next = (OP*)loop;
4203 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4205 loop->op_redoop = redo;
4206 loop->op_lastop = o;
4207 o->op_private |= loopflags;
4210 loop->op_nextop = next;
4212 loop->op_nextop = o;
4214 o->op_flags |= flags;
4215 o->op_private |= (flags >> 8);
4220 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4224 PADOFFSET padoff = 0;
4228 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4229 sv->op_type = OP_RV2GV;
4230 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4232 else if (sv->op_type == OP_PADSV) { /* private variable */
4233 padoff = sv->op_targ;
4238 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4239 padoff = sv->op_targ;
4241 iterflags |= OPf_SPECIAL;
4246 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4249 #ifdef USE_5005THREADS
4250 padoff = find_threadsv("_");
4251 iterflags |= OPf_SPECIAL;
4253 sv = newGVOP(OP_GV, 0, PL_defgv);
4256 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4257 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4258 iterflags |= OPf_STACKED;
4260 else if (expr->op_type == OP_NULL &&
4261 (expr->op_flags & OPf_KIDS) &&
4262 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4264 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4265 * set the STACKED flag to indicate that these values are to be
4266 * treated as min/max values by 'pp_iterinit'.
4268 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4269 LOGOP* range = (LOGOP*) flip->op_first;
4270 OP* left = range->op_first;
4271 OP* right = left->op_sibling;
4274 range->op_flags &= ~OPf_KIDS;
4275 range->op_first = Nullop;
4277 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4278 listop->op_first->op_next = range->op_next;
4279 left->op_next = range->op_other;
4280 right->op_next = (OP*)listop;
4281 listop->op_next = listop->op_first;
4284 expr = (OP*)(listop);
4286 iterflags |= OPf_STACKED;
4289 expr = mod(force_list(expr), OP_GREPSTART);
4293 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4294 append_elem(OP_LIST, expr, scalar(sv))));
4295 assert(!loop->op_next);
4296 #ifdef PL_OP_SLAB_ALLOC
4299 NewOp(1234,tmp,1,LOOP);
4300 Copy(loop,tmp,1,LOOP);
4305 Renew(loop, 1, LOOP);
4307 loop->op_targ = padoff;
4308 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4309 PL_copline = forline;
4310 return newSTATEOP(0, label, wop);
4314 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4319 if (type != OP_GOTO || label->op_type == OP_CONST) {
4320 /* "last()" means "last" */
4321 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4322 o = newOP(type, OPf_SPECIAL);
4324 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4325 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4331 if (label->op_type == OP_ENTERSUB)
4332 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4333 o = newUNOP(type, OPf_STACKED, label);
4335 PL_hints |= HINT_BLOCK_SCOPE;
4340 Perl_cv_undef(pTHX_ CV *cv)
4343 CV *freecv = Nullcv;
4344 bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */
4346 #ifdef USE_5005THREADS
4348 MUTEX_DESTROY(CvMUTEXP(cv));
4349 Safefree(CvMUTEXP(cv));
4352 #endif /* USE_5005THREADS */
4355 if (CvFILE(cv) && !CvXSUB(cv)) {
4356 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4357 Safefree(CvFILE(cv));
4362 if (!CvXSUB(cv) && CvROOT(cv)) {
4363 #ifdef USE_5005THREADS
4364 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4365 Perl_croak(aTHX_ "Can't undef active subroutine");
4368 Perl_croak(aTHX_ "Can't undef active subroutine");
4369 #endif /* USE_5005THREADS */
4372 SAVEVPTR(PL_curpad);
4375 op_free(CvROOT(cv));
4376 CvROOT(cv) = Nullop;
4379 SvPOK_off((SV*)cv); /* forget prototype */
4381 outsidecv = CvOUTSIDE(cv);
4382 /* Since closure prototypes have the same lifetime as the containing
4383 * CV, they don't hold a refcount on the outside CV. This avoids
4384 * the refcount loop between the outer CV (which keeps a refcount to
4385 * the closure prototype in the pad entry for pp_anoncode()) and the
4386 * closure prototype, and the ensuing memory leak. --GSAR */
4387 if (!CvANON(cv) || CvCLONED(cv))
4389 CvOUTSIDE(cv) = Nullcv;
4391 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4394 if (CvPADLIST(cv)) {
4395 /* may be during global destruction */
4396 if (SvREFCNT(CvPADLIST(cv))) {
4397 AV *padlist = CvPADLIST(cv);
4399 /* pads may be cleared out already during global destruction */
4400 if ((is_eval && !PL_dirty) || CvSPECIAL(cv)) {
4401 /* inner references to eval's cv must be fixed up */
4402 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4403 AV *comppad = (AV*)AvARRAY(padlist)[1];
4404 SV **namepad = AvARRAY(comppad_name);
4405 SV **curpad = AvARRAY(comppad);
4406 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4407 SV *namesv = namepad[ix];
4408 if (namesv && namesv != &PL_sv_undef
4409 && *SvPVX(namesv) == '&'
4410 && ix <= AvFILLp(comppad))
4412 CV *innercv = (CV*)curpad[ix];
4413 if (innercv && SvTYPE(innercv) == SVt_PVCV
4414 && CvOUTSIDE(innercv) == cv)
4416 CvOUTSIDE(innercv) = outsidecv;
4417 if (!CvANON(innercv) || CvCLONED(innercv)) {
4418 (void)SvREFCNT_inc(outsidecv);
4427 SvREFCNT_dec(freecv);
4428 ix = AvFILLp(padlist);
4430 SV* sv = AvARRAY(padlist)[ix--];
4433 if (sv == (SV*)PL_comppad_name)
4434 PL_comppad_name = Nullav;
4435 else if (sv == (SV*)PL_comppad) {
4436 PL_comppad = Nullav;
4437 PL_curpad = Null(SV**);
4441 SvREFCNT_dec((SV*)CvPADLIST(cv));
4443 CvPADLIST(cv) = Nullav;
4446 SvREFCNT_dec(freecv);
4453 #ifdef DEBUG_CLOSURES
4455 S_cv_dump(pTHX_ CV *cv)
4458 CV *outside = CvOUTSIDE(cv);
4459 AV* padlist = CvPADLIST(cv);
4466 PerlIO_printf(Perl_debug_log,
4467 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4469 (CvANON(cv) ? "ANON"
4470 : (cv == PL_main_cv) ? "MAIN"
4471 : CvUNIQUE(cv) ? "UNIQUE"
4472 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4475 : CvANON(outside) ? "ANON"
4476 : (outside == PL_main_cv) ? "MAIN"
4477 : CvUNIQUE(outside) ? "UNIQUE"
4478 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4483 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4484 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4485 pname = AvARRAY(pad_name);
4486 ppad = AvARRAY(pad);
4488 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4489 if (SvPOK(pname[ix]))
4490 PerlIO_printf(Perl_debug_log,
4491 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4492 (int)ix, PTR2UV(ppad[ix]),
4493 SvFAKE(pname[ix]) ? "FAKE " : "",
4495 (IV)I_32(SvNVX(pname[ix])),
4498 #endif /* DEBUGGING */
4500 #endif /* DEBUG_CLOSURES */
4503 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4507 AV* protopadlist = CvPADLIST(proto);
4508 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4509 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4510 SV** pname = AvARRAY(protopad_name);
4511 SV** ppad = AvARRAY(protopad);
4512 I32 fname = AvFILLp(protopad_name);
4513 I32 fpad = AvFILLp(protopad);
4517 assert(!CvUNIQUE(proto));
4521 SAVESPTR(PL_comppad_name);
4522 SAVESPTR(PL_compcv);
4524 cv = PL_compcv = (CV*)NEWSV(1104,0);
4525 sv_upgrade((SV *)cv, SvTYPE(proto));
4526 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4529 #ifdef USE_5005THREADS
4530 New(666, CvMUTEXP(cv), 1, perl_mutex);
4531 MUTEX_INIT(CvMUTEXP(cv));
4533 #endif /* USE_5005THREADS */
4535 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4536 : savepv(CvFILE(proto));
4538 CvFILE(cv) = CvFILE(proto);
4540 CvGV(cv) = CvGV(proto);
4541 CvSTASH(cv) = CvSTASH(proto);
4542 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4543 CvSTART(cv) = CvSTART(proto);
4545 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4548 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4550 PL_comppad_name = newAV();
4551 for (ix = fname; ix >= 0; ix--)
4552 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4554 PL_comppad = newAV();
4556 comppadlist = newAV();
4557 AvREAL_off(comppadlist);
4558 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4559 av_store(comppadlist, 1, (SV*)PL_comppad);
4560 CvPADLIST(cv) = comppadlist;
4561 av_fill(PL_comppad, AvFILLp(protopad));
4562 PL_curpad = AvARRAY(PL_comppad);
4564 av = newAV(); /* will be @_ */
4566 av_store(PL_comppad, 0, (SV*)av);
4567 AvFLAGS(av) = AVf_REIFY;
4569 for (ix = fpad; ix > 0; ix--) {
4570 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4571 if (namesv && namesv != &PL_sv_undef) {
4572 char *name = SvPVX(namesv); /* XXX */
4573 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4574 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4575 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4577 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4579 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4581 else { /* our own lexical */
4584 /* anon code -- we'll come back for it */
4585 sv = SvREFCNT_inc(ppad[ix]);
4587 else if (*name == '@')
4589 else if (*name == '%')
4598 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4599 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4602 SV* sv = NEWSV(0,0);
4608 /* Now that vars are all in place, clone nested closures. */
4610 for (ix = fpad; ix > 0; ix--) {
4611 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4613 && namesv != &PL_sv_undef
4614 && !(SvFLAGS(namesv) & SVf_FAKE)
4615 && *SvPVX(namesv) == '&'
4616 && CvCLONE(ppad[ix]))
4618 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4619 SvREFCNT_dec(ppad[ix]);
4622 PL_curpad[ix] = (SV*)kid;
4626 #ifdef DEBUG_CLOSURES
4627 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4629 PerlIO_printf(Perl_debug_log, " from:\n");
4631 PerlIO_printf(Perl_debug_log, " to:\n");
4638 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4640 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4642 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4649 Perl_cv_clone(pTHX_ CV *proto)
4652 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4653 cv = cv_clone2(proto, CvOUTSIDE(proto));
4654 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4659 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4661 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4662 SV* msg = sv_newmortal();
4666 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4667 sv_setpv(msg, "Prototype mismatch:");
4669 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4671 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4672 sv_catpv(msg, " vs ");
4674 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4676 sv_catpv(msg, "none");
4677 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4681 static void const_sv_xsub(pTHX_ CV* cv);
4685 =head1 Optree Manipulation Functions
4687 =for apidoc cv_const_sv
4689 If C<cv> is a constant sub eligible for inlining. returns the constant
4690 value returned by the sub. Otherwise, returns NULL.
4692 Constant subs can be created with C<newCONSTSUB> or as described in
4693 L<perlsub/"Constant Functions">.
4698 Perl_cv_const_sv(pTHX_ CV *cv)
4700 if (!cv || !CvCONST(cv))
4702 return (SV*)CvXSUBANY(cv).any_ptr;
4706 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4713 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4714 o = cLISTOPo->op_first->op_sibling;
4716 for (; o; o = o->op_next) {
4717 OPCODE type = o->op_type;
4719 if (sv && o->op_next == o)
4721 if (o->op_next != o) {
4722 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4724 if (type == OP_DBSTATE)
4727 if (type == OP_LEAVESUB || type == OP_RETURN)
4731 if (type == OP_CONST && cSVOPo->op_sv)
4733 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4734 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4735 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4739 /* We get here only from cv_clone2() while creating a closure.
4740 Copy the const value here instead of in cv_clone2 so that
4741 SvREADONLY_on doesn't lead to problems when leaving
4746 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4758 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4768 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4772 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4774 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4778 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4784 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4789 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4790 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4791 SV *sv = sv_newmortal();
4792 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4793 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4794 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4799 gv = gv_fetchpv(name ? name : (aname ? aname :
4800 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4801 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4811 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4812 maximum a prototype before. */
4813 if (SvTYPE(gv) > SVt_NULL) {
4814 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4815 && ckWARN_d(WARN_PROTOTYPE))
4817 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4819 cv_ckproto((CV*)gv, NULL, ps);
4822 sv_setpv((SV*)gv, ps);
4824 sv_setiv((SV*)gv, -1);
4825 SvREFCNT_dec(PL_compcv);
4826 cv = PL_compcv = NULL;
4827 PL_sub_generation++;
4831 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4833 #ifdef GV_UNIQUE_CHECK
4834 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4835 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4839 if (!block || !ps || *ps || attrs)
4842 const_sv = op_const_sv(block, Nullcv);
4845 bool exists = CvROOT(cv) || CvXSUB(cv);
4847 #ifdef GV_UNIQUE_CHECK
4848 if (exists && GvUNIQUE(gv)) {
4849 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4853 /* if the subroutine doesn't exist and wasn't pre-declared
4854 * with a prototype, assume it will be AUTOLOADed,
4855 * skipping the prototype check
4857 if (exists || SvPOK(cv))
4858 cv_ckproto(cv, gv, ps);
4859 /* already defined (or promised)? */
4860 if (exists || GvASSUMECV(gv)) {
4861 if (!block && !attrs) {
4862 if (CvFLAGS(PL_compcv)) {
4863 /* might have had built-in attrs applied */
4864 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4866 /* just a "sub foo;" when &foo is already defined */
4867 SAVEFREESV(PL_compcv);
4870 /* ahem, death to those who redefine active sort subs */
4871 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4872 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4874 if (ckWARN(WARN_REDEFINE)
4876 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4878 line_t oldline = CopLINE(PL_curcop);
4879 if (PL_copline != NOLINE)
4880 CopLINE_set(PL_curcop, PL_copline);
4881 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4882 CvCONST(cv) ? "Constant subroutine %s redefined"
4883 : "Subroutine %s redefined", name);
4884 CopLINE_set(PL_curcop, oldline);
4892 SvREFCNT_inc(const_sv);
4894 assert(!CvROOT(cv) && !CvCONST(cv));
4895 sv_setpv((SV*)cv, ""); /* prototype is "" */
4896 CvXSUBANY(cv).any_ptr = const_sv;
4897 CvXSUB(cv) = const_sv_xsub;
4902 cv = newCONSTSUB(NULL, name, const_sv);
4905 SvREFCNT_dec(PL_compcv);
4907 PL_sub_generation++;
4914 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4915 * before we clobber PL_compcv.
4919 /* Might have had built-in attributes applied -- propagate them. */
4920 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4921 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4922 stash = GvSTASH(CvGV(cv));
4923 else if (CvSTASH(cv))
4924 stash = CvSTASH(cv);
4926 stash = PL_curstash;
4929 /* possibly about to re-define existing subr -- ignore old cv */
4930 rcv = (SV*)PL_compcv;
4931 if (name && GvSTASH(gv))
4932 stash = GvSTASH(gv);
4934 stash = PL_curstash;
4936 apply_attrs(stash, rcv, attrs, FALSE);
4938 if (cv) { /* must reuse cv if autoloaded */
4940 /* got here with just attrs -- work done, so bug out */
4941 SAVEFREESV(PL_compcv);
4945 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4946 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4947 CvOUTSIDE(PL_compcv) = 0;
4948 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4949 CvPADLIST(PL_compcv) = 0;
4950 /* inner references to PL_compcv must be fixed up ... */
4952 AV *padlist = CvPADLIST(cv);
4953 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4954 AV *comppad = (AV*)AvARRAY(padlist)[1];
4955 SV **namepad = AvARRAY(comppad_name);
4956 SV **curpad = AvARRAY(comppad);
4957 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4958 SV *namesv = namepad[ix];
4959 if (namesv && namesv != &PL_sv_undef
4960 && *SvPVX(namesv) == '&')
4962 CV *innercv = (CV*)curpad[ix];
4963 if (CvOUTSIDE(innercv) == PL_compcv) {
4964 CvOUTSIDE(innercv) = cv;
4965 if (!CvANON(innercv) || CvCLONED(innercv)) {
4966 (void)SvREFCNT_inc(cv);
4967 SvREFCNT_dec(PL_compcv);
4973 /* ... before we throw it away */
4974 SvREFCNT_dec(PL_compcv);
4975 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4976 ++PL_sub_generation;
4983 PL_sub_generation++;
4987 CvFILE_set_from_cop(cv, PL_curcop);
4988 CvSTASH(cv) = PL_curstash;
4989 #ifdef USE_5005THREADS
4991 if (!CvMUTEXP(cv)) {
4992 New(666, CvMUTEXP(cv), 1, perl_mutex);
4993 MUTEX_INIT(CvMUTEXP(cv));
4995 #endif /* USE_5005THREADS */
4998 sv_setpv((SV*)cv, ps);
5000 if (PL_error_count) {
5004 char *s = strrchr(name, ':');
5006 if (strEQ(s, "BEGIN")) {
5008 "BEGIN not safe after errors--compilation aborted";
5009 if (PL_in_eval & EVAL_KEEPERR)
5010 Perl_croak(aTHX_ not_safe);
5012 /* force display of errors found but not reported */
5013 sv_catpv(ERRSV, not_safe);
5014 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
5022 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5023 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5026 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5027 mod(scalarseq(block), OP_LEAVESUBLV));
5030 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5032 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5033 OpREFCNT_set(CvROOT(cv), 1);
5034 CvSTART(cv) = LINKLIST(CvROOT(cv));
5035 CvROOT(cv)->op_next = 0;
5036 CALL_PEEP(CvSTART(cv));
5038 /* now that optimizer has done its work, adjust pad values */
5040 SV **namep = AvARRAY(PL_comppad_name);
5041 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5044 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5047 * The only things that a clonable function needs in its
5048 * pad are references to outer lexicals and anonymous subs.
5049 * The rest are created anew during cloning.
5051 if (!((namesv = namep[ix]) != Nullsv &&
5052 namesv != &PL_sv_undef &&
5054 *SvPVX(namesv) == '&')))
5056 SvREFCNT_dec(PL_curpad[ix]);
5057 PL_curpad[ix] = Nullsv;
5060 assert(!CvCONST(cv));
5061 if (ps && !*ps && op_const_sv(block, cv))
5065 AV *av = newAV(); /* Will be @_ */
5067 av_store(PL_comppad, 0, (SV*)av);
5068 AvFLAGS(av) = AVf_REIFY;
5070 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5071 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5073 if (!SvPADMY(PL_curpad[ix]))
5074 SvPADTMP_on(PL_curpad[ix]);
5078 /* If a potential closure prototype, don't keep a refcount on outer CV.
5079 * This is okay as the lifetime of the prototype is tied to the
5080 * lifetime of the outer CV. Avoids memory leak due to reference
5083 SvREFCNT_dec(CvOUTSIDE(cv));
5085 if (name || aname) {
5087 char *tname = (name ? name : aname);
5089 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5090 SV *sv = NEWSV(0,0);
5091 SV *tmpstr = sv_newmortal();
5092 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5096 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5098 (long)PL_subline, (long)CopLINE(PL_curcop));
5099 gv_efullname3(tmpstr, gv, Nullch);
5100 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5101 hv = GvHVn(db_postponed);
5102 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5103 && (pcv = GvCV(db_postponed)))
5109 call_sv((SV*)pcv, G_DISCARD);
5113 if ((s = strrchr(tname,':')))
5118 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5121 if (strEQ(s, "BEGIN")) {
5122 I32 oldscope = PL_scopestack_ix;
5124 SAVECOPFILE(&PL_compiling);
5125 SAVECOPLINE(&PL_compiling);
5128 PL_beginav = newAV();
5129 DEBUG_x( dump_sub(gv) );
5130 av_push(PL_beginav, (SV*)cv);
5131 GvCV(gv) = 0; /* cv has been hijacked */
5132 call_list(oldscope, PL_beginav);
5134 PL_curcop = &PL_compiling;
5135 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5138 else if (strEQ(s, "END") && !PL_error_count) {
5141 DEBUG_x( dump_sub(gv) );
5142 av_unshift(PL_endav, 1);
5143 av_store(PL_endav, 0, (SV*)cv);
5144 GvCV(gv) = 0; /* cv has been hijacked */
5146 else if (strEQ(s, "CHECK") && !PL_error_count) {
5148 PL_checkav = newAV();
5149 DEBUG_x( dump_sub(gv) );
5150 if (PL_main_start && ckWARN(WARN_VOID))
5151 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5152 av_unshift(PL_checkav, 1);
5153 av_store(PL_checkav, 0, (SV*)cv);
5154 GvCV(gv) = 0; /* cv has been hijacked */
5156 else if (strEQ(s, "INIT") && !PL_error_count) {
5158 PL_initav = newAV();
5159 DEBUG_x( dump_sub(gv) );
5160 if (PL_main_start && ckWARN(WARN_VOID))
5161 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5162 av_push(PL_initav, (SV*)cv);
5163 GvCV(gv) = 0; /* cv has been hijacked */
5168 PL_copline = NOLINE;
5173 /* XXX unsafe for threads if eval_owner isn't held */
5175 =for apidoc newCONSTSUB
5177 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5178 eligible for inlining at compile-time.
5184 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5190 SAVECOPLINE(PL_curcop);
5191 CopLINE_set(PL_curcop, PL_copline);
5194 PL_hints &= ~HINT_BLOCK_SCOPE;
5197 SAVESPTR(PL_curstash);
5198 SAVECOPSTASH(PL_curcop);
5199 PL_curstash = stash;
5200 CopSTASH_set(PL_curcop,stash);
5203 cv = newXS(name, const_sv_xsub, __FILE__);
5204 CvXSUBANY(cv).any_ptr = sv;
5206 sv_setpv((SV*)cv, ""); /* prototype is "" */
5214 =for apidoc U||newXS
5216 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5222 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5224 GV *gv = gv_fetchpv(name ? name :
5225 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5226 GV_ADDMULTI, SVt_PVCV);
5230 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5232 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5234 /* just a cached method */
5238 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5239 /* already defined (or promised) */
5240 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5241 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5242 line_t oldline = CopLINE(PL_curcop);
5243 if (PL_copline != NOLINE)
5244 CopLINE_set(PL_curcop, PL_copline);
5245 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5246 CvCONST(cv) ? "Constant subroutine %s redefined"
5247 : "Subroutine %s redefined"
5249 CopLINE_set(PL_curcop, oldline);
5256 if (cv) /* must reuse cv if autoloaded */
5259 cv = (CV*)NEWSV(1105,0);
5260 sv_upgrade((SV *)cv, SVt_PVCV);
5264 PL_sub_generation++;
5268 #ifdef USE_5005THREADS
5269 New(666, CvMUTEXP(cv), 1, perl_mutex);
5270 MUTEX_INIT(CvMUTEXP(cv));
5272 #endif /* USE_5005THREADS */
5273 (void)gv_fetchfile(filename);
5274 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5275 an external constant string */
5276 CvXSUB(cv) = subaddr;
5279 char *s = strrchr(name,':');
5285 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5288 if (strEQ(s, "BEGIN")) {
5290 PL_beginav = newAV();
5291 av_push(PL_beginav, (SV*)cv);
5292 GvCV(gv) = 0; /* cv has been hijacked */
5294 else if (strEQ(s, "END")) {
5297 av_unshift(PL_endav, 1);
5298 av_store(PL_endav, 0, (SV*)cv);
5299 GvCV(gv) = 0; /* cv has been hijacked */
5301 else if (strEQ(s, "CHECK")) {
5303 PL_checkav = newAV();
5304 if (PL_main_start && ckWARN(WARN_VOID))
5305 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5306 av_unshift(PL_checkav, 1);
5307 av_store(PL_checkav, 0, (SV*)cv);
5308 GvCV(gv) = 0; /* cv has been hijacked */
5310 else if (strEQ(s, "INIT")) {
5312 PL_initav = newAV();
5313 if (PL_main_start && ckWARN(WARN_VOID))
5314 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5315 av_push(PL_initav, (SV*)cv);
5316 GvCV(gv) = 0; /* cv has been hijacked */
5327 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5336 name = SvPVx(cSVOPo->op_sv, n_a);
5339 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5340 #ifdef GV_UNIQUE_CHECK
5342 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5346 if ((cv = GvFORM(gv))) {
5347 if (ckWARN(WARN_REDEFINE)) {
5348 line_t oldline = CopLINE(PL_curcop);
5349 if (PL_copline != NOLINE)
5350 CopLINE_set(PL_curcop, PL_copline);
5351 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
5352 CopLINE_set(PL_curcop, oldline);
5359 CvFILE_set_from_cop(cv, PL_curcop);
5361 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5362 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5363 SvPADTMP_on(PL_curpad[ix]);
5366 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5367 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5368 OpREFCNT_set(CvROOT(cv), 1);
5369 CvSTART(cv) = LINKLIST(CvROOT(cv));
5370 CvROOT(cv)->op_next = 0;
5371 CALL_PEEP(CvSTART(cv));
5373 PL_copline = NOLINE;
5378 Perl_newANONLIST(pTHX_ OP *o)
5380 return newUNOP(OP_REFGEN, 0,
5381 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5385 Perl_newANONHASH(pTHX_ OP *o)
5387 return newUNOP(OP_REFGEN, 0,
5388 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5392 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5394 return newANONATTRSUB(floor, proto, Nullop, block);
5398 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5400 return newUNOP(OP_REFGEN, 0,
5401 newSVOP(OP_ANONCODE, 0,
5402 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5406 Perl_oopsAV(pTHX_ OP *o)
5408 switch (o->op_type) {
5410 o->op_type = OP_PADAV;
5411 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5412 return ref(o, OP_RV2AV);
5415 o->op_type = OP_RV2AV;
5416 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5421 if (ckWARN_d(WARN_INTERNAL))
5422 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5429 Perl_oopsHV(pTHX_ OP *o)
5431 switch (o->op_type) {
5434 o->op_type = OP_PADHV;
5435 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5436 return ref(o, OP_RV2HV);
5440 o->op_type = OP_RV2HV;
5441 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5446 if (ckWARN_d(WARN_INTERNAL))
5447 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5454 Perl_newAVREF(pTHX_ OP *o)
5456 if (o->op_type == OP_PADANY) {
5457 o->op_type = OP_PADAV;
5458 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5461 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5462 && ckWARN(WARN_DEPRECATED)) {
5463 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5464 "Using an array as a reference is deprecated");
5466 return newUNOP(OP_RV2AV, 0, scalar(o));
5470 Perl_newGVREF(pTHX_ I32 type, OP *o)
5472 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5473 return newUNOP(OP_NULL, 0, o);
5474 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5478 Perl_newHVREF(pTHX_ OP *o)
5480 if (o->op_type == OP_PADANY) {
5481 o->op_type = OP_PADHV;
5482 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5485 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5486 && ckWARN(WARN_DEPRECATED)) {
5487 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5488 "Using a hash as a reference is deprecated");
5490 return newUNOP(OP_RV2HV, 0, scalar(o));
5494 Perl_oopsCV(pTHX_ OP *o)
5496 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5502 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5504 return newUNOP(OP_RV2CV, flags, scalar(o));
5508 Perl_newSVREF(pTHX_ OP *o)
5510 if (o->op_type == OP_PADANY) {
5511 o->op_type = OP_PADSV;
5512 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5515 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5516 o->op_flags |= OPpDONE_SVREF;
5519 return newUNOP(OP_RV2SV, 0, scalar(o));
5522 /* Check routines. */
5525 Perl_ck_anoncode(pTHX_ OP *o)
5530 name = NEWSV(1106,0);
5531 sv_upgrade(name, SVt_PVNV);
5532 sv_setpvn(name, "&", 1);
5535 ix = pad_alloc(o->op_type, SVs_PADMY);
5536 av_store(PL_comppad_name, ix, name);
5537 av_store(PL_comppad, ix, cSVOPo->op_sv);
5538 SvPADMY_on(cSVOPo->op_sv);
5539 cSVOPo->op_sv = Nullsv;
5540 cSVOPo->op_targ = ix;
5545 Perl_ck_bitop(pTHX_ OP *o)
5547 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5552 Perl_ck_concat(pTHX_ OP *o)
5554 if (cUNOPo->op_first->op_type == OP_CONCAT)
5555 o->op_flags |= OPf_STACKED;
5560 Perl_ck_spair(pTHX_ OP *o)
5562 if (o->op_flags & OPf_KIDS) {
5565 OPCODE type = o->op_type;
5566 o = modkids(ck_fun(o), type);
5567 kid = cUNOPo->op_first;
5568 newop = kUNOP->op_first->op_sibling;
5570 (newop->op_sibling ||
5571 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5572 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5573 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5577 op_free(kUNOP->op_first);
5578 kUNOP->op_first = newop;
5580 o->op_ppaddr = PL_ppaddr[++o->op_type];
5585 Perl_ck_delete(pTHX_ OP *o)
5589 if (o->op_flags & OPf_KIDS) {
5590 OP *kid = cUNOPo->op_first;
5591 switch (kid->op_type) {
5593 o->op_flags |= OPf_SPECIAL;
5596 o->op_private |= OPpSLICE;
5599 o->op_flags |= OPf_SPECIAL;
5604 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5613 Perl_ck_die(pTHX_ OP *o)
5616 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5622 Perl_ck_eof(pTHX_ OP *o)
5624 I32 type = o->op_type;
5626 if (o->op_flags & OPf_KIDS) {
5627 if (cLISTOPo->op_first->op_type == OP_STUB) {
5629 o = newUNOP(type, OPf_SPECIAL,
5630 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5638 Perl_ck_eval(pTHX_ OP *o)
5640 PL_hints |= HINT_BLOCK_SCOPE;
5641 if (o->op_flags & OPf_KIDS) {
5642 SVOP *kid = (SVOP*)cUNOPo->op_first;
5645 o->op_flags &= ~OPf_KIDS;
5648 else if (kid->op_type == OP_LINESEQ) {
5651 kid->op_next = o->op_next;
5652 cUNOPo->op_first = 0;
5655 NewOp(1101, enter, 1, LOGOP);
5656 enter->op_type = OP_ENTERTRY;
5657 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5658 enter->op_private = 0;
5660 /* establish postfix order */
5661 enter->op_next = (OP*)enter;
5663 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5664 o->op_type = OP_LEAVETRY;
5665 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5666 enter->op_other = o;
5674 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5676 o->op_targ = (PADOFFSET)PL_hints;
5681 Perl_ck_exit(pTHX_ OP *o)
5684 HV *table = GvHV(PL_hintgv);
5686 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5687 if (svp && *svp && SvTRUE(*svp))
5688 o->op_private |= OPpEXIT_VMSISH;
5690 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5696 Perl_ck_exec(pTHX_ OP *o)
5699 if (o->op_flags & OPf_STACKED) {
5701 kid = cUNOPo->op_first->op_sibling;
5702 if (kid->op_type == OP_RV2GV)
5711 Perl_ck_exists(pTHX_ OP *o)
5714 if (o->op_flags & OPf_KIDS) {
5715 OP *kid = cUNOPo->op_first;
5716 if (kid->op_type == OP_ENTERSUB) {
5717 (void) ref(kid, o->op_type);
5718 if (kid->op_type != OP_RV2CV && !PL_error_count)
5719 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5721 o->op_private |= OPpEXISTS_SUB;
5723 else if (kid->op_type == OP_AELEM)
5724 o->op_flags |= OPf_SPECIAL;
5725 else if (kid->op_type != OP_HELEM)
5726 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5735 Perl_ck_gvconst(pTHX_ register OP *o)
5737 o = fold_constants(o);
5738 if (o->op_type == OP_CONST)
5745 Perl_ck_rvconst(pTHX_ register OP *o)
5747 SVOP *kid = (SVOP*)cUNOPo->op_first;
5749 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5750 if (kid->op_type == OP_CONST) {
5754 SV *kidsv = kid->op_sv;
5757 /* Is it a constant from cv_const_sv()? */
5758 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5759 SV *rsv = SvRV(kidsv);
5760 int svtype = SvTYPE(rsv);
5761 char *badtype = Nullch;
5763 switch (o->op_type) {
5765 if (svtype > SVt_PVMG)
5766 badtype = "a SCALAR";
5769 if (svtype != SVt_PVAV)
5770 badtype = "an ARRAY";
5773 if (svtype != SVt_PVHV)
5777 if (svtype != SVt_PVCV)
5782 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5785 name = SvPV(kidsv, n_a);
5786 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5787 char *badthing = Nullch;
5788 switch (o->op_type) {
5790 badthing = "a SCALAR";
5793 badthing = "an ARRAY";
5796 badthing = "a HASH";
5801 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5805 * This is a little tricky. We only want to add the symbol if we
5806 * didn't add it in the lexer. Otherwise we get duplicate strict
5807 * warnings. But if we didn't add it in the lexer, we must at
5808 * least pretend like we wanted to add it even if it existed before,
5809 * or we get possible typo warnings. OPpCONST_ENTERED says
5810 * whether the lexer already added THIS instance of this symbol.
5812 iscv = (o->op_type == OP_RV2CV) * 2;
5814 gv = gv_fetchpv(name,
5815 iscv | !(kid->op_private & OPpCONST_ENTERED),
5818 : o->op_type == OP_RV2SV
5820 : o->op_type == OP_RV2AV
5822 : o->op_type == OP_RV2HV
5825 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5827 kid->op_type = OP_GV;
5828 SvREFCNT_dec(kid->op_sv);
5830 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5831 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5832 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5834 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5836 kid->op_sv = SvREFCNT_inc(gv);
5838 kid->op_private = 0;
5839 kid->op_ppaddr = PL_ppaddr[OP_GV];
5846 Perl_ck_ftst(pTHX_ OP *o)
5848 I32 type = o->op_type;
5850 if (o->op_flags & OPf_REF) {
5853 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5854 SVOP *kid = (SVOP*)cUNOPo->op_first;
5856 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5858 OP *newop = newGVOP(type, OPf_REF,
5859 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5866 if (type == OP_FTTTY)
5867 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5870 o = newUNOP(type, 0, newDEFSVOP());
5876 Perl_ck_fun(pTHX_ OP *o)
5882 int type = o->op_type;
5883 register I32 oa = PL_opargs[type] >> OASHIFT;
5885 if (o->op_flags & OPf_STACKED) {
5886 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5889 return no_fh_allowed(o);
5892 if (o->op_flags & OPf_KIDS) {
5894 tokid = &cLISTOPo->op_first;
5895 kid = cLISTOPo->op_first;
5896 if (kid->op_type == OP_PUSHMARK ||
5897 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5899 tokid = &kid->op_sibling;
5900 kid = kid->op_sibling;
5902 if (!kid && PL_opargs[type] & OA_DEFGV)
5903 *tokid = kid = newDEFSVOP();
5907 sibl = kid->op_sibling;
5910 /* list seen where single (scalar) arg expected? */
5911 if (numargs == 1 && !(oa >> 4)
5912 && kid->op_type == OP_LIST && type != OP_SCALAR)
5914 return too_many_arguments(o,PL_op_desc[type]);
5927 if ((type == OP_PUSH || type == OP_UNSHIFT)
5928 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5929 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5930 "Useless use of %s with no values",
5933 if (kid->op_type == OP_CONST &&
5934 (kid->op_private & OPpCONST_BARE))
5936 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5937 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5938 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5939 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5940 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5941 "Array @%s missing the @ in argument %"IVdf" of %s()",
5942 name, (IV)numargs, PL_op_desc[type]);
5945 kid->op_sibling = sibl;
5948 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5949 bad_type(numargs, "array", PL_op_desc[type], kid);
5953 if (kid->op_type == OP_CONST &&
5954 (kid->op_private & OPpCONST_BARE))
5956 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5957 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5958 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5959 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5960 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5961 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5962 name, (IV)numargs, PL_op_desc[type]);
5965 kid->op_sibling = sibl;
5968 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5969 bad_type(numargs, "hash", PL_op_desc[type], kid);
5974 OP *newop = newUNOP(OP_NULL, 0, kid);
5975 kid->op_sibling = 0;
5977 newop->op_next = newop;
5979 kid->op_sibling = sibl;
5984 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5985 if (kid->op_type == OP_CONST &&
5986 (kid->op_private & OPpCONST_BARE))
5988 OP *newop = newGVOP(OP_GV, 0,
5989 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5991 if (!(o->op_private & 1) && /* if not unop */
5992 kid == cLISTOPo->op_last)
5993 cLISTOPo->op_last = newop;
5997 else if (kid->op_type == OP_READLINE) {
5998 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5999 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6002 I32 flags = OPf_SPECIAL;
6006 /* is this op a FH constructor? */
6007 if (is_handle_constructor(o,numargs)) {
6008 char *name = Nullch;
6012 /* Set a flag to tell rv2gv to vivify
6013 * need to "prove" flag does not mean something
6014 * else already - NI-S 1999/05/07
6017 if (kid->op_type == OP_PADSV) {
6018 SV **namep = av_fetch(PL_comppad_name,
6020 if (namep && *namep)
6021 name = SvPV(*namep, len);
6023 else if (kid->op_type == OP_RV2SV
6024 && kUNOP->op_first->op_type == OP_GV)
6026 GV *gv = cGVOPx_gv(kUNOP->op_first);
6028 len = GvNAMELEN(gv);
6030 else if (kid->op_type == OP_AELEM
6031 || kid->op_type == OP_HELEM)
6033 name = "__ANONIO__";
6039 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6040 namesv = PL_curpad[targ];
6041 (void)SvUPGRADE(namesv, SVt_PV);
6043 sv_setpvn(namesv, "$", 1);
6044 sv_catpvn(namesv, name, len);
6047 kid->op_sibling = 0;
6048 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6049 kid->op_targ = targ;
6050 kid->op_private |= priv;
6052 kid->op_sibling = sibl;
6058 mod(scalar(kid), type);
6062 tokid = &kid->op_sibling;
6063 kid = kid->op_sibling;
6065 o->op_private |= numargs;
6067 return too_many_arguments(o,OP_DESC(o));
6070 else if (PL_opargs[type] & OA_DEFGV) {
6072 return newUNOP(type, 0, newDEFSVOP());
6076 while (oa & OA_OPTIONAL)
6078 if (oa && oa != OA_LIST)
6079 return too_few_arguments(o,OP_DESC(o));
6085 Perl_ck_glob(pTHX_ OP *o)
6090 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6091 append_elem(OP_GLOB, o, newDEFSVOP());
6093 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6094 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6096 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6099 #if !defined(PERL_EXTERNAL_GLOB)
6100 /* XXX this can be tightened up and made more failsafe. */
6104 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6105 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6106 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6107 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6108 GvCV(gv) = GvCV(glob_gv);
6109 SvREFCNT_inc((SV*)GvCV(gv));
6110 GvIMPORTED_CV_on(gv);
6113 #endif /* PERL_EXTERNAL_GLOB */
6115 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6116 append_elem(OP_GLOB, o,
6117 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6118 o->op_type = OP_LIST;
6119 o->op_ppaddr = PL_ppaddr[OP_LIST];
6120 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6121 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6122 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6123 append_elem(OP_LIST, o,
6124 scalar(newUNOP(OP_RV2CV, 0,
6125 newGVOP(OP_GV, 0, gv)))));
6126 o = newUNOP(OP_NULL, 0, ck_subr(o));
6127 o->op_targ = OP_GLOB; /* hint at what it used to be */
6130 gv = newGVgen("main");
6132 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6138 Perl_ck_grep(pTHX_ OP *o)
6142 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6144 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6145 NewOp(1101, gwop, 1, LOGOP);
6147 if (o->op_flags & OPf_STACKED) {
6150 kid = cLISTOPo->op_first->op_sibling;
6151 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6154 kid->op_next = (OP*)gwop;
6155 o->op_flags &= ~OPf_STACKED;
6157 kid = cLISTOPo->op_first->op_sibling;
6158 if (type == OP_MAPWHILE)
6165 kid = cLISTOPo->op_first->op_sibling;
6166 if (kid->op_type != OP_NULL)
6167 Perl_croak(aTHX_ "panic: ck_grep");
6168 kid = kUNOP->op_first;
6170 gwop->op_type = type;
6171 gwop->op_ppaddr = PL_ppaddr[type];
6172 gwop->op_first = listkids(o);
6173 gwop->op_flags |= OPf_KIDS;
6174 gwop->op_private = 1;
6175 gwop->op_other = LINKLIST(kid);
6176 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6177 kid->op_next = (OP*)gwop;
6179 kid = cLISTOPo->op_first->op_sibling;
6180 if (!kid || !kid->op_sibling)
6181 return too_few_arguments(o,OP_DESC(o));
6182 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6183 mod(kid, OP_GREPSTART);
6189 Perl_ck_index(pTHX_ OP *o)
6191 if (o->op_flags & OPf_KIDS) {
6192 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6194 kid = kid->op_sibling; /* get past "big" */
6195 if (kid && kid->op_type == OP_CONST)
6196 fbm_compile(((SVOP*)kid)->op_sv, 0);
6202 Perl_ck_lengthconst(pTHX_ OP *o)
6204 /* XXX length optimization goes here */
6209 Perl_ck_lfun(pTHX_ OP *o)
6211 OPCODE type = o->op_type;
6212 return modkids(ck_fun(o), type);
6216 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6218 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6219 switch (cUNOPo->op_first->op_type) {
6221 /* This is needed for
6222 if (defined %stash::)
6223 to work. Do not break Tk.
6225 break; /* Globals via GV can be undef */
6227 case OP_AASSIGN: /* Is this a good idea? */
6228 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6229 "defined(@array) is deprecated");
6230 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6231 "\t(Maybe you should just omit the defined()?)\n");
6234 /* This is needed for
6235 if (defined %stash::)
6236 to work. Do not break Tk.
6238 break; /* Globals via GV can be undef */
6240 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6241 "defined(%%hash) is deprecated");
6242 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6243 "\t(Maybe you should just omit the defined()?)\n");
6254 Perl_ck_rfun(pTHX_ OP *o)
6256 OPCODE type = o->op_type;
6257 return refkids(ck_fun(o), type);
6261 Perl_ck_listiob(pTHX_ OP *o)
6265 kid = cLISTOPo->op_first;
6268 kid = cLISTOPo->op_first;
6270 if (kid->op_type == OP_PUSHMARK)
6271 kid = kid->op_sibling;
6272 if (kid && o->op_flags & OPf_STACKED)
6273 kid = kid->op_sibling;
6274 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6275 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6276 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6277 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6278 cLISTOPo->op_first->op_sibling = kid;
6279 cLISTOPo->op_last = kid;
6280 kid = kid->op_sibling;
6285 append_elem(o->op_type, o, newDEFSVOP());
6291 Perl_ck_sassign(pTHX_ OP *o)
6293 OP *kid = cLISTOPo->op_first;
6294 /* has a disposable target? */
6295 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6296 && !(kid->op_flags & OPf_STACKED)
6297 /* Cannot steal the second time! */
6298 && !(kid->op_private & OPpTARGET_MY))
6300 OP *kkid = kid->op_sibling;
6302 /* Can just relocate the target. */
6303 if (kkid && kkid->op_type == OP_PADSV
6304 && !(kkid->op_private & OPpLVAL_INTRO))
6306 kid->op_targ = kkid->op_targ;
6308 /* Now we do not need PADSV and SASSIGN. */
6309 kid->op_sibling = o->op_sibling; /* NULL */
6310 cLISTOPo->op_first = NULL;
6313 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6321 Perl_ck_match(pTHX_ OP *o)
6323 o->op_private |= OPpRUNTIME;
6328 Perl_ck_method(pTHX_ OP *o)
6330 OP *kid = cUNOPo->op_first;
6331 if (kid->op_type == OP_CONST) {
6332 SV* sv = kSVOP->op_sv;
6333 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6335 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6336 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6339 kSVOP->op_sv = Nullsv;
6341 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6350 Perl_ck_null(pTHX_ OP *o)
6356 Perl_ck_open(pTHX_ OP *o)
6358 HV *table = GvHV(PL_hintgv);
6362 svp = hv_fetch(table, "open_IN", 7, FALSE);
6364 mode = mode_from_discipline(*svp);
6365 if (mode & O_BINARY)
6366 o->op_private |= OPpOPEN_IN_RAW;
6367 else if (mode & O_TEXT)
6368 o->op_private |= OPpOPEN_IN_CRLF;
6371 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6373 mode = mode_from_discipline(*svp);
6374 if (mode & O_BINARY)
6375 o->op_private |= OPpOPEN_OUT_RAW;
6376 else if (mode & O_TEXT)
6377 o->op_private |= OPpOPEN_OUT_CRLF;
6380 if (o->op_type == OP_BACKTICK)
6386 Perl_ck_repeat(pTHX_ OP *o)
6388 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6389 o->op_private |= OPpREPEAT_DOLIST;
6390 cBINOPo->op_first = force_list(cBINOPo->op_first);
6398 Perl_ck_require(pTHX_ OP *o)
6402 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6403 SVOP *kid = (SVOP*)cUNOPo->op_first;
6405 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6407 for (s = SvPVX(kid->op_sv); *s; s++) {
6408 if (*s == ':' && s[1] == ':') {
6410 Move(s+2, s+1, strlen(s+2)+1, char);
6411 --SvCUR(kid->op_sv);
6414 if (SvREADONLY(kid->op_sv)) {
6415 SvREADONLY_off(kid->op_sv);
6416 sv_catpvn(kid->op_sv, ".pm", 3);
6417 SvREADONLY_on(kid->op_sv);
6420 sv_catpvn(kid->op_sv, ".pm", 3);
6424 /* handle override, if any */
6425 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6426 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6427 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6429 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6430 OP *kid = cUNOPo->op_first;
6431 cUNOPo->op_first = 0;
6433 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6434 append_elem(OP_LIST, kid,
6435 scalar(newUNOP(OP_RV2CV, 0,
6444 Perl_ck_return(pTHX_ OP *o)
6447 if (CvLVALUE(PL_compcv)) {
6448 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6449 mod(kid, OP_LEAVESUBLV);
6456 Perl_ck_retarget(pTHX_ OP *o)
6458 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6465 Perl_ck_select(pTHX_ OP *o)
6468 if (o->op_flags & OPf_KIDS) {
6469 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6470 if (kid && kid->op_sibling) {
6471 o->op_type = OP_SSELECT;
6472 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6474 return fold_constants(o);
6478 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6479 if (kid && kid->op_type == OP_RV2GV)
6480 kid->op_private &= ~HINT_STRICT_REFS;
6485 Perl_ck_shift(pTHX_ OP *o)
6487 I32 type = o->op_type;
6489 if (!(o->op_flags & OPf_KIDS)) {
6493 #ifdef USE_5005THREADS
6494 if (!CvUNIQUE(PL_compcv)) {
6495 argop = newOP(OP_PADAV, OPf_REF);
6496 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6499 argop = newUNOP(OP_RV2AV, 0,
6500 scalar(newGVOP(OP_GV, 0,
6501 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6504 argop = newUNOP(OP_RV2AV, 0,
6505 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6506 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6507 #endif /* USE_5005THREADS */
6508 return newUNOP(type, 0, scalar(argop));
6510 return scalar(modkids(ck_fun(o), type));
6514 Perl_ck_sort(pTHX_ OP *o)
6518 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6520 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6521 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6523 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6525 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6527 if (kid->op_type == OP_SCOPE) {
6531 else if (kid->op_type == OP_LEAVE) {
6532 if (o->op_type == OP_SORT) {
6533 op_null(kid); /* wipe out leave */
6536 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6537 if (k->op_next == kid)
6539 /* don't descend into loops */
6540 else if (k->op_type == OP_ENTERLOOP
6541 || k->op_type == OP_ENTERITER)
6543 k = cLOOPx(k)->op_lastop;
6548 kid->op_next = 0; /* just disconnect the leave */
6549 k = kLISTOP->op_first;
6554 if (o->op_type == OP_SORT) {
6555 /* provide scalar context for comparison function/block */
6561 o->op_flags |= OPf_SPECIAL;
6563 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6566 firstkid = firstkid->op_sibling;
6569 /* provide list context for arguments */
6570 if (o->op_type == OP_SORT)
6577 S_simplify_sort(pTHX_ OP *o)
6579 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6583 if (!(o->op_flags & OPf_STACKED))
6585 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6586 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6587 kid = kUNOP->op_first; /* get past null */
6588 if (kid->op_type != OP_SCOPE)
6590 kid = kLISTOP->op_last; /* get past scope */
6591 switch(kid->op_type) {
6599 k = kid; /* remember this node*/
6600 if (kBINOP->op_first->op_type != OP_RV2SV)
6602 kid = kBINOP->op_first; /* get past cmp */
6603 if (kUNOP->op_first->op_type != OP_GV)
6605 kid = kUNOP->op_first; /* get past rv2sv */
6607 if (GvSTASH(gv) != PL_curstash)
6609 if (strEQ(GvNAME(gv), "a"))
6611 else if (strEQ(GvNAME(gv), "b"))
6615 kid = k; /* back to cmp */
6616 if (kBINOP->op_last->op_type != OP_RV2SV)
6618 kid = kBINOP->op_last; /* down to 2nd arg */
6619 if (kUNOP->op_first->op_type != OP_GV)
6621 kid = kUNOP->op_first; /* get past rv2sv */
6623 if (GvSTASH(gv) != PL_curstash
6625 ? strNE(GvNAME(gv), "a")
6626 : strNE(GvNAME(gv), "b")))
6628 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6630 o->op_private |= OPpSORT_REVERSE;
6631 if (k->op_type == OP_NCMP)
6632 o->op_private |= OPpSORT_NUMERIC;
6633 if (k->op_type == OP_I_NCMP)
6634 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6635 kid = cLISTOPo->op_first->op_sibling;
6636 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6637 op_free(kid); /* then delete it */
6641 Perl_ck_split(pTHX_ OP *o)
6645 if (o->op_flags & OPf_STACKED)
6646 return no_fh_allowed(o);
6648 kid = cLISTOPo->op_first;
6649 if (kid->op_type != OP_NULL)
6650 Perl_croak(aTHX_ "panic: ck_split");
6651 kid = kid->op_sibling;
6652 op_free(cLISTOPo->op_first);
6653 cLISTOPo->op_first = kid;
6655 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6656 cLISTOPo->op_last = kid; /* There was only one element previously */
6659 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6660 OP *sibl = kid->op_sibling;
6661 kid->op_sibling = 0;
6662 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6663 if (cLISTOPo->op_first == cLISTOPo->op_last)
6664 cLISTOPo->op_last = kid;
6665 cLISTOPo->op_first = kid;
6666 kid->op_sibling = sibl;
6669 kid->op_type = OP_PUSHRE;
6670 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6672 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6673 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6674 "Use of /g modifier is meaningless in split");
6677 if (!kid->op_sibling)
6678 append_elem(OP_SPLIT, o, newDEFSVOP());
6680 kid = kid->op_sibling;
6683 if (!kid->op_sibling)
6684 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6686 kid = kid->op_sibling;
6689 if (kid->op_sibling)
6690 return too_many_arguments(o,OP_DESC(o));
6696 Perl_ck_join(pTHX_ OP *o)
6698 if (ckWARN(WARN_SYNTAX)) {
6699 OP *kid = cLISTOPo->op_first->op_sibling;
6700 if (kid && kid->op_type == OP_MATCH) {
6701 char *pmstr = "STRING";
6702 if (PM_GETRE(kPMOP))
6703 pmstr = PM_GETRE(kPMOP)->precomp;
6704 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6705 "/%s/ should probably be written as \"%s\"",
6713 Perl_ck_subr(pTHX_ OP *o)
6715 OP *prev = ((cUNOPo->op_first->op_sibling)
6716 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6717 OP *o2 = prev->op_sibling;
6724 I32 contextclass = 0;
6728 o->op_private |= OPpENTERSUB_HASTARG;
6729 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6730 if (cvop->op_type == OP_RV2CV) {
6732 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6733 op_null(cvop); /* disable rv2cv */
6734 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6735 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6736 GV *gv = cGVOPx_gv(tmpop);
6739 tmpop->op_private |= OPpEARLY_CV;
6740 else if (SvPOK(cv)) {
6741 namegv = CvANON(cv) ? gv : CvGV(cv);
6742 proto = SvPV((SV*)cv, n_a);
6746 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6747 if (o2->op_type == OP_CONST)
6748 o2->op_private &= ~OPpCONST_STRICT;
6749 else if (o2->op_type == OP_LIST) {
6750 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6751 if (o && o->op_type == OP_CONST)
6752 o->op_private &= ~OPpCONST_STRICT;
6755 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6756 if (PERLDB_SUB && PL_curstash != PL_debstash)
6757 o->op_private |= OPpENTERSUB_DB;
6758 while (o2 != cvop) {
6762 return too_many_arguments(o, gv_ename(namegv));
6780 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6782 arg == 1 ? "block or sub {}" : "sub {}",
6783 gv_ename(namegv), o2);
6786 /* '*' allows any scalar type, including bareword */
6789 if (o2->op_type == OP_RV2GV)
6790 goto wrapref; /* autoconvert GLOB -> GLOBref */
6791 else if (o2->op_type == OP_CONST)
6792 o2->op_private &= ~OPpCONST_STRICT;
6793 else if (o2->op_type == OP_ENTERSUB) {
6794 /* accidental subroutine, revert to bareword */
6795 OP *gvop = ((UNOP*)o2)->op_first;
6796 if (gvop && gvop->op_type == OP_NULL) {
6797 gvop = ((UNOP*)gvop)->op_first;
6799 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6802 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6803 (gvop = ((UNOP*)gvop)->op_first) &&
6804 gvop->op_type == OP_GV)
6806 GV *gv = cGVOPx_gv(gvop);
6807 OP *sibling = o2->op_sibling;
6808 SV *n = newSVpvn("",0);
6810 gv_fullname3(n, gv, "");
6811 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6812 sv_chop(n, SvPVX(n)+6);
6813 o2 = newSVOP(OP_CONST, 0, n);
6814 prev->op_sibling = o2;
6815 o2->op_sibling = sibling;
6831 if (contextclass++ == 0) {
6832 e = strchr(proto, ']');
6833 if (!e || e == proto)
6846 while (*--p != '[');
6847 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6848 gv_ename(namegv), o2);
6854 if (o2->op_type == OP_RV2GV)
6857 bad_type(arg, "symbol", gv_ename(namegv), o2);
6860 if (o2->op_type == OP_ENTERSUB)
6863 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6866 if (o2->op_type == OP_RV2SV ||
6867 o2->op_type == OP_PADSV ||
6868 o2->op_type == OP_HELEM ||
6869 o2->op_type == OP_AELEM ||
6870 o2->op_type == OP_THREADSV)
6873 bad_type(arg, "scalar", gv_ename(namegv), o2);
6876 if (o2->op_type == OP_RV2AV ||
6877 o2->op_type == OP_PADAV)
6880 bad_type(arg, "array", gv_ename(namegv), o2);
6883 if (o2->op_type == OP_RV2HV ||
6884 o2->op_type == OP_PADHV)
6887 bad_type(arg, "hash", gv_ename(namegv), o2);
6892 OP* sib = kid->op_sibling;
6893 kid->op_sibling = 0;
6894 o2 = newUNOP(OP_REFGEN, 0, kid);
6895 o2->op_sibling = sib;
6896 prev->op_sibling = o2;
6898 if (contextclass && e) {
6913 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6914 gv_ename(namegv), SvPV((SV*)cv, n_a));
6919 mod(o2, OP_ENTERSUB);
6921 o2 = o2->op_sibling;
6923 if (proto && !optional &&
6924 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6925 return too_few_arguments(o, gv_ename(namegv));
6930 Perl_ck_svconst(pTHX_ OP *o)
6932 SvREADONLY_on(cSVOPo->op_sv);
6937 Perl_ck_trunc(pTHX_ OP *o)
6939 if (o->op_flags & OPf_KIDS) {
6940 SVOP *kid = (SVOP*)cUNOPo->op_first;
6942 if (kid->op_type == OP_NULL)
6943 kid = (SVOP*)kid->op_sibling;
6944 if (kid && kid->op_type == OP_CONST &&
6945 (kid->op_private & OPpCONST_BARE))
6947 o->op_flags |= OPf_SPECIAL;
6948 kid->op_private &= ~OPpCONST_STRICT;
6955 Perl_ck_substr(pTHX_ OP *o)
6958 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6959 OP *kid = cLISTOPo->op_first;
6961 if (kid->op_type == OP_NULL)
6962 kid = kid->op_sibling;
6964 kid->op_flags |= OPf_MOD;
6970 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6973 Perl_peep(pTHX_ register OP *o)
6975 register OP* oldop = 0;
6977 if (!o || o->op_seq)
6981 SAVEVPTR(PL_curcop);
6982 for (; o; o = o->op_next) {
6988 switch (o->op_type) {
6992 PL_curcop = ((COP*)o); /* for warnings */
6993 o->op_seq = PL_op_seqmax++;
6997 if (cSVOPo->op_private & OPpCONST_STRICT)
6998 no_bareword_allowed(o);
7000 /* Relocate sv to the pad for thread safety.
7001 * Despite being a "constant", the SV is written to,
7002 * for reference counts, sv_upgrade() etc. */
7004 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7005 if (SvPADTMP(cSVOPo->op_sv)) {
7006 /* If op_sv is already a PADTMP then it is being used by
7007 * some pad, so make a copy. */
7008 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
7009 SvREADONLY_on(PL_curpad[ix]);
7010 SvREFCNT_dec(cSVOPo->op_sv);
7013 SvREFCNT_dec(PL_curpad[ix]);
7014 SvPADTMP_on(cSVOPo->op_sv);
7015 PL_curpad[ix] = cSVOPo->op_sv;
7016 /* XXX I don't know how this isn't readonly already. */
7017 SvREADONLY_on(PL_curpad[ix]);
7019 cSVOPo->op_sv = Nullsv;
7023 o->op_seq = PL_op_seqmax++;
7027 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7028 if (o->op_next->op_private & OPpTARGET_MY) {
7029 if (o->op_flags & OPf_STACKED) /* chained concats */
7030 goto ignore_optimization;
7032 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7033 o->op_targ = o->op_next->op_targ;
7034 o->op_next->op_targ = 0;
7035 o->op_private |= OPpTARGET_MY;
7038 op_null(o->op_next);
7040 ignore_optimization:
7041 o->op_seq = PL_op_seqmax++;
7044 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7045 o->op_seq = PL_op_seqmax++;
7046 break; /* Scalar stub must produce undef. List stub is noop */
7050 if (o->op_targ == OP_NEXTSTATE
7051 || o->op_targ == OP_DBSTATE
7052 || o->op_targ == OP_SETSTATE)
7054 PL_curcop = ((COP*)o);
7056 /* XXX: We avoid setting op_seq here to prevent later calls
7057 to peep() from mistakenly concluding that optimisation
7058 has already occurred. This doesn't fix the real problem,
7059 though (See 20010220.007). AMS 20010719 */
7060 if (oldop && o->op_next) {
7061 oldop->op_next = o->op_next;
7069 if (oldop && o->op_next) {
7070 oldop->op_next = o->op_next;
7073 o->op_seq = PL_op_seqmax++;
7077 if (o->op_next->op_type == OP_RV2SV) {
7078 if (!(o->op_next->op_private & OPpDEREF)) {
7079 op_null(o->op_next);
7080 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7082 o->op_next = o->op_next->op_next;
7083 o->op_type = OP_GVSV;
7084 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7087 else if (o->op_next->op_type == OP_RV2AV) {
7088 OP* pop = o->op_next->op_next;
7090 if (pop && pop->op_type == OP_CONST &&
7091 (PL_op = pop->op_next) &&
7092 pop->op_next->op_type == OP_AELEM &&
7093 !(pop->op_next->op_private &
7094 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7095 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7100 op_null(o->op_next);
7101 op_null(pop->op_next);
7103 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7104 o->op_next = pop->op_next->op_next;
7105 o->op_type = OP_AELEMFAST;
7106 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7107 o->op_private = (U8)i;
7112 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7114 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7115 /* XXX could check prototype here instead of just carping */
7116 SV *sv = sv_newmortal();
7117 gv_efullname3(sv, gv, Nullch);
7118 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7119 "%s() called too early to check prototype",
7123 else if (o->op_next->op_type == OP_READLINE
7124 && o->op_next->op_next->op_type == OP_CONCAT
7125 && (o->op_next->op_next->op_flags & OPf_STACKED))
7127 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7128 o->op_type = OP_RCATLINE;
7129 o->op_flags |= OPf_STACKED;
7130 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7131 op_null(o->op_next->op_next);
7132 op_null(o->op_next);
7135 o->op_seq = PL_op_seqmax++;
7148 o->op_seq = PL_op_seqmax++;
7149 while (cLOGOP->op_other->op_type == OP_NULL)
7150 cLOGOP->op_other = cLOGOP->op_other->op_next;
7151 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7156 o->op_seq = PL_op_seqmax++;
7157 while (cLOOP->op_redoop->op_type == OP_NULL)
7158 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7159 peep(cLOOP->op_redoop);
7160 while (cLOOP->op_nextop->op_type == OP_NULL)
7161 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7162 peep(cLOOP->op_nextop);
7163 while (cLOOP->op_lastop->op_type == OP_NULL)
7164 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7165 peep(cLOOP->op_lastop);
7171 o->op_seq = PL_op_seqmax++;
7172 while (cPMOP->op_pmreplstart &&
7173 cPMOP->op_pmreplstart->op_type == OP_NULL)
7174 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7175 peep(cPMOP->op_pmreplstart);
7179 o->op_seq = PL_op_seqmax++;
7180 if (ckWARN(WARN_SYNTAX) && o->op_next
7181 && o->op_next->op_type == OP_NEXTSTATE) {
7182 if (o->op_next->op_sibling &&
7183 o->op_next->op_sibling->op_type != OP_EXIT &&
7184 o->op_next->op_sibling->op_type != OP_WARN &&
7185 o->op_next->op_sibling->op_type != OP_DIE) {
7186 line_t oldline = CopLINE(PL_curcop);
7188 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7189 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7190 "Statement unlikely to be reached");
7191 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7192 "\t(Maybe you meant system() when you said exec()?)\n");
7193 CopLINE_set(PL_curcop, oldline);
7204 o->op_seq = PL_op_seqmax++;
7206 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7209 /* Make the CONST have a shared SV */
7210 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7211 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7212 key = SvPV(sv, keylen);
7213 lexname = newSVpvn_share(key,
7214 SvUTF8(sv) ? -(I32)keylen : keylen,
7223 o->op_seq = PL_op_seqmax++;
7233 char* Perl_custom_op_name(pTHX_ OP* o)
7235 IV index = PTR2IV(o->op_ppaddr);
7239 if (!PL_custom_op_names) /* This probably shouldn't happen */
7240 return PL_op_name[OP_CUSTOM];
7242 keysv = sv_2mortal(newSViv(index));
7244 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7246 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7248 return SvPV_nolen(HeVAL(he));
7251 char* Perl_custom_op_desc(pTHX_ OP* o)
7253 IV index = PTR2IV(o->op_ppaddr);
7257 if (!PL_custom_op_descs)
7258 return PL_op_desc[OP_CUSTOM];
7260 keysv = sv_2mortal(newSViv(index));
7262 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7264 return PL_op_desc[OP_CUSTOM];
7266 return SvPV_nolen(HeVAL(he));
7272 /* Efficient sub that returns a constant scalar value. */
7274 const_sv_xsub(pTHX_ CV* cv)
7279 Perl_croak(aTHX_ "usage: %s::%s()",
7280 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7284 ST(0) = (SV*)XSANY.any_ptr;