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 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
616 if ((I32)po < PL_padix)
621 Perl_pad_swipe(pTHX_ PADOFFSET po)
623 if (AvARRAY(PL_comppad) != PL_curpad)
624 Perl_croak(aTHX_ "panic: pad_swipe curpad");
626 Perl_croak(aTHX_ "panic: pad_swipe po");
627 #ifdef USE_5005THREADS
628 DEBUG_X(PerlIO_printf(Perl_debug_log,
629 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
630 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
632 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
633 PTR2UV(PL_curpad), (IV)po));
634 #endif /* USE_5005THREADS */
635 SvPADTMP_off(PL_curpad[po]);
636 PL_curpad[po] = NEWSV(1107,0);
637 SvPADTMP_on(PL_curpad[po]);
638 if ((I32)po < PL_padix)
642 /* XXX pad_reset() is currently disabled because it results in serious bugs.
643 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
644 * on the stack by OPs that use them, there are several ways to get an alias
645 * to a shared TARG. Such an alias will change randomly and unpredictably.
646 * We avoid doing this until we can think of a Better Way.
651 #ifdef USE_BROKEN_PAD_RESET
654 if (AvARRAY(PL_comppad) != PL_curpad)
655 Perl_croak(aTHX_ "panic: pad_reset curpad");
656 #ifdef USE_5005THREADS
657 DEBUG_X(PerlIO_printf(Perl_debug_log,
658 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
659 PTR2UV(thr), PTR2UV(PL_curpad)));
661 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
663 #endif /* USE_5005THREADS */
664 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
665 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
666 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
667 SvPADTMP_off(PL_curpad[po]);
669 PL_padix = PL_padix_floor;
672 PL_pad_reset_pending = FALSE;
675 #ifdef USE_5005THREADS
676 /* find_threadsv is not reentrant */
678 Perl_find_threadsv(pTHX_ const char *name)
683 /* We currently only handle names of a single character */
684 p = strchr(PL_threadsv_names, *name);
687 key = p - PL_threadsv_names;
688 MUTEX_LOCK(&thr->mutex);
689 svp = av_fetch(thr->threadsv, key, FALSE);
691 MUTEX_UNLOCK(&thr->mutex);
693 SV *sv = NEWSV(0, 0);
694 av_store(thr->threadsv, key, sv);
695 thr->threadsvp = AvARRAY(thr->threadsv);
696 MUTEX_UNLOCK(&thr->mutex);
698 * Some magic variables used to be automagically initialised
699 * in gv_fetchpv. Those which are now per-thread magicals get
700 * initialised here instead.
706 sv_setpv(sv, "\034");
707 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
712 PL_sawampersand = TRUE;
726 /* XXX %! tied to Errno.pm needs to be added here.
727 * See gv_fetchpv(). */
731 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
733 DEBUG_S(PerlIO_printf(Perl_error_log,
734 "find_threadsv: new SV %p for $%s%c\n",
735 sv, (*name < 32) ? "^" : "",
736 (*name < 32) ? toCTRL(*name) : *name));
740 #endif /* USE_5005THREADS */
745 Perl_op_free(pTHX_ OP *o)
747 register OP *kid, *nextkid;
750 if (!o || o->op_seq == (U16)-1)
753 if (o->op_private & OPpREFCOUNTED) {
754 switch (o->op_type) {
762 if (OpREFCNT_dec(o)) {
773 if (o->op_flags & OPf_KIDS) {
774 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
775 nextkid = kid->op_sibling; /* Get before next freeing kid */
781 type = (OPCODE)o->op_targ;
783 /* COP* is not cleared by op_clear() so that we may track line
784 * numbers etc even after null() */
785 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
793 Perl_op_clear(pTHX_ OP *o)
796 switch (o->op_type) {
797 case OP_NULL: /* Was holding old type, if any. */
798 case OP_ENTEREVAL: /* Was holding hints. */
799 #ifdef USE_5005THREADS
800 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
804 #ifdef USE_5005THREADS
806 if (!(o->op_flags & OPf_SPECIAL))
809 #endif /* USE_5005THREADS */
811 if (!(o->op_flags & OPf_REF)
812 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
819 if (cPADOPo->op_padix > 0) {
822 pad_swipe(cPADOPo->op_padix);
823 /* No GvIN_PAD_off(gv) here, because other references may still
824 * exist on the pad */
827 cPADOPo->op_padix = 0;
830 SvREFCNT_dec(cSVOPo->op_sv);
831 cSVOPo->op_sv = Nullsv;
834 case OP_METHOD_NAMED:
836 SvREFCNT_dec(cSVOPo->op_sv);
837 cSVOPo->op_sv = Nullsv;
843 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
847 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
848 SvREFCNT_dec(cSVOPo->op_sv);
849 cSVOPo->op_sv = Nullsv;
852 Safefree(cPVOPo->op_pv);
853 cPVOPo->op_pv = Nullch;
857 op_free(cPMOPo->op_pmreplroot);
861 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
863 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
864 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
865 /* No GvIN_PAD_off(gv) here, because other references may still
866 * exist on the pad */
871 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
878 HV *pmstash = PmopSTASH(cPMOPo);
879 if (pmstash && SvREFCNT(pmstash)) {
880 PMOP *pmop = HvPMROOT(pmstash);
881 PMOP *lastpmop = NULL;
883 if (cPMOPo == pmop) {
885 lastpmop->op_pmnext = pmop->op_pmnext;
887 HvPMROOT(pmstash) = pmop->op_pmnext;
891 pmop = pmop->op_pmnext;
894 PmopSTASH_free(cPMOPo);
896 cPMOPo->op_pmreplroot = Nullop;
897 /* we use the "SAFE" version of the PM_ macros here
898 * since sv_clean_all might release some PMOPs
899 * after PL_regex_padav has been cleared
900 * and the clearing of PL_regex_padav needs to
901 * happen before sv_clean_all
903 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
904 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
906 if(PL_regex_pad) { /* We could be in destruction */
907 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
908 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
909 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
916 if (o->op_targ > 0) {
917 pad_free(o->op_targ);
923 S_cop_free(pTHX_ COP* cop)
925 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
928 if (! specialWARN(cop->cop_warnings))
929 SvREFCNT_dec(cop->cop_warnings);
930 if (! specialCopIO(cop->cop_io)) {
934 char *s = SvPV(cop->cop_io,len);
935 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
938 SvREFCNT_dec(cop->cop_io);
944 Perl_op_null(pTHX_ OP *o)
946 if (o->op_type == OP_NULL)
949 o->op_targ = o->op_type;
950 o->op_type = OP_NULL;
951 o->op_ppaddr = PL_ppaddr[OP_NULL];
954 /* Contextualizers */
956 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
959 Perl_linklist(pTHX_ OP *o)
966 /* establish postfix order */
967 if (cUNOPo->op_first) {
968 o->op_next = LINKLIST(cUNOPo->op_first);
969 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
971 kid->op_next = LINKLIST(kid->op_sibling);
983 Perl_scalarkids(pTHX_ OP *o)
986 if (o && o->op_flags & OPf_KIDS) {
987 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
994 S_scalarboolean(pTHX_ OP *o)
996 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
997 if (ckWARN(WARN_SYNTAX)) {
998 line_t oldline = CopLINE(PL_curcop);
1000 if (PL_copline != NOLINE)
1001 CopLINE_set(PL_curcop, PL_copline);
1002 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1003 CopLINE_set(PL_curcop, oldline);
1010 Perl_scalar(pTHX_ OP *o)
1014 /* assumes no premature commitment */
1015 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1016 || o->op_type == OP_RETURN)
1021 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1023 switch (o->op_type) {
1025 scalar(cBINOPo->op_first);
1030 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1034 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1035 if (!kPMOP->op_pmreplroot)
1036 deprecate_old("implicit split to @_");
1044 if (o->op_flags & OPf_KIDS) {
1045 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1051 kid = cLISTOPo->op_first;
1053 while ((kid = kid->op_sibling)) {
1054 if (kid->op_sibling)
1059 WITH_THR(PL_curcop = &PL_compiling);
1064 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1065 if (kid->op_sibling)
1070 WITH_THR(PL_curcop = &PL_compiling);
1073 if (ckWARN(WARN_VOID))
1074 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1080 Perl_scalarvoid(pTHX_ OP *o)
1087 if (o->op_type == OP_NEXTSTATE
1088 || o->op_type == OP_SETSTATE
1089 || o->op_type == OP_DBSTATE
1090 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1091 || o->op_targ == OP_SETSTATE
1092 || o->op_targ == OP_DBSTATE)))
1093 PL_curcop = (COP*)o; /* for warning below */
1095 /* assumes no premature commitment */
1096 want = o->op_flags & OPf_WANT;
1097 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1098 || o->op_type == OP_RETURN)
1103 if ((o->op_private & OPpTARGET_MY)
1104 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1106 return scalar(o); /* As if inside SASSIGN */
1109 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1111 switch (o->op_type) {
1113 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1117 if (o->op_flags & OPf_STACKED)
1121 if (o->op_private == 4)
1163 case OP_GETSOCKNAME:
1164 case OP_GETPEERNAME:
1169 case OP_GETPRIORITY:
1192 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1193 useless = OP_DESC(o);
1200 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1201 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1202 useless = "a variable";
1207 if (cSVOPo->op_private & OPpCONST_STRICT)
1208 no_bareword_allowed(o);
1210 if (ckWARN(WARN_VOID)) {
1211 useless = "a constant";
1212 /* the constants 0 and 1 are permitted as they are
1213 conventionally used as dummies in constructs like
1214 1 while some_condition_with_side_effects; */
1215 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1217 else if (SvPOK(sv)) {
1218 /* perl4's way of mixing documentation and code
1219 (before the invention of POD) was based on a
1220 trick to mix nroff and perl code. The trick was
1221 built upon these three nroff macros being used in
1222 void context. The pink camel has the details in
1223 the script wrapman near page 319. */
1224 if (strnEQ(SvPVX(sv), "di", 2) ||
1225 strnEQ(SvPVX(sv), "ds", 2) ||
1226 strnEQ(SvPVX(sv), "ig", 2))
1231 op_null(o); /* don't execute or even remember it */
1235 o->op_type = OP_PREINC; /* pre-increment is faster */
1236 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1240 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1241 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1248 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1253 if (o->op_flags & OPf_STACKED)
1260 if (!(o->op_flags & OPf_KIDS))
1269 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1276 /* all requires must return a boolean value */
1277 o->op_flags &= ~OPf_WANT;
1282 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1283 if (!kPMOP->op_pmreplroot)
1284 deprecate_old("implicit split to @_");
1288 if (useless && ckWARN(WARN_VOID))
1289 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1294 Perl_listkids(pTHX_ OP *o)
1297 if (o && o->op_flags & OPf_KIDS) {
1298 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1305 Perl_list(pTHX_ OP *o)
1309 /* assumes no premature commitment */
1310 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1311 || o->op_type == OP_RETURN)
1316 if ((o->op_private & OPpTARGET_MY)
1317 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1319 return o; /* As if inside SASSIGN */
1322 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1324 switch (o->op_type) {
1327 list(cBINOPo->op_first);
1332 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1340 if (!(o->op_flags & OPf_KIDS))
1342 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1343 list(cBINOPo->op_first);
1344 return gen_constant_list(o);
1351 kid = cLISTOPo->op_first;
1353 while ((kid = kid->op_sibling)) {
1354 if (kid->op_sibling)
1359 WITH_THR(PL_curcop = &PL_compiling);
1363 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1364 if (kid->op_sibling)
1369 WITH_THR(PL_curcop = &PL_compiling);
1372 /* all requires must return a boolean value */
1373 o->op_flags &= ~OPf_WANT;
1380 Perl_scalarseq(pTHX_ OP *o)
1385 if (o->op_type == OP_LINESEQ ||
1386 o->op_type == OP_SCOPE ||
1387 o->op_type == OP_LEAVE ||
1388 o->op_type == OP_LEAVETRY)
1390 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1391 if (kid->op_sibling) {
1395 PL_curcop = &PL_compiling;
1397 o->op_flags &= ~OPf_PARENS;
1398 if (PL_hints & HINT_BLOCK_SCOPE)
1399 o->op_flags |= OPf_PARENS;
1402 o = newOP(OP_STUB, 0);
1407 S_modkids(pTHX_ OP *o, I32 type)
1410 if (o && o->op_flags & OPf_KIDS) {
1411 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1418 Perl_mod(pTHX_ OP *o, I32 type)
1423 if (!o || PL_error_count)
1426 if ((o->op_private & OPpTARGET_MY)
1427 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1432 switch (o->op_type) {
1437 if (!(o->op_private & (OPpCONST_ARYBASE)))
1439 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1440 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1444 SAVEI32(PL_compiling.cop_arybase);
1445 PL_compiling.cop_arybase = 0;
1447 else if (type == OP_REFGEN)
1450 Perl_croak(aTHX_ "That use of $[ is unsupported");
1453 if (o->op_flags & OPf_PARENS)
1457 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1458 !(o->op_flags & OPf_STACKED)) {
1459 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1460 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1461 assert(cUNOPo->op_first->op_type == OP_NULL);
1462 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1465 else if (o->op_private & OPpENTERSUB_NOMOD)
1467 else { /* lvalue subroutine call */
1468 o->op_private |= OPpLVAL_INTRO;
1469 PL_modcount = RETURN_UNLIMITED_NUMBER;
1470 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1471 /* Backward compatibility mode: */
1472 o->op_private |= OPpENTERSUB_INARGS;
1475 else { /* Compile-time error message: */
1476 OP *kid = cUNOPo->op_first;
1480 if (kid->op_type == OP_PUSHMARK)
1482 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1484 "panic: unexpected lvalue entersub "
1485 "args: type/targ %ld:%"UVuf,
1486 (long)kid->op_type, (UV)kid->op_targ);
1487 kid = kLISTOP->op_first;
1489 while (kid->op_sibling)
1490 kid = kid->op_sibling;
1491 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1493 if (kid->op_type == OP_METHOD_NAMED
1494 || kid->op_type == OP_METHOD)
1498 NewOp(1101, newop, 1, UNOP);
1499 newop->op_type = OP_RV2CV;
1500 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1501 newop->op_first = Nullop;
1502 newop->op_next = (OP*)newop;
1503 kid->op_sibling = (OP*)newop;
1504 newop->op_private |= OPpLVAL_INTRO;
1508 if (kid->op_type != OP_RV2CV)
1510 "panic: unexpected lvalue entersub "
1511 "entry via type/targ %ld:%"UVuf,
1512 (long)kid->op_type, (UV)kid->op_targ);
1513 kid->op_private |= OPpLVAL_INTRO;
1514 break; /* Postpone until runtime */
1518 kid = kUNOP->op_first;
1519 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1520 kid = kUNOP->op_first;
1521 if (kid->op_type == OP_NULL)
1523 "Unexpected constant lvalue entersub "
1524 "entry via type/targ %ld:%"UVuf,
1525 (long)kid->op_type, (UV)kid->op_targ);
1526 if (kid->op_type != OP_GV) {
1527 /* Restore RV2CV to check lvalueness */
1529 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1530 okid->op_next = kid->op_next;
1531 kid->op_next = okid;
1534 okid->op_next = Nullop;
1535 okid->op_type = OP_RV2CV;
1537 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1538 okid->op_private |= OPpLVAL_INTRO;
1542 cv = GvCV(kGVOP_gv);
1552 /* grep, foreach, subcalls, refgen */
1553 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1555 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1556 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1558 : (o->op_type == OP_ENTERSUB
1559 ? "non-lvalue subroutine call"
1561 type ? PL_op_desc[type] : "local"));
1575 case OP_RIGHT_SHIFT:
1584 if (!(o->op_flags & OPf_STACKED))
1590 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1596 if (!type && cUNOPo->op_first->op_type != OP_GV)
1597 Perl_croak(aTHX_ "Can't localize through a reference");
1598 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1599 PL_modcount = RETURN_UNLIMITED_NUMBER;
1600 return o; /* Treat \(@foo) like ordinary list. */
1604 if (scalar_mod_type(o, type))
1606 ref(cUNOPo->op_first, o->op_type);
1610 if (type == OP_LEAVESUBLV)
1611 o->op_private |= OPpMAYBE_LVSUB;
1616 PL_modcount = RETURN_UNLIMITED_NUMBER;
1619 if (!type && cUNOPo->op_first->op_type != OP_GV)
1620 Perl_croak(aTHX_ "Can't localize through a reference");
1621 ref(cUNOPo->op_first, o->op_type);
1625 PL_hints |= HINT_BLOCK_SCOPE;
1636 PL_modcount = RETURN_UNLIMITED_NUMBER;
1637 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1638 return o; /* Treat \(@foo) like ordinary list. */
1639 if (scalar_mod_type(o, type))
1641 if (type == OP_LEAVESUBLV)
1642 o->op_private |= OPpMAYBE_LVSUB;
1647 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1648 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1651 #ifdef USE_5005THREADS
1653 PL_modcount++; /* XXX ??? */
1655 #endif /* USE_5005THREADS */
1661 if (type != OP_SASSIGN)
1665 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1670 if (type == OP_LEAVESUBLV)
1671 o->op_private |= OPpMAYBE_LVSUB;
1673 pad_free(o->op_targ);
1674 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1675 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1676 if (o->op_flags & OPf_KIDS)
1677 mod(cBINOPo->op_first->op_sibling, type);
1682 ref(cBINOPo->op_first, o->op_type);
1683 if (type == OP_ENTERSUB &&
1684 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1685 o->op_private |= OPpLVAL_DEFER;
1686 if (type == OP_LEAVESUBLV)
1687 o->op_private |= OPpMAYBE_LVSUB;
1695 if (o->op_flags & OPf_KIDS)
1696 mod(cLISTOPo->op_last, type);
1700 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1702 else if (!(o->op_flags & OPf_KIDS))
1704 if (o->op_targ != OP_LIST) {
1705 mod(cBINOPo->op_first, type);
1710 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1715 if (type != OP_LEAVESUBLV)
1717 break; /* mod()ing was handled by ck_return() */
1720 /* [20011101.069] File test operators interpret OPf_REF to mean that
1721 their argument is a filehandle; thus \stat(".") should not set
1723 if (type == OP_REFGEN &&
1724 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1727 if (type != OP_LEAVESUBLV)
1728 o->op_flags |= OPf_MOD;
1730 if (type == OP_AASSIGN || type == OP_SASSIGN)
1731 o->op_flags |= OPf_SPECIAL|OPf_REF;
1733 o->op_private |= OPpLVAL_INTRO;
1734 o->op_flags &= ~OPf_SPECIAL;
1735 PL_hints |= HINT_BLOCK_SCOPE;
1737 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1738 && type != OP_LEAVESUBLV)
1739 o->op_flags |= OPf_REF;
1744 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1748 if (o->op_type == OP_RV2GV)
1772 case OP_RIGHT_SHIFT:
1791 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1793 switch (o->op_type) {
1801 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1814 Perl_refkids(pTHX_ OP *o, I32 type)
1817 if (o && o->op_flags & OPf_KIDS) {
1818 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1825 Perl_ref(pTHX_ OP *o, I32 type)
1829 if (!o || PL_error_count)
1832 switch (o->op_type) {
1834 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1835 !(o->op_flags & OPf_STACKED)) {
1836 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1837 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1838 assert(cUNOPo->op_first->op_type == OP_NULL);
1839 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1840 o->op_flags |= OPf_SPECIAL;
1845 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1849 if (type == OP_DEFINED)
1850 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1851 ref(cUNOPo->op_first, o->op_type);
1854 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1855 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1856 : type == OP_RV2HV ? OPpDEREF_HV
1858 o->op_flags |= OPf_MOD;
1863 o->op_flags |= OPf_MOD; /* XXX ??? */
1868 o->op_flags |= OPf_REF;
1871 if (type == OP_DEFINED)
1872 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1873 ref(cUNOPo->op_first, o->op_type);
1878 o->op_flags |= OPf_REF;
1883 if (!(o->op_flags & OPf_KIDS))
1885 ref(cBINOPo->op_first, type);
1889 ref(cBINOPo->op_first, o->op_type);
1890 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1891 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1892 : type == OP_RV2HV ? OPpDEREF_HV
1894 o->op_flags |= OPf_MOD;
1902 if (!(o->op_flags & OPf_KIDS))
1904 ref(cLISTOPo->op_last, type);
1914 S_dup_attrlist(pTHX_ OP *o)
1918 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1919 * where the first kid is OP_PUSHMARK and the remaining ones
1920 * are OP_CONST. We need to push the OP_CONST values.
1922 if (o->op_type == OP_CONST)
1923 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1925 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1926 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1927 if (o->op_type == OP_CONST)
1928 rop = append_elem(OP_LIST, rop,
1929 newSVOP(OP_CONST, o->op_flags,
1930 SvREFCNT_inc(cSVOPo->op_sv)));
1937 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1941 /* fake up C<use attributes $pkg,$rv,@attrs> */
1942 ENTER; /* need to protect against side-effects of 'use' */
1945 stashsv = newSVpv(HvNAME(stash), 0);
1947 stashsv = &PL_sv_no;
1949 #define ATTRSMODULE "attributes"
1950 #define ATTRSMODULE_PM "attributes.pm"
1954 /* Don't force the C<use> if we don't need it. */
1955 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1956 sizeof(ATTRSMODULE_PM)-1, 0);
1957 if (svp && *svp != &PL_sv_undef)
1958 ; /* already in %INC */
1960 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1961 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1965 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1966 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1968 prepend_elem(OP_LIST,
1969 newSVOP(OP_CONST, 0, stashsv),
1970 prepend_elem(OP_LIST,
1971 newSVOP(OP_CONST, 0,
1973 dup_attrlist(attrs))));
1979 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1981 OP *pack, *imop, *arg;
1987 assert(target->op_type == OP_PADSV ||
1988 target->op_type == OP_PADHV ||
1989 target->op_type == OP_PADAV);
1991 /* Ensure that attributes.pm is loaded. */
1992 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1994 /* Need package name for method call. */
1995 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1997 /* Build up the real arg-list. */
1999 stashsv = newSVpv(HvNAME(stash), 0);
2001 stashsv = &PL_sv_no;
2002 arg = newOP(OP_PADSV, 0);
2003 arg->op_targ = target->op_targ;
2004 arg = prepend_elem(OP_LIST,
2005 newSVOP(OP_CONST, 0, stashsv),
2006 prepend_elem(OP_LIST,
2007 newUNOP(OP_REFGEN, 0,
2008 mod(arg, OP_REFGEN)),
2009 dup_attrlist(attrs)));
2011 /* Fake up a method call to import */
2012 meth = newSVpvn("import", 6);
2013 (void)SvUPGRADE(meth, SVt_PVIV);
2014 (void)SvIOK_on(meth);
2015 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2016 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2017 append_elem(OP_LIST,
2018 prepend_elem(OP_LIST, pack, list(arg)),
2019 newSVOP(OP_METHOD_NAMED, 0, meth)));
2020 imop->op_private |= OPpENTERSUB_NOMOD;
2022 /* Combine the ops. */
2023 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2027 =notfor apidoc apply_attrs_string
2029 Attempts to apply a list of attributes specified by the C<attrstr> and
2030 C<len> arguments to the subroutine identified by the C<cv> argument which
2031 is expected to be associated with the package identified by the C<stashpv>
2032 argument (see L<attributes>). It gets this wrong, though, in that it
2033 does not correctly identify the boundaries of the individual attribute
2034 specifications within C<attrstr>. This is not really intended for the
2035 public API, but has to be listed here for systems such as AIX which
2036 need an explicit export list for symbols. (It's called from XS code
2037 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2038 to respect attribute syntax properly would be welcome.
2044 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2045 char *attrstr, STRLEN len)
2050 len = strlen(attrstr);
2054 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2056 char *sstr = attrstr;
2057 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2058 attrs = append_elem(OP_LIST, attrs,
2059 newSVOP(OP_CONST, 0,
2060 newSVpvn(sstr, attrstr-sstr)));
2064 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2065 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2066 Nullsv, prepend_elem(OP_LIST,
2067 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2068 prepend_elem(OP_LIST,
2069 newSVOP(OP_CONST, 0,
2075 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2080 if (!o || PL_error_count)
2084 if (type == OP_LIST) {
2085 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2086 my_kid(kid, attrs, imopsp);
2087 } else if (type == OP_UNDEF) {
2089 } else if (type == OP_RV2SV || /* "our" declaration */
2091 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2092 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2093 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
2094 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
2096 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2098 PL_in_my_stash = Nullhv;
2099 apply_attrs(GvSTASH(gv),
2100 (type == OP_RV2SV ? GvSV(gv) :
2101 type == OP_RV2AV ? (SV*)GvAV(gv) :
2102 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2105 o->op_private |= OPpOUR_INTRO;
2108 else if (type != OP_PADSV &&
2111 type != OP_PUSHMARK)
2113 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2115 PL_in_my == KEY_our ? "our" : "my"));
2118 else if (attrs && type != OP_PUSHMARK) {
2123 PL_in_my_stash = Nullhv;
2125 /* check for C<my Dog $spot> when deciding package */
2126 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2127 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2128 stash = SvSTASH(*namesvp);
2130 stash = PL_curstash;
2131 apply_attrs_my(stash, o, attrs, imopsp);
2133 o->op_flags |= OPf_MOD;
2134 o->op_private |= OPpLVAL_INTRO;
2139 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2142 int maybe_scalar = 0;
2144 if (o->op_flags & OPf_PARENS)
2150 o = my_kid(o, attrs, &rops);
2152 if (maybe_scalar && o->op_type == OP_PADSV) {
2153 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2154 o->op_private |= OPpLVAL_INTRO;
2157 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2160 PL_in_my_stash = Nullhv;
2165 Perl_my(pTHX_ OP *o)
2167 return my_attrs(o, Nullop);
2171 Perl_sawparens(pTHX_ OP *o)
2174 o->op_flags |= OPf_PARENS;
2179 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2183 if (ckWARN(WARN_MISC) &&
2184 (left->op_type == OP_RV2AV ||
2185 left->op_type == OP_RV2HV ||
2186 left->op_type == OP_PADAV ||
2187 left->op_type == OP_PADHV)) {
2188 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2189 right->op_type == OP_TRANS)
2190 ? right->op_type : OP_MATCH];
2191 const char *sample = ((left->op_type == OP_RV2AV ||
2192 left->op_type == OP_PADAV)
2193 ? "@array" : "%hash");
2194 Perl_warner(aTHX_ packWARN(WARN_MISC),
2195 "Applying %s to %s will act on scalar(%s)",
2196 desc, sample, sample);
2199 if (right->op_type == OP_CONST &&
2200 cSVOPx(right)->op_private & OPpCONST_BARE &&
2201 cSVOPx(right)->op_private & OPpCONST_STRICT)
2203 no_bareword_allowed(right);
2206 if (!(right->op_flags & OPf_STACKED) &&
2207 (right->op_type == OP_MATCH ||
2208 right->op_type == OP_SUBST ||
2209 right->op_type == OP_TRANS)) {
2210 right->op_flags |= OPf_STACKED;
2211 if (right->op_type != OP_MATCH &&
2212 ! (right->op_type == OP_TRANS &&
2213 right->op_private & OPpTRANS_IDENTICAL))
2214 left = mod(left, right->op_type);
2215 if (right->op_type == OP_TRANS)
2216 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2218 o = prepend_elem(right->op_type, scalar(left), right);
2220 return newUNOP(OP_NOT, 0, scalar(o));
2224 return bind_match(type, left,
2225 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2229 Perl_invert(pTHX_ OP *o)
2233 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2234 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2238 Perl_scope(pTHX_ OP *o)
2241 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2242 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2243 o->op_type = OP_LEAVE;
2244 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2247 if (o->op_type == OP_LINESEQ) {
2249 o->op_type = OP_SCOPE;
2250 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2251 kid = ((LISTOP*)o)->op_first;
2252 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2256 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2263 Perl_save_hints(pTHX)
2266 SAVESPTR(GvHV(PL_hintgv));
2267 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2268 SAVEFREESV(GvHV(PL_hintgv));
2272 Perl_block_start(pTHX_ int full)
2274 int retval = PL_savestack_ix;
2276 SAVEI32(PL_comppad_name_floor);
2277 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2279 PL_comppad_name_fill = PL_comppad_name_floor;
2280 if (PL_comppad_name_floor < 0)
2281 PL_comppad_name_floor = 0;
2282 SAVEI32(PL_min_intro_pending);
2283 SAVEI32(PL_max_intro_pending);
2284 PL_min_intro_pending = 0;
2285 SAVEI32(PL_comppad_name_fill);
2286 SAVEI32(PL_padix_floor);
2287 PL_padix_floor = PL_padix;
2288 PL_pad_reset_pending = FALSE;
2290 PL_hints &= ~HINT_BLOCK_SCOPE;
2291 SAVESPTR(PL_compiling.cop_warnings);
2292 if (! specialWARN(PL_compiling.cop_warnings)) {
2293 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2294 SAVEFREESV(PL_compiling.cop_warnings) ;
2296 SAVESPTR(PL_compiling.cop_io);
2297 if (! specialCopIO(PL_compiling.cop_io)) {
2298 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2299 SAVEFREESV(PL_compiling.cop_io) ;
2305 Perl_block_end(pTHX_ I32 floor, OP *seq)
2307 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2308 line_t copline = PL_copline;
2309 /* there should be a nextstate in every block */
2310 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2311 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2313 PL_pad_reset_pending = FALSE;
2314 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2316 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2317 pad_leavemy(PL_comppad_name_fill);
2325 #ifdef USE_5005THREADS
2326 OP *o = newOP(OP_THREADSV, 0);
2327 o->op_targ = find_threadsv("_");
2330 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2331 #endif /* USE_5005THREADS */
2335 Perl_newPROG(pTHX_ OP *o)
2340 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2341 ((PL_in_eval & EVAL_KEEPERR)
2342 ? OPf_SPECIAL : 0), o);
2343 PL_eval_start = linklist(PL_eval_root);
2344 PL_eval_root->op_private |= OPpREFCOUNTED;
2345 OpREFCNT_set(PL_eval_root, 1);
2346 PL_eval_root->op_next = 0;
2347 CALL_PEEP(PL_eval_start);
2352 PL_main_root = scope(sawparens(scalarvoid(o)));
2353 PL_curcop = &PL_compiling;
2354 PL_main_start = LINKLIST(PL_main_root);
2355 PL_main_root->op_private |= OPpREFCOUNTED;
2356 OpREFCNT_set(PL_main_root, 1);
2357 PL_main_root->op_next = 0;
2358 CALL_PEEP(PL_main_start);
2361 /* Register with debugger */
2363 CV *cv = get_cv("DB::postponed", FALSE);
2367 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2369 call_sv((SV*)cv, G_DISCARD);
2376 Perl_localize(pTHX_ OP *o, I32 lex)
2378 if (o->op_flags & OPf_PARENS)
2381 if (ckWARN(WARN_PARENTHESIS)
2382 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2384 char *s = PL_bufptr;
2386 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2389 if (*s == ';' || *s == '=')
2390 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2391 "Parentheses missing around \"%s\" list",
2392 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2398 o = mod(o, OP_NULL); /* a bit kludgey */
2400 PL_in_my_stash = Nullhv;
2405 Perl_jmaybe(pTHX_ OP *o)
2407 if (o->op_type == OP_LIST) {
2409 #ifdef USE_5005THREADS
2410 o2 = newOP(OP_THREADSV, 0);
2411 o2->op_targ = find_threadsv(";");
2413 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2414 #endif /* USE_5005THREADS */
2415 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2421 Perl_fold_constants(pTHX_ register OP *o)
2424 I32 type = o->op_type;
2427 if (PL_opargs[type] & OA_RETSCALAR)
2429 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2430 o->op_targ = pad_alloc(type, SVs_PADTMP);
2432 /* integerize op, unless it happens to be C<-foo>.
2433 * XXX should pp_i_negate() do magic string negation instead? */
2434 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2435 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2436 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2438 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2441 if (!(PL_opargs[type] & OA_FOLDCONST))
2446 /* XXX might want a ck_negate() for this */
2447 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2459 /* XXX what about the numeric ops? */
2460 if (PL_hints & HINT_LOCALE)
2465 goto nope; /* Don't try to run w/ errors */
2467 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2468 if ((curop->op_type != OP_CONST ||
2469 (curop->op_private & OPpCONST_BARE)) &&
2470 curop->op_type != OP_LIST &&
2471 curop->op_type != OP_SCALAR &&
2472 curop->op_type != OP_NULL &&
2473 curop->op_type != OP_PUSHMARK)
2479 curop = LINKLIST(o);
2483 sv = *(PL_stack_sp--);
2484 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2485 pad_swipe(o->op_targ);
2486 else if (SvTEMP(sv)) { /* grab mortal temp? */
2487 (void)SvREFCNT_inc(sv);
2491 if (type == OP_RV2GV)
2492 return newGVOP(OP_GV, 0, (GV*)sv);
2494 /* try to smush double to int, but don't smush -2.0 to -2 */
2495 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2498 #ifdef PERL_PRESERVE_IVUV
2499 /* Only bother to attempt to fold to IV if
2500 most operators will benefit */
2504 return newSVOP(OP_CONST, 0, sv);
2512 Perl_gen_constant_list(pTHX_ register OP *o)
2515 I32 oldtmps_floor = PL_tmps_floor;
2519 return o; /* Don't attempt to run with errors */
2521 PL_op = curop = LINKLIST(o);
2528 PL_tmps_floor = oldtmps_floor;
2530 o->op_type = OP_RV2AV;
2531 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2532 o->op_seq = 0; /* needs to be revisited in peep() */
2533 curop = ((UNOP*)o)->op_first;
2534 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2541 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2543 if (!o || o->op_type != OP_LIST)
2544 o = newLISTOP(OP_LIST, 0, o, Nullop);
2546 o->op_flags &= ~OPf_WANT;
2548 if (!(PL_opargs[type] & OA_MARK))
2549 op_null(cLISTOPo->op_first);
2551 o->op_type = (OPCODE)type;
2552 o->op_ppaddr = PL_ppaddr[type];
2553 o->op_flags |= flags;
2555 o = CHECKOP(type, o);
2556 if (o->op_type != type)
2559 return fold_constants(o);
2562 /* List constructors */
2565 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2573 if (first->op_type != type
2574 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2576 return newLISTOP(type, 0, first, last);
2579 if (first->op_flags & OPf_KIDS)
2580 ((LISTOP*)first)->op_last->op_sibling = last;
2582 first->op_flags |= OPf_KIDS;
2583 ((LISTOP*)first)->op_first = last;
2585 ((LISTOP*)first)->op_last = last;
2590 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2598 if (first->op_type != type)
2599 return prepend_elem(type, (OP*)first, (OP*)last);
2601 if (last->op_type != type)
2602 return append_elem(type, (OP*)first, (OP*)last);
2604 first->op_last->op_sibling = last->op_first;
2605 first->op_last = last->op_last;
2606 first->op_flags |= (last->op_flags & OPf_KIDS);
2614 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2622 if (last->op_type == type) {
2623 if (type == OP_LIST) { /* already a PUSHMARK there */
2624 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2625 ((LISTOP*)last)->op_first->op_sibling = first;
2626 if (!(first->op_flags & OPf_PARENS))
2627 last->op_flags &= ~OPf_PARENS;
2630 if (!(last->op_flags & OPf_KIDS)) {
2631 ((LISTOP*)last)->op_last = first;
2632 last->op_flags |= OPf_KIDS;
2634 first->op_sibling = ((LISTOP*)last)->op_first;
2635 ((LISTOP*)last)->op_first = first;
2637 last->op_flags |= OPf_KIDS;
2641 return newLISTOP(type, 0, first, last);
2647 Perl_newNULLLIST(pTHX)
2649 return newOP(OP_STUB, 0);
2653 Perl_force_list(pTHX_ OP *o)
2655 if (!o || o->op_type != OP_LIST)
2656 o = newLISTOP(OP_LIST, 0, o, Nullop);
2662 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2666 NewOp(1101, listop, 1, LISTOP);
2668 listop->op_type = (OPCODE)type;
2669 listop->op_ppaddr = PL_ppaddr[type];
2672 listop->op_flags = (U8)flags;
2676 else if (!first && last)
2679 first->op_sibling = last;
2680 listop->op_first = first;
2681 listop->op_last = last;
2682 if (type == OP_LIST) {
2684 pushop = newOP(OP_PUSHMARK, 0);
2685 pushop->op_sibling = first;
2686 listop->op_first = pushop;
2687 listop->op_flags |= OPf_KIDS;
2689 listop->op_last = pushop;
2696 Perl_newOP(pTHX_ I32 type, I32 flags)
2699 NewOp(1101, o, 1, OP);
2700 o->op_type = (OPCODE)type;
2701 o->op_ppaddr = PL_ppaddr[type];
2702 o->op_flags = (U8)flags;
2705 o->op_private = (U8)(0 | (flags >> 8));
2706 if (PL_opargs[type] & OA_RETSCALAR)
2708 if (PL_opargs[type] & OA_TARGET)
2709 o->op_targ = pad_alloc(type, SVs_PADTMP);
2710 return CHECKOP(type, o);
2714 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2719 first = newOP(OP_STUB, 0);
2720 if (PL_opargs[type] & OA_MARK)
2721 first = force_list(first);
2723 NewOp(1101, unop, 1, UNOP);
2724 unop->op_type = (OPCODE)type;
2725 unop->op_ppaddr = PL_ppaddr[type];
2726 unop->op_first = first;
2727 unop->op_flags = flags | OPf_KIDS;
2728 unop->op_private = (U8)(1 | (flags >> 8));
2729 unop = (UNOP*) CHECKOP(type, unop);
2733 return fold_constants((OP *) unop);
2737 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2740 NewOp(1101, binop, 1, BINOP);
2743 first = newOP(OP_NULL, 0);
2745 binop->op_type = (OPCODE)type;
2746 binop->op_ppaddr = PL_ppaddr[type];
2747 binop->op_first = first;
2748 binop->op_flags = flags | OPf_KIDS;
2751 binop->op_private = (U8)(1 | (flags >> 8));
2754 binop->op_private = (U8)(2 | (flags >> 8));
2755 first->op_sibling = last;
2758 binop = (BINOP*)CHECKOP(type, binop);
2759 if (binop->op_next || binop->op_type != (OPCODE)type)
2762 binop->op_last = binop->op_first->op_sibling;
2764 return fold_constants((OP *)binop);
2768 uvcompare(const void *a, const void *b)
2770 if (*((UV *)a) < (*(UV *)b))
2772 if (*((UV *)a) > (*(UV *)b))
2774 if (*((UV *)a+1) < (*(UV *)b+1))
2776 if (*((UV *)a+1) > (*(UV *)b+1))
2782 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2784 SV *tstr = ((SVOP*)expr)->op_sv;
2785 SV *rstr = ((SVOP*)repl)->op_sv;
2788 U8 *t = (U8*)SvPV(tstr, tlen);
2789 U8 *r = (U8*)SvPV(rstr, rlen);
2796 register short *tbl;
2798 PL_hints |= HINT_BLOCK_SCOPE;
2799 complement = o->op_private & OPpTRANS_COMPLEMENT;
2800 del = o->op_private & OPpTRANS_DELETE;
2801 squash = o->op_private & OPpTRANS_SQUASH;
2804 o->op_private |= OPpTRANS_FROM_UTF;
2807 o->op_private |= OPpTRANS_TO_UTF;
2809 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2810 SV* listsv = newSVpvn("# comment\n",10);
2812 U8* tend = t + tlen;
2813 U8* rend = r + rlen;
2827 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2828 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2834 tsave = t = bytes_to_utf8(t, &len);
2837 if (!to_utf && rlen) {
2839 rsave = r = bytes_to_utf8(r, &len);
2843 /* There are several snags with this code on EBCDIC:
2844 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2845 2. scan_const() in toke.c has encoded chars in native encoding which makes
2846 ranges at least in EBCDIC 0..255 range the bottom odd.
2850 U8 tmpbuf[UTF8_MAXLEN+1];
2853 New(1109, cp, 2*tlen, UV);
2855 transv = newSVpvn("",0);
2857 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2859 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2861 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2865 cp[2*i+1] = cp[2*i];
2869 qsort(cp, i, 2*sizeof(UV), uvcompare);
2870 for (j = 0; j < i; j++) {
2872 diff = val - nextmin;
2874 t = uvuni_to_utf8(tmpbuf,nextmin);
2875 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2877 U8 range_mark = UTF_TO_NATIVE(0xff);
2878 t = uvuni_to_utf8(tmpbuf, val - 1);
2879 sv_catpvn(transv, (char *)&range_mark, 1);
2880 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2887 t = uvuni_to_utf8(tmpbuf,nextmin);
2888 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2890 U8 range_mark = UTF_TO_NATIVE(0xff);
2891 sv_catpvn(transv, (char *)&range_mark, 1);
2893 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2894 UNICODE_ALLOW_SUPER);
2895 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2896 t = (U8*)SvPVX(transv);
2897 tlen = SvCUR(transv);
2901 else if (!rlen && !del) {
2902 r = t; rlen = tlen; rend = tend;
2905 if ((!rlen && !del) || t == r ||
2906 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2908 o->op_private |= OPpTRANS_IDENTICAL;
2912 while (t < tend || tfirst <= tlast) {
2913 /* see if we need more "t" chars */
2914 if (tfirst > tlast) {
2915 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2917 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2919 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2926 /* now see if we need more "r" chars */
2927 if (rfirst > rlast) {
2929 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2931 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2933 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2942 rfirst = rlast = 0xffffffff;
2946 /* now see which range will peter our first, if either. */
2947 tdiff = tlast - tfirst;
2948 rdiff = rlast - rfirst;
2955 if (rfirst == 0xffffffff) {
2956 diff = tdiff; /* oops, pretend rdiff is infinite */
2958 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2959 (long)tfirst, (long)tlast);
2961 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2965 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2966 (long)tfirst, (long)(tfirst + diff),
2969 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2970 (long)tfirst, (long)rfirst);
2972 if (rfirst + diff > max)
2973 max = rfirst + diff;
2975 grows = (tfirst < rfirst &&
2976 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2988 else if (max > 0xff)
2993 Safefree(cPVOPo->op_pv);
2994 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2995 SvREFCNT_dec(listsv);
2997 SvREFCNT_dec(transv);
2999 if (!del && havefinal && rlen)
3000 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3001 newSVuv((UV)final), 0);
3004 o->op_private |= OPpTRANS_GROWS;
3016 tbl = (short*)cPVOPo->op_pv;
3018 Zero(tbl, 256, short);
3019 for (i = 0; i < (I32)tlen; i++)
3021 for (i = 0, j = 0; i < 256; i++) {
3023 if (j >= (I32)rlen) {
3032 if (i < 128 && r[j] >= 128)
3042 o->op_private |= OPpTRANS_IDENTICAL;
3044 else if (j >= (I32)rlen)
3047 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3048 tbl[0x100] = rlen - j;
3049 for (i=0; i < (I32)rlen - j; i++)
3050 tbl[0x101+i] = r[j+i];
3054 if (!rlen && !del) {
3057 o->op_private |= OPpTRANS_IDENTICAL;
3059 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3060 o->op_private |= OPpTRANS_IDENTICAL;
3062 for (i = 0; i < 256; i++)
3064 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3065 if (j >= (I32)rlen) {
3067 if (tbl[t[i]] == -1)
3073 if (tbl[t[i]] == -1) {
3074 if (t[i] < 128 && r[j] >= 128)
3081 o->op_private |= OPpTRANS_GROWS;
3089 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3093 NewOp(1101, pmop, 1, PMOP);
3094 pmop->op_type = (OPCODE)type;
3095 pmop->op_ppaddr = PL_ppaddr[type];
3096 pmop->op_flags = (U8)flags;
3097 pmop->op_private = (U8)(0 | (flags >> 8));
3099 if (PL_hints & HINT_RE_TAINT)
3100 pmop->op_pmpermflags |= PMf_RETAINT;
3101 if (PL_hints & HINT_LOCALE)
3102 pmop->op_pmpermflags |= PMf_LOCALE;
3103 pmop->op_pmflags = pmop->op_pmpermflags;
3108 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3109 repointer = av_pop((AV*)PL_regex_pad[0]);
3110 pmop->op_pmoffset = SvIV(repointer);
3111 SvREPADTMP_off(repointer);
3112 sv_setiv(repointer,0);
3114 repointer = newSViv(0);
3115 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3116 pmop->op_pmoffset = av_len(PL_regex_padav);
3117 PL_regex_pad = AvARRAY(PL_regex_padav);
3122 /* link into pm list */
3123 if (type != OP_TRANS && PL_curstash) {
3124 pmop->op_pmnext = HvPMROOT(PL_curstash);
3125 HvPMROOT(PL_curstash) = pmop;
3126 PmopSTASH_set(pmop,PL_curstash);
3133 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3137 I32 repl_has_vars = 0;
3139 if (o->op_type == OP_TRANS)
3140 return pmtrans(o, expr, repl);
3142 PL_hints |= HINT_BLOCK_SCOPE;
3145 if (expr->op_type == OP_CONST) {
3147 SV *pat = ((SVOP*)expr)->op_sv;
3148 char *p = SvPV(pat, plen);
3149 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3150 sv_setpvn(pat, "\\s+", 3);
3151 p = SvPV(pat, plen);
3152 pm->op_pmflags |= PMf_SKIPWHITE;
3155 pm->op_pmdynflags |= PMdf_UTF8;
3156 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3157 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3158 pm->op_pmflags |= PMf_WHITE;
3162 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3163 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3165 : OP_REGCMAYBE),0,expr);
3167 NewOp(1101, rcop, 1, LOGOP);
3168 rcop->op_type = OP_REGCOMP;
3169 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3170 rcop->op_first = scalar(expr);
3171 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3172 ? (OPf_SPECIAL | OPf_KIDS)
3174 rcop->op_private = 1;
3177 /* establish postfix order */
3178 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3180 rcop->op_next = expr;
3181 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3184 rcop->op_next = LINKLIST(expr);
3185 expr->op_next = (OP*)rcop;
3188 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3193 if (pm->op_pmflags & PMf_EVAL) {
3195 if (CopLINE(PL_curcop) < PL_multi_end)
3196 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3198 #ifdef USE_5005THREADS
3199 else if (repl->op_type == OP_THREADSV
3200 && strchr("&`'123456789+",
3201 PL_threadsv_names[repl->op_targ]))
3205 #endif /* USE_5005THREADS */
3206 else if (repl->op_type == OP_CONST)
3210 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3211 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3212 #ifdef USE_5005THREADS
3213 if (curop->op_type == OP_THREADSV) {
3215 if (strchr("&`'123456789+", curop->op_private))
3219 if (curop->op_type == OP_GV) {
3220 GV *gv = cGVOPx_gv(curop);
3222 if (strchr("&`'123456789+", *GvENAME(gv)))
3225 #endif /* USE_5005THREADS */
3226 else if (curop->op_type == OP_RV2CV)
3228 else if (curop->op_type == OP_RV2SV ||
3229 curop->op_type == OP_RV2AV ||
3230 curop->op_type == OP_RV2HV ||
3231 curop->op_type == OP_RV2GV) {
3232 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3235 else if (curop->op_type == OP_PADSV ||
3236 curop->op_type == OP_PADAV ||
3237 curop->op_type == OP_PADHV ||
3238 curop->op_type == OP_PADANY) {
3241 else if (curop->op_type == OP_PUSHRE)
3242 ; /* Okay here, dangerous in newASSIGNOP */
3252 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3253 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3254 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3255 prepend_elem(o->op_type, scalar(repl), o);
3258 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3259 pm->op_pmflags |= PMf_MAYBE_CONST;
3260 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3262 NewOp(1101, rcop, 1, LOGOP);
3263 rcop->op_type = OP_SUBSTCONT;
3264 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3265 rcop->op_first = scalar(repl);
3266 rcop->op_flags |= OPf_KIDS;
3267 rcop->op_private = 1;
3270 /* establish postfix order */
3271 rcop->op_next = LINKLIST(repl);
3272 repl->op_next = (OP*)rcop;
3274 pm->op_pmreplroot = scalar((OP*)rcop);
3275 pm->op_pmreplstart = LINKLIST(rcop);
3284 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3287 NewOp(1101, svop, 1, SVOP);
3288 svop->op_type = (OPCODE)type;
3289 svop->op_ppaddr = PL_ppaddr[type];
3291 svop->op_next = (OP*)svop;
3292 svop->op_flags = (U8)flags;
3293 if (PL_opargs[type] & OA_RETSCALAR)
3295 if (PL_opargs[type] & OA_TARGET)
3296 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3297 return CHECKOP(type, svop);
3301 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3304 NewOp(1101, padop, 1, PADOP);
3305 padop->op_type = (OPCODE)type;
3306 padop->op_ppaddr = PL_ppaddr[type];
3307 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3308 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3309 PL_curpad[padop->op_padix] = sv;
3311 padop->op_next = (OP*)padop;
3312 padop->op_flags = (U8)flags;
3313 if (PL_opargs[type] & OA_RETSCALAR)
3315 if (PL_opargs[type] & OA_TARGET)
3316 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3317 return CHECKOP(type, padop);
3321 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3325 return newPADOP(type, flags, SvREFCNT_inc(gv));
3327 return newSVOP(type, flags, SvREFCNT_inc(gv));
3332 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3335 NewOp(1101, pvop, 1, PVOP);
3336 pvop->op_type = (OPCODE)type;
3337 pvop->op_ppaddr = PL_ppaddr[type];
3339 pvop->op_next = (OP*)pvop;
3340 pvop->op_flags = (U8)flags;
3341 if (PL_opargs[type] & OA_RETSCALAR)
3343 if (PL_opargs[type] & OA_TARGET)
3344 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3345 return CHECKOP(type, pvop);
3349 Perl_package(pTHX_ OP *o)
3353 save_hptr(&PL_curstash);
3354 save_item(PL_curstname);
3359 name = SvPV(sv, len);
3360 PL_curstash = gv_stashpvn(name,len,TRUE);
3361 sv_setpvn(PL_curstname, name, len);
3365 deprecate("\"package\" with no arguments");
3366 sv_setpv(PL_curstname,"<none>");
3367 PL_curstash = Nullhv;
3369 PL_hints |= HINT_BLOCK_SCOPE;
3370 PL_copline = NOLINE;
3375 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3381 if (id->op_type != OP_CONST)
3382 Perl_croak(aTHX_ "Module name must be constant");
3386 if (version != Nullop) {
3387 SV *vesv = ((SVOP*)version)->op_sv;
3389 if (arg == Nullop && !SvNIOKp(vesv)) {
3396 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3397 Perl_croak(aTHX_ "Version number must be constant number");
3399 /* Make copy of id so we don't free it twice */
3400 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3402 /* Fake up a method call to VERSION */
3403 meth = newSVpvn("VERSION",7);
3404 sv_upgrade(meth, SVt_PVIV);
3405 (void)SvIOK_on(meth);
3406 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3407 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3408 append_elem(OP_LIST,
3409 prepend_elem(OP_LIST, pack, list(version)),
3410 newSVOP(OP_METHOD_NAMED, 0, meth)));
3414 /* Fake up an import/unimport */
3415 if (arg && arg->op_type == OP_STUB)
3416 imop = arg; /* no import on explicit () */
3417 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3418 imop = Nullop; /* use 5.0; */
3423 /* Make copy of id so we don't free it twice */
3424 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3426 /* Fake up a method call to import/unimport */
3427 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3428 (void)SvUPGRADE(meth, SVt_PVIV);
3429 (void)SvIOK_on(meth);
3430 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3431 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3432 append_elem(OP_LIST,
3433 prepend_elem(OP_LIST, pack, list(arg)),
3434 newSVOP(OP_METHOD_NAMED, 0, meth)));
3437 /* Fake up the BEGIN {}, which does its thing immediately. */
3439 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3442 append_elem(OP_LINESEQ,
3443 append_elem(OP_LINESEQ,
3444 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3445 newSTATEOP(0, Nullch, veop)),
3446 newSTATEOP(0, Nullch, imop) ));
3448 /* The "did you use incorrect case?" warning used to be here.
3449 * The problem is that on case-insensitive filesystems one
3450 * might get false positives for "use" (and "require"):
3451 * "use Strict" or "require CARP" will work. This causes
3452 * portability problems for the script: in case-strict
3453 * filesystems the script will stop working.
3455 * The "incorrect case" warning checked whether "use Foo"
3456 * imported "Foo" to your namespace, but that is wrong, too:
3457 * there is no requirement nor promise in the language that
3458 * a Foo.pm should or would contain anything in package "Foo".
3460 * There is very little Configure-wise that can be done, either:
3461 * the case-sensitivity of the build filesystem of Perl does not
3462 * help in guessing the case-sensitivity of the runtime environment.
3465 PL_hints |= HINT_BLOCK_SCOPE;
3466 PL_copline = NOLINE;
3471 =head1 Embedding Functions
3473 =for apidoc load_module
3475 Loads the module whose name is pointed to by the string part of name.
3476 Note that the actual module name, not its filename, should be given.
3477 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3478 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3479 (or 0 for no flags). ver, if specified, provides version semantics
3480 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3481 arguments can be used to specify arguments to the module's import()
3482 method, similar to C<use Foo::Bar VERSION LIST>.
3487 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3490 va_start(args, ver);
3491 vload_module(flags, name, ver, &args);
3495 #ifdef PERL_IMPLICIT_CONTEXT
3497 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3501 va_start(args, ver);
3502 vload_module(flags, name, ver, &args);
3508 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3510 OP *modname, *veop, *imop;
3512 modname = newSVOP(OP_CONST, 0, name);
3513 modname->op_private |= OPpCONST_BARE;
3515 veop = newSVOP(OP_CONST, 0, ver);
3519 if (flags & PERL_LOADMOD_NOIMPORT) {
3520 imop = sawparens(newNULLLIST());
3522 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3523 imop = va_arg(*args, OP*);
3528 sv = va_arg(*args, SV*);
3530 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3531 sv = va_arg(*args, SV*);
3535 line_t ocopline = PL_copline;
3536 int oexpect = PL_expect;
3538 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3539 veop, modname, imop);
3540 PL_expect = oexpect;
3541 PL_copline = ocopline;
3546 Perl_dofile(pTHX_ OP *term)
3551 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3552 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3553 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3555 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3556 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3557 append_elem(OP_LIST, term,
3558 scalar(newUNOP(OP_RV2CV, 0,
3563 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3569 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3571 return newBINOP(OP_LSLICE, flags,
3572 list(force_list(subscript)),
3573 list(force_list(listval)) );
3577 S_list_assignment(pTHX_ register OP *o)
3582 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3583 o = cUNOPo->op_first;
3585 if (o->op_type == OP_COND_EXPR) {
3586 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3587 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3592 yyerror("Assignment to both a list and a scalar");
3596 if (o->op_type == OP_LIST &&
3597 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3598 o->op_private & OPpLVAL_INTRO)
3601 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3602 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3603 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3606 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3609 if (o->op_type == OP_RV2SV)
3616 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3621 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3622 return newLOGOP(optype, 0,
3623 mod(scalar(left), optype),
3624 newUNOP(OP_SASSIGN, 0, scalar(right)));
3627 return newBINOP(optype, OPf_STACKED,
3628 mod(scalar(left), optype), scalar(right));
3632 if (list_assignment(left)) {
3636 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3637 left = mod(left, OP_AASSIGN);
3645 curop = list(force_list(left));
3646 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3647 o->op_private = (U8)(0 | (flags >> 8));
3648 if (!(left->op_private & OPpLVAL_INTRO)) {
3651 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3652 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3653 if (curop->op_type == OP_GV) {
3654 GV *gv = cGVOPx_gv(curop);
3655 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3657 SvCUR(gv) = PL_generation;
3659 else if (curop->op_type == OP_PADSV ||
3660 curop->op_type == OP_PADAV ||
3661 curop->op_type == OP_PADHV ||
3662 curop->op_type == OP_PADANY) {
3663 SV **svp = AvARRAY(PL_comppad_name);
3664 SV *sv = svp[curop->op_targ];
3665 if ((int)SvCUR(sv) == PL_generation)
3667 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3669 else if (curop->op_type == OP_RV2CV)
3671 else if (curop->op_type == OP_RV2SV ||
3672 curop->op_type == OP_RV2AV ||
3673 curop->op_type == OP_RV2HV ||
3674 curop->op_type == OP_RV2GV) {
3675 if (lastop->op_type != OP_GV) /* funny deref? */
3678 else if (curop->op_type == OP_PUSHRE) {
3679 if (((PMOP*)curop)->op_pmreplroot) {
3681 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3683 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3685 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3687 SvCUR(gv) = PL_generation;
3696 o->op_private |= OPpASSIGN_COMMON;
3698 if (right && right->op_type == OP_SPLIT) {
3700 if ((tmpop = ((LISTOP*)right)->op_first) &&
3701 tmpop->op_type == OP_PUSHRE)
3703 PMOP *pm = (PMOP*)tmpop;
3704 if (left->op_type == OP_RV2AV &&
3705 !(left->op_private & OPpLVAL_INTRO) &&
3706 !(o->op_private & OPpASSIGN_COMMON) )
3708 tmpop = ((UNOP*)left)->op_first;
3709 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3711 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3712 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3714 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3715 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3717 pm->op_pmflags |= PMf_ONCE;
3718 tmpop = cUNOPo->op_first; /* to list (nulled) */
3719 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3720 tmpop->op_sibling = Nullop; /* don't free split */
3721 right->op_next = tmpop->op_next; /* fix starting loc */
3722 op_free(o); /* blow off assign */
3723 right->op_flags &= ~OPf_WANT;
3724 /* "I don't know and I don't care." */
3729 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3730 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3732 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3734 sv_setiv(sv, PL_modcount+1);
3742 right = newOP(OP_UNDEF, 0);
3743 if (right->op_type == OP_READLINE) {
3744 right->op_flags |= OPf_STACKED;
3745 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3748 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3749 o = newBINOP(OP_SASSIGN, flags,
3750 scalar(right), mod(scalar(left), OP_SASSIGN) );
3762 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3764 U32 seq = intro_my();
3767 NewOp(1101, cop, 1, COP);
3768 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3769 cop->op_type = OP_DBSTATE;
3770 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3773 cop->op_type = OP_NEXTSTATE;
3774 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3776 cop->op_flags = (U8)flags;
3777 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3779 cop->op_private |= NATIVE_HINTS;
3781 PL_compiling.op_private = cop->op_private;
3782 cop->op_next = (OP*)cop;
3785 cop->cop_label = label;
3786 PL_hints |= HINT_BLOCK_SCOPE;
3789 cop->cop_arybase = PL_curcop->cop_arybase;
3790 if (specialWARN(PL_curcop->cop_warnings))
3791 cop->cop_warnings = PL_curcop->cop_warnings ;
3793 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3794 if (specialCopIO(PL_curcop->cop_io))
3795 cop->cop_io = PL_curcop->cop_io;
3797 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3800 if (PL_copline == NOLINE)
3801 CopLINE_set(cop, CopLINE(PL_curcop));
3803 CopLINE_set(cop, PL_copline);
3804 PL_copline = NOLINE;
3807 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3809 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3811 CopSTASH_set(cop, PL_curstash);
3813 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3814 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3815 if (svp && *svp != &PL_sv_undef ) {
3816 (void)SvIOK_on(*svp);
3817 SvIVX(*svp) = PTR2IV(cop);
3821 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3824 /* "Introduce" my variables to visible status. */
3832 if (! PL_min_intro_pending)
3833 return PL_cop_seqmax;
3835 svp = AvARRAY(PL_comppad_name);
3836 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3837 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3838 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3839 SvNVX(sv) = (NV)PL_cop_seqmax;
3842 PL_min_intro_pending = 0;
3843 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3844 return PL_cop_seqmax++;
3848 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3850 return new_logop(type, flags, &first, &other);
3854 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3858 OP *first = *firstp;
3859 OP *other = *otherp;
3861 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3862 return newBINOP(type, flags, scalar(first), scalar(other));
3864 scalarboolean(first);
3865 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3866 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3867 if (type == OP_AND || type == OP_OR) {
3873 first = *firstp = cUNOPo->op_first;
3875 first->op_next = o->op_next;
3876 cUNOPo->op_first = Nullop;
3880 if (first->op_type == OP_CONST) {
3881 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3882 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3883 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3894 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3895 OP *k1 = ((UNOP*)first)->op_first;
3896 OP *k2 = k1->op_sibling;
3898 switch (first->op_type)
3901 if (k2 && k2->op_type == OP_READLINE
3902 && (k2->op_flags & OPf_STACKED)
3903 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3905 warnop = k2->op_type;
3910 if (k1->op_type == OP_READDIR
3911 || k1->op_type == OP_GLOB
3912 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3913 || k1->op_type == OP_EACH)
3915 warnop = ((k1->op_type == OP_NULL)
3916 ? (OPCODE)k1->op_targ : k1->op_type);
3921 line_t oldline = CopLINE(PL_curcop);
3922 CopLINE_set(PL_curcop, PL_copline);
3923 Perl_warner(aTHX_ packWARN(WARN_MISC),
3924 "Value of %s%s can be \"0\"; test with defined()",
3926 ((warnop == OP_READLINE || warnop == OP_GLOB)
3927 ? " construct" : "() operator"));
3928 CopLINE_set(PL_curcop, oldline);
3935 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3936 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3938 NewOp(1101, logop, 1, LOGOP);
3940 logop->op_type = (OPCODE)type;
3941 logop->op_ppaddr = PL_ppaddr[type];
3942 logop->op_first = first;
3943 logop->op_flags = flags | OPf_KIDS;
3944 logop->op_other = LINKLIST(other);
3945 logop->op_private = (U8)(1 | (flags >> 8));
3947 /* establish postfix order */
3948 logop->op_next = LINKLIST(first);
3949 first->op_next = (OP*)logop;
3950 first->op_sibling = other;
3952 o = newUNOP(OP_NULL, 0, (OP*)logop);
3959 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3966 return newLOGOP(OP_AND, 0, first, trueop);
3968 return newLOGOP(OP_OR, 0, first, falseop);
3970 scalarboolean(first);
3971 if (first->op_type == OP_CONST) {
3972 if (first->op_private & OPpCONST_BARE &&
3973 first->op_private & OPpCONST_STRICT) {
3974 no_bareword_allowed(first);
3976 if (SvTRUE(((SVOP*)first)->op_sv)) {
3987 NewOp(1101, logop, 1, LOGOP);
3988 logop->op_type = OP_COND_EXPR;
3989 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3990 logop->op_first = first;
3991 logop->op_flags = flags | OPf_KIDS;
3992 logop->op_private = (U8)(1 | (flags >> 8));
3993 logop->op_other = LINKLIST(trueop);
3994 logop->op_next = LINKLIST(falseop);
3997 /* establish postfix order */
3998 start = LINKLIST(first);
3999 first->op_next = (OP*)logop;
4001 first->op_sibling = trueop;
4002 trueop->op_sibling = falseop;
4003 o = newUNOP(OP_NULL, 0, (OP*)logop);
4005 trueop->op_next = falseop->op_next = o;
4012 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4020 NewOp(1101, range, 1, LOGOP);
4022 range->op_type = OP_RANGE;
4023 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4024 range->op_first = left;
4025 range->op_flags = OPf_KIDS;
4026 leftstart = LINKLIST(left);
4027 range->op_other = LINKLIST(right);
4028 range->op_private = (U8)(1 | (flags >> 8));
4030 left->op_sibling = right;
4032 range->op_next = (OP*)range;
4033 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4034 flop = newUNOP(OP_FLOP, 0, flip);
4035 o = newUNOP(OP_NULL, 0, flop);
4037 range->op_next = leftstart;
4039 left->op_next = flip;
4040 right->op_next = flop;
4042 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4043 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4044 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4045 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4047 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4048 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4051 if (!flip->op_private || !flop->op_private)
4052 linklist(o); /* blow off optimizer unless constant */
4058 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4062 int once = block && block->op_flags & OPf_SPECIAL &&
4063 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4066 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4067 return block; /* do {} while 0 does once */
4068 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4069 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4070 expr = newUNOP(OP_DEFINED, 0,
4071 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4072 } else if (expr->op_flags & OPf_KIDS) {
4073 OP *k1 = ((UNOP*)expr)->op_first;
4074 OP *k2 = (k1) ? k1->op_sibling : NULL;
4075 switch (expr->op_type) {
4077 if (k2 && k2->op_type == OP_READLINE
4078 && (k2->op_flags & OPf_STACKED)
4079 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4080 expr = newUNOP(OP_DEFINED, 0, expr);
4084 if (k1->op_type == OP_READDIR
4085 || k1->op_type == OP_GLOB
4086 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4087 || k1->op_type == OP_EACH)
4088 expr = newUNOP(OP_DEFINED, 0, expr);
4094 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4095 o = new_logop(OP_AND, 0, &expr, &listop);
4098 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4100 if (once && o != listop)
4101 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4104 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4106 o->op_flags |= flags;
4108 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4113 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4121 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4122 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4123 expr = newUNOP(OP_DEFINED, 0,
4124 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4125 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4126 OP *k1 = ((UNOP*)expr)->op_first;
4127 OP *k2 = (k1) ? k1->op_sibling : NULL;
4128 switch (expr->op_type) {
4130 if (k2 && k2->op_type == OP_READLINE
4131 && (k2->op_flags & OPf_STACKED)
4132 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4133 expr = newUNOP(OP_DEFINED, 0, expr);
4137 if (k1->op_type == OP_READDIR
4138 || k1->op_type == OP_GLOB
4139 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4140 || k1->op_type == OP_EACH)
4141 expr = newUNOP(OP_DEFINED, 0, expr);
4147 block = newOP(OP_NULL, 0);
4149 block = scope(block);
4153 next = LINKLIST(cont);
4156 OP *unstack = newOP(OP_UNSTACK, 0);
4159 cont = append_elem(OP_LINESEQ, cont, unstack);
4160 if ((line_t)whileline != NOLINE) {
4161 PL_copline = (line_t)whileline;
4162 cont = append_elem(OP_LINESEQ, cont,
4163 newSTATEOP(0, Nullch, Nullop));
4167 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4168 redo = LINKLIST(listop);
4171 PL_copline = (line_t)whileline;
4173 o = new_logop(OP_AND, 0, &expr, &listop);
4174 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4175 op_free(expr); /* oops, it's a while (0) */
4177 return Nullop; /* listop already freed by new_logop */
4180 ((LISTOP*)listop)->op_last->op_next =
4181 (o == listop ? redo : LINKLIST(o));
4187 NewOp(1101,loop,1,LOOP);
4188 loop->op_type = OP_ENTERLOOP;
4189 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4190 loop->op_private = 0;
4191 loop->op_next = (OP*)loop;
4194 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4196 loop->op_redoop = redo;
4197 loop->op_lastop = o;
4198 o->op_private |= loopflags;
4201 loop->op_nextop = next;
4203 loop->op_nextop = o;
4205 o->op_flags |= flags;
4206 o->op_private |= (flags >> 8);
4211 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4215 PADOFFSET padoff = 0;
4219 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4220 sv->op_type = OP_RV2GV;
4221 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4223 else if (sv->op_type == OP_PADSV) { /* private variable */
4224 padoff = sv->op_targ;
4229 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4230 padoff = sv->op_targ;
4232 iterflags |= OPf_SPECIAL;
4237 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4240 #ifdef USE_5005THREADS
4241 padoff = find_threadsv("_");
4242 iterflags |= OPf_SPECIAL;
4244 sv = newGVOP(OP_GV, 0, PL_defgv);
4247 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4248 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4249 iterflags |= OPf_STACKED;
4251 else if (expr->op_type == OP_NULL &&
4252 (expr->op_flags & OPf_KIDS) &&
4253 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4255 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4256 * set the STACKED flag to indicate that these values are to be
4257 * treated as min/max values by 'pp_iterinit'.
4259 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4260 LOGOP* range = (LOGOP*) flip->op_first;
4261 OP* left = range->op_first;
4262 OP* right = left->op_sibling;
4265 range->op_flags &= ~OPf_KIDS;
4266 range->op_first = Nullop;
4268 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4269 listop->op_first->op_next = range->op_next;
4270 left->op_next = range->op_other;
4271 right->op_next = (OP*)listop;
4272 listop->op_next = listop->op_first;
4275 expr = (OP*)(listop);
4277 iterflags |= OPf_STACKED;
4280 expr = mod(force_list(expr), OP_GREPSTART);
4284 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4285 append_elem(OP_LIST, expr, scalar(sv))));
4286 assert(!loop->op_next);
4287 #ifdef PL_OP_SLAB_ALLOC
4290 NewOp(1234,tmp,1,LOOP);
4291 Copy(loop,tmp,1,LOOP);
4296 Renew(loop, 1, LOOP);
4298 loop->op_targ = padoff;
4299 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4300 PL_copline = forline;
4301 return newSTATEOP(0, label, wop);
4305 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4310 if (type != OP_GOTO || label->op_type == OP_CONST) {
4311 /* "last()" means "last" */
4312 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4313 o = newOP(type, OPf_SPECIAL);
4315 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4316 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4322 if (label->op_type == OP_ENTERSUB)
4323 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4324 o = newUNOP(type, OPf_STACKED, label);
4326 PL_hints |= HINT_BLOCK_SCOPE;
4331 Perl_cv_undef(pTHX_ CV *cv)
4334 CV *freecv = Nullcv;
4335 bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */
4337 #ifdef USE_5005THREADS
4339 MUTEX_DESTROY(CvMUTEXP(cv));
4340 Safefree(CvMUTEXP(cv));
4343 #endif /* USE_5005THREADS */
4346 if (CvFILE(cv) && !CvXSUB(cv)) {
4347 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4348 Safefree(CvFILE(cv));
4353 if (!CvXSUB(cv) && CvROOT(cv)) {
4354 #ifdef USE_5005THREADS
4355 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4356 Perl_croak(aTHX_ "Can't undef active subroutine");
4359 Perl_croak(aTHX_ "Can't undef active subroutine");
4360 #endif /* USE_5005THREADS */
4363 SAVEVPTR(PL_curpad);
4366 op_free(CvROOT(cv));
4367 CvROOT(cv) = Nullop;
4370 SvPOK_off((SV*)cv); /* forget prototype */
4372 outsidecv = CvOUTSIDE(cv);
4373 /* Since closure prototypes have the same lifetime as the containing
4374 * CV, they don't hold a refcount on the outside CV. This avoids
4375 * the refcount loop between the outer CV (which keeps a refcount to
4376 * the closure prototype in the pad entry for pp_anoncode()) and the
4377 * closure prototype, and the ensuing memory leak. --GSAR */
4378 if (!CvANON(cv) || CvCLONED(cv))
4380 CvOUTSIDE(cv) = Nullcv;
4382 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4385 if (CvPADLIST(cv)) {
4386 /* may be during global destruction */
4387 if (SvREFCNT(CvPADLIST(cv))) {
4388 AV *padlist = CvPADLIST(cv);
4390 /* pads may be cleared out already during global destruction */
4391 if (is_eval && !PL_dirty) {
4392 /* inner references to eval's cv must be fixed up */
4393 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4394 AV *comppad = (AV*)AvARRAY(padlist)[1];
4395 SV **namepad = AvARRAY(comppad_name);
4396 SV **curpad = AvARRAY(comppad);
4397 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4398 SV *namesv = namepad[ix];
4399 if (namesv && namesv != &PL_sv_undef
4400 && *SvPVX(namesv) == '&'
4401 && ix <= AvFILLp(comppad))
4403 CV *innercv = (CV*)curpad[ix];
4404 if (innercv && SvTYPE(innercv) == SVt_PVCV
4405 && CvOUTSIDE(innercv) == cv)
4407 CvOUTSIDE(innercv) = outsidecv;
4408 if (!CvANON(innercv) || CvCLONED(innercv)) {
4409 (void)SvREFCNT_inc(outsidecv);
4418 SvREFCNT_dec(freecv);
4419 ix = AvFILLp(padlist);
4421 SV* sv = AvARRAY(padlist)[ix--];
4424 if (sv == (SV*)PL_comppad_name)
4425 PL_comppad_name = Nullav;
4426 else if (sv == (SV*)PL_comppad) {
4427 PL_comppad = Nullav;
4428 PL_curpad = Null(SV**);
4432 SvREFCNT_dec((SV*)CvPADLIST(cv));
4434 CvPADLIST(cv) = Nullav;
4437 SvREFCNT_dec(freecv);
4444 #ifdef DEBUG_CLOSURES
4446 S_cv_dump(pTHX_ CV *cv)
4449 CV *outside = CvOUTSIDE(cv);
4450 AV* padlist = CvPADLIST(cv);
4457 PerlIO_printf(Perl_debug_log,
4458 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4460 (CvANON(cv) ? "ANON"
4461 : (cv == PL_main_cv) ? "MAIN"
4462 : CvUNIQUE(cv) ? "UNIQUE"
4463 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4466 : CvANON(outside) ? "ANON"
4467 : (outside == PL_main_cv) ? "MAIN"
4468 : CvUNIQUE(outside) ? "UNIQUE"
4469 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4474 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4475 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4476 pname = AvARRAY(pad_name);
4477 ppad = AvARRAY(pad);
4479 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4480 if (SvPOK(pname[ix]))
4481 PerlIO_printf(Perl_debug_log,
4482 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4483 (int)ix, PTR2UV(ppad[ix]),
4484 SvFAKE(pname[ix]) ? "FAKE " : "",
4486 (IV)I_32(SvNVX(pname[ix])),
4489 #endif /* DEBUGGING */
4491 #endif /* DEBUG_CLOSURES */
4494 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4498 AV* protopadlist = CvPADLIST(proto);
4499 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4500 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4501 SV** pname = AvARRAY(protopad_name);
4502 SV** ppad = AvARRAY(protopad);
4503 I32 fname = AvFILLp(protopad_name);
4504 I32 fpad = AvFILLp(protopad);
4508 assert(!CvUNIQUE(proto));
4512 SAVESPTR(PL_comppad_name);
4513 SAVESPTR(PL_compcv);
4515 cv = PL_compcv = (CV*)NEWSV(1104,0);
4516 sv_upgrade((SV *)cv, SvTYPE(proto));
4517 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4520 #ifdef USE_5005THREADS
4521 New(666, CvMUTEXP(cv), 1, perl_mutex);
4522 MUTEX_INIT(CvMUTEXP(cv));
4524 #endif /* USE_5005THREADS */
4526 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4527 : savepv(CvFILE(proto));
4529 CvFILE(cv) = CvFILE(proto);
4531 CvGV(cv) = CvGV(proto);
4532 CvSTASH(cv) = CvSTASH(proto);
4533 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4534 CvSTART(cv) = CvSTART(proto);
4536 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4539 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4541 PL_comppad_name = newAV();
4542 for (ix = fname; ix >= 0; ix--)
4543 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4545 PL_comppad = newAV();
4547 comppadlist = newAV();
4548 AvREAL_off(comppadlist);
4549 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4550 av_store(comppadlist, 1, (SV*)PL_comppad);
4551 CvPADLIST(cv) = comppadlist;
4552 av_fill(PL_comppad, AvFILLp(protopad));
4553 PL_curpad = AvARRAY(PL_comppad);
4555 av = newAV(); /* will be @_ */
4557 av_store(PL_comppad, 0, (SV*)av);
4558 AvFLAGS(av) = AVf_REIFY;
4560 for (ix = fpad; ix > 0; ix--) {
4561 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4562 if (namesv && namesv != &PL_sv_undef) {
4563 char *name = SvPVX(namesv); /* XXX */
4564 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4565 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4566 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4568 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4570 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4572 else { /* our own lexical */
4575 /* anon code -- we'll come back for it */
4576 sv = SvREFCNT_inc(ppad[ix]);
4578 else if (*name == '@')
4580 else if (*name == '%')
4589 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4590 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4593 SV* sv = NEWSV(0,0);
4599 /* Now that vars are all in place, clone nested closures. */
4601 for (ix = fpad; ix > 0; ix--) {
4602 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4604 && namesv != &PL_sv_undef
4605 && !(SvFLAGS(namesv) & SVf_FAKE)
4606 && *SvPVX(namesv) == '&'
4607 && CvCLONE(ppad[ix]))
4609 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4610 SvREFCNT_dec(ppad[ix]);
4613 PL_curpad[ix] = (SV*)kid;
4617 #ifdef DEBUG_CLOSURES
4618 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4620 PerlIO_printf(Perl_debug_log, " from:\n");
4622 PerlIO_printf(Perl_debug_log, " to:\n");
4629 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4631 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4633 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4640 Perl_cv_clone(pTHX_ CV *proto)
4643 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4644 cv = cv_clone2(proto, CvOUTSIDE(proto));
4645 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4650 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4652 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4653 SV* msg = sv_newmortal();
4657 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4658 sv_setpv(msg, "Prototype mismatch:");
4660 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4662 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4663 sv_catpv(msg, " vs ");
4665 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4667 sv_catpv(msg, "none");
4668 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4672 static void const_sv_xsub(pTHX_ CV* cv);
4676 =head1 Optree Manipulation Functions
4678 =for apidoc cv_const_sv
4680 If C<cv> is a constant sub eligible for inlining. returns the constant
4681 value returned by the sub. Otherwise, returns NULL.
4683 Constant subs can be created with C<newCONSTSUB> or as described in
4684 L<perlsub/"Constant Functions">.
4689 Perl_cv_const_sv(pTHX_ CV *cv)
4691 if (!cv || !CvCONST(cv))
4693 return (SV*)CvXSUBANY(cv).any_ptr;
4697 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4704 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4705 o = cLISTOPo->op_first->op_sibling;
4707 for (; o; o = o->op_next) {
4708 OPCODE type = o->op_type;
4710 if (sv && o->op_next == o)
4712 if (o->op_next != o) {
4713 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4715 if (type == OP_DBSTATE)
4718 if (type == OP_LEAVESUB || type == OP_RETURN)
4722 if (type == OP_CONST && cSVOPo->op_sv)
4724 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4725 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4726 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4730 /* We get here only from cv_clone2() while creating a closure.
4731 Copy the const value here instead of in cv_clone2 so that
4732 SvREADONLY_on doesn't lead to problems when leaving
4737 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4749 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4759 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4763 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4765 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4769 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4775 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4780 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4781 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4782 SV *sv = sv_newmortal();
4783 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4784 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4785 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4790 gv = gv_fetchpv(name ? name : (aname ? aname :
4791 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4792 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4802 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4803 maximum a prototype before. */
4804 if (SvTYPE(gv) > SVt_NULL) {
4805 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4806 && ckWARN_d(WARN_PROTOTYPE))
4808 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4810 cv_ckproto((CV*)gv, NULL, ps);
4813 sv_setpv((SV*)gv, ps);
4815 sv_setiv((SV*)gv, -1);
4816 SvREFCNT_dec(PL_compcv);
4817 cv = PL_compcv = NULL;
4818 PL_sub_generation++;
4822 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4824 #ifdef GV_UNIQUE_CHECK
4825 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4826 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4830 if (!block || !ps || *ps || attrs)
4833 const_sv = op_const_sv(block, Nullcv);
4836 bool exists = CvROOT(cv) || CvXSUB(cv);
4838 #ifdef GV_UNIQUE_CHECK
4839 if (exists && GvUNIQUE(gv)) {
4840 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4844 /* if the subroutine doesn't exist and wasn't pre-declared
4845 * with a prototype, assume it will be AUTOLOADed,
4846 * skipping the prototype check
4848 if (exists || SvPOK(cv))
4849 cv_ckproto(cv, gv, ps);
4850 /* already defined (or promised)? */
4851 if (exists || GvASSUMECV(gv)) {
4852 if (!block && !attrs) {
4853 if (CvFLAGS(PL_compcv)) {
4854 /* might have had built-in attrs applied */
4855 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4857 /* just a "sub foo;" when &foo is already defined */
4858 SAVEFREESV(PL_compcv);
4861 /* ahem, death to those who redefine active sort subs */
4862 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4863 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4865 if (ckWARN(WARN_REDEFINE)
4867 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4869 line_t oldline = CopLINE(PL_curcop);
4870 if (PL_copline != NOLINE)
4871 CopLINE_set(PL_curcop, PL_copline);
4872 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4873 CvCONST(cv) ? "Constant subroutine %s redefined"
4874 : "Subroutine %s redefined", name);
4875 CopLINE_set(PL_curcop, oldline);
4883 SvREFCNT_inc(const_sv);
4885 assert(!CvROOT(cv) && !CvCONST(cv));
4886 sv_setpv((SV*)cv, ""); /* prototype is "" */
4887 CvXSUBANY(cv).any_ptr = const_sv;
4888 CvXSUB(cv) = const_sv_xsub;
4893 cv = newCONSTSUB(NULL, name, const_sv);
4896 SvREFCNT_dec(PL_compcv);
4898 PL_sub_generation++;
4905 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4906 * before we clobber PL_compcv.
4910 /* Might have had built-in attributes applied -- propagate them. */
4911 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4912 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4913 stash = GvSTASH(CvGV(cv));
4914 else if (CvSTASH(cv))
4915 stash = CvSTASH(cv);
4917 stash = PL_curstash;
4920 /* possibly about to re-define existing subr -- ignore old cv */
4921 rcv = (SV*)PL_compcv;
4922 if (name && GvSTASH(gv))
4923 stash = GvSTASH(gv);
4925 stash = PL_curstash;
4927 apply_attrs(stash, rcv, attrs, FALSE);
4929 if (cv) { /* must reuse cv if autoloaded */
4931 /* got here with just attrs -- work done, so bug out */
4932 SAVEFREESV(PL_compcv);
4936 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4937 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4938 CvOUTSIDE(PL_compcv) = 0;
4939 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4940 CvPADLIST(PL_compcv) = 0;
4941 /* inner references to PL_compcv must be fixed up ... */
4943 AV *padlist = CvPADLIST(cv);
4944 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4945 AV *comppad = (AV*)AvARRAY(padlist)[1];
4946 SV **namepad = AvARRAY(comppad_name);
4947 SV **curpad = AvARRAY(comppad);
4948 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4949 SV *namesv = namepad[ix];
4950 if (namesv && namesv != &PL_sv_undef
4951 && *SvPVX(namesv) == '&')
4953 CV *innercv = (CV*)curpad[ix];
4954 if (CvOUTSIDE(innercv) == PL_compcv) {
4955 CvOUTSIDE(innercv) = cv;
4956 if (!CvANON(innercv) || CvCLONED(innercv)) {
4957 (void)SvREFCNT_inc(cv);
4958 SvREFCNT_dec(PL_compcv);
4964 /* ... before we throw it away */
4965 SvREFCNT_dec(PL_compcv);
4966 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4967 ++PL_sub_generation;
4974 PL_sub_generation++;
4978 CvFILE_set_from_cop(cv, PL_curcop);
4979 CvSTASH(cv) = PL_curstash;
4980 #ifdef USE_5005THREADS
4982 if (!CvMUTEXP(cv)) {
4983 New(666, CvMUTEXP(cv), 1, perl_mutex);
4984 MUTEX_INIT(CvMUTEXP(cv));
4986 #endif /* USE_5005THREADS */
4989 sv_setpv((SV*)cv, ps);
4991 if (PL_error_count) {
4995 char *s = strrchr(name, ':');
4997 if (strEQ(s, "BEGIN")) {
4999 "BEGIN not safe after errors--compilation aborted";
5000 if (PL_in_eval & EVAL_KEEPERR)
5001 Perl_croak(aTHX_ not_safe);
5003 /* force display of errors found but not reported */
5004 sv_catpv(ERRSV, not_safe);
5005 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
5013 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5014 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5017 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5018 mod(scalarseq(block), OP_LEAVESUBLV));
5021 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5023 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5024 OpREFCNT_set(CvROOT(cv), 1);
5025 CvSTART(cv) = LINKLIST(CvROOT(cv));
5026 CvROOT(cv)->op_next = 0;
5027 CALL_PEEP(CvSTART(cv));
5029 /* now that optimizer has done its work, adjust pad values */
5031 SV **namep = AvARRAY(PL_comppad_name);
5032 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5035 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5038 * The only things that a clonable function needs in its
5039 * pad are references to outer lexicals and anonymous subs.
5040 * The rest are created anew during cloning.
5042 if (!((namesv = namep[ix]) != Nullsv &&
5043 namesv != &PL_sv_undef &&
5045 *SvPVX(namesv) == '&')))
5047 SvREFCNT_dec(PL_curpad[ix]);
5048 PL_curpad[ix] = Nullsv;
5051 assert(!CvCONST(cv));
5052 if (ps && !*ps && op_const_sv(block, cv))
5056 AV *av = newAV(); /* Will be @_ */
5058 av_store(PL_comppad, 0, (SV*)av);
5059 AvFLAGS(av) = AVf_REIFY;
5061 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5062 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5064 if (!SvPADMY(PL_curpad[ix]))
5065 SvPADTMP_on(PL_curpad[ix]);
5069 /* If a potential closure prototype, don't keep a refcount on outer CV.
5070 * This is okay as the lifetime of the prototype is tied to the
5071 * lifetime of the outer CV. Avoids memory leak due to reference
5074 SvREFCNT_dec(CvOUTSIDE(cv));
5076 if (name || aname) {
5078 char *tname = (name ? name : aname);
5080 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5081 SV *sv = NEWSV(0,0);
5082 SV *tmpstr = sv_newmortal();
5083 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5087 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5089 (long)PL_subline, (long)CopLINE(PL_curcop));
5090 gv_efullname3(tmpstr, gv, Nullch);
5091 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5092 hv = GvHVn(db_postponed);
5093 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5094 && (pcv = GvCV(db_postponed)))
5100 call_sv((SV*)pcv, G_DISCARD);
5104 if ((s = strrchr(tname,':')))
5109 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5112 if (strEQ(s, "BEGIN")) {
5113 I32 oldscope = PL_scopestack_ix;
5115 SAVECOPFILE(&PL_compiling);
5116 SAVECOPLINE(&PL_compiling);
5119 PL_beginav = newAV();
5120 DEBUG_x( dump_sub(gv) );
5121 av_push(PL_beginav, (SV*)cv);
5122 GvCV(gv) = 0; /* cv has been hijacked */
5123 call_list(oldscope, PL_beginav);
5125 PL_curcop = &PL_compiling;
5126 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5129 else if (strEQ(s, "END") && !PL_error_count) {
5132 DEBUG_x( dump_sub(gv) );
5133 av_unshift(PL_endav, 1);
5134 av_store(PL_endav, 0, (SV*)cv);
5135 GvCV(gv) = 0; /* cv has been hijacked */
5137 else if (strEQ(s, "CHECK") && !PL_error_count) {
5139 PL_checkav = newAV();
5140 DEBUG_x( dump_sub(gv) );
5141 if (PL_main_start && ckWARN(WARN_VOID))
5142 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5143 av_unshift(PL_checkav, 1);
5144 av_store(PL_checkav, 0, (SV*)cv);
5145 GvCV(gv) = 0; /* cv has been hijacked */
5147 else if (strEQ(s, "INIT") && !PL_error_count) {
5149 PL_initav = newAV();
5150 DEBUG_x( dump_sub(gv) );
5151 if (PL_main_start && ckWARN(WARN_VOID))
5152 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5153 av_push(PL_initav, (SV*)cv);
5154 GvCV(gv) = 0; /* cv has been hijacked */
5159 PL_copline = NOLINE;
5164 /* XXX unsafe for threads if eval_owner isn't held */
5166 =for apidoc newCONSTSUB
5168 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5169 eligible for inlining at compile-time.
5175 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5181 SAVECOPLINE(PL_curcop);
5182 CopLINE_set(PL_curcop, PL_copline);
5185 PL_hints &= ~HINT_BLOCK_SCOPE;
5188 SAVESPTR(PL_curstash);
5189 SAVECOPSTASH(PL_curcop);
5190 PL_curstash = stash;
5191 CopSTASH_set(PL_curcop,stash);
5194 cv = newXS(name, const_sv_xsub, __FILE__);
5195 CvXSUBANY(cv).any_ptr = sv;
5197 sv_setpv((SV*)cv, ""); /* prototype is "" */
5205 =for apidoc U||newXS
5207 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5213 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5215 GV *gv = gv_fetchpv(name ? name :
5216 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5217 GV_ADDMULTI, SVt_PVCV);
5221 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5223 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5225 /* just a cached method */
5229 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5230 /* already defined (or promised) */
5231 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5232 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5233 line_t oldline = CopLINE(PL_curcop);
5234 if (PL_copline != NOLINE)
5235 CopLINE_set(PL_curcop, PL_copline);
5236 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5237 CvCONST(cv) ? "Constant subroutine %s redefined"
5238 : "Subroutine %s redefined"
5240 CopLINE_set(PL_curcop, oldline);
5247 if (cv) /* must reuse cv if autoloaded */
5250 cv = (CV*)NEWSV(1105,0);
5251 sv_upgrade((SV *)cv, SVt_PVCV);
5255 PL_sub_generation++;
5259 #ifdef USE_5005THREADS
5260 New(666, CvMUTEXP(cv), 1, perl_mutex);
5261 MUTEX_INIT(CvMUTEXP(cv));
5263 #endif /* USE_5005THREADS */
5264 (void)gv_fetchfile(filename);
5265 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5266 an external constant string */
5267 CvXSUB(cv) = subaddr;
5270 char *s = strrchr(name,':');
5276 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5279 if (strEQ(s, "BEGIN")) {
5281 PL_beginav = newAV();
5282 av_push(PL_beginav, (SV*)cv);
5283 GvCV(gv) = 0; /* cv has been hijacked */
5285 else if (strEQ(s, "END")) {
5288 av_unshift(PL_endav, 1);
5289 av_store(PL_endav, 0, (SV*)cv);
5290 GvCV(gv) = 0; /* cv has been hijacked */
5292 else if (strEQ(s, "CHECK")) {
5294 PL_checkav = newAV();
5295 if (PL_main_start && ckWARN(WARN_VOID))
5296 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5297 av_unshift(PL_checkav, 1);
5298 av_store(PL_checkav, 0, (SV*)cv);
5299 GvCV(gv) = 0; /* cv has been hijacked */
5301 else if (strEQ(s, "INIT")) {
5303 PL_initav = newAV();
5304 if (PL_main_start && ckWARN(WARN_VOID))
5305 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5306 av_push(PL_initav, (SV*)cv);
5307 GvCV(gv) = 0; /* cv has been hijacked */
5318 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5327 name = SvPVx(cSVOPo->op_sv, n_a);
5330 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5331 #ifdef GV_UNIQUE_CHECK
5333 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5337 if ((cv = GvFORM(gv))) {
5338 if (ckWARN(WARN_REDEFINE)) {
5339 line_t oldline = CopLINE(PL_curcop);
5340 if (PL_copline != NOLINE)
5341 CopLINE_set(PL_curcop, PL_copline);
5342 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
5343 CopLINE_set(PL_curcop, oldline);
5350 CvFILE_set_from_cop(cv, PL_curcop);
5352 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5353 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5354 SvPADTMP_on(PL_curpad[ix]);
5357 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5358 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5359 OpREFCNT_set(CvROOT(cv), 1);
5360 CvSTART(cv) = LINKLIST(CvROOT(cv));
5361 CvROOT(cv)->op_next = 0;
5362 CALL_PEEP(CvSTART(cv));
5364 PL_copline = NOLINE;
5369 Perl_newANONLIST(pTHX_ OP *o)
5371 return newUNOP(OP_REFGEN, 0,
5372 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5376 Perl_newANONHASH(pTHX_ OP *o)
5378 return newUNOP(OP_REFGEN, 0,
5379 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5383 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5385 return newANONATTRSUB(floor, proto, Nullop, block);
5389 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5391 return newUNOP(OP_REFGEN, 0,
5392 newSVOP(OP_ANONCODE, 0,
5393 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5397 Perl_oopsAV(pTHX_ OP *o)
5399 switch (o->op_type) {
5401 o->op_type = OP_PADAV;
5402 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5403 return ref(o, OP_RV2AV);
5406 o->op_type = OP_RV2AV;
5407 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5412 if (ckWARN_d(WARN_INTERNAL))
5413 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5420 Perl_oopsHV(pTHX_ OP *o)
5422 switch (o->op_type) {
5425 o->op_type = OP_PADHV;
5426 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5427 return ref(o, OP_RV2HV);
5431 o->op_type = OP_RV2HV;
5432 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5437 if (ckWARN_d(WARN_INTERNAL))
5438 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5445 Perl_newAVREF(pTHX_ OP *o)
5447 if (o->op_type == OP_PADANY) {
5448 o->op_type = OP_PADAV;
5449 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5452 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5453 && ckWARN(WARN_DEPRECATED)) {
5454 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5455 "Using an array as a reference is deprecated");
5457 return newUNOP(OP_RV2AV, 0, scalar(o));
5461 Perl_newGVREF(pTHX_ I32 type, OP *o)
5463 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5464 return newUNOP(OP_NULL, 0, o);
5465 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5469 Perl_newHVREF(pTHX_ OP *o)
5471 if (o->op_type == OP_PADANY) {
5472 o->op_type = OP_PADHV;
5473 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5476 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5477 && ckWARN(WARN_DEPRECATED)) {
5478 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5479 "Using a hash as a reference is deprecated");
5481 return newUNOP(OP_RV2HV, 0, scalar(o));
5485 Perl_oopsCV(pTHX_ OP *o)
5487 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5493 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5495 return newUNOP(OP_RV2CV, flags, scalar(o));
5499 Perl_newSVREF(pTHX_ OP *o)
5501 if (o->op_type == OP_PADANY) {
5502 o->op_type = OP_PADSV;
5503 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5506 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5507 o->op_flags |= OPpDONE_SVREF;
5510 return newUNOP(OP_RV2SV, 0, scalar(o));
5513 /* Check routines. */
5516 Perl_ck_anoncode(pTHX_ OP *o)
5521 name = NEWSV(1106,0);
5522 sv_upgrade(name, SVt_PVNV);
5523 sv_setpvn(name, "&", 1);
5526 ix = pad_alloc(o->op_type, SVs_PADMY);
5527 av_store(PL_comppad_name, ix, name);
5528 av_store(PL_comppad, ix, cSVOPo->op_sv);
5529 SvPADMY_on(cSVOPo->op_sv);
5530 cSVOPo->op_sv = Nullsv;
5531 cSVOPo->op_targ = ix;
5536 Perl_ck_bitop(pTHX_ OP *o)
5538 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5543 Perl_ck_concat(pTHX_ OP *o)
5545 if (cUNOPo->op_first->op_type == OP_CONCAT)
5546 o->op_flags |= OPf_STACKED;
5551 Perl_ck_spair(pTHX_ OP *o)
5553 if (o->op_flags & OPf_KIDS) {
5556 OPCODE type = o->op_type;
5557 o = modkids(ck_fun(o), type);
5558 kid = cUNOPo->op_first;
5559 newop = kUNOP->op_first->op_sibling;
5561 (newop->op_sibling ||
5562 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5563 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5564 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5568 op_free(kUNOP->op_first);
5569 kUNOP->op_first = newop;
5571 o->op_ppaddr = PL_ppaddr[++o->op_type];
5576 Perl_ck_delete(pTHX_ OP *o)
5580 if (o->op_flags & OPf_KIDS) {
5581 OP *kid = cUNOPo->op_first;
5582 switch (kid->op_type) {
5584 o->op_flags |= OPf_SPECIAL;
5587 o->op_private |= OPpSLICE;
5590 o->op_flags |= OPf_SPECIAL;
5595 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5604 Perl_ck_die(pTHX_ OP *o)
5607 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5613 Perl_ck_eof(pTHX_ OP *o)
5615 I32 type = o->op_type;
5617 if (o->op_flags & OPf_KIDS) {
5618 if (cLISTOPo->op_first->op_type == OP_STUB) {
5620 o = newUNOP(type, OPf_SPECIAL,
5621 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5629 Perl_ck_eval(pTHX_ OP *o)
5631 PL_hints |= HINT_BLOCK_SCOPE;
5632 if (o->op_flags & OPf_KIDS) {
5633 SVOP *kid = (SVOP*)cUNOPo->op_first;
5636 o->op_flags &= ~OPf_KIDS;
5639 else if (kid->op_type == OP_LINESEQ) {
5642 kid->op_next = o->op_next;
5643 cUNOPo->op_first = 0;
5646 NewOp(1101, enter, 1, LOGOP);
5647 enter->op_type = OP_ENTERTRY;
5648 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5649 enter->op_private = 0;
5651 /* establish postfix order */
5652 enter->op_next = (OP*)enter;
5654 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5655 o->op_type = OP_LEAVETRY;
5656 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5657 enter->op_other = o;
5665 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5667 o->op_targ = (PADOFFSET)PL_hints;
5672 Perl_ck_exit(pTHX_ OP *o)
5675 HV *table = GvHV(PL_hintgv);
5677 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5678 if (svp && *svp && SvTRUE(*svp))
5679 o->op_private |= OPpEXIT_VMSISH;
5681 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5687 Perl_ck_exec(pTHX_ OP *o)
5690 if (o->op_flags & OPf_STACKED) {
5692 kid = cUNOPo->op_first->op_sibling;
5693 if (kid->op_type == OP_RV2GV)
5702 Perl_ck_exists(pTHX_ OP *o)
5705 if (o->op_flags & OPf_KIDS) {
5706 OP *kid = cUNOPo->op_first;
5707 if (kid->op_type == OP_ENTERSUB) {
5708 (void) ref(kid, o->op_type);
5709 if (kid->op_type != OP_RV2CV && !PL_error_count)
5710 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5712 o->op_private |= OPpEXISTS_SUB;
5714 else if (kid->op_type == OP_AELEM)
5715 o->op_flags |= OPf_SPECIAL;
5716 else if (kid->op_type != OP_HELEM)
5717 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5726 Perl_ck_gvconst(pTHX_ register OP *o)
5728 o = fold_constants(o);
5729 if (o->op_type == OP_CONST)
5736 Perl_ck_rvconst(pTHX_ register OP *o)
5738 SVOP *kid = (SVOP*)cUNOPo->op_first;
5740 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5741 if (kid->op_type == OP_CONST) {
5745 SV *kidsv = kid->op_sv;
5748 /* Is it a constant from cv_const_sv()? */
5749 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5750 SV *rsv = SvRV(kidsv);
5751 int svtype = SvTYPE(rsv);
5752 char *badtype = Nullch;
5754 switch (o->op_type) {
5756 if (svtype > SVt_PVMG)
5757 badtype = "a SCALAR";
5760 if (svtype != SVt_PVAV)
5761 badtype = "an ARRAY";
5764 if (svtype != SVt_PVHV)
5768 if (svtype != SVt_PVCV)
5773 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5776 name = SvPV(kidsv, n_a);
5777 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5778 char *badthing = Nullch;
5779 switch (o->op_type) {
5781 badthing = "a SCALAR";
5784 badthing = "an ARRAY";
5787 badthing = "a HASH";
5792 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5796 * This is a little tricky. We only want to add the symbol if we
5797 * didn't add it in the lexer. Otherwise we get duplicate strict
5798 * warnings. But if we didn't add it in the lexer, we must at
5799 * least pretend like we wanted to add it even if it existed before,
5800 * or we get possible typo warnings. OPpCONST_ENTERED says
5801 * whether the lexer already added THIS instance of this symbol.
5803 iscv = (o->op_type == OP_RV2CV) * 2;
5805 gv = gv_fetchpv(name,
5806 iscv | !(kid->op_private & OPpCONST_ENTERED),
5809 : o->op_type == OP_RV2SV
5811 : o->op_type == OP_RV2AV
5813 : o->op_type == OP_RV2HV
5816 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5818 kid->op_type = OP_GV;
5819 SvREFCNT_dec(kid->op_sv);
5821 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5822 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5823 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5825 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5827 kid->op_sv = SvREFCNT_inc(gv);
5829 kid->op_private = 0;
5830 kid->op_ppaddr = PL_ppaddr[OP_GV];
5837 Perl_ck_ftst(pTHX_ OP *o)
5839 I32 type = o->op_type;
5841 if (o->op_flags & OPf_REF) {
5844 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5845 SVOP *kid = (SVOP*)cUNOPo->op_first;
5847 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5849 OP *newop = newGVOP(type, OPf_REF,
5850 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5857 if (type == OP_FTTTY)
5858 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5861 o = newUNOP(type, 0, newDEFSVOP());
5867 Perl_ck_fun(pTHX_ OP *o)
5873 int type = o->op_type;
5874 register I32 oa = PL_opargs[type] >> OASHIFT;
5876 if (o->op_flags & OPf_STACKED) {
5877 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5880 return no_fh_allowed(o);
5883 if (o->op_flags & OPf_KIDS) {
5885 tokid = &cLISTOPo->op_first;
5886 kid = cLISTOPo->op_first;
5887 if (kid->op_type == OP_PUSHMARK ||
5888 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5890 tokid = &kid->op_sibling;
5891 kid = kid->op_sibling;
5893 if (!kid && PL_opargs[type] & OA_DEFGV)
5894 *tokid = kid = newDEFSVOP();
5898 sibl = kid->op_sibling;
5901 /* list seen where single (scalar) arg expected? */
5902 if (numargs == 1 && !(oa >> 4)
5903 && kid->op_type == OP_LIST && type != OP_SCALAR)
5905 return too_many_arguments(o,PL_op_desc[type]);
5918 if ((type == OP_PUSH || type == OP_UNSHIFT)
5919 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5920 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5921 "Useless use of %s with no values",
5924 if (kid->op_type == OP_CONST &&
5925 (kid->op_private & OPpCONST_BARE))
5927 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5928 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5929 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5930 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5931 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5932 "Array @%s missing the @ in argument %"IVdf" of %s()",
5933 name, (IV)numargs, PL_op_desc[type]);
5936 kid->op_sibling = sibl;
5939 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5940 bad_type(numargs, "array", PL_op_desc[type], kid);
5944 if (kid->op_type == OP_CONST &&
5945 (kid->op_private & OPpCONST_BARE))
5947 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5948 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5949 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5950 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5951 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5952 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5953 name, (IV)numargs, PL_op_desc[type]);
5956 kid->op_sibling = sibl;
5959 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5960 bad_type(numargs, "hash", PL_op_desc[type], kid);
5965 OP *newop = newUNOP(OP_NULL, 0, kid);
5966 kid->op_sibling = 0;
5968 newop->op_next = newop;
5970 kid->op_sibling = sibl;
5975 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5976 if (kid->op_type == OP_CONST &&
5977 (kid->op_private & OPpCONST_BARE))
5979 OP *newop = newGVOP(OP_GV, 0,
5980 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5982 if (!(o->op_private & 1) && /* if not unop */
5983 kid == cLISTOPo->op_last)
5984 cLISTOPo->op_last = newop;
5988 else if (kid->op_type == OP_READLINE) {
5989 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5990 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5993 I32 flags = OPf_SPECIAL;
5997 /* is this op a FH constructor? */
5998 if (is_handle_constructor(o,numargs)) {
5999 char *name = Nullch;
6003 /* Set a flag to tell rv2gv to vivify
6004 * need to "prove" flag does not mean something
6005 * else already - NI-S 1999/05/07
6008 if (kid->op_type == OP_PADSV) {
6009 SV **namep = av_fetch(PL_comppad_name,
6011 if (namep && *namep)
6012 name = SvPV(*namep, len);
6014 else if (kid->op_type == OP_RV2SV
6015 && kUNOP->op_first->op_type == OP_GV)
6017 GV *gv = cGVOPx_gv(kUNOP->op_first);
6019 len = GvNAMELEN(gv);
6021 else if (kid->op_type == OP_AELEM
6022 || kid->op_type == OP_HELEM)
6024 name = "__ANONIO__";
6030 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6031 namesv = PL_curpad[targ];
6032 (void)SvUPGRADE(namesv, SVt_PV);
6034 sv_setpvn(namesv, "$", 1);
6035 sv_catpvn(namesv, name, len);
6038 kid->op_sibling = 0;
6039 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6040 kid->op_targ = targ;
6041 kid->op_private |= priv;
6043 kid->op_sibling = sibl;
6049 mod(scalar(kid), type);
6053 tokid = &kid->op_sibling;
6054 kid = kid->op_sibling;
6056 o->op_private |= numargs;
6058 return too_many_arguments(o,OP_DESC(o));
6061 else if (PL_opargs[type] & OA_DEFGV) {
6063 return newUNOP(type, 0, newDEFSVOP());
6067 while (oa & OA_OPTIONAL)
6069 if (oa && oa != OA_LIST)
6070 return too_few_arguments(o,OP_DESC(o));
6076 Perl_ck_glob(pTHX_ OP *o)
6081 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6082 append_elem(OP_GLOB, o, newDEFSVOP());
6084 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6085 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6087 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6090 #if !defined(PERL_EXTERNAL_GLOB)
6091 /* XXX this can be tightened up and made more failsafe. */
6095 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6096 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6097 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6098 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6099 GvCV(gv) = GvCV(glob_gv);
6100 SvREFCNT_inc((SV*)GvCV(gv));
6101 GvIMPORTED_CV_on(gv);
6104 #endif /* PERL_EXTERNAL_GLOB */
6106 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6107 append_elem(OP_GLOB, o,
6108 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6109 o->op_type = OP_LIST;
6110 o->op_ppaddr = PL_ppaddr[OP_LIST];
6111 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6112 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6113 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6114 append_elem(OP_LIST, o,
6115 scalar(newUNOP(OP_RV2CV, 0,
6116 newGVOP(OP_GV, 0, gv)))));
6117 o = newUNOP(OP_NULL, 0, ck_subr(o));
6118 o->op_targ = OP_GLOB; /* hint at what it used to be */
6121 gv = newGVgen("main");
6123 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6129 Perl_ck_grep(pTHX_ OP *o)
6133 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6135 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6136 NewOp(1101, gwop, 1, LOGOP);
6138 if (o->op_flags & OPf_STACKED) {
6141 kid = cLISTOPo->op_first->op_sibling;
6142 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6145 kid->op_next = (OP*)gwop;
6146 o->op_flags &= ~OPf_STACKED;
6148 kid = cLISTOPo->op_first->op_sibling;
6149 if (type == OP_MAPWHILE)
6156 kid = cLISTOPo->op_first->op_sibling;
6157 if (kid->op_type != OP_NULL)
6158 Perl_croak(aTHX_ "panic: ck_grep");
6159 kid = kUNOP->op_first;
6161 gwop->op_type = type;
6162 gwop->op_ppaddr = PL_ppaddr[type];
6163 gwop->op_first = listkids(o);
6164 gwop->op_flags |= OPf_KIDS;
6165 gwop->op_private = 1;
6166 gwop->op_other = LINKLIST(kid);
6167 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6168 kid->op_next = (OP*)gwop;
6170 kid = cLISTOPo->op_first->op_sibling;
6171 if (!kid || !kid->op_sibling)
6172 return too_few_arguments(o,OP_DESC(o));
6173 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6174 mod(kid, OP_GREPSTART);
6180 Perl_ck_index(pTHX_ OP *o)
6182 if (o->op_flags & OPf_KIDS) {
6183 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6185 kid = kid->op_sibling; /* get past "big" */
6186 if (kid && kid->op_type == OP_CONST)
6187 fbm_compile(((SVOP*)kid)->op_sv, 0);
6193 Perl_ck_lengthconst(pTHX_ OP *o)
6195 /* XXX length optimization goes here */
6200 Perl_ck_lfun(pTHX_ OP *o)
6202 OPCODE type = o->op_type;
6203 return modkids(ck_fun(o), type);
6207 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6209 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6210 switch (cUNOPo->op_first->op_type) {
6212 /* This is needed for
6213 if (defined %stash::)
6214 to work. Do not break Tk.
6216 break; /* Globals via GV can be undef */
6218 case OP_AASSIGN: /* Is this a good idea? */
6219 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6220 "defined(@array) is deprecated");
6221 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6222 "\t(Maybe you should just omit the defined()?)\n");
6225 /* This is needed for
6226 if (defined %stash::)
6227 to work. Do not break Tk.
6229 break; /* Globals via GV can be undef */
6231 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6232 "defined(%%hash) is deprecated");
6233 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6234 "\t(Maybe you should just omit the defined()?)\n");
6245 Perl_ck_rfun(pTHX_ OP *o)
6247 OPCODE type = o->op_type;
6248 return refkids(ck_fun(o), type);
6252 Perl_ck_listiob(pTHX_ OP *o)
6256 kid = cLISTOPo->op_first;
6259 kid = cLISTOPo->op_first;
6261 if (kid->op_type == OP_PUSHMARK)
6262 kid = kid->op_sibling;
6263 if (kid && o->op_flags & OPf_STACKED)
6264 kid = kid->op_sibling;
6265 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6266 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6267 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6268 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6269 cLISTOPo->op_first->op_sibling = kid;
6270 cLISTOPo->op_last = kid;
6271 kid = kid->op_sibling;
6276 append_elem(o->op_type, o, newDEFSVOP());
6282 Perl_ck_sassign(pTHX_ OP *o)
6284 OP *kid = cLISTOPo->op_first;
6285 /* has a disposable target? */
6286 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6287 && !(kid->op_flags & OPf_STACKED)
6288 /* Cannot steal the second time! */
6289 && !(kid->op_private & OPpTARGET_MY))
6291 OP *kkid = kid->op_sibling;
6293 /* Can just relocate the target. */
6294 if (kkid && kkid->op_type == OP_PADSV
6295 && !(kkid->op_private & OPpLVAL_INTRO))
6297 kid->op_targ = kkid->op_targ;
6299 /* Now we do not need PADSV and SASSIGN. */
6300 kid->op_sibling = o->op_sibling; /* NULL */
6301 cLISTOPo->op_first = NULL;
6304 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6312 Perl_ck_match(pTHX_ OP *o)
6314 o->op_private |= OPpRUNTIME;
6319 Perl_ck_method(pTHX_ OP *o)
6321 OP *kid = cUNOPo->op_first;
6322 if (kid->op_type == OP_CONST) {
6323 SV* sv = kSVOP->op_sv;
6324 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6326 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6327 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6330 kSVOP->op_sv = Nullsv;
6332 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6341 Perl_ck_null(pTHX_ OP *o)
6347 Perl_ck_open(pTHX_ OP *o)
6349 HV *table = GvHV(PL_hintgv);
6353 svp = hv_fetch(table, "open_IN", 7, FALSE);
6355 mode = mode_from_discipline(*svp);
6356 if (mode & O_BINARY)
6357 o->op_private |= OPpOPEN_IN_RAW;
6358 else if (mode & O_TEXT)
6359 o->op_private |= OPpOPEN_IN_CRLF;
6362 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6364 mode = mode_from_discipline(*svp);
6365 if (mode & O_BINARY)
6366 o->op_private |= OPpOPEN_OUT_RAW;
6367 else if (mode & O_TEXT)
6368 o->op_private |= OPpOPEN_OUT_CRLF;
6371 if (o->op_type == OP_BACKTICK)
6377 Perl_ck_repeat(pTHX_ OP *o)
6379 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6380 o->op_private |= OPpREPEAT_DOLIST;
6381 cBINOPo->op_first = force_list(cBINOPo->op_first);
6389 Perl_ck_require(pTHX_ OP *o)
6393 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6394 SVOP *kid = (SVOP*)cUNOPo->op_first;
6396 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6398 for (s = SvPVX(kid->op_sv); *s; s++) {
6399 if (*s == ':' && s[1] == ':') {
6401 Move(s+2, s+1, strlen(s+2)+1, char);
6402 --SvCUR(kid->op_sv);
6405 if (SvREADONLY(kid->op_sv)) {
6406 SvREADONLY_off(kid->op_sv);
6407 sv_catpvn(kid->op_sv, ".pm", 3);
6408 SvREADONLY_on(kid->op_sv);
6411 sv_catpvn(kid->op_sv, ".pm", 3);
6415 /* handle override, if any */
6416 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6417 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6418 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6420 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6421 OP *kid = cUNOPo->op_first;
6422 cUNOPo->op_first = 0;
6424 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6425 append_elem(OP_LIST, kid,
6426 scalar(newUNOP(OP_RV2CV, 0,
6435 Perl_ck_return(pTHX_ OP *o)
6438 if (CvLVALUE(PL_compcv)) {
6439 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6440 mod(kid, OP_LEAVESUBLV);
6447 Perl_ck_retarget(pTHX_ OP *o)
6449 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6456 Perl_ck_select(pTHX_ OP *o)
6459 if (o->op_flags & OPf_KIDS) {
6460 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6461 if (kid && kid->op_sibling) {
6462 o->op_type = OP_SSELECT;
6463 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6465 return fold_constants(o);
6469 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6470 if (kid && kid->op_type == OP_RV2GV)
6471 kid->op_private &= ~HINT_STRICT_REFS;
6476 Perl_ck_shift(pTHX_ OP *o)
6478 I32 type = o->op_type;
6480 if (!(o->op_flags & OPf_KIDS)) {
6484 #ifdef USE_5005THREADS
6485 if (!CvUNIQUE(PL_compcv)) {
6486 argop = newOP(OP_PADAV, OPf_REF);
6487 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6490 argop = newUNOP(OP_RV2AV, 0,
6491 scalar(newGVOP(OP_GV, 0,
6492 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6495 argop = newUNOP(OP_RV2AV, 0,
6496 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6497 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6498 #endif /* USE_5005THREADS */
6499 return newUNOP(type, 0, scalar(argop));
6501 return scalar(modkids(ck_fun(o), type));
6505 Perl_ck_sort(pTHX_ OP *o)
6509 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6511 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6512 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6514 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6516 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6518 if (kid->op_type == OP_SCOPE) {
6522 else if (kid->op_type == OP_LEAVE) {
6523 if (o->op_type == OP_SORT) {
6524 op_null(kid); /* wipe out leave */
6527 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6528 if (k->op_next == kid)
6530 /* don't descend into loops */
6531 else if (k->op_type == OP_ENTERLOOP
6532 || k->op_type == OP_ENTERITER)
6534 k = cLOOPx(k)->op_lastop;
6539 kid->op_next = 0; /* just disconnect the leave */
6540 k = kLISTOP->op_first;
6545 if (o->op_type == OP_SORT) {
6546 /* provide scalar context for comparison function/block */
6552 o->op_flags |= OPf_SPECIAL;
6554 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6557 firstkid = firstkid->op_sibling;
6560 /* provide list context for arguments */
6561 if (o->op_type == OP_SORT)
6568 S_simplify_sort(pTHX_ OP *o)
6570 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6574 if (!(o->op_flags & OPf_STACKED))
6576 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6577 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6578 kid = kUNOP->op_first; /* get past null */
6579 if (kid->op_type != OP_SCOPE)
6581 kid = kLISTOP->op_last; /* get past scope */
6582 switch(kid->op_type) {
6590 k = kid; /* remember this node*/
6591 if (kBINOP->op_first->op_type != OP_RV2SV)
6593 kid = kBINOP->op_first; /* get past cmp */
6594 if (kUNOP->op_first->op_type != OP_GV)
6596 kid = kUNOP->op_first; /* get past rv2sv */
6598 if (GvSTASH(gv) != PL_curstash)
6600 if (strEQ(GvNAME(gv), "a"))
6602 else if (strEQ(GvNAME(gv), "b"))
6606 kid = k; /* back to cmp */
6607 if (kBINOP->op_last->op_type != OP_RV2SV)
6609 kid = kBINOP->op_last; /* down to 2nd arg */
6610 if (kUNOP->op_first->op_type != OP_GV)
6612 kid = kUNOP->op_first; /* get past rv2sv */
6614 if (GvSTASH(gv) != PL_curstash
6616 ? strNE(GvNAME(gv), "a")
6617 : strNE(GvNAME(gv), "b")))
6619 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6621 o->op_private |= OPpSORT_REVERSE;
6622 if (k->op_type == OP_NCMP)
6623 o->op_private |= OPpSORT_NUMERIC;
6624 if (k->op_type == OP_I_NCMP)
6625 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6626 kid = cLISTOPo->op_first->op_sibling;
6627 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6628 op_free(kid); /* then delete it */
6632 Perl_ck_split(pTHX_ OP *o)
6636 if (o->op_flags & OPf_STACKED)
6637 return no_fh_allowed(o);
6639 kid = cLISTOPo->op_first;
6640 if (kid->op_type != OP_NULL)
6641 Perl_croak(aTHX_ "panic: ck_split");
6642 kid = kid->op_sibling;
6643 op_free(cLISTOPo->op_first);
6644 cLISTOPo->op_first = kid;
6646 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6647 cLISTOPo->op_last = kid; /* There was only one element previously */
6650 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6651 OP *sibl = kid->op_sibling;
6652 kid->op_sibling = 0;
6653 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6654 if (cLISTOPo->op_first == cLISTOPo->op_last)
6655 cLISTOPo->op_last = kid;
6656 cLISTOPo->op_first = kid;
6657 kid->op_sibling = sibl;
6660 kid->op_type = OP_PUSHRE;
6661 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6663 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6664 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6665 "Use of /g modifier is meaningless in split");
6668 if (!kid->op_sibling)
6669 append_elem(OP_SPLIT, o, newDEFSVOP());
6671 kid = kid->op_sibling;
6674 if (!kid->op_sibling)
6675 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6677 kid = kid->op_sibling;
6680 if (kid->op_sibling)
6681 return too_many_arguments(o,OP_DESC(o));
6687 Perl_ck_join(pTHX_ OP *o)
6689 if (ckWARN(WARN_SYNTAX)) {
6690 OP *kid = cLISTOPo->op_first->op_sibling;
6691 if (kid && kid->op_type == OP_MATCH) {
6692 char *pmstr = "STRING";
6693 if (PM_GETRE(kPMOP))
6694 pmstr = PM_GETRE(kPMOP)->precomp;
6695 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6696 "/%s/ should probably be written as \"%s\"",
6704 Perl_ck_subr(pTHX_ OP *o)
6706 OP *prev = ((cUNOPo->op_first->op_sibling)
6707 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6708 OP *o2 = prev->op_sibling;
6715 I32 contextclass = 0;
6719 o->op_private |= OPpENTERSUB_HASTARG;
6720 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6721 if (cvop->op_type == OP_RV2CV) {
6723 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6724 op_null(cvop); /* disable rv2cv */
6725 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6726 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6727 GV *gv = cGVOPx_gv(tmpop);
6730 tmpop->op_private |= OPpEARLY_CV;
6731 else if (SvPOK(cv)) {
6732 namegv = CvANON(cv) ? gv : CvGV(cv);
6733 proto = SvPV((SV*)cv, n_a);
6737 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6738 if (o2->op_type == OP_CONST)
6739 o2->op_private &= ~OPpCONST_STRICT;
6740 else if (o2->op_type == OP_LIST) {
6741 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6742 if (o && o->op_type == OP_CONST)
6743 o->op_private &= ~OPpCONST_STRICT;
6746 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6747 if (PERLDB_SUB && PL_curstash != PL_debstash)
6748 o->op_private |= OPpENTERSUB_DB;
6749 while (o2 != cvop) {
6753 return too_many_arguments(o, gv_ename(namegv));
6771 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6773 arg == 1 ? "block or sub {}" : "sub {}",
6774 gv_ename(namegv), o2);
6777 /* '*' allows any scalar type, including bareword */
6780 if (o2->op_type == OP_RV2GV)
6781 goto wrapref; /* autoconvert GLOB -> GLOBref */
6782 else if (o2->op_type == OP_CONST)
6783 o2->op_private &= ~OPpCONST_STRICT;
6784 else if (o2->op_type == OP_ENTERSUB) {
6785 /* accidental subroutine, revert to bareword */
6786 OP *gvop = ((UNOP*)o2)->op_first;
6787 if (gvop && gvop->op_type == OP_NULL) {
6788 gvop = ((UNOP*)gvop)->op_first;
6790 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6793 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6794 (gvop = ((UNOP*)gvop)->op_first) &&
6795 gvop->op_type == OP_GV)
6797 GV *gv = cGVOPx_gv(gvop);
6798 OP *sibling = o2->op_sibling;
6799 SV *n = newSVpvn("",0);
6801 gv_fullname3(n, gv, "");
6802 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6803 sv_chop(n, SvPVX(n)+6);
6804 o2 = newSVOP(OP_CONST, 0, n);
6805 prev->op_sibling = o2;
6806 o2->op_sibling = sibling;
6822 if (contextclass++ == 0) {
6823 e = strchr(proto, ']');
6824 if (!e || e == proto)
6837 while (*--p != '[');
6838 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6839 gv_ename(namegv), o2);
6845 if (o2->op_type == OP_RV2GV)
6848 bad_type(arg, "symbol", gv_ename(namegv), o2);
6851 if (o2->op_type == OP_ENTERSUB)
6854 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6857 if (o2->op_type == OP_RV2SV ||
6858 o2->op_type == OP_PADSV ||
6859 o2->op_type == OP_HELEM ||
6860 o2->op_type == OP_AELEM ||
6861 o2->op_type == OP_THREADSV)
6864 bad_type(arg, "scalar", gv_ename(namegv), o2);
6867 if (o2->op_type == OP_RV2AV ||
6868 o2->op_type == OP_PADAV)
6871 bad_type(arg, "array", gv_ename(namegv), o2);
6874 if (o2->op_type == OP_RV2HV ||
6875 o2->op_type == OP_PADHV)
6878 bad_type(arg, "hash", gv_ename(namegv), o2);
6883 OP* sib = kid->op_sibling;
6884 kid->op_sibling = 0;
6885 o2 = newUNOP(OP_REFGEN, 0, kid);
6886 o2->op_sibling = sib;
6887 prev->op_sibling = o2;
6889 if (contextclass && e) {
6904 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6905 gv_ename(namegv), SvPV((SV*)cv, n_a));
6910 mod(o2, OP_ENTERSUB);
6912 o2 = o2->op_sibling;
6914 if (proto && !optional &&
6915 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6916 return too_few_arguments(o, gv_ename(namegv));
6921 Perl_ck_svconst(pTHX_ OP *o)
6923 SvREADONLY_on(cSVOPo->op_sv);
6928 Perl_ck_trunc(pTHX_ OP *o)
6930 if (o->op_flags & OPf_KIDS) {
6931 SVOP *kid = (SVOP*)cUNOPo->op_first;
6933 if (kid->op_type == OP_NULL)
6934 kid = (SVOP*)kid->op_sibling;
6935 if (kid && kid->op_type == OP_CONST &&
6936 (kid->op_private & OPpCONST_BARE))
6938 o->op_flags |= OPf_SPECIAL;
6939 kid->op_private &= ~OPpCONST_STRICT;
6946 Perl_ck_substr(pTHX_ OP *o)
6949 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6950 OP *kid = cLISTOPo->op_first;
6952 if (kid->op_type == OP_NULL)
6953 kid = kid->op_sibling;
6955 kid->op_flags |= OPf_MOD;
6961 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6964 Perl_peep(pTHX_ register OP *o)
6966 register OP* oldop = 0;
6968 if (!o || o->op_seq)
6972 SAVEVPTR(PL_curcop);
6973 for (; o; o = o->op_next) {
6979 switch (o->op_type) {
6983 PL_curcop = ((COP*)o); /* for warnings */
6984 o->op_seq = PL_op_seqmax++;
6988 if (cSVOPo->op_private & OPpCONST_STRICT)
6989 no_bareword_allowed(o);
6991 /* Relocate sv to the pad for thread safety.
6992 * Despite being a "constant", the SV is written to,
6993 * for reference counts, sv_upgrade() etc. */
6995 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6996 if (SvPADTMP(cSVOPo->op_sv)) {
6997 /* If op_sv is already a PADTMP then it is being used by
6998 * some pad, so make a copy. */
6999 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
7000 SvREADONLY_on(PL_curpad[ix]);
7001 SvREFCNT_dec(cSVOPo->op_sv);
7004 SvREFCNT_dec(PL_curpad[ix]);
7005 SvPADTMP_on(cSVOPo->op_sv);
7006 PL_curpad[ix] = cSVOPo->op_sv;
7007 /* XXX I don't know how this isn't readonly already. */
7008 SvREADONLY_on(PL_curpad[ix]);
7010 cSVOPo->op_sv = Nullsv;
7014 o->op_seq = PL_op_seqmax++;
7018 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7019 if (o->op_next->op_private & OPpTARGET_MY) {
7020 if (o->op_flags & OPf_STACKED) /* chained concats */
7021 goto ignore_optimization;
7023 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7024 o->op_targ = o->op_next->op_targ;
7025 o->op_next->op_targ = 0;
7026 o->op_private |= OPpTARGET_MY;
7029 op_null(o->op_next);
7031 ignore_optimization:
7032 o->op_seq = PL_op_seqmax++;
7035 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7036 o->op_seq = PL_op_seqmax++;
7037 break; /* Scalar stub must produce undef. List stub is noop */
7041 if (o->op_targ == OP_NEXTSTATE
7042 || o->op_targ == OP_DBSTATE
7043 || o->op_targ == OP_SETSTATE)
7045 PL_curcop = ((COP*)o);
7047 /* XXX: We avoid setting op_seq here to prevent later calls
7048 to peep() from mistakenly concluding that optimisation
7049 has already occurred. This doesn't fix the real problem,
7050 though (See 20010220.007). AMS 20010719 */
7051 if (oldop && o->op_next) {
7052 oldop->op_next = o->op_next;
7060 if (oldop && o->op_next) {
7061 oldop->op_next = o->op_next;
7064 o->op_seq = PL_op_seqmax++;
7068 if (o->op_next->op_type == OP_RV2SV) {
7069 if (!(o->op_next->op_private & OPpDEREF)) {
7070 op_null(o->op_next);
7071 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7073 o->op_next = o->op_next->op_next;
7074 o->op_type = OP_GVSV;
7075 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7078 else if (o->op_next->op_type == OP_RV2AV) {
7079 OP* pop = o->op_next->op_next;
7081 if (pop && pop->op_type == OP_CONST &&
7082 (PL_op = pop->op_next) &&
7083 pop->op_next->op_type == OP_AELEM &&
7084 !(pop->op_next->op_private &
7085 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7086 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7091 op_null(o->op_next);
7092 op_null(pop->op_next);
7094 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7095 o->op_next = pop->op_next->op_next;
7096 o->op_type = OP_AELEMFAST;
7097 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7098 o->op_private = (U8)i;
7103 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7105 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7106 /* XXX could check prototype here instead of just carping */
7107 SV *sv = sv_newmortal();
7108 gv_efullname3(sv, gv, Nullch);
7109 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7110 "%s() called too early to check prototype",
7114 else if (o->op_next->op_type == OP_READLINE
7115 && o->op_next->op_next->op_type == OP_CONCAT
7116 && (o->op_next->op_next->op_flags & OPf_STACKED))
7118 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7119 o->op_type = OP_RCATLINE;
7120 o->op_flags |= OPf_STACKED;
7121 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7122 op_null(o->op_next->op_next);
7123 op_null(o->op_next);
7126 o->op_seq = PL_op_seqmax++;
7139 o->op_seq = PL_op_seqmax++;
7140 while (cLOGOP->op_other->op_type == OP_NULL)
7141 cLOGOP->op_other = cLOGOP->op_other->op_next;
7142 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7147 o->op_seq = PL_op_seqmax++;
7148 while (cLOOP->op_redoop->op_type == OP_NULL)
7149 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7150 peep(cLOOP->op_redoop);
7151 while (cLOOP->op_nextop->op_type == OP_NULL)
7152 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7153 peep(cLOOP->op_nextop);
7154 while (cLOOP->op_lastop->op_type == OP_NULL)
7155 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7156 peep(cLOOP->op_lastop);
7162 o->op_seq = PL_op_seqmax++;
7163 while (cPMOP->op_pmreplstart &&
7164 cPMOP->op_pmreplstart->op_type == OP_NULL)
7165 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7166 peep(cPMOP->op_pmreplstart);
7170 o->op_seq = PL_op_seqmax++;
7171 if (ckWARN(WARN_SYNTAX) && o->op_next
7172 && o->op_next->op_type == OP_NEXTSTATE) {
7173 if (o->op_next->op_sibling &&
7174 o->op_next->op_sibling->op_type != OP_EXIT &&
7175 o->op_next->op_sibling->op_type != OP_WARN &&
7176 o->op_next->op_sibling->op_type != OP_DIE) {
7177 line_t oldline = CopLINE(PL_curcop);
7179 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7180 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7181 "Statement unlikely to be reached");
7182 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7183 "\t(Maybe you meant system() when you said exec()?)\n");
7184 CopLINE_set(PL_curcop, oldline);
7195 o->op_seq = PL_op_seqmax++;
7197 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7200 /* Make the CONST have a shared SV */
7201 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7202 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7203 key = SvPV(sv, keylen);
7204 lexname = newSVpvn_share(key,
7205 SvUTF8(sv) ? -(I32)keylen : keylen,
7214 o->op_seq = PL_op_seqmax++;
7224 char* Perl_custom_op_name(pTHX_ OP* o)
7226 IV index = PTR2IV(o->op_ppaddr);
7230 if (!PL_custom_op_names) /* This probably shouldn't happen */
7231 return PL_op_name[OP_CUSTOM];
7233 keysv = sv_2mortal(newSViv(index));
7235 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7237 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7239 return SvPV_nolen(HeVAL(he));
7242 char* Perl_custom_op_desc(pTHX_ OP* o)
7244 IV index = PTR2IV(o->op_ppaddr);
7248 if (!PL_custom_op_descs)
7249 return PL_op_desc[OP_CUSTOM];
7251 keysv = sv_2mortal(newSViv(index));
7253 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7255 return PL_op_desc[OP_CUSTOM];
7257 return SvPV_nolen(HeVAL(he));
7263 /* Efficient sub that returns a constant scalar value. */
7265 const_sv_xsub(pTHX_ CV* cv)
7270 Perl_croak(aTHX_ "usage: %s::%s()",
7271 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7275 ST(0) = (SV*)XSANY.any_ptr;