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; 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 &&
312 seq > 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 &&
475 seq > 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 */
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];
1247 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1252 if (o->op_flags & OPf_STACKED)
1259 if (!(o->op_flags & OPf_KIDS))
1268 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1275 /* all requires must return a boolean value */
1276 o->op_flags &= ~OPf_WANT;
1281 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1282 if (!kPMOP->op_pmreplroot)
1283 deprecate_old("implicit split to @_");
1287 if (useless && ckWARN(WARN_VOID))
1288 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1293 Perl_listkids(pTHX_ OP *o)
1296 if (o && o->op_flags & OPf_KIDS) {
1297 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1304 Perl_list(pTHX_ OP *o)
1308 /* assumes no premature commitment */
1309 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1310 || o->op_type == OP_RETURN)
1315 if ((o->op_private & OPpTARGET_MY)
1316 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1318 return o; /* As if inside SASSIGN */
1321 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1323 switch (o->op_type) {
1326 list(cBINOPo->op_first);
1331 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1339 if (!(o->op_flags & OPf_KIDS))
1341 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1342 list(cBINOPo->op_first);
1343 return gen_constant_list(o);
1350 kid = cLISTOPo->op_first;
1352 while ((kid = kid->op_sibling)) {
1353 if (kid->op_sibling)
1358 WITH_THR(PL_curcop = &PL_compiling);
1362 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1363 if (kid->op_sibling)
1368 WITH_THR(PL_curcop = &PL_compiling);
1371 /* all requires must return a boolean value */
1372 o->op_flags &= ~OPf_WANT;
1379 Perl_scalarseq(pTHX_ OP *o)
1384 if (o->op_type == OP_LINESEQ ||
1385 o->op_type == OP_SCOPE ||
1386 o->op_type == OP_LEAVE ||
1387 o->op_type == OP_LEAVETRY)
1389 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1390 if (kid->op_sibling) {
1394 PL_curcop = &PL_compiling;
1396 o->op_flags &= ~OPf_PARENS;
1397 if (PL_hints & HINT_BLOCK_SCOPE)
1398 o->op_flags |= OPf_PARENS;
1401 o = newOP(OP_STUB, 0);
1406 S_modkids(pTHX_ OP *o, I32 type)
1409 if (o && o->op_flags & OPf_KIDS) {
1410 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1417 Perl_mod(pTHX_ OP *o, I32 type)
1422 if (!o || PL_error_count)
1425 if ((o->op_private & OPpTARGET_MY)
1426 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1431 switch (o->op_type) {
1436 if (!(o->op_private & (OPpCONST_ARYBASE)))
1438 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1439 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1443 SAVEI32(PL_compiling.cop_arybase);
1444 PL_compiling.cop_arybase = 0;
1446 else if (type == OP_REFGEN)
1449 Perl_croak(aTHX_ "That use of $[ is unsupported");
1452 if (o->op_flags & OPf_PARENS)
1456 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1457 !(o->op_flags & OPf_STACKED)) {
1458 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1459 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1460 assert(cUNOPo->op_first->op_type == OP_NULL);
1461 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1464 else if (o->op_private & OPpENTERSUB_NOMOD)
1466 else { /* lvalue subroutine call */
1467 o->op_private |= OPpLVAL_INTRO;
1468 PL_modcount = RETURN_UNLIMITED_NUMBER;
1469 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1470 /* Backward compatibility mode: */
1471 o->op_private |= OPpENTERSUB_INARGS;
1474 else { /* Compile-time error message: */
1475 OP *kid = cUNOPo->op_first;
1479 if (kid->op_type == OP_PUSHMARK)
1481 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1483 "panic: unexpected lvalue entersub "
1484 "args: type/targ %ld:%"UVuf,
1485 (long)kid->op_type, (UV)kid->op_targ);
1486 kid = kLISTOP->op_first;
1488 while (kid->op_sibling)
1489 kid = kid->op_sibling;
1490 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1492 if (kid->op_type == OP_METHOD_NAMED
1493 || kid->op_type == OP_METHOD)
1497 NewOp(1101, newop, 1, UNOP);
1498 newop->op_type = OP_RV2CV;
1499 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1500 newop->op_first = Nullop;
1501 newop->op_next = (OP*)newop;
1502 kid->op_sibling = (OP*)newop;
1503 newop->op_private |= OPpLVAL_INTRO;
1507 if (kid->op_type != OP_RV2CV)
1509 "panic: unexpected lvalue entersub "
1510 "entry via type/targ %ld:%"UVuf,
1511 (long)kid->op_type, (UV)kid->op_targ);
1512 kid->op_private |= OPpLVAL_INTRO;
1513 break; /* Postpone until runtime */
1517 kid = kUNOP->op_first;
1518 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1519 kid = kUNOP->op_first;
1520 if (kid->op_type == OP_NULL)
1522 "Unexpected constant lvalue entersub "
1523 "entry via type/targ %ld:%"UVuf,
1524 (long)kid->op_type, (UV)kid->op_targ);
1525 if (kid->op_type != OP_GV) {
1526 /* Restore RV2CV to check lvalueness */
1528 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1529 okid->op_next = kid->op_next;
1530 kid->op_next = okid;
1533 okid->op_next = Nullop;
1534 okid->op_type = OP_RV2CV;
1536 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1537 okid->op_private |= OPpLVAL_INTRO;
1541 cv = GvCV(kGVOP_gv);
1551 /* grep, foreach, subcalls, refgen */
1552 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1554 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1555 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1557 : (o->op_type == OP_ENTERSUB
1558 ? "non-lvalue subroutine call"
1560 type ? PL_op_desc[type] : "local"));
1574 case OP_RIGHT_SHIFT:
1583 if (!(o->op_flags & OPf_STACKED))
1589 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1595 if (!type && cUNOPo->op_first->op_type != OP_GV)
1596 Perl_croak(aTHX_ "Can't localize through a reference");
1597 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1598 PL_modcount = RETURN_UNLIMITED_NUMBER;
1599 return o; /* Treat \(@foo) like ordinary list. */
1603 if (scalar_mod_type(o, type))
1605 ref(cUNOPo->op_first, o->op_type);
1609 if (type == OP_LEAVESUBLV)
1610 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;
1635 PL_modcount = RETURN_UNLIMITED_NUMBER;
1636 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1637 return o; /* Treat \(@foo) like ordinary list. */
1638 if (scalar_mod_type(o, type))
1640 if (type == OP_LEAVESUBLV)
1641 o->op_private |= OPpMAYBE_LVSUB;
1646 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1647 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1650 #ifdef USE_5005THREADS
1652 PL_modcount++; /* XXX ??? */
1654 #endif /* USE_5005THREADS */
1660 if (type != OP_SASSIGN)
1664 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1669 if (type == OP_LEAVESUBLV)
1670 o->op_private |= OPpMAYBE_LVSUB;
1672 pad_free(o->op_targ);
1673 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1674 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1675 if (o->op_flags & OPf_KIDS)
1676 mod(cBINOPo->op_first->op_sibling, type);
1681 ref(cBINOPo->op_first, o->op_type);
1682 if (type == OP_ENTERSUB &&
1683 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1684 o->op_private |= OPpLVAL_DEFER;
1685 if (type == OP_LEAVESUBLV)
1686 o->op_private |= OPpMAYBE_LVSUB;
1694 if (o->op_flags & OPf_KIDS)
1695 mod(cLISTOPo->op_last, type);
1699 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1701 else if (!(o->op_flags & OPf_KIDS))
1703 if (o->op_targ != OP_LIST) {
1704 mod(cBINOPo->op_first, type);
1709 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1714 if (type != OP_LEAVESUBLV)
1716 break; /* mod()ing was handled by ck_return() */
1719 /* [20011101.069] File test operators interpret OPf_REF to mean that
1720 their argument is a filehandle; thus \stat(".") should not set
1722 if (type == OP_REFGEN &&
1723 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1726 if (type != OP_LEAVESUBLV)
1727 o->op_flags |= OPf_MOD;
1729 if (type == OP_AASSIGN || type == OP_SASSIGN)
1730 o->op_flags |= OPf_SPECIAL|OPf_REF;
1732 o->op_private |= OPpLVAL_INTRO;
1733 o->op_flags &= ~OPf_SPECIAL;
1734 PL_hints |= HINT_BLOCK_SCOPE;
1736 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1737 && type != OP_LEAVESUBLV)
1738 o->op_flags |= OPf_REF;
1743 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1747 if (o->op_type == OP_RV2GV)
1771 case OP_RIGHT_SHIFT:
1790 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1792 switch (o->op_type) {
1800 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1813 Perl_refkids(pTHX_ OP *o, I32 type)
1816 if (o && o->op_flags & OPf_KIDS) {
1817 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1824 Perl_ref(pTHX_ OP *o, I32 type)
1828 if (!o || PL_error_count)
1831 switch (o->op_type) {
1833 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1834 !(o->op_flags & OPf_STACKED)) {
1835 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1836 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1837 assert(cUNOPo->op_first->op_type == OP_NULL);
1838 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1839 o->op_flags |= OPf_SPECIAL;
1844 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1848 if (type == OP_DEFINED)
1849 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1850 ref(cUNOPo->op_first, o->op_type);
1853 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1854 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1855 : type == OP_RV2HV ? OPpDEREF_HV
1857 o->op_flags |= OPf_MOD;
1862 o->op_flags |= OPf_MOD; /* XXX ??? */
1867 o->op_flags |= OPf_REF;
1870 if (type == OP_DEFINED)
1871 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1872 ref(cUNOPo->op_first, o->op_type);
1877 o->op_flags |= OPf_REF;
1882 if (!(o->op_flags & OPf_KIDS))
1884 ref(cBINOPo->op_first, type);
1888 ref(cBINOPo->op_first, o->op_type);
1889 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1890 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1891 : type == OP_RV2HV ? OPpDEREF_HV
1893 o->op_flags |= OPf_MOD;
1901 if (!(o->op_flags & OPf_KIDS))
1903 ref(cLISTOPo->op_last, type);
1913 S_dup_attrlist(pTHX_ OP *o)
1917 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1918 * where the first kid is OP_PUSHMARK and the remaining ones
1919 * are OP_CONST. We need to push the OP_CONST values.
1921 if (o->op_type == OP_CONST)
1922 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1924 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1925 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1926 if (o->op_type == OP_CONST)
1927 rop = append_elem(OP_LIST, rop,
1928 newSVOP(OP_CONST, o->op_flags,
1929 SvREFCNT_inc(cSVOPo->op_sv)));
1936 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1940 /* fake up C<use attributes $pkg,$rv,@attrs> */
1941 ENTER; /* need to protect against side-effects of 'use' */
1944 stashsv = newSVpv(HvNAME(stash), 0);
1946 stashsv = &PL_sv_no;
1948 #define ATTRSMODULE "attributes"
1949 #define ATTRSMODULE_PM "attributes.pm"
1953 /* Don't force the C<use> if we don't need it. */
1954 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1955 sizeof(ATTRSMODULE_PM)-1, 0);
1956 if (svp && *svp != &PL_sv_undef)
1957 ; /* already in %INC */
1959 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1960 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1964 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1965 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1967 prepend_elem(OP_LIST,
1968 newSVOP(OP_CONST, 0, stashsv),
1969 prepend_elem(OP_LIST,
1970 newSVOP(OP_CONST, 0,
1972 dup_attrlist(attrs))));
1978 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1980 OP *pack, *imop, *arg;
1986 assert(target->op_type == OP_PADSV ||
1987 target->op_type == OP_PADHV ||
1988 target->op_type == OP_PADAV);
1990 /* Ensure that attributes.pm is loaded. */
1991 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1993 /* Need package name for method call. */
1994 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1996 /* Build up the real arg-list. */
1998 stashsv = newSVpv(HvNAME(stash), 0);
2000 stashsv = &PL_sv_no;
2001 arg = newOP(OP_PADSV, 0);
2002 arg->op_targ = target->op_targ;
2003 arg = prepend_elem(OP_LIST,
2004 newSVOP(OP_CONST, 0, stashsv),
2005 prepend_elem(OP_LIST,
2006 newUNOP(OP_REFGEN, 0,
2007 mod(arg, OP_REFGEN)),
2008 dup_attrlist(attrs)));
2010 /* Fake up a method call to import */
2011 meth = newSVpvn("import", 6);
2012 (void)SvUPGRADE(meth, SVt_PVIV);
2013 (void)SvIOK_on(meth);
2014 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2015 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2016 append_elem(OP_LIST,
2017 prepend_elem(OP_LIST, pack, list(arg)),
2018 newSVOP(OP_METHOD_NAMED, 0, meth)));
2019 imop->op_private |= OPpENTERSUB_NOMOD;
2021 /* Combine the ops. */
2022 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2026 =notfor apidoc apply_attrs_string
2028 Attempts to apply a list of attributes specified by the C<attrstr> and
2029 C<len> arguments to the subroutine identified by the C<cv> argument which
2030 is expected to be associated with the package identified by the C<stashpv>
2031 argument (see L<attributes>). It gets this wrong, though, in that it
2032 does not correctly identify the boundaries of the individual attribute
2033 specifications within C<attrstr>. This is not really intended for the
2034 public API, but has to be listed here for systems such as AIX which
2035 need an explicit export list for symbols. (It's called from XS code
2036 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2037 to respect attribute syntax properly would be welcome.
2043 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2044 char *attrstr, STRLEN len)
2049 len = strlen(attrstr);
2053 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2055 char *sstr = attrstr;
2056 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2057 attrs = append_elem(OP_LIST, attrs,
2058 newSVOP(OP_CONST, 0,
2059 newSVpvn(sstr, attrstr-sstr)));
2063 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2064 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2065 Nullsv, prepend_elem(OP_LIST,
2066 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2067 prepend_elem(OP_LIST,
2068 newSVOP(OP_CONST, 0,
2074 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2079 if (!o || PL_error_count)
2083 if (type == OP_LIST) {
2084 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2085 my_kid(kid, attrs, imopsp);
2086 } else if (type == OP_UNDEF) {
2088 } else if (type == OP_RV2SV || /* "our" declaration */
2090 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2091 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2092 yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
2095 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2097 PL_in_my_stash = Nullhv;
2098 apply_attrs(GvSTASH(gv),
2099 (type == OP_RV2SV ? GvSV(gv) :
2100 type == OP_RV2AV ? (SV*)GvAV(gv) :
2101 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2104 o->op_private |= OPpOUR_INTRO;
2107 else if (type != OP_PADSV &&
2110 type != OP_PUSHMARK)
2112 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2114 PL_in_my == KEY_our ? "our" : "my"));
2117 else if (attrs && type != OP_PUSHMARK) {
2122 PL_in_my_stash = Nullhv;
2124 /* check for C<my Dog $spot> when deciding package */
2125 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2126 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2127 stash = SvSTASH(*namesvp);
2129 stash = PL_curstash;
2130 apply_attrs_my(stash, o, attrs, imopsp);
2132 o->op_flags |= OPf_MOD;
2133 o->op_private |= OPpLVAL_INTRO;
2138 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2141 int maybe_scalar = 0;
2143 if (o->op_flags & OPf_PARENS)
2149 o = my_kid(o, attrs, &rops);
2151 if (maybe_scalar && o->op_type == OP_PADSV) {
2152 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2153 o->op_private |= OPpLVAL_INTRO;
2156 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2159 PL_in_my_stash = Nullhv;
2164 Perl_my(pTHX_ OP *o)
2166 return my_attrs(o, Nullop);
2170 Perl_sawparens(pTHX_ OP *o)
2173 o->op_flags |= OPf_PARENS;
2178 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2182 if (ckWARN(WARN_MISC) &&
2183 (left->op_type == OP_RV2AV ||
2184 left->op_type == OP_RV2HV ||
2185 left->op_type == OP_PADAV ||
2186 left->op_type == OP_PADHV)) {
2187 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2188 right->op_type == OP_TRANS)
2189 ? right->op_type : OP_MATCH];
2190 const char *sample = ((left->op_type == OP_RV2AV ||
2191 left->op_type == OP_PADAV)
2192 ? "@array" : "%hash");
2193 Perl_warner(aTHX_ packWARN(WARN_MISC),
2194 "Applying %s to %s will act on scalar(%s)",
2195 desc, sample, sample);
2198 if (right->op_type == OP_CONST &&
2199 cSVOPx(right)->op_private & OPpCONST_BARE &&
2200 cSVOPx(right)->op_private & OPpCONST_STRICT)
2202 no_bareword_allowed(right);
2205 if (!(right->op_flags & OPf_STACKED) &&
2206 (right->op_type == OP_MATCH ||
2207 right->op_type == OP_SUBST ||
2208 right->op_type == OP_TRANS)) {
2209 right->op_flags |= OPf_STACKED;
2210 if (right->op_type != OP_MATCH &&
2211 ! (right->op_type == OP_TRANS &&
2212 right->op_private & OPpTRANS_IDENTICAL))
2213 left = mod(left, right->op_type);
2214 if (right->op_type == OP_TRANS)
2215 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2217 o = prepend_elem(right->op_type, scalar(left), right);
2219 return newUNOP(OP_NOT, 0, scalar(o));
2223 return bind_match(type, left,
2224 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2228 Perl_invert(pTHX_ OP *o)
2232 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2233 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2237 Perl_scope(pTHX_ OP *o)
2240 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2241 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2242 o->op_type = OP_LEAVE;
2243 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2246 if (o->op_type == OP_LINESEQ) {
2248 o->op_type = OP_SCOPE;
2249 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2250 kid = ((LISTOP*)o)->op_first;
2251 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2255 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2262 Perl_save_hints(pTHX)
2265 SAVESPTR(GvHV(PL_hintgv));
2266 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2267 SAVEFREESV(GvHV(PL_hintgv));
2271 Perl_block_start(pTHX_ int full)
2273 int retval = PL_savestack_ix;
2275 SAVEI32(PL_comppad_name_floor);
2276 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2278 PL_comppad_name_fill = PL_comppad_name_floor;
2279 if (PL_comppad_name_floor < 0)
2280 PL_comppad_name_floor = 0;
2281 SAVEI32(PL_min_intro_pending);
2282 SAVEI32(PL_max_intro_pending);
2283 PL_min_intro_pending = 0;
2284 SAVEI32(PL_comppad_name_fill);
2285 SAVEI32(PL_padix_floor);
2286 PL_padix_floor = PL_padix;
2287 PL_pad_reset_pending = FALSE;
2289 PL_hints &= ~HINT_BLOCK_SCOPE;
2290 SAVESPTR(PL_compiling.cop_warnings);
2291 if (! specialWARN(PL_compiling.cop_warnings)) {
2292 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2293 SAVEFREESV(PL_compiling.cop_warnings) ;
2295 SAVESPTR(PL_compiling.cop_io);
2296 if (! specialCopIO(PL_compiling.cop_io)) {
2297 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2298 SAVEFREESV(PL_compiling.cop_io) ;
2304 Perl_block_end(pTHX_ I32 floor, OP *seq)
2306 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2307 line_t copline = PL_copline;
2308 /* there should be a nextstate in every block */
2309 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2310 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2312 PL_pad_reset_pending = FALSE;
2313 PL_compiling.op_private = PL_hints;
2315 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2316 pad_leavemy(PL_comppad_name_fill);
2324 #ifdef USE_5005THREADS
2325 OP *o = newOP(OP_THREADSV, 0);
2326 o->op_targ = find_threadsv("_");
2329 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2330 #endif /* USE_5005THREADS */
2334 Perl_newPROG(pTHX_ OP *o)
2339 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2340 ((PL_in_eval & EVAL_KEEPERR)
2341 ? OPf_SPECIAL : 0), o);
2342 PL_eval_start = linklist(PL_eval_root);
2343 PL_eval_root->op_private |= OPpREFCOUNTED;
2344 OpREFCNT_set(PL_eval_root, 1);
2345 PL_eval_root->op_next = 0;
2346 CALL_PEEP(PL_eval_start);
2351 PL_main_root = scope(sawparens(scalarvoid(o)));
2352 PL_curcop = &PL_compiling;
2353 PL_main_start = LINKLIST(PL_main_root);
2354 PL_main_root->op_private |= OPpREFCOUNTED;
2355 OpREFCNT_set(PL_main_root, 1);
2356 PL_main_root->op_next = 0;
2357 CALL_PEEP(PL_main_start);
2360 /* Register with debugger */
2362 CV *cv = get_cv("DB::postponed", FALSE);
2366 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2368 call_sv((SV*)cv, G_DISCARD);
2375 Perl_localize(pTHX_ OP *o, I32 lex)
2377 if (o->op_flags & OPf_PARENS)
2380 if (ckWARN(WARN_PARENTHESIS)
2381 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2383 char *s = PL_bufptr;
2385 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2388 if (*s == ';' || *s == '=')
2389 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2390 "Parentheses missing around \"%s\" list",
2391 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2397 o = mod(o, OP_NULL); /* a bit kludgey */
2399 PL_in_my_stash = Nullhv;
2404 Perl_jmaybe(pTHX_ OP *o)
2406 if (o->op_type == OP_LIST) {
2408 #ifdef USE_5005THREADS
2409 o2 = newOP(OP_THREADSV, 0);
2410 o2->op_targ = find_threadsv(";");
2412 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2413 #endif /* USE_5005THREADS */
2414 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2420 Perl_fold_constants(pTHX_ register OP *o)
2423 I32 type = o->op_type;
2426 if (PL_opargs[type] & OA_RETSCALAR)
2428 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2429 o->op_targ = pad_alloc(type, SVs_PADTMP);
2431 /* integerize op, unless it happens to be C<-foo>.
2432 * XXX should pp_i_negate() do magic string negation instead? */
2433 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2434 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2435 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2437 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2440 if (!(PL_opargs[type] & OA_FOLDCONST))
2445 /* XXX might want a ck_negate() for this */
2446 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2458 /* XXX what about the numeric ops? */
2459 if (PL_hints & HINT_LOCALE)
2464 goto nope; /* Don't try to run w/ errors */
2466 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2467 if ((curop->op_type != OP_CONST ||
2468 (curop->op_private & OPpCONST_BARE)) &&
2469 curop->op_type != OP_LIST &&
2470 curop->op_type != OP_SCALAR &&
2471 curop->op_type != OP_NULL &&
2472 curop->op_type != OP_PUSHMARK)
2478 curop = LINKLIST(o);
2482 sv = *(PL_stack_sp--);
2483 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2484 pad_swipe(o->op_targ);
2485 else if (SvTEMP(sv)) { /* grab mortal temp? */
2486 (void)SvREFCNT_inc(sv);
2490 if (type == OP_RV2GV)
2491 return newGVOP(OP_GV, 0, (GV*)sv);
2493 /* try to smush double to int, but don't smush -2.0 to -2 */
2494 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2497 #ifdef PERL_PRESERVE_IVUV
2498 /* Only bother to attempt to fold to IV if
2499 most operators will benefit */
2503 return newSVOP(OP_CONST, 0, sv);
2511 Perl_gen_constant_list(pTHX_ register OP *o)
2514 I32 oldtmps_floor = PL_tmps_floor;
2518 return o; /* Don't attempt to run with errors */
2520 PL_op = curop = LINKLIST(o);
2527 PL_tmps_floor = oldtmps_floor;
2529 o->op_type = OP_RV2AV;
2530 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2531 o->op_seq = 0; /* needs to be revisited in peep() */
2532 curop = ((UNOP*)o)->op_first;
2533 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2540 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2542 if (!o || o->op_type != OP_LIST)
2543 o = newLISTOP(OP_LIST, 0, o, Nullop);
2545 o->op_flags &= ~OPf_WANT;
2547 if (!(PL_opargs[type] & OA_MARK))
2548 op_null(cLISTOPo->op_first);
2551 o->op_ppaddr = PL_ppaddr[type];
2552 o->op_flags |= flags;
2554 o = CHECKOP(type, o);
2555 if (o->op_type != type)
2558 return fold_constants(o);
2561 /* List constructors */
2564 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2572 if (first->op_type != type
2573 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2575 return newLISTOP(type, 0, first, last);
2578 if (first->op_flags & OPf_KIDS)
2579 ((LISTOP*)first)->op_last->op_sibling = last;
2581 first->op_flags |= OPf_KIDS;
2582 ((LISTOP*)first)->op_first = last;
2584 ((LISTOP*)first)->op_last = last;
2589 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2597 if (first->op_type != type)
2598 return prepend_elem(type, (OP*)first, (OP*)last);
2600 if (last->op_type != type)
2601 return append_elem(type, (OP*)first, (OP*)last);
2603 first->op_last->op_sibling = last->op_first;
2604 first->op_last = last->op_last;
2605 first->op_flags |= (last->op_flags & OPf_KIDS);
2613 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2621 if (last->op_type == type) {
2622 if (type == OP_LIST) { /* already a PUSHMARK there */
2623 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2624 ((LISTOP*)last)->op_first->op_sibling = first;
2625 if (!(first->op_flags & OPf_PARENS))
2626 last->op_flags &= ~OPf_PARENS;
2629 if (!(last->op_flags & OPf_KIDS)) {
2630 ((LISTOP*)last)->op_last = first;
2631 last->op_flags |= OPf_KIDS;
2633 first->op_sibling = ((LISTOP*)last)->op_first;
2634 ((LISTOP*)last)->op_first = first;
2636 last->op_flags |= OPf_KIDS;
2640 return newLISTOP(type, 0, first, last);
2646 Perl_newNULLLIST(pTHX)
2648 return newOP(OP_STUB, 0);
2652 Perl_force_list(pTHX_ OP *o)
2654 if (!o || o->op_type != OP_LIST)
2655 o = newLISTOP(OP_LIST, 0, o, Nullop);
2661 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2665 NewOp(1101, listop, 1, LISTOP);
2667 listop->op_type = type;
2668 listop->op_ppaddr = PL_ppaddr[type];
2671 listop->op_flags = flags;
2675 else if (!first && last)
2678 first->op_sibling = last;
2679 listop->op_first = first;
2680 listop->op_last = last;
2681 if (type == OP_LIST) {
2683 pushop = newOP(OP_PUSHMARK, 0);
2684 pushop->op_sibling = first;
2685 listop->op_first = pushop;
2686 listop->op_flags |= OPf_KIDS;
2688 listop->op_last = pushop;
2695 Perl_newOP(pTHX_ I32 type, I32 flags)
2698 NewOp(1101, o, 1, OP);
2700 o->op_ppaddr = PL_ppaddr[type];
2701 o->op_flags = flags;
2704 o->op_private = 0 + (flags >> 8);
2705 if (PL_opargs[type] & OA_RETSCALAR)
2707 if (PL_opargs[type] & OA_TARGET)
2708 o->op_targ = pad_alloc(type, SVs_PADTMP);
2709 return CHECKOP(type, o);
2713 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2718 first = newOP(OP_STUB, 0);
2719 if (PL_opargs[type] & OA_MARK)
2720 first = force_list(first);
2722 NewOp(1101, unop, 1, UNOP);
2723 unop->op_type = type;
2724 unop->op_ppaddr = PL_ppaddr[type];
2725 unop->op_first = first;
2726 unop->op_flags = flags | OPf_KIDS;
2727 unop->op_private = 1 | (flags >> 8);
2728 unop = (UNOP*) CHECKOP(type, unop);
2732 return fold_constants((OP *) unop);
2736 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2739 NewOp(1101, binop, 1, BINOP);
2742 first = newOP(OP_NULL, 0);
2744 binop->op_type = type;
2745 binop->op_ppaddr = PL_ppaddr[type];
2746 binop->op_first = first;
2747 binop->op_flags = flags | OPf_KIDS;
2750 binop->op_private = 1 | (flags >> 8);
2753 binop->op_private = 2 | (flags >> 8);
2754 first->op_sibling = last;
2757 binop = (BINOP*)CHECKOP(type, binop);
2758 if (binop->op_next || binop->op_type != type)
2761 binop->op_last = binop->op_first->op_sibling;
2763 return fold_constants((OP *)binop);
2767 uvcompare(const void *a, const void *b)
2769 if (*((UV *)a) < (*(UV *)b))
2771 if (*((UV *)a) > (*(UV *)b))
2773 if (*((UV *)a+1) < (*(UV *)b+1))
2775 if (*((UV *)a+1) > (*(UV *)b+1))
2781 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2783 SV *tstr = ((SVOP*)expr)->op_sv;
2784 SV *rstr = ((SVOP*)repl)->op_sv;
2787 U8 *t = (U8*)SvPV(tstr, tlen);
2788 U8 *r = (U8*)SvPV(rstr, rlen);
2795 register short *tbl;
2797 PL_hints |= HINT_BLOCK_SCOPE;
2798 complement = o->op_private & OPpTRANS_COMPLEMENT;
2799 del = o->op_private & OPpTRANS_DELETE;
2800 squash = o->op_private & OPpTRANS_SQUASH;
2803 o->op_private |= OPpTRANS_FROM_UTF;
2806 o->op_private |= OPpTRANS_TO_UTF;
2808 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2809 SV* listsv = newSVpvn("# comment\n",10);
2811 U8* tend = t + tlen;
2812 U8* rend = r + rlen;
2826 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2827 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2833 tsave = t = bytes_to_utf8(t, &len);
2836 if (!to_utf && rlen) {
2838 rsave = r = bytes_to_utf8(r, &len);
2842 /* There are several snags with this code on EBCDIC:
2843 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2844 2. scan_const() in toke.c has encoded chars in native encoding which makes
2845 ranges at least in EBCDIC 0..255 range the bottom odd.
2849 U8 tmpbuf[UTF8_MAXLEN+1];
2852 New(1109, cp, 2*tlen, UV);
2854 transv = newSVpvn("",0);
2856 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2858 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2860 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2864 cp[2*i+1] = cp[2*i];
2868 qsort(cp, i, 2*sizeof(UV), uvcompare);
2869 for (j = 0; j < i; j++) {
2871 diff = val - nextmin;
2873 t = uvuni_to_utf8(tmpbuf,nextmin);
2874 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2876 U8 range_mark = UTF_TO_NATIVE(0xff);
2877 t = uvuni_to_utf8(tmpbuf, val - 1);
2878 sv_catpvn(transv, (char *)&range_mark, 1);
2879 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2886 t = uvuni_to_utf8(tmpbuf,nextmin);
2887 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2889 U8 range_mark = UTF_TO_NATIVE(0xff);
2890 sv_catpvn(transv, (char *)&range_mark, 1);
2892 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2893 UNICODE_ALLOW_SUPER);
2894 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2895 t = (U8*)SvPVX(transv);
2896 tlen = SvCUR(transv);
2900 else if (!rlen && !del) {
2901 r = t; rlen = tlen; rend = tend;
2904 if ((!rlen && !del) || t == r ||
2905 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2907 o->op_private |= OPpTRANS_IDENTICAL;
2911 while (t < tend || tfirst <= tlast) {
2912 /* see if we need more "t" chars */
2913 if (tfirst > tlast) {
2914 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2916 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2918 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2925 /* now see if we need more "r" chars */
2926 if (rfirst > rlast) {
2928 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2930 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2932 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2941 rfirst = rlast = 0xffffffff;
2945 /* now see which range will peter our first, if either. */
2946 tdiff = tlast - tfirst;
2947 rdiff = rlast - rfirst;
2954 if (rfirst == 0xffffffff) {
2955 diff = tdiff; /* oops, pretend rdiff is infinite */
2957 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2958 (long)tfirst, (long)tlast);
2960 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2964 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2965 (long)tfirst, (long)(tfirst + diff),
2968 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2969 (long)tfirst, (long)rfirst);
2971 if (rfirst + diff > max)
2972 max = rfirst + diff;
2974 grows = (tfirst < rfirst &&
2975 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2987 else if (max > 0xff)
2992 Safefree(cPVOPo->op_pv);
2993 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2994 SvREFCNT_dec(listsv);
2996 SvREFCNT_dec(transv);
2998 if (!del && havefinal && rlen)
2999 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3000 newSVuv((UV)final), 0);
3003 o->op_private |= OPpTRANS_GROWS;
3015 tbl = (short*)cPVOPo->op_pv;
3017 Zero(tbl, 256, short);
3018 for (i = 0; i < tlen; i++)
3020 for (i = 0, j = 0; i < 256; i++) {
3031 if (i < 128 && r[j] >= 128)
3041 o->op_private |= OPpTRANS_IDENTICAL;
3046 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3047 tbl[0x100] = rlen - j;
3048 for (i=0; i < rlen - j; i++)
3049 tbl[0x101+i] = r[j+i];
3053 if (!rlen && !del) {
3056 o->op_private |= OPpTRANS_IDENTICAL;
3058 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3059 o->op_private |= OPpTRANS_IDENTICAL;
3061 for (i = 0; i < 256; i++)
3063 for (i = 0, j = 0; i < tlen; i++,j++) {
3066 if (tbl[t[i]] == -1)
3072 if (tbl[t[i]] == -1) {
3073 if (t[i] < 128 && r[j] >= 128)
3080 o->op_private |= OPpTRANS_GROWS;
3088 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3092 NewOp(1101, pmop, 1, PMOP);
3093 pmop->op_type = type;
3094 pmop->op_ppaddr = PL_ppaddr[type];
3095 pmop->op_flags = flags;
3096 pmop->op_private = 0 | (flags >> 8);
3098 if (PL_hints & HINT_RE_TAINT)
3099 pmop->op_pmpermflags |= PMf_RETAINT;
3100 if (PL_hints & HINT_LOCALE)
3101 pmop->op_pmpermflags |= PMf_LOCALE;
3102 pmop->op_pmflags = pmop->op_pmpermflags;
3107 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3108 repointer = av_pop((AV*)PL_regex_pad[0]);
3109 pmop->op_pmoffset = SvIV(repointer);
3110 SvREPADTMP_off(repointer);
3111 sv_setiv(repointer,0);
3113 repointer = newSViv(0);
3114 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3115 pmop->op_pmoffset = av_len(PL_regex_padav);
3116 PL_regex_pad = AvARRAY(PL_regex_padav);
3121 /* link into pm list */
3122 if (type != OP_TRANS && PL_curstash) {
3123 pmop->op_pmnext = HvPMROOT(PL_curstash);
3124 HvPMROOT(PL_curstash) = pmop;
3125 PmopSTASH_set(pmop,PL_curstash);
3132 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3136 I32 repl_has_vars = 0;
3138 if (o->op_type == OP_TRANS)
3139 return pmtrans(o, expr, repl);
3141 PL_hints |= HINT_BLOCK_SCOPE;
3144 if (expr->op_type == OP_CONST) {
3146 SV *pat = ((SVOP*)expr)->op_sv;
3147 char *p = SvPV(pat, plen);
3148 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3149 sv_setpvn(pat, "\\s+", 3);
3150 p = SvPV(pat, plen);
3151 pm->op_pmflags |= PMf_SKIPWHITE;
3154 pm->op_pmdynflags |= PMdf_UTF8;
3155 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3156 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3157 pm->op_pmflags |= PMf_WHITE;
3161 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3162 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3164 : OP_REGCMAYBE),0,expr);
3166 NewOp(1101, rcop, 1, LOGOP);
3167 rcop->op_type = OP_REGCOMP;
3168 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3169 rcop->op_first = scalar(expr);
3170 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3171 ? (OPf_SPECIAL | OPf_KIDS)
3173 rcop->op_private = 1;
3176 /* establish postfix order */
3177 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3179 rcop->op_next = expr;
3180 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3183 rcop->op_next = LINKLIST(expr);
3184 expr->op_next = (OP*)rcop;
3187 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3192 if (pm->op_pmflags & PMf_EVAL) {
3194 if (CopLINE(PL_curcop) < PL_multi_end)
3195 CopLINE_set(PL_curcop, PL_multi_end);
3197 #ifdef USE_5005THREADS
3198 else if (repl->op_type == OP_THREADSV
3199 && strchr("&`'123456789+",
3200 PL_threadsv_names[repl->op_targ]))
3204 #endif /* USE_5005THREADS */
3205 else if (repl->op_type == OP_CONST)
3209 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3210 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3211 #ifdef USE_5005THREADS
3212 if (curop->op_type == OP_THREADSV) {
3214 if (strchr("&`'123456789+", curop->op_private))
3218 if (curop->op_type == OP_GV) {
3219 GV *gv = cGVOPx_gv(curop);
3221 if (strchr("&`'123456789+", *GvENAME(gv)))
3224 #endif /* USE_5005THREADS */
3225 else if (curop->op_type == OP_RV2CV)
3227 else if (curop->op_type == OP_RV2SV ||
3228 curop->op_type == OP_RV2AV ||
3229 curop->op_type == OP_RV2HV ||
3230 curop->op_type == OP_RV2GV) {
3231 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3234 else if (curop->op_type == OP_PADSV ||
3235 curop->op_type == OP_PADAV ||
3236 curop->op_type == OP_PADHV ||
3237 curop->op_type == OP_PADANY) {
3240 else if (curop->op_type == OP_PUSHRE)
3241 ; /* Okay here, dangerous in newASSIGNOP */
3251 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3252 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3253 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3254 prepend_elem(o->op_type, scalar(repl), o);
3257 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3258 pm->op_pmflags |= PMf_MAYBE_CONST;
3259 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3261 NewOp(1101, rcop, 1, LOGOP);
3262 rcop->op_type = OP_SUBSTCONT;
3263 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3264 rcop->op_first = scalar(repl);
3265 rcop->op_flags |= OPf_KIDS;
3266 rcop->op_private = 1;
3269 /* establish postfix order */
3270 rcop->op_next = LINKLIST(repl);
3271 repl->op_next = (OP*)rcop;
3273 pm->op_pmreplroot = scalar((OP*)rcop);
3274 pm->op_pmreplstart = LINKLIST(rcop);
3283 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3286 NewOp(1101, svop, 1, SVOP);
3287 svop->op_type = type;
3288 svop->op_ppaddr = PL_ppaddr[type];
3290 svop->op_next = (OP*)svop;
3291 svop->op_flags = flags;
3292 if (PL_opargs[type] & OA_RETSCALAR)
3294 if (PL_opargs[type] & OA_TARGET)
3295 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3296 return CHECKOP(type, svop);
3300 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3303 NewOp(1101, padop, 1, PADOP);
3304 padop->op_type = type;
3305 padop->op_ppaddr = PL_ppaddr[type];
3306 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3307 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3308 PL_curpad[padop->op_padix] = sv;
3310 padop->op_next = (OP*)padop;
3311 padop->op_flags = flags;
3312 if (PL_opargs[type] & OA_RETSCALAR)
3314 if (PL_opargs[type] & OA_TARGET)
3315 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3316 return CHECKOP(type, padop);
3320 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3324 return newPADOP(type, flags, SvREFCNT_inc(gv));
3326 return newSVOP(type, flags, SvREFCNT_inc(gv));
3331 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3334 NewOp(1101, pvop, 1, PVOP);
3335 pvop->op_type = type;
3336 pvop->op_ppaddr = PL_ppaddr[type];
3338 pvop->op_next = (OP*)pvop;
3339 pvop->op_flags = flags;
3340 if (PL_opargs[type] & OA_RETSCALAR)
3342 if (PL_opargs[type] & OA_TARGET)
3343 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3344 return CHECKOP(type, pvop);
3348 Perl_package(pTHX_ OP *o)
3352 save_hptr(&PL_curstash);
3353 save_item(PL_curstname);
3358 name = SvPV(sv, len);
3359 PL_curstash = gv_stashpvn(name,len,TRUE);
3360 sv_setpvn(PL_curstname, name, len);
3364 deprecate("\"package\" with no arguments");
3365 sv_setpv(PL_curstname,"<none>");
3366 PL_curstash = Nullhv;
3368 PL_hints |= HINT_BLOCK_SCOPE;
3369 PL_copline = NOLINE;
3374 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3379 char *packname = Nullch;
3383 if (id->op_type != OP_CONST)
3384 Perl_croak(aTHX_ "Module name must be constant");
3388 if (version != Nullop) {
3389 SV *vesv = ((SVOP*)version)->op_sv;
3391 if (arg == Nullop && !SvNIOKp(vesv)) {
3398 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3399 Perl_croak(aTHX_ "Version number must be constant number");
3401 /* Make copy of id so we don't free it twice */
3402 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3404 /* Fake up a method call to VERSION */
3405 meth = newSVpvn("VERSION",7);
3406 sv_upgrade(meth, SVt_PVIV);
3407 (void)SvIOK_on(meth);
3408 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3409 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3410 append_elem(OP_LIST,
3411 prepend_elem(OP_LIST, pack, list(version)),
3412 newSVOP(OP_METHOD_NAMED, 0, meth)));
3416 /* Fake up an import/unimport */
3417 if (arg && arg->op_type == OP_STUB)
3418 imop = arg; /* no import on explicit () */
3419 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3420 imop = Nullop; /* use 5.0; */
3425 /* Make copy of id so we don't free it twice */
3426 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3428 /* Fake up a method call to import/unimport */
3429 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3430 (void)SvUPGRADE(meth, SVt_PVIV);
3431 (void)SvIOK_on(meth);
3432 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3433 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3434 append_elem(OP_LIST,
3435 prepend_elem(OP_LIST, pack, list(arg)),
3436 newSVOP(OP_METHOD_NAMED, 0, meth)));
3439 if (ckWARN(WARN_MISC) &&
3440 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3441 SvPOK(packsv = ((SVOP*)id)->op_sv))
3443 /* BEGIN will free the ops, so we need to make a copy */
3444 packlen = SvCUR(packsv);
3445 packname = savepvn(SvPVX(packsv), packlen);
3448 /* Fake up the BEGIN {}, which does its thing immediately. */
3450 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3453 append_elem(OP_LINESEQ,
3454 append_elem(OP_LINESEQ,
3455 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3456 newSTATEOP(0, Nullch, veop)),
3457 newSTATEOP(0, Nullch, imop) ));
3460 /* The "did you use incorrect case?" warning used to be here.
3461 * The problem is that on case-insensitive filesystems one
3462 * might get false positives for "use" (and "require"):
3463 * "use Strict" or "require CARP" will work. This causes
3464 * portability problems for the script: in case-strict
3465 * filesystems the script will stop working.
3467 * The "incorrect case" warning checked whether "use Foo"
3468 * imported "Foo" to your namespace, but that is wrong, too:
3469 * there is no requirement nor promise in the language that
3470 * a Foo.pm should or would contain anything in package "Foo".
3472 * There is very little Configure-wise that can be done, either:
3473 * the case-sensitivity of the build filesystem of Perl does not
3474 * help in guessing the case-sensitivity of the runtime environment.
3479 PL_hints |= HINT_BLOCK_SCOPE;
3480 PL_copline = NOLINE;
3485 =head1 Embedding Functions
3487 =for apidoc load_module
3489 Loads the module whose name is pointed to by the string part of name.
3490 Note that the actual module name, not its filename, should be given.
3491 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3492 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3493 (or 0 for no flags). ver, if specified, provides version semantics
3494 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3495 arguments can be used to specify arguments to the module's import()
3496 method, similar to C<use Foo::Bar VERSION LIST>.
3501 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3504 va_start(args, ver);
3505 vload_module(flags, name, ver, &args);
3509 #ifdef PERL_IMPLICIT_CONTEXT
3511 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3515 va_start(args, ver);
3516 vload_module(flags, name, ver, &args);
3522 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3524 OP *modname, *veop, *imop;
3526 modname = newSVOP(OP_CONST, 0, name);
3527 modname->op_private |= OPpCONST_BARE;
3529 veop = newSVOP(OP_CONST, 0, ver);
3533 if (flags & PERL_LOADMOD_NOIMPORT) {
3534 imop = sawparens(newNULLLIST());
3536 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3537 imop = va_arg(*args, OP*);
3542 sv = va_arg(*args, SV*);
3544 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3545 sv = va_arg(*args, SV*);
3549 line_t ocopline = PL_copline;
3550 int oexpect = PL_expect;
3552 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3553 veop, modname, imop);
3554 PL_expect = oexpect;
3555 PL_copline = ocopline;
3560 Perl_dofile(pTHX_ OP *term)
3565 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3566 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3567 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3569 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3570 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3571 append_elem(OP_LIST, term,
3572 scalar(newUNOP(OP_RV2CV, 0,
3577 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3583 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3585 return newBINOP(OP_LSLICE, flags,
3586 list(force_list(subscript)),
3587 list(force_list(listval)) );
3591 S_list_assignment(pTHX_ register OP *o)
3596 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3597 o = cUNOPo->op_first;
3599 if (o->op_type == OP_COND_EXPR) {
3600 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3601 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3606 yyerror("Assignment to both a list and a scalar");
3610 if (o->op_type == OP_LIST &&
3611 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3612 o->op_private & OPpLVAL_INTRO)
3615 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3616 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3617 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3620 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3623 if (o->op_type == OP_RV2SV)
3630 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3635 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3636 return newLOGOP(optype, 0,
3637 mod(scalar(left), optype),
3638 newUNOP(OP_SASSIGN, 0, scalar(right)));
3641 return newBINOP(optype, OPf_STACKED,
3642 mod(scalar(left), optype), scalar(right));
3646 if (list_assignment(left)) {
3650 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3651 left = mod(left, OP_AASSIGN);
3659 curop = list(force_list(left));
3660 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3661 o->op_private = 0 | (flags >> 8);
3662 for (curop = ((LISTOP*)curop)->op_first;
3663 curop; curop = curop->op_sibling)
3665 if (curop->op_type == OP_RV2HV &&
3666 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3667 o->op_private |= OPpASSIGN_HASH;
3671 if (!(left->op_private & OPpLVAL_INTRO)) {
3674 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3675 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3676 if (curop->op_type == OP_GV) {
3677 GV *gv = cGVOPx_gv(curop);
3678 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3680 SvCUR(gv) = PL_generation;
3682 else if (curop->op_type == OP_PADSV ||
3683 curop->op_type == OP_PADAV ||
3684 curop->op_type == OP_PADHV ||
3685 curop->op_type == OP_PADANY) {
3686 SV **svp = AvARRAY(PL_comppad_name);
3687 SV *sv = svp[curop->op_targ];
3688 if (SvCUR(sv) == PL_generation)
3690 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3692 else if (curop->op_type == OP_RV2CV)
3694 else if (curop->op_type == OP_RV2SV ||
3695 curop->op_type == OP_RV2AV ||
3696 curop->op_type == OP_RV2HV ||
3697 curop->op_type == OP_RV2GV) {
3698 if (lastop->op_type != OP_GV) /* funny deref? */
3701 else if (curop->op_type == OP_PUSHRE) {
3702 if (((PMOP*)curop)->op_pmreplroot) {
3704 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3706 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3708 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3710 SvCUR(gv) = PL_generation;
3719 o->op_private |= OPpASSIGN_COMMON;
3721 if (right && right->op_type == OP_SPLIT) {
3723 if ((tmpop = ((LISTOP*)right)->op_first) &&
3724 tmpop->op_type == OP_PUSHRE)
3726 PMOP *pm = (PMOP*)tmpop;
3727 if (left->op_type == OP_RV2AV &&
3728 !(left->op_private & OPpLVAL_INTRO) &&
3729 !(o->op_private & OPpASSIGN_COMMON) )
3731 tmpop = ((UNOP*)left)->op_first;
3732 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3734 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3735 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3737 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3738 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3740 pm->op_pmflags |= PMf_ONCE;
3741 tmpop = cUNOPo->op_first; /* to list (nulled) */
3742 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3743 tmpop->op_sibling = Nullop; /* don't free split */
3744 right->op_next = tmpop->op_next; /* fix starting loc */
3745 op_free(o); /* blow off assign */
3746 right->op_flags &= ~OPf_WANT;
3747 /* "I don't know and I don't care." */
3752 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3753 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3755 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3757 sv_setiv(sv, PL_modcount+1);
3765 right = newOP(OP_UNDEF, 0);
3766 if (right->op_type == OP_READLINE) {
3767 right->op_flags |= OPf_STACKED;
3768 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3771 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3772 o = newBINOP(OP_SASSIGN, flags,
3773 scalar(right), mod(scalar(left), OP_SASSIGN) );
3785 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3787 U32 seq = intro_my();
3790 NewOp(1101, cop, 1, COP);
3791 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3792 cop->op_type = OP_DBSTATE;
3793 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3796 cop->op_type = OP_NEXTSTATE;
3797 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3799 cop->op_flags = flags;
3800 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3802 cop->op_private |= NATIVE_HINTS;
3804 PL_compiling.op_private = cop->op_private;
3805 cop->op_next = (OP*)cop;
3808 cop->cop_label = label;
3809 PL_hints |= HINT_BLOCK_SCOPE;
3812 cop->cop_arybase = PL_curcop->cop_arybase;
3813 if (specialWARN(PL_curcop->cop_warnings))
3814 cop->cop_warnings = PL_curcop->cop_warnings ;
3816 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3817 if (specialCopIO(PL_curcop->cop_io))
3818 cop->cop_io = PL_curcop->cop_io;
3820 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3823 if (PL_copline == NOLINE)
3824 CopLINE_set(cop, CopLINE(PL_curcop));
3826 CopLINE_set(cop, PL_copline);
3827 PL_copline = NOLINE;
3830 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3832 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3834 CopSTASH_set(cop, PL_curstash);
3836 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3837 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3838 if (svp && *svp != &PL_sv_undef ) {
3839 (void)SvIOK_on(*svp);
3840 SvIVX(*svp) = PTR2IV(cop);
3844 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3847 /* "Introduce" my variables to visible status. */
3855 if (! PL_min_intro_pending)
3856 return PL_cop_seqmax;
3858 svp = AvARRAY(PL_comppad_name);
3859 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3860 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3861 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3862 SvNVX(sv) = (NV)PL_cop_seqmax;
3865 PL_min_intro_pending = 0;
3866 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3867 return PL_cop_seqmax++;
3871 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3873 return new_logop(type, flags, &first, &other);
3877 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3881 OP *first = *firstp;
3882 OP *other = *otherp;
3884 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3885 return newBINOP(type, flags, scalar(first), scalar(other));
3887 scalarboolean(first);
3888 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3889 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3890 if (type == OP_AND || type == OP_OR) {
3896 first = *firstp = cUNOPo->op_first;
3898 first->op_next = o->op_next;
3899 cUNOPo->op_first = Nullop;
3903 if (first->op_type == OP_CONST) {
3904 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3905 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3906 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3917 else if (first->op_type == OP_WANTARRAY) {
3923 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3924 OP *k1 = ((UNOP*)first)->op_first;
3925 OP *k2 = k1->op_sibling;
3927 switch (first->op_type)
3930 if (k2 && k2->op_type == OP_READLINE
3931 && (k2->op_flags & OPf_STACKED)
3932 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3934 warnop = k2->op_type;
3939 if (k1->op_type == OP_READDIR
3940 || k1->op_type == OP_GLOB
3941 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3942 || k1->op_type == OP_EACH)
3944 warnop = ((k1->op_type == OP_NULL)
3945 ? k1->op_targ : k1->op_type);
3950 line_t oldline = CopLINE(PL_curcop);
3951 CopLINE_set(PL_curcop, PL_copline);
3952 Perl_warner(aTHX_ packWARN(WARN_MISC),
3953 "Value of %s%s can be \"0\"; test with defined()",
3955 ((warnop == OP_READLINE || warnop == OP_GLOB)
3956 ? " construct" : "() operator"));
3957 CopLINE_set(PL_curcop, oldline);
3964 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3965 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3967 NewOp(1101, logop, 1, LOGOP);
3969 logop->op_type = type;
3970 logop->op_ppaddr = PL_ppaddr[type];
3971 logop->op_first = first;
3972 logop->op_flags = flags | OPf_KIDS;
3973 logop->op_other = LINKLIST(other);
3974 logop->op_private = 1 | (flags >> 8);
3976 /* establish postfix order */
3977 logop->op_next = LINKLIST(first);
3978 first->op_next = (OP*)logop;
3979 first->op_sibling = other;
3981 o = newUNOP(OP_NULL, 0, (OP*)logop);
3988 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3995 return newLOGOP(OP_AND, 0, first, trueop);
3997 return newLOGOP(OP_OR, 0, first, falseop);
3999 scalarboolean(first);
4000 if (first->op_type == OP_CONST) {
4001 if (SvTRUE(((SVOP*)first)->op_sv)) {
4012 else if (first->op_type == OP_WANTARRAY) {
4016 NewOp(1101, logop, 1, LOGOP);
4017 logop->op_type = OP_COND_EXPR;
4018 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4019 logop->op_first = first;
4020 logop->op_flags = flags | OPf_KIDS;
4021 logop->op_private = 1 | (flags >> 8);
4022 logop->op_other = LINKLIST(trueop);
4023 logop->op_next = LINKLIST(falseop);
4026 /* establish postfix order */
4027 start = LINKLIST(first);
4028 first->op_next = (OP*)logop;
4030 first->op_sibling = trueop;
4031 trueop->op_sibling = falseop;
4032 o = newUNOP(OP_NULL, 0, (OP*)logop);
4034 trueop->op_next = falseop->op_next = o;
4041 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4049 NewOp(1101, range, 1, LOGOP);
4051 range->op_type = OP_RANGE;
4052 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4053 range->op_first = left;
4054 range->op_flags = OPf_KIDS;
4055 leftstart = LINKLIST(left);
4056 range->op_other = LINKLIST(right);
4057 range->op_private = 1 | (flags >> 8);
4059 left->op_sibling = right;
4061 range->op_next = (OP*)range;
4062 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4063 flop = newUNOP(OP_FLOP, 0, flip);
4064 o = newUNOP(OP_NULL, 0, flop);
4066 range->op_next = leftstart;
4068 left->op_next = flip;
4069 right->op_next = flop;
4071 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4072 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4073 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4074 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4076 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4077 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4080 if (!flip->op_private || !flop->op_private)
4081 linklist(o); /* blow off optimizer unless constant */
4087 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4091 int once = block && block->op_flags & OPf_SPECIAL &&
4092 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4095 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4096 return block; /* do {} while 0 does once */
4097 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4098 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4099 expr = newUNOP(OP_DEFINED, 0,
4100 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4101 } else if (expr->op_flags & OPf_KIDS) {
4102 OP *k1 = ((UNOP*)expr)->op_first;
4103 OP *k2 = (k1) ? k1->op_sibling : NULL;
4104 switch (expr->op_type) {
4106 if (k2 && k2->op_type == OP_READLINE
4107 && (k2->op_flags & OPf_STACKED)
4108 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4109 expr = newUNOP(OP_DEFINED, 0, expr);
4113 if (k1->op_type == OP_READDIR
4114 || k1->op_type == OP_GLOB
4115 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4116 || k1->op_type == OP_EACH)
4117 expr = newUNOP(OP_DEFINED, 0, expr);
4123 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4124 o = new_logop(OP_AND, 0, &expr, &listop);
4127 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4129 if (once && o != listop)
4130 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4133 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4135 o->op_flags |= flags;
4137 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4142 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4150 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4151 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4152 expr = newUNOP(OP_DEFINED, 0,
4153 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4154 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4155 OP *k1 = ((UNOP*)expr)->op_first;
4156 OP *k2 = (k1) ? k1->op_sibling : NULL;
4157 switch (expr->op_type) {
4159 if (k2 && k2->op_type == OP_READLINE
4160 && (k2->op_flags & OPf_STACKED)
4161 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4162 expr = newUNOP(OP_DEFINED, 0, expr);
4166 if (k1->op_type == OP_READDIR
4167 || k1->op_type == OP_GLOB
4168 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4169 || k1->op_type == OP_EACH)
4170 expr = newUNOP(OP_DEFINED, 0, expr);
4176 block = newOP(OP_NULL, 0);
4178 block = scope(block);
4182 next = LINKLIST(cont);
4185 OP *unstack = newOP(OP_UNSTACK, 0);
4188 cont = append_elem(OP_LINESEQ, cont, unstack);
4189 if ((line_t)whileline != NOLINE) {
4190 PL_copline = whileline;
4191 cont = append_elem(OP_LINESEQ, cont,
4192 newSTATEOP(0, Nullch, Nullop));
4196 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4197 redo = LINKLIST(listop);
4200 PL_copline = whileline;
4202 o = new_logop(OP_AND, 0, &expr, &listop);
4203 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4204 op_free(expr); /* oops, it's a while (0) */
4206 return Nullop; /* listop already freed by new_logop */
4209 ((LISTOP*)listop)->op_last->op_next =
4210 (o == listop ? redo : LINKLIST(o));
4216 NewOp(1101,loop,1,LOOP);
4217 loop->op_type = OP_ENTERLOOP;
4218 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4219 loop->op_private = 0;
4220 loop->op_next = (OP*)loop;
4223 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4225 loop->op_redoop = redo;
4226 loop->op_lastop = o;
4227 o->op_private |= loopflags;
4230 loop->op_nextop = next;
4232 loop->op_nextop = o;
4234 o->op_flags |= flags;
4235 o->op_private |= (flags >> 8);
4240 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4248 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4249 sv->op_type = OP_RV2GV;
4250 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4252 else if (sv->op_type == OP_PADSV) { /* private variable */
4253 padoff = sv->op_targ;
4258 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4259 padoff = sv->op_targ;
4261 iterflags |= OPf_SPECIAL;
4266 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4269 #ifdef USE_5005THREADS
4270 padoff = find_threadsv("_");
4271 iterflags |= OPf_SPECIAL;
4273 sv = newGVOP(OP_GV, 0, PL_defgv);
4276 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4277 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4278 iterflags |= OPf_STACKED;
4280 else if (expr->op_type == OP_NULL &&
4281 (expr->op_flags & OPf_KIDS) &&
4282 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4284 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4285 * set the STACKED flag to indicate that these values are to be
4286 * treated as min/max values by 'pp_iterinit'.
4288 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4289 LOGOP* range = (LOGOP*) flip->op_first;
4290 OP* left = range->op_first;
4291 OP* right = left->op_sibling;
4294 range->op_flags &= ~OPf_KIDS;
4295 range->op_first = Nullop;
4297 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4298 listop->op_first->op_next = range->op_next;
4299 left->op_next = range->op_other;
4300 right->op_next = (OP*)listop;
4301 listop->op_next = listop->op_first;
4304 expr = (OP*)(listop);
4306 iterflags |= OPf_STACKED;
4309 expr = mod(force_list(expr), OP_GREPSTART);
4313 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4314 append_elem(OP_LIST, expr, scalar(sv))));
4315 assert(!loop->op_next);
4316 #ifdef PL_OP_SLAB_ALLOC
4319 NewOp(1234,tmp,1,LOOP);
4320 Copy(loop,tmp,1,LOOP);
4325 Renew(loop, 1, LOOP);
4327 loop->op_targ = padoff;
4328 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4329 PL_copline = forline;
4330 return newSTATEOP(0, label, wop);
4334 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4339 if (type != OP_GOTO || label->op_type == OP_CONST) {
4340 /* "last()" means "last" */
4341 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4342 o = newOP(type, OPf_SPECIAL);
4344 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4345 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4351 if (label->op_type == OP_ENTERSUB)
4352 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4353 o = newUNOP(type, OPf_STACKED, label);
4355 PL_hints |= HINT_BLOCK_SCOPE;
4360 Perl_cv_undef(pTHX_ CV *cv)
4362 #ifdef USE_5005THREADS
4364 MUTEX_DESTROY(CvMUTEXP(cv));
4365 Safefree(CvMUTEXP(cv));
4368 #endif /* USE_5005THREADS */
4371 if (CvFILE(cv) && !CvXSUB(cv)) {
4372 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4373 Safefree(CvFILE(cv));
4378 if (!CvXSUB(cv) && CvROOT(cv)) {
4379 #ifdef USE_5005THREADS
4380 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4381 Perl_croak(aTHX_ "Can't undef active subroutine");
4384 Perl_croak(aTHX_ "Can't undef active subroutine");
4385 #endif /* USE_5005THREADS */
4388 SAVEVPTR(PL_curpad);
4391 op_free(CvROOT(cv));
4392 CvROOT(cv) = Nullop;
4395 SvPOK_off((SV*)cv); /* forget prototype */
4397 /* Since closure prototypes have the same lifetime as the containing
4398 * CV, they don't hold a refcount on the outside CV. This avoids
4399 * the refcount loop between the outer CV (which keeps a refcount to
4400 * the closure prototype in the pad entry for pp_anoncode()) and the
4401 * closure prototype, and the ensuing memory leak. --GSAR */
4402 if (!CvANON(cv) || CvCLONED(cv))
4403 SvREFCNT_dec(CvOUTSIDE(cv));
4404 CvOUTSIDE(cv) = Nullcv;
4406 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4409 if (CvPADLIST(cv)) {
4410 /* may be during global destruction */
4411 if (SvREFCNT(CvPADLIST(cv))) {
4412 I32 i = AvFILLp(CvPADLIST(cv));
4414 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4415 SV* sv = svp ? *svp : Nullsv;
4418 if (sv == (SV*)PL_comppad_name)
4419 PL_comppad_name = Nullav;
4420 else if (sv == (SV*)PL_comppad) {
4421 PL_comppad = Nullav;
4422 PL_curpad = Null(SV**);
4426 SvREFCNT_dec((SV*)CvPADLIST(cv));
4428 CvPADLIST(cv) = Nullav;
4436 #ifdef DEBUG_CLOSURES
4438 S_cv_dump(pTHX_ CV *cv)
4441 CV *outside = CvOUTSIDE(cv);
4442 AV* padlist = CvPADLIST(cv);
4449 PerlIO_printf(Perl_debug_log,
4450 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4452 (CvANON(cv) ? "ANON"
4453 : (cv == PL_main_cv) ? "MAIN"
4454 : CvUNIQUE(cv) ? "UNIQUE"
4455 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4458 : CvANON(outside) ? "ANON"
4459 : (outside == PL_main_cv) ? "MAIN"
4460 : CvUNIQUE(outside) ? "UNIQUE"
4461 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4466 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4467 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4468 pname = AvARRAY(pad_name);
4469 ppad = AvARRAY(pad);
4471 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4472 if (SvPOK(pname[ix]))
4473 PerlIO_printf(Perl_debug_log,
4474 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4475 (int)ix, PTR2UV(ppad[ix]),
4476 SvFAKE(pname[ix]) ? "FAKE " : "",
4478 (IV)I_32(SvNVX(pname[ix])),
4481 #endif /* DEBUGGING */
4483 #endif /* DEBUG_CLOSURES */
4486 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4490 AV* protopadlist = CvPADLIST(proto);
4491 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4492 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4493 SV** pname = AvARRAY(protopad_name);
4494 SV** ppad = AvARRAY(protopad);
4495 I32 fname = AvFILLp(protopad_name);
4496 I32 fpad = AvFILLp(protopad);
4500 assert(!CvUNIQUE(proto));
4504 SAVESPTR(PL_comppad_name);
4505 SAVESPTR(PL_compcv);
4507 cv = PL_compcv = (CV*)NEWSV(1104,0);
4508 sv_upgrade((SV *)cv, SvTYPE(proto));
4509 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4512 #ifdef USE_5005THREADS
4513 New(666, CvMUTEXP(cv), 1, perl_mutex);
4514 MUTEX_INIT(CvMUTEXP(cv));
4516 #endif /* USE_5005THREADS */
4518 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4519 : savepv(CvFILE(proto));
4521 CvFILE(cv) = CvFILE(proto);
4523 CvGV(cv) = CvGV(proto);
4524 CvSTASH(cv) = CvSTASH(proto);
4525 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4526 CvSTART(cv) = CvSTART(proto);
4528 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4531 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4533 PL_comppad_name = newAV();
4534 for (ix = fname; ix >= 0; ix--)
4535 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4537 PL_comppad = newAV();
4539 comppadlist = newAV();
4540 AvREAL_off(comppadlist);
4541 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4542 av_store(comppadlist, 1, (SV*)PL_comppad);
4543 CvPADLIST(cv) = comppadlist;
4544 av_fill(PL_comppad, AvFILLp(protopad));
4545 PL_curpad = AvARRAY(PL_comppad);
4547 av = newAV(); /* will be @_ */
4549 av_store(PL_comppad, 0, (SV*)av);
4550 AvFLAGS(av) = AVf_REIFY;
4552 for (ix = fpad; ix > 0; ix--) {
4553 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4554 if (namesv && namesv != &PL_sv_undef) {
4555 char *name = SvPVX(namesv); /* XXX */
4556 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4557 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4558 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4560 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4562 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4564 else { /* our own lexical */
4567 /* anon code -- we'll come back for it */
4568 sv = SvREFCNT_inc(ppad[ix]);
4570 else if (*name == '@')
4572 else if (*name == '%')
4581 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4582 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4585 SV* sv = NEWSV(0,0);
4591 /* Now that vars are all in place, clone nested closures. */
4593 for (ix = fpad; ix > 0; ix--) {
4594 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4596 && namesv != &PL_sv_undef
4597 && !(SvFLAGS(namesv) & SVf_FAKE)
4598 && *SvPVX(namesv) == '&'
4599 && CvCLONE(ppad[ix]))
4601 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4602 SvREFCNT_dec(ppad[ix]);
4605 PL_curpad[ix] = (SV*)kid;
4609 #ifdef DEBUG_CLOSURES
4610 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4612 PerlIO_printf(Perl_debug_log, " from:\n");
4614 PerlIO_printf(Perl_debug_log, " to:\n");
4621 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4623 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4625 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4632 Perl_cv_clone(pTHX_ CV *proto)
4635 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4636 cv = cv_clone2(proto, CvOUTSIDE(proto));
4637 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4642 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4644 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4645 SV* msg = sv_newmortal();
4649 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4650 sv_setpv(msg, "Prototype mismatch:");
4652 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4654 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4655 sv_catpv(msg, " vs ");
4657 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4659 sv_catpv(msg, "none");
4660 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4664 static void const_sv_xsub(pTHX_ CV* cv);
4668 =head1 Optree Manipulation Functions
4670 =for apidoc cv_const_sv
4672 If C<cv> is a constant sub eligible for inlining. returns the constant
4673 value returned by the sub. Otherwise, returns NULL.
4675 Constant subs can be created with C<newCONSTSUB> or as described in
4676 L<perlsub/"Constant Functions">.
4681 Perl_cv_const_sv(pTHX_ CV *cv)
4683 if (!cv || !CvCONST(cv))
4685 return (SV*)CvXSUBANY(cv).any_ptr;
4689 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4696 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4697 o = cLISTOPo->op_first->op_sibling;
4699 for (; o; o = o->op_next) {
4700 OPCODE type = o->op_type;
4702 if (sv && o->op_next == o)
4704 if (o->op_next != o) {
4705 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4707 if (type == OP_DBSTATE)
4710 if (type == OP_LEAVESUB || type == OP_RETURN)
4714 if (type == OP_CONST && cSVOPo->op_sv)
4716 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4717 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4718 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4722 /* We get here only from cv_clone2() while creating a closure.
4723 Copy the const value here instead of in cv_clone2 so that
4724 SvREADONLY_on doesn't lead to problems when leaving
4729 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4741 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4751 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4755 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4757 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4761 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4767 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4772 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4773 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4774 SV *sv = sv_newmortal();
4775 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4776 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4777 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4782 gv = gv_fetchpv(name ? name : (aname ? aname :
4783 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4784 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4794 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4795 maximum a prototype before. */
4796 if (SvTYPE(gv) > SVt_NULL) {
4797 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4798 && ckWARN_d(WARN_PROTOTYPE))
4800 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4802 cv_ckproto((CV*)gv, NULL, ps);
4805 sv_setpv((SV*)gv, ps);
4807 sv_setiv((SV*)gv, -1);
4808 SvREFCNT_dec(PL_compcv);
4809 cv = PL_compcv = NULL;
4810 PL_sub_generation++;
4814 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4816 #ifdef GV_UNIQUE_CHECK
4817 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4818 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4822 if (!block || !ps || *ps || attrs)
4825 const_sv = op_const_sv(block, Nullcv);
4828 bool exists = CvROOT(cv) || CvXSUB(cv);
4830 #ifdef GV_UNIQUE_CHECK
4831 if (exists && GvUNIQUE(gv)) {
4832 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4836 /* if the subroutine doesn't exist and wasn't pre-declared
4837 * with a prototype, assume it will be AUTOLOADed,
4838 * skipping the prototype check
4840 if (exists || SvPOK(cv))
4841 cv_ckproto(cv, gv, ps);
4842 /* already defined (or promised)? */
4843 if (exists || GvASSUMECV(gv)) {
4844 if (!block && !attrs) {
4845 /* just a "sub foo;" when &foo is already defined */
4846 SAVEFREESV(PL_compcv);
4849 /* ahem, death to those who redefine active sort subs */
4850 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4851 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4853 if (ckWARN(WARN_REDEFINE)
4855 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4857 line_t oldline = CopLINE(PL_curcop);
4858 if (PL_copline != NOLINE)
4859 CopLINE_set(PL_curcop, PL_copline);
4860 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4861 CvCONST(cv) ? "Constant subroutine %s redefined"
4862 : "Subroutine %s redefined", name);
4863 CopLINE_set(PL_curcop, oldline);
4871 SvREFCNT_inc(const_sv);
4873 assert(!CvROOT(cv) && !CvCONST(cv));
4874 sv_setpv((SV*)cv, ""); /* prototype is "" */
4875 CvXSUBANY(cv).any_ptr = const_sv;
4876 CvXSUB(cv) = const_sv_xsub;
4881 cv = newCONSTSUB(NULL, name, const_sv);
4884 SvREFCNT_dec(PL_compcv);
4886 PL_sub_generation++;
4893 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4894 * before we clobber PL_compcv.
4898 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4899 stash = GvSTASH(CvGV(cv));
4900 else if (CvSTASH(cv))
4901 stash = CvSTASH(cv);
4903 stash = PL_curstash;
4906 /* possibly about to re-define existing subr -- ignore old cv */
4907 rcv = (SV*)PL_compcv;
4908 if (name && GvSTASH(gv))
4909 stash = GvSTASH(gv);
4911 stash = PL_curstash;
4913 apply_attrs(stash, rcv, attrs, FALSE);
4915 if (cv) { /* must reuse cv if autoloaded */
4917 /* got here with just attrs -- work done, so bug out */
4918 SAVEFREESV(PL_compcv);
4922 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4923 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4924 CvOUTSIDE(PL_compcv) = 0;
4925 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4926 CvPADLIST(PL_compcv) = 0;
4927 /* inner references to PL_compcv must be fixed up ... */
4929 AV *padlist = CvPADLIST(cv);
4930 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4931 AV *comppad = (AV*)AvARRAY(padlist)[1];
4932 SV **namepad = AvARRAY(comppad_name);
4933 SV **curpad = AvARRAY(comppad);
4934 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4935 SV *namesv = namepad[ix];
4936 if (namesv && namesv != &PL_sv_undef
4937 && *SvPVX(namesv) == '&')
4939 CV *innercv = (CV*)curpad[ix];
4940 if (CvOUTSIDE(innercv) == PL_compcv) {
4941 CvOUTSIDE(innercv) = cv;
4942 if (!CvANON(innercv) || CvCLONED(innercv)) {
4943 (void)SvREFCNT_inc(cv);
4944 SvREFCNT_dec(PL_compcv);
4950 /* ... before we throw it away */
4951 SvREFCNT_dec(PL_compcv);
4952 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4953 ++PL_sub_generation;
4960 PL_sub_generation++;
4964 CvFILE_set_from_cop(cv, PL_curcop);
4965 CvSTASH(cv) = PL_curstash;
4966 #ifdef USE_5005THREADS
4968 if (!CvMUTEXP(cv)) {
4969 New(666, CvMUTEXP(cv), 1, perl_mutex);
4970 MUTEX_INIT(CvMUTEXP(cv));
4972 #endif /* USE_5005THREADS */
4975 sv_setpv((SV*)cv, ps);
4977 if (PL_error_count) {
4981 char *s = strrchr(name, ':');
4983 if (strEQ(s, "BEGIN")) {
4985 "BEGIN not safe after errors--compilation aborted";
4986 if (PL_in_eval & EVAL_KEEPERR)
4987 Perl_croak(aTHX_ not_safe);
4989 /* force display of errors found but not reported */
4990 sv_catpv(ERRSV, not_safe);
4991 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4999 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5000 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5003 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5004 mod(scalarseq(block), OP_LEAVESUBLV));
5007 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5009 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5010 OpREFCNT_set(CvROOT(cv), 1);
5011 CvSTART(cv) = LINKLIST(CvROOT(cv));
5012 CvROOT(cv)->op_next = 0;
5013 CALL_PEEP(CvSTART(cv));
5015 /* now that optimizer has done its work, adjust pad values */
5017 SV **namep = AvARRAY(PL_comppad_name);
5018 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5021 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5024 * The only things that a clonable function needs in its
5025 * pad are references to outer lexicals and anonymous subs.
5026 * The rest are created anew during cloning.
5028 if (!((namesv = namep[ix]) != Nullsv &&
5029 namesv != &PL_sv_undef &&
5031 *SvPVX(namesv) == '&')))
5033 SvREFCNT_dec(PL_curpad[ix]);
5034 PL_curpad[ix] = Nullsv;
5037 assert(!CvCONST(cv));
5038 if (ps && !*ps && op_const_sv(block, cv))
5042 AV *av = newAV(); /* Will be @_ */
5044 av_store(PL_comppad, 0, (SV*)av);
5045 AvFLAGS(av) = AVf_REIFY;
5047 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5048 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5050 if (!SvPADMY(PL_curpad[ix]))
5051 SvPADTMP_on(PL_curpad[ix]);
5055 /* If a potential closure prototype, don't keep a refcount on outer CV.
5056 * This is okay as the lifetime of the prototype is tied to the
5057 * lifetime of the outer CV. Avoids memory leak due to reference
5060 SvREFCNT_dec(CvOUTSIDE(cv));
5062 if (name || aname) {
5064 char *tname = (name ? name : aname);
5066 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5067 SV *sv = NEWSV(0,0);
5068 SV *tmpstr = sv_newmortal();
5069 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5073 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5075 (long)PL_subline, (long)CopLINE(PL_curcop));
5076 gv_efullname3(tmpstr, gv, Nullch);
5077 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5078 hv = GvHVn(db_postponed);
5079 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5080 && (pcv = GvCV(db_postponed)))
5086 call_sv((SV*)pcv, G_DISCARD);
5090 if ((s = strrchr(tname,':')))
5095 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5098 if (strEQ(s, "BEGIN")) {
5099 I32 oldscope = PL_scopestack_ix;
5101 SAVECOPFILE(&PL_compiling);
5102 SAVECOPLINE(&PL_compiling);
5105 PL_beginav = newAV();
5106 DEBUG_x( dump_sub(gv) );
5107 av_push(PL_beginav, (SV*)cv);
5108 GvCV(gv) = 0; /* cv has been hijacked */
5109 call_list(oldscope, PL_beginav);
5111 PL_curcop = &PL_compiling;
5112 PL_compiling.op_private = PL_hints;
5115 else if (strEQ(s, "END") && !PL_error_count) {
5118 DEBUG_x( dump_sub(gv) );
5119 av_unshift(PL_endav, 1);
5120 av_store(PL_endav, 0, (SV*)cv);
5121 GvCV(gv) = 0; /* cv has been hijacked */
5123 else if (strEQ(s, "CHECK") && !PL_error_count) {
5125 PL_checkav = newAV();
5126 DEBUG_x( dump_sub(gv) );
5127 if (PL_main_start && ckWARN(WARN_VOID))
5128 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5129 av_unshift(PL_checkav, 1);
5130 av_store(PL_checkav, 0, (SV*)cv);
5131 GvCV(gv) = 0; /* cv has been hijacked */
5133 else if (strEQ(s, "INIT") && !PL_error_count) {
5135 PL_initav = newAV();
5136 DEBUG_x( dump_sub(gv) );
5137 if (PL_main_start && ckWARN(WARN_VOID))
5138 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5139 av_push(PL_initav, (SV*)cv);
5140 GvCV(gv) = 0; /* cv has been hijacked */
5145 PL_copline = NOLINE;
5150 /* XXX unsafe for threads if eval_owner isn't held */
5152 =for apidoc newCONSTSUB
5154 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5155 eligible for inlining at compile-time.
5161 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5167 SAVECOPLINE(PL_curcop);
5168 CopLINE_set(PL_curcop, PL_copline);
5171 PL_hints &= ~HINT_BLOCK_SCOPE;
5174 SAVESPTR(PL_curstash);
5175 SAVECOPSTASH(PL_curcop);
5176 PL_curstash = stash;
5177 CopSTASH_set(PL_curcop,stash);
5180 cv = newXS(name, const_sv_xsub, __FILE__);
5181 CvXSUBANY(cv).any_ptr = sv;
5183 sv_setpv((SV*)cv, ""); /* prototype is "" */
5191 =for apidoc U||newXS
5193 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5199 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5201 GV *gv = gv_fetchpv(name ? name :
5202 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5203 GV_ADDMULTI, SVt_PVCV);
5206 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5208 /* just a cached method */
5212 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5213 /* already defined (or promised) */
5214 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5215 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5216 line_t oldline = CopLINE(PL_curcop);
5217 if (PL_copline != NOLINE)
5218 CopLINE_set(PL_curcop, PL_copline);
5219 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5220 CvCONST(cv) ? "Constant subroutine %s redefined"
5221 : "Subroutine %s redefined"
5223 CopLINE_set(PL_curcop, oldline);
5230 if (cv) /* must reuse cv if autoloaded */
5233 cv = (CV*)NEWSV(1105,0);
5234 sv_upgrade((SV *)cv, SVt_PVCV);
5238 PL_sub_generation++;
5242 #ifdef USE_5005THREADS
5243 New(666, CvMUTEXP(cv), 1, perl_mutex);
5244 MUTEX_INIT(CvMUTEXP(cv));
5246 #endif /* USE_5005THREADS */
5247 (void)gv_fetchfile(filename);
5248 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5249 an external constant string */
5250 CvXSUB(cv) = subaddr;
5253 char *s = strrchr(name,':');
5259 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5262 if (strEQ(s, "BEGIN")) {
5264 PL_beginav = newAV();
5265 av_push(PL_beginav, (SV*)cv);
5266 GvCV(gv) = 0; /* cv has been hijacked */
5268 else if (strEQ(s, "END")) {
5271 av_unshift(PL_endav, 1);
5272 av_store(PL_endav, 0, (SV*)cv);
5273 GvCV(gv) = 0; /* cv has been hijacked */
5275 else if (strEQ(s, "CHECK")) {
5277 PL_checkav = newAV();
5278 if (PL_main_start && ckWARN(WARN_VOID))
5279 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5280 av_unshift(PL_checkav, 1);
5281 av_store(PL_checkav, 0, (SV*)cv);
5282 GvCV(gv) = 0; /* cv has been hijacked */
5284 else if (strEQ(s, "INIT")) {
5286 PL_initav = newAV();
5287 if (PL_main_start && ckWARN(WARN_VOID))
5288 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5289 av_push(PL_initav, (SV*)cv);
5290 GvCV(gv) = 0; /* cv has been hijacked */
5301 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5310 name = SvPVx(cSVOPo->op_sv, n_a);
5313 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5314 #ifdef GV_UNIQUE_CHECK
5316 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5320 if ((cv = GvFORM(gv))) {
5321 if (ckWARN(WARN_REDEFINE)) {
5322 line_t oldline = CopLINE(PL_curcop);
5323 if (PL_copline != NOLINE)
5324 CopLINE_set(PL_curcop, PL_copline);
5325 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
5326 CopLINE_set(PL_curcop, oldline);
5333 CvFILE_set_from_cop(cv, PL_curcop);
5335 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5336 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5337 SvPADTMP_on(PL_curpad[ix]);
5340 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5341 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5342 OpREFCNT_set(CvROOT(cv), 1);
5343 CvSTART(cv) = LINKLIST(CvROOT(cv));
5344 CvROOT(cv)->op_next = 0;
5345 CALL_PEEP(CvSTART(cv));
5347 PL_copline = NOLINE;
5352 Perl_newANONLIST(pTHX_ OP *o)
5354 return newUNOP(OP_REFGEN, 0,
5355 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5359 Perl_newANONHASH(pTHX_ OP *o)
5361 return newUNOP(OP_REFGEN, 0,
5362 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5366 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5368 return newANONATTRSUB(floor, proto, Nullop, block);
5372 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5374 return newUNOP(OP_REFGEN, 0,
5375 newSVOP(OP_ANONCODE, 0,
5376 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5380 Perl_oopsAV(pTHX_ OP *o)
5382 switch (o->op_type) {
5384 o->op_type = OP_PADAV;
5385 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5386 return ref(o, OP_RV2AV);
5389 o->op_type = OP_RV2AV;
5390 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5395 if (ckWARN_d(WARN_INTERNAL))
5396 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5403 Perl_oopsHV(pTHX_ OP *o)
5405 switch (o->op_type) {
5408 o->op_type = OP_PADHV;
5409 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5410 return ref(o, OP_RV2HV);
5414 o->op_type = OP_RV2HV;
5415 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5420 if (ckWARN_d(WARN_INTERNAL))
5421 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5428 Perl_newAVREF(pTHX_ OP *o)
5430 if (o->op_type == OP_PADANY) {
5431 o->op_type = OP_PADAV;
5432 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5435 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5436 && ckWARN(WARN_DEPRECATED)) {
5437 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5438 "Using an array as a reference is deprecated");
5440 return newUNOP(OP_RV2AV, 0, scalar(o));
5444 Perl_newGVREF(pTHX_ I32 type, OP *o)
5446 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5447 return newUNOP(OP_NULL, 0, o);
5448 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5452 Perl_newHVREF(pTHX_ OP *o)
5454 if (o->op_type == OP_PADANY) {
5455 o->op_type = OP_PADHV;
5456 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5459 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5460 && ckWARN(WARN_DEPRECATED)) {
5461 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5462 "Using a hash as a reference is deprecated");
5464 return newUNOP(OP_RV2HV, 0, scalar(o));
5468 Perl_oopsCV(pTHX_ OP *o)
5470 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5476 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5478 return newUNOP(OP_RV2CV, flags, scalar(o));
5482 Perl_newSVREF(pTHX_ OP *o)
5484 if (o->op_type == OP_PADANY) {
5485 o->op_type = OP_PADSV;
5486 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5489 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5490 o->op_flags |= OPpDONE_SVREF;
5493 return newUNOP(OP_RV2SV, 0, scalar(o));
5496 /* Check routines. */
5499 Perl_ck_anoncode(pTHX_ OP *o)
5504 name = NEWSV(1106,0);
5505 sv_upgrade(name, SVt_PVNV);
5506 sv_setpvn(name, "&", 1);
5509 ix = pad_alloc(o->op_type, SVs_PADMY);
5510 av_store(PL_comppad_name, ix, name);
5511 av_store(PL_comppad, ix, cSVOPo->op_sv);
5512 SvPADMY_on(cSVOPo->op_sv);
5513 cSVOPo->op_sv = Nullsv;
5514 cSVOPo->op_targ = ix;
5519 Perl_ck_bitop(pTHX_ OP *o)
5521 o->op_private = PL_hints;
5526 Perl_ck_concat(pTHX_ OP *o)
5528 if (cUNOPo->op_first->op_type == OP_CONCAT)
5529 o->op_flags |= OPf_STACKED;
5534 Perl_ck_spair(pTHX_ OP *o)
5536 if (o->op_flags & OPf_KIDS) {
5539 OPCODE type = o->op_type;
5540 o = modkids(ck_fun(o), type);
5541 kid = cUNOPo->op_first;
5542 newop = kUNOP->op_first->op_sibling;
5544 (newop->op_sibling ||
5545 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5546 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5547 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5551 op_free(kUNOP->op_first);
5552 kUNOP->op_first = newop;
5554 o->op_ppaddr = PL_ppaddr[++o->op_type];
5559 Perl_ck_delete(pTHX_ OP *o)
5563 if (o->op_flags & OPf_KIDS) {
5564 OP *kid = cUNOPo->op_first;
5565 switch (kid->op_type) {
5567 o->op_flags |= OPf_SPECIAL;
5570 o->op_private |= OPpSLICE;
5573 o->op_flags |= OPf_SPECIAL;
5578 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5587 Perl_ck_die(pTHX_ OP *o)
5590 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5596 Perl_ck_eof(pTHX_ OP *o)
5598 I32 type = o->op_type;
5600 if (o->op_flags & OPf_KIDS) {
5601 if (cLISTOPo->op_first->op_type == OP_STUB) {
5603 o = newUNOP(type, OPf_SPECIAL,
5604 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5612 Perl_ck_eval(pTHX_ OP *o)
5614 PL_hints |= HINT_BLOCK_SCOPE;
5615 if (o->op_flags & OPf_KIDS) {
5616 SVOP *kid = (SVOP*)cUNOPo->op_first;
5619 o->op_flags &= ~OPf_KIDS;
5622 else if (kid->op_type == OP_LINESEQ) {
5625 kid->op_next = o->op_next;
5626 cUNOPo->op_first = 0;
5629 NewOp(1101, enter, 1, LOGOP);
5630 enter->op_type = OP_ENTERTRY;
5631 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5632 enter->op_private = 0;
5634 /* establish postfix order */
5635 enter->op_next = (OP*)enter;
5637 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5638 o->op_type = OP_LEAVETRY;
5639 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5640 enter->op_other = o;
5648 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5650 o->op_targ = (PADOFFSET)PL_hints;
5655 Perl_ck_exit(pTHX_ OP *o)
5658 HV *table = GvHV(PL_hintgv);
5660 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5661 if (svp && *svp && SvTRUE(*svp))
5662 o->op_private |= OPpEXIT_VMSISH;
5664 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5670 Perl_ck_exec(pTHX_ OP *o)
5673 if (o->op_flags & OPf_STACKED) {
5675 kid = cUNOPo->op_first->op_sibling;
5676 if (kid->op_type == OP_RV2GV)
5685 Perl_ck_exists(pTHX_ OP *o)
5688 if (o->op_flags & OPf_KIDS) {
5689 OP *kid = cUNOPo->op_first;
5690 if (kid->op_type == OP_ENTERSUB) {
5691 (void) ref(kid, o->op_type);
5692 if (kid->op_type != OP_RV2CV && !PL_error_count)
5693 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5695 o->op_private |= OPpEXISTS_SUB;
5697 else if (kid->op_type == OP_AELEM)
5698 o->op_flags |= OPf_SPECIAL;
5699 else if (kid->op_type != OP_HELEM)
5700 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5709 Perl_ck_gvconst(pTHX_ register OP *o)
5711 o = fold_constants(o);
5712 if (o->op_type == OP_CONST)
5719 Perl_ck_rvconst(pTHX_ register OP *o)
5721 SVOP *kid = (SVOP*)cUNOPo->op_first;
5723 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5724 if (kid->op_type == OP_CONST) {
5728 SV *kidsv = kid->op_sv;
5731 /* Is it a constant from cv_const_sv()? */
5732 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5733 SV *rsv = SvRV(kidsv);
5734 int svtype = SvTYPE(rsv);
5735 char *badtype = Nullch;
5737 switch (o->op_type) {
5739 if (svtype > SVt_PVMG)
5740 badtype = "a SCALAR";
5743 if (svtype != SVt_PVAV)
5744 badtype = "an ARRAY";
5747 if (svtype != SVt_PVHV) {
5748 if (svtype == SVt_PVAV) { /* pseudohash? */
5749 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5750 if (ksv && SvROK(*ksv)
5751 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5760 if (svtype != SVt_PVCV)
5765 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5768 name = SvPV(kidsv, n_a);
5769 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5770 char *badthing = Nullch;
5771 switch (o->op_type) {
5773 badthing = "a SCALAR";
5776 badthing = "an ARRAY";
5779 badthing = "a HASH";
5784 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5788 * This is a little tricky. We only want to add the symbol if we
5789 * didn't add it in the lexer. Otherwise we get duplicate strict
5790 * warnings. But if we didn't add it in the lexer, we must at
5791 * least pretend like we wanted to add it even if it existed before,
5792 * or we get possible typo warnings. OPpCONST_ENTERED says
5793 * whether the lexer already added THIS instance of this symbol.
5795 iscv = (o->op_type == OP_RV2CV) * 2;
5797 gv = gv_fetchpv(name,
5798 iscv | !(kid->op_private & OPpCONST_ENTERED),
5801 : o->op_type == OP_RV2SV
5803 : o->op_type == OP_RV2AV
5805 : o->op_type == OP_RV2HV
5808 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5810 kid->op_type = OP_GV;
5811 SvREFCNT_dec(kid->op_sv);
5813 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5814 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5815 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5817 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5819 kid->op_sv = SvREFCNT_inc(gv);
5821 kid->op_private = 0;
5822 kid->op_ppaddr = PL_ppaddr[OP_GV];
5829 Perl_ck_ftst(pTHX_ OP *o)
5831 I32 type = o->op_type;
5833 if (o->op_flags & OPf_REF) {
5836 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5837 SVOP *kid = (SVOP*)cUNOPo->op_first;
5839 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5841 OP *newop = newGVOP(type, OPf_REF,
5842 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5849 if (type == OP_FTTTY)
5850 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5853 o = newUNOP(type, 0, newDEFSVOP());
5859 Perl_ck_fun(pTHX_ OP *o)
5865 int type = o->op_type;
5866 register I32 oa = PL_opargs[type] >> OASHIFT;
5868 if (o->op_flags & OPf_STACKED) {
5869 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5872 return no_fh_allowed(o);
5875 if (o->op_flags & OPf_KIDS) {
5877 tokid = &cLISTOPo->op_first;
5878 kid = cLISTOPo->op_first;
5879 if (kid->op_type == OP_PUSHMARK ||
5880 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5882 tokid = &kid->op_sibling;
5883 kid = kid->op_sibling;
5885 if (!kid && PL_opargs[type] & OA_DEFGV)
5886 *tokid = kid = newDEFSVOP();
5890 sibl = kid->op_sibling;
5893 /* list seen where single (scalar) arg expected? */
5894 if (numargs == 1 && !(oa >> 4)
5895 && kid->op_type == OP_LIST && type != OP_SCALAR)
5897 return too_many_arguments(o,PL_op_desc[type]);
5910 if ((type == OP_PUSH || type == OP_UNSHIFT)
5911 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5912 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5913 "Useless use of %s with no values",
5916 if (kid->op_type == OP_CONST &&
5917 (kid->op_private & OPpCONST_BARE))
5919 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5920 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5921 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5922 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5923 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5924 "Array @%s missing the @ in argument %"IVdf" of %s()",
5925 name, (IV)numargs, PL_op_desc[type]);
5928 kid->op_sibling = sibl;
5931 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5932 bad_type(numargs, "array", PL_op_desc[type], kid);
5936 if (kid->op_type == OP_CONST &&
5937 (kid->op_private & OPpCONST_BARE))
5939 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5940 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5941 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5942 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5943 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5944 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5945 name, (IV)numargs, PL_op_desc[type]);
5948 kid->op_sibling = sibl;
5951 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5952 bad_type(numargs, "hash", PL_op_desc[type], kid);
5957 OP *newop = newUNOP(OP_NULL, 0, kid);
5958 kid->op_sibling = 0;
5960 newop->op_next = newop;
5962 kid->op_sibling = sibl;
5967 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5968 if (kid->op_type == OP_CONST &&
5969 (kid->op_private & OPpCONST_BARE))
5971 OP *newop = newGVOP(OP_GV, 0,
5972 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5974 if (!(o->op_private & 1) && /* if not unop */
5975 kid == cLISTOPo->op_last)
5976 cLISTOPo->op_last = newop;
5980 else if (kid->op_type == OP_READLINE) {
5981 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5982 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5985 I32 flags = OPf_SPECIAL;
5989 /* is this op a FH constructor? */
5990 if (is_handle_constructor(o,numargs)) {
5991 char *name = Nullch;
5995 /* Set a flag to tell rv2gv to vivify
5996 * need to "prove" flag does not mean something
5997 * else already - NI-S 1999/05/07
6000 if (kid->op_type == OP_PADSV) {
6001 SV **namep = av_fetch(PL_comppad_name,
6003 if (namep && *namep)
6004 name = SvPV(*namep, len);
6006 else if (kid->op_type == OP_RV2SV
6007 && kUNOP->op_first->op_type == OP_GV)
6009 GV *gv = cGVOPx_gv(kUNOP->op_first);
6011 len = GvNAMELEN(gv);
6013 else if (kid->op_type == OP_AELEM
6014 || kid->op_type == OP_HELEM)
6016 name = "__ANONIO__";
6022 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6023 namesv = PL_curpad[targ];
6024 (void)SvUPGRADE(namesv, SVt_PV);
6026 sv_setpvn(namesv, "$", 1);
6027 sv_catpvn(namesv, name, len);
6030 kid->op_sibling = 0;
6031 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6032 kid->op_targ = targ;
6033 kid->op_private |= priv;
6035 kid->op_sibling = sibl;
6041 mod(scalar(kid), type);
6045 tokid = &kid->op_sibling;
6046 kid = kid->op_sibling;
6048 o->op_private |= numargs;
6050 return too_many_arguments(o,OP_DESC(o));
6053 else if (PL_opargs[type] & OA_DEFGV) {
6055 return newUNOP(type, 0, newDEFSVOP());
6059 while (oa & OA_OPTIONAL)
6061 if (oa && oa != OA_LIST)
6062 return too_few_arguments(o,OP_DESC(o));
6068 Perl_ck_glob(pTHX_ OP *o)
6073 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6074 append_elem(OP_GLOB, o, newDEFSVOP());
6076 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6077 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6079 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6082 #if !defined(PERL_EXTERNAL_GLOB)
6083 /* XXX this can be tightened up and made more failsafe. */
6087 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6088 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6089 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6090 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6091 GvCV(gv) = GvCV(glob_gv);
6092 SvREFCNT_inc((SV*)GvCV(gv));
6093 GvIMPORTED_CV_on(gv);
6096 #endif /* PERL_EXTERNAL_GLOB */
6098 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6099 append_elem(OP_GLOB, o,
6100 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6101 o->op_type = OP_LIST;
6102 o->op_ppaddr = PL_ppaddr[OP_LIST];
6103 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6104 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6105 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6106 append_elem(OP_LIST, o,
6107 scalar(newUNOP(OP_RV2CV, 0,
6108 newGVOP(OP_GV, 0, gv)))));
6109 o = newUNOP(OP_NULL, 0, ck_subr(o));
6110 o->op_targ = OP_GLOB; /* hint at what it used to be */
6113 gv = newGVgen("main");
6115 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6121 Perl_ck_grep(pTHX_ OP *o)
6125 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6127 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6128 NewOp(1101, gwop, 1, LOGOP);
6130 if (o->op_flags & OPf_STACKED) {
6133 kid = cLISTOPo->op_first->op_sibling;
6134 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6137 kid->op_next = (OP*)gwop;
6138 o->op_flags &= ~OPf_STACKED;
6140 kid = cLISTOPo->op_first->op_sibling;
6141 if (type == OP_MAPWHILE)
6148 kid = cLISTOPo->op_first->op_sibling;
6149 if (kid->op_type != OP_NULL)
6150 Perl_croak(aTHX_ "panic: ck_grep");
6151 kid = kUNOP->op_first;
6153 gwop->op_type = type;
6154 gwop->op_ppaddr = PL_ppaddr[type];
6155 gwop->op_first = listkids(o);
6156 gwop->op_flags |= OPf_KIDS;
6157 gwop->op_private = 1;
6158 gwop->op_other = LINKLIST(kid);
6159 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6160 kid->op_next = (OP*)gwop;
6162 kid = cLISTOPo->op_first->op_sibling;
6163 if (!kid || !kid->op_sibling)
6164 return too_few_arguments(o,OP_DESC(o));
6165 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6166 mod(kid, OP_GREPSTART);
6172 Perl_ck_index(pTHX_ OP *o)
6174 if (o->op_flags & OPf_KIDS) {
6175 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6177 kid = kid->op_sibling; /* get past "big" */
6178 if (kid && kid->op_type == OP_CONST)
6179 fbm_compile(((SVOP*)kid)->op_sv, 0);
6185 Perl_ck_lengthconst(pTHX_ OP *o)
6187 /* XXX length optimization goes here */
6192 Perl_ck_lfun(pTHX_ OP *o)
6194 OPCODE type = o->op_type;
6195 return modkids(ck_fun(o), type);
6199 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6201 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6202 switch (cUNOPo->op_first->op_type) {
6204 /* This is needed for
6205 if (defined %stash::)
6206 to work. Do not break Tk.
6208 break; /* Globals via GV can be undef */
6210 case OP_AASSIGN: /* Is this a good idea? */
6211 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6212 "defined(@array) is deprecated");
6213 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6214 "\t(Maybe you should just omit the defined()?)\n");
6217 /* This is needed for
6218 if (defined %stash::)
6219 to work. Do not break Tk.
6221 break; /* Globals via GV can be undef */
6223 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6224 "defined(%%hash) is deprecated");
6225 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6226 "\t(Maybe you should just omit the defined()?)\n");
6237 Perl_ck_rfun(pTHX_ OP *o)
6239 OPCODE type = o->op_type;
6240 return refkids(ck_fun(o), type);
6244 Perl_ck_listiob(pTHX_ OP *o)
6248 kid = cLISTOPo->op_first;
6251 kid = cLISTOPo->op_first;
6253 if (kid->op_type == OP_PUSHMARK)
6254 kid = kid->op_sibling;
6255 if (kid && o->op_flags & OPf_STACKED)
6256 kid = kid->op_sibling;
6257 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6258 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6259 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6260 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6261 cLISTOPo->op_first->op_sibling = kid;
6262 cLISTOPo->op_last = kid;
6263 kid = kid->op_sibling;
6268 append_elem(o->op_type, o, newDEFSVOP());
6274 Perl_ck_sassign(pTHX_ OP *o)
6276 OP *kid = cLISTOPo->op_first;
6277 /* has a disposable target? */
6278 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6279 && !(kid->op_flags & OPf_STACKED)
6280 /* Cannot steal the second time! */
6281 && !(kid->op_private & OPpTARGET_MY))
6283 OP *kkid = kid->op_sibling;
6285 /* Can just relocate the target. */
6286 if (kkid && kkid->op_type == OP_PADSV
6287 && !(kkid->op_private & OPpLVAL_INTRO))
6289 kid->op_targ = kkid->op_targ;
6291 /* Now we do not need PADSV and SASSIGN. */
6292 kid->op_sibling = o->op_sibling; /* NULL */
6293 cLISTOPo->op_first = NULL;
6296 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6304 Perl_ck_match(pTHX_ OP *o)
6306 o->op_private |= OPpRUNTIME;
6311 Perl_ck_method(pTHX_ OP *o)
6313 OP *kid = cUNOPo->op_first;
6314 if (kid->op_type == OP_CONST) {
6315 SV* sv = kSVOP->op_sv;
6316 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6318 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6319 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6322 kSVOP->op_sv = Nullsv;
6324 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6333 Perl_ck_null(pTHX_ OP *o)
6339 Perl_ck_open(pTHX_ OP *o)
6341 HV *table = GvHV(PL_hintgv);
6345 svp = hv_fetch(table, "open_IN", 7, FALSE);
6347 mode = mode_from_discipline(*svp);
6348 if (mode & O_BINARY)
6349 o->op_private |= OPpOPEN_IN_RAW;
6350 else if (mode & O_TEXT)
6351 o->op_private |= OPpOPEN_IN_CRLF;
6354 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6356 mode = mode_from_discipline(*svp);
6357 if (mode & O_BINARY)
6358 o->op_private |= OPpOPEN_OUT_RAW;
6359 else if (mode & O_TEXT)
6360 o->op_private |= OPpOPEN_OUT_CRLF;
6363 if (o->op_type == OP_BACKTICK)
6369 Perl_ck_repeat(pTHX_ OP *o)
6371 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6372 o->op_private |= OPpREPEAT_DOLIST;
6373 cBINOPo->op_first = force_list(cBINOPo->op_first);
6381 Perl_ck_require(pTHX_ OP *o)
6385 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6386 SVOP *kid = (SVOP*)cUNOPo->op_first;
6388 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6390 for (s = SvPVX(kid->op_sv); *s; s++) {
6391 if (*s == ':' && s[1] == ':') {
6393 Move(s+2, s+1, strlen(s+2)+1, char);
6394 --SvCUR(kid->op_sv);
6397 if (SvREADONLY(kid->op_sv)) {
6398 SvREADONLY_off(kid->op_sv);
6399 sv_catpvn(kid->op_sv, ".pm", 3);
6400 SvREADONLY_on(kid->op_sv);
6403 sv_catpvn(kid->op_sv, ".pm", 3);
6407 /* handle override, if any */
6408 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6409 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6410 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6412 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6413 OP *kid = cUNOPo->op_first;
6414 cUNOPo->op_first = 0;
6416 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6417 append_elem(OP_LIST, kid,
6418 scalar(newUNOP(OP_RV2CV, 0,
6427 Perl_ck_return(pTHX_ OP *o)
6430 if (CvLVALUE(PL_compcv)) {
6431 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6432 mod(kid, OP_LEAVESUBLV);
6439 Perl_ck_retarget(pTHX_ OP *o)
6441 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6448 Perl_ck_select(pTHX_ OP *o)
6451 if (o->op_flags & OPf_KIDS) {
6452 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6453 if (kid && kid->op_sibling) {
6454 o->op_type = OP_SSELECT;
6455 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6457 return fold_constants(o);
6461 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6462 if (kid && kid->op_type == OP_RV2GV)
6463 kid->op_private &= ~HINT_STRICT_REFS;
6468 Perl_ck_shift(pTHX_ OP *o)
6470 I32 type = o->op_type;
6472 if (!(o->op_flags & OPf_KIDS)) {
6476 #ifdef USE_5005THREADS
6477 if (!CvUNIQUE(PL_compcv)) {
6478 argop = newOP(OP_PADAV, OPf_REF);
6479 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6482 argop = newUNOP(OP_RV2AV, 0,
6483 scalar(newGVOP(OP_GV, 0,
6484 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6487 argop = newUNOP(OP_RV2AV, 0,
6488 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6489 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6490 #endif /* USE_5005THREADS */
6491 return newUNOP(type, 0, scalar(argop));
6493 return scalar(modkids(ck_fun(o), type));
6497 Perl_ck_sort(pTHX_ OP *o)
6501 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6503 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6504 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6506 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6508 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6510 if (kid->op_type == OP_SCOPE) {
6514 else if (kid->op_type == OP_LEAVE) {
6515 if (o->op_type == OP_SORT) {
6516 op_null(kid); /* wipe out leave */
6519 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6520 if (k->op_next == kid)
6522 /* don't descend into loops */
6523 else if (k->op_type == OP_ENTERLOOP
6524 || k->op_type == OP_ENTERITER)
6526 k = cLOOPx(k)->op_lastop;
6531 kid->op_next = 0; /* just disconnect the leave */
6532 k = kLISTOP->op_first;
6537 if (o->op_type == OP_SORT) {
6538 /* provide scalar context for comparison function/block */
6544 o->op_flags |= OPf_SPECIAL;
6546 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6549 firstkid = firstkid->op_sibling;
6552 /* provide list context for arguments */
6553 if (o->op_type == OP_SORT)
6560 S_simplify_sort(pTHX_ OP *o)
6562 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6566 if (!(o->op_flags & OPf_STACKED))
6568 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6569 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6570 kid = kUNOP->op_first; /* get past null */
6571 if (kid->op_type != OP_SCOPE)
6573 kid = kLISTOP->op_last; /* get past scope */
6574 switch(kid->op_type) {
6582 k = kid; /* remember this node*/
6583 if (kBINOP->op_first->op_type != OP_RV2SV)
6585 kid = kBINOP->op_first; /* get past cmp */
6586 if (kUNOP->op_first->op_type != OP_GV)
6588 kid = kUNOP->op_first; /* get past rv2sv */
6590 if (GvSTASH(gv) != PL_curstash)
6592 if (strEQ(GvNAME(gv), "a"))
6594 else if (strEQ(GvNAME(gv), "b"))
6598 kid = k; /* back to cmp */
6599 if (kBINOP->op_last->op_type != OP_RV2SV)
6601 kid = kBINOP->op_last; /* down to 2nd arg */
6602 if (kUNOP->op_first->op_type != OP_GV)
6604 kid = kUNOP->op_first; /* get past rv2sv */
6606 if (GvSTASH(gv) != PL_curstash
6608 ? strNE(GvNAME(gv), "a")
6609 : strNE(GvNAME(gv), "b")))
6611 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6613 o->op_private |= OPpSORT_REVERSE;
6614 if (k->op_type == OP_NCMP)
6615 o->op_private |= OPpSORT_NUMERIC;
6616 if (k->op_type == OP_I_NCMP)
6617 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6618 kid = cLISTOPo->op_first->op_sibling;
6619 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6620 op_free(kid); /* then delete it */
6624 Perl_ck_split(pTHX_ OP *o)
6628 if (o->op_flags & OPf_STACKED)
6629 return no_fh_allowed(o);
6631 kid = cLISTOPo->op_first;
6632 if (kid->op_type != OP_NULL)
6633 Perl_croak(aTHX_ "panic: ck_split");
6634 kid = kid->op_sibling;
6635 op_free(cLISTOPo->op_first);
6636 cLISTOPo->op_first = kid;
6638 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6639 cLISTOPo->op_last = kid; /* There was only one element previously */
6642 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6643 OP *sibl = kid->op_sibling;
6644 kid->op_sibling = 0;
6645 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6646 if (cLISTOPo->op_first == cLISTOPo->op_last)
6647 cLISTOPo->op_last = kid;
6648 cLISTOPo->op_first = kid;
6649 kid->op_sibling = sibl;
6652 kid->op_type = OP_PUSHRE;
6653 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6656 if (!kid->op_sibling)
6657 append_elem(OP_SPLIT, o, newDEFSVOP());
6659 kid = kid->op_sibling;
6662 if (!kid->op_sibling)
6663 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6665 kid = kid->op_sibling;
6668 if (kid->op_sibling)
6669 return too_many_arguments(o,OP_DESC(o));
6675 Perl_ck_join(pTHX_ OP *o)
6677 if (ckWARN(WARN_SYNTAX)) {
6678 OP *kid = cLISTOPo->op_first->op_sibling;
6679 if (kid && kid->op_type == OP_MATCH) {
6680 char *pmstr = "STRING";
6681 if (PM_GETRE(kPMOP))
6682 pmstr = PM_GETRE(kPMOP)->precomp;
6683 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6684 "/%s/ should probably be written as \"%s\"",
6692 Perl_ck_subr(pTHX_ OP *o)
6694 OP *prev = ((cUNOPo->op_first->op_sibling)
6695 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6696 OP *o2 = prev->op_sibling;
6703 I32 contextclass = 0;
6707 o->op_private |= OPpENTERSUB_HASTARG;
6708 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6709 if (cvop->op_type == OP_RV2CV) {
6711 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6712 op_null(cvop); /* disable rv2cv */
6713 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6714 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6715 GV *gv = cGVOPx_gv(tmpop);
6718 tmpop->op_private |= OPpEARLY_CV;
6719 else if (SvPOK(cv)) {
6720 namegv = CvANON(cv) ? gv : CvGV(cv);
6721 proto = SvPV((SV*)cv, n_a);
6725 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6726 if (o2->op_type == OP_CONST)
6727 o2->op_private &= ~OPpCONST_STRICT;
6728 else if (o2->op_type == OP_LIST) {
6729 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6730 if (o && o->op_type == OP_CONST)
6731 o->op_private &= ~OPpCONST_STRICT;
6734 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6735 if (PERLDB_SUB && PL_curstash != PL_debstash)
6736 o->op_private |= OPpENTERSUB_DB;
6737 while (o2 != cvop) {
6741 return too_many_arguments(o, gv_ename(namegv));
6759 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6761 arg == 1 ? "block or sub {}" : "sub {}",
6762 gv_ename(namegv), o2);
6765 /* '*' allows any scalar type, including bareword */
6768 if (o2->op_type == OP_RV2GV)
6769 goto wrapref; /* autoconvert GLOB -> GLOBref */
6770 else if (o2->op_type == OP_CONST)
6771 o2->op_private &= ~OPpCONST_STRICT;
6772 else if (o2->op_type == OP_ENTERSUB) {
6773 /* accidental subroutine, revert to bareword */
6774 OP *gvop = ((UNOP*)o2)->op_first;
6775 if (gvop && gvop->op_type == OP_NULL) {
6776 gvop = ((UNOP*)gvop)->op_first;
6778 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6781 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6782 (gvop = ((UNOP*)gvop)->op_first) &&
6783 gvop->op_type == OP_GV)
6785 GV *gv = cGVOPx_gv(gvop);
6786 OP *sibling = o2->op_sibling;
6787 SV *n = newSVpvn("",0);
6789 gv_fullname3(n, gv, "");
6790 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6791 sv_chop(n, SvPVX(n)+6);
6792 o2 = newSVOP(OP_CONST, 0, n);
6793 prev->op_sibling = o2;
6794 o2->op_sibling = sibling;
6810 if (contextclass++ == 0) {
6811 e = strchr(proto, ']');
6812 if (!e || e == proto)
6825 while (*--p != '[');
6826 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6827 gv_ename(namegv), o2);
6833 if (o2->op_type == OP_RV2GV)
6836 bad_type(arg, "symbol", gv_ename(namegv), o2);
6839 if (o2->op_type == OP_ENTERSUB)
6842 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6845 if (o2->op_type == OP_RV2SV ||
6846 o2->op_type == OP_PADSV ||
6847 o2->op_type == OP_HELEM ||
6848 o2->op_type == OP_AELEM ||
6849 o2->op_type == OP_THREADSV)
6852 bad_type(arg, "scalar", gv_ename(namegv), o2);
6855 if (o2->op_type == OP_RV2AV ||
6856 o2->op_type == OP_PADAV)
6859 bad_type(arg, "array", gv_ename(namegv), o2);
6862 if (o2->op_type == OP_RV2HV ||
6863 o2->op_type == OP_PADHV)
6866 bad_type(arg, "hash", gv_ename(namegv), o2);
6871 OP* sib = kid->op_sibling;
6872 kid->op_sibling = 0;
6873 o2 = newUNOP(OP_REFGEN, 0, kid);
6874 o2->op_sibling = sib;
6875 prev->op_sibling = o2;
6877 if (contextclass && e) {
6892 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6893 gv_ename(namegv), SvPV((SV*)cv, n_a));
6898 mod(o2, OP_ENTERSUB);
6900 o2 = o2->op_sibling;
6902 if (proto && !optional &&
6903 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6904 return too_few_arguments(o, gv_ename(namegv));
6909 Perl_ck_svconst(pTHX_ OP *o)
6911 SvREADONLY_on(cSVOPo->op_sv);
6916 Perl_ck_trunc(pTHX_ OP *o)
6918 if (o->op_flags & OPf_KIDS) {
6919 SVOP *kid = (SVOP*)cUNOPo->op_first;
6921 if (kid->op_type == OP_NULL)
6922 kid = (SVOP*)kid->op_sibling;
6923 if (kid && kid->op_type == OP_CONST &&
6924 (kid->op_private & OPpCONST_BARE))
6926 o->op_flags |= OPf_SPECIAL;
6927 kid->op_private &= ~OPpCONST_STRICT;
6934 Perl_ck_substr(pTHX_ OP *o)
6937 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6938 OP *kid = cLISTOPo->op_first;
6940 if (kid->op_type == OP_NULL)
6941 kid = kid->op_sibling;
6943 kid->op_flags |= OPf_MOD;
6949 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6952 Perl_peep(pTHX_ register OP *o)
6954 register OP* oldop = 0;
6957 if (!o || o->op_seq)
6961 SAVEVPTR(PL_curcop);
6962 for (; o; o = o->op_next) {
6968 switch (o->op_type) {
6972 PL_curcop = ((COP*)o); /* for warnings */
6973 o->op_seq = PL_op_seqmax++;
6977 if (cSVOPo->op_private & OPpCONST_STRICT)
6978 no_bareword_allowed(o);
6980 /* Relocate sv to the pad for thread safety.
6981 * Despite being a "constant", the SV is written to,
6982 * for reference counts, sv_upgrade() etc. */
6984 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6985 if (SvPADTMP(cSVOPo->op_sv)) {
6986 /* If op_sv is already a PADTMP then it is being used by
6987 * some pad, so make a copy. */
6988 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6989 SvREADONLY_on(PL_curpad[ix]);
6990 SvREFCNT_dec(cSVOPo->op_sv);
6993 SvREFCNT_dec(PL_curpad[ix]);
6994 SvPADTMP_on(cSVOPo->op_sv);
6995 PL_curpad[ix] = cSVOPo->op_sv;
6996 /* XXX I don't know how this isn't readonly already. */
6997 SvREADONLY_on(PL_curpad[ix]);
6999 cSVOPo->op_sv = Nullsv;
7003 o->op_seq = PL_op_seqmax++;
7007 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7008 if (o->op_next->op_private & OPpTARGET_MY) {
7009 if (o->op_flags & OPf_STACKED) /* chained concats */
7010 goto ignore_optimization;
7012 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7013 o->op_targ = o->op_next->op_targ;
7014 o->op_next->op_targ = 0;
7015 o->op_private |= OPpTARGET_MY;
7018 op_null(o->op_next);
7020 ignore_optimization:
7021 o->op_seq = PL_op_seqmax++;
7024 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7025 o->op_seq = PL_op_seqmax++;
7026 break; /* Scalar stub must produce undef. List stub is noop */
7030 if (o->op_targ == OP_NEXTSTATE
7031 || o->op_targ == OP_DBSTATE
7032 || o->op_targ == OP_SETSTATE)
7034 PL_curcop = ((COP*)o);
7036 /* XXX: We avoid setting op_seq here to prevent later calls
7037 to peep() from mistakenly concluding that optimisation
7038 has already occurred. This doesn't fix the real problem,
7039 though (See 20010220.007). AMS 20010719 */
7040 if (oldop && o->op_next) {
7041 oldop->op_next = o->op_next;
7049 if (oldop && o->op_next) {
7050 oldop->op_next = o->op_next;
7053 o->op_seq = PL_op_seqmax++;
7057 if (o->op_next->op_type == OP_RV2SV) {
7058 if (!(o->op_next->op_private & OPpDEREF)) {
7059 op_null(o->op_next);
7060 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7062 o->op_next = o->op_next->op_next;
7063 o->op_type = OP_GVSV;
7064 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7067 else if (o->op_next->op_type == OP_RV2AV) {
7068 OP* pop = o->op_next->op_next;
7070 if (pop && pop->op_type == OP_CONST &&
7071 (PL_op = pop->op_next) &&
7072 pop->op_next->op_type == OP_AELEM &&
7073 !(pop->op_next->op_private &
7074 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7075 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7080 op_null(o->op_next);
7081 op_null(pop->op_next);
7083 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7084 o->op_next = pop->op_next->op_next;
7085 o->op_type = OP_AELEMFAST;
7086 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7087 o->op_private = (U8)i;
7092 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7094 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7095 /* XXX could check prototype here instead of just carping */
7096 SV *sv = sv_newmortal();
7097 gv_efullname3(sv, gv, Nullch);
7098 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7099 "%s() called too early to check prototype",
7103 else if (o->op_next->op_type == OP_READLINE
7104 && o->op_next->op_next->op_type == OP_CONCAT
7105 && (o->op_next->op_next->op_flags & OPf_STACKED))
7107 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7108 o->op_type = OP_RCATLINE;
7109 o->op_flags |= OPf_STACKED;
7110 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7111 op_null(o->op_next->op_next);
7112 op_null(o->op_next);
7115 o->op_seq = PL_op_seqmax++;
7126 o->op_seq = PL_op_seqmax++;
7127 while (cLOGOP->op_other->op_type == OP_NULL)
7128 cLOGOP->op_other = cLOGOP->op_other->op_next;
7129 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7134 o->op_seq = PL_op_seqmax++;
7135 while (cLOOP->op_redoop->op_type == OP_NULL)
7136 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7137 peep(cLOOP->op_redoop);
7138 while (cLOOP->op_nextop->op_type == OP_NULL)
7139 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7140 peep(cLOOP->op_nextop);
7141 while (cLOOP->op_lastop->op_type == OP_NULL)
7142 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7143 peep(cLOOP->op_lastop);
7149 o->op_seq = PL_op_seqmax++;
7150 while (cPMOP->op_pmreplstart &&
7151 cPMOP->op_pmreplstart->op_type == OP_NULL)
7152 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7153 peep(cPMOP->op_pmreplstart);
7157 o->op_seq = PL_op_seqmax++;
7158 if (ckWARN(WARN_SYNTAX) && o->op_next
7159 && o->op_next->op_type == OP_NEXTSTATE) {
7160 if (o->op_next->op_sibling &&
7161 o->op_next->op_sibling->op_type != OP_EXIT &&
7162 o->op_next->op_sibling->op_type != OP_WARN &&
7163 o->op_next->op_sibling->op_type != OP_DIE) {
7164 line_t oldline = CopLINE(PL_curcop);
7166 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7167 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7168 "Statement unlikely to be reached");
7169 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7170 "\t(Maybe you meant system() when you said exec()?)\n");
7171 CopLINE_set(PL_curcop, oldline);
7180 SV **svp, **indsvp, *sv;
7185 o->op_seq = PL_op_seqmax++;
7187 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7190 /* Make the CONST have a shared SV */
7191 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7192 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7193 key = SvPV(sv, keylen);
7194 lexname = newSVpvn_share(key,
7195 SvUTF8(sv) ? -(I32)keylen : keylen,
7201 if ((o->op_private & (OPpLVAL_INTRO)))
7204 rop = (UNOP*)((BINOP*)o)->op_first;
7205 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7207 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7208 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7210 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7211 if (!fields || !GvHV(*fields))
7213 key = SvPV(*svp, keylen);
7214 indsvp = hv_fetch(GvHV(*fields), key,
7215 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7217 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7218 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7220 ind = SvIV(*indsvp);
7222 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7223 rop->op_type = OP_RV2AV;
7224 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7225 o->op_type = OP_AELEM;
7226 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7228 if (SvREADONLY(*svp))
7230 SvFLAGS(sv) |= (SvFLAGS(*svp)
7231 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7241 SV **svp, **indsvp, *sv;
7245 SVOP *first_key_op, *key_op;
7247 o->op_seq = PL_op_seqmax++;
7248 if ((o->op_private & (OPpLVAL_INTRO))
7249 /* I bet there's always a pushmark... */
7250 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7251 /* hmmm, no optimization if list contains only one key. */
7253 rop = (UNOP*)((LISTOP*)o)->op_last;
7254 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7256 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7257 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7259 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7260 if (!fields || !GvHV(*fields))
7262 /* Again guessing that the pushmark can be jumped over.... */
7263 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7264 ->op_first->op_sibling;
7265 /* Check that the key list contains only constants. */
7266 for (key_op = first_key_op; key_op;
7267 key_op = (SVOP*)key_op->op_sibling)
7268 if (key_op->op_type != OP_CONST)
7272 rop->op_type = OP_RV2AV;
7273 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7274 o->op_type = OP_ASLICE;
7275 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7276 for (key_op = first_key_op; key_op;
7277 key_op = (SVOP*)key_op->op_sibling) {
7278 svp = cSVOPx_svp(key_op);
7279 key = SvPV(*svp, keylen);
7280 indsvp = hv_fetch(GvHV(*fields), key,
7281 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7283 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7284 "in variable %s of type %s",
7285 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7287 ind = SvIV(*indsvp);
7289 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7291 if (SvREADONLY(*svp))
7293 SvFLAGS(sv) |= (SvFLAGS(*svp)
7294 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7302 o->op_seq = PL_op_seqmax++;
7312 char* Perl_custom_op_name(pTHX_ OP* o)
7314 IV index = PTR2IV(o->op_ppaddr);
7318 if (!PL_custom_op_names) /* This probably shouldn't happen */
7319 return PL_op_name[OP_CUSTOM];
7321 keysv = sv_2mortal(newSViv(index));
7323 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7325 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7327 return SvPV_nolen(HeVAL(he));
7330 char* Perl_custom_op_desc(pTHX_ OP* o)
7332 IV index = PTR2IV(o->op_ppaddr);
7336 if (!PL_custom_op_descs)
7337 return PL_op_desc[OP_CUSTOM];
7339 keysv = sv_2mortal(newSViv(index));
7341 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7343 return PL_op_desc[OP_CUSTOM];
7345 return SvPV_nolen(HeVAL(he));
7351 /* Efficient sub that returns a constant scalar value. */
7353 const_sv_xsub(pTHX_ CV* cv)
7358 Perl_croak(aTHX_ "usage: %s::%s()",
7359 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7363 ST(0) = (SV*)XSANY.any_ptr;