3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
47 if ((PL_OpSpace -= sz) < 0) {
48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
63 PL_OpPtr += PERL_SLAB_SIZE;
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
77 S_Slab_Free(pTHX_ void *op)
79 I32 **ptr = (I32 **) op;
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
86 #define PerlMemShared PerlMem
89 PerlMemShared_free(slab);
90 if (slab == PL_OpSlab) {
97 #define NewOp(m, var, c, type) Newz(m, var, c, type)
98 #define FreeOp(p) Safefree(p)
101 * In the following definition, the ", Nullop" is just to make the compiler
102 * think the expression is of the right type: croak actually does a Siglongjmp.
104 #define CHECKOP(type,o) \
105 ((PL_op_mask && PL_op_mask[type]) \
106 ? ( op_free((OP*)o), \
107 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
109 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
111 #define PAD_MAX 999999999
112 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
115 S_gv_ename(pTHX_ GV *gv)
118 SV* tmpsv = sv_newmortal();
119 gv_efullname3(tmpsv, gv, Nullch);
120 return SvPV(tmpsv,n_a);
124 S_no_fh_allowed(pTHX_ OP *o)
126 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
132 S_too_few_arguments(pTHX_ OP *o, char *name)
134 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
139 S_too_many_arguments(pTHX_ OP *o, char *name)
141 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
146 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
148 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
149 (int)n, name, t, OP_DESC(kid)));
153 S_no_bareword_allowed(pTHX_ OP *o)
155 qerror(Perl_mess(aTHX_
156 "Bareword \"%s\" not allowed while \"strict subs\" in use",
157 SvPV_nolen(cSVOPo_sv)));
160 /* "register" allocation */
163 Perl_pad_allocmy(pTHX_ char *name)
168 if (!(PL_in_my == KEY_our ||
170 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
171 (name[1] == '_' && (int)strlen(name) > 2)))
173 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
174 /* 1999-02-27 mjd@plover.com */
176 p = strchr(name, '\0');
177 /* The next block assumes the buffer is at least 205 chars
178 long. At present, it's always at least 256 chars. */
180 strcpy(name+200, "...");
186 /* Move everything else down one character */
187 for (; p-name > 2; p--)
189 name[2] = toCTRL(name[1]);
192 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
194 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
195 SV **svp = AvARRAY(PL_comppad_name);
196 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
197 PADOFFSET top = AvFILLp(PL_comppad_name);
198 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
200 && sv != &PL_sv_undef
201 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
202 && (PL_in_my != KEY_our
203 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
204 && strEQ(name, SvPVX(sv)))
206 Perl_warner(aTHX_ packWARN(WARN_MISC),
207 "\"%s\" variable %s masks earlier declaration in same %s",
208 (PL_in_my == KEY_our ? "our" : "my"),
210 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
215 if (PL_in_my == KEY_our) {
218 && sv != &PL_sv_undef
219 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
220 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
221 && strEQ(name, SvPVX(sv)))
223 Perl_warner(aTHX_ packWARN(WARN_MISC),
224 "\"our\" variable %s redeclared", name);
225 Perl_warner(aTHX_ packWARN(WARN_MISC),
226 "\t(Did you mean \"local\" instead of \"our\"?)\n");
229 } while ( off-- > 0 );
232 off = pad_alloc(OP_PADSV, SVs_PADMY);
234 sv_upgrade(sv, SVt_PVNV);
236 if (PL_in_my_stash) {
238 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
239 name, PL_in_my == KEY_our ? "our" : "my"));
240 SvFLAGS(sv) |= SVpad_TYPED;
241 (void)SvUPGRADE(sv, SVt_PVMG);
242 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
244 if (PL_in_my == KEY_our) {
245 (void)SvUPGRADE(sv, SVt_PVGV);
246 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
247 SvFLAGS(sv) |= SVpad_OUR;
249 av_store(PL_comppad_name, off, sv);
250 SvNVX(sv) = (NV)PAD_MAX;
251 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
252 if (!PL_min_intro_pending)
253 PL_min_intro_pending = off;
254 PL_max_intro_pending = off;
256 av_store(PL_comppad, off, (SV*)newAV());
257 else if (*name == '%')
258 av_store(PL_comppad, off, (SV*)newHV());
259 SvPADMY_on(PL_curpad[off]);
264 S_pad_addlex(pTHX_ SV *proto_namesv)
266 SV *namesv = NEWSV(1103,0);
267 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
268 sv_upgrade(namesv, SVt_PVNV);
269 sv_setpv(namesv, SvPVX(proto_namesv));
270 av_store(PL_comppad_name, newoff, namesv);
271 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
272 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
273 SvFAKE_on(namesv); /* A ref, not a real var */
274 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
275 SvFLAGS(namesv) |= SVpad_OUR;
276 (void)SvUPGRADE(namesv, SVt_PVGV);
277 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
279 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
280 SvFLAGS(namesv) |= SVpad_TYPED;
281 (void)SvUPGRADE(namesv, SVt_PVMG);
282 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
287 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
290 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
291 I32 cx_ix, I32 saweval, U32 flags)
297 register PERL_CONTEXT *cx;
299 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
300 AV *curlist = CvPADLIST(cv);
301 SV **svp = av_fetch(curlist, 0, FALSE);
304 if (!svp || *svp == &PL_sv_undef)
307 svp = AvARRAY(curname);
308 for (off = AvFILLp(curname); off > 0; off--) {
309 if ((sv = svp[off]) &&
310 sv != &PL_sv_undef &&
311 seq <= (U32)SvIVX(sv) &&
312 seq > (U32)I_32(SvNVX(sv)) &&
313 strEQ(SvPVX(sv), name))
324 return 0; /* don't clone from inactive stack frame */
328 oldpad = (AV*)AvARRAY(curlist)[depth];
329 oldsv = *av_fetch(oldpad, off, TRUE);
330 if (!newoff) { /* Not a mere clone operation. */
331 newoff = pad_addlex(sv);
332 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
333 /* "It's closures all the way down." */
334 CvCLONE_on(PL_compcv);
336 if (CvANON(PL_compcv))
337 oldsv = Nullsv; /* no need to keep ref */
342 bcv && bcv != cv && !CvCLONE(bcv);
343 bcv = CvOUTSIDE(bcv))
346 /* install the missing pad entry in intervening
347 * nested subs and mark them cloneable.
348 * XXX fix pad_foo() to not use globals */
349 AV *ocomppad_name = PL_comppad_name;
350 AV *ocomppad = PL_comppad;
351 SV **ocurpad = PL_curpad;
352 AV *padlist = CvPADLIST(bcv);
353 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
354 PL_comppad = (AV*)AvARRAY(padlist)[1];
355 PL_curpad = AvARRAY(PL_comppad);
357 PL_comppad_name = ocomppad_name;
358 PL_comppad = ocomppad;
363 if (ckWARN(WARN_CLOSURE)
364 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
366 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
367 "Variable \"%s\" may be unavailable",
375 else if (!CvUNIQUE(PL_compcv)) {
376 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
377 && !(SvFLAGS(sv) & SVpad_OUR))
379 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
380 "Variable \"%s\" will not stay shared", name);
384 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
390 if (flags & FINDLEX_NOSEARCH)
393 /* Nothing in current lexical context--try eval's context, if any.
394 * This is necessary to let the perldb get at lexically scoped variables.
395 * XXX This will also probably interact badly with eval tree caching.
398 for (i = cx_ix; i >= 0; i--) {
400 switch (CxTYPE(cx)) {
402 if (i == 0 && saweval) {
403 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
407 switch (cx->blk_eval.old_op_type) {
409 if (CxREALEVAL(cx)) {
412 seq = cxstack[i].blk_oldcop->cop_seq;
413 startcv = cxstack[i].blk_eval.cv;
414 if (startcv && CvOUTSIDE(startcv)) {
415 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
417 if (off) /* continue looking if not found here */
424 /* require/do must have their own scope */
433 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
434 saweval = i; /* so we know where we were called from */
435 seq = cxstack[i].blk_oldcop->cop_seq;
438 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
446 Perl_pad_findmy(pTHX_ char *name)
451 SV **svp = AvARRAY(PL_comppad_name);
452 U32 seq = PL_cop_seqmax;
456 #ifdef USE_5005THREADS
458 * Special case to get lexical (and hence per-thread) @_.
459 * XXX I need to find out how to tell at parse-time whether use
460 * of @_ should refer to a lexical (from a sub) or defgv (global
461 * scope and maybe weird sub-ish things like formats). See
462 * startsub in perly.y. It's possible that @_ could be lexical
463 * (at least from subs) even in non-threaded perl.
465 if (strEQ(name, "@_"))
466 return 0; /* success. (NOT_IN_PAD indicates failure) */
467 #endif /* USE_5005THREADS */
469 /* The one we're looking for is probably just before comppad_name_fill. */
470 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
471 if ((sv = svp[off]) &&
472 sv != &PL_sv_undef &&
474 (seq <= (U32)SvIVX(sv) &&
475 seq > (U32)I_32(SvNVX(sv)))) &&
476 strEQ(SvPVX(sv), name))
478 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
479 return (PADOFFSET)off;
480 pendoff = off; /* this pending def. will override import */
484 outside = CvOUTSIDE(PL_compcv);
486 /* Check if if we're compiling an eval'', and adjust seq to be the
487 * eval's seq number. This depends on eval'' having a non-null
488 * CvOUTSIDE() while it is being compiled. The eval'' itself is
489 * identified by CvEVAL being true and CvGV being null. */
490 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
491 cx = &cxstack[cxstack_ix];
493 seq = cx->blk_oldcop->cop_seq;
496 /* See if it's in a nested scope */
497 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
499 /* If there is a pending local definition, this new alias must die */
501 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
502 return off; /* pad_findlex returns 0 for failure...*/
504 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
508 Perl_pad_leavemy(pTHX_ I32 fill)
511 SV **svp = AvARRAY(PL_comppad_name);
513 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
514 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
515 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
516 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "%s never introduced", SvPVX(sv));
519 /* "Deintroduce" my variables that are leaving with this scope. */
520 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
521 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
522 SvIVX(sv) = PL_cop_seqmax;
527 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
532 if (AvARRAY(PL_comppad) != PL_curpad)
533 Perl_croak(aTHX_ "panic: pad_alloc");
534 if (PL_pad_reset_pending)
536 if (tmptype & SVs_PADMY) {
538 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
539 } while (SvPADBUSY(sv)); /* need a fresh one */
540 retval = AvFILLp(PL_comppad);
543 SV **names = AvARRAY(PL_comppad_name);
544 SSize_t names_fill = AvFILLp(PL_comppad_name);
547 * "foreach" index vars temporarily become aliases to non-"my"
548 * values. Thus we must skip, not just pad values that are
549 * marked as current pad values, but also those with names.
551 if (++PL_padix <= names_fill &&
552 (sv = names[PL_padix]) && sv != &PL_sv_undef)
554 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
555 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
556 !IS_PADGV(sv) && !IS_PADCONST(sv))
561 SvFLAGS(sv) |= tmptype;
562 PL_curpad = AvARRAY(PL_comppad);
563 #ifdef USE_5005THREADS
564 DEBUG_X(PerlIO_printf(Perl_debug_log,
565 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
566 PTR2UV(thr), PTR2UV(PL_curpad),
567 (long) retval, PL_op_name[optype]));
569 DEBUG_X(PerlIO_printf(Perl_debug_log,
570 "Pad 0x%"UVxf" alloc %ld for %s\n",
572 (long) retval, PL_op_name[optype]));
573 #endif /* USE_5005THREADS */
574 return (PADOFFSET)retval;
578 Perl_pad_sv(pTHX_ PADOFFSET po)
580 #ifdef USE_5005THREADS
581 DEBUG_X(PerlIO_printf(Perl_debug_log,
582 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
583 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
586 Perl_croak(aTHX_ "panic: pad_sv po");
587 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
588 PTR2UV(PL_curpad), (IV)po));
589 #endif /* USE_5005THREADS */
590 return PL_curpad[po]; /* eventually we'll turn this into a macro */
594 Perl_pad_free(pTHX_ PADOFFSET po)
598 if (AvARRAY(PL_comppad) != PL_curpad)
599 Perl_croak(aTHX_ "panic: pad_free curpad");
601 Perl_croak(aTHX_ "panic: pad_free po");
602 #ifdef USE_5005THREADS
603 DEBUG_X(PerlIO_printf(Perl_debug_log,
604 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
605 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
607 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
608 PTR2UV(PL_curpad), (IV)po));
609 #endif /* USE_5005THREADS */
610 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
611 SvPADTMP_off(PL_curpad[po]);
613 #ifdef PERL_COPY_ON_WRITE
614 if (SvIsCOW(PL_curpad[po])) {
615 sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
618 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
621 if ((I32)po < PL_padix)
626 Perl_pad_swipe(pTHX_ PADOFFSET po)
628 if (AvARRAY(PL_comppad) != PL_curpad)
629 Perl_croak(aTHX_ "panic: pad_swipe curpad");
631 Perl_croak(aTHX_ "panic: pad_swipe po");
632 #ifdef USE_5005THREADS
633 DEBUG_X(PerlIO_printf(Perl_debug_log,
634 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
635 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
637 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
638 PTR2UV(PL_curpad), (IV)po));
639 #endif /* USE_5005THREADS */
640 SvPADTMP_off(PL_curpad[po]);
641 PL_curpad[po] = NEWSV(1107,0);
642 SvPADTMP_on(PL_curpad[po]);
643 if ((I32)po < PL_padix)
647 /* XXX pad_reset() is currently disabled because it results in serious bugs.
648 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
649 * on the stack by OPs that use them, there are several ways to get an alias
650 * to a shared TARG. Such an alias will change randomly and unpredictably.
651 * We avoid doing this until we can think of a Better Way.
656 #ifdef USE_BROKEN_PAD_RESET
659 if (AvARRAY(PL_comppad) != PL_curpad)
660 Perl_croak(aTHX_ "panic: pad_reset curpad");
661 #ifdef USE_5005THREADS
662 DEBUG_X(PerlIO_printf(Perl_debug_log,
663 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
664 PTR2UV(thr), PTR2UV(PL_curpad)));
666 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
668 #endif /* USE_5005THREADS */
669 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
670 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
671 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
672 SvPADTMP_off(PL_curpad[po]);
674 PL_padix = PL_padix_floor;
677 PL_pad_reset_pending = FALSE;
680 #ifdef USE_5005THREADS
681 /* find_threadsv is not reentrant */
683 Perl_find_threadsv(pTHX_ const char *name)
688 /* We currently only handle names of a single character */
689 p = strchr(PL_threadsv_names, *name);
692 key = p - PL_threadsv_names;
693 MUTEX_LOCK(&thr->mutex);
694 svp = av_fetch(thr->threadsv, key, FALSE);
696 MUTEX_UNLOCK(&thr->mutex);
698 SV *sv = NEWSV(0, 0);
699 av_store(thr->threadsv, key, sv);
700 thr->threadsvp = AvARRAY(thr->threadsv);
701 MUTEX_UNLOCK(&thr->mutex);
703 * Some magic variables used to be automagically initialised
704 * in gv_fetchpv. Those which are now per-thread magicals get
705 * initialised here instead.
711 sv_setpv(sv, "\034");
712 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
717 PL_sawampersand = TRUE;
731 /* XXX %! tied to Errno.pm needs to be added here.
732 * See gv_fetchpv(). */
736 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
738 DEBUG_S(PerlIO_printf(Perl_error_log,
739 "find_threadsv: new SV %p for $%s%c\n",
740 sv, (*name < 32) ? "^" : "",
741 (*name < 32) ? toCTRL(*name) : *name));
745 #endif /* USE_5005THREADS */
750 Perl_op_free(pTHX_ OP *o)
752 register OP *kid, *nextkid;
755 if (!o || o->op_seq == (U16)-1)
758 if (o->op_private & OPpREFCOUNTED) {
759 switch (o->op_type) {
767 if (OpREFCNT_dec(o)) {
778 if (o->op_flags & OPf_KIDS) {
779 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
780 nextkid = kid->op_sibling; /* Get before next freeing kid */
786 type = (OPCODE)o->op_targ;
788 /* COP* is not cleared by op_clear() so that we may track line
789 * numbers etc even after null() */
790 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
798 Perl_op_clear(pTHX_ OP *o)
801 switch (o->op_type) {
802 case OP_NULL: /* Was holding old type, if any. */
803 case OP_ENTEREVAL: /* Was holding hints. */
804 #ifdef USE_5005THREADS
805 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
809 #ifdef USE_5005THREADS
811 if (!(o->op_flags & OPf_SPECIAL))
814 #endif /* USE_5005THREADS */
816 if (!(o->op_flags & OPf_REF)
817 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
824 if (cPADOPo->op_padix > 0) {
827 pad_swipe(cPADOPo->op_padix);
828 /* No GvIN_PAD_off(gv) here, because other references may still
829 * exist on the pad */
832 cPADOPo->op_padix = 0;
835 SvREFCNT_dec(cSVOPo->op_sv);
836 cSVOPo->op_sv = Nullsv;
839 case OP_METHOD_NAMED:
841 SvREFCNT_dec(cSVOPo->op_sv);
842 cSVOPo->op_sv = Nullsv;
848 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
852 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
853 SvREFCNT_dec(cSVOPo->op_sv);
854 cSVOPo->op_sv = Nullsv;
857 Safefree(cPVOPo->op_pv);
858 cPVOPo->op_pv = Nullch;
862 op_free(cPMOPo->op_pmreplroot);
866 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
868 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
869 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
870 /* No GvIN_PAD_off(gv) here, because other references may still
871 * exist on the pad */
876 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
883 HV *pmstash = PmopSTASH(cPMOPo);
884 if (pmstash && SvREFCNT(pmstash)) {
885 PMOP *pmop = HvPMROOT(pmstash);
886 PMOP *lastpmop = NULL;
888 if (cPMOPo == pmop) {
890 lastpmop->op_pmnext = pmop->op_pmnext;
892 HvPMROOT(pmstash) = pmop->op_pmnext;
896 pmop = pmop->op_pmnext;
899 PmopSTASH_free(cPMOPo);
901 cPMOPo->op_pmreplroot = Nullop;
902 /* we use the "SAFE" version of the PM_ macros here
903 * since sv_clean_all might release some PMOPs
904 * after PL_regex_padav has been cleared
905 * and the clearing of PL_regex_padav needs to
906 * happen before sv_clean_all
908 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
909 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
911 if(PL_regex_pad) { /* We could be in destruction */
912 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
913 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
914 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
921 if (o->op_targ > 0) {
922 pad_free(o->op_targ);
928 S_cop_free(pTHX_ COP* cop)
930 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
933 if (! specialWARN(cop->cop_warnings))
934 SvREFCNT_dec(cop->cop_warnings);
935 if (! specialCopIO(cop->cop_io)) {
939 char *s = SvPV(cop->cop_io,len);
940 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
943 SvREFCNT_dec(cop->cop_io);
949 Perl_op_null(pTHX_ OP *o)
951 if (o->op_type == OP_NULL)
954 o->op_targ = o->op_type;
955 o->op_type = OP_NULL;
956 o->op_ppaddr = PL_ppaddr[OP_NULL];
959 /* Contextualizers */
961 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
964 Perl_linklist(pTHX_ OP *o)
971 /* establish postfix order */
972 if (cUNOPo->op_first) {
973 o->op_next = LINKLIST(cUNOPo->op_first);
974 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
976 kid->op_next = LINKLIST(kid->op_sibling);
988 Perl_scalarkids(pTHX_ OP *o)
991 if (o && o->op_flags & OPf_KIDS) {
992 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
999 S_scalarboolean(pTHX_ OP *o)
1001 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
1002 if (ckWARN(WARN_SYNTAX)) {
1003 line_t oldline = CopLINE(PL_curcop);
1005 if (PL_copline != NOLINE)
1006 CopLINE_set(PL_curcop, PL_copline);
1007 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1008 CopLINE_set(PL_curcop, oldline);
1015 Perl_scalar(pTHX_ OP *o)
1019 /* assumes no premature commitment */
1020 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1021 || o->op_type == OP_RETURN)
1026 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1028 switch (o->op_type) {
1030 scalar(cBINOPo->op_first);
1035 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1039 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1040 if (!kPMOP->op_pmreplroot)
1041 deprecate_old("implicit split to @_");
1049 if (o->op_flags & OPf_KIDS) {
1050 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1056 kid = cLISTOPo->op_first;
1058 while ((kid = kid->op_sibling)) {
1059 if (kid->op_sibling)
1064 WITH_THR(PL_curcop = &PL_compiling);
1069 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1070 if (kid->op_sibling)
1075 WITH_THR(PL_curcop = &PL_compiling);
1078 if (ckWARN(WARN_VOID))
1079 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1085 Perl_scalarvoid(pTHX_ OP *o)
1092 if (o->op_type == OP_NEXTSTATE
1093 || o->op_type == OP_SETSTATE
1094 || o->op_type == OP_DBSTATE
1095 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1096 || o->op_targ == OP_SETSTATE
1097 || o->op_targ == OP_DBSTATE)))
1098 PL_curcop = (COP*)o; /* for warning below */
1100 /* assumes no premature commitment */
1101 want = o->op_flags & OPf_WANT;
1102 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1103 || o->op_type == OP_RETURN)
1108 if ((o->op_private & OPpTARGET_MY)
1109 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1111 return scalar(o); /* As if inside SASSIGN */
1114 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1116 switch (o->op_type) {
1118 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1122 if (o->op_flags & OPf_STACKED)
1126 if (o->op_private == 4)
1168 case OP_GETSOCKNAME:
1169 case OP_GETPEERNAME:
1174 case OP_GETPRIORITY:
1197 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1198 useless = OP_DESC(o);
1205 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1206 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1207 useless = "a variable";
1212 if (cSVOPo->op_private & OPpCONST_STRICT)
1213 no_bareword_allowed(o);
1215 if (ckWARN(WARN_VOID)) {
1216 useless = "a constant";
1217 /* the constants 0 and 1 are permitted as they are
1218 conventionally used as dummies in constructs like
1219 1 while some_condition_with_side_effects; */
1220 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1222 else if (SvPOK(sv)) {
1223 /* perl4's way of mixing documentation and code
1224 (before the invention of POD) was based on a
1225 trick to mix nroff and perl code. The trick was
1226 built upon these three nroff macros being used in
1227 void context. The pink camel has the details in
1228 the script wrapman near page 319. */
1229 if (strnEQ(SvPVX(sv), "di", 2) ||
1230 strnEQ(SvPVX(sv), "ds", 2) ||
1231 strnEQ(SvPVX(sv), "ig", 2))
1236 op_null(o); /* don't execute or even remember it */
1240 o->op_type = OP_PREINC; /* pre-increment is faster */
1241 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1245 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1246 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1253 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1258 if (o->op_flags & OPf_STACKED)
1265 if (!(o->op_flags & OPf_KIDS))
1274 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1281 /* all requires must return a boolean value */
1282 o->op_flags &= ~OPf_WANT;
1287 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1288 if (!kPMOP->op_pmreplroot)
1289 deprecate_old("implicit split to @_");
1293 if (useless && ckWARN(WARN_VOID))
1294 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1299 Perl_listkids(pTHX_ OP *o)
1302 if (o && o->op_flags & OPf_KIDS) {
1303 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1310 Perl_list(pTHX_ OP *o)
1314 /* assumes no premature commitment */
1315 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1316 || o->op_type == OP_RETURN)
1321 if ((o->op_private & OPpTARGET_MY)
1322 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1324 return o; /* As if inside SASSIGN */
1327 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1329 switch (o->op_type) {
1332 list(cBINOPo->op_first);
1337 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1345 if (!(o->op_flags & OPf_KIDS))
1347 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1348 list(cBINOPo->op_first);
1349 return gen_constant_list(o);
1356 kid = cLISTOPo->op_first;
1358 while ((kid = kid->op_sibling)) {
1359 if (kid->op_sibling)
1364 WITH_THR(PL_curcop = &PL_compiling);
1368 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1369 if (kid->op_sibling)
1374 WITH_THR(PL_curcop = &PL_compiling);
1377 /* all requires must return a boolean value */
1378 o->op_flags &= ~OPf_WANT;
1385 Perl_scalarseq(pTHX_ OP *o)
1390 if (o->op_type == OP_LINESEQ ||
1391 o->op_type == OP_SCOPE ||
1392 o->op_type == OP_LEAVE ||
1393 o->op_type == OP_LEAVETRY)
1395 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1396 if (kid->op_sibling) {
1400 PL_curcop = &PL_compiling;
1402 o->op_flags &= ~OPf_PARENS;
1403 if (PL_hints & HINT_BLOCK_SCOPE)
1404 o->op_flags |= OPf_PARENS;
1407 o = newOP(OP_STUB, 0);
1412 S_modkids(pTHX_ OP *o, I32 type)
1415 if (o && o->op_flags & OPf_KIDS) {
1416 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1423 Perl_mod(pTHX_ OP *o, I32 type)
1428 if (!o || PL_error_count)
1431 if ((o->op_private & OPpTARGET_MY)
1432 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1437 switch (o->op_type) {
1442 if (!(o->op_private & (OPpCONST_ARYBASE)))
1444 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1445 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1449 SAVEI32(PL_compiling.cop_arybase);
1450 PL_compiling.cop_arybase = 0;
1452 else if (type == OP_REFGEN)
1455 Perl_croak(aTHX_ "That use of $[ is unsupported");
1458 if (o->op_flags & OPf_PARENS)
1462 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1463 !(o->op_flags & OPf_STACKED)) {
1464 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1465 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1466 assert(cUNOPo->op_first->op_type == OP_NULL);
1467 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1470 else if (o->op_private & OPpENTERSUB_NOMOD)
1472 else { /* lvalue subroutine call */
1473 o->op_private |= OPpLVAL_INTRO;
1474 PL_modcount = RETURN_UNLIMITED_NUMBER;
1475 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1476 /* Backward compatibility mode: */
1477 o->op_private |= OPpENTERSUB_INARGS;
1480 else { /* Compile-time error message: */
1481 OP *kid = cUNOPo->op_first;
1485 if (kid->op_type == OP_PUSHMARK)
1487 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1489 "panic: unexpected lvalue entersub "
1490 "args: type/targ %ld:%"UVuf,
1491 (long)kid->op_type, (UV)kid->op_targ);
1492 kid = kLISTOP->op_first;
1494 while (kid->op_sibling)
1495 kid = kid->op_sibling;
1496 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1498 if (kid->op_type == OP_METHOD_NAMED
1499 || kid->op_type == OP_METHOD)
1503 NewOp(1101, newop, 1, UNOP);
1504 newop->op_type = OP_RV2CV;
1505 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1506 newop->op_first = Nullop;
1507 newop->op_next = (OP*)newop;
1508 kid->op_sibling = (OP*)newop;
1509 newop->op_private |= OPpLVAL_INTRO;
1513 if (kid->op_type != OP_RV2CV)
1515 "panic: unexpected lvalue entersub "
1516 "entry via type/targ %ld:%"UVuf,
1517 (long)kid->op_type, (UV)kid->op_targ);
1518 kid->op_private |= OPpLVAL_INTRO;
1519 break; /* Postpone until runtime */
1523 kid = kUNOP->op_first;
1524 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1525 kid = kUNOP->op_first;
1526 if (kid->op_type == OP_NULL)
1528 "Unexpected constant lvalue entersub "
1529 "entry via type/targ %ld:%"UVuf,
1530 (long)kid->op_type, (UV)kid->op_targ);
1531 if (kid->op_type != OP_GV) {
1532 /* Restore RV2CV to check lvalueness */
1534 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1535 okid->op_next = kid->op_next;
1536 kid->op_next = okid;
1539 okid->op_next = Nullop;
1540 okid->op_type = OP_RV2CV;
1542 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1543 okid->op_private |= OPpLVAL_INTRO;
1547 cv = GvCV(kGVOP_gv);
1557 /* grep, foreach, subcalls, refgen */
1558 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1560 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1561 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1563 : (o->op_type == OP_ENTERSUB
1564 ? "non-lvalue subroutine call"
1566 type ? PL_op_desc[type] : "local"));
1580 case OP_RIGHT_SHIFT:
1589 if (!(o->op_flags & OPf_STACKED))
1595 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1601 if (!type && cUNOPo->op_first->op_type != OP_GV)
1602 Perl_croak(aTHX_ "Can't localize through a reference");
1603 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1604 PL_modcount = RETURN_UNLIMITED_NUMBER;
1605 return o; /* Treat \(@foo) like ordinary list. */
1609 if (scalar_mod_type(o, type))
1611 ref(cUNOPo->op_first, o->op_type);
1615 if (type == OP_LEAVESUBLV)
1616 o->op_private |= OPpMAYBE_LVSUB;
1621 PL_modcount = RETURN_UNLIMITED_NUMBER;
1624 if (!type && cUNOPo->op_first->op_type != OP_GV)
1625 Perl_croak(aTHX_ "Can't localize through a reference");
1626 ref(cUNOPo->op_first, o->op_type);
1630 PL_hints |= HINT_BLOCK_SCOPE;
1641 PL_modcount = RETURN_UNLIMITED_NUMBER;
1642 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1643 return o; /* Treat \(@foo) like ordinary list. */
1644 if (scalar_mod_type(o, type))
1646 if (type == OP_LEAVESUBLV)
1647 o->op_private |= OPpMAYBE_LVSUB;
1652 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1653 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1656 #ifdef USE_5005THREADS
1658 PL_modcount++; /* XXX ??? */
1660 #endif /* USE_5005THREADS */
1666 if (type != OP_SASSIGN)
1670 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1675 if (type == OP_LEAVESUBLV)
1676 o->op_private |= OPpMAYBE_LVSUB;
1678 pad_free(o->op_targ);
1679 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1680 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1681 if (o->op_flags & OPf_KIDS)
1682 mod(cBINOPo->op_first->op_sibling, type);
1687 ref(cBINOPo->op_first, o->op_type);
1688 if (type == OP_ENTERSUB &&
1689 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1690 o->op_private |= OPpLVAL_DEFER;
1691 if (type == OP_LEAVESUBLV)
1692 o->op_private |= OPpMAYBE_LVSUB;
1700 if (o->op_flags & OPf_KIDS)
1701 mod(cLISTOPo->op_last, type);
1705 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1707 else if (!(o->op_flags & OPf_KIDS))
1709 if (o->op_targ != OP_LIST) {
1710 mod(cBINOPo->op_first, type);
1715 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1720 if (type != OP_LEAVESUBLV)
1722 break; /* mod()ing was handled by ck_return() */
1725 /* [20011101.069] File test operators interpret OPf_REF to mean that
1726 their argument is a filehandle; thus \stat(".") should not set
1728 if (type == OP_REFGEN &&
1729 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1732 if (type != OP_LEAVESUBLV)
1733 o->op_flags |= OPf_MOD;
1735 if (type == OP_AASSIGN || type == OP_SASSIGN)
1736 o->op_flags |= OPf_SPECIAL|OPf_REF;
1738 o->op_private |= OPpLVAL_INTRO;
1739 o->op_flags &= ~OPf_SPECIAL;
1740 PL_hints |= HINT_BLOCK_SCOPE;
1742 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1743 && type != OP_LEAVESUBLV)
1744 o->op_flags |= OPf_REF;
1749 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1753 if (o->op_type == OP_RV2GV)
1777 case OP_RIGHT_SHIFT:
1796 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1798 switch (o->op_type) {
1806 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1819 Perl_refkids(pTHX_ OP *o, I32 type)
1822 if (o && o->op_flags & OPf_KIDS) {
1823 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1830 Perl_ref(pTHX_ OP *o, I32 type)
1834 if (!o || PL_error_count)
1837 switch (o->op_type) {
1839 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1840 !(o->op_flags & OPf_STACKED)) {
1841 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1842 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1843 assert(cUNOPo->op_first->op_type == OP_NULL);
1844 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1845 o->op_flags |= OPf_SPECIAL;
1850 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1854 if (type == OP_DEFINED)
1855 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1856 ref(cUNOPo->op_first, o->op_type);
1859 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1860 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1861 : type == OP_RV2HV ? OPpDEREF_HV
1863 o->op_flags |= OPf_MOD;
1868 o->op_flags |= OPf_MOD; /* XXX ??? */
1873 o->op_flags |= OPf_REF;
1876 if (type == OP_DEFINED)
1877 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1878 ref(cUNOPo->op_first, o->op_type);
1883 o->op_flags |= OPf_REF;
1888 if (!(o->op_flags & OPf_KIDS))
1890 ref(cBINOPo->op_first, type);
1894 ref(cBINOPo->op_first, o->op_type);
1895 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1896 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1897 : type == OP_RV2HV ? OPpDEREF_HV
1899 o->op_flags |= OPf_MOD;
1907 if (!(o->op_flags & OPf_KIDS))
1909 ref(cLISTOPo->op_last, type);
1919 S_dup_attrlist(pTHX_ OP *o)
1923 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1924 * where the first kid is OP_PUSHMARK and the remaining ones
1925 * are OP_CONST. We need to push the OP_CONST values.
1927 if (o->op_type == OP_CONST)
1928 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1930 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1931 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1932 if (o->op_type == OP_CONST)
1933 rop = append_elem(OP_LIST, rop,
1934 newSVOP(OP_CONST, o->op_flags,
1935 SvREFCNT_inc(cSVOPo->op_sv)));
1942 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1946 /* fake up C<use attributes $pkg,$rv,@attrs> */
1947 ENTER; /* need to protect against side-effects of 'use' */
1950 stashsv = newSVpv(HvNAME(stash), 0);
1952 stashsv = &PL_sv_no;
1954 #define ATTRSMODULE "attributes"
1955 #define ATTRSMODULE_PM "attributes.pm"
1959 /* Don't force the C<use> if we don't need it. */
1960 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1961 sizeof(ATTRSMODULE_PM)-1, 0);
1962 if (svp && *svp != &PL_sv_undef)
1963 ; /* already in %INC */
1965 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1966 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1970 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1971 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1973 prepend_elem(OP_LIST,
1974 newSVOP(OP_CONST, 0, stashsv),
1975 prepend_elem(OP_LIST,
1976 newSVOP(OP_CONST, 0,
1978 dup_attrlist(attrs))));
1984 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1986 OP *pack, *imop, *arg;
1992 assert(target->op_type == OP_PADSV ||
1993 target->op_type == OP_PADHV ||
1994 target->op_type == OP_PADAV);
1996 /* Ensure that attributes.pm is loaded. */
1997 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1999 /* Need package name for method call. */
2000 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
2002 /* Build up the real arg-list. */
2004 stashsv = newSVpv(HvNAME(stash), 0);
2006 stashsv = &PL_sv_no;
2007 arg = newOP(OP_PADSV, 0);
2008 arg->op_targ = target->op_targ;
2009 arg = prepend_elem(OP_LIST,
2010 newSVOP(OP_CONST, 0, stashsv),
2011 prepend_elem(OP_LIST,
2012 newUNOP(OP_REFGEN, 0,
2013 mod(arg, OP_REFGEN)),
2014 dup_attrlist(attrs)));
2016 /* Fake up a method call to import */
2017 meth = newSVpvn("import", 6);
2018 (void)SvUPGRADE(meth, SVt_PVIV);
2019 (void)SvIOK_on(meth);
2020 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2021 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2022 append_elem(OP_LIST,
2023 prepend_elem(OP_LIST, pack, list(arg)),
2024 newSVOP(OP_METHOD_NAMED, 0, meth)));
2025 imop->op_private |= OPpENTERSUB_NOMOD;
2027 /* Combine the ops. */
2028 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2032 =notfor apidoc apply_attrs_string
2034 Attempts to apply a list of attributes specified by the C<attrstr> and
2035 C<len> arguments to the subroutine identified by the C<cv> argument which
2036 is expected to be associated with the package identified by the C<stashpv>
2037 argument (see L<attributes>). It gets this wrong, though, in that it
2038 does not correctly identify the boundaries of the individual attribute
2039 specifications within C<attrstr>. This is not really intended for the
2040 public API, but has to be listed here for systems such as AIX which
2041 need an explicit export list for symbols. (It's called from XS code
2042 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2043 to respect attribute syntax properly would be welcome.
2049 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2050 char *attrstr, STRLEN len)
2055 len = strlen(attrstr);
2059 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2061 char *sstr = attrstr;
2062 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2063 attrs = append_elem(OP_LIST, attrs,
2064 newSVOP(OP_CONST, 0,
2065 newSVpvn(sstr, attrstr-sstr)));
2069 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2070 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2071 Nullsv, prepend_elem(OP_LIST,
2072 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2073 prepend_elem(OP_LIST,
2074 newSVOP(OP_CONST, 0,
2080 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2085 if (!o || PL_error_count)
2089 if (type == OP_LIST) {
2090 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2091 my_kid(kid, attrs, imopsp);
2092 } else if (type == OP_UNDEF) {
2094 } else if (type == OP_RV2SV || /* "our" declaration */
2096 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2097 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2098 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
2099 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
2101 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2103 PL_in_my_stash = Nullhv;
2104 apply_attrs(GvSTASH(gv),
2105 (type == OP_RV2SV ? GvSV(gv) :
2106 type == OP_RV2AV ? (SV*)GvAV(gv) :
2107 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2110 o->op_private |= OPpOUR_INTRO;
2113 else if (type != OP_PADSV &&
2116 type != OP_PUSHMARK)
2118 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2120 PL_in_my == KEY_our ? "our" : "my"));
2123 else if (attrs && type != OP_PUSHMARK) {
2128 PL_in_my_stash = Nullhv;
2130 /* check for C<my Dog $spot> when deciding package */
2131 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2132 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2133 stash = SvSTASH(*namesvp);
2135 stash = PL_curstash;
2136 apply_attrs_my(stash, o, attrs, imopsp);
2138 o->op_flags |= OPf_MOD;
2139 o->op_private |= OPpLVAL_INTRO;
2144 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2147 int maybe_scalar = 0;
2149 if (o->op_flags & OPf_PARENS)
2155 o = my_kid(o, attrs, &rops);
2157 if (maybe_scalar && o->op_type == OP_PADSV) {
2158 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2159 o->op_private |= OPpLVAL_INTRO;
2162 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2165 PL_in_my_stash = Nullhv;
2170 Perl_my(pTHX_ OP *o)
2172 return my_attrs(o, Nullop);
2176 Perl_sawparens(pTHX_ OP *o)
2179 o->op_flags |= OPf_PARENS;
2184 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2188 if (ckWARN(WARN_MISC) &&
2189 (left->op_type == OP_RV2AV ||
2190 left->op_type == OP_RV2HV ||
2191 left->op_type == OP_PADAV ||
2192 left->op_type == OP_PADHV)) {
2193 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2194 right->op_type == OP_TRANS)
2195 ? right->op_type : OP_MATCH];
2196 const char *sample = ((left->op_type == OP_RV2AV ||
2197 left->op_type == OP_PADAV)
2198 ? "@array" : "%hash");
2199 Perl_warner(aTHX_ packWARN(WARN_MISC),
2200 "Applying %s to %s will act on scalar(%s)",
2201 desc, sample, sample);
2204 if (right->op_type == OP_CONST &&
2205 cSVOPx(right)->op_private & OPpCONST_BARE &&
2206 cSVOPx(right)->op_private & OPpCONST_STRICT)
2208 no_bareword_allowed(right);
2211 if (!(right->op_flags & OPf_STACKED) &&
2212 (right->op_type == OP_MATCH ||
2213 right->op_type == OP_SUBST ||
2214 right->op_type == OP_TRANS)) {
2215 right->op_flags |= OPf_STACKED;
2216 if (right->op_type != OP_MATCH &&
2217 ! (right->op_type == OP_TRANS &&
2218 right->op_private & OPpTRANS_IDENTICAL))
2219 left = mod(left, right->op_type);
2220 if (right->op_type == OP_TRANS)
2221 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2223 o = prepend_elem(right->op_type, scalar(left), right);
2225 return newUNOP(OP_NOT, 0, scalar(o));
2229 return bind_match(type, left,
2230 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2234 Perl_invert(pTHX_ OP *o)
2238 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2239 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2243 Perl_scope(pTHX_ OP *o)
2246 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2247 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2248 o->op_type = OP_LEAVE;
2249 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2252 if (o->op_type == OP_LINESEQ) {
2254 o->op_type = OP_SCOPE;
2255 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2256 kid = ((LISTOP*)o)->op_first;
2257 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2261 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2268 Perl_save_hints(pTHX)
2271 SAVESPTR(GvHV(PL_hintgv));
2272 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2273 SAVEFREESV(GvHV(PL_hintgv));
2277 Perl_block_start(pTHX_ int full)
2279 int retval = PL_savestack_ix;
2281 SAVEI32(PL_comppad_name_floor);
2282 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2284 PL_comppad_name_fill = PL_comppad_name_floor;
2285 if (PL_comppad_name_floor < 0)
2286 PL_comppad_name_floor = 0;
2287 SAVEI32(PL_min_intro_pending);
2288 SAVEI32(PL_max_intro_pending);
2289 PL_min_intro_pending = 0;
2290 SAVEI32(PL_comppad_name_fill);
2291 SAVEI32(PL_padix_floor);
2292 PL_padix_floor = PL_padix;
2293 PL_pad_reset_pending = FALSE;
2295 PL_hints &= ~HINT_BLOCK_SCOPE;
2296 SAVESPTR(PL_compiling.cop_warnings);
2297 if (! specialWARN(PL_compiling.cop_warnings)) {
2298 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2299 SAVEFREESV(PL_compiling.cop_warnings) ;
2301 SAVESPTR(PL_compiling.cop_io);
2302 if (! specialCopIO(PL_compiling.cop_io)) {
2303 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2304 SAVEFREESV(PL_compiling.cop_io) ;
2310 Perl_block_end(pTHX_ I32 floor, OP *seq)
2312 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2313 line_t copline = PL_copline;
2314 /* there should be a nextstate in every block */
2315 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2316 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2318 PL_pad_reset_pending = FALSE;
2319 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2321 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2322 pad_leavemy(PL_comppad_name_fill);
2330 #ifdef USE_5005THREADS
2331 OP *o = newOP(OP_THREADSV, 0);
2332 o->op_targ = find_threadsv("_");
2335 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2336 #endif /* USE_5005THREADS */
2340 Perl_newPROG(pTHX_ OP *o)
2345 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2346 ((PL_in_eval & EVAL_KEEPERR)
2347 ? OPf_SPECIAL : 0), o);
2348 PL_eval_start = linklist(PL_eval_root);
2349 PL_eval_root->op_private |= OPpREFCOUNTED;
2350 OpREFCNT_set(PL_eval_root, 1);
2351 PL_eval_root->op_next = 0;
2352 CALL_PEEP(PL_eval_start);
2357 PL_main_root = scope(sawparens(scalarvoid(o)));
2358 PL_curcop = &PL_compiling;
2359 PL_main_start = LINKLIST(PL_main_root);
2360 PL_main_root->op_private |= OPpREFCOUNTED;
2361 OpREFCNT_set(PL_main_root, 1);
2362 PL_main_root->op_next = 0;
2363 CALL_PEEP(PL_main_start);
2366 /* Register with debugger */
2368 CV *cv = get_cv("DB::postponed", FALSE);
2372 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2374 call_sv((SV*)cv, G_DISCARD);
2381 Perl_localize(pTHX_ OP *o, I32 lex)
2383 if (o->op_flags & OPf_PARENS)
2386 if (ckWARN(WARN_PARENTHESIS)
2387 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2389 char *s = PL_bufptr;
2391 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2394 if (*s == ';' || *s == '=')
2395 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2396 "Parentheses missing around \"%s\" list",
2397 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2403 o = mod(o, OP_NULL); /* a bit kludgey */
2405 PL_in_my_stash = Nullhv;
2410 Perl_jmaybe(pTHX_ OP *o)
2412 if (o->op_type == OP_LIST) {
2414 #ifdef USE_5005THREADS
2415 o2 = newOP(OP_THREADSV, 0);
2416 o2->op_targ = find_threadsv(";");
2418 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2419 #endif /* USE_5005THREADS */
2420 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2426 Perl_fold_constants(pTHX_ register OP *o)
2429 I32 type = o->op_type;
2432 if (PL_opargs[type] & OA_RETSCALAR)
2434 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2435 o->op_targ = pad_alloc(type, SVs_PADTMP);
2437 /* integerize op, unless it happens to be C<-foo>.
2438 * XXX should pp_i_negate() do magic string negation instead? */
2439 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2440 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2441 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2443 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2446 if (!(PL_opargs[type] & OA_FOLDCONST))
2451 /* XXX might want a ck_negate() for this */
2452 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2464 /* XXX what about the numeric ops? */
2465 if (PL_hints & HINT_LOCALE)
2470 goto nope; /* Don't try to run w/ errors */
2472 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2473 if ((curop->op_type != OP_CONST ||
2474 (curop->op_private & OPpCONST_BARE)) &&
2475 curop->op_type != OP_LIST &&
2476 curop->op_type != OP_SCALAR &&
2477 curop->op_type != OP_NULL &&
2478 curop->op_type != OP_PUSHMARK)
2484 curop = LINKLIST(o);
2488 sv = *(PL_stack_sp--);
2489 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2490 pad_swipe(o->op_targ);
2491 else if (SvTEMP(sv)) { /* grab mortal temp? */
2492 (void)SvREFCNT_inc(sv);
2496 if (type == OP_RV2GV)
2497 return newGVOP(OP_GV, 0, (GV*)sv);
2499 /* try to smush double to int, but don't smush -2.0 to -2 */
2500 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2503 #ifdef PERL_PRESERVE_IVUV
2504 /* Only bother to attempt to fold to IV if
2505 most operators will benefit */
2509 return newSVOP(OP_CONST, 0, sv);
2517 Perl_gen_constant_list(pTHX_ register OP *o)
2520 I32 oldtmps_floor = PL_tmps_floor;
2524 return o; /* Don't attempt to run with errors */
2526 PL_op = curop = LINKLIST(o);
2533 PL_tmps_floor = oldtmps_floor;
2535 o->op_type = OP_RV2AV;
2536 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2537 o->op_seq = 0; /* needs to be revisited in peep() */
2538 curop = ((UNOP*)o)->op_first;
2539 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2546 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2548 if (!o || o->op_type != OP_LIST)
2549 o = newLISTOP(OP_LIST, 0, o, Nullop);
2551 o->op_flags &= ~OPf_WANT;
2553 if (!(PL_opargs[type] & OA_MARK))
2554 op_null(cLISTOPo->op_first);
2556 o->op_type = (OPCODE)type;
2557 o->op_ppaddr = PL_ppaddr[type];
2558 o->op_flags |= flags;
2560 o = CHECKOP(type, o);
2561 if (o->op_type != type)
2564 return fold_constants(o);
2567 /* List constructors */
2570 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2578 if (first->op_type != type
2579 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2581 return newLISTOP(type, 0, first, last);
2584 if (first->op_flags & OPf_KIDS)
2585 ((LISTOP*)first)->op_last->op_sibling = last;
2587 first->op_flags |= OPf_KIDS;
2588 ((LISTOP*)first)->op_first = last;
2590 ((LISTOP*)first)->op_last = last;
2595 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2603 if (first->op_type != type)
2604 return prepend_elem(type, (OP*)first, (OP*)last);
2606 if (last->op_type != type)
2607 return append_elem(type, (OP*)first, (OP*)last);
2609 first->op_last->op_sibling = last->op_first;
2610 first->op_last = last->op_last;
2611 first->op_flags |= (last->op_flags & OPf_KIDS);
2619 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2627 if (last->op_type == type) {
2628 if (type == OP_LIST) { /* already a PUSHMARK there */
2629 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2630 ((LISTOP*)last)->op_first->op_sibling = first;
2631 if (!(first->op_flags & OPf_PARENS))
2632 last->op_flags &= ~OPf_PARENS;
2635 if (!(last->op_flags & OPf_KIDS)) {
2636 ((LISTOP*)last)->op_last = first;
2637 last->op_flags |= OPf_KIDS;
2639 first->op_sibling = ((LISTOP*)last)->op_first;
2640 ((LISTOP*)last)->op_first = first;
2642 last->op_flags |= OPf_KIDS;
2646 return newLISTOP(type, 0, first, last);
2652 Perl_newNULLLIST(pTHX)
2654 return newOP(OP_STUB, 0);
2658 Perl_force_list(pTHX_ OP *o)
2660 if (!o || o->op_type != OP_LIST)
2661 o = newLISTOP(OP_LIST, 0, o, Nullop);
2667 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2671 NewOp(1101, listop, 1, LISTOP);
2673 listop->op_type = (OPCODE)type;
2674 listop->op_ppaddr = PL_ppaddr[type];
2677 listop->op_flags = (U8)flags;
2681 else if (!first && last)
2684 first->op_sibling = last;
2685 listop->op_first = first;
2686 listop->op_last = last;
2687 if (type == OP_LIST) {
2689 pushop = newOP(OP_PUSHMARK, 0);
2690 pushop->op_sibling = first;
2691 listop->op_first = pushop;
2692 listop->op_flags |= OPf_KIDS;
2694 listop->op_last = pushop;
2701 Perl_newOP(pTHX_ I32 type, I32 flags)
2704 NewOp(1101, o, 1, OP);
2705 o->op_type = (OPCODE)type;
2706 o->op_ppaddr = PL_ppaddr[type];
2707 o->op_flags = (U8)flags;
2710 o->op_private = (U8)(0 | (flags >> 8));
2711 if (PL_opargs[type] & OA_RETSCALAR)
2713 if (PL_opargs[type] & OA_TARGET)
2714 o->op_targ = pad_alloc(type, SVs_PADTMP);
2715 return CHECKOP(type, o);
2719 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2724 first = newOP(OP_STUB, 0);
2725 if (PL_opargs[type] & OA_MARK)
2726 first = force_list(first);
2728 NewOp(1101, unop, 1, UNOP);
2729 unop->op_type = (OPCODE)type;
2730 unop->op_ppaddr = PL_ppaddr[type];
2731 unop->op_first = first;
2732 unop->op_flags = flags | OPf_KIDS;
2733 unop->op_private = (U8)(1 | (flags >> 8));
2734 unop = (UNOP*) CHECKOP(type, unop);
2738 return fold_constants((OP *) unop);
2742 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2745 NewOp(1101, binop, 1, BINOP);
2748 first = newOP(OP_NULL, 0);
2750 binop->op_type = (OPCODE)type;
2751 binop->op_ppaddr = PL_ppaddr[type];
2752 binop->op_first = first;
2753 binop->op_flags = flags | OPf_KIDS;
2756 binop->op_private = (U8)(1 | (flags >> 8));
2759 binop->op_private = (U8)(2 | (flags >> 8));
2760 first->op_sibling = last;
2763 binop = (BINOP*)CHECKOP(type, binop);
2764 if (binop->op_next || binop->op_type != (OPCODE)type)
2767 binop->op_last = binop->op_first->op_sibling;
2769 return fold_constants((OP *)binop);
2773 uvcompare(const void *a, const void *b)
2775 if (*((UV *)a) < (*(UV *)b))
2777 if (*((UV *)a) > (*(UV *)b))
2779 if (*((UV *)a+1) < (*(UV *)b+1))
2781 if (*((UV *)a+1) > (*(UV *)b+1))
2787 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2789 SV *tstr = ((SVOP*)expr)->op_sv;
2790 SV *rstr = ((SVOP*)repl)->op_sv;
2793 U8 *t = (U8*)SvPV(tstr, tlen);
2794 U8 *r = (U8*)SvPV(rstr, rlen);
2801 register short *tbl;
2803 PL_hints |= HINT_BLOCK_SCOPE;
2804 complement = o->op_private & OPpTRANS_COMPLEMENT;
2805 del = o->op_private & OPpTRANS_DELETE;
2806 squash = o->op_private & OPpTRANS_SQUASH;
2809 o->op_private |= OPpTRANS_FROM_UTF;
2812 o->op_private |= OPpTRANS_TO_UTF;
2814 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2815 SV* listsv = newSVpvn("# comment\n",10);
2817 U8* tend = t + tlen;
2818 U8* rend = r + rlen;
2832 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2833 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2839 tsave = t = bytes_to_utf8(t, &len);
2842 if (!to_utf && rlen) {
2844 rsave = r = bytes_to_utf8(r, &len);
2848 /* There are several snags with this code on EBCDIC:
2849 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2850 2. scan_const() in toke.c has encoded chars in native encoding which makes
2851 ranges at least in EBCDIC 0..255 range the bottom odd.
2855 U8 tmpbuf[UTF8_MAXLEN+1];
2858 New(1109, cp, 2*tlen, UV);
2860 transv = newSVpvn("",0);
2862 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2864 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2866 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2870 cp[2*i+1] = cp[2*i];
2874 qsort(cp, i, 2*sizeof(UV), uvcompare);
2875 for (j = 0; j < i; j++) {
2877 diff = val - nextmin;
2879 t = uvuni_to_utf8(tmpbuf,nextmin);
2880 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2882 U8 range_mark = UTF_TO_NATIVE(0xff);
2883 t = uvuni_to_utf8(tmpbuf, val - 1);
2884 sv_catpvn(transv, (char *)&range_mark, 1);
2885 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2892 t = uvuni_to_utf8(tmpbuf,nextmin);
2893 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2895 U8 range_mark = UTF_TO_NATIVE(0xff);
2896 sv_catpvn(transv, (char *)&range_mark, 1);
2898 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2899 UNICODE_ALLOW_SUPER);
2900 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2901 t = (U8*)SvPVX(transv);
2902 tlen = SvCUR(transv);
2906 else if (!rlen && !del) {
2907 r = t; rlen = tlen; rend = tend;
2910 if ((!rlen && !del) || t == r ||
2911 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2913 o->op_private |= OPpTRANS_IDENTICAL;
2917 while (t < tend || tfirst <= tlast) {
2918 /* see if we need more "t" chars */
2919 if (tfirst > tlast) {
2920 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2922 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2924 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2931 /* now see if we need more "r" chars */
2932 if (rfirst > rlast) {
2934 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2936 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2938 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2947 rfirst = rlast = 0xffffffff;
2951 /* now see which range will peter our first, if either. */
2952 tdiff = tlast - tfirst;
2953 rdiff = rlast - rfirst;
2960 if (rfirst == 0xffffffff) {
2961 diff = tdiff; /* oops, pretend rdiff is infinite */
2963 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2964 (long)tfirst, (long)tlast);
2966 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2970 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2971 (long)tfirst, (long)(tfirst + diff),
2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2975 (long)tfirst, (long)rfirst);
2977 if (rfirst + diff > max)
2978 max = rfirst + diff;
2980 grows = (tfirst < rfirst &&
2981 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2993 else if (max > 0xff)
2998 Safefree(cPVOPo->op_pv);
2999 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3000 SvREFCNT_dec(listsv);
3002 SvREFCNT_dec(transv);
3004 if (!del && havefinal && rlen)
3005 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3006 newSVuv((UV)final), 0);
3009 o->op_private |= OPpTRANS_GROWS;
3021 tbl = (short*)cPVOPo->op_pv;
3023 Zero(tbl, 256, short);
3024 for (i = 0; i < (I32)tlen; i++)
3026 for (i = 0, j = 0; i < 256; i++) {
3028 if (j >= (I32)rlen) {
3037 if (i < 128 && r[j] >= 128)
3047 o->op_private |= OPpTRANS_IDENTICAL;
3049 else if (j >= (I32)rlen)
3052 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3053 tbl[0x100] = rlen - j;
3054 for (i=0; i < (I32)rlen - j; i++)
3055 tbl[0x101+i] = r[j+i];
3059 if (!rlen && !del) {
3062 o->op_private |= OPpTRANS_IDENTICAL;
3064 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3065 o->op_private |= OPpTRANS_IDENTICAL;
3067 for (i = 0; i < 256; i++)
3069 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3070 if (j >= (I32)rlen) {
3072 if (tbl[t[i]] == -1)
3078 if (tbl[t[i]] == -1) {
3079 if (t[i] < 128 && r[j] >= 128)
3086 o->op_private |= OPpTRANS_GROWS;
3094 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3098 NewOp(1101, pmop, 1, PMOP);
3099 pmop->op_type = (OPCODE)type;
3100 pmop->op_ppaddr = PL_ppaddr[type];
3101 pmop->op_flags = (U8)flags;
3102 pmop->op_private = (U8)(0 | (flags >> 8));
3104 if (PL_hints & HINT_RE_TAINT)
3105 pmop->op_pmpermflags |= PMf_RETAINT;
3106 if (PL_hints & HINT_LOCALE)
3107 pmop->op_pmpermflags |= PMf_LOCALE;
3108 pmop->op_pmflags = pmop->op_pmpermflags;
3113 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3114 repointer = av_pop((AV*)PL_regex_pad[0]);
3115 pmop->op_pmoffset = SvIV(repointer);
3116 SvREPADTMP_off(repointer);
3117 sv_setiv(repointer,0);
3119 repointer = newSViv(0);
3120 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3121 pmop->op_pmoffset = av_len(PL_regex_padav);
3122 PL_regex_pad = AvARRAY(PL_regex_padav);
3127 /* link into pm list */
3128 if (type != OP_TRANS && PL_curstash) {
3129 pmop->op_pmnext = HvPMROOT(PL_curstash);
3130 HvPMROOT(PL_curstash) = pmop;
3131 PmopSTASH_set(pmop,PL_curstash);
3138 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3142 I32 repl_has_vars = 0;
3144 if (o->op_type == OP_TRANS)
3145 return pmtrans(o, expr, repl);
3147 PL_hints |= HINT_BLOCK_SCOPE;
3150 if (expr->op_type == OP_CONST) {
3152 SV *pat = ((SVOP*)expr)->op_sv;
3153 char *p = SvPV(pat, plen);
3154 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3155 sv_setpvn(pat, "\\s+", 3);
3156 p = SvPV(pat, plen);
3157 pm->op_pmflags |= PMf_SKIPWHITE;
3160 pm->op_pmdynflags |= PMdf_UTF8;
3161 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3162 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3163 pm->op_pmflags |= PMf_WHITE;
3167 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3168 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3170 : OP_REGCMAYBE),0,expr);
3172 NewOp(1101, rcop, 1, LOGOP);
3173 rcop->op_type = OP_REGCOMP;
3174 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3175 rcop->op_first = scalar(expr);
3176 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3177 ? (OPf_SPECIAL | OPf_KIDS)
3179 rcop->op_private = 1;
3182 /* establish postfix order */
3183 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3185 rcop->op_next = expr;
3186 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3189 rcop->op_next = LINKLIST(expr);
3190 expr->op_next = (OP*)rcop;
3193 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3198 if (pm->op_pmflags & PMf_EVAL) {
3200 if (CopLINE(PL_curcop) < PL_multi_end)
3201 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3203 #ifdef USE_5005THREADS
3204 else if (repl->op_type == OP_THREADSV
3205 && strchr("&`'123456789+",
3206 PL_threadsv_names[repl->op_targ]))
3210 #endif /* USE_5005THREADS */
3211 else if (repl->op_type == OP_CONST)
3215 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3216 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3217 #ifdef USE_5005THREADS
3218 if (curop->op_type == OP_THREADSV) {
3220 if (strchr("&`'123456789+", curop->op_private))
3224 if (curop->op_type == OP_GV) {
3225 GV *gv = cGVOPx_gv(curop);
3227 if (strchr("&`'123456789+", *GvENAME(gv)))
3230 #endif /* USE_5005THREADS */
3231 else if (curop->op_type == OP_RV2CV)
3233 else if (curop->op_type == OP_RV2SV ||
3234 curop->op_type == OP_RV2AV ||
3235 curop->op_type == OP_RV2HV ||
3236 curop->op_type == OP_RV2GV) {
3237 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3240 else if (curop->op_type == OP_PADSV ||
3241 curop->op_type == OP_PADAV ||
3242 curop->op_type == OP_PADHV ||
3243 curop->op_type == OP_PADANY) {
3246 else if (curop->op_type == OP_PUSHRE)
3247 ; /* Okay here, dangerous in newASSIGNOP */
3257 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3258 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3259 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3260 prepend_elem(o->op_type, scalar(repl), o);
3263 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3264 pm->op_pmflags |= PMf_MAYBE_CONST;
3265 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3267 NewOp(1101, rcop, 1, LOGOP);
3268 rcop->op_type = OP_SUBSTCONT;
3269 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3270 rcop->op_first = scalar(repl);
3271 rcop->op_flags |= OPf_KIDS;
3272 rcop->op_private = 1;
3275 /* establish postfix order */
3276 rcop->op_next = LINKLIST(repl);
3277 repl->op_next = (OP*)rcop;
3279 pm->op_pmreplroot = scalar((OP*)rcop);
3280 pm->op_pmreplstart = LINKLIST(rcop);
3289 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3292 NewOp(1101, svop, 1, SVOP);
3293 svop->op_type = (OPCODE)type;
3294 svop->op_ppaddr = PL_ppaddr[type];
3296 svop->op_next = (OP*)svop;
3297 svop->op_flags = (U8)flags;
3298 if (PL_opargs[type] & OA_RETSCALAR)
3300 if (PL_opargs[type] & OA_TARGET)
3301 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3302 return CHECKOP(type, svop);
3306 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3309 NewOp(1101, padop, 1, PADOP);
3310 padop->op_type = (OPCODE)type;
3311 padop->op_ppaddr = PL_ppaddr[type];
3312 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3313 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3314 PL_curpad[padop->op_padix] = sv;
3316 padop->op_next = (OP*)padop;
3317 padop->op_flags = (U8)flags;
3318 if (PL_opargs[type] & OA_RETSCALAR)
3320 if (PL_opargs[type] & OA_TARGET)
3321 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3322 return CHECKOP(type, padop);
3326 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3330 return newPADOP(type, flags, SvREFCNT_inc(gv));
3332 return newSVOP(type, flags, SvREFCNT_inc(gv));
3337 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3340 NewOp(1101, pvop, 1, PVOP);
3341 pvop->op_type = (OPCODE)type;
3342 pvop->op_ppaddr = PL_ppaddr[type];
3344 pvop->op_next = (OP*)pvop;
3345 pvop->op_flags = (U8)flags;
3346 if (PL_opargs[type] & OA_RETSCALAR)
3348 if (PL_opargs[type] & OA_TARGET)
3349 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3350 return CHECKOP(type, pvop);
3354 Perl_package(pTHX_ OP *o)
3358 save_hptr(&PL_curstash);
3359 save_item(PL_curstname);
3364 name = SvPV(sv, len);
3365 PL_curstash = gv_stashpvn(name,len,TRUE);
3366 sv_setpvn(PL_curstname, name, len);
3370 deprecate("\"package\" with no arguments");
3371 sv_setpv(PL_curstname,"<none>");
3372 PL_curstash = Nullhv;
3374 PL_hints |= HINT_BLOCK_SCOPE;
3375 PL_copline = NOLINE;
3380 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3386 if (id->op_type != OP_CONST)
3387 Perl_croak(aTHX_ "Module name must be constant");
3391 if (version != Nullop) {
3392 SV *vesv = ((SVOP*)version)->op_sv;
3394 if (arg == Nullop && !SvNIOKp(vesv)) {
3401 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3402 Perl_croak(aTHX_ "Version number must be constant number");
3404 /* Make copy of id so we don't free it twice */
3405 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3407 /* Fake up a method call to VERSION */
3408 meth = newSVpvn("VERSION",7);
3409 sv_upgrade(meth, SVt_PVIV);
3410 (void)SvIOK_on(meth);
3411 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3412 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3413 append_elem(OP_LIST,
3414 prepend_elem(OP_LIST, pack, list(version)),
3415 newSVOP(OP_METHOD_NAMED, 0, meth)));
3419 /* Fake up an import/unimport */
3420 if (arg && arg->op_type == OP_STUB)
3421 imop = arg; /* no import on explicit () */
3422 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3423 imop = Nullop; /* use 5.0; */
3428 /* Make copy of id so we don't free it twice */
3429 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3431 /* Fake up a method call to import/unimport */
3432 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3433 (void)SvUPGRADE(meth, SVt_PVIV);
3434 (void)SvIOK_on(meth);
3435 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3436 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3437 append_elem(OP_LIST,
3438 prepend_elem(OP_LIST, pack, list(arg)),
3439 newSVOP(OP_METHOD_NAMED, 0, meth)));
3442 /* Fake up the BEGIN {}, which does its thing immediately. */
3444 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3447 append_elem(OP_LINESEQ,
3448 append_elem(OP_LINESEQ,
3449 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3450 newSTATEOP(0, Nullch, veop)),
3451 newSTATEOP(0, Nullch, imop) ));
3453 /* The "did you use incorrect case?" warning used to be here.
3454 * The problem is that on case-insensitive filesystems one
3455 * might get false positives for "use" (and "require"):
3456 * "use Strict" or "require CARP" will work. This causes
3457 * portability problems for the script: in case-strict
3458 * filesystems the script will stop working.
3460 * The "incorrect case" warning checked whether "use Foo"
3461 * imported "Foo" to your namespace, but that is wrong, too:
3462 * there is no requirement nor promise in the language that
3463 * a Foo.pm should or would contain anything in package "Foo".
3465 * There is very little Configure-wise that can be done, either:
3466 * the case-sensitivity of the build filesystem of Perl does not
3467 * help in guessing the case-sensitivity of the runtime environment.
3470 PL_hints |= HINT_BLOCK_SCOPE;
3471 PL_copline = NOLINE;
3476 =head1 Embedding Functions
3478 =for apidoc load_module
3480 Loads the module whose name is pointed to by the string part of name.
3481 Note that the actual module name, not its filename, should be given.
3482 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3483 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3484 (or 0 for no flags). ver, if specified, provides version semantics
3485 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3486 arguments can be used to specify arguments to the module's import()
3487 method, similar to C<use Foo::Bar VERSION LIST>.
3492 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3495 va_start(args, ver);
3496 vload_module(flags, name, ver, &args);
3500 #ifdef PERL_IMPLICIT_CONTEXT
3502 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3506 va_start(args, ver);
3507 vload_module(flags, name, ver, &args);
3513 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3515 OP *modname, *veop, *imop;
3517 modname = newSVOP(OP_CONST, 0, name);
3518 modname->op_private |= OPpCONST_BARE;
3520 veop = newSVOP(OP_CONST, 0, ver);
3524 if (flags & PERL_LOADMOD_NOIMPORT) {
3525 imop = sawparens(newNULLLIST());
3527 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3528 imop = va_arg(*args, OP*);
3533 sv = va_arg(*args, SV*);
3535 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3536 sv = va_arg(*args, SV*);
3540 line_t ocopline = PL_copline;
3541 int oexpect = PL_expect;
3543 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3544 veop, modname, imop);
3545 PL_expect = oexpect;
3546 PL_copline = ocopline;
3551 Perl_dofile(pTHX_ OP *term)
3556 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3557 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3558 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3560 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3561 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3562 append_elem(OP_LIST, term,
3563 scalar(newUNOP(OP_RV2CV, 0,
3568 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3574 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3576 return newBINOP(OP_LSLICE, flags,
3577 list(force_list(subscript)),
3578 list(force_list(listval)) );
3582 S_list_assignment(pTHX_ register OP *o)
3587 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3588 o = cUNOPo->op_first;
3590 if (o->op_type == OP_COND_EXPR) {
3591 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3592 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3597 yyerror("Assignment to both a list and a scalar");
3601 if (o->op_type == OP_LIST &&
3602 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3603 o->op_private & OPpLVAL_INTRO)
3606 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3607 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3608 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3611 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3614 if (o->op_type == OP_RV2SV)
3621 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3626 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3627 return newLOGOP(optype, 0,
3628 mod(scalar(left), optype),
3629 newUNOP(OP_SASSIGN, 0, scalar(right)));
3632 return newBINOP(optype, OPf_STACKED,
3633 mod(scalar(left), optype), scalar(right));
3637 if (list_assignment(left)) {
3641 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3642 left = mod(left, OP_AASSIGN);
3650 curop = list(force_list(left));
3651 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3652 o->op_private = (U8)(0 | (flags >> 8));
3653 if (!(left->op_private & OPpLVAL_INTRO)) {
3656 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3657 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3658 if (curop->op_type == OP_GV) {
3659 GV *gv = cGVOPx_gv(curop);
3660 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3662 SvCUR(gv) = PL_generation;
3664 else if (curop->op_type == OP_PADSV ||
3665 curop->op_type == OP_PADAV ||
3666 curop->op_type == OP_PADHV ||
3667 curop->op_type == OP_PADANY) {
3668 SV **svp = AvARRAY(PL_comppad_name);
3669 SV *sv = svp[curop->op_targ];
3670 if ((int)SvCUR(sv) == PL_generation)
3672 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3674 else if (curop->op_type == OP_RV2CV)
3676 else if (curop->op_type == OP_RV2SV ||
3677 curop->op_type == OP_RV2AV ||
3678 curop->op_type == OP_RV2HV ||
3679 curop->op_type == OP_RV2GV) {
3680 if (lastop->op_type != OP_GV) /* funny deref? */
3683 else if (curop->op_type == OP_PUSHRE) {
3684 if (((PMOP*)curop)->op_pmreplroot) {
3686 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3688 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3690 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3692 SvCUR(gv) = PL_generation;
3701 o->op_private |= OPpASSIGN_COMMON;
3703 if (right && right->op_type == OP_SPLIT) {
3705 if ((tmpop = ((LISTOP*)right)->op_first) &&
3706 tmpop->op_type == OP_PUSHRE)
3708 PMOP *pm = (PMOP*)tmpop;
3709 if (left->op_type == OP_RV2AV &&
3710 !(left->op_private & OPpLVAL_INTRO) &&
3711 !(o->op_private & OPpASSIGN_COMMON) )
3713 tmpop = ((UNOP*)left)->op_first;
3714 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3716 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3717 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3719 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3720 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3722 pm->op_pmflags |= PMf_ONCE;
3723 tmpop = cUNOPo->op_first; /* to list (nulled) */
3724 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3725 tmpop->op_sibling = Nullop; /* don't free split */
3726 right->op_next = tmpop->op_next; /* fix starting loc */
3727 op_free(o); /* blow off assign */
3728 right->op_flags &= ~OPf_WANT;
3729 /* "I don't know and I don't care." */
3734 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3735 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3737 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3739 sv_setiv(sv, PL_modcount+1);
3747 right = newOP(OP_UNDEF, 0);
3748 if (right->op_type == OP_READLINE) {
3749 right->op_flags |= OPf_STACKED;
3750 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3753 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3754 o = newBINOP(OP_SASSIGN, flags,
3755 scalar(right), mod(scalar(left), OP_SASSIGN) );
3767 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3769 U32 seq = intro_my();
3772 NewOp(1101, cop, 1, COP);
3773 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3774 cop->op_type = OP_DBSTATE;
3775 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3778 cop->op_type = OP_NEXTSTATE;
3779 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3781 cop->op_flags = (U8)flags;
3782 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3784 cop->op_private |= NATIVE_HINTS;
3786 PL_compiling.op_private = cop->op_private;
3787 cop->op_next = (OP*)cop;
3790 cop->cop_label = label;
3791 PL_hints |= HINT_BLOCK_SCOPE;
3794 cop->cop_arybase = PL_curcop->cop_arybase;
3795 if (specialWARN(PL_curcop->cop_warnings))
3796 cop->cop_warnings = PL_curcop->cop_warnings ;
3798 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3799 if (specialCopIO(PL_curcop->cop_io))
3800 cop->cop_io = PL_curcop->cop_io;
3802 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3805 if (PL_copline == NOLINE)
3806 CopLINE_set(cop, CopLINE(PL_curcop));
3808 CopLINE_set(cop, PL_copline);
3809 PL_copline = NOLINE;
3812 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3814 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3816 CopSTASH_set(cop, PL_curstash);
3818 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3819 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3820 if (svp && *svp != &PL_sv_undef ) {
3821 (void)SvIOK_on(*svp);
3822 SvIVX(*svp) = PTR2IV(cop);
3826 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3829 /* "Introduce" my variables to visible status. */
3837 if (! PL_min_intro_pending)
3838 return PL_cop_seqmax;
3840 svp = AvARRAY(PL_comppad_name);
3841 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3842 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3843 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3844 SvNVX(sv) = (NV)PL_cop_seqmax;
3847 PL_min_intro_pending = 0;
3848 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3849 return PL_cop_seqmax++;
3853 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3855 return new_logop(type, flags, &first, &other);
3859 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3863 OP *first = *firstp;
3864 OP *other = *otherp;
3866 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3867 return newBINOP(type, flags, scalar(first), scalar(other));
3869 scalarboolean(first);
3870 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3871 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3872 if (type == OP_AND || type == OP_OR) {
3878 first = *firstp = cUNOPo->op_first;
3880 first->op_next = o->op_next;
3881 cUNOPo->op_first = Nullop;
3885 if (first->op_type == OP_CONST) {
3886 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3887 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3888 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3899 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3900 OP *k1 = ((UNOP*)first)->op_first;
3901 OP *k2 = k1->op_sibling;
3903 switch (first->op_type)
3906 if (k2 && k2->op_type == OP_READLINE
3907 && (k2->op_flags & OPf_STACKED)
3908 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3910 warnop = k2->op_type;
3915 if (k1->op_type == OP_READDIR
3916 || k1->op_type == OP_GLOB
3917 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3918 || k1->op_type == OP_EACH)
3920 warnop = ((k1->op_type == OP_NULL)
3921 ? (OPCODE)k1->op_targ : k1->op_type);
3926 line_t oldline = CopLINE(PL_curcop);
3927 CopLINE_set(PL_curcop, PL_copline);
3928 Perl_warner(aTHX_ packWARN(WARN_MISC),
3929 "Value of %s%s can be \"0\"; test with defined()",
3931 ((warnop == OP_READLINE || warnop == OP_GLOB)
3932 ? " construct" : "() operator"));
3933 CopLINE_set(PL_curcop, oldline);
3940 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3941 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3943 NewOp(1101, logop, 1, LOGOP);
3945 logop->op_type = (OPCODE)type;
3946 logop->op_ppaddr = PL_ppaddr[type];
3947 logop->op_first = first;
3948 logop->op_flags = flags | OPf_KIDS;
3949 logop->op_other = LINKLIST(other);
3950 logop->op_private = (U8)(1 | (flags >> 8));
3952 /* establish postfix order */
3953 logop->op_next = LINKLIST(first);
3954 first->op_next = (OP*)logop;
3955 first->op_sibling = other;
3957 o = newUNOP(OP_NULL, 0, (OP*)logop);
3964 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3971 return newLOGOP(OP_AND, 0, first, trueop);
3973 return newLOGOP(OP_OR, 0, first, falseop);
3975 scalarboolean(first);
3976 if (first->op_type == OP_CONST) {
3977 if (first->op_private & OPpCONST_BARE &&
3978 first->op_private & OPpCONST_STRICT) {
3979 no_bareword_allowed(first);
3981 if (SvTRUE(((SVOP*)first)->op_sv)) {
3992 NewOp(1101, logop, 1, LOGOP);
3993 logop->op_type = OP_COND_EXPR;
3994 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3995 logop->op_first = first;
3996 logop->op_flags = flags | OPf_KIDS;
3997 logop->op_private = (U8)(1 | (flags >> 8));
3998 logop->op_other = LINKLIST(trueop);
3999 logop->op_next = LINKLIST(falseop);
4002 /* establish postfix order */
4003 start = LINKLIST(first);
4004 first->op_next = (OP*)logop;
4006 first->op_sibling = trueop;
4007 trueop->op_sibling = falseop;
4008 o = newUNOP(OP_NULL, 0, (OP*)logop);
4010 trueop->op_next = falseop->op_next = o;
4017 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4025 NewOp(1101, range, 1, LOGOP);
4027 range->op_type = OP_RANGE;
4028 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4029 range->op_first = left;
4030 range->op_flags = OPf_KIDS;
4031 leftstart = LINKLIST(left);
4032 range->op_other = LINKLIST(right);
4033 range->op_private = (U8)(1 | (flags >> 8));
4035 left->op_sibling = right;
4037 range->op_next = (OP*)range;
4038 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4039 flop = newUNOP(OP_FLOP, 0, flip);
4040 o = newUNOP(OP_NULL, 0, flop);
4042 range->op_next = leftstart;
4044 left->op_next = flip;
4045 right->op_next = flop;
4047 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4048 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4049 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4050 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4052 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4053 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4056 if (!flip->op_private || !flop->op_private)
4057 linklist(o); /* blow off optimizer unless constant */
4063 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4067 int once = block && block->op_flags & OPf_SPECIAL &&
4068 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4071 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4072 return block; /* do {} while 0 does once */
4073 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4074 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4075 expr = newUNOP(OP_DEFINED, 0,
4076 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4077 } else if (expr->op_flags & OPf_KIDS) {
4078 OP *k1 = ((UNOP*)expr)->op_first;
4079 OP *k2 = (k1) ? k1->op_sibling : NULL;
4080 switch (expr->op_type) {
4082 if (k2 && k2->op_type == OP_READLINE
4083 && (k2->op_flags & OPf_STACKED)
4084 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4085 expr = newUNOP(OP_DEFINED, 0, expr);
4089 if (k1->op_type == OP_READDIR
4090 || k1->op_type == OP_GLOB
4091 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4092 || k1->op_type == OP_EACH)
4093 expr = newUNOP(OP_DEFINED, 0, expr);
4099 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4100 o = new_logop(OP_AND, 0, &expr, &listop);
4103 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4105 if (once && o != listop)
4106 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4109 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4111 o->op_flags |= flags;
4113 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4118 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4126 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4127 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4128 expr = newUNOP(OP_DEFINED, 0,
4129 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4130 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4131 OP *k1 = ((UNOP*)expr)->op_first;
4132 OP *k2 = (k1) ? k1->op_sibling : NULL;
4133 switch (expr->op_type) {
4135 if (k2 && k2->op_type == OP_READLINE
4136 && (k2->op_flags & OPf_STACKED)
4137 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4138 expr = newUNOP(OP_DEFINED, 0, expr);
4142 if (k1->op_type == OP_READDIR
4143 || k1->op_type == OP_GLOB
4144 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4145 || k1->op_type == OP_EACH)
4146 expr = newUNOP(OP_DEFINED, 0, expr);
4152 block = newOP(OP_NULL, 0);
4154 block = scope(block);
4158 next = LINKLIST(cont);
4161 OP *unstack = newOP(OP_UNSTACK, 0);
4164 cont = append_elem(OP_LINESEQ, cont, unstack);
4165 if ((line_t)whileline != NOLINE) {
4166 PL_copline = (line_t)whileline;
4167 cont = append_elem(OP_LINESEQ, cont,
4168 newSTATEOP(0, Nullch, Nullop));
4172 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4173 redo = LINKLIST(listop);
4176 PL_copline = (line_t)whileline;
4178 o = new_logop(OP_AND, 0, &expr, &listop);
4179 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4180 op_free(expr); /* oops, it's a while (0) */
4182 return Nullop; /* listop already freed by new_logop */
4185 ((LISTOP*)listop)->op_last->op_next =
4186 (o == listop ? redo : LINKLIST(o));
4192 NewOp(1101,loop,1,LOOP);
4193 loop->op_type = OP_ENTERLOOP;
4194 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4195 loop->op_private = 0;
4196 loop->op_next = (OP*)loop;
4199 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4201 loop->op_redoop = redo;
4202 loop->op_lastop = o;
4203 o->op_private |= loopflags;
4206 loop->op_nextop = next;
4208 loop->op_nextop = o;
4210 o->op_flags |= flags;
4211 o->op_private |= (flags >> 8);
4216 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4220 PADOFFSET padoff = 0;
4224 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4225 sv->op_type = OP_RV2GV;
4226 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4228 else if (sv->op_type == OP_PADSV) { /* private variable */
4229 padoff = sv->op_targ;
4234 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4235 padoff = sv->op_targ;
4237 iterflags |= OPf_SPECIAL;
4242 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4245 #ifdef USE_5005THREADS
4246 padoff = find_threadsv("_");
4247 iterflags |= OPf_SPECIAL;
4249 sv = newGVOP(OP_GV, 0, PL_defgv);
4252 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4253 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4254 iterflags |= OPf_STACKED;
4256 else if (expr->op_type == OP_NULL &&
4257 (expr->op_flags & OPf_KIDS) &&
4258 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4260 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4261 * set the STACKED flag to indicate that these values are to be
4262 * treated as min/max values by 'pp_iterinit'.
4264 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4265 LOGOP* range = (LOGOP*) flip->op_first;
4266 OP* left = range->op_first;
4267 OP* right = left->op_sibling;
4270 range->op_flags &= ~OPf_KIDS;
4271 range->op_first = Nullop;
4273 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4274 listop->op_first->op_next = range->op_next;
4275 left->op_next = range->op_other;
4276 right->op_next = (OP*)listop;
4277 listop->op_next = listop->op_first;
4280 expr = (OP*)(listop);
4282 iterflags |= OPf_STACKED;
4285 expr = mod(force_list(expr), OP_GREPSTART);
4289 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4290 append_elem(OP_LIST, expr, scalar(sv))));
4291 assert(!loop->op_next);
4292 #ifdef PL_OP_SLAB_ALLOC
4295 NewOp(1234,tmp,1,LOOP);
4296 Copy(loop,tmp,1,LOOP);
4301 Renew(loop, 1, LOOP);
4303 loop->op_targ = padoff;
4304 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4305 PL_copline = forline;
4306 return newSTATEOP(0, label, wop);
4310 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4315 if (type != OP_GOTO || label->op_type == OP_CONST) {
4316 /* "last()" means "last" */
4317 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4318 o = newOP(type, OPf_SPECIAL);
4320 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4321 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4327 if (label->op_type == OP_ENTERSUB)
4328 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4329 o = newUNOP(type, OPf_STACKED, label);
4331 PL_hints |= HINT_BLOCK_SCOPE;
4336 Perl_cv_undef(pTHX_ CV *cv)
4339 CV *freecv = Nullcv;
4340 bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */
4342 #ifdef USE_5005THREADS
4344 MUTEX_DESTROY(CvMUTEXP(cv));
4345 Safefree(CvMUTEXP(cv));
4348 #endif /* USE_5005THREADS */
4351 if (CvFILE(cv) && !CvXSUB(cv)) {
4352 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4353 Safefree(CvFILE(cv));
4358 if (!CvXSUB(cv) && CvROOT(cv)) {
4359 #ifdef USE_5005THREADS
4360 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4361 Perl_croak(aTHX_ "Can't undef active subroutine");
4364 Perl_croak(aTHX_ "Can't undef active subroutine");
4365 #endif /* USE_5005THREADS */
4368 SAVEVPTR(PL_curpad);
4371 op_free(CvROOT(cv));
4372 CvROOT(cv) = Nullop;
4375 SvPOK_off((SV*)cv); /* forget prototype */
4377 outsidecv = CvOUTSIDE(cv);
4378 /* Since closure prototypes have the same lifetime as the containing
4379 * CV, they don't hold a refcount on the outside CV. This avoids
4380 * the refcount loop between the outer CV (which keeps a refcount to
4381 * the closure prototype in the pad entry for pp_anoncode()) and the
4382 * closure prototype, and the ensuing memory leak. --GSAR */
4383 if (!CvANON(cv) || CvCLONED(cv))
4385 CvOUTSIDE(cv) = Nullcv;
4387 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4390 if (CvPADLIST(cv)) {
4391 /* may be during global destruction */
4392 if (SvREFCNT(CvPADLIST(cv))) {
4393 AV *padlist = CvPADLIST(cv);
4395 /* pads may be cleared out already during global destruction */
4396 if (is_eval && !PL_dirty) {
4397 /* inner references to eval's cv must be fixed up */
4398 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4399 AV *comppad = (AV*)AvARRAY(padlist)[1];
4400 SV **namepad = AvARRAY(comppad_name);
4401 SV **curpad = AvARRAY(comppad);
4402 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4403 SV *namesv = namepad[ix];
4404 if (namesv && namesv != &PL_sv_undef
4405 && *SvPVX(namesv) == '&'
4406 && ix <= AvFILLp(comppad))
4408 CV *innercv = (CV*)curpad[ix];
4409 if (innercv && SvTYPE(innercv) == SVt_PVCV
4410 && CvOUTSIDE(innercv) == cv)
4412 CvOUTSIDE(innercv) = outsidecv;
4413 if (!CvANON(innercv) || CvCLONED(innercv)) {
4414 (void)SvREFCNT_inc(outsidecv);
4423 SvREFCNT_dec(freecv);
4424 ix = AvFILLp(padlist);
4426 SV* sv = AvARRAY(padlist)[ix--];
4429 if (sv == (SV*)PL_comppad_name)
4430 PL_comppad_name = Nullav;
4431 else if (sv == (SV*)PL_comppad) {
4432 PL_comppad = Nullav;
4433 PL_curpad = Null(SV**);
4437 SvREFCNT_dec((SV*)CvPADLIST(cv));
4439 CvPADLIST(cv) = Nullav;
4442 SvREFCNT_dec(freecv);
4449 #ifdef DEBUG_CLOSURES
4451 S_cv_dump(pTHX_ CV *cv)
4454 CV *outside = CvOUTSIDE(cv);
4455 AV* padlist = CvPADLIST(cv);
4462 PerlIO_printf(Perl_debug_log,
4463 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4465 (CvANON(cv) ? "ANON"
4466 : (cv == PL_main_cv) ? "MAIN"
4467 : CvUNIQUE(cv) ? "UNIQUE"
4468 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4471 : CvANON(outside) ? "ANON"
4472 : (outside == PL_main_cv) ? "MAIN"
4473 : CvUNIQUE(outside) ? "UNIQUE"
4474 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4479 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4480 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4481 pname = AvARRAY(pad_name);
4482 ppad = AvARRAY(pad);
4484 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4485 if (SvPOK(pname[ix]))
4486 PerlIO_printf(Perl_debug_log,
4487 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4488 (int)ix, PTR2UV(ppad[ix]),
4489 SvFAKE(pname[ix]) ? "FAKE " : "",
4491 (IV)I_32(SvNVX(pname[ix])),
4494 #endif /* DEBUGGING */
4496 #endif /* DEBUG_CLOSURES */
4499 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4503 AV* protopadlist = CvPADLIST(proto);
4504 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4505 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4506 SV** pname = AvARRAY(protopad_name);
4507 SV** ppad = AvARRAY(protopad);
4508 I32 fname = AvFILLp(protopad_name);
4509 I32 fpad = AvFILLp(protopad);
4513 assert(!CvUNIQUE(proto));
4517 SAVESPTR(PL_comppad_name);
4518 SAVESPTR(PL_compcv);
4520 cv = PL_compcv = (CV*)NEWSV(1104,0);
4521 sv_upgrade((SV *)cv, SvTYPE(proto));
4522 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4525 #ifdef USE_5005THREADS
4526 New(666, CvMUTEXP(cv), 1, perl_mutex);
4527 MUTEX_INIT(CvMUTEXP(cv));
4529 #endif /* USE_5005THREADS */
4531 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4532 : savepv(CvFILE(proto));
4534 CvFILE(cv) = CvFILE(proto);
4536 CvGV(cv) = CvGV(proto);
4537 CvSTASH(cv) = CvSTASH(proto);
4538 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4539 CvSTART(cv) = CvSTART(proto);
4541 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4544 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4546 PL_comppad_name = newAV();
4547 for (ix = fname; ix >= 0; ix--)
4548 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4550 PL_comppad = newAV();
4552 comppadlist = newAV();
4553 AvREAL_off(comppadlist);
4554 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4555 av_store(comppadlist, 1, (SV*)PL_comppad);
4556 CvPADLIST(cv) = comppadlist;
4557 av_fill(PL_comppad, AvFILLp(protopad));
4558 PL_curpad = AvARRAY(PL_comppad);
4560 av = newAV(); /* will be @_ */
4562 av_store(PL_comppad, 0, (SV*)av);
4563 AvFLAGS(av) = AVf_REIFY;
4565 for (ix = fpad; ix > 0; ix--) {
4566 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4567 if (namesv && namesv != &PL_sv_undef) {
4568 char *name = SvPVX(namesv); /* XXX */
4569 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4570 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4571 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4573 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4575 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4577 else { /* our own lexical */
4580 /* anon code -- we'll come back for it */
4581 sv = SvREFCNT_inc(ppad[ix]);
4583 else if (*name == '@')
4585 else if (*name == '%')
4594 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4595 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4598 SV* sv = NEWSV(0,0);
4604 /* Now that vars are all in place, clone nested closures. */
4606 for (ix = fpad; ix > 0; ix--) {
4607 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4609 && namesv != &PL_sv_undef
4610 && !(SvFLAGS(namesv) & SVf_FAKE)
4611 && *SvPVX(namesv) == '&'
4612 && CvCLONE(ppad[ix]))
4614 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4615 SvREFCNT_dec(ppad[ix]);
4618 PL_curpad[ix] = (SV*)kid;
4622 #ifdef DEBUG_CLOSURES
4623 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4625 PerlIO_printf(Perl_debug_log, " from:\n");
4627 PerlIO_printf(Perl_debug_log, " to:\n");
4634 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4636 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4638 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4645 Perl_cv_clone(pTHX_ CV *proto)
4648 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4649 cv = cv_clone2(proto, CvOUTSIDE(proto));
4650 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4655 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4657 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4658 SV* msg = sv_newmortal();
4662 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4663 sv_setpv(msg, "Prototype mismatch:");
4665 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4667 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4668 sv_catpv(msg, " vs ");
4670 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4672 sv_catpv(msg, "none");
4673 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4677 static void const_sv_xsub(pTHX_ CV* cv);
4681 =head1 Optree Manipulation Functions
4683 =for apidoc cv_const_sv
4685 If C<cv> is a constant sub eligible for inlining. returns the constant
4686 value returned by the sub. Otherwise, returns NULL.
4688 Constant subs can be created with C<newCONSTSUB> or as described in
4689 L<perlsub/"Constant Functions">.
4694 Perl_cv_const_sv(pTHX_ CV *cv)
4696 if (!cv || !CvCONST(cv))
4698 return (SV*)CvXSUBANY(cv).any_ptr;
4702 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4709 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4710 o = cLISTOPo->op_first->op_sibling;
4712 for (; o; o = o->op_next) {
4713 OPCODE type = o->op_type;
4715 if (sv && o->op_next == o)
4717 if (o->op_next != o) {
4718 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4720 if (type == OP_DBSTATE)
4723 if (type == OP_LEAVESUB || type == OP_RETURN)
4727 if (type == OP_CONST && cSVOPo->op_sv)
4729 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4730 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4731 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4735 /* We get here only from cv_clone2() while creating a closure.
4736 Copy the const value here instead of in cv_clone2 so that
4737 SvREADONLY_on doesn't lead to problems when leaving
4742 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4754 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4764 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4768 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4770 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4774 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4780 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4785 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4786 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4787 SV *sv = sv_newmortal();
4788 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4789 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4790 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4795 gv = gv_fetchpv(name ? name : (aname ? aname :
4796 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4797 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4807 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4808 maximum a prototype before. */
4809 if (SvTYPE(gv) > SVt_NULL) {
4810 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4811 && ckWARN_d(WARN_PROTOTYPE))
4813 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4815 cv_ckproto((CV*)gv, NULL, ps);
4818 sv_setpv((SV*)gv, ps);
4820 sv_setiv((SV*)gv, -1);
4821 SvREFCNT_dec(PL_compcv);
4822 cv = PL_compcv = NULL;
4823 PL_sub_generation++;
4827 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4829 #ifdef GV_UNIQUE_CHECK
4830 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4831 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4835 if (!block || !ps || *ps || attrs)
4838 const_sv = op_const_sv(block, Nullcv);
4841 bool exists = CvROOT(cv) || CvXSUB(cv);
4843 #ifdef GV_UNIQUE_CHECK
4844 if (exists && GvUNIQUE(gv)) {
4845 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4849 /* if the subroutine doesn't exist and wasn't pre-declared
4850 * with a prototype, assume it will be AUTOLOADed,
4851 * skipping the prototype check
4853 if (exists || SvPOK(cv))
4854 cv_ckproto(cv, gv, ps);
4855 /* already defined (or promised)? */
4856 if (exists || GvASSUMECV(gv)) {
4857 if (!block && !attrs) {
4858 if (CvFLAGS(PL_compcv)) {
4859 /* might have had built-in attrs applied */
4860 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4862 /* just a "sub foo;" when &foo is already defined */
4863 SAVEFREESV(PL_compcv);
4866 /* ahem, death to those who redefine active sort subs */
4867 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4868 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4870 if (ckWARN(WARN_REDEFINE)
4872 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4874 line_t oldline = CopLINE(PL_curcop);
4875 if (PL_copline != NOLINE)
4876 CopLINE_set(PL_curcop, PL_copline);
4877 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4878 CvCONST(cv) ? "Constant subroutine %s redefined"
4879 : "Subroutine %s redefined", name);
4880 CopLINE_set(PL_curcop, oldline);
4888 SvREFCNT_inc(const_sv);
4890 assert(!CvROOT(cv) && !CvCONST(cv));
4891 sv_setpv((SV*)cv, ""); /* prototype is "" */
4892 CvXSUBANY(cv).any_ptr = const_sv;
4893 CvXSUB(cv) = const_sv_xsub;
4898 cv = newCONSTSUB(NULL, name, const_sv);
4901 SvREFCNT_dec(PL_compcv);
4903 PL_sub_generation++;
4910 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4911 * before we clobber PL_compcv.
4915 /* Might have had built-in attributes applied -- propagate them. */
4916 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4917 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4918 stash = GvSTASH(CvGV(cv));
4919 else if (CvSTASH(cv))
4920 stash = CvSTASH(cv);
4922 stash = PL_curstash;
4925 /* possibly about to re-define existing subr -- ignore old cv */
4926 rcv = (SV*)PL_compcv;
4927 if (name && GvSTASH(gv))
4928 stash = GvSTASH(gv);
4930 stash = PL_curstash;
4932 apply_attrs(stash, rcv, attrs, FALSE);
4934 if (cv) { /* must reuse cv if autoloaded */
4936 /* got here with just attrs -- work done, so bug out */
4937 SAVEFREESV(PL_compcv);
4941 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4942 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4943 CvOUTSIDE(PL_compcv) = 0;
4944 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4945 CvPADLIST(PL_compcv) = 0;
4946 /* inner references to PL_compcv must be fixed up ... */
4948 AV *padlist = CvPADLIST(cv);
4949 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4950 AV *comppad = (AV*)AvARRAY(padlist)[1];
4951 SV **namepad = AvARRAY(comppad_name);
4952 SV **curpad = AvARRAY(comppad);
4953 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4954 SV *namesv = namepad[ix];
4955 if (namesv && namesv != &PL_sv_undef
4956 && *SvPVX(namesv) == '&')
4958 CV *innercv = (CV*)curpad[ix];
4959 if (CvOUTSIDE(innercv) == PL_compcv) {
4960 CvOUTSIDE(innercv) = cv;
4961 if (!CvANON(innercv) || CvCLONED(innercv)) {
4962 (void)SvREFCNT_inc(cv);
4963 SvREFCNT_dec(PL_compcv);
4969 /* ... before we throw it away */
4970 SvREFCNT_dec(PL_compcv);
4971 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4972 ++PL_sub_generation;
4979 PL_sub_generation++;
4983 CvFILE_set_from_cop(cv, PL_curcop);
4984 CvSTASH(cv) = PL_curstash;
4985 #ifdef USE_5005THREADS
4987 if (!CvMUTEXP(cv)) {
4988 New(666, CvMUTEXP(cv), 1, perl_mutex);
4989 MUTEX_INIT(CvMUTEXP(cv));
4991 #endif /* USE_5005THREADS */
4994 sv_setpv((SV*)cv, ps);
4996 if (PL_error_count) {
5000 char *s = strrchr(name, ':');
5002 if (strEQ(s, "BEGIN")) {
5004 "BEGIN not safe after errors--compilation aborted";
5005 if (PL_in_eval & EVAL_KEEPERR)
5006 Perl_croak(aTHX_ not_safe);
5008 /* force display of errors found but not reported */
5009 sv_catpv(ERRSV, not_safe);
5010 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
5018 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5019 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5022 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5023 mod(scalarseq(block), OP_LEAVESUBLV));
5026 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5028 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5029 OpREFCNT_set(CvROOT(cv), 1);
5030 CvSTART(cv) = LINKLIST(CvROOT(cv));
5031 CvROOT(cv)->op_next = 0;
5032 CALL_PEEP(CvSTART(cv));
5034 /* now that optimizer has done its work, adjust pad values */
5036 SV **namep = AvARRAY(PL_comppad_name);
5037 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5040 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5043 * The only things that a clonable function needs in its
5044 * pad are references to outer lexicals and anonymous subs.
5045 * The rest are created anew during cloning.
5047 if (!((namesv = namep[ix]) != Nullsv &&
5048 namesv != &PL_sv_undef &&
5050 *SvPVX(namesv) == '&')))
5052 SvREFCNT_dec(PL_curpad[ix]);
5053 PL_curpad[ix] = Nullsv;
5056 assert(!CvCONST(cv));
5057 if (ps && !*ps && op_const_sv(block, cv))
5061 AV *av = newAV(); /* Will be @_ */
5063 av_store(PL_comppad, 0, (SV*)av);
5064 AvFLAGS(av) = AVf_REIFY;
5066 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5067 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5069 if (!SvPADMY(PL_curpad[ix]))
5070 SvPADTMP_on(PL_curpad[ix]);
5074 /* If a potential closure prototype, don't keep a refcount on outer CV.
5075 * This is okay as the lifetime of the prototype is tied to the
5076 * lifetime of the outer CV. Avoids memory leak due to reference
5079 SvREFCNT_dec(CvOUTSIDE(cv));
5081 if (name || aname) {
5083 char *tname = (name ? name : aname);
5085 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5086 SV *sv = NEWSV(0,0);
5087 SV *tmpstr = sv_newmortal();
5088 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5092 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5094 (long)PL_subline, (long)CopLINE(PL_curcop));
5095 gv_efullname3(tmpstr, gv, Nullch);
5096 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5097 hv = GvHVn(db_postponed);
5098 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5099 && (pcv = GvCV(db_postponed)))
5105 call_sv((SV*)pcv, G_DISCARD);
5109 if ((s = strrchr(tname,':')))
5114 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5117 if (strEQ(s, "BEGIN")) {
5118 I32 oldscope = PL_scopestack_ix;
5120 SAVECOPFILE(&PL_compiling);
5121 SAVECOPLINE(&PL_compiling);
5124 PL_beginav = newAV();
5125 DEBUG_x( dump_sub(gv) );
5126 av_push(PL_beginav, (SV*)cv);
5127 GvCV(gv) = 0; /* cv has been hijacked */
5128 call_list(oldscope, PL_beginav);
5130 PL_curcop = &PL_compiling;
5131 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5134 else if (strEQ(s, "END") && !PL_error_count) {
5137 DEBUG_x( dump_sub(gv) );
5138 av_unshift(PL_endav, 1);
5139 av_store(PL_endav, 0, (SV*)cv);
5140 GvCV(gv) = 0; /* cv has been hijacked */
5142 else if (strEQ(s, "CHECK") && !PL_error_count) {
5144 PL_checkav = newAV();
5145 DEBUG_x( dump_sub(gv) );
5146 if (PL_main_start && ckWARN(WARN_VOID))
5147 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5148 av_unshift(PL_checkav, 1);
5149 av_store(PL_checkav, 0, (SV*)cv);
5150 GvCV(gv) = 0; /* cv has been hijacked */
5152 else if (strEQ(s, "INIT") && !PL_error_count) {
5154 PL_initav = newAV();
5155 DEBUG_x( dump_sub(gv) );
5156 if (PL_main_start && ckWARN(WARN_VOID))
5157 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5158 av_push(PL_initav, (SV*)cv);
5159 GvCV(gv) = 0; /* cv has been hijacked */
5164 PL_copline = NOLINE;
5169 /* XXX unsafe for threads if eval_owner isn't held */
5171 =for apidoc newCONSTSUB
5173 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5174 eligible for inlining at compile-time.
5180 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5186 SAVECOPLINE(PL_curcop);
5187 CopLINE_set(PL_curcop, PL_copline);
5190 PL_hints &= ~HINT_BLOCK_SCOPE;
5193 SAVESPTR(PL_curstash);
5194 SAVECOPSTASH(PL_curcop);
5195 PL_curstash = stash;
5196 CopSTASH_set(PL_curcop,stash);
5199 cv = newXS(name, const_sv_xsub, __FILE__);
5200 CvXSUBANY(cv).any_ptr = sv;
5202 sv_setpv((SV*)cv, ""); /* prototype is "" */
5210 =for apidoc U||newXS
5212 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5218 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5220 GV *gv = gv_fetchpv(name ? name :
5221 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5222 GV_ADDMULTI, SVt_PVCV);
5226 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5228 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5230 /* just a cached method */
5234 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5235 /* already defined (or promised) */
5236 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5237 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5238 line_t oldline = CopLINE(PL_curcop);
5239 if (PL_copline != NOLINE)
5240 CopLINE_set(PL_curcop, PL_copline);
5241 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5242 CvCONST(cv) ? "Constant subroutine %s redefined"
5243 : "Subroutine %s redefined"
5245 CopLINE_set(PL_curcop, oldline);
5252 if (cv) /* must reuse cv if autoloaded */
5255 cv = (CV*)NEWSV(1105,0);
5256 sv_upgrade((SV *)cv, SVt_PVCV);
5260 PL_sub_generation++;
5264 #ifdef USE_5005THREADS
5265 New(666, CvMUTEXP(cv), 1, perl_mutex);
5266 MUTEX_INIT(CvMUTEXP(cv));
5268 #endif /* USE_5005THREADS */
5269 (void)gv_fetchfile(filename);
5270 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5271 an external constant string */
5272 CvXSUB(cv) = subaddr;
5275 char *s = strrchr(name,':');
5281 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5284 if (strEQ(s, "BEGIN")) {
5286 PL_beginav = newAV();
5287 av_push(PL_beginav, (SV*)cv);
5288 GvCV(gv) = 0; /* cv has been hijacked */
5290 else if (strEQ(s, "END")) {
5293 av_unshift(PL_endav, 1);
5294 av_store(PL_endav, 0, (SV*)cv);
5295 GvCV(gv) = 0; /* cv has been hijacked */
5297 else if (strEQ(s, "CHECK")) {
5299 PL_checkav = newAV();
5300 if (PL_main_start && ckWARN(WARN_VOID))
5301 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5302 av_unshift(PL_checkav, 1);
5303 av_store(PL_checkav, 0, (SV*)cv);
5304 GvCV(gv) = 0; /* cv has been hijacked */
5306 else if (strEQ(s, "INIT")) {
5308 PL_initav = newAV();
5309 if (PL_main_start && ckWARN(WARN_VOID))
5310 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5311 av_push(PL_initav, (SV*)cv);
5312 GvCV(gv) = 0; /* cv has been hijacked */
5323 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5332 name = SvPVx(cSVOPo->op_sv, n_a);
5335 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5336 #ifdef GV_UNIQUE_CHECK
5338 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5342 if ((cv = GvFORM(gv))) {
5343 if (ckWARN(WARN_REDEFINE)) {
5344 line_t oldline = CopLINE(PL_curcop);
5345 if (PL_copline != NOLINE)
5346 CopLINE_set(PL_curcop, PL_copline);
5347 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
5348 CopLINE_set(PL_curcop, oldline);
5355 CvFILE_set_from_cop(cv, PL_curcop);
5357 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5358 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5359 SvPADTMP_on(PL_curpad[ix]);
5362 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5363 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5364 OpREFCNT_set(CvROOT(cv), 1);
5365 CvSTART(cv) = LINKLIST(CvROOT(cv));
5366 CvROOT(cv)->op_next = 0;
5367 CALL_PEEP(CvSTART(cv));
5369 PL_copline = NOLINE;
5374 Perl_newANONLIST(pTHX_ OP *o)
5376 return newUNOP(OP_REFGEN, 0,
5377 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5381 Perl_newANONHASH(pTHX_ OP *o)
5383 return newUNOP(OP_REFGEN, 0,
5384 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5388 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5390 return newANONATTRSUB(floor, proto, Nullop, block);
5394 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5396 return newUNOP(OP_REFGEN, 0,
5397 newSVOP(OP_ANONCODE, 0,
5398 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5402 Perl_oopsAV(pTHX_ OP *o)
5404 switch (o->op_type) {
5406 o->op_type = OP_PADAV;
5407 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5408 return ref(o, OP_RV2AV);
5411 o->op_type = OP_RV2AV;
5412 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5417 if (ckWARN_d(WARN_INTERNAL))
5418 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5425 Perl_oopsHV(pTHX_ OP *o)
5427 switch (o->op_type) {
5430 o->op_type = OP_PADHV;
5431 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5432 return ref(o, OP_RV2HV);
5436 o->op_type = OP_RV2HV;
5437 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5442 if (ckWARN_d(WARN_INTERNAL))
5443 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5450 Perl_newAVREF(pTHX_ OP *o)
5452 if (o->op_type == OP_PADANY) {
5453 o->op_type = OP_PADAV;
5454 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5457 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5458 && ckWARN(WARN_DEPRECATED)) {
5459 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5460 "Using an array as a reference is deprecated");
5462 return newUNOP(OP_RV2AV, 0, scalar(o));
5466 Perl_newGVREF(pTHX_ I32 type, OP *o)
5468 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5469 return newUNOP(OP_NULL, 0, o);
5470 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5474 Perl_newHVREF(pTHX_ OP *o)
5476 if (o->op_type == OP_PADANY) {
5477 o->op_type = OP_PADHV;
5478 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5481 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5482 && ckWARN(WARN_DEPRECATED)) {
5483 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5484 "Using a hash as a reference is deprecated");
5486 return newUNOP(OP_RV2HV, 0, scalar(o));
5490 Perl_oopsCV(pTHX_ OP *o)
5492 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5498 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5500 return newUNOP(OP_RV2CV, flags, scalar(o));
5504 Perl_newSVREF(pTHX_ OP *o)
5506 if (o->op_type == OP_PADANY) {
5507 o->op_type = OP_PADSV;
5508 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5511 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5512 o->op_flags |= OPpDONE_SVREF;
5515 return newUNOP(OP_RV2SV, 0, scalar(o));
5518 /* Check routines. */
5521 Perl_ck_anoncode(pTHX_ OP *o)
5526 name = NEWSV(1106,0);
5527 sv_upgrade(name, SVt_PVNV);
5528 sv_setpvn(name, "&", 1);
5531 ix = pad_alloc(o->op_type, SVs_PADMY);
5532 av_store(PL_comppad_name, ix, name);
5533 av_store(PL_comppad, ix, cSVOPo->op_sv);
5534 SvPADMY_on(cSVOPo->op_sv);
5535 cSVOPo->op_sv = Nullsv;
5536 cSVOPo->op_targ = ix;
5541 Perl_ck_bitop(pTHX_ OP *o)
5543 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5548 Perl_ck_concat(pTHX_ OP *o)
5550 if (cUNOPo->op_first->op_type == OP_CONCAT)
5551 o->op_flags |= OPf_STACKED;
5556 Perl_ck_spair(pTHX_ OP *o)
5558 if (o->op_flags & OPf_KIDS) {
5561 OPCODE type = o->op_type;
5562 o = modkids(ck_fun(o), type);
5563 kid = cUNOPo->op_first;
5564 newop = kUNOP->op_first->op_sibling;
5566 (newop->op_sibling ||
5567 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5568 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5569 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5573 op_free(kUNOP->op_first);
5574 kUNOP->op_first = newop;
5576 o->op_ppaddr = PL_ppaddr[++o->op_type];
5581 Perl_ck_delete(pTHX_ OP *o)
5585 if (o->op_flags & OPf_KIDS) {
5586 OP *kid = cUNOPo->op_first;
5587 switch (kid->op_type) {
5589 o->op_flags |= OPf_SPECIAL;
5592 o->op_private |= OPpSLICE;
5595 o->op_flags |= OPf_SPECIAL;
5600 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5609 Perl_ck_die(pTHX_ OP *o)
5612 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5618 Perl_ck_eof(pTHX_ OP *o)
5620 I32 type = o->op_type;
5622 if (o->op_flags & OPf_KIDS) {
5623 if (cLISTOPo->op_first->op_type == OP_STUB) {
5625 o = newUNOP(type, OPf_SPECIAL,
5626 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5634 Perl_ck_eval(pTHX_ OP *o)
5636 PL_hints |= HINT_BLOCK_SCOPE;
5637 if (o->op_flags & OPf_KIDS) {
5638 SVOP *kid = (SVOP*)cUNOPo->op_first;
5641 o->op_flags &= ~OPf_KIDS;
5644 else if (kid->op_type == OP_LINESEQ) {
5647 kid->op_next = o->op_next;
5648 cUNOPo->op_first = 0;
5651 NewOp(1101, enter, 1, LOGOP);
5652 enter->op_type = OP_ENTERTRY;
5653 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5654 enter->op_private = 0;
5656 /* establish postfix order */
5657 enter->op_next = (OP*)enter;
5659 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5660 o->op_type = OP_LEAVETRY;
5661 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5662 enter->op_other = o;
5670 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5672 o->op_targ = (PADOFFSET)PL_hints;
5677 Perl_ck_exit(pTHX_ OP *o)
5680 HV *table = GvHV(PL_hintgv);
5682 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5683 if (svp && *svp && SvTRUE(*svp))
5684 o->op_private |= OPpEXIT_VMSISH;
5686 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5692 Perl_ck_exec(pTHX_ OP *o)
5695 if (o->op_flags & OPf_STACKED) {
5697 kid = cUNOPo->op_first->op_sibling;
5698 if (kid->op_type == OP_RV2GV)
5707 Perl_ck_exists(pTHX_ OP *o)
5710 if (o->op_flags & OPf_KIDS) {
5711 OP *kid = cUNOPo->op_first;
5712 if (kid->op_type == OP_ENTERSUB) {
5713 (void) ref(kid, o->op_type);
5714 if (kid->op_type != OP_RV2CV && !PL_error_count)
5715 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5717 o->op_private |= OPpEXISTS_SUB;
5719 else if (kid->op_type == OP_AELEM)
5720 o->op_flags |= OPf_SPECIAL;
5721 else if (kid->op_type != OP_HELEM)
5722 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5731 Perl_ck_gvconst(pTHX_ register OP *o)
5733 o = fold_constants(o);
5734 if (o->op_type == OP_CONST)
5741 Perl_ck_rvconst(pTHX_ register OP *o)
5743 SVOP *kid = (SVOP*)cUNOPo->op_first;
5745 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5746 if (kid->op_type == OP_CONST) {
5750 SV *kidsv = kid->op_sv;
5753 /* Is it a constant from cv_const_sv()? */
5754 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5755 SV *rsv = SvRV(kidsv);
5756 int svtype = SvTYPE(rsv);
5757 char *badtype = Nullch;
5759 switch (o->op_type) {
5761 if (svtype > SVt_PVMG)
5762 badtype = "a SCALAR";
5765 if (svtype != SVt_PVAV)
5766 badtype = "an ARRAY";
5769 if (svtype != SVt_PVHV)
5773 if (svtype != SVt_PVCV)
5778 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5781 name = SvPV(kidsv, n_a);
5782 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5783 char *badthing = Nullch;
5784 switch (o->op_type) {
5786 badthing = "a SCALAR";
5789 badthing = "an ARRAY";
5792 badthing = "a HASH";
5797 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5801 * This is a little tricky. We only want to add the symbol if we
5802 * didn't add it in the lexer. Otherwise we get duplicate strict
5803 * warnings. But if we didn't add it in the lexer, we must at
5804 * least pretend like we wanted to add it even if it existed before,
5805 * or we get possible typo warnings. OPpCONST_ENTERED says
5806 * whether the lexer already added THIS instance of this symbol.
5808 iscv = (o->op_type == OP_RV2CV) * 2;
5810 gv = gv_fetchpv(name,
5811 iscv | !(kid->op_private & OPpCONST_ENTERED),
5814 : o->op_type == OP_RV2SV
5816 : o->op_type == OP_RV2AV
5818 : o->op_type == OP_RV2HV
5821 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5823 kid->op_type = OP_GV;
5824 SvREFCNT_dec(kid->op_sv);
5826 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5827 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5828 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5830 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5832 kid->op_sv = SvREFCNT_inc(gv);
5834 kid->op_private = 0;
5835 kid->op_ppaddr = PL_ppaddr[OP_GV];
5842 Perl_ck_ftst(pTHX_ OP *o)
5844 I32 type = o->op_type;
5846 if (o->op_flags & OPf_REF) {
5849 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5850 SVOP *kid = (SVOP*)cUNOPo->op_first;
5852 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5854 OP *newop = newGVOP(type, OPf_REF,
5855 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5862 if (type == OP_FTTTY)
5863 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5866 o = newUNOP(type, 0, newDEFSVOP());
5872 Perl_ck_fun(pTHX_ OP *o)
5878 int type = o->op_type;
5879 register I32 oa = PL_opargs[type] >> OASHIFT;
5881 if (o->op_flags & OPf_STACKED) {
5882 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5885 return no_fh_allowed(o);
5888 if (o->op_flags & OPf_KIDS) {
5890 tokid = &cLISTOPo->op_first;
5891 kid = cLISTOPo->op_first;
5892 if (kid->op_type == OP_PUSHMARK ||
5893 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5895 tokid = &kid->op_sibling;
5896 kid = kid->op_sibling;
5898 if (!kid && PL_opargs[type] & OA_DEFGV)
5899 *tokid = kid = newDEFSVOP();
5903 sibl = kid->op_sibling;
5906 /* list seen where single (scalar) arg expected? */
5907 if (numargs == 1 && !(oa >> 4)
5908 && kid->op_type == OP_LIST && type != OP_SCALAR)
5910 return too_many_arguments(o,PL_op_desc[type]);
5923 if ((type == OP_PUSH || type == OP_UNSHIFT)
5924 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5925 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5926 "Useless use of %s with no values",
5929 if (kid->op_type == OP_CONST &&
5930 (kid->op_private & OPpCONST_BARE))
5932 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5933 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5934 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5935 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5936 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5937 "Array @%s missing the @ in argument %"IVdf" of %s()",
5938 name, (IV)numargs, PL_op_desc[type]);
5941 kid->op_sibling = sibl;
5944 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5945 bad_type(numargs, "array", PL_op_desc[type], kid);
5949 if (kid->op_type == OP_CONST &&
5950 (kid->op_private & OPpCONST_BARE))
5952 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5953 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5954 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5955 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5956 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5957 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5958 name, (IV)numargs, PL_op_desc[type]);
5961 kid->op_sibling = sibl;
5964 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5965 bad_type(numargs, "hash", PL_op_desc[type], kid);
5970 OP *newop = newUNOP(OP_NULL, 0, kid);
5971 kid->op_sibling = 0;
5973 newop->op_next = newop;
5975 kid->op_sibling = sibl;
5980 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5981 if (kid->op_type == OP_CONST &&
5982 (kid->op_private & OPpCONST_BARE))
5984 OP *newop = newGVOP(OP_GV, 0,
5985 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5987 if (!(o->op_private & 1) && /* if not unop */
5988 kid == cLISTOPo->op_last)
5989 cLISTOPo->op_last = newop;
5993 else if (kid->op_type == OP_READLINE) {
5994 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5995 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5998 I32 flags = OPf_SPECIAL;
6002 /* is this op a FH constructor? */
6003 if (is_handle_constructor(o,numargs)) {
6004 char *name = Nullch;
6008 /* Set a flag to tell rv2gv to vivify
6009 * need to "prove" flag does not mean something
6010 * else already - NI-S 1999/05/07
6013 if (kid->op_type == OP_PADSV) {
6014 SV **namep = av_fetch(PL_comppad_name,
6016 if (namep && *namep)
6017 name = SvPV(*namep, len);
6019 else if (kid->op_type == OP_RV2SV
6020 && kUNOP->op_first->op_type == OP_GV)
6022 GV *gv = cGVOPx_gv(kUNOP->op_first);
6024 len = GvNAMELEN(gv);
6026 else if (kid->op_type == OP_AELEM
6027 || kid->op_type == OP_HELEM)
6029 name = "__ANONIO__";
6035 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6036 namesv = PL_curpad[targ];
6037 (void)SvUPGRADE(namesv, SVt_PV);
6039 sv_setpvn(namesv, "$", 1);
6040 sv_catpvn(namesv, name, len);
6043 kid->op_sibling = 0;
6044 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6045 kid->op_targ = targ;
6046 kid->op_private |= priv;
6048 kid->op_sibling = sibl;
6054 mod(scalar(kid), type);
6058 tokid = &kid->op_sibling;
6059 kid = kid->op_sibling;
6061 o->op_private |= numargs;
6063 return too_many_arguments(o,OP_DESC(o));
6066 else if (PL_opargs[type] & OA_DEFGV) {
6068 return newUNOP(type, 0, newDEFSVOP());
6072 while (oa & OA_OPTIONAL)
6074 if (oa && oa != OA_LIST)
6075 return too_few_arguments(o,OP_DESC(o));
6081 Perl_ck_glob(pTHX_ OP *o)
6086 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6087 append_elem(OP_GLOB, o, newDEFSVOP());
6089 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6090 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6092 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6095 #if !defined(PERL_EXTERNAL_GLOB)
6096 /* XXX this can be tightened up and made more failsafe. */
6100 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6101 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6102 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6103 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6104 GvCV(gv) = GvCV(glob_gv);
6105 SvREFCNT_inc((SV*)GvCV(gv));
6106 GvIMPORTED_CV_on(gv);
6109 #endif /* PERL_EXTERNAL_GLOB */
6111 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6112 append_elem(OP_GLOB, o,
6113 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6114 o->op_type = OP_LIST;
6115 o->op_ppaddr = PL_ppaddr[OP_LIST];
6116 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6117 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6118 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6119 append_elem(OP_LIST, o,
6120 scalar(newUNOP(OP_RV2CV, 0,
6121 newGVOP(OP_GV, 0, gv)))));
6122 o = newUNOP(OP_NULL, 0, ck_subr(o));
6123 o->op_targ = OP_GLOB; /* hint at what it used to be */
6126 gv = newGVgen("main");
6128 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6134 Perl_ck_grep(pTHX_ OP *o)
6138 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6140 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6141 NewOp(1101, gwop, 1, LOGOP);
6143 if (o->op_flags & OPf_STACKED) {
6146 kid = cLISTOPo->op_first->op_sibling;
6147 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6150 kid->op_next = (OP*)gwop;
6151 o->op_flags &= ~OPf_STACKED;
6153 kid = cLISTOPo->op_first->op_sibling;
6154 if (type == OP_MAPWHILE)
6161 kid = cLISTOPo->op_first->op_sibling;
6162 if (kid->op_type != OP_NULL)
6163 Perl_croak(aTHX_ "panic: ck_grep");
6164 kid = kUNOP->op_first;
6166 gwop->op_type = type;
6167 gwop->op_ppaddr = PL_ppaddr[type];
6168 gwop->op_first = listkids(o);
6169 gwop->op_flags |= OPf_KIDS;
6170 gwop->op_private = 1;
6171 gwop->op_other = LINKLIST(kid);
6172 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6173 kid->op_next = (OP*)gwop;
6175 kid = cLISTOPo->op_first->op_sibling;
6176 if (!kid || !kid->op_sibling)
6177 return too_few_arguments(o,OP_DESC(o));
6178 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6179 mod(kid, OP_GREPSTART);
6185 Perl_ck_index(pTHX_ OP *o)
6187 if (o->op_flags & OPf_KIDS) {
6188 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6190 kid = kid->op_sibling; /* get past "big" */
6191 if (kid && kid->op_type == OP_CONST)
6192 fbm_compile(((SVOP*)kid)->op_sv, 0);
6198 Perl_ck_lengthconst(pTHX_ OP *o)
6200 /* XXX length optimization goes here */
6205 Perl_ck_lfun(pTHX_ OP *o)
6207 OPCODE type = o->op_type;
6208 return modkids(ck_fun(o), type);
6212 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6214 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6215 switch (cUNOPo->op_first->op_type) {
6217 /* This is needed for
6218 if (defined %stash::)
6219 to work. Do not break Tk.
6221 break; /* Globals via GV can be undef */
6223 case OP_AASSIGN: /* Is this a good idea? */
6224 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6225 "defined(@array) is deprecated");
6226 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6227 "\t(Maybe you should just omit the defined()?)\n");
6230 /* This is needed for
6231 if (defined %stash::)
6232 to work. Do not break Tk.
6234 break; /* Globals via GV can be undef */
6236 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6237 "defined(%%hash) is deprecated");
6238 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6239 "\t(Maybe you should just omit the defined()?)\n");
6250 Perl_ck_rfun(pTHX_ OP *o)
6252 OPCODE type = o->op_type;
6253 return refkids(ck_fun(o), type);
6257 Perl_ck_listiob(pTHX_ OP *o)
6261 kid = cLISTOPo->op_first;
6264 kid = cLISTOPo->op_first;
6266 if (kid->op_type == OP_PUSHMARK)
6267 kid = kid->op_sibling;
6268 if (kid && o->op_flags & OPf_STACKED)
6269 kid = kid->op_sibling;
6270 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6271 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6272 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6273 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6274 cLISTOPo->op_first->op_sibling = kid;
6275 cLISTOPo->op_last = kid;
6276 kid = kid->op_sibling;
6281 append_elem(o->op_type, o, newDEFSVOP());
6287 Perl_ck_sassign(pTHX_ OP *o)
6289 OP *kid = cLISTOPo->op_first;
6290 /* has a disposable target? */
6291 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6292 && !(kid->op_flags & OPf_STACKED)
6293 /* Cannot steal the second time! */
6294 && !(kid->op_private & OPpTARGET_MY))
6296 OP *kkid = kid->op_sibling;
6298 /* Can just relocate the target. */
6299 if (kkid && kkid->op_type == OP_PADSV
6300 && !(kkid->op_private & OPpLVAL_INTRO))
6302 kid->op_targ = kkid->op_targ;
6304 /* Now we do not need PADSV and SASSIGN. */
6305 kid->op_sibling = o->op_sibling; /* NULL */
6306 cLISTOPo->op_first = NULL;
6309 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6317 Perl_ck_match(pTHX_ OP *o)
6319 o->op_private |= OPpRUNTIME;
6324 Perl_ck_method(pTHX_ OP *o)
6326 OP *kid = cUNOPo->op_first;
6327 if (kid->op_type == OP_CONST) {
6328 SV* sv = kSVOP->op_sv;
6329 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6331 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6332 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6335 kSVOP->op_sv = Nullsv;
6337 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6346 Perl_ck_null(pTHX_ OP *o)
6352 Perl_ck_open(pTHX_ OP *o)
6354 HV *table = GvHV(PL_hintgv);
6358 svp = hv_fetch(table, "open_IN", 7, FALSE);
6360 mode = mode_from_discipline(*svp);
6361 if (mode & O_BINARY)
6362 o->op_private |= OPpOPEN_IN_RAW;
6363 else if (mode & O_TEXT)
6364 o->op_private |= OPpOPEN_IN_CRLF;
6367 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6369 mode = mode_from_discipline(*svp);
6370 if (mode & O_BINARY)
6371 o->op_private |= OPpOPEN_OUT_RAW;
6372 else if (mode & O_TEXT)
6373 o->op_private |= OPpOPEN_OUT_CRLF;
6376 if (o->op_type == OP_BACKTICK)
6382 Perl_ck_repeat(pTHX_ OP *o)
6384 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6385 o->op_private |= OPpREPEAT_DOLIST;
6386 cBINOPo->op_first = force_list(cBINOPo->op_first);
6394 Perl_ck_require(pTHX_ OP *o)
6398 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6399 SVOP *kid = (SVOP*)cUNOPo->op_first;
6401 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6403 for (s = SvPVX(kid->op_sv); *s; s++) {
6404 if (*s == ':' && s[1] == ':') {
6406 Move(s+2, s+1, strlen(s+2)+1, char);
6407 --SvCUR(kid->op_sv);
6410 if (SvREADONLY(kid->op_sv)) {
6411 SvREADONLY_off(kid->op_sv);
6412 sv_catpvn(kid->op_sv, ".pm", 3);
6413 SvREADONLY_on(kid->op_sv);
6416 sv_catpvn(kid->op_sv, ".pm", 3);
6420 /* handle override, if any */
6421 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6422 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6423 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6425 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6426 OP *kid = cUNOPo->op_first;
6427 cUNOPo->op_first = 0;
6429 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6430 append_elem(OP_LIST, kid,
6431 scalar(newUNOP(OP_RV2CV, 0,
6440 Perl_ck_return(pTHX_ OP *o)
6443 if (CvLVALUE(PL_compcv)) {
6444 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6445 mod(kid, OP_LEAVESUBLV);
6452 Perl_ck_retarget(pTHX_ OP *o)
6454 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6461 Perl_ck_select(pTHX_ OP *o)
6464 if (o->op_flags & OPf_KIDS) {
6465 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6466 if (kid && kid->op_sibling) {
6467 o->op_type = OP_SSELECT;
6468 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6470 return fold_constants(o);
6474 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6475 if (kid && kid->op_type == OP_RV2GV)
6476 kid->op_private &= ~HINT_STRICT_REFS;
6481 Perl_ck_shift(pTHX_ OP *o)
6483 I32 type = o->op_type;
6485 if (!(o->op_flags & OPf_KIDS)) {
6489 #ifdef USE_5005THREADS
6490 if (!CvUNIQUE(PL_compcv)) {
6491 argop = newOP(OP_PADAV, OPf_REF);
6492 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6495 argop = newUNOP(OP_RV2AV, 0,
6496 scalar(newGVOP(OP_GV, 0,
6497 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6500 argop = newUNOP(OP_RV2AV, 0,
6501 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6502 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6503 #endif /* USE_5005THREADS */
6504 return newUNOP(type, 0, scalar(argop));
6506 return scalar(modkids(ck_fun(o), type));
6510 Perl_ck_sort(pTHX_ OP *o)
6514 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6516 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6517 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6519 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6521 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6523 if (kid->op_type == OP_SCOPE) {
6527 else if (kid->op_type == OP_LEAVE) {
6528 if (o->op_type == OP_SORT) {
6529 op_null(kid); /* wipe out leave */
6532 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6533 if (k->op_next == kid)
6535 /* don't descend into loops */
6536 else if (k->op_type == OP_ENTERLOOP
6537 || k->op_type == OP_ENTERITER)
6539 k = cLOOPx(k)->op_lastop;
6544 kid->op_next = 0; /* just disconnect the leave */
6545 k = kLISTOP->op_first;
6550 if (o->op_type == OP_SORT) {
6551 /* provide scalar context for comparison function/block */
6557 o->op_flags |= OPf_SPECIAL;
6559 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6562 firstkid = firstkid->op_sibling;
6565 /* provide list context for arguments */
6566 if (o->op_type == OP_SORT)
6573 S_simplify_sort(pTHX_ OP *o)
6575 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6579 if (!(o->op_flags & OPf_STACKED))
6581 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6582 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6583 kid = kUNOP->op_first; /* get past null */
6584 if (kid->op_type != OP_SCOPE)
6586 kid = kLISTOP->op_last; /* get past scope */
6587 switch(kid->op_type) {
6595 k = kid; /* remember this node*/
6596 if (kBINOP->op_first->op_type != OP_RV2SV)
6598 kid = kBINOP->op_first; /* get past cmp */
6599 if (kUNOP->op_first->op_type != OP_GV)
6601 kid = kUNOP->op_first; /* get past rv2sv */
6603 if (GvSTASH(gv) != PL_curstash)
6605 if (strEQ(GvNAME(gv), "a"))
6607 else if (strEQ(GvNAME(gv), "b"))
6611 kid = k; /* back to cmp */
6612 if (kBINOP->op_last->op_type != OP_RV2SV)
6614 kid = kBINOP->op_last; /* down to 2nd arg */
6615 if (kUNOP->op_first->op_type != OP_GV)
6617 kid = kUNOP->op_first; /* get past rv2sv */
6619 if (GvSTASH(gv) != PL_curstash
6621 ? strNE(GvNAME(gv), "a")
6622 : strNE(GvNAME(gv), "b")))
6624 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6626 o->op_private |= OPpSORT_REVERSE;
6627 if (k->op_type == OP_NCMP)
6628 o->op_private |= OPpSORT_NUMERIC;
6629 if (k->op_type == OP_I_NCMP)
6630 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6631 kid = cLISTOPo->op_first->op_sibling;
6632 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6633 op_free(kid); /* then delete it */
6637 Perl_ck_split(pTHX_ OP *o)
6641 if (o->op_flags & OPf_STACKED)
6642 return no_fh_allowed(o);
6644 kid = cLISTOPo->op_first;
6645 if (kid->op_type != OP_NULL)
6646 Perl_croak(aTHX_ "panic: ck_split");
6647 kid = kid->op_sibling;
6648 op_free(cLISTOPo->op_first);
6649 cLISTOPo->op_first = kid;
6651 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6652 cLISTOPo->op_last = kid; /* There was only one element previously */
6655 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6656 OP *sibl = kid->op_sibling;
6657 kid->op_sibling = 0;
6658 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6659 if (cLISTOPo->op_first == cLISTOPo->op_last)
6660 cLISTOPo->op_last = kid;
6661 cLISTOPo->op_first = kid;
6662 kid->op_sibling = sibl;
6665 kid->op_type = OP_PUSHRE;
6666 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6668 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6669 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6670 "Use of /g modifier is meaningless in split");
6673 if (!kid->op_sibling)
6674 append_elem(OP_SPLIT, o, newDEFSVOP());
6676 kid = kid->op_sibling;
6679 if (!kid->op_sibling)
6680 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6682 kid = kid->op_sibling;
6685 if (kid->op_sibling)
6686 return too_many_arguments(o,OP_DESC(o));
6692 Perl_ck_join(pTHX_ OP *o)
6694 if (ckWARN(WARN_SYNTAX)) {
6695 OP *kid = cLISTOPo->op_first->op_sibling;
6696 if (kid && kid->op_type == OP_MATCH) {
6697 char *pmstr = "STRING";
6698 if (PM_GETRE(kPMOP))
6699 pmstr = PM_GETRE(kPMOP)->precomp;
6700 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6701 "/%s/ should probably be written as \"%s\"",
6709 Perl_ck_subr(pTHX_ OP *o)
6711 OP *prev = ((cUNOPo->op_first->op_sibling)
6712 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6713 OP *o2 = prev->op_sibling;
6720 I32 contextclass = 0;
6724 o->op_private |= OPpENTERSUB_HASTARG;
6725 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6726 if (cvop->op_type == OP_RV2CV) {
6728 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6729 op_null(cvop); /* disable rv2cv */
6730 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6731 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6732 GV *gv = cGVOPx_gv(tmpop);
6735 tmpop->op_private |= OPpEARLY_CV;
6736 else if (SvPOK(cv)) {
6737 namegv = CvANON(cv) ? gv : CvGV(cv);
6738 proto = SvPV((SV*)cv, n_a);
6742 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6743 if (o2->op_type == OP_CONST)
6744 o2->op_private &= ~OPpCONST_STRICT;
6745 else if (o2->op_type == OP_LIST) {
6746 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6747 if (o && o->op_type == OP_CONST)
6748 o->op_private &= ~OPpCONST_STRICT;
6751 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6752 if (PERLDB_SUB && PL_curstash != PL_debstash)
6753 o->op_private |= OPpENTERSUB_DB;
6754 while (o2 != cvop) {
6758 return too_many_arguments(o, gv_ename(namegv));
6776 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6778 arg == 1 ? "block or sub {}" : "sub {}",
6779 gv_ename(namegv), o2);
6782 /* '*' allows any scalar type, including bareword */
6785 if (o2->op_type == OP_RV2GV)
6786 goto wrapref; /* autoconvert GLOB -> GLOBref */
6787 else if (o2->op_type == OP_CONST)
6788 o2->op_private &= ~OPpCONST_STRICT;
6789 else if (o2->op_type == OP_ENTERSUB) {
6790 /* accidental subroutine, revert to bareword */
6791 OP *gvop = ((UNOP*)o2)->op_first;
6792 if (gvop && gvop->op_type == OP_NULL) {
6793 gvop = ((UNOP*)gvop)->op_first;
6795 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6798 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6799 (gvop = ((UNOP*)gvop)->op_first) &&
6800 gvop->op_type == OP_GV)
6802 GV *gv = cGVOPx_gv(gvop);
6803 OP *sibling = o2->op_sibling;
6804 SV *n = newSVpvn("",0);
6806 gv_fullname3(n, gv, "");
6807 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6808 sv_chop(n, SvPVX(n)+6);
6809 o2 = newSVOP(OP_CONST, 0, n);
6810 prev->op_sibling = o2;
6811 o2->op_sibling = sibling;
6827 if (contextclass++ == 0) {
6828 e = strchr(proto, ']');
6829 if (!e || e == proto)
6842 while (*--p != '[');
6843 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6844 gv_ename(namegv), o2);
6850 if (o2->op_type == OP_RV2GV)
6853 bad_type(arg, "symbol", gv_ename(namegv), o2);
6856 if (o2->op_type == OP_ENTERSUB)
6859 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6862 if (o2->op_type == OP_RV2SV ||
6863 o2->op_type == OP_PADSV ||
6864 o2->op_type == OP_HELEM ||
6865 o2->op_type == OP_AELEM ||
6866 o2->op_type == OP_THREADSV)
6869 bad_type(arg, "scalar", gv_ename(namegv), o2);
6872 if (o2->op_type == OP_RV2AV ||
6873 o2->op_type == OP_PADAV)
6876 bad_type(arg, "array", gv_ename(namegv), o2);
6879 if (o2->op_type == OP_RV2HV ||
6880 o2->op_type == OP_PADHV)
6883 bad_type(arg, "hash", gv_ename(namegv), o2);
6888 OP* sib = kid->op_sibling;
6889 kid->op_sibling = 0;
6890 o2 = newUNOP(OP_REFGEN, 0, kid);
6891 o2->op_sibling = sib;
6892 prev->op_sibling = o2;
6894 if (contextclass && e) {
6909 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6910 gv_ename(namegv), SvPV((SV*)cv, n_a));
6915 mod(o2, OP_ENTERSUB);
6917 o2 = o2->op_sibling;
6919 if (proto && !optional &&
6920 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6921 return too_few_arguments(o, gv_ename(namegv));
6926 Perl_ck_svconst(pTHX_ OP *o)
6928 SvREADONLY_on(cSVOPo->op_sv);
6933 Perl_ck_trunc(pTHX_ OP *o)
6935 if (o->op_flags & OPf_KIDS) {
6936 SVOP *kid = (SVOP*)cUNOPo->op_first;
6938 if (kid->op_type == OP_NULL)
6939 kid = (SVOP*)kid->op_sibling;
6940 if (kid && kid->op_type == OP_CONST &&
6941 (kid->op_private & OPpCONST_BARE))
6943 o->op_flags |= OPf_SPECIAL;
6944 kid->op_private &= ~OPpCONST_STRICT;
6951 Perl_ck_substr(pTHX_ OP *o)
6954 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6955 OP *kid = cLISTOPo->op_first;
6957 if (kid->op_type == OP_NULL)
6958 kid = kid->op_sibling;
6960 kid->op_flags |= OPf_MOD;
6966 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6969 Perl_peep(pTHX_ register OP *o)
6971 register OP* oldop = 0;
6973 if (!o || o->op_seq)
6977 SAVEVPTR(PL_curcop);
6978 for (; o; o = o->op_next) {
6984 switch (o->op_type) {
6988 PL_curcop = ((COP*)o); /* for warnings */
6989 o->op_seq = PL_op_seqmax++;
6993 if (cSVOPo->op_private & OPpCONST_STRICT)
6994 no_bareword_allowed(o);
6996 /* Relocate sv to the pad for thread safety.
6997 * Despite being a "constant", the SV is written to,
6998 * for reference counts, sv_upgrade() etc. */
7000 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7001 if (SvPADTMP(cSVOPo->op_sv)) {
7002 /* If op_sv is already a PADTMP then it is being used by
7003 * some pad, so make a copy. */
7004 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
7005 SvREADONLY_on(PL_curpad[ix]);
7006 SvREFCNT_dec(cSVOPo->op_sv);
7009 SvREFCNT_dec(PL_curpad[ix]);
7010 SvPADTMP_on(cSVOPo->op_sv);
7011 PL_curpad[ix] = cSVOPo->op_sv;
7012 /* XXX I don't know how this isn't readonly already. */
7013 SvREADONLY_on(PL_curpad[ix]);
7015 cSVOPo->op_sv = Nullsv;
7019 o->op_seq = PL_op_seqmax++;
7023 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7024 if (o->op_next->op_private & OPpTARGET_MY) {
7025 if (o->op_flags & OPf_STACKED) /* chained concats */
7026 goto ignore_optimization;
7028 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7029 o->op_targ = o->op_next->op_targ;
7030 o->op_next->op_targ = 0;
7031 o->op_private |= OPpTARGET_MY;
7034 op_null(o->op_next);
7036 ignore_optimization:
7037 o->op_seq = PL_op_seqmax++;
7040 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7041 o->op_seq = PL_op_seqmax++;
7042 break; /* Scalar stub must produce undef. List stub is noop */
7046 if (o->op_targ == OP_NEXTSTATE
7047 || o->op_targ == OP_DBSTATE
7048 || o->op_targ == OP_SETSTATE)
7050 PL_curcop = ((COP*)o);
7052 /* XXX: We avoid setting op_seq here to prevent later calls
7053 to peep() from mistakenly concluding that optimisation
7054 has already occurred. This doesn't fix the real problem,
7055 though (See 20010220.007). AMS 20010719 */
7056 if (oldop && o->op_next) {
7057 oldop->op_next = o->op_next;
7065 if (oldop && o->op_next) {
7066 oldop->op_next = o->op_next;
7069 o->op_seq = PL_op_seqmax++;
7073 if (o->op_next->op_type == OP_RV2SV) {
7074 if (!(o->op_next->op_private & OPpDEREF)) {
7075 op_null(o->op_next);
7076 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7078 o->op_next = o->op_next->op_next;
7079 o->op_type = OP_GVSV;
7080 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7083 else if (o->op_next->op_type == OP_RV2AV) {
7084 OP* pop = o->op_next->op_next;
7086 if (pop && pop->op_type == OP_CONST &&
7087 (PL_op = pop->op_next) &&
7088 pop->op_next->op_type == OP_AELEM &&
7089 !(pop->op_next->op_private &
7090 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7091 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7096 op_null(o->op_next);
7097 op_null(pop->op_next);
7099 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7100 o->op_next = pop->op_next->op_next;
7101 o->op_type = OP_AELEMFAST;
7102 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7103 o->op_private = (U8)i;
7108 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7110 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7111 /* XXX could check prototype here instead of just carping */
7112 SV *sv = sv_newmortal();
7113 gv_efullname3(sv, gv, Nullch);
7114 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7115 "%s() called too early to check prototype",
7119 else if (o->op_next->op_type == OP_READLINE
7120 && o->op_next->op_next->op_type == OP_CONCAT
7121 && (o->op_next->op_next->op_flags & OPf_STACKED))
7123 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7124 o->op_type = OP_RCATLINE;
7125 o->op_flags |= OPf_STACKED;
7126 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7127 op_null(o->op_next->op_next);
7128 op_null(o->op_next);
7131 o->op_seq = PL_op_seqmax++;
7144 o->op_seq = PL_op_seqmax++;
7145 while (cLOGOP->op_other->op_type == OP_NULL)
7146 cLOGOP->op_other = cLOGOP->op_other->op_next;
7147 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7152 o->op_seq = PL_op_seqmax++;
7153 while (cLOOP->op_redoop->op_type == OP_NULL)
7154 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7155 peep(cLOOP->op_redoop);
7156 while (cLOOP->op_nextop->op_type == OP_NULL)
7157 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7158 peep(cLOOP->op_nextop);
7159 while (cLOOP->op_lastop->op_type == OP_NULL)
7160 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7161 peep(cLOOP->op_lastop);
7167 o->op_seq = PL_op_seqmax++;
7168 while (cPMOP->op_pmreplstart &&
7169 cPMOP->op_pmreplstart->op_type == OP_NULL)
7170 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7171 peep(cPMOP->op_pmreplstart);
7175 o->op_seq = PL_op_seqmax++;
7176 if (ckWARN(WARN_SYNTAX) && o->op_next
7177 && o->op_next->op_type == OP_NEXTSTATE) {
7178 if (o->op_next->op_sibling &&
7179 o->op_next->op_sibling->op_type != OP_EXIT &&
7180 o->op_next->op_sibling->op_type != OP_WARN &&
7181 o->op_next->op_sibling->op_type != OP_DIE) {
7182 line_t oldline = CopLINE(PL_curcop);
7184 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7185 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7186 "Statement unlikely to be reached");
7187 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7188 "\t(Maybe you meant system() when you said exec()?)\n");
7189 CopLINE_set(PL_curcop, oldline);
7200 o->op_seq = PL_op_seqmax++;
7202 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7205 /* Make the CONST have a shared SV */
7206 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7207 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7208 key = SvPV(sv, keylen);
7209 lexname = newSVpvn_share(key,
7210 SvUTF8(sv) ? -(I32)keylen : keylen,
7219 o->op_seq = PL_op_seqmax++;
7229 char* Perl_custom_op_name(pTHX_ OP* o)
7231 IV index = PTR2IV(o->op_ppaddr);
7235 if (!PL_custom_op_names) /* This probably shouldn't happen */
7236 return PL_op_name[OP_CUSTOM];
7238 keysv = sv_2mortal(newSViv(index));
7240 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7242 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7244 return SvPV_nolen(HeVAL(he));
7247 char* Perl_custom_op_desc(pTHX_ OP* o)
7249 IV index = PTR2IV(o->op_ppaddr);
7253 if (!PL_custom_op_descs)
7254 return PL_op_desc[OP_CUSTOM];
7256 keysv = sv_2mortal(newSViv(index));
7258 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7260 return PL_op_desc[OP_CUSTOM];
7262 return SvPV_nolen(HeVAL(he));
7268 /* Efficient sub that returns a constant scalar value. */
7270 const_sv_xsub(pTHX_ CV* cv)
7275 Perl_croak(aTHX_ "usage: %s::%s()",
7276 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7280 ST(0) = (SV*)XSANY.any_ptr;