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 */
641 SvPADTMP_off(PL_curpad[po]);
642 PL_curpad[po] = NEWSV(1107,0);
643 SvPADTMP_on(PL_curpad[po]);
644 if ((I32)po < PL_padix)
648 /* XXX pad_reset() is currently disabled because it results in serious bugs.
649 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
650 * on the stack by OPs that use them, there are several ways to get an alias
651 * to a shared TARG. Such an alias will change randomly and unpredictably.
652 * We avoid doing this until we can think of a Better Way.
657 #ifdef USE_BROKEN_PAD_RESET
660 if (AvARRAY(PL_comppad) != PL_curpad)
661 Perl_croak(aTHX_ "panic: pad_reset curpad");
662 #ifdef USE_5005THREADS
663 DEBUG_X(PerlIO_printf(Perl_debug_log,
664 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
665 PTR2UV(thr), PTR2UV(PL_curpad)));
667 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
669 #endif /* USE_5005THREADS */
670 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
671 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
672 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
673 SvPADTMP_off(PL_curpad[po]);
675 PL_padix = PL_padix_floor;
678 PL_pad_reset_pending = FALSE;
681 #ifdef USE_5005THREADS
682 /* find_threadsv is not reentrant */
684 Perl_find_threadsv(pTHX_ const char *name)
689 /* We currently only handle names of a single character */
690 p = strchr(PL_threadsv_names, *name);
693 key = p - PL_threadsv_names;
694 MUTEX_LOCK(&thr->mutex);
695 svp = av_fetch(thr->threadsv, key, FALSE);
697 MUTEX_UNLOCK(&thr->mutex);
699 SV *sv = NEWSV(0, 0);
700 av_store(thr->threadsv, key, sv);
701 thr->threadsvp = AvARRAY(thr->threadsv);
702 MUTEX_UNLOCK(&thr->mutex);
704 * Some magic variables used to be automagically initialised
705 * in gv_fetchpv. Those which are now per-thread magicals get
706 * initialised here instead.
712 sv_setpv(sv, "\034");
713 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
718 PL_sawampersand = TRUE;
732 /* XXX %! tied to Errno.pm needs to be added here.
733 * See gv_fetchpv(). */
737 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
739 DEBUG_S(PerlIO_printf(Perl_error_log,
740 "find_threadsv: new SV %p for $%s%c\n",
741 sv, (*name < 32) ? "^" : "",
742 (*name < 32) ? toCTRL(*name) : *name));
746 #endif /* USE_5005THREADS */
751 Perl_op_free(pTHX_ OP *o)
753 register OP *kid, *nextkid;
756 if (!o || o->op_seq == (U16)-1)
759 if (o->op_private & OPpREFCOUNTED) {
760 switch (o->op_type) {
768 if (OpREFCNT_dec(o)) {
779 if (o->op_flags & OPf_KIDS) {
780 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
781 nextkid = kid->op_sibling; /* Get before next freeing kid */
787 type = (OPCODE)o->op_targ;
789 /* COP* is not cleared by op_clear() so that we may track line
790 * numbers etc even after null() */
791 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
799 Perl_op_clear(pTHX_ OP *o)
802 switch (o->op_type) {
803 case OP_NULL: /* Was holding old type, if any. */
804 case OP_ENTEREVAL: /* Was holding hints. */
805 #ifdef USE_5005THREADS
806 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
810 #ifdef USE_5005THREADS
812 if (!(o->op_flags & OPf_SPECIAL))
815 #endif /* USE_5005THREADS */
817 if (!(o->op_flags & OPf_REF)
818 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
825 if (cPADOPo->op_padix > 0) {
828 pad_swipe(cPADOPo->op_padix);
829 /* No GvIN_PAD_off(gv) here, because other references may still
830 * exist on the pad */
833 cPADOPo->op_padix = 0;
836 SvREFCNT_dec(cSVOPo->op_sv);
837 cSVOPo->op_sv = Nullsv;
840 case OP_METHOD_NAMED:
842 SvREFCNT_dec(cSVOPo->op_sv);
843 cSVOPo->op_sv = Nullsv;
849 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
853 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
854 SvREFCNT_dec(cSVOPo->op_sv);
855 cSVOPo->op_sv = Nullsv;
858 Safefree(cPVOPo->op_pv);
859 cPVOPo->op_pv = Nullch;
863 op_free(cPMOPo->op_pmreplroot);
867 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
869 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
870 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
871 /* No GvIN_PAD_off(gv) here, because other references may still
872 * exist on the pad */
877 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
884 HV *pmstash = PmopSTASH(cPMOPo);
885 if (pmstash && SvREFCNT(pmstash)) {
886 PMOP *pmop = HvPMROOT(pmstash);
887 PMOP *lastpmop = NULL;
889 if (cPMOPo == pmop) {
891 lastpmop->op_pmnext = pmop->op_pmnext;
893 HvPMROOT(pmstash) = pmop->op_pmnext;
897 pmop = pmop->op_pmnext;
900 PmopSTASH_free(cPMOPo);
902 cPMOPo->op_pmreplroot = Nullop;
903 /* we use the "SAFE" version of the PM_ macros here
904 * since sv_clean_all might release some PMOPs
905 * after PL_regex_padav has been cleared
906 * and the clearing of PL_regex_padav needs to
907 * happen before sv_clean_all
909 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
910 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
912 if(PL_regex_pad) { /* We could be in destruction */
913 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
914 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
915 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
922 if (o->op_targ > 0) {
923 pad_free(o->op_targ);
929 S_cop_free(pTHX_ COP* cop)
931 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
934 if (! specialWARN(cop->cop_warnings))
935 SvREFCNT_dec(cop->cop_warnings);
936 if (! specialCopIO(cop->cop_io)) {
940 char *s = SvPV(cop->cop_io,len);
941 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
944 SvREFCNT_dec(cop->cop_io);
950 Perl_op_null(pTHX_ OP *o)
952 if (o->op_type == OP_NULL)
955 o->op_targ = o->op_type;
956 o->op_type = OP_NULL;
957 o->op_ppaddr = PL_ppaddr[OP_NULL];
960 /* Contextualizers */
962 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
965 Perl_linklist(pTHX_ OP *o)
972 /* establish postfix order */
973 if (cUNOPo->op_first) {
974 o->op_next = LINKLIST(cUNOPo->op_first);
975 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
977 kid->op_next = LINKLIST(kid->op_sibling);
989 Perl_scalarkids(pTHX_ OP *o)
992 if (o && o->op_flags & OPf_KIDS) {
993 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1000 S_scalarboolean(pTHX_ OP *o)
1002 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
1003 if (ckWARN(WARN_SYNTAX)) {
1004 line_t oldline = CopLINE(PL_curcop);
1006 if (PL_copline != NOLINE)
1007 CopLINE_set(PL_curcop, PL_copline);
1008 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1009 CopLINE_set(PL_curcop, oldline);
1016 Perl_scalar(pTHX_ OP *o)
1020 /* assumes no premature commitment */
1021 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1022 || o->op_type == OP_RETURN)
1027 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1029 switch (o->op_type) {
1031 scalar(cBINOPo->op_first);
1036 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1040 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1041 if (!kPMOP->op_pmreplroot)
1042 deprecate_old("implicit split to @_");
1050 if (o->op_flags & OPf_KIDS) {
1051 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1057 kid = cLISTOPo->op_first;
1059 while ((kid = kid->op_sibling)) {
1060 if (kid->op_sibling)
1065 WITH_THR(PL_curcop = &PL_compiling);
1070 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1071 if (kid->op_sibling)
1076 WITH_THR(PL_curcop = &PL_compiling);
1079 if (ckWARN(WARN_VOID))
1080 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1086 Perl_scalarvoid(pTHX_ OP *o)
1093 if (o->op_type == OP_NEXTSTATE
1094 || o->op_type == OP_SETSTATE
1095 || o->op_type == OP_DBSTATE
1096 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1097 || o->op_targ == OP_SETSTATE
1098 || o->op_targ == OP_DBSTATE)))
1099 PL_curcop = (COP*)o; /* for warning below */
1101 /* assumes no premature commitment */
1102 want = o->op_flags & OPf_WANT;
1103 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1104 || o->op_type == OP_RETURN)
1109 if ((o->op_private & OPpTARGET_MY)
1110 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1112 return scalar(o); /* As if inside SASSIGN */
1115 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1117 switch (o->op_type) {
1119 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1123 if (o->op_flags & OPf_STACKED)
1127 if (o->op_private == 4)
1169 case OP_GETSOCKNAME:
1170 case OP_GETPEERNAME:
1175 case OP_GETPRIORITY:
1198 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1199 useless = OP_DESC(o);
1206 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1207 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1208 useless = "a variable";
1213 if (cSVOPo->op_private & OPpCONST_STRICT)
1214 no_bareword_allowed(o);
1216 if (ckWARN(WARN_VOID)) {
1217 useless = "a constant";
1218 /* the constants 0 and 1 are permitted as they are
1219 conventionally used as dummies in constructs like
1220 1 while some_condition_with_side_effects; */
1221 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1223 else if (SvPOK(sv)) {
1224 /* perl4's way of mixing documentation and code
1225 (before the invention of POD) was based on a
1226 trick to mix nroff and perl code. The trick was
1227 built upon these three nroff macros being used in
1228 void context. The pink camel has the details in
1229 the script wrapman near page 319. */
1230 if (strnEQ(SvPVX(sv), "di", 2) ||
1231 strnEQ(SvPVX(sv), "ds", 2) ||
1232 strnEQ(SvPVX(sv), "ig", 2))
1237 op_null(o); /* don't execute or even remember it */
1241 o->op_type = OP_PREINC; /* pre-increment is faster */
1242 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1246 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1247 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1254 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1259 if (o->op_flags & OPf_STACKED)
1266 if (!(o->op_flags & OPf_KIDS))
1275 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1282 /* all requires must return a boolean value */
1283 o->op_flags &= ~OPf_WANT;
1288 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1289 if (!kPMOP->op_pmreplroot)
1290 deprecate_old("implicit split to @_");
1294 if (useless && ckWARN(WARN_VOID))
1295 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1300 Perl_listkids(pTHX_ OP *o)
1303 if (o && o->op_flags & OPf_KIDS) {
1304 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1311 Perl_list(pTHX_ OP *o)
1315 /* assumes no premature commitment */
1316 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1317 || o->op_type == OP_RETURN)
1322 if ((o->op_private & OPpTARGET_MY)
1323 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1325 return o; /* As if inside SASSIGN */
1328 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1330 switch (o->op_type) {
1333 list(cBINOPo->op_first);
1338 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1346 if (!(o->op_flags & OPf_KIDS))
1348 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1349 list(cBINOPo->op_first);
1350 return gen_constant_list(o);
1357 kid = cLISTOPo->op_first;
1359 while ((kid = kid->op_sibling)) {
1360 if (kid->op_sibling)
1365 WITH_THR(PL_curcop = &PL_compiling);
1369 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1370 if (kid->op_sibling)
1375 WITH_THR(PL_curcop = &PL_compiling);
1378 /* all requires must return a boolean value */
1379 o->op_flags &= ~OPf_WANT;
1386 Perl_scalarseq(pTHX_ OP *o)
1391 if (o->op_type == OP_LINESEQ ||
1392 o->op_type == OP_SCOPE ||
1393 o->op_type == OP_LEAVE ||
1394 o->op_type == OP_LEAVETRY)
1396 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1397 if (kid->op_sibling) {
1401 PL_curcop = &PL_compiling;
1403 o->op_flags &= ~OPf_PARENS;
1404 if (PL_hints & HINT_BLOCK_SCOPE)
1405 o->op_flags |= OPf_PARENS;
1408 o = newOP(OP_STUB, 0);
1413 S_modkids(pTHX_ OP *o, I32 type)
1416 if (o && o->op_flags & OPf_KIDS) {
1417 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1424 Perl_mod(pTHX_ OP *o, I32 type)
1429 if (!o || PL_error_count)
1432 if ((o->op_private & OPpTARGET_MY)
1433 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1438 switch (o->op_type) {
1443 if (!(o->op_private & (OPpCONST_ARYBASE)))
1445 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1446 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1450 SAVEI32(PL_compiling.cop_arybase);
1451 PL_compiling.cop_arybase = 0;
1453 else if (type == OP_REFGEN)
1456 Perl_croak(aTHX_ "That use of $[ is unsupported");
1459 if (o->op_flags & OPf_PARENS)
1463 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1464 !(o->op_flags & OPf_STACKED)) {
1465 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1466 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1467 assert(cUNOPo->op_first->op_type == OP_NULL);
1468 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1471 else if (o->op_private & OPpENTERSUB_NOMOD)
1473 else { /* lvalue subroutine call */
1474 o->op_private |= OPpLVAL_INTRO;
1475 PL_modcount = RETURN_UNLIMITED_NUMBER;
1476 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1477 /* Backward compatibility mode: */
1478 o->op_private |= OPpENTERSUB_INARGS;
1481 else { /* Compile-time error message: */
1482 OP *kid = cUNOPo->op_first;
1486 if (kid->op_type == OP_PUSHMARK)
1488 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1490 "panic: unexpected lvalue entersub "
1491 "args: type/targ %ld:%"UVuf,
1492 (long)kid->op_type, (UV)kid->op_targ);
1493 kid = kLISTOP->op_first;
1495 while (kid->op_sibling)
1496 kid = kid->op_sibling;
1497 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1499 if (kid->op_type == OP_METHOD_NAMED
1500 || kid->op_type == OP_METHOD)
1504 NewOp(1101, newop, 1, UNOP);
1505 newop->op_type = OP_RV2CV;
1506 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1507 newop->op_first = Nullop;
1508 newop->op_next = (OP*)newop;
1509 kid->op_sibling = (OP*)newop;
1510 newop->op_private |= OPpLVAL_INTRO;
1514 if (kid->op_type != OP_RV2CV)
1516 "panic: unexpected lvalue entersub "
1517 "entry via type/targ %ld:%"UVuf,
1518 (long)kid->op_type, (UV)kid->op_targ);
1519 kid->op_private |= OPpLVAL_INTRO;
1520 break; /* Postpone until runtime */
1524 kid = kUNOP->op_first;
1525 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1526 kid = kUNOP->op_first;
1527 if (kid->op_type == OP_NULL)
1529 "Unexpected constant lvalue entersub "
1530 "entry via type/targ %ld:%"UVuf,
1531 (long)kid->op_type, (UV)kid->op_targ);
1532 if (kid->op_type != OP_GV) {
1533 /* Restore RV2CV to check lvalueness */
1535 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1536 okid->op_next = kid->op_next;
1537 kid->op_next = okid;
1540 okid->op_next = Nullop;
1541 okid->op_type = OP_RV2CV;
1543 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1544 okid->op_private |= OPpLVAL_INTRO;
1548 cv = GvCV(kGVOP_gv);
1558 /* grep, foreach, subcalls, refgen */
1559 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1561 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1562 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1564 : (o->op_type == OP_ENTERSUB
1565 ? "non-lvalue subroutine call"
1567 type ? PL_op_desc[type] : "local"));
1581 case OP_RIGHT_SHIFT:
1590 if (!(o->op_flags & OPf_STACKED))
1596 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1602 if (!type && cUNOPo->op_first->op_type != OP_GV)
1603 Perl_croak(aTHX_ "Can't localize through a reference");
1604 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1605 PL_modcount = RETURN_UNLIMITED_NUMBER;
1606 return o; /* Treat \(@foo) like ordinary list. */
1610 if (scalar_mod_type(o, type))
1612 ref(cUNOPo->op_first, o->op_type);
1616 if (type == OP_LEAVESUBLV)
1617 o->op_private |= OPpMAYBE_LVSUB;
1622 PL_modcount = RETURN_UNLIMITED_NUMBER;
1625 if (!type && cUNOPo->op_first->op_type != OP_GV)
1626 Perl_croak(aTHX_ "Can't localize through a reference");
1627 ref(cUNOPo->op_first, o->op_type);
1631 PL_hints |= HINT_BLOCK_SCOPE;
1642 PL_modcount = RETURN_UNLIMITED_NUMBER;
1643 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1644 return o; /* Treat \(@foo) like ordinary list. */
1645 if (scalar_mod_type(o, type))
1647 if (type == OP_LEAVESUBLV)
1648 o->op_private |= OPpMAYBE_LVSUB;
1653 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1654 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1657 #ifdef USE_5005THREADS
1659 PL_modcount++; /* XXX ??? */
1661 #endif /* USE_5005THREADS */
1667 if (type != OP_SASSIGN)
1671 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1676 if (type == OP_LEAVESUBLV)
1677 o->op_private |= OPpMAYBE_LVSUB;
1679 pad_free(o->op_targ);
1680 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1681 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1682 if (o->op_flags & OPf_KIDS)
1683 mod(cBINOPo->op_first->op_sibling, type);
1688 ref(cBINOPo->op_first, o->op_type);
1689 if (type == OP_ENTERSUB &&
1690 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1691 o->op_private |= OPpLVAL_DEFER;
1692 if (type == OP_LEAVESUBLV)
1693 o->op_private |= OPpMAYBE_LVSUB;
1701 if (o->op_flags & OPf_KIDS)
1702 mod(cLISTOPo->op_last, type);
1706 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1708 else if (!(o->op_flags & OPf_KIDS))
1710 if (o->op_targ != OP_LIST) {
1711 mod(cBINOPo->op_first, type);
1716 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1721 if (type != OP_LEAVESUBLV)
1723 break; /* mod()ing was handled by ck_return() */
1726 /* [20011101.069] File test operators interpret OPf_REF to mean that
1727 their argument is a filehandle; thus \stat(".") should not set
1729 if (type == OP_REFGEN &&
1730 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1733 if (type != OP_LEAVESUBLV)
1734 o->op_flags |= OPf_MOD;
1736 if (type == OP_AASSIGN || type == OP_SASSIGN)
1737 o->op_flags |= OPf_SPECIAL|OPf_REF;
1739 o->op_private |= OPpLVAL_INTRO;
1740 o->op_flags &= ~OPf_SPECIAL;
1741 PL_hints |= HINT_BLOCK_SCOPE;
1743 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1744 && type != OP_LEAVESUBLV)
1745 o->op_flags |= OPf_REF;
1750 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1754 if (o->op_type == OP_RV2GV)
1778 case OP_RIGHT_SHIFT:
1797 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1799 switch (o->op_type) {
1807 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1820 Perl_refkids(pTHX_ OP *o, I32 type)
1823 if (o && o->op_flags & OPf_KIDS) {
1824 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1831 Perl_ref(pTHX_ OP *o, I32 type)
1835 if (!o || PL_error_count)
1838 switch (o->op_type) {
1840 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1841 !(o->op_flags & OPf_STACKED)) {
1842 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1843 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1844 assert(cUNOPo->op_first->op_type == OP_NULL);
1845 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1846 o->op_flags |= OPf_SPECIAL;
1851 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1855 if (type == OP_DEFINED)
1856 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1857 ref(cUNOPo->op_first, o->op_type);
1860 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1861 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1862 : type == OP_RV2HV ? OPpDEREF_HV
1864 o->op_flags |= OPf_MOD;
1869 o->op_flags |= OPf_MOD; /* XXX ??? */
1874 o->op_flags |= OPf_REF;
1877 if (type == OP_DEFINED)
1878 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1879 ref(cUNOPo->op_first, o->op_type);
1884 o->op_flags |= OPf_REF;
1889 if (!(o->op_flags & OPf_KIDS))
1891 ref(cBINOPo->op_first, type);
1895 ref(cBINOPo->op_first, o->op_type);
1896 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1897 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1898 : type == OP_RV2HV ? OPpDEREF_HV
1900 o->op_flags |= OPf_MOD;
1908 if (!(o->op_flags & OPf_KIDS))
1910 ref(cLISTOPo->op_last, type);
1920 S_dup_attrlist(pTHX_ OP *o)
1924 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1925 * where the first kid is OP_PUSHMARK and the remaining ones
1926 * are OP_CONST. We need to push the OP_CONST values.
1928 if (o->op_type == OP_CONST)
1929 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1931 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1932 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1933 if (o->op_type == OP_CONST)
1934 rop = append_elem(OP_LIST, rop,
1935 newSVOP(OP_CONST, o->op_flags,
1936 SvREFCNT_inc(cSVOPo->op_sv)));
1943 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1947 /* fake up C<use attributes $pkg,$rv,@attrs> */
1948 ENTER; /* need to protect against side-effects of 'use' */
1951 stashsv = newSVpv(HvNAME(stash), 0);
1953 stashsv = &PL_sv_no;
1955 #define ATTRSMODULE "attributes"
1956 #define ATTRSMODULE_PM "attributes.pm"
1960 /* Don't force the C<use> if we don't need it. */
1961 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1962 sizeof(ATTRSMODULE_PM)-1, 0);
1963 if (svp && *svp != &PL_sv_undef)
1964 ; /* already in %INC */
1966 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1967 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1971 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1972 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1974 prepend_elem(OP_LIST,
1975 newSVOP(OP_CONST, 0, stashsv),
1976 prepend_elem(OP_LIST,
1977 newSVOP(OP_CONST, 0,
1979 dup_attrlist(attrs))));
1985 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1987 OP *pack, *imop, *arg;
1993 assert(target->op_type == OP_PADSV ||
1994 target->op_type == OP_PADHV ||
1995 target->op_type == OP_PADAV);
1997 /* Ensure that attributes.pm is loaded. */
1998 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
2000 /* Need package name for method call. */
2001 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
2003 /* Build up the real arg-list. */
2005 stashsv = newSVpv(HvNAME(stash), 0);
2007 stashsv = &PL_sv_no;
2008 arg = newOP(OP_PADSV, 0);
2009 arg->op_targ = target->op_targ;
2010 arg = prepend_elem(OP_LIST,
2011 newSVOP(OP_CONST, 0, stashsv),
2012 prepend_elem(OP_LIST,
2013 newUNOP(OP_REFGEN, 0,
2014 mod(arg, OP_REFGEN)),
2015 dup_attrlist(attrs)));
2017 /* Fake up a method call to import */
2018 meth = newSVpvn("import", 6);
2019 (void)SvUPGRADE(meth, SVt_PVIV);
2020 (void)SvIOK_on(meth);
2021 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2022 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2023 append_elem(OP_LIST,
2024 prepend_elem(OP_LIST, pack, list(arg)),
2025 newSVOP(OP_METHOD_NAMED, 0, meth)));
2026 imop->op_private |= OPpENTERSUB_NOMOD;
2028 /* Combine the ops. */
2029 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2033 =notfor apidoc apply_attrs_string
2035 Attempts to apply a list of attributes specified by the C<attrstr> and
2036 C<len> arguments to the subroutine identified by the C<cv> argument which
2037 is expected to be associated with the package identified by the C<stashpv>
2038 argument (see L<attributes>). It gets this wrong, though, in that it
2039 does not correctly identify the boundaries of the individual attribute
2040 specifications within C<attrstr>. This is not really intended for the
2041 public API, but has to be listed here for systems such as AIX which
2042 need an explicit export list for symbols. (It's called from XS code
2043 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2044 to respect attribute syntax properly would be welcome.
2050 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2051 char *attrstr, STRLEN len)
2056 len = strlen(attrstr);
2060 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2062 char *sstr = attrstr;
2063 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2064 attrs = append_elem(OP_LIST, attrs,
2065 newSVOP(OP_CONST, 0,
2066 newSVpvn(sstr, attrstr-sstr)));
2070 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2071 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2072 Nullsv, prepend_elem(OP_LIST,
2073 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2074 prepend_elem(OP_LIST,
2075 newSVOP(OP_CONST, 0,
2081 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2086 if (!o || PL_error_count)
2090 if (type == OP_LIST) {
2091 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2092 my_kid(kid, attrs, imopsp);
2093 } else if (type == OP_UNDEF) {
2095 } else if (type == OP_RV2SV || /* "our" declaration */
2097 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2098 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2099 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
2100 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
2102 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2104 PL_in_my_stash = Nullhv;
2105 apply_attrs(GvSTASH(gv),
2106 (type == OP_RV2SV ? GvSV(gv) :
2107 type == OP_RV2AV ? (SV*)GvAV(gv) :
2108 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2111 o->op_private |= OPpOUR_INTRO;
2114 else if (type != OP_PADSV &&
2117 type != OP_PUSHMARK)
2119 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2121 PL_in_my == KEY_our ? "our" : "my"));
2124 else if (attrs && type != OP_PUSHMARK) {
2129 PL_in_my_stash = Nullhv;
2131 /* check for C<my Dog $spot> when deciding package */
2132 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2133 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2134 stash = SvSTASH(*namesvp);
2136 stash = PL_curstash;
2137 apply_attrs_my(stash, o, attrs, imopsp);
2139 o->op_flags |= OPf_MOD;
2140 o->op_private |= OPpLVAL_INTRO;
2145 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2148 int maybe_scalar = 0;
2150 /* [perl #17376]: this appears to be premature, and results in code such as
2151 C< my(%x); > executing in list mode rather than void mode */
2153 if (o->op_flags & OPf_PARENS)
2162 o = my_kid(o, attrs, &rops);
2164 if (maybe_scalar && o->op_type == OP_PADSV) {
2165 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2166 o->op_private |= OPpLVAL_INTRO;
2169 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2172 PL_in_my_stash = Nullhv;
2177 Perl_my(pTHX_ OP *o)
2179 return my_attrs(o, Nullop);
2183 Perl_sawparens(pTHX_ OP *o)
2186 o->op_flags |= OPf_PARENS;
2191 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2195 if (ckWARN(WARN_MISC) &&
2196 (left->op_type == OP_RV2AV ||
2197 left->op_type == OP_RV2HV ||
2198 left->op_type == OP_PADAV ||
2199 left->op_type == OP_PADHV)) {
2200 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2201 right->op_type == OP_TRANS)
2202 ? right->op_type : OP_MATCH];
2203 const char *sample = ((left->op_type == OP_RV2AV ||
2204 left->op_type == OP_PADAV)
2205 ? "@array" : "%hash");
2206 Perl_warner(aTHX_ packWARN(WARN_MISC),
2207 "Applying %s to %s will act on scalar(%s)",
2208 desc, sample, sample);
2211 if (right->op_type == OP_CONST &&
2212 cSVOPx(right)->op_private & OPpCONST_BARE &&
2213 cSVOPx(right)->op_private & OPpCONST_STRICT)
2215 no_bareword_allowed(right);
2218 if (!(right->op_flags & OPf_STACKED) &&
2219 (right->op_type == OP_MATCH ||
2220 right->op_type == OP_SUBST ||
2221 right->op_type == OP_TRANS)) {
2222 right->op_flags |= OPf_STACKED;
2223 if (right->op_type != OP_MATCH &&
2224 ! (right->op_type == OP_TRANS &&
2225 right->op_private & OPpTRANS_IDENTICAL))
2226 left = mod(left, right->op_type);
2227 if (right->op_type == OP_TRANS)
2228 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2230 o = prepend_elem(right->op_type, scalar(left), right);
2232 return newUNOP(OP_NOT, 0, scalar(o));
2236 return bind_match(type, left,
2237 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2241 Perl_invert(pTHX_ OP *o)
2245 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2246 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2250 Perl_scope(pTHX_ OP *o)
2253 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2254 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2255 o->op_type = OP_LEAVE;
2256 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2259 if (o->op_type == OP_LINESEQ) {
2261 o->op_type = OP_SCOPE;
2262 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2263 kid = ((LISTOP*)o)->op_first;
2264 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2268 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2275 Perl_save_hints(pTHX)
2278 SAVESPTR(GvHV(PL_hintgv));
2279 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2280 SAVEFREESV(GvHV(PL_hintgv));
2284 Perl_block_start(pTHX_ int full)
2286 int retval = PL_savestack_ix;
2288 SAVEI32(PL_comppad_name_floor);
2289 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2291 PL_comppad_name_fill = PL_comppad_name_floor;
2292 if (PL_comppad_name_floor < 0)
2293 PL_comppad_name_floor = 0;
2294 SAVEI32(PL_min_intro_pending);
2295 SAVEI32(PL_max_intro_pending);
2296 PL_min_intro_pending = 0;
2297 SAVEI32(PL_comppad_name_fill);
2298 SAVEI32(PL_padix_floor);
2299 PL_padix_floor = PL_padix;
2300 PL_pad_reset_pending = FALSE;
2302 PL_hints &= ~HINT_BLOCK_SCOPE;
2303 SAVESPTR(PL_compiling.cop_warnings);
2304 if (! specialWARN(PL_compiling.cop_warnings)) {
2305 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2306 SAVEFREESV(PL_compiling.cop_warnings) ;
2308 SAVESPTR(PL_compiling.cop_io);
2309 if (! specialCopIO(PL_compiling.cop_io)) {
2310 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2311 SAVEFREESV(PL_compiling.cop_io) ;
2317 Perl_block_end(pTHX_ I32 floor, OP *seq)
2319 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2320 line_t copline = PL_copline;
2321 /* there should be a nextstate in every block */
2322 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2323 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2325 PL_pad_reset_pending = FALSE;
2326 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2328 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2329 pad_leavemy(PL_comppad_name_fill);
2337 #ifdef USE_5005THREADS
2338 OP *o = newOP(OP_THREADSV, 0);
2339 o->op_targ = find_threadsv("_");
2342 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2343 #endif /* USE_5005THREADS */
2347 Perl_newPROG(pTHX_ OP *o)
2352 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2353 ((PL_in_eval & EVAL_KEEPERR)
2354 ? OPf_SPECIAL : 0), o);
2355 PL_eval_start = linklist(PL_eval_root);
2356 PL_eval_root->op_private |= OPpREFCOUNTED;
2357 OpREFCNT_set(PL_eval_root, 1);
2358 PL_eval_root->op_next = 0;
2359 CALL_PEEP(PL_eval_start);
2364 PL_main_root = scope(sawparens(scalarvoid(o)));
2365 PL_curcop = &PL_compiling;
2366 PL_main_start = LINKLIST(PL_main_root);
2367 PL_main_root->op_private |= OPpREFCOUNTED;
2368 OpREFCNT_set(PL_main_root, 1);
2369 PL_main_root->op_next = 0;
2370 CALL_PEEP(PL_main_start);
2373 /* Register with debugger */
2375 CV *cv = get_cv("DB::postponed", FALSE);
2379 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2381 call_sv((SV*)cv, G_DISCARD);
2388 Perl_localize(pTHX_ OP *o, I32 lex)
2390 if (o->op_flags & OPf_PARENS)
2391 /* [perl #17376]: this appears to be premature, and results in code such as
2392 C< our(%x); > executing in list mode rather than void mode */
2399 if (ckWARN(WARN_PARENTHESIS)
2400 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2402 char *s = PL_bufptr;
2404 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2407 if (*s == ';' || *s == '=')
2408 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2409 "Parentheses missing around \"%s\" list",
2410 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2416 o = mod(o, OP_NULL); /* a bit kludgey */
2418 PL_in_my_stash = Nullhv;
2423 Perl_jmaybe(pTHX_ OP *o)
2425 if (o->op_type == OP_LIST) {
2427 #ifdef USE_5005THREADS
2428 o2 = newOP(OP_THREADSV, 0);
2429 o2->op_targ = find_threadsv(";");
2431 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2432 #endif /* USE_5005THREADS */
2433 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2439 Perl_fold_constants(pTHX_ register OP *o)
2442 I32 type = o->op_type;
2445 if (PL_opargs[type] & OA_RETSCALAR)
2447 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2448 o->op_targ = pad_alloc(type, SVs_PADTMP);
2450 /* integerize op, unless it happens to be C<-foo>.
2451 * XXX should pp_i_negate() do magic string negation instead? */
2452 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2453 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2454 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2456 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2459 if (!(PL_opargs[type] & OA_FOLDCONST))
2464 /* XXX might want a ck_negate() for this */
2465 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2477 /* XXX what about the numeric ops? */
2478 if (PL_hints & HINT_LOCALE)
2483 goto nope; /* Don't try to run w/ errors */
2485 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2486 if ((curop->op_type != OP_CONST ||
2487 (curop->op_private & OPpCONST_BARE)) &&
2488 curop->op_type != OP_LIST &&
2489 curop->op_type != OP_SCALAR &&
2490 curop->op_type != OP_NULL &&
2491 curop->op_type != OP_PUSHMARK)
2497 curop = LINKLIST(o);
2501 sv = *(PL_stack_sp--);
2502 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2503 pad_swipe(o->op_targ);
2504 else if (SvTEMP(sv)) { /* grab mortal temp? */
2505 (void)SvREFCNT_inc(sv);
2509 if (type == OP_RV2GV)
2510 return newGVOP(OP_GV, 0, (GV*)sv);
2512 /* try to smush double to int, but don't smush -2.0 to -2 */
2513 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2516 #ifdef PERL_PRESERVE_IVUV
2517 /* Only bother to attempt to fold to IV if
2518 most operators will benefit */
2522 return newSVOP(OP_CONST, 0, sv);
2530 Perl_gen_constant_list(pTHX_ register OP *o)
2533 I32 oldtmps_floor = PL_tmps_floor;
2537 return o; /* Don't attempt to run with errors */
2539 PL_op = curop = LINKLIST(o);
2546 PL_tmps_floor = oldtmps_floor;
2548 o->op_type = OP_RV2AV;
2549 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2550 o->op_seq = 0; /* needs to be revisited in peep() */
2551 curop = ((UNOP*)o)->op_first;
2552 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2559 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2561 if (!o || o->op_type != OP_LIST)
2562 o = newLISTOP(OP_LIST, 0, o, Nullop);
2564 o->op_flags &= ~OPf_WANT;
2566 if (!(PL_opargs[type] & OA_MARK))
2567 op_null(cLISTOPo->op_first);
2569 o->op_type = (OPCODE)type;
2570 o->op_ppaddr = PL_ppaddr[type];
2571 o->op_flags |= flags;
2573 o = CHECKOP(type, o);
2574 if (o->op_type != type)
2577 return fold_constants(o);
2580 /* List constructors */
2583 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2591 if (first->op_type != type
2592 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2594 return newLISTOP(type, 0, first, last);
2597 if (first->op_flags & OPf_KIDS)
2598 ((LISTOP*)first)->op_last->op_sibling = last;
2600 first->op_flags |= OPf_KIDS;
2601 ((LISTOP*)first)->op_first = last;
2603 ((LISTOP*)first)->op_last = last;
2608 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2616 if (first->op_type != type)
2617 return prepend_elem(type, (OP*)first, (OP*)last);
2619 if (last->op_type != type)
2620 return append_elem(type, (OP*)first, (OP*)last);
2622 first->op_last->op_sibling = last->op_first;
2623 first->op_last = last->op_last;
2624 first->op_flags |= (last->op_flags & OPf_KIDS);
2632 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2640 if (last->op_type == type) {
2641 if (type == OP_LIST) { /* already a PUSHMARK there */
2642 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2643 ((LISTOP*)last)->op_first->op_sibling = first;
2644 if (!(first->op_flags & OPf_PARENS))
2645 last->op_flags &= ~OPf_PARENS;
2648 if (!(last->op_flags & OPf_KIDS)) {
2649 ((LISTOP*)last)->op_last = first;
2650 last->op_flags |= OPf_KIDS;
2652 first->op_sibling = ((LISTOP*)last)->op_first;
2653 ((LISTOP*)last)->op_first = first;
2655 last->op_flags |= OPf_KIDS;
2659 return newLISTOP(type, 0, first, last);
2665 Perl_newNULLLIST(pTHX)
2667 return newOP(OP_STUB, 0);
2671 Perl_force_list(pTHX_ OP *o)
2673 if (!o || o->op_type != OP_LIST)
2674 o = newLISTOP(OP_LIST, 0, o, Nullop);
2680 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2684 NewOp(1101, listop, 1, LISTOP);
2686 listop->op_type = (OPCODE)type;
2687 listop->op_ppaddr = PL_ppaddr[type];
2690 listop->op_flags = (U8)flags;
2694 else if (!first && last)
2697 first->op_sibling = last;
2698 listop->op_first = first;
2699 listop->op_last = last;
2700 if (type == OP_LIST) {
2702 pushop = newOP(OP_PUSHMARK, 0);
2703 pushop->op_sibling = first;
2704 listop->op_first = pushop;
2705 listop->op_flags |= OPf_KIDS;
2707 listop->op_last = pushop;
2714 Perl_newOP(pTHX_ I32 type, I32 flags)
2717 NewOp(1101, o, 1, OP);
2718 o->op_type = (OPCODE)type;
2719 o->op_ppaddr = PL_ppaddr[type];
2720 o->op_flags = (U8)flags;
2723 o->op_private = (U8)(0 | (flags >> 8));
2724 if (PL_opargs[type] & OA_RETSCALAR)
2726 if (PL_opargs[type] & OA_TARGET)
2727 o->op_targ = pad_alloc(type, SVs_PADTMP);
2728 return CHECKOP(type, o);
2732 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2737 first = newOP(OP_STUB, 0);
2738 if (PL_opargs[type] & OA_MARK)
2739 first = force_list(first);
2741 NewOp(1101, unop, 1, UNOP);
2742 unop->op_type = (OPCODE)type;
2743 unop->op_ppaddr = PL_ppaddr[type];
2744 unop->op_first = first;
2745 unop->op_flags = flags | OPf_KIDS;
2746 unop->op_private = (U8)(1 | (flags >> 8));
2747 unop = (UNOP*) CHECKOP(type, unop);
2751 return fold_constants((OP *) unop);
2755 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2758 NewOp(1101, binop, 1, BINOP);
2761 first = newOP(OP_NULL, 0);
2763 binop->op_type = (OPCODE)type;
2764 binop->op_ppaddr = PL_ppaddr[type];
2765 binop->op_first = first;
2766 binop->op_flags = flags | OPf_KIDS;
2769 binop->op_private = (U8)(1 | (flags >> 8));
2772 binop->op_private = (U8)(2 | (flags >> 8));
2773 first->op_sibling = last;
2776 binop = (BINOP*)CHECKOP(type, binop);
2777 if (binop->op_next || binop->op_type != (OPCODE)type)
2780 binop->op_last = binop->op_first->op_sibling;
2782 return fold_constants((OP *)binop);
2786 uvcompare(const void *a, const void *b)
2788 if (*((UV *)a) < (*(UV *)b))
2790 if (*((UV *)a) > (*(UV *)b))
2792 if (*((UV *)a+1) < (*(UV *)b+1))
2794 if (*((UV *)a+1) > (*(UV *)b+1))
2800 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2802 SV *tstr = ((SVOP*)expr)->op_sv;
2803 SV *rstr = ((SVOP*)repl)->op_sv;
2806 U8 *t = (U8*)SvPV(tstr, tlen);
2807 U8 *r = (U8*)SvPV(rstr, rlen);
2814 register short *tbl;
2816 PL_hints |= HINT_BLOCK_SCOPE;
2817 complement = o->op_private & OPpTRANS_COMPLEMENT;
2818 del = o->op_private & OPpTRANS_DELETE;
2819 squash = o->op_private & OPpTRANS_SQUASH;
2822 o->op_private |= OPpTRANS_FROM_UTF;
2825 o->op_private |= OPpTRANS_TO_UTF;
2827 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2828 SV* listsv = newSVpvn("# comment\n",10);
2830 U8* tend = t + tlen;
2831 U8* rend = r + rlen;
2845 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2846 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2852 tsave = t = bytes_to_utf8(t, &len);
2855 if (!to_utf && rlen) {
2857 rsave = r = bytes_to_utf8(r, &len);
2861 /* There are several snags with this code on EBCDIC:
2862 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2863 2. scan_const() in toke.c has encoded chars in native encoding which makes
2864 ranges at least in EBCDIC 0..255 range the bottom odd.
2868 U8 tmpbuf[UTF8_MAXLEN+1];
2871 New(1109, cp, 2*tlen, UV);
2873 transv = newSVpvn("",0);
2875 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2877 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2879 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2883 cp[2*i+1] = cp[2*i];
2887 qsort(cp, i, 2*sizeof(UV), uvcompare);
2888 for (j = 0; j < i; j++) {
2890 diff = val - nextmin;
2892 t = uvuni_to_utf8(tmpbuf,nextmin);
2893 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2895 U8 range_mark = UTF_TO_NATIVE(0xff);
2896 t = uvuni_to_utf8(tmpbuf, val - 1);
2897 sv_catpvn(transv, (char *)&range_mark, 1);
2898 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2905 t = uvuni_to_utf8(tmpbuf,nextmin);
2906 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2908 U8 range_mark = UTF_TO_NATIVE(0xff);
2909 sv_catpvn(transv, (char *)&range_mark, 1);
2911 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2912 UNICODE_ALLOW_SUPER);
2913 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2914 t = (U8*)SvPVX(transv);
2915 tlen = SvCUR(transv);
2919 else if (!rlen && !del) {
2920 r = t; rlen = tlen; rend = tend;
2923 if ((!rlen && !del) || t == r ||
2924 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2926 o->op_private |= OPpTRANS_IDENTICAL;
2930 while (t < tend || tfirst <= tlast) {
2931 /* see if we need more "t" chars */
2932 if (tfirst > tlast) {
2933 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2935 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2937 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2944 /* now see if we need more "r" chars */
2945 if (rfirst > rlast) {
2947 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2949 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2951 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2960 rfirst = rlast = 0xffffffff;
2964 /* now see which range will peter our first, if either. */
2965 tdiff = tlast - tfirst;
2966 rdiff = rlast - rfirst;
2973 if (rfirst == 0xffffffff) {
2974 diff = tdiff; /* oops, pretend rdiff is infinite */
2976 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2977 (long)tfirst, (long)tlast);
2979 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2983 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2984 (long)tfirst, (long)(tfirst + diff),
2987 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2988 (long)tfirst, (long)rfirst);
2990 if (rfirst + diff > max)
2991 max = rfirst + diff;
2993 grows = (tfirst < rfirst &&
2994 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3006 else if (max > 0xff)
3011 Safefree(cPVOPo->op_pv);
3012 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3013 SvREFCNT_dec(listsv);
3015 SvREFCNT_dec(transv);
3017 if (!del && havefinal && rlen)
3018 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3019 newSVuv((UV)final), 0);
3022 o->op_private |= OPpTRANS_GROWS;
3034 tbl = (short*)cPVOPo->op_pv;
3036 Zero(tbl, 256, short);
3037 for (i = 0; i < (I32)tlen; i++)
3039 for (i = 0, j = 0; i < 256; i++) {
3041 if (j >= (I32)rlen) {
3050 if (i < 128 && r[j] >= 128)
3060 o->op_private |= OPpTRANS_IDENTICAL;
3062 else if (j >= (I32)rlen)
3065 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3066 tbl[0x100] = rlen - j;
3067 for (i=0; i < (I32)rlen - j; i++)
3068 tbl[0x101+i] = r[j+i];
3072 if (!rlen && !del) {
3075 o->op_private |= OPpTRANS_IDENTICAL;
3077 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3078 o->op_private |= OPpTRANS_IDENTICAL;
3080 for (i = 0; i < 256; i++)
3082 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3083 if (j >= (I32)rlen) {
3085 if (tbl[t[i]] == -1)
3091 if (tbl[t[i]] == -1) {
3092 if (t[i] < 128 && r[j] >= 128)
3099 o->op_private |= OPpTRANS_GROWS;
3107 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3111 NewOp(1101, pmop, 1, PMOP);
3112 pmop->op_type = (OPCODE)type;
3113 pmop->op_ppaddr = PL_ppaddr[type];
3114 pmop->op_flags = (U8)flags;
3115 pmop->op_private = (U8)(0 | (flags >> 8));
3117 if (PL_hints & HINT_RE_TAINT)
3118 pmop->op_pmpermflags |= PMf_RETAINT;
3119 if (PL_hints & HINT_LOCALE)
3120 pmop->op_pmpermflags |= PMf_LOCALE;
3121 pmop->op_pmflags = pmop->op_pmpermflags;
3126 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3127 repointer = av_pop((AV*)PL_regex_pad[0]);
3128 pmop->op_pmoffset = SvIV(repointer);
3129 SvREPADTMP_off(repointer);
3130 sv_setiv(repointer,0);
3132 repointer = newSViv(0);
3133 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3134 pmop->op_pmoffset = av_len(PL_regex_padav);
3135 PL_regex_pad = AvARRAY(PL_regex_padav);
3140 /* link into pm list */
3141 if (type != OP_TRANS && PL_curstash) {
3142 pmop->op_pmnext = HvPMROOT(PL_curstash);
3143 HvPMROOT(PL_curstash) = pmop;
3144 PmopSTASH_set(pmop,PL_curstash);
3151 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3155 I32 repl_has_vars = 0;
3157 if (o->op_type == OP_TRANS)
3158 return pmtrans(o, expr, repl);
3160 PL_hints |= HINT_BLOCK_SCOPE;
3163 if (expr->op_type == OP_CONST) {
3165 SV *pat = ((SVOP*)expr)->op_sv;
3166 char *p = SvPV(pat, plen);
3167 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3168 sv_setpvn(pat, "\\s+", 3);
3169 p = SvPV(pat, plen);
3170 pm->op_pmflags |= PMf_SKIPWHITE;
3173 pm->op_pmdynflags |= PMdf_UTF8;
3174 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3175 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3176 pm->op_pmflags |= PMf_WHITE;
3180 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3181 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3183 : OP_REGCMAYBE),0,expr);
3185 NewOp(1101, rcop, 1, LOGOP);
3186 rcop->op_type = OP_REGCOMP;
3187 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3188 rcop->op_first = scalar(expr);
3189 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3190 ? (OPf_SPECIAL | OPf_KIDS)
3192 rcop->op_private = 1;
3195 /* establish postfix order */
3196 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3198 rcop->op_next = expr;
3199 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3202 rcop->op_next = LINKLIST(expr);
3203 expr->op_next = (OP*)rcop;
3206 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3211 if (pm->op_pmflags & PMf_EVAL) {
3213 if (CopLINE(PL_curcop) < PL_multi_end)
3214 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3216 #ifdef USE_5005THREADS
3217 else if (repl->op_type == OP_THREADSV
3218 && strchr("&`'123456789+",
3219 PL_threadsv_names[repl->op_targ]))
3223 #endif /* USE_5005THREADS */
3224 else if (repl->op_type == OP_CONST)
3228 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3229 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3230 #ifdef USE_5005THREADS
3231 if (curop->op_type == OP_THREADSV) {
3233 if (strchr("&`'123456789+", curop->op_private))
3237 if (curop->op_type == OP_GV) {
3238 GV *gv = cGVOPx_gv(curop);
3240 if (strchr("&`'123456789+", *GvENAME(gv)))
3243 #endif /* USE_5005THREADS */
3244 else if (curop->op_type == OP_RV2CV)
3246 else if (curop->op_type == OP_RV2SV ||
3247 curop->op_type == OP_RV2AV ||
3248 curop->op_type == OP_RV2HV ||
3249 curop->op_type == OP_RV2GV) {
3250 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3253 else if (curop->op_type == OP_PADSV ||
3254 curop->op_type == OP_PADAV ||
3255 curop->op_type == OP_PADHV ||
3256 curop->op_type == OP_PADANY) {
3259 else if (curop->op_type == OP_PUSHRE)
3260 ; /* Okay here, dangerous in newASSIGNOP */
3270 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3271 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3272 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3273 prepend_elem(o->op_type, scalar(repl), o);
3276 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3277 pm->op_pmflags |= PMf_MAYBE_CONST;
3278 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3280 NewOp(1101, rcop, 1, LOGOP);
3281 rcop->op_type = OP_SUBSTCONT;
3282 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3283 rcop->op_first = scalar(repl);
3284 rcop->op_flags |= OPf_KIDS;
3285 rcop->op_private = 1;
3288 /* establish postfix order */
3289 rcop->op_next = LINKLIST(repl);
3290 repl->op_next = (OP*)rcop;
3292 pm->op_pmreplroot = scalar((OP*)rcop);
3293 pm->op_pmreplstart = LINKLIST(rcop);
3302 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3305 NewOp(1101, svop, 1, SVOP);
3306 svop->op_type = (OPCODE)type;
3307 svop->op_ppaddr = PL_ppaddr[type];
3309 svop->op_next = (OP*)svop;
3310 svop->op_flags = (U8)flags;
3311 if (PL_opargs[type] & OA_RETSCALAR)
3313 if (PL_opargs[type] & OA_TARGET)
3314 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3315 return CHECKOP(type, svop);
3319 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3322 NewOp(1101, padop, 1, PADOP);
3323 padop->op_type = (OPCODE)type;
3324 padop->op_ppaddr = PL_ppaddr[type];
3325 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3326 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3327 PL_curpad[padop->op_padix] = sv;
3330 padop->op_next = (OP*)padop;
3331 padop->op_flags = (U8)flags;
3332 if (PL_opargs[type] & OA_RETSCALAR)
3334 if (PL_opargs[type] & OA_TARGET)
3335 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3336 return CHECKOP(type, padop);
3340 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3345 return newPADOP(type, flags, SvREFCNT_inc(gv));
3347 return newSVOP(type, flags, SvREFCNT_inc(gv));
3352 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3355 NewOp(1101, pvop, 1, PVOP);
3356 pvop->op_type = (OPCODE)type;
3357 pvop->op_ppaddr = PL_ppaddr[type];
3359 pvop->op_next = (OP*)pvop;
3360 pvop->op_flags = (U8)flags;
3361 if (PL_opargs[type] & OA_RETSCALAR)
3363 if (PL_opargs[type] & OA_TARGET)
3364 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3365 return CHECKOP(type, pvop);
3369 Perl_package(pTHX_ OP *o)
3374 save_hptr(&PL_curstash);
3375 save_item(PL_curstname);
3377 name = SvPV(cSVOPo->op_sv, len);
3378 PL_curstash = gv_stashpvn(name, len, TRUE);
3379 sv_setpvn(PL_curstname, name, len);
3382 PL_hints |= HINT_BLOCK_SCOPE;
3383 PL_copline = NOLINE;
3388 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3394 if (id->op_type != OP_CONST)
3395 Perl_croak(aTHX_ "Module name must be constant");
3399 if (version != Nullop) {
3400 SV *vesv = ((SVOP*)version)->op_sv;
3402 if (arg == Nullop && !SvNIOKp(vesv)) {
3409 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3410 Perl_croak(aTHX_ "Version number must be constant number");
3412 /* Make copy of id so we don't free it twice */
3413 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3415 /* Fake up a method call to VERSION */
3416 meth = newSVpvn("VERSION",7);
3417 sv_upgrade(meth, SVt_PVIV);
3418 (void)SvIOK_on(meth);
3419 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3420 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3421 append_elem(OP_LIST,
3422 prepend_elem(OP_LIST, pack, list(version)),
3423 newSVOP(OP_METHOD_NAMED, 0, meth)));
3427 /* Fake up an import/unimport */
3428 if (arg && arg->op_type == OP_STUB)
3429 imop = arg; /* no import on explicit () */
3430 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3431 imop = Nullop; /* use 5.0; */
3436 /* Make copy of id so we don't free it twice */
3437 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3439 /* Fake up a method call to import/unimport */
3440 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3441 (void)SvUPGRADE(meth, SVt_PVIV);
3442 (void)SvIOK_on(meth);
3443 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3444 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3445 append_elem(OP_LIST,
3446 prepend_elem(OP_LIST, pack, list(arg)),
3447 newSVOP(OP_METHOD_NAMED, 0, meth)));
3450 /* Fake up the BEGIN {}, which does its thing immediately. */
3452 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3455 append_elem(OP_LINESEQ,
3456 append_elem(OP_LINESEQ,
3457 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3458 newSTATEOP(0, Nullch, veop)),
3459 newSTATEOP(0, Nullch, imop) ));
3461 /* The "did you use incorrect case?" warning used to be here.
3462 * The problem is that on case-insensitive filesystems one
3463 * might get false positives for "use" (and "require"):
3464 * "use Strict" or "require CARP" will work. This causes
3465 * portability problems for the script: in case-strict
3466 * filesystems the script will stop working.
3468 * The "incorrect case" warning checked whether "use Foo"
3469 * imported "Foo" to your namespace, but that is wrong, too:
3470 * there is no requirement nor promise in the language that
3471 * a Foo.pm should or would contain anything in package "Foo".
3473 * There is very little Configure-wise that can be done, either:
3474 * the case-sensitivity of the build filesystem of Perl does not
3475 * help in guessing the case-sensitivity of the runtime environment.
3478 PL_hints |= HINT_BLOCK_SCOPE;
3479 PL_copline = NOLINE;
3484 =head1 Embedding Functions
3486 =for apidoc load_module
3488 Loads the module whose name is pointed to by the string part of name.
3489 Note that the actual module name, not its filename, should be given.
3490 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3491 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3492 (or 0 for no flags). ver, if specified, provides version semantics
3493 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3494 arguments can be used to specify arguments to the module's import()
3495 method, similar to C<use Foo::Bar VERSION LIST>.
3500 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3503 va_start(args, ver);
3504 vload_module(flags, name, ver, &args);
3508 #ifdef PERL_IMPLICIT_CONTEXT
3510 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3514 va_start(args, ver);
3515 vload_module(flags, name, ver, &args);
3521 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3523 OP *modname, *veop, *imop;
3525 modname = newSVOP(OP_CONST, 0, name);
3526 modname->op_private |= OPpCONST_BARE;
3528 veop = newSVOP(OP_CONST, 0, ver);
3532 if (flags & PERL_LOADMOD_NOIMPORT) {
3533 imop = sawparens(newNULLLIST());
3535 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3536 imop = va_arg(*args, OP*);
3541 sv = va_arg(*args, SV*);
3543 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3544 sv = va_arg(*args, SV*);
3548 line_t ocopline = PL_copline;
3549 int oexpect = PL_expect;
3551 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3552 veop, modname, imop);
3553 PL_expect = oexpect;
3554 PL_copline = ocopline;
3559 Perl_dofile(pTHX_ OP *term)
3564 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3565 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3566 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3568 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3569 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3570 append_elem(OP_LIST, term,
3571 scalar(newUNOP(OP_RV2CV, 0,
3576 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3582 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3584 return newBINOP(OP_LSLICE, flags,
3585 list(force_list(subscript)),
3586 list(force_list(listval)) );
3590 S_list_assignment(pTHX_ register OP *o)
3595 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3596 o = cUNOPo->op_first;
3598 if (o->op_type == OP_COND_EXPR) {
3599 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3600 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3605 yyerror("Assignment to both a list and a scalar");
3609 if (o->op_type == OP_LIST &&
3610 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3611 o->op_private & OPpLVAL_INTRO)
3614 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3615 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3616 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3619 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3622 if (o->op_type == OP_RV2SV)
3629 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3634 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3635 return newLOGOP(optype, 0,
3636 mod(scalar(left), optype),
3637 newUNOP(OP_SASSIGN, 0, scalar(right)));
3640 return newBINOP(optype, OPf_STACKED,
3641 mod(scalar(left), optype), scalar(right));
3645 if (list_assignment(left)) {
3649 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3650 left = mod(left, OP_AASSIGN);
3658 curop = list(force_list(left));
3659 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3660 o->op_private = (U8)(0 | (flags >> 8));
3661 if (!(left->op_private & OPpLVAL_INTRO)) {
3664 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3665 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3666 if (curop->op_type == OP_GV) {
3667 GV *gv = cGVOPx_gv(curop);
3668 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3670 SvCUR(gv) = PL_generation;
3672 else if (curop->op_type == OP_PADSV ||
3673 curop->op_type == OP_PADAV ||
3674 curop->op_type == OP_PADHV ||
3675 curop->op_type == OP_PADANY) {
3676 SV **svp = AvARRAY(PL_comppad_name);
3677 SV *sv = svp[curop->op_targ];
3678 if ((int)SvCUR(sv) == PL_generation)
3680 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3682 else if (curop->op_type == OP_RV2CV)
3684 else if (curop->op_type == OP_RV2SV ||
3685 curop->op_type == OP_RV2AV ||
3686 curop->op_type == OP_RV2HV ||
3687 curop->op_type == OP_RV2GV) {
3688 if (lastop->op_type != OP_GV) /* funny deref? */
3691 else if (curop->op_type == OP_PUSHRE) {
3692 if (((PMOP*)curop)->op_pmreplroot) {
3694 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3696 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3698 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3700 SvCUR(gv) = PL_generation;
3709 o->op_private |= OPpASSIGN_COMMON;
3711 if (right && right->op_type == OP_SPLIT) {
3713 if ((tmpop = ((LISTOP*)right)->op_first) &&
3714 tmpop->op_type == OP_PUSHRE)
3716 PMOP *pm = (PMOP*)tmpop;
3717 if (left->op_type == OP_RV2AV &&
3718 !(left->op_private & OPpLVAL_INTRO) &&
3719 !(o->op_private & OPpASSIGN_COMMON) )
3721 tmpop = ((UNOP*)left)->op_first;
3722 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3724 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3725 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3727 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3728 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3730 pm->op_pmflags |= PMf_ONCE;
3731 tmpop = cUNOPo->op_first; /* to list (nulled) */
3732 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3733 tmpop->op_sibling = Nullop; /* don't free split */
3734 right->op_next = tmpop->op_next; /* fix starting loc */
3735 op_free(o); /* blow off assign */
3736 right->op_flags &= ~OPf_WANT;
3737 /* "I don't know and I don't care." */
3742 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3743 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3745 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3747 sv_setiv(sv, PL_modcount+1);
3755 right = newOP(OP_UNDEF, 0);
3756 if (right->op_type == OP_READLINE) {
3757 right->op_flags |= OPf_STACKED;
3758 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3761 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3762 o = newBINOP(OP_SASSIGN, flags,
3763 scalar(right), mod(scalar(left), OP_SASSIGN) );
3775 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3777 U32 seq = intro_my();
3780 NewOp(1101, cop, 1, COP);
3781 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3782 cop->op_type = OP_DBSTATE;
3783 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3786 cop->op_type = OP_NEXTSTATE;
3787 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3789 cop->op_flags = (U8)flags;
3790 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3792 cop->op_private |= NATIVE_HINTS;
3794 PL_compiling.op_private = cop->op_private;
3795 cop->op_next = (OP*)cop;
3798 cop->cop_label = label;
3799 PL_hints |= HINT_BLOCK_SCOPE;
3802 cop->cop_arybase = PL_curcop->cop_arybase;
3803 if (specialWARN(PL_curcop->cop_warnings))
3804 cop->cop_warnings = PL_curcop->cop_warnings ;
3806 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3807 if (specialCopIO(PL_curcop->cop_io))
3808 cop->cop_io = PL_curcop->cop_io;
3810 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3813 if (PL_copline == NOLINE)
3814 CopLINE_set(cop, CopLINE(PL_curcop));
3816 CopLINE_set(cop, PL_copline);
3817 PL_copline = NOLINE;
3820 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3822 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3824 CopSTASH_set(cop, PL_curstash);
3826 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3827 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3828 if (svp && *svp != &PL_sv_undef ) {
3829 (void)SvIOK_on(*svp);
3830 SvIVX(*svp) = PTR2IV(cop);
3834 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3837 /* "Introduce" my variables to visible status. */
3845 if (! PL_min_intro_pending)
3846 return PL_cop_seqmax;
3848 svp = AvARRAY(PL_comppad_name);
3849 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3850 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3851 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3852 SvNVX(sv) = (NV)PL_cop_seqmax;
3855 PL_min_intro_pending = 0;
3856 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3857 return PL_cop_seqmax++;
3861 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3863 return new_logop(type, flags, &first, &other);
3867 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3871 OP *first = *firstp;
3872 OP *other = *otherp;
3874 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3875 return newBINOP(type, flags, scalar(first), scalar(other));
3877 scalarboolean(first);
3878 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3879 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3880 if (type == OP_AND || type == OP_OR) {
3886 first = *firstp = cUNOPo->op_first;
3888 first->op_next = o->op_next;
3889 cUNOPo->op_first = Nullop;
3893 if (first->op_type == OP_CONST) {
3894 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3895 if (first->op_private & OPpCONST_STRICT)
3896 no_bareword_allowed(first);
3898 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3900 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3911 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3912 OP *k1 = ((UNOP*)first)->op_first;
3913 OP *k2 = k1->op_sibling;
3915 switch (first->op_type)
3918 if (k2 && k2->op_type == OP_READLINE
3919 && (k2->op_flags & OPf_STACKED)
3920 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3922 warnop = k2->op_type;
3927 if (k1->op_type == OP_READDIR
3928 || k1->op_type == OP_GLOB
3929 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3930 || k1->op_type == OP_EACH)
3932 warnop = ((k1->op_type == OP_NULL)
3933 ? (OPCODE)k1->op_targ : k1->op_type);
3938 line_t oldline = CopLINE(PL_curcop);
3939 CopLINE_set(PL_curcop, PL_copline);
3940 Perl_warner(aTHX_ packWARN(WARN_MISC),
3941 "Value of %s%s can be \"0\"; test with defined()",
3943 ((warnop == OP_READLINE || warnop == OP_GLOB)
3944 ? " construct" : "() operator"));
3945 CopLINE_set(PL_curcop, oldline);
3952 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3953 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3955 NewOp(1101, logop, 1, LOGOP);
3957 logop->op_type = (OPCODE)type;
3958 logop->op_ppaddr = PL_ppaddr[type];
3959 logop->op_first = first;
3960 logop->op_flags = flags | OPf_KIDS;
3961 logop->op_other = LINKLIST(other);
3962 logop->op_private = (U8)(1 | (flags >> 8));
3964 /* establish postfix order */
3965 logop->op_next = LINKLIST(first);
3966 first->op_next = (OP*)logop;
3967 first->op_sibling = other;
3969 o = newUNOP(OP_NULL, 0, (OP*)logop);
3976 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3983 return newLOGOP(OP_AND, 0, first, trueop);
3985 return newLOGOP(OP_OR, 0, first, falseop);
3987 scalarboolean(first);
3988 if (first->op_type == OP_CONST) {
3989 if (first->op_private & OPpCONST_BARE &&
3990 first->op_private & OPpCONST_STRICT) {
3991 no_bareword_allowed(first);
3993 if (SvTRUE(((SVOP*)first)->op_sv)) {
4004 NewOp(1101, logop, 1, LOGOP);
4005 logop->op_type = OP_COND_EXPR;
4006 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4007 logop->op_first = first;
4008 logop->op_flags = flags | OPf_KIDS;
4009 logop->op_private = (U8)(1 | (flags >> 8));
4010 logop->op_other = LINKLIST(trueop);
4011 logop->op_next = LINKLIST(falseop);
4014 /* establish postfix order */
4015 start = LINKLIST(first);
4016 first->op_next = (OP*)logop;
4018 first->op_sibling = trueop;
4019 trueop->op_sibling = falseop;
4020 o = newUNOP(OP_NULL, 0, (OP*)logop);
4022 trueop->op_next = falseop->op_next = o;
4029 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4037 NewOp(1101, range, 1, LOGOP);
4039 range->op_type = OP_RANGE;
4040 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4041 range->op_first = left;
4042 range->op_flags = OPf_KIDS;
4043 leftstart = LINKLIST(left);
4044 range->op_other = LINKLIST(right);
4045 range->op_private = (U8)(1 | (flags >> 8));
4047 left->op_sibling = right;
4049 range->op_next = (OP*)range;
4050 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4051 flop = newUNOP(OP_FLOP, 0, flip);
4052 o = newUNOP(OP_NULL, 0, flop);
4054 range->op_next = leftstart;
4056 left->op_next = flip;
4057 right->op_next = flop;
4059 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4060 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4061 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4062 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4064 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4065 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4068 if (!flip->op_private || !flop->op_private)
4069 linklist(o); /* blow off optimizer unless constant */
4075 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4079 int once = block && block->op_flags & OPf_SPECIAL &&
4080 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4083 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4084 return block; /* do {} while 0 does once */
4085 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4086 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4087 expr = newUNOP(OP_DEFINED, 0,
4088 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4089 } else if (expr->op_flags & OPf_KIDS) {
4090 OP *k1 = ((UNOP*)expr)->op_first;
4091 OP *k2 = (k1) ? k1->op_sibling : NULL;
4092 switch (expr->op_type) {
4094 if (k2 && k2->op_type == OP_READLINE
4095 && (k2->op_flags & OPf_STACKED)
4096 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4097 expr = newUNOP(OP_DEFINED, 0, expr);
4101 if (k1->op_type == OP_READDIR
4102 || k1->op_type == OP_GLOB
4103 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4104 || k1->op_type == OP_EACH)
4105 expr = newUNOP(OP_DEFINED, 0, expr);
4111 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4112 o = new_logop(OP_AND, 0, &expr, &listop);
4115 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4117 if (once && o != listop)
4118 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4121 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4123 o->op_flags |= flags;
4125 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4130 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4138 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4139 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4140 expr = newUNOP(OP_DEFINED, 0,
4141 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4142 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4143 OP *k1 = ((UNOP*)expr)->op_first;
4144 OP *k2 = (k1) ? k1->op_sibling : NULL;
4145 switch (expr->op_type) {
4147 if (k2 && k2->op_type == OP_READLINE
4148 && (k2->op_flags & OPf_STACKED)
4149 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4150 expr = newUNOP(OP_DEFINED, 0, expr);
4154 if (k1->op_type == OP_READDIR
4155 || k1->op_type == OP_GLOB
4156 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4157 || k1->op_type == OP_EACH)
4158 expr = newUNOP(OP_DEFINED, 0, expr);
4164 block = newOP(OP_NULL, 0);
4166 block = scope(block);
4170 next = LINKLIST(cont);
4173 OP *unstack = newOP(OP_UNSTACK, 0);
4176 cont = append_elem(OP_LINESEQ, cont, unstack);
4177 if ((line_t)whileline != NOLINE) {
4178 PL_copline = (line_t)whileline;
4179 cont = append_elem(OP_LINESEQ, cont,
4180 newSTATEOP(0, Nullch, Nullop));
4184 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4185 redo = LINKLIST(listop);
4188 PL_copline = (line_t)whileline;
4190 o = new_logop(OP_AND, 0, &expr, &listop);
4191 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4192 op_free(expr); /* oops, it's a while (0) */
4194 return Nullop; /* listop already freed by new_logop */
4197 ((LISTOP*)listop)->op_last->op_next =
4198 (o == listop ? redo : LINKLIST(o));
4204 NewOp(1101,loop,1,LOOP);
4205 loop->op_type = OP_ENTERLOOP;
4206 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4207 loop->op_private = 0;
4208 loop->op_next = (OP*)loop;
4211 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4213 loop->op_redoop = redo;
4214 loop->op_lastop = o;
4215 o->op_private |= loopflags;
4218 loop->op_nextop = next;
4220 loop->op_nextop = o;
4222 o->op_flags |= flags;
4223 o->op_private |= (flags >> 8);
4228 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4232 PADOFFSET padoff = 0;
4236 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4237 sv->op_type = OP_RV2GV;
4238 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4240 else if (sv->op_type == OP_PADSV) { /* private variable */
4241 padoff = sv->op_targ;
4246 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4247 padoff = sv->op_targ;
4249 iterflags |= OPf_SPECIAL;
4254 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4257 #ifdef USE_5005THREADS
4258 padoff = find_threadsv("_");
4259 iterflags |= OPf_SPECIAL;
4261 sv = newGVOP(OP_GV, 0, PL_defgv);
4264 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4265 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4266 iterflags |= OPf_STACKED;
4268 else if (expr->op_type == OP_NULL &&
4269 (expr->op_flags & OPf_KIDS) &&
4270 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4272 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4273 * set the STACKED flag to indicate that these values are to be
4274 * treated as min/max values by 'pp_iterinit'.
4276 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4277 LOGOP* range = (LOGOP*) flip->op_first;
4278 OP* left = range->op_first;
4279 OP* right = left->op_sibling;
4282 range->op_flags &= ~OPf_KIDS;
4283 range->op_first = Nullop;
4285 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4286 listop->op_first->op_next = range->op_next;
4287 left->op_next = range->op_other;
4288 right->op_next = (OP*)listop;
4289 listop->op_next = listop->op_first;
4292 expr = (OP*)(listop);
4294 iterflags |= OPf_STACKED;
4297 expr = mod(force_list(expr), OP_GREPSTART);
4301 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4302 append_elem(OP_LIST, expr, scalar(sv))));
4303 assert(!loop->op_next);
4304 #ifdef PL_OP_SLAB_ALLOC
4307 NewOp(1234,tmp,1,LOOP);
4308 Copy(loop,tmp,1,LOOP);
4313 Renew(loop, 1, LOOP);
4315 loop->op_targ = padoff;
4316 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4317 PL_copline = forline;
4318 return newSTATEOP(0, label, wop);
4322 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4327 if (type != OP_GOTO || label->op_type == OP_CONST) {
4328 /* "last()" means "last" */
4329 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4330 o = newOP(type, OPf_SPECIAL);
4332 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4333 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4339 if (label->op_type == OP_ENTERSUB)
4340 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4341 o = newUNOP(type, OPf_STACKED, label);
4343 PL_hints |= HINT_BLOCK_SCOPE;
4348 Perl_cv_undef(pTHX_ CV *cv)
4351 CV *freecv = Nullcv;
4352 bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */
4354 #ifdef USE_5005THREADS
4356 MUTEX_DESTROY(CvMUTEXP(cv));
4357 Safefree(CvMUTEXP(cv));
4360 #endif /* USE_5005THREADS */
4363 if (CvFILE(cv) && !CvXSUB(cv)) {
4364 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4365 Safefree(CvFILE(cv));
4370 if (!CvXSUB(cv) && CvROOT(cv)) {
4371 #ifdef USE_5005THREADS
4372 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4373 Perl_croak(aTHX_ "Can't undef active subroutine");
4376 Perl_croak(aTHX_ "Can't undef active subroutine");
4377 #endif /* USE_5005THREADS */
4380 SAVEVPTR(PL_curpad);
4383 op_free(CvROOT(cv));
4384 CvROOT(cv) = Nullop;
4387 SvPOK_off((SV*)cv); /* forget prototype */
4389 outsidecv = CvOUTSIDE(cv);
4390 /* Since closure prototypes have the same lifetime as the containing
4391 * CV, they don't hold a refcount on the outside CV. This avoids
4392 * the refcount loop between the outer CV (which keeps a refcount to
4393 * the closure prototype in the pad entry for pp_anoncode()) and the
4394 * closure prototype, and the ensuing memory leak. --GSAR */
4395 if (!CvANON(cv) || CvCLONED(cv))
4397 CvOUTSIDE(cv) = Nullcv;
4399 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4402 if (CvPADLIST(cv)) {
4403 /* may be during global destruction */
4404 if (SvREFCNT(CvPADLIST(cv))) {
4405 AV *padlist = CvPADLIST(cv);
4407 /* pads may be cleared out already during global destruction */
4408 if ((is_eval && !PL_dirty) || CvSPECIAL(cv)) {
4409 /* inner references to eval's cv must be fixed up */
4410 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4411 AV *comppad = (AV*)AvARRAY(padlist)[1];
4412 SV **namepad = AvARRAY(comppad_name);
4413 SV **curpad = AvARRAY(comppad);
4414 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4415 SV *namesv = namepad[ix];
4416 if (namesv && namesv != &PL_sv_undef
4417 && *SvPVX(namesv) == '&'
4418 && ix <= AvFILLp(comppad))
4420 CV *innercv = (CV*)curpad[ix];
4421 if (innercv && SvTYPE(innercv) == SVt_PVCV
4422 && CvOUTSIDE(innercv) == cv)
4424 CvOUTSIDE(innercv) = outsidecv;
4425 if (!CvANON(innercv) || CvCLONED(innercv)) {
4426 (void)SvREFCNT_inc(outsidecv);
4435 SvREFCNT_dec(freecv);
4436 ix = AvFILLp(padlist);
4438 SV* sv = AvARRAY(padlist)[ix--];
4441 if (sv == (SV*)PL_comppad_name)
4442 PL_comppad_name = Nullav;
4443 else if (sv == (SV*)PL_comppad) {
4444 PL_comppad = Nullav;
4445 PL_curpad = Null(SV**);
4449 SvREFCNT_dec((SV*)CvPADLIST(cv));
4451 CvPADLIST(cv) = Nullav;
4454 SvREFCNT_dec(freecv);
4461 #ifdef DEBUG_CLOSURES
4463 S_cv_dump(pTHX_ CV *cv)
4466 CV *outside = CvOUTSIDE(cv);
4467 AV* padlist = CvPADLIST(cv);
4474 PerlIO_printf(Perl_debug_log,
4475 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4477 (CvANON(cv) ? "ANON"
4478 : (cv == PL_main_cv) ? "MAIN"
4479 : CvUNIQUE(cv) ? "UNIQUE"
4480 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4483 : CvANON(outside) ? "ANON"
4484 : (outside == PL_main_cv) ? "MAIN"
4485 : CvUNIQUE(outside) ? "UNIQUE"
4486 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4491 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4492 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4493 pname = AvARRAY(pad_name);
4494 ppad = AvARRAY(pad);
4496 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4497 if (SvPOK(pname[ix]))
4498 PerlIO_printf(Perl_debug_log,
4499 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4500 (int)ix, PTR2UV(ppad[ix]),
4501 SvFAKE(pname[ix]) ? "FAKE " : "",
4503 (IV)I_32(SvNVX(pname[ix])),
4506 #endif /* DEBUGGING */
4508 #endif /* DEBUG_CLOSURES */
4511 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4515 AV* protopadlist = CvPADLIST(proto);
4516 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4517 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4518 SV** pname = AvARRAY(protopad_name);
4519 SV** ppad = AvARRAY(protopad);
4520 I32 fname = AvFILLp(protopad_name);
4521 I32 fpad = AvFILLp(protopad);
4525 assert(!CvUNIQUE(proto));
4529 SAVESPTR(PL_comppad_name);
4530 SAVESPTR(PL_compcv);
4532 cv = PL_compcv = (CV*)NEWSV(1104,0);
4533 sv_upgrade((SV *)cv, SvTYPE(proto));
4534 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4537 #ifdef USE_5005THREADS
4538 New(666, CvMUTEXP(cv), 1, perl_mutex);
4539 MUTEX_INIT(CvMUTEXP(cv));
4541 #endif /* USE_5005THREADS */
4543 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4544 : savepv(CvFILE(proto));
4546 CvFILE(cv) = CvFILE(proto);
4548 CvGV(cv) = CvGV(proto);
4549 CvSTASH(cv) = CvSTASH(proto);
4550 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4551 CvSTART(cv) = CvSTART(proto);
4553 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4556 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4558 PL_comppad_name = newAV();
4559 for (ix = fname; ix >= 0; ix--)
4560 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4562 PL_comppad = newAV();
4564 comppadlist = newAV();
4565 AvREAL_off(comppadlist);
4566 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4567 av_store(comppadlist, 1, (SV*)PL_comppad);
4568 CvPADLIST(cv) = comppadlist;
4569 av_fill(PL_comppad, AvFILLp(protopad));
4570 PL_curpad = AvARRAY(PL_comppad);
4572 av = newAV(); /* will be @_ */
4574 av_store(PL_comppad, 0, (SV*)av);
4575 AvFLAGS(av) = AVf_REIFY;
4577 for (ix = fpad; ix > 0; ix--) {
4578 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4579 if (namesv && namesv != &PL_sv_undef) {
4580 char *name = SvPVX(namesv); /* XXX */
4581 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4582 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4583 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4585 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4587 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4589 else { /* our own lexical */
4592 /* anon code -- we'll come back for it */
4593 sv = SvREFCNT_inc(ppad[ix]);
4595 else if (*name == '@')
4597 else if (*name == '%')
4606 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4607 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4610 SV* sv = NEWSV(0,0);
4616 /* Now that vars are all in place, clone nested closures. */
4618 for (ix = fpad; ix > 0; ix--) {
4619 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4621 && namesv != &PL_sv_undef
4622 && !(SvFLAGS(namesv) & SVf_FAKE)
4623 && *SvPVX(namesv) == '&'
4624 && CvCLONE(ppad[ix]))
4626 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4627 SvREFCNT_dec(ppad[ix]);
4630 PL_curpad[ix] = (SV*)kid;
4634 #ifdef DEBUG_CLOSURES
4635 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4637 PerlIO_printf(Perl_debug_log, " from:\n");
4639 PerlIO_printf(Perl_debug_log, " to:\n");
4646 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4648 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4650 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4657 Perl_cv_clone(pTHX_ CV *proto)
4660 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4661 cv = cv_clone2(proto, CvOUTSIDE(proto));
4662 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4667 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4669 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4670 SV* msg = sv_newmortal();
4674 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4675 sv_setpv(msg, "Prototype mismatch:");
4677 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4679 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4680 sv_catpv(msg, " vs ");
4682 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4684 sv_catpv(msg, "none");
4685 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4689 static void const_sv_xsub(pTHX_ CV* cv);
4693 =head1 Optree Manipulation Functions
4695 =for apidoc cv_const_sv
4697 If C<cv> is a constant sub eligible for inlining. returns the constant
4698 value returned by the sub. Otherwise, returns NULL.
4700 Constant subs can be created with C<newCONSTSUB> or as described in
4701 L<perlsub/"Constant Functions">.
4706 Perl_cv_const_sv(pTHX_ CV *cv)
4708 if (!cv || !CvCONST(cv))
4710 return (SV*)CvXSUBANY(cv).any_ptr;
4714 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4721 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4722 o = cLISTOPo->op_first->op_sibling;
4724 for (; o; o = o->op_next) {
4725 OPCODE type = o->op_type;
4727 if (sv && o->op_next == o)
4729 if (o->op_next != o) {
4730 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4732 if (type == OP_DBSTATE)
4735 if (type == OP_LEAVESUB || type == OP_RETURN)
4739 if (type == OP_CONST && cSVOPo->op_sv)
4741 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4742 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4743 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4747 /* We get here only from cv_clone2() while creating a closure.
4748 Copy the const value here instead of in cv_clone2 so that
4749 SvREADONLY_on doesn't lead to problems when leaving
4754 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4766 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4776 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4780 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4782 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4786 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4792 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4797 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4798 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4799 SV *sv = sv_newmortal();
4800 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4801 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4802 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4807 gv = gv_fetchpv(name ? name : (aname ? aname :
4808 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4809 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4819 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4820 maximum a prototype before. */
4821 if (SvTYPE(gv) > SVt_NULL) {
4822 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4823 && ckWARN_d(WARN_PROTOTYPE))
4825 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4827 cv_ckproto((CV*)gv, NULL, ps);
4830 sv_setpv((SV*)gv, ps);
4832 sv_setiv((SV*)gv, -1);
4833 SvREFCNT_dec(PL_compcv);
4834 cv = PL_compcv = NULL;
4835 PL_sub_generation++;
4839 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4841 #ifdef GV_UNIQUE_CHECK
4842 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4843 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4847 if (!block || !ps || *ps || attrs)
4850 const_sv = op_const_sv(block, Nullcv);
4853 bool exists = CvROOT(cv) || CvXSUB(cv);
4855 #ifdef GV_UNIQUE_CHECK
4856 if (exists && GvUNIQUE(gv)) {
4857 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4861 /* if the subroutine doesn't exist and wasn't pre-declared
4862 * with a prototype, assume it will be AUTOLOADed,
4863 * skipping the prototype check
4865 if (exists || SvPOK(cv))
4866 cv_ckproto(cv, gv, ps);
4867 /* already defined (or promised)? */
4868 if (exists || GvASSUMECV(gv)) {
4869 if (!block && !attrs) {
4870 if (CvFLAGS(PL_compcv)) {
4871 /* might have had built-in attrs applied */
4872 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4874 /* just a "sub foo;" when &foo is already defined */
4875 SAVEFREESV(PL_compcv);
4878 /* ahem, death to those who redefine active sort subs */
4879 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4880 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4882 if (ckWARN(WARN_REDEFINE)
4884 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4886 line_t oldline = CopLINE(PL_curcop);
4887 if (PL_copline != NOLINE)
4888 CopLINE_set(PL_curcop, PL_copline);
4889 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4890 CvCONST(cv) ? "Constant subroutine %s redefined"
4891 : "Subroutine %s redefined", name);
4892 CopLINE_set(PL_curcop, oldline);
4900 SvREFCNT_inc(const_sv);
4902 assert(!CvROOT(cv) && !CvCONST(cv));
4903 sv_setpv((SV*)cv, ""); /* prototype is "" */
4904 CvXSUBANY(cv).any_ptr = const_sv;
4905 CvXSUB(cv) = const_sv_xsub;
4910 cv = newCONSTSUB(NULL, name, const_sv);
4913 SvREFCNT_dec(PL_compcv);
4915 PL_sub_generation++;
4922 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4923 * before we clobber PL_compcv.
4927 /* Might have had built-in attributes applied -- propagate them. */
4928 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4929 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4930 stash = GvSTASH(CvGV(cv));
4931 else if (CvSTASH(cv))
4932 stash = CvSTASH(cv);
4934 stash = PL_curstash;
4937 /* possibly about to re-define existing subr -- ignore old cv */
4938 rcv = (SV*)PL_compcv;
4939 if (name && GvSTASH(gv))
4940 stash = GvSTASH(gv);
4942 stash = PL_curstash;
4944 apply_attrs(stash, rcv, attrs, FALSE);
4946 if (cv) { /* must reuse cv if autoloaded */
4948 /* got here with just attrs -- work done, so bug out */
4949 SAVEFREESV(PL_compcv);
4953 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4954 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4955 CvOUTSIDE(PL_compcv) = 0;
4956 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4957 CvPADLIST(PL_compcv) = 0;
4958 /* inner references to PL_compcv must be fixed up ... */
4960 AV *padlist = CvPADLIST(cv);
4961 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4962 AV *comppad = (AV*)AvARRAY(padlist)[1];
4963 SV **namepad = AvARRAY(comppad_name);
4964 SV **curpad = AvARRAY(comppad);
4965 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4966 SV *namesv = namepad[ix];
4967 if (namesv && namesv != &PL_sv_undef
4968 && *SvPVX(namesv) == '&')
4970 CV *innercv = (CV*)curpad[ix];
4971 if (CvOUTSIDE(innercv) == PL_compcv) {
4972 CvOUTSIDE(innercv) = cv;
4973 if (!CvANON(innercv) || CvCLONED(innercv)) {
4974 (void)SvREFCNT_inc(cv);
4975 SvREFCNT_dec(PL_compcv);
4981 /* ... before we throw it away */
4982 SvREFCNT_dec(PL_compcv);
4983 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4984 ++PL_sub_generation;
4991 PL_sub_generation++;
4995 CvFILE_set_from_cop(cv, PL_curcop);
4996 CvSTASH(cv) = PL_curstash;
4997 #ifdef USE_5005THREADS
4999 if (!CvMUTEXP(cv)) {
5000 New(666, CvMUTEXP(cv), 1, perl_mutex);
5001 MUTEX_INIT(CvMUTEXP(cv));
5003 #endif /* USE_5005THREADS */
5006 sv_setpv((SV*)cv, ps);
5008 if (PL_error_count) {
5012 char *s = strrchr(name, ':');
5014 if (strEQ(s, "BEGIN")) {
5016 "BEGIN not safe after errors--compilation aborted";
5017 if (PL_in_eval & EVAL_KEEPERR)
5018 Perl_croak(aTHX_ not_safe);
5020 /* force display of errors found but not reported */
5021 sv_catpv(ERRSV, not_safe);
5022 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
5030 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5031 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5034 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5035 mod(scalarseq(block), OP_LEAVESUBLV));
5038 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5040 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5041 OpREFCNT_set(CvROOT(cv), 1);
5042 CvSTART(cv) = LINKLIST(CvROOT(cv));
5043 CvROOT(cv)->op_next = 0;
5044 CALL_PEEP(CvSTART(cv));
5046 /* now that optimizer has done its work, adjust pad values */
5048 SV **namep = AvARRAY(PL_comppad_name);
5049 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5052 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5055 * The only things that a clonable function needs in its
5056 * pad are references to outer lexicals and anonymous subs.
5057 * The rest are created anew during cloning.
5059 if (!((namesv = namep[ix]) != Nullsv &&
5060 namesv != &PL_sv_undef &&
5062 *SvPVX(namesv) == '&')))
5064 SvREFCNT_dec(PL_curpad[ix]);
5065 PL_curpad[ix] = Nullsv;
5068 assert(!CvCONST(cv));
5069 if (ps && !*ps && op_const_sv(block, cv))
5073 AV *av = newAV(); /* Will be @_ */
5075 av_store(PL_comppad, 0, (SV*)av);
5076 AvFLAGS(av) = AVf_REIFY;
5078 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5079 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5081 if (!SvPADMY(PL_curpad[ix]))
5082 SvPADTMP_on(PL_curpad[ix]);
5086 /* If a potential closure prototype, don't keep a refcount on outer CV.
5087 * This is okay as the lifetime of the prototype is tied to the
5088 * lifetime of the outer CV. Avoids memory leak due to reference
5091 SvREFCNT_dec(CvOUTSIDE(cv));
5093 if (name || aname) {
5095 char *tname = (name ? name : aname);
5097 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5098 SV *sv = NEWSV(0,0);
5099 SV *tmpstr = sv_newmortal();
5100 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5104 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5106 (long)PL_subline, (long)CopLINE(PL_curcop));
5107 gv_efullname3(tmpstr, gv, Nullch);
5108 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5109 hv = GvHVn(db_postponed);
5110 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5111 && (pcv = GvCV(db_postponed)))
5117 call_sv((SV*)pcv, G_DISCARD);
5121 if ((s = strrchr(tname,':')))
5126 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5129 if (strEQ(s, "BEGIN")) {
5130 I32 oldscope = PL_scopestack_ix;
5132 SAVECOPFILE(&PL_compiling);
5133 SAVECOPLINE(&PL_compiling);
5136 PL_beginav = newAV();
5137 DEBUG_x( dump_sub(gv) );
5138 av_push(PL_beginav, (SV*)cv);
5139 GvCV(gv) = 0; /* cv has been hijacked */
5140 call_list(oldscope, PL_beginav);
5142 PL_curcop = &PL_compiling;
5143 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5146 else if (strEQ(s, "END") && !PL_error_count) {
5149 DEBUG_x( dump_sub(gv) );
5150 av_unshift(PL_endav, 1);
5151 av_store(PL_endav, 0, (SV*)cv);
5152 GvCV(gv) = 0; /* cv has been hijacked */
5154 else if (strEQ(s, "CHECK") && !PL_error_count) {
5156 PL_checkav = newAV();
5157 DEBUG_x( dump_sub(gv) );
5158 if (PL_main_start && ckWARN(WARN_VOID))
5159 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5160 av_unshift(PL_checkav, 1);
5161 av_store(PL_checkav, 0, (SV*)cv);
5162 GvCV(gv) = 0; /* cv has been hijacked */
5164 else if (strEQ(s, "INIT") && !PL_error_count) {
5166 PL_initav = newAV();
5167 DEBUG_x( dump_sub(gv) );
5168 if (PL_main_start && ckWARN(WARN_VOID))
5169 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5170 av_push(PL_initav, (SV*)cv);
5171 GvCV(gv) = 0; /* cv has been hijacked */
5176 PL_copline = NOLINE;
5181 /* XXX unsafe for threads if eval_owner isn't held */
5183 =for apidoc newCONSTSUB
5185 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5186 eligible for inlining at compile-time.
5192 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5198 SAVECOPLINE(PL_curcop);
5199 CopLINE_set(PL_curcop, PL_copline);
5202 PL_hints &= ~HINT_BLOCK_SCOPE;
5205 SAVESPTR(PL_curstash);
5206 SAVECOPSTASH(PL_curcop);
5207 PL_curstash = stash;
5208 CopSTASH_set(PL_curcop,stash);
5211 cv = newXS(name, const_sv_xsub, __FILE__);
5212 CvXSUBANY(cv).any_ptr = sv;
5214 sv_setpv((SV*)cv, ""); /* prototype is "" */
5222 =for apidoc U||newXS
5224 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5230 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5232 GV *gv = gv_fetchpv(name ? name :
5233 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5234 GV_ADDMULTI, SVt_PVCV);
5238 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5240 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5242 /* just a cached method */
5246 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5247 /* already defined (or promised) */
5248 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5249 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5250 line_t oldline = CopLINE(PL_curcop);
5251 if (PL_copline != NOLINE)
5252 CopLINE_set(PL_curcop, PL_copline);
5253 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5254 CvCONST(cv) ? "Constant subroutine %s redefined"
5255 : "Subroutine %s redefined"
5257 CopLINE_set(PL_curcop, oldline);
5264 if (cv) /* must reuse cv if autoloaded */
5267 cv = (CV*)NEWSV(1105,0);
5268 sv_upgrade((SV *)cv, SVt_PVCV);
5272 PL_sub_generation++;
5276 #ifdef USE_5005THREADS
5277 New(666, CvMUTEXP(cv), 1, perl_mutex);
5278 MUTEX_INIT(CvMUTEXP(cv));
5280 #endif /* USE_5005THREADS */
5281 (void)gv_fetchfile(filename);
5282 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5283 an external constant string */
5284 CvXSUB(cv) = subaddr;
5287 char *s = strrchr(name,':');
5293 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5296 if (strEQ(s, "BEGIN")) {
5298 PL_beginav = newAV();
5299 av_push(PL_beginav, (SV*)cv);
5300 GvCV(gv) = 0; /* cv has been hijacked */
5302 else if (strEQ(s, "END")) {
5305 av_unshift(PL_endav, 1);
5306 av_store(PL_endav, 0, (SV*)cv);
5307 GvCV(gv) = 0; /* cv has been hijacked */
5309 else if (strEQ(s, "CHECK")) {
5311 PL_checkav = newAV();
5312 if (PL_main_start && ckWARN(WARN_VOID))
5313 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5314 av_unshift(PL_checkav, 1);
5315 av_store(PL_checkav, 0, (SV*)cv);
5316 GvCV(gv) = 0; /* cv has been hijacked */
5318 else if (strEQ(s, "INIT")) {
5320 PL_initav = newAV();
5321 if (PL_main_start && ckWARN(WARN_VOID))
5322 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5323 av_push(PL_initav, (SV*)cv);
5324 GvCV(gv) = 0; /* cv has been hijacked */
5335 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5344 name = SvPVx(cSVOPo->op_sv, n_a);
5347 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5348 #ifdef GV_UNIQUE_CHECK
5350 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5354 if ((cv = GvFORM(gv))) {
5355 if (ckWARN(WARN_REDEFINE)) {
5356 line_t oldline = CopLINE(PL_curcop);
5357 if (PL_copline != NOLINE)
5358 CopLINE_set(PL_curcop, PL_copline);
5359 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
5360 CopLINE_set(PL_curcop, oldline);
5367 CvFILE_set_from_cop(cv, PL_curcop);
5369 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5370 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5371 SvPADTMP_on(PL_curpad[ix]);
5374 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5375 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5376 OpREFCNT_set(CvROOT(cv), 1);
5377 CvSTART(cv) = LINKLIST(CvROOT(cv));
5378 CvROOT(cv)->op_next = 0;
5379 CALL_PEEP(CvSTART(cv));
5381 PL_copline = NOLINE;
5386 Perl_newANONLIST(pTHX_ OP *o)
5388 return newUNOP(OP_REFGEN, 0,
5389 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5393 Perl_newANONHASH(pTHX_ OP *o)
5395 return newUNOP(OP_REFGEN, 0,
5396 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5400 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5402 return newANONATTRSUB(floor, proto, Nullop, block);
5406 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5408 return newUNOP(OP_REFGEN, 0,
5409 newSVOP(OP_ANONCODE, 0,
5410 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5414 Perl_oopsAV(pTHX_ OP *o)
5416 switch (o->op_type) {
5418 o->op_type = OP_PADAV;
5419 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5420 return ref(o, OP_RV2AV);
5423 o->op_type = OP_RV2AV;
5424 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5429 if (ckWARN_d(WARN_INTERNAL))
5430 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5437 Perl_oopsHV(pTHX_ OP *o)
5439 switch (o->op_type) {
5442 o->op_type = OP_PADHV;
5443 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5444 return ref(o, OP_RV2HV);
5448 o->op_type = OP_RV2HV;
5449 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5454 if (ckWARN_d(WARN_INTERNAL))
5455 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5462 Perl_newAVREF(pTHX_ OP *o)
5464 if (o->op_type == OP_PADANY) {
5465 o->op_type = OP_PADAV;
5466 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5469 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5470 && ckWARN(WARN_DEPRECATED)) {
5471 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5472 "Using an array as a reference is deprecated");
5474 return newUNOP(OP_RV2AV, 0, scalar(o));
5478 Perl_newGVREF(pTHX_ I32 type, OP *o)
5480 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5481 return newUNOP(OP_NULL, 0, o);
5482 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5486 Perl_newHVREF(pTHX_ OP *o)
5488 if (o->op_type == OP_PADANY) {
5489 o->op_type = OP_PADHV;
5490 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5493 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5494 && ckWARN(WARN_DEPRECATED)) {
5495 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5496 "Using a hash as a reference is deprecated");
5498 return newUNOP(OP_RV2HV, 0, scalar(o));
5502 Perl_oopsCV(pTHX_ OP *o)
5504 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5510 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5512 return newUNOP(OP_RV2CV, flags, scalar(o));
5516 Perl_newSVREF(pTHX_ OP *o)
5518 if (o->op_type == OP_PADANY) {
5519 o->op_type = OP_PADSV;
5520 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5523 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5524 o->op_flags |= OPpDONE_SVREF;
5527 return newUNOP(OP_RV2SV, 0, scalar(o));
5530 /* Check routines. */
5533 Perl_ck_anoncode(pTHX_ OP *o)
5538 name = NEWSV(1106,0);
5539 sv_upgrade(name, SVt_PVNV);
5540 sv_setpvn(name, "&", 1);
5543 ix = pad_alloc(o->op_type, SVs_PADMY);
5544 av_store(PL_comppad_name, ix, name);
5545 av_store(PL_comppad, ix, cSVOPo->op_sv);
5546 SvPADMY_on(cSVOPo->op_sv);
5547 cSVOPo->op_sv = Nullsv;
5548 cSVOPo->op_targ = ix;
5553 Perl_ck_bitop(pTHX_ OP *o)
5555 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5560 Perl_ck_concat(pTHX_ OP *o)
5562 if (cUNOPo->op_first->op_type == OP_CONCAT)
5563 o->op_flags |= OPf_STACKED;
5568 Perl_ck_spair(pTHX_ OP *o)
5570 if (o->op_flags & OPf_KIDS) {
5573 OPCODE type = o->op_type;
5574 o = modkids(ck_fun(o), type);
5575 kid = cUNOPo->op_first;
5576 newop = kUNOP->op_first->op_sibling;
5578 (newop->op_sibling ||
5579 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5580 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5581 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5585 op_free(kUNOP->op_first);
5586 kUNOP->op_first = newop;
5588 o->op_ppaddr = PL_ppaddr[++o->op_type];
5593 Perl_ck_delete(pTHX_ OP *o)
5597 if (o->op_flags & OPf_KIDS) {
5598 OP *kid = cUNOPo->op_first;
5599 switch (kid->op_type) {
5601 o->op_flags |= OPf_SPECIAL;
5604 o->op_private |= OPpSLICE;
5607 o->op_flags |= OPf_SPECIAL;
5612 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5621 Perl_ck_die(pTHX_ OP *o)
5624 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5630 Perl_ck_eof(pTHX_ OP *o)
5632 I32 type = o->op_type;
5634 if (o->op_flags & OPf_KIDS) {
5635 if (cLISTOPo->op_first->op_type == OP_STUB) {
5637 o = newUNOP(type, OPf_SPECIAL,
5638 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5646 Perl_ck_eval(pTHX_ OP *o)
5648 PL_hints |= HINT_BLOCK_SCOPE;
5649 if (o->op_flags & OPf_KIDS) {
5650 SVOP *kid = (SVOP*)cUNOPo->op_first;
5653 o->op_flags &= ~OPf_KIDS;
5656 else if (kid->op_type == OP_LINESEQ) {
5659 kid->op_next = o->op_next;
5660 cUNOPo->op_first = 0;
5663 NewOp(1101, enter, 1, LOGOP);
5664 enter->op_type = OP_ENTERTRY;
5665 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5666 enter->op_private = 0;
5668 /* establish postfix order */
5669 enter->op_next = (OP*)enter;
5671 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5672 o->op_type = OP_LEAVETRY;
5673 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5674 enter->op_other = o;
5682 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5684 o->op_targ = (PADOFFSET)PL_hints;
5689 Perl_ck_exit(pTHX_ OP *o)
5692 HV *table = GvHV(PL_hintgv);
5694 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5695 if (svp && *svp && SvTRUE(*svp))
5696 o->op_private |= OPpEXIT_VMSISH;
5698 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5704 Perl_ck_exec(pTHX_ OP *o)
5707 if (o->op_flags & OPf_STACKED) {
5709 kid = cUNOPo->op_first->op_sibling;
5710 if (kid->op_type == OP_RV2GV)
5719 Perl_ck_exists(pTHX_ OP *o)
5722 if (o->op_flags & OPf_KIDS) {
5723 OP *kid = cUNOPo->op_first;
5724 if (kid->op_type == OP_ENTERSUB) {
5725 (void) ref(kid, o->op_type);
5726 if (kid->op_type != OP_RV2CV && !PL_error_count)
5727 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5729 o->op_private |= OPpEXISTS_SUB;
5731 else if (kid->op_type == OP_AELEM)
5732 o->op_flags |= OPf_SPECIAL;
5733 else if (kid->op_type != OP_HELEM)
5734 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5743 Perl_ck_gvconst(pTHX_ register OP *o)
5745 o = fold_constants(o);
5746 if (o->op_type == OP_CONST)
5753 Perl_ck_rvconst(pTHX_ register OP *o)
5755 SVOP *kid = (SVOP*)cUNOPo->op_first;
5757 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5758 if (kid->op_type == OP_CONST) {
5762 SV *kidsv = kid->op_sv;
5765 /* Is it a constant from cv_const_sv()? */
5766 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5767 SV *rsv = SvRV(kidsv);
5768 int svtype = SvTYPE(rsv);
5769 char *badtype = Nullch;
5771 switch (o->op_type) {
5773 if (svtype > SVt_PVMG)
5774 badtype = "a SCALAR";
5777 if (svtype != SVt_PVAV)
5778 badtype = "an ARRAY";
5781 if (svtype != SVt_PVHV)
5785 if (svtype != SVt_PVCV)
5790 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5793 name = SvPV(kidsv, n_a);
5794 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5795 char *badthing = Nullch;
5796 switch (o->op_type) {
5798 badthing = "a SCALAR";
5801 badthing = "an ARRAY";
5804 badthing = "a HASH";
5809 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5813 * This is a little tricky. We only want to add the symbol if we
5814 * didn't add it in the lexer. Otherwise we get duplicate strict
5815 * warnings. But if we didn't add it in the lexer, we must at
5816 * least pretend like we wanted to add it even if it existed before,
5817 * or we get possible typo warnings. OPpCONST_ENTERED says
5818 * whether the lexer already added THIS instance of this symbol.
5820 iscv = (o->op_type == OP_RV2CV) * 2;
5822 gv = gv_fetchpv(name,
5823 iscv | !(kid->op_private & OPpCONST_ENTERED),
5826 : o->op_type == OP_RV2SV
5828 : o->op_type == OP_RV2AV
5830 : o->op_type == OP_RV2HV
5833 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5835 kid->op_type = OP_GV;
5836 SvREFCNT_dec(kid->op_sv);
5838 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5839 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5840 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5842 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5844 kid->op_sv = SvREFCNT_inc(gv);
5846 kid->op_private = 0;
5847 kid->op_ppaddr = PL_ppaddr[OP_GV];
5854 Perl_ck_ftst(pTHX_ OP *o)
5856 I32 type = o->op_type;
5858 if (o->op_flags & OPf_REF) {
5861 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5862 SVOP *kid = (SVOP*)cUNOPo->op_first;
5864 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5866 OP *newop = newGVOP(type, OPf_REF,
5867 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5874 if (type == OP_FTTTY)
5875 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5878 o = newUNOP(type, 0, newDEFSVOP());
5884 Perl_ck_fun(pTHX_ OP *o)
5890 int type = o->op_type;
5891 register I32 oa = PL_opargs[type] >> OASHIFT;
5893 if (o->op_flags & OPf_STACKED) {
5894 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5897 return no_fh_allowed(o);
5900 if (o->op_flags & OPf_KIDS) {
5902 tokid = &cLISTOPo->op_first;
5903 kid = cLISTOPo->op_first;
5904 if (kid->op_type == OP_PUSHMARK ||
5905 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5907 tokid = &kid->op_sibling;
5908 kid = kid->op_sibling;
5910 if (!kid && PL_opargs[type] & OA_DEFGV)
5911 *tokid = kid = newDEFSVOP();
5915 sibl = kid->op_sibling;
5918 /* list seen where single (scalar) arg expected? */
5919 if (numargs == 1 && !(oa >> 4)
5920 && kid->op_type == OP_LIST && type != OP_SCALAR)
5922 return too_many_arguments(o,PL_op_desc[type]);
5935 if ((type == OP_PUSH || type == OP_UNSHIFT)
5936 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5937 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5938 "Useless use of %s with no values",
5941 if (kid->op_type == OP_CONST &&
5942 (kid->op_private & OPpCONST_BARE))
5944 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5945 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5946 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5947 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5948 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5949 "Array @%s missing the @ in argument %"IVdf" of %s()",
5950 name, (IV)numargs, PL_op_desc[type]);
5953 kid->op_sibling = sibl;
5956 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5957 bad_type(numargs, "array", PL_op_desc[type], kid);
5961 if (kid->op_type == OP_CONST &&
5962 (kid->op_private & OPpCONST_BARE))
5964 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5965 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5966 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5967 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5968 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5969 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5970 name, (IV)numargs, PL_op_desc[type]);
5973 kid->op_sibling = sibl;
5976 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5977 bad_type(numargs, "hash", PL_op_desc[type], kid);
5982 OP *newop = newUNOP(OP_NULL, 0, kid);
5983 kid->op_sibling = 0;
5985 newop->op_next = newop;
5987 kid->op_sibling = sibl;
5992 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5993 if (kid->op_type == OP_CONST &&
5994 (kid->op_private & OPpCONST_BARE))
5996 OP *newop = newGVOP(OP_GV, 0,
5997 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5999 if (!(o->op_private & 1) && /* if not unop */
6000 kid == cLISTOPo->op_last)
6001 cLISTOPo->op_last = newop;
6005 else if (kid->op_type == OP_READLINE) {
6006 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6007 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6010 I32 flags = OPf_SPECIAL;
6014 /* is this op a FH constructor? */
6015 if (is_handle_constructor(o,numargs)) {
6016 char *name = Nullch;
6020 /* Set a flag to tell rv2gv to vivify
6021 * need to "prove" flag does not mean something
6022 * else already - NI-S 1999/05/07
6025 if (kid->op_type == OP_PADSV) {
6026 SV **namep = av_fetch(PL_comppad_name,
6028 if (namep && *namep)
6029 name = SvPV(*namep, len);
6031 else if (kid->op_type == OP_RV2SV
6032 && kUNOP->op_first->op_type == OP_GV)
6034 GV *gv = cGVOPx_gv(kUNOP->op_first);
6036 len = GvNAMELEN(gv);
6038 else if (kid->op_type == OP_AELEM
6039 || kid->op_type == OP_HELEM)
6041 name = "__ANONIO__";
6047 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6048 namesv = PL_curpad[targ];
6049 (void)SvUPGRADE(namesv, SVt_PV);
6051 sv_setpvn(namesv, "$", 1);
6052 sv_catpvn(namesv, name, len);
6055 kid->op_sibling = 0;
6056 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6057 kid->op_targ = targ;
6058 kid->op_private |= priv;
6060 kid->op_sibling = sibl;
6066 mod(scalar(kid), type);
6070 tokid = &kid->op_sibling;
6071 kid = kid->op_sibling;
6073 o->op_private |= numargs;
6075 return too_many_arguments(o,OP_DESC(o));
6078 else if (PL_opargs[type] & OA_DEFGV) {
6080 return newUNOP(type, 0, newDEFSVOP());
6084 while (oa & OA_OPTIONAL)
6086 if (oa && oa != OA_LIST)
6087 return too_few_arguments(o,OP_DESC(o));
6093 Perl_ck_glob(pTHX_ OP *o)
6098 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6099 append_elem(OP_GLOB, o, newDEFSVOP());
6101 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6102 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6104 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6107 #if !defined(PERL_EXTERNAL_GLOB)
6108 /* XXX this can be tightened up and made more failsafe. */
6112 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6113 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6114 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6115 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6116 GvCV(gv) = GvCV(glob_gv);
6117 SvREFCNT_inc((SV*)GvCV(gv));
6118 GvIMPORTED_CV_on(gv);
6121 #endif /* PERL_EXTERNAL_GLOB */
6123 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6124 append_elem(OP_GLOB, o,
6125 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6126 o->op_type = OP_LIST;
6127 o->op_ppaddr = PL_ppaddr[OP_LIST];
6128 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6129 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6130 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6131 append_elem(OP_LIST, o,
6132 scalar(newUNOP(OP_RV2CV, 0,
6133 newGVOP(OP_GV, 0, gv)))));
6134 o = newUNOP(OP_NULL, 0, ck_subr(o));
6135 o->op_targ = OP_GLOB; /* hint at what it used to be */
6138 gv = newGVgen("main");
6140 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6146 Perl_ck_grep(pTHX_ OP *o)
6150 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6152 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6153 NewOp(1101, gwop, 1, LOGOP);
6155 if (o->op_flags & OPf_STACKED) {
6158 kid = cLISTOPo->op_first->op_sibling;
6159 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6162 kid->op_next = (OP*)gwop;
6163 o->op_flags &= ~OPf_STACKED;
6165 kid = cLISTOPo->op_first->op_sibling;
6166 if (type == OP_MAPWHILE)
6173 kid = cLISTOPo->op_first->op_sibling;
6174 if (kid->op_type != OP_NULL)
6175 Perl_croak(aTHX_ "panic: ck_grep");
6176 kid = kUNOP->op_first;
6178 gwop->op_type = type;
6179 gwop->op_ppaddr = PL_ppaddr[type];
6180 gwop->op_first = listkids(o);
6181 gwop->op_flags |= OPf_KIDS;
6182 gwop->op_private = 1;
6183 gwop->op_other = LINKLIST(kid);
6184 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6185 kid->op_next = (OP*)gwop;
6187 kid = cLISTOPo->op_first->op_sibling;
6188 if (!kid || !kid->op_sibling)
6189 return too_few_arguments(o,OP_DESC(o));
6190 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6191 mod(kid, OP_GREPSTART);
6197 Perl_ck_index(pTHX_ OP *o)
6199 if (o->op_flags & OPf_KIDS) {
6200 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6202 kid = kid->op_sibling; /* get past "big" */
6203 if (kid && kid->op_type == OP_CONST)
6204 fbm_compile(((SVOP*)kid)->op_sv, 0);
6210 Perl_ck_lengthconst(pTHX_ OP *o)
6212 /* XXX length optimization goes here */
6217 Perl_ck_lfun(pTHX_ OP *o)
6219 OPCODE type = o->op_type;
6220 return modkids(ck_fun(o), type);
6224 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6226 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6227 switch (cUNOPo->op_first->op_type) {
6229 /* This is needed for
6230 if (defined %stash::)
6231 to work. Do not break Tk.
6233 break; /* Globals via GV can be undef */
6235 case OP_AASSIGN: /* Is this a good idea? */
6236 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6237 "defined(@array) is deprecated");
6238 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6239 "\t(Maybe you should just omit the defined()?)\n");
6242 /* This is needed for
6243 if (defined %stash::)
6244 to work. Do not break Tk.
6246 break; /* Globals via GV can be undef */
6248 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6249 "defined(%%hash) is deprecated");
6250 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6251 "\t(Maybe you should just omit the defined()?)\n");
6262 Perl_ck_rfun(pTHX_ OP *o)
6264 OPCODE type = o->op_type;
6265 return refkids(ck_fun(o), type);
6269 Perl_ck_listiob(pTHX_ OP *o)
6273 kid = cLISTOPo->op_first;
6276 kid = cLISTOPo->op_first;
6278 if (kid->op_type == OP_PUSHMARK)
6279 kid = kid->op_sibling;
6280 if (kid && o->op_flags & OPf_STACKED)
6281 kid = kid->op_sibling;
6282 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6283 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6284 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6285 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6286 cLISTOPo->op_first->op_sibling = kid;
6287 cLISTOPo->op_last = kid;
6288 kid = kid->op_sibling;
6293 append_elem(o->op_type, o, newDEFSVOP());
6299 Perl_ck_sassign(pTHX_ OP *o)
6301 OP *kid = cLISTOPo->op_first;
6302 /* has a disposable target? */
6303 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6304 && !(kid->op_flags & OPf_STACKED)
6305 /* Cannot steal the second time! */
6306 && !(kid->op_private & OPpTARGET_MY))
6308 OP *kkid = kid->op_sibling;
6310 /* Can just relocate the target. */
6311 if (kkid && kkid->op_type == OP_PADSV
6312 && !(kkid->op_private & OPpLVAL_INTRO))
6314 kid->op_targ = kkid->op_targ;
6316 /* Now we do not need PADSV and SASSIGN. */
6317 kid->op_sibling = o->op_sibling; /* NULL */
6318 cLISTOPo->op_first = NULL;
6321 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6329 Perl_ck_match(pTHX_ OP *o)
6331 o->op_private |= OPpRUNTIME;
6336 Perl_ck_method(pTHX_ OP *o)
6338 OP *kid = cUNOPo->op_first;
6339 if (kid->op_type == OP_CONST) {
6340 SV* sv = kSVOP->op_sv;
6341 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6343 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6344 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6347 kSVOP->op_sv = Nullsv;
6349 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6358 Perl_ck_null(pTHX_ OP *o)
6364 Perl_ck_open(pTHX_ OP *o)
6366 HV *table = GvHV(PL_hintgv);
6370 svp = hv_fetch(table, "open_IN", 7, FALSE);
6372 mode = mode_from_discipline(*svp);
6373 if (mode & O_BINARY)
6374 o->op_private |= OPpOPEN_IN_RAW;
6375 else if (mode & O_TEXT)
6376 o->op_private |= OPpOPEN_IN_CRLF;
6379 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6381 mode = mode_from_discipline(*svp);
6382 if (mode & O_BINARY)
6383 o->op_private |= OPpOPEN_OUT_RAW;
6384 else if (mode & O_TEXT)
6385 o->op_private |= OPpOPEN_OUT_CRLF;
6388 if (o->op_type == OP_BACKTICK)
6394 Perl_ck_repeat(pTHX_ OP *o)
6396 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6397 o->op_private |= OPpREPEAT_DOLIST;
6398 cBINOPo->op_first = force_list(cBINOPo->op_first);
6406 Perl_ck_require(pTHX_ OP *o)
6410 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6411 SVOP *kid = (SVOP*)cUNOPo->op_first;
6413 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6415 for (s = SvPVX(kid->op_sv); *s; s++) {
6416 if (*s == ':' && s[1] == ':') {
6418 Move(s+2, s+1, strlen(s+2)+1, char);
6419 --SvCUR(kid->op_sv);
6422 if (SvREADONLY(kid->op_sv)) {
6423 SvREADONLY_off(kid->op_sv);
6424 sv_catpvn(kid->op_sv, ".pm", 3);
6425 SvREADONLY_on(kid->op_sv);
6428 sv_catpvn(kid->op_sv, ".pm", 3);
6432 /* handle override, if any */
6433 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6434 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6435 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6437 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6438 OP *kid = cUNOPo->op_first;
6439 cUNOPo->op_first = 0;
6441 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6442 append_elem(OP_LIST, kid,
6443 scalar(newUNOP(OP_RV2CV, 0,
6452 Perl_ck_return(pTHX_ OP *o)
6455 if (CvLVALUE(PL_compcv)) {
6456 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6457 mod(kid, OP_LEAVESUBLV);
6464 Perl_ck_retarget(pTHX_ OP *o)
6466 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6473 Perl_ck_select(pTHX_ OP *o)
6476 if (o->op_flags & OPf_KIDS) {
6477 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6478 if (kid && kid->op_sibling) {
6479 o->op_type = OP_SSELECT;
6480 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6482 return fold_constants(o);
6486 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6487 if (kid && kid->op_type == OP_RV2GV)
6488 kid->op_private &= ~HINT_STRICT_REFS;
6493 Perl_ck_shift(pTHX_ OP *o)
6495 I32 type = o->op_type;
6497 if (!(o->op_flags & OPf_KIDS)) {
6501 #ifdef USE_5005THREADS
6502 if (!CvUNIQUE(PL_compcv)) {
6503 argop = newOP(OP_PADAV, OPf_REF);
6504 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6507 argop = newUNOP(OP_RV2AV, 0,
6508 scalar(newGVOP(OP_GV, 0,
6509 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6512 argop = newUNOP(OP_RV2AV, 0,
6513 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6514 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6515 #endif /* USE_5005THREADS */
6516 return newUNOP(type, 0, scalar(argop));
6518 return scalar(modkids(ck_fun(o), type));
6522 Perl_ck_sort(pTHX_ OP *o)
6526 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6528 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6529 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6531 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6533 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6535 if (kid->op_type == OP_SCOPE) {
6539 else if (kid->op_type == OP_LEAVE) {
6540 if (o->op_type == OP_SORT) {
6541 op_null(kid); /* wipe out leave */
6544 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6545 if (k->op_next == kid)
6547 /* don't descend into loops */
6548 else if (k->op_type == OP_ENTERLOOP
6549 || k->op_type == OP_ENTERITER)
6551 k = cLOOPx(k)->op_lastop;
6556 kid->op_next = 0; /* just disconnect the leave */
6557 k = kLISTOP->op_first;
6562 if (o->op_type == OP_SORT) {
6563 /* provide scalar context for comparison function/block */
6569 o->op_flags |= OPf_SPECIAL;
6571 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6574 firstkid = firstkid->op_sibling;
6577 /* provide list context for arguments */
6578 if (o->op_type == OP_SORT)
6585 S_simplify_sort(pTHX_ OP *o)
6587 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6591 if (!(o->op_flags & OPf_STACKED))
6593 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6594 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6595 kid = kUNOP->op_first; /* get past null */
6596 if (kid->op_type != OP_SCOPE)
6598 kid = kLISTOP->op_last; /* get past scope */
6599 switch(kid->op_type) {
6607 k = kid; /* remember this node*/
6608 if (kBINOP->op_first->op_type != OP_RV2SV)
6610 kid = kBINOP->op_first; /* get past cmp */
6611 if (kUNOP->op_first->op_type != OP_GV)
6613 kid = kUNOP->op_first; /* get past rv2sv */
6615 if (GvSTASH(gv) != PL_curstash)
6617 if (strEQ(GvNAME(gv), "a"))
6619 else if (strEQ(GvNAME(gv), "b"))
6623 kid = k; /* back to cmp */
6624 if (kBINOP->op_last->op_type != OP_RV2SV)
6626 kid = kBINOP->op_last; /* down to 2nd arg */
6627 if (kUNOP->op_first->op_type != OP_GV)
6629 kid = kUNOP->op_first; /* get past rv2sv */
6631 if (GvSTASH(gv) != PL_curstash
6633 ? strNE(GvNAME(gv), "a")
6634 : strNE(GvNAME(gv), "b")))
6636 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6638 o->op_private |= OPpSORT_REVERSE;
6639 if (k->op_type == OP_NCMP)
6640 o->op_private |= OPpSORT_NUMERIC;
6641 if (k->op_type == OP_I_NCMP)
6642 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6643 kid = cLISTOPo->op_first->op_sibling;
6644 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6645 op_free(kid); /* then delete it */
6649 Perl_ck_split(pTHX_ OP *o)
6653 if (o->op_flags & OPf_STACKED)
6654 return no_fh_allowed(o);
6656 kid = cLISTOPo->op_first;
6657 if (kid->op_type != OP_NULL)
6658 Perl_croak(aTHX_ "panic: ck_split");
6659 kid = kid->op_sibling;
6660 op_free(cLISTOPo->op_first);
6661 cLISTOPo->op_first = kid;
6663 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6664 cLISTOPo->op_last = kid; /* There was only one element previously */
6667 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6668 OP *sibl = kid->op_sibling;
6669 kid->op_sibling = 0;
6670 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6671 if (cLISTOPo->op_first == cLISTOPo->op_last)
6672 cLISTOPo->op_last = kid;
6673 cLISTOPo->op_first = kid;
6674 kid->op_sibling = sibl;
6677 kid->op_type = OP_PUSHRE;
6678 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6680 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6681 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6682 "Use of /g modifier is meaningless in split");
6685 if (!kid->op_sibling)
6686 append_elem(OP_SPLIT, o, newDEFSVOP());
6688 kid = kid->op_sibling;
6691 if (!kid->op_sibling)
6692 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6694 kid = kid->op_sibling;
6697 if (kid->op_sibling)
6698 return too_many_arguments(o,OP_DESC(o));
6704 Perl_ck_join(pTHX_ OP *o)
6706 if (ckWARN(WARN_SYNTAX)) {
6707 OP *kid = cLISTOPo->op_first->op_sibling;
6708 if (kid && kid->op_type == OP_MATCH) {
6709 char *pmstr = "STRING";
6710 if (PM_GETRE(kPMOP))
6711 pmstr = PM_GETRE(kPMOP)->precomp;
6712 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6713 "/%s/ should probably be written as \"%s\"",
6721 Perl_ck_subr(pTHX_ OP *o)
6723 OP *prev = ((cUNOPo->op_first->op_sibling)
6724 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6725 OP *o2 = prev->op_sibling;
6732 I32 contextclass = 0;
6736 o->op_private |= OPpENTERSUB_HASTARG;
6737 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6738 if (cvop->op_type == OP_RV2CV) {
6740 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6741 op_null(cvop); /* disable rv2cv */
6742 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6743 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6744 GV *gv = cGVOPx_gv(tmpop);
6747 tmpop->op_private |= OPpEARLY_CV;
6748 else if (SvPOK(cv)) {
6749 namegv = CvANON(cv) ? gv : CvGV(cv);
6750 proto = SvPV((SV*)cv, n_a);
6754 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6755 if (o2->op_type == OP_CONST)
6756 o2->op_private &= ~OPpCONST_STRICT;
6757 else if (o2->op_type == OP_LIST) {
6758 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6759 if (o && o->op_type == OP_CONST)
6760 o->op_private &= ~OPpCONST_STRICT;
6763 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6764 if (PERLDB_SUB && PL_curstash != PL_debstash)
6765 o->op_private |= OPpENTERSUB_DB;
6766 while (o2 != cvop) {
6770 return too_many_arguments(o, gv_ename(namegv));
6788 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6790 arg == 1 ? "block or sub {}" : "sub {}",
6791 gv_ename(namegv), o2);
6794 /* '*' allows any scalar type, including bareword */
6797 if (o2->op_type == OP_RV2GV)
6798 goto wrapref; /* autoconvert GLOB -> GLOBref */
6799 else if (o2->op_type == OP_CONST)
6800 o2->op_private &= ~OPpCONST_STRICT;
6801 else if (o2->op_type == OP_ENTERSUB) {
6802 /* accidental subroutine, revert to bareword */
6803 OP *gvop = ((UNOP*)o2)->op_first;
6804 if (gvop && gvop->op_type == OP_NULL) {
6805 gvop = ((UNOP*)gvop)->op_first;
6807 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6810 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6811 (gvop = ((UNOP*)gvop)->op_first) &&
6812 gvop->op_type == OP_GV)
6814 GV *gv = cGVOPx_gv(gvop);
6815 OP *sibling = o2->op_sibling;
6816 SV *n = newSVpvn("",0);
6818 gv_fullname3(n, gv, "");
6819 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6820 sv_chop(n, SvPVX(n)+6);
6821 o2 = newSVOP(OP_CONST, 0, n);
6822 prev->op_sibling = o2;
6823 o2->op_sibling = sibling;
6839 if (contextclass++ == 0) {
6840 e = strchr(proto, ']');
6841 if (!e || e == proto)
6854 while (*--p != '[');
6855 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6856 gv_ename(namegv), o2);
6862 if (o2->op_type == OP_RV2GV)
6865 bad_type(arg, "symbol", gv_ename(namegv), o2);
6868 if (o2->op_type == OP_ENTERSUB)
6871 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6874 if (o2->op_type == OP_RV2SV ||
6875 o2->op_type == OP_PADSV ||
6876 o2->op_type == OP_HELEM ||
6877 o2->op_type == OP_AELEM ||
6878 o2->op_type == OP_THREADSV)
6881 bad_type(arg, "scalar", gv_ename(namegv), o2);
6884 if (o2->op_type == OP_RV2AV ||
6885 o2->op_type == OP_PADAV)
6888 bad_type(arg, "array", gv_ename(namegv), o2);
6891 if (o2->op_type == OP_RV2HV ||
6892 o2->op_type == OP_PADHV)
6895 bad_type(arg, "hash", gv_ename(namegv), o2);
6900 OP* sib = kid->op_sibling;
6901 kid->op_sibling = 0;
6902 o2 = newUNOP(OP_REFGEN, 0, kid);
6903 o2->op_sibling = sib;
6904 prev->op_sibling = o2;
6906 if (contextclass && e) {
6921 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6922 gv_ename(namegv), SvPV((SV*)cv, n_a));
6927 mod(o2, OP_ENTERSUB);
6929 o2 = o2->op_sibling;
6931 if (proto && !optional &&
6932 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6933 return too_few_arguments(o, gv_ename(namegv));
6938 Perl_ck_svconst(pTHX_ OP *o)
6940 SvREADONLY_on(cSVOPo->op_sv);
6945 Perl_ck_trunc(pTHX_ OP *o)
6947 if (o->op_flags & OPf_KIDS) {
6948 SVOP *kid = (SVOP*)cUNOPo->op_first;
6950 if (kid->op_type == OP_NULL)
6951 kid = (SVOP*)kid->op_sibling;
6952 if (kid && kid->op_type == OP_CONST &&
6953 (kid->op_private & OPpCONST_BARE))
6955 o->op_flags |= OPf_SPECIAL;
6956 kid->op_private &= ~OPpCONST_STRICT;
6963 Perl_ck_substr(pTHX_ OP *o)
6966 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6967 OP *kid = cLISTOPo->op_first;
6969 if (kid->op_type == OP_NULL)
6970 kid = kid->op_sibling;
6972 kid->op_flags |= OPf_MOD;
6978 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6981 Perl_peep(pTHX_ register OP *o)
6983 register OP* oldop = 0;
6985 if (!o || o->op_seq)
6989 SAVEVPTR(PL_curcop);
6990 for (; o; o = o->op_next) {
6996 switch (o->op_type) {
7000 PL_curcop = ((COP*)o); /* for warnings */
7001 o->op_seq = PL_op_seqmax++;
7005 if (cSVOPo->op_private & OPpCONST_STRICT)
7006 no_bareword_allowed(o);
7008 /* Relocate sv to the pad for thread safety.
7009 * Despite being a "constant", the SV is written to,
7010 * for reference counts, sv_upgrade() etc. */
7012 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7013 if (SvPADTMP(cSVOPo->op_sv)) {
7014 /* If op_sv is already a PADTMP then it is being used by
7015 * some pad, so make a copy. */
7016 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
7017 SvREADONLY_on(PL_curpad[ix]);
7018 SvREFCNT_dec(cSVOPo->op_sv);
7021 SvREFCNT_dec(PL_curpad[ix]);
7022 SvPADTMP_on(cSVOPo->op_sv);
7023 PL_curpad[ix] = cSVOPo->op_sv;
7024 /* XXX I don't know how this isn't readonly already. */
7025 SvREADONLY_on(PL_curpad[ix]);
7027 cSVOPo->op_sv = Nullsv;
7031 o->op_seq = PL_op_seqmax++;
7035 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7036 if (o->op_next->op_private & OPpTARGET_MY) {
7037 if (o->op_flags & OPf_STACKED) /* chained concats */
7038 goto ignore_optimization;
7040 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7041 o->op_targ = o->op_next->op_targ;
7042 o->op_next->op_targ = 0;
7043 o->op_private |= OPpTARGET_MY;
7046 op_null(o->op_next);
7048 ignore_optimization:
7049 o->op_seq = PL_op_seqmax++;
7052 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7053 o->op_seq = PL_op_seqmax++;
7054 break; /* Scalar stub must produce undef. List stub is noop */
7058 if (o->op_targ == OP_NEXTSTATE
7059 || o->op_targ == OP_DBSTATE
7060 || o->op_targ == OP_SETSTATE)
7062 PL_curcop = ((COP*)o);
7064 /* XXX: We avoid setting op_seq here to prevent later calls
7065 to peep() from mistakenly concluding that optimisation
7066 has already occurred. This doesn't fix the real problem,
7067 though (See 20010220.007). AMS 20010719 */
7068 if (oldop && o->op_next) {
7069 oldop->op_next = o->op_next;
7077 if (oldop && o->op_next) {
7078 oldop->op_next = o->op_next;
7081 o->op_seq = PL_op_seqmax++;
7085 if (o->op_next->op_type == OP_RV2SV) {
7086 if (!(o->op_next->op_private & OPpDEREF)) {
7087 op_null(o->op_next);
7088 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7090 o->op_next = o->op_next->op_next;
7091 o->op_type = OP_GVSV;
7092 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7095 else if (o->op_next->op_type == OP_RV2AV) {
7096 OP* pop = o->op_next->op_next;
7098 if (pop && pop->op_type == OP_CONST &&
7099 (PL_op = pop->op_next) &&
7100 pop->op_next->op_type == OP_AELEM &&
7101 !(pop->op_next->op_private &
7102 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7103 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7108 op_null(o->op_next);
7109 op_null(pop->op_next);
7111 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7112 o->op_next = pop->op_next->op_next;
7113 o->op_type = OP_AELEMFAST;
7114 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7115 o->op_private = (U8)i;
7120 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7122 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7123 /* XXX could check prototype here instead of just carping */
7124 SV *sv = sv_newmortal();
7125 gv_efullname3(sv, gv, Nullch);
7126 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7127 "%s() called too early to check prototype",
7131 else if (o->op_next->op_type == OP_READLINE
7132 && o->op_next->op_next->op_type == OP_CONCAT
7133 && (o->op_next->op_next->op_flags & OPf_STACKED))
7135 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7136 o->op_type = OP_RCATLINE;
7137 o->op_flags |= OPf_STACKED;
7138 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7139 op_null(o->op_next->op_next);
7140 op_null(o->op_next);
7143 o->op_seq = PL_op_seqmax++;
7156 o->op_seq = PL_op_seqmax++;
7157 while (cLOGOP->op_other->op_type == OP_NULL)
7158 cLOGOP->op_other = cLOGOP->op_other->op_next;
7159 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7164 o->op_seq = PL_op_seqmax++;
7165 while (cLOOP->op_redoop->op_type == OP_NULL)
7166 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7167 peep(cLOOP->op_redoop);
7168 while (cLOOP->op_nextop->op_type == OP_NULL)
7169 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7170 peep(cLOOP->op_nextop);
7171 while (cLOOP->op_lastop->op_type == OP_NULL)
7172 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7173 peep(cLOOP->op_lastop);
7179 o->op_seq = PL_op_seqmax++;
7180 while (cPMOP->op_pmreplstart &&
7181 cPMOP->op_pmreplstart->op_type == OP_NULL)
7182 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7183 peep(cPMOP->op_pmreplstart);
7187 o->op_seq = PL_op_seqmax++;
7188 if (ckWARN(WARN_SYNTAX) && o->op_next
7189 && o->op_next->op_type == OP_NEXTSTATE) {
7190 if (o->op_next->op_sibling &&
7191 o->op_next->op_sibling->op_type != OP_EXIT &&
7192 o->op_next->op_sibling->op_type != OP_WARN &&
7193 o->op_next->op_sibling->op_type != OP_DIE) {
7194 line_t oldline = CopLINE(PL_curcop);
7196 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7197 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7198 "Statement unlikely to be reached");
7199 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7200 "\t(Maybe you meant system() when you said exec()?)\n");
7201 CopLINE_set(PL_curcop, oldline);
7212 o->op_seq = PL_op_seqmax++;
7214 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7217 /* Make the CONST have a shared SV */
7218 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7219 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7220 key = SvPV(sv, keylen);
7221 lexname = newSVpvn_share(key,
7222 SvUTF8(sv) ? -(I32)keylen : keylen,
7231 o->op_seq = PL_op_seqmax++;
7241 char* Perl_custom_op_name(pTHX_ OP* o)
7243 IV index = PTR2IV(o->op_ppaddr);
7247 if (!PL_custom_op_names) /* This probably shouldn't happen */
7248 return PL_op_name[OP_CUSTOM];
7250 keysv = sv_2mortal(newSViv(index));
7252 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7254 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7256 return SvPV_nolen(HeVAL(he));
7259 char* Perl_custom_op_desc(pTHX_ OP* o)
7261 IV index = PTR2IV(o->op_ppaddr);
7265 if (!PL_custom_op_descs)
7266 return PL_op_desc[OP_CUSTOM];
7268 keysv = sv_2mortal(newSViv(index));
7270 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7272 return PL_op_desc[OP_CUSTOM];
7274 return SvPV_nolen(HeVAL(he));
7280 /* Efficient sub that returns a constant scalar value. */
7282 const_sv_xsub(pTHX_ CV* cv)
7287 Perl_croak(aTHX_ "usage: %s::%s()",
7288 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7292 ST(0) = (SV*)XSANY.any_ptr;