3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
47 if ((PL_OpSpace -= sz) < 0) {
48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
63 PL_OpPtr += PERL_SLAB_SIZE;
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
77 S_Slab_Free(pTHX_ void *op)
79 I32 **ptr = (I32 **) op;
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
86 #define PerlMemShared PerlMem
89 PerlMemShared_free(slab);
90 if (slab == PL_OpSlab) {
97 #define NewOp(m, var, c, type) Newz(m, var, c, type)
98 #define FreeOp(p) Safefree(p)
101 * In the following definition, the ", Nullop" is just to make the compiler
102 * think the expression is of the right type: croak actually does a Siglongjmp.
104 #define CHECKOP(type,o) \
105 ((PL_op_mask && PL_op_mask[type]) \
106 ? ( op_free((OP*)o), \
107 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
109 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
111 #define PAD_MAX 999999999
112 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
115 S_gv_ename(pTHX_ GV *gv)
118 SV* tmpsv = sv_newmortal();
119 gv_efullname3(tmpsv, gv, Nullch);
120 return SvPV(tmpsv,n_a);
124 S_no_fh_allowed(pTHX_ OP *o)
126 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
132 S_too_few_arguments(pTHX_ OP *o, char *name)
134 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
139 S_too_many_arguments(pTHX_ OP *o, char *name)
141 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
146 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
148 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
149 (int)n, name, t, OP_DESC(kid)));
153 S_no_bareword_allowed(pTHX_ OP *o)
155 qerror(Perl_mess(aTHX_
156 "Bareword \"%s\" not allowed while \"strict subs\" in use",
157 SvPV_nolen(cSVOPo_sv)));
160 /* "register" allocation */
163 Perl_pad_allocmy(pTHX_ char *name)
168 if (!(PL_in_my == KEY_our ||
170 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
171 (name[1] == '_' && (int)strlen(name) > 2)))
173 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
174 /* 1999-02-27 mjd@plover.com */
176 p = strchr(name, '\0');
177 /* The next block assumes the buffer is at least 205 chars
178 long. At present, it's always at least 256 chars. */
180 strcpy(name+200, "...");
186 /* Move everything else down one character */
187 for (; p-name > 2; p--)
189 name[2] = toCTRL(name[1]);
192 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
194 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
195 SV **svp = AvARRAY(PL_comppad_name);
196 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
197 PADOFFSET top = AvFILLp(PL_comppad_name);
198 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
200 && sv != &PL_sv_undef
201 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
202 && (PL_in_my != KEY_our
203 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
204 && strEQ(name, SvPVX(sv)))
206 Perl_warner(aTHX_ packWARN(WARN_MISC),
207 "\"%s\" variable %s masks earlier declaration in same %s",
208 (PL_in_my == KEY_our ? "our" : "my"),
210 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
215 if (PL_in_my == KEY_our) {
218 && sv != &PL_sv_undef
219 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
220 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
221 && strEQ(name, SvPVX(sv)))
223 Perl_warner(aTHX_ packWARN(WARN_MISC),
224 "\"our\" variable %s redeclared", name);
225 Perl_warner(aTHX_ packWARN(WARN_MISC),
226 "\t(Did you mean \"local\" instead of \"our\"?)\n");
229 } while ( off-- > 0 );
232 off = pad_alloc(OP_PADSV, SVs_PADMY);
234 sv_upgrade(sv, SVt_PVNV);
236 if (PL_in_my_stash) {
238 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
239 name, PL_in_my == KEY_our ? "our" : "my"));
240 SvFLAGS(sv) |= SVpad_TYPED;
241 (void)SvUPGRADE(sv, SVt_PVMG);
242 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
244 if (PL_in_my == KEY_our) {
245 (void)SvUPGRADE(sv, SVt_PVGV);
246 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
247 SvFLAGS(sv) |= SVpad_OUR;
249 av_store(PL_comppad_name, off, sv);
250 SvNVX(sv) = (NV)PAD_MAX;
251 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
252 if (!PL_min_intro_pending)
253 PL_min_intro_pending = off;
254 PL_max_intro_pending = off;
256 av_store(PL_comppad, off, (SV*)newAV());
257 else if (*name == '%')
258 av_store(PL_comppad, off, (SV*)newHV());
259 SvPADMY_on(PL_curpad[off]);
264 S_pad_addlex(pTHX_ SV *proto_namesv)
266 SV *namesv = NEWSV(1103,0);
267 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
268 sv_upgrade(namesv, SVt_PVNV);
269 sv_setpv(namesv, SvPVX(proto_namesv));
270 av_store(PL_comppad_name, newoff, namesv);
271 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
272 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
273 SvFAKE_on(namesv); /* A ref, not a real var */
274 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
275 SvFLAGS(namesv) |= SVpad_OUR;
276 (void)SvUPGRADE(namesv, SVt_PVGV);
277 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
279 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
280 SvFLAGS(namesv) |= SVpad_TYPED;
281 (void)SvUPGRADE(namesv, SVt_PVMG);
282 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
287 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
290 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
291 I32 cx_ix, I32 saweval, U32 flags)
297 register PERL_CONTEXT *cx;
299 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
300 AV *curlist = CvPADLIST(cv);
301 SV **svp = av_fetch(curlist, 0, FALSE);
304 if (!svp || *svp == &PL_sv_undef)
307 svp = AvARRAY(curname);
308 for (off = AvFILLp(curname); off > 0; off--) {
309 if ((sv = svp[off]) &&
310 sv != &PL_sv_undef &&
311 seq <= (U32)SvIVX(sv) &&
312 seq > (U32)I_32(SvNVX(sv)) &&
313 strEQ(SvPVX(sv), name))
324 return 0; /* don't clone from inactive stack frame */
328 oldpad = (AV*)AvARRAY(curlist)[depth];
329 oldsv = *av_fetch(oldpad, off, TRUE);
330 if (!newoff) { /* Not a mere clone operation. */
331 newoff = pad_addlex(sv);
332 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
333 /* "It's closures all the way down." */
334 CvCLONE_on(PL_compcv);
336 if (CvANON(PL_compcv))
337 oldsv = Nullsv; /* no need to keep ref */
342 bcv && bcv != cv && !CvCLONE(bcv);
343 bcv = CvOUTSIDE(bcv))
346 /* install the missing pad entry in intervening
347 * nested subs and mark them cloneable.
348 * XXX fix pad_foo() to not use globals */
349 AV *ocomppad_name = PL_comppad_name;
350 AV *ocomppad = PL_comppad;
351 SV **ocurpad = PL_curpad;
352 AV *padlist = CvPADLIST(bcv);
353 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
354 PL_comppad = (AV*)AvARRAY(padlist)[1];
355 PL_curpad = AvARRAY(PL_comppad);
357 PL_comppad_name = ocomppad_name;
358 PL_comppad = ocomppad;
363 if (ckWARN(WARN_CLOSURE)
364 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
366 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
367 "Variable \"%s\" may be unavailable",
375 else if (!CvUNIQUE(PL_compcv)) {
376 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
377 && !(SvFLAGS(sv) & SVpad_OUR))
379 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
380 "Variable \"%s\" will not stay shared", name);
384 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
390 if (flags & FINDLEX_NOSEARCH)
393 /* Nothing in current lexical context--try eval's context, if any.
394 * This is necessary to let the perldb get at lexically scoped variables.
395 * XXX This will also probably interact badly with eval tree caching.
398 for (i = cx_ix; i >= 0; i--) {
400 switch (CxTYPE(cx)) {
402 if (i == 0 && saweval) {
403 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
407 switch (cx->blk_eval.old_op_type) {
409 if (CxREALEVAL(cx)) {
412 seq = cxstack[i].blk_oldcop->cop_seq;
413 startcv = cxstack[i].blk_eval.cv;
414 if (startcv && CvOUTSIDE(startcv)) {
415 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
417 if (off) /* continue looking if not found here */
424 /* require/do must have their own scope */
433 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
434 saweval = i; /* so we know where we were called from */
435 seq = cxstack[i].blk_oldcop->cop_seq;
438 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
446 Perl_pad_findmy(pTHX_ char *name)
451 SV **svp = AvARRAY(PL_comppad_name);
452 U32 seq = PL_cop_seqmax;
456 #ifdef USE_5005THREADS
458 * Special case to get lexical (and hence per-thread) @_.
459 * XXX I need to find out how to tell at parse-time whether use
460 * of @_ should refer to a lexical (from a sub) or defgv (global
461 * scope and maybe weird sub-ish things like formats). See
462 * startsub in perly.y. It's possible that @_ could be lexical
463 * (at least from subs) even in non-threaded perl.
465 if (strEQ(name, "@_"))
466 return 0; /* success. (NOT_IN_PAD indicates failure) */
467 #endif /* USE_5005THREADS */
469 /* The one we're looking for is probably just before comppad_name_fill. */
470 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
471 if ((sv = svp[off]) &&
472 sv != &PL_sv_undef &&
474 (seq <= (U32)SvIVX(sv) &&
475 seq > (U32)I_32(SvNVX(sv)))) &&
476 strEQ(SvPVX(sv), name))
478 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
479 return (PADOFFSET)off;
480 pendoff = off; /* this pending def. will override import */
484 outside = CvOUTSIDE(PL_compcv);
486 /* Check if if we're compiling an eval'', and adjust seq to be the
487 * eval's seq number. This depends on eval'' having a non-null
488 * CvOUTSIDE() while it is being compiled. The eval'' itself is
489 * identified by CvEVAL being true and CvGV being null. */
490 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
491 cx = &cxstack[cxstack_ix];
493 seq = cx->blk_oldcop->cop_seq;
496 /* See if it's in a nested scope */
497 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
499 /* If there is a pending local definition, this new alias must die */
501 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
502 return off; /* pad_findlex returns 0 for failure...*/
504 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
508 Perl_pad_leavemy(pTHX_ I32 fill)
511 SV **svp = AvARRAY(PL_comppad_name);
513 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
514 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
515 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
516 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "%s never introduced", SvPVX(sv));
519 /* "Deintroduce" my variables that are leaving with this scope. */
520 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
521 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
522 SvIVX(sv) = PL_cop_seqmax;
527 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
532 if (AvARRAY(PL_comppad) != PL_curpad)
533 Perl_croak(aTHX_ "panic: pad_alloc");
534 if (PL_pad_reset_pending)
536 if (tmptype & SVs_PADMY) {
538 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
539 } while (SvPADBUSY(sv)); /* need a fresh one */
540 retval = AvFILLp(PL_comppad);
543 SV **names = AvARRAY(PL_comppad_name);
544 SSize_t names_fill = AvFILLp(PL_comppad_name);
547 * "foreach" index vars temporarily become aliases to non-"my"
548 * values. Thus we must skip, not just pad values that are
549 * marked as current pad values, but also those with names.
551 if (++PL_padix <= names_fill &&
552 (sv = names[PL_padix]) && sv != &PL_sv_undef)
554 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
555 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
556 !IS_PADGV(sv) && !IS_PADCONST(sv))
561 SvFLAGS(sv) |= tmptype;
562 PL_curpad = AvARRAY(PL_comppad);
563 #ifdef USE_5005THREADS
564 DEBUG_X(PerlIO_printf(Perl_debug_log,
565 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
566 PTR2UV(thr), PTR2UV(PL_curpad),
567 (long) retval, PL_op_name[optype]));
569 DEBUG_X(PerlIO_printf(Perl_debug_log,
570 "Pad 0x%"UVxf" alloc %ld for %s\n",
572 (long) retval, PL_op_name[optype]));
573 #endif /* USE_5005THREADS */
574 return (PADOFFSET)retval;
578 Perl_pad_sv(pTHX_ PADOFFSET po)
580 #ifdef USE_5005THREADS
581 DEBUG_X(PerlIO_printf(Perl_debug_log,
582 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
583 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
586 Perl_croak(aTHX_ "panic: pad_sv po");
587 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
588 PTR2UV(PL_curpad), (IV)po));
589 #endif /* USE_5005THREADS */
590 return PL_curpad[po]; /* eventually we'll turn this into a macro */
594 Perl_pad_free(pTHX_ PADOFFSET po)
598 if (AvARRAY(PL_comppad) != PL_curpad)
599 Perl_croak(aTHX_ "panic: pad_free curpad");
601 Perl_croak(aTHX_ "panic: pad_free po");
602 #ifdef USE_5005THREADS
603 DEBUG_X(PerlIO_printf(Perl_debug_log,
604 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
605 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
607 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
608 PTR2UV(PL_curpad), (IV)po));
609 #endif /* USE_5005THREADS */
610 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
611 SvPADTMP_off(PL_curpad[po]);
613 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
616 if ((I32)po < PL_padix)
621 Perl_pad_swipe(pTHX_ PADOFFSET po)
623 if (AvARRAY(PL_comppad) != PL_curpad)
624 Perl_croak(aTHX_ "panic: pad_swipe curpad");
626 Perl_croak(aTHX_ "panic: pad_swipe po");
627 #ifdef USE_5005THREADS
628 DEBUG_X(PerlIO_printf(Perl_debug_log,
629 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
630 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
632 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
633 PTR2UV(PL_curpad), (IV)po));
634 #endif /* USE_5005THREADS */
635 SvPADTMP_off(PL_curpad[po]);
636 PL_curpad[po] = NEWSV(1107,0);
637 SvPADTMP_on(PL_curpad[po]);
638 if ((I32)po < PL_padix)
642 /* XXX pad_reset() is currently disabled because it results in serious bugs.
643 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
644 * on the stack by OPs that use them, there are several ways to get an alias
645 * to a shared TARG. Such an alias will change randomly and unpredictably.
646 * We avoid doing this until we can think of a Better Way.
651 #ifdef USE_BROKEN_PAD_RESET
654 if (AvARRAY(PL_comppad) != PL_curpad)
655 Perl_croak(aTHX_ "panic: pad_reset curpad");
656 #ifdef USE_5005THREADS
657 DEBUG_X(PerlIO_printf(Perl_debug_log,
658 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
659 PTR2UV(thr), PTR2UV(PL_curpad)));
661 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
663 #endif /* USE_5005THREADS */
664 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
665 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
666 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
667 SvPADTMP_off(PL_curpad[po]);
669 PL_padix = PL_padix_floor;
672 PL_pad_reset_pending = FALSE;
675 #ifdef USE_5005THREADS
676 /* find_threadsv is not reentrant */
678 Perl_find_threadsv(pTHX_ const char *name)
683 /* We currently only handle names of a single character */
684 p = strchr(PL_threadsv_names, *name);
687 key = p - PL_threadsv_names;
688 MUTEX_LOCK(&thr->mutex);
689 svp = av_fetch(thr->threadsv, key, FALSE);
691 MUTEX_UNLOCK(&thr->mutex);
693 SV *sv = NEWSV(0, 0);
694 av_store(thr->threadsv, key, sv);
695 thr->threadsvp = AvARRAY(thr->threadsv);
696 MUTEX_UNLOCK(&thr->mutex);
698 * Some magic variables used to be automagically initialised
699 * in gv_fetchpv. Those which are now per-thread magicals get
700 * initialised here instead.
706 sv_setpv(sv, "\034");
707 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
712 PL_sawampersand = TRUE;
726 /* XXX %! tied to Errno.pm needs to be added here.
727 * See gv_fetchpv(). */
731 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
733 DEBUG_S(PerlIO_printf(Perl_error_log,
734 "find_threadsv: new SV %p for $%s%c\n",
735 sv, (*name < 32) ? "^" : "",
736 (*name < 32) ? toCTRL(*name) : *name));
740 #endif /* USE_5005THREADS */
745 Perl_op_free(pTHX_ OP *o)
747 register OP *kid, *nextkid;
750 if (!o || o->op_seq == (U16)-1)
753 if (o->op_private & OPpREFCOUNTED) {
754 switch (o->op_type) {
762 if (OpREFCNT_dec(o)) {
773 if (o->op_flags & OPf_KIDS) {
774 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
775 nextkid = kid->op_sibling; /* Get before next freeing kid */
781 type = (OPCODE)o->op_targ;
783 /* COP* is not cleared by op_clear() so that we may track line
784 * numbers etc even after null() */
785 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
793 Perl_op_clear(pTHX_ OP *o)
796 switch (o->op_type) {
797 case OP_NULL: /* Was holding old type, if any. */
798 case OP_ENTEREVAL: /* Was holding hints. */
799 #ifdef USE_5005THREADS
800 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
804 #ifdef USE_5005THREADS
806 if (!(o->op_flags & OPf_SPECIAL))
809 #endif /* USE_5005THREADS */
811 if (!(o->op_flags & OPf_REF)
812 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
819 if (cPADOPo->op_padix > 0) {
822 pad_swipe(cPADOPo->op_padix);
823 /* No GvIN_PAD_off(gv) here, because other references may still
824 * exist on the pad */
827 cPADOPo->op_padix = 0;
830 SvREFCNT_dec(cSVOPo->op_sv);
831 cSVOPo->op_sv = Nullsv;
834 case OP_METHOD_NAMED:
836 SvREFCNT_dec(cSVOPo->op_sv);
837 cSVOPo->op_sv = Nullsv;
843 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
847 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
848 SvREFCNT_dec(cSVOPo->op_sv);
849 cSVOPo->op_sv = Nullsv;
852 Safefree(cPVOPo->op_pv);
853 cPVOPo->op_pv = Nullch;
857 op_free(cPMOPo->op_pmreplroot);
861 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
863 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
864 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
865 /* No GvIN_PAD_off(gv) here, because other references may still
866 * exist on the pad */
871 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
878 HV *pmstash = PmopSTASH(cPMOPo);
879 if (pmstash && SvREFCNT(pmstash)) {
880 PMOP *pmop = HvPMROOT(pmstash);
881 PMOP *lastpmop = NULL;
883 if (cPMOPo == pmop) {
885 lastpmop->op_pmnext = pmop->op_pmnext;
887 HvPMROOT(pmstash) = pmop->op_pmnext;
891 pmop = pmop->op_pmnext;
894 PmopSTASH_free(cPMOPo);
896 cPMOPo->op_pmreplroot = Nullop;
897 /* we use the "SAFE" version of the PM_ macros here
898 * since sv_clean_all might release some PMOPs
899 * after PL_regex_padav has been cleared
900 * and the clearing of PL_regex_padav needs to
901 * happen before sv_clean_all
903 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
904 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
906 if(PL_regex_pad) { /* We could be in destruction */
907 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
908 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
909 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
916 if (o->op_targ > 0) {
917 pad_free(o->op_targ);
923 S_cop_free(pTHX_ COP* cop)
925 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
928 if (! specialWARN(cop->cop_warnings))
929 SvREFCNT_dec(cop->cop_warnings);
930 if (! specialCopIO(cop->cop_io)) {
934 char *s = SvPV(cop->cop_io,len);
935 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
938 SvREFCNT_dec(cop->cop_io);
944 Perl_op_null(pTHX_ OP *o)
946 if (o->op_type == OP_NULL)
949 o->op_targ = o->op_type;
950 o->op_type = OP_NULL;
951 o->op_ppaddr = PL_ppaddr[OP_NULL];
954 /* Contextualizers */
956 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
959 Perl_linklist(pTHX_ OP *o)
966 /* establish postfix order */
967 if (cUNOPo->op_first) {
968 o->op_next = LINKLIST(cUNOPo->op_first);
969 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
971 kid->op_next = LINKLIST(kid->op_sibling);
983 Perl_scalarkids(pTHX_ OP *o)
986 if (o && o->op_flags & OPf_KIDS) {
987 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
994 S_scalarboolean(pTHX_ OP *o)
996 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
997 if (ckWARN(WARN_SYNTAX)) {
998 line_t oldline = CopLINE(PL_curcop);
1000 if (PL_copline != NOLINE)
1001 CopLINE_set(PL_curcop, PL_copline);
1002 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1003 CopLINE_set(PL_curcop, oldline);
1010 Perl_scalar(pTHX_ OP *o)
1014 /* assumes no premature commitment */
1015 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1016 || o->op_type == OP_RETURN)
1021 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1023 switch (o->op_type) {
1025 scalar(cBINOPo->op_first);
1030 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1034 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1035 if (!kPMOP->op_pmreplroot)
1036 deprecate_old("implicit split to @_");
1044 if (o->op_flags & OPf_KIDS) {
1045 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1051 kid = cLISTOPo->op_first;
1053 while ((kid = kid->op_sibling)) {
1054 if (kid->op_sibling)
1059 WITH_THR(PL_curcop = &PL_compiling);
1064 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1065 if (kid->op_sibling)
1070 WITH_THR(PL_curcop = &PL_compiling);
1073 if (ckWARN(WARN_VOID))
1074 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1080 Perl_scalarvoid(pTHX_ OP *o)
1087 if (o->op_type == OP_NEXTSTATE
1088 || o->op_type == OP_SETSTATE
1089 || o->op_type == OP_DBSTATE
1090 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1091 || o->op_targ == OP_SETSTATE
1092 || o->op_targ == OP_DBSTATE)))
1093 PL_curcop = (COP*)o; /* for warning below */
1095 /* assumes no premature commitment */
1096 want = o->op_flags & OPf_WANT;
1097 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1098 || o->op_type == OP_RETURN)
1103 if ((o->op_private & OPpTARGET_MY)
1104 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1106 return scalar(o); /* As if inside SASSIGN */
1109 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1111 switch (o->op_type) {
1113 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1117 if (o->op_flags & OPf_STACKED)
1121 if (o->op_private == 4)
1163 case OP_GETSOCKNAME:
1164 case OP_GETPEERNAME:
1169 case OP_GETPRIORITY:
1192 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1193 useless = OP_DESC(o);
1200 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1201 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1202 useless = "a variable";
1207 if (cSVOPo->op_private & OPpCONST_STRICT)
1208 no_bareword_allowed(o);
1210 if (ckWARN(WARN_VOID)) {
1211 useless = "a constant";
1212 /* the constants 0 and 1 are permitted as they are
1213 conventionally used as dummies in constructs like
1214 1 while some_condition_with_side_effects; */
1215 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1217 else if (SvPOK(sv)) {
1218 /* perl4's way of mixing documentation and code
1219 (before the invention of POD) was based on a
1220 trick to mix nroff and perl code. The trick was
1221 built upon these three nroff macros being used in
1222 void context. The pink camel has the details in
1223 the script wrapman near page 319. */
1224 if (strnEQ(SvPVX(sv), "di", 2) ||
1225 strnEQ(SvPVX(sv), "ds", 2) ||
1226 strnEQ(SvPVX(sv), "ig", 2))
1231 op_null(o); /* don't execute or even remember it */
1235 o->op_type = OP_PREINC; /* pre-increment is faster */
1236 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1240 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1241 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
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 = (U8)(PL_hints & HINT_PRIVATE_MASK);
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);
2550 o->op_type = (OPCODE)type;
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 = (OPCODE)type;
2668 listop->op_ppaddr = PL_ppaddr[type];
2671 listop->op_flags = (U8)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);
2699 o->op_type = (OPCODE)type;
2700 o->op_ppaddr = PL_ppaddr[type];
2701 o->op_flags = (U8)flags;
2704 o->op_private = (U8)(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 = (OPCODE)type;
2724 unop->op_ppaddr = PL_ppaddr[type];
2725 unop->op_first = first;
2726 unop->op_flags = flags | OPf_KIDS;
2727 unop->op_private = (U8)(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 = (OPCODE)type;
2745 binop->op_ppaddr = PL_ppaddr[type];
2746 binop->op_first = first;
2747 binop->op_flags = flags | OPf_KIDS;
2750 binop->op_private = (U8)(1 | (flags >> 8));
2753 binop->op_private = (U8)(2 | (flags >> 8));
2754 first->op_sibling = last;
2757 binop = (BINOP*)CHECKOP(type, binop);
2758 if (binop->op_next || binop->op_type != (OPCODE)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 < (I32)tlen; i++)
3020 for (i = 0, j = 0; i < 256; i++) {
3022 if (j >= (I32)rlen) {
3031 if (i < 128 && r[j] >= 128)
3041 o->op_private |= OPpTRANS_IDENTICAL;
3043 else if (j >= (I32)rlen)
3046 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3047 tbl[0x100] = rlen - j;
3048 for (i=0; i < (I32)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 < (I32)tlen; i++,j++) {
3064 if (j >= (I32)rlen) {
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 = (OPCODE)type;
3094 pmop->op_ppaddr = PL_ppaddr[type];
3095 pmop->op_flags = (U8)flags;
3096 pmop->op_private = (U8)(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, (line_t)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 = (OPCODE)type;
3288 svop->op_ppaddr = PL_ppaddr[type];
3290 svop->op_next = (OP*)svop;
3291 svop->op_flags = (U8)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 = (OPCODE)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 = (U8)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 = (OPCODE)type;
3336 pvop->op_ppaddr = PL_ppaddr[type];
3338 pvop->op_next = (OP*)pvop;
3339 pvop->op_flags = (U8)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)
3380 if (id->op_type != OP_CONST)
3381 Perl_croak(aTHX_ "Module name must be constant");
3385 if (version != Nullop) {
3386 SV *vesv = ((SVOP*)version)->op_sv;
3388 if (arg == Nullop && !SvNIOKp(vesv)) {
3395 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3396 Perl_croak(aTHX_ "Version number must be constant number");
3398 /* Make copy of id so we don't free it twice */
3399 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3401 /* Fake up a method call to VERSION */
3402 meth = newSVpvn("VERSION",7);
3403 sv_upgrade(meth, SVt_PVIV);
3404 (void)SvIOK_on(meth);
3405 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3406 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3407 append_elem(OP_LIST,
3408 prepend_elem(OP_LIST, pack, list(version)),
3409 newSVOP(OP_METHOD_NAMED, 0, meth)));
3413 /* Fake up an import/unimport */
3414 if (arg && arg->op_type == OP_STUB)
3415 imop = arg; /* no import on explicit () */
3416 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3417 imop = Nullop; /* use 5.0; */
3422 /* Make copy of id so we don't free it twice */
3423 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3425 /* Fake up a method call to import/unimport */
3426 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3427 (void)SvUPGRADE(meth, SVt_PVIV);
3428 (void)SvIOK_on(meth);
3429 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3430 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3431 append_elem(OP_LIST,
3432 prepend_elem(OP_LIST, pack, list(arg)),
3433 newSVOP(OP_METHOD_NAMED, 0, meth)));
3436 /* Fake up the BEGIN {}, which does its thing immediately. */
3438 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3441 append_elem(OP_LINESEQ,
3442 append_elem(OP_LINESEQ,
3443 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3444 newSTATEOP(0, Nullch, veop)),
3445 newSTATEOP(0, Nullch, imop) ));
3447 /* The "did you use incorrect case?" warning used to be here.
3448 * The problem is that on case-insensitive filesystems one
3449 * might get false positives for "use" (and "require"):
3450 * "use Strict" or "require CARP" will work. This causes
3451 * portability problems for the script: in case-strict
3452 * filesystems the script will stop working.
3454 * The "incorrect case" warning checked whether "use Foo"
3455 * imported "Foo" to your namespace, but that is wrong, too:
3456 * there is no requirement nor promise in the language that
3457 * a Foo.pm should or would contain anything in package "Foo".
3459 * There is very little Configure-wise that can be done, either:
3460 * the case-sensitivity of the build filesystem of Perl does not
3461 * help in guessing the case-sensitivity of the runtime environment.
3464 PL_hints |= HINT_BLOCK_SCOPE;
3465 PL_copline = NOLINE;
3470 =head1 Embedding Functions
3472 =for apidoc load_module
3474 Loads the module whose name is pointed to by the string part of name.
3475 Note that the actual module name, not its filename, should be given.
3476 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3477 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3478 (or 0 for no flags). ver, if specified, provides version semantics
3479 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3480 arguments can be used to specify arguments to the module's import()
3481 method, similar to C<use Foo::Bar VERSION LIST>.
3486 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3489 va_start(args, ver);
3490 vload_module(flags, name, ver, &args);
3494 #ifdef PERL_IMPLICIT_CONTEXT
3496 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3500 va_start(args, ver);
3501 vload_module(flags, name, ver, &args);
3507 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3509 OP *modname, *veop, *imop;
3511 modname = newSVOP(OP_CONST, 0, name);
3512 modname->op_private |= OPpCONST_BARE;
3514 veop = newSVOP(OP_CONST, 0, ver);
3518 if (flags & PERL_LOADMOD_NOIMPORT) {
3519 imop = sawparens(newNULLLIST());
3521 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3522 imop = va_arg(*args, OP*);
3527 sv = va_arg(*args, SV*);
3529 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3530 sv = va_arg(*args, SV*);
3534 line_t ocopline = PL_copline;
3535 int oexpect = PL_expect;
3537 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3538 veop, modname, imop);
3539 PL_expect = oexpect;
3540 PL_copline = ocopline;
3545 Perl_dofile(pTHX_ OP *term)
3550 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3551 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3552 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3554 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3555 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3556 append_elem(OP_LIST, term,
3557 scalar(newUNOP(OP_RV2CV, 0,
3562 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3568 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3570 return newBINOP(OP_LSLICE, flags,
3571 list(force_list(subscript)),
3572 list(force_list(listval)) );
3576 S_list_assignment(pTHX_ register OP *o)
3581 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3582 o = cUNOPo->op_first;
3584 if (o->op_type == OP_COND_EXPR) {
3585 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3586 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3591 yyerror("Assignment to both a list and a scalar");
3595 if (o->op_type == OP_LIST &&
3596 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3597 o->op_private & OPpLVAL_INTRO)
3600 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3601 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3602 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3605 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3608 if (o->op_type == OP_RV2SV)
3615 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3620 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3621 return newLOGOP(optype, 0,
3622 mod(scalar(left), optype),
3623 newUNOP(OP_SASSIGN, 0, scalar(right)));
3626 return newBINOP(optype, OPf_STACKED,
3627 mod(scalar(left), optype), scalar(right));
3631 if (list_assignment(left)) {
3635 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3636 left = mod(left, OP_AASSIGN);
3644 curop = list(force_list(left));
3645 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3646 o->op_private = (U8)(0 | (flags >> 8));
3647 for (curop = ((LISTOP*)curop)->op_first;
3648 curop; curop = curop->op_sibling)
3650 if (curop->op_type == OP_RV2HV &&
3651 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3652 o->op_private |= OPpASSIGN_HASH;
3656 if (!(left->op_private & OPpLVAL_INTRO)) {
3659 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3660 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3661 if (curop->op_type == OP_GV) {
3662 GV *gv = cGVOPx_gv(curop);
3663 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3665 SvCUR(gv) = PL_generation;
3667 else if (curop->op_type == OP_PADSV ||
3668 curop->op_type == OP_PADAV ||
3669 curop->op_type == OP_PADHV ||
3670 curop->op_type == OP_PADANY) {
3671 SV **svp = AvARRAY(PL_comppad_name);
3672 SV *sv = svp[curop->op_targ];
3673 if ((int)SvCUR(sv) == PL_generation)
3675 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3677 else if (curop->op_type == OP_RV2CV)
3679 else if (curop->op_type == OP_RV2SV ||
3680 curop->op_type == OP_RV2AV ||
3681 curop->op_type == OP_RV2HV ||
3682 curop->op_type == OP_RV2GV) {
3683 if (lastop->op_type != OP_GV) /* funny deref? */
3686 else if (curop->op_type == OP_PUSHRE) {
3687 if (((PMOP*)curop)->op_pmreplroot) {
3689 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3691 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3693 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3695 SvCUR(gv) = PL_generation;
3704 o->op_private |= OPpASSIGN_COMMON;
3706 if (right && right->op_type == OP_SPLIT) {
3708 if ((tmpop = ((LISTOP*)right)->op_first) &&
3709 tmpop->op_type == OP_PUSHRE)
3711 PMOP *pm = (PMOP*)tmpop;
3712 if (left->op_type == OP_RV2AV &&
3713 !(left->op_private & OPpLVAL_INTRO) &&
3714 !(o->op_private & OPpASSIGN_COMMON) )
3716 tmpop = ((UNOP*)left)->op_first;
3717 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3719 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3720 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3722 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3723 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3725 pm->op_pmflags |= PMf_ONCE;
3726 tmpop = cUNOPo->op_first; /* to list (nulled) */
3727 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3728 tmpop->op_sibling = Nullop; /* don't free split */
3729 right->op_next = tmpop->op_next; /* fix starting loc */
3730 op_free(o); /* blow off assign */
3731 right->op_flags &= ~OPf_WANT;
3732 /* "I don't know and I don't care." */
3737 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3738 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3740 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3742 sv_setiv(sv, PL_modcount+1);
3750 right = newOP(OP_UNDEF, 0);
3751 if (right->op_type == OP_READLINE) {
3752 right->op_flags |= OPf_STACKED;
3753 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3756 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3757 o = newBINOP(OP_SASSIGN, flags,
3758 scalar(right), mod(scalar(left), OP_SASSIGN) );
3770 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3772 U32 seq = intro_my();
3775 NewOp(1101, cop, 1, COP);
3776 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3777 cop->op_type = OP_DBSTATE;
3778 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3781 cop->op_type = OP_NEXTSTATE;
3782 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3784 cop->op_flags = (U8)flags;
3785 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3787 cop->op_private |= NATIVE_HINTS;
3789 PL_compiling.op_private = cop->op_private;
3790 cop->op_next = (OP*)cop;
3793 cop->cop_label = label;
3794 PL_hints |= HINT_BLOCK_SCOPE;
3797 cop->cop_arybase = PL_curcop->cop_arybase;
3798 if (specialWARN(PL_curcop->cop_warnings))
3799 cop->cop_warnings = PL_curcop->cop_warnings ;
3801 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3802 if (specialCopIO(PL_curcop->cop_io))
3803 cop->cop_io = PL_curcop->cop_io;
3805 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3808 if (PL_copline == NOLINE)
3809 CopLINE_set(cop, CopLINE(PL_curcop));
3811 CopLINE_set(cop, PL_copline);
3812 PL_copline = NOLINE;
3815 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3817 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3819 CopSTASH_set(cop, PL_curstash);
3821 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3822 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3823 if (svp && *svp != &PL_sv_undef ) {
3824 (void)SvIOK_on(*svp);
3825 SvIVX(*svp) = PTR2IV(cop);
3829 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3832 /* "Introduce" my variables to visible status. */
3840 if (! PL_min_intro_pending)
3841 return PL_cop_seqmax;
3843 svp = AvARRAY(PL_comppad_name);
3844 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3845 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3846 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3847 SvNVX(sv) = (NV)PL_cop_seqmax;
3850 PL_min_intro_pending = 0;
3851 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3852 return PL_cop_seqmax++;
3856 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3858 return new_logop(type, flags, &first, &other);
3862 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3866 OP *first = *firstp;
3867 OP *other = *otherp;
3869 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3870 return newBINOP(type, flags, scalar(first), scalar(other));
3872 scalarboolean(first);
3873 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3874 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3875 if (type == OP_AND || type == OP_OR) {
3881 first = *firstp = cUNOPo->op_first;
3883 first->op_next = o->op_next;
3884 cUNOPo->op_first = Nullop;
3888 if (first->op_type == OP_CONST) {
3889 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3890 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3891 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3902 else if (first->op_type == OP_WANTARRAY) {
3903 /* XXX true only if this result will be returned, else should
3904 propagate outer context */
3910 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3911 OP *k1 = ((UNOP*)first)->op_first;
3912 OP *k2 = k1->op_sibling;
3914 switch (first->op_type)
3917 if (k2 && k2->op_type == OP_READLINE
3918 && (k2->op_flags & OPf_STACKED)
3919 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3921 warnop = k2->op_type;
3926 if (k1->op_type == OP_READDIR
3927 || k1->op_type == OP_GLOB
3928 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3929 || k1->op_type == OP_EACH)
3931 warnop = ((k1->op_type == OP_NULL)
3932 ? (OPCODE)k1->op_targ : k1->op_type);
3937 line_t oldline = CopLINE(PL_curcop);
3938 CopLINE_set(PL_curcop, PL_copline);
3939 Perl_warner(aTHX_ packWARN(WARN_MISC),
3940 "Value of %s%s can be \"0\"; test with defined()",
3942 ((warnop == OP_READLINE || warnop == OP_GLOB)
3943 ? " construct" : "() operator"));
3944 CopLINE_set(PL_curcop, oldline);
3951 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3952 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3954 NewOp(1101, logop, 1, LOGOP);
3956 logop->op_type = (OPCODE)type;
3957 logop->op_ppaddr = PL_ppaddr[type];
3958 logop->op_first = first;
3959 logop->op_flags = flags | OPf_KIDS;
3960 logop->op_other = LINKLIST(other);
3961 logop->op_private = (U8)(1 | (flags >> 8));
3963 /* establish postfix order */
3964 logop->op_next = LINKLIST(first);
3965 first->op_next = (OP*)logop;
3966 first->op_sibling = other;
3968 o = newUNOP(OP_NULL, 0, (OP*)logop);
3975 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3982 return newLOGOP(OP_AND, 0, first, trueop);
3984 return newLOGOP(OP_OR, 0, first, falseop);
3986 scalarboolean(first);
3987 if (first->op_type == OP_CONST) {
3988 if (SvTRUE(((SVOP*)first)->op_sv)) {
3999 else if (first->op_type == OP_WANTARRAY) {
4000 /* XXX true only if this result will be returned, else should
4001 propagate outer context */
4005 NewOp(1101, logop, 1, LOGOP);
4006 logop->op_type = OP_COND_EXPR;
4007 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4008 logop->op_first = first;
4009 logop->op_flags = flags | OPf_KIDS;
4010 logop->op_private = (U8)(1 | (flags >> 8));
4011 logop->op_other = LINKLIST(trueop);
4012 logop->op_next = LINKLIST(falseop);
4015 /* establish postfix order */
4016 start = LINKLIST(first);
4017 first->op_next = (OP*)logop;
4019 first->op_sibling = trueop;
4020 trueop->op_sibling = falseop;
4021 o = newUNOP(OP_NULL, 0, (OP*)logop);
4023 trueop->op_next = falseop->op_next = o;
4030 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4038 NewOp(1101, range, 1, LOGOP);
4040 range->op_type = OP_RANGE;
4041 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4042 range->op_first = left;
4043 range->op_flags = OPf_KIDS;
4044 leftstart = LINKLIST(left);
4045 range->op_other = LINKLIST(right);
4046 range->op_private = (U8)(1 | (flags >> 8));
4048 left->op_sibling = right;
4050 range->op_next = (OP*)range;
4051 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4052 flop = newUNOP(OP_FLOP, 0, flip);
4053 o = newUNOP(OP_NULL, 0, flop);
4055 range->op_next = leftstart;
4057 left->op_next = flip;
4058 right->op_next = flop;
4060 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4061 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4062 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4063 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4065 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4066 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4069 if (!flip->op_private || !flop->op_private)
4070 linklist(o); /* blow off optimizer unless constant */
4076 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4080 int once = block && block->op_flags & OPf_SPECIAL &&
4081 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4084 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4085 return block; /* do {} while 0 does once */
4086 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4087 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4088 expr = newUNOP(OP_DEFINED, 0,
4089 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4090 } else if (expr->op_flags & OPf_KIDS) {
4091 OP *k1 = ((UNOP*)expr)->op_first;
4092 OP *k2 = (k1) ? k1->op_sibling : NULL;
4093 switch (expr->op_type) {
4095 if (k2 && k2->op_type == OP_READLINE
4096 && (k2->op_flags & OPf_STACKED)
4097 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4098 expr = newUNOP(OP_DEFINED, 0, expr);
4102 if (k1->op_type == OP_READDIR
4103 || k1->op_type == OP_GLOB
4104 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4105 || k1->op_type == OP_EACH)
4106 expr = newUNOP(OP_DEFINED, 0, expr);
4112 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4113 o = new_logop(OP_AND, 0, &expr, &listop);
4116 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4118 if (once && o != listop)
4119 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4122 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4124 o->op_flags |= flags;
4126 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4131 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4139 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4140 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4141 expr = newUNOP(OP_DEFINED, 0,
4142 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4143 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4144 OP *k1 = ((UNOP*)expr)->op_first;
4145 OP *k2 = (k1) ? k1->op_sibling : NULL;
4146 switch (expr->op_type) {
4148 if (k2 && k2->op_type == OP_READLINE
4149 && (k2->op_flags & OPf_STACKED)
4150 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4151 expr = newUNOP(OP_DEFINED, 0, expr);
4155 if (k1->op_type == OP_READDIR
4156 || k1->op_type == OP_GLOB
4157 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4158 || k1->op_type == OP_EACH)
4159 expr = newUNOP(OP_DEFINED, 0, expr);
4165 block = newOP(OP_NULL, 0);
4167 block = scope(block);
4171 next = LINKLIST(cont);
4174 OP *unstack = newOP(OP_UNSTACK, 0);
4177 cont = append_elem(OP_LINESEQ, cont, unstack);
4178 if ((line_t)whileline != NOLINE) {
4179 PL_copline = (line_t)whileline;
4180 cont = append_elem(OP_LINESEQ, cont,
4181 newSTATEOP(0, Nullch, Nullop));
4185 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4186 redo = LINKLIST(listop);
4189 PL_copline = (line_t)whileline;
4191 o = new_logop(OP_AND, 0, &expr, &listop);
4192 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4193 op_free(expr); /* oops, it's a while (0) */
4195 return Nullop; /* listop already freed by new_logop */
4198 ((LISTOP*)listop)->op_last->op_next =
4199 (o == listop ? redo : LINKLIST(o));
4205 NewOp(1101,loop,1,LOOP);
4206 loop->op_type = OP_ENTERLOOP;
4207 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4208 loop->op_private = 0;
4209 loop->op_next = (OP*)loop;
4212 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4214 loop->op_redoop = redo;
4215 loop->op_lastop = o;
4216 o->op_private |= loopflags;
4219 loop->op_nextop = next;
4221 loop->op_nextop = o;
4223 o->op_flags |= flags;
4224 o->op_private |= (flags >> 8);
4229 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4233 PADOFFSET padoff = 0;
4237 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4238 sv->op_type = OP_RV2GV;
4239 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4241 else if (sv->op_type == OP_PADSV) { /* private variable */
4242 padoff = sv->op_targ;
4247 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4248 padoff = sv->op_targ;
4250 iterflags |= OPf_SPECIAL;
4255 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4258 #ifdef USE_5005THREADS
4259 padoff = find_threadsv("_");
4260 iterflags |= OPf_SPECIAL;
4262 sv = newGVOP(OP_GV, 0, PL_defgv);
4265 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4266 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4267 iterflags |= OPf_STACKED;
4269 else if (expr->op_type == OP_NULL &&
4270 (expr->op_flags & OPf_KIDS) &&
4271 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4273 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4274 * set the STACKED flag to indicate that these values are to be
4275 * treated as min/max values by 'pp_iterinit'.
4277 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4278 LOGOP* range = (LOGOP*) flip->op_first;
4279 OP* left = range->op_first;
4280 OP* right = left->op_sibling;
4283 range->op_flags &= ~OPf_KIDS;
4284 range->op_first = Nullop;
4286 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4287 listop->op_first->op_next = range->op_next;
4288 left->op_next = range->op_other;
4289 right->op_next = (OP*)listop;
4290 listop->op_next = listop->op_first;
4293 expr = (OP*)(listop);
4295 iterflags |= OPf_STACKED;
4298 expr = mod(force_list(expr), OP_GREPSTART);
4302 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4303 append_elem(OP_LIST, expr, scalar(sv))));
4304 assert(!loop->op_next);
4305 #ifdef PL_OP_SLAB_ALLOC
4308 NewOp(1234,tmp,1,LOOP);
4309 Copy(loop,tmp,1,LOOP);
4314 Renew(loop, 1, LOOP);
4316 loop->op_targ = padoff;
4317 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4318 PL_copline = forline;
4319 return newSTATEOP(0, label, wop);
4323 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4328 if (type != OP_GOTO || label->op_type == OP_CONST) {
4329 /* "last()" means "last" */
4330 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4331 o = newOP(type, OPf_SPECIAL);
4333 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4334 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4340 if (label->op_type == OP_ENTERSUB)
4341 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4342 o = newUNOP(type, OPf_STACKED, label);
4344 PL_hints |= HINT_BLOCK_SCOPE;
4349 Perl_cv_undef(pTHX_ CV *cv)
4352 CV *freecv = Nullcv;
4353 bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */
4355 #ifdef USE_5005THREADS
4357 MUTEX_DESTROY(CvMUTEXP(cv));
4358 Safefree(CvMUTEXP(cv));
4361 #endif /* USE_5005THREADS */
4364 if (CvFILE(cv) && !CvXSUB(cv)) {
4365 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4366 Safefree(CvFILE(cv));
4371 if (!CvXSUB(cv) && CvROOT(cv)) {
4372 #ifdef USE_5005THREADS
4373 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4374 Perl_croak(aTHX_ "Can't undef active subroutine");
4377 Perl_croak(aTHX_ "Can't undef active subroutine");
4378 #endif /* USE_5005THREADS */
4381 SAVEVPTR(PL_curpad);
4384 op_free(CvROOT(cv));
4385 CvROOT(cv) = Nullop;
4388 SvPOK_off((SV*)cv); /* forget prototype */
4390 outsidecv = CvOUTSIDE(cv);
4391 /* Since closure prototypes have the same lifetime as the containing
4392 * CV, they don't hold a refcount on the outside CV. This avoids
4393 * the refcount loop between the outer CV (which keeps a refcount to
4394 * the closure prototype in the pad entry for pp_anoncode()) and the
4395 * closure prototype, and the ensuing memory leak. --GSAR */
4396 if (!CvANON(cv) || CvCLONED(cv))
4398 CvOUTSIDE(cv) = Nullcv;
4400 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4403 if (CvPADLIST(cv)) {
4404 /* may be during global destruction */
4405 if (SvREFCNT(CvPADLIST(cv))) {
4406 AV *padlist = CvPADLIST(cv);
4408 /* pads may be cleared out already during global destruction */
4409 if (is_eval && !PL_dirty) {
4410 /* inner references to eval's cv must be fixed up */
4411 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4412 AV *comppad = (AV*)AvARRAY(padlist)[1];
4413 SV **namepad = AvARRAY(comppad_name);
4414 SV **curpad = AvARRAY(comppad);
4415 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4416 SV *namesv = namepad[ix];
4417 if (namesv && namesv != &PL_sv_undef
4418 && *SvPVX(namesv) == '&'
4419 && ix <= AvFILLp(comppad))
4421 CV *innercv = (CV*)curpad[ix];
4422 if (innercv && SvTYPE(innercv) == SVt_PVCV
4423 && CvOUTSIDE(innercv) == cv)
4425 CvOUTSIDE(innercv) = outsidecv;
4426 if (!CvANON(innercv) || CvCLONED(innercv)) {
4427 (void)SvREFCNT_inc(outsidecv);
4436 SvREFCNT_dec(freecv);
4437 ix = AvFILLp(padlist);
4439 SV* sv = AvARRAY(padlist)[ix--];
4442 if (sv == (SV*)PL_comppad_name)
4443 PL_comppad_name = Nullav;
4444 else if (sv == (SV*)PL_comppad) {
4445 PL_comppad = Nullav;
4446 PL_curpad = Null(SV**);
4450 SvREFCNT_dec((SV*)CvPADLIST(cv));
4452 CvPADLIST(cv) = Nullav;
4455 SvREFCNT_dec(freecv);
4462 #ifdef DEBUG_CLOSURES
4464 S_cv_dump(pTHX_ CV *cv)
4467 CV *outside = CvOUTSIDE(cv);
4468 AV* padlist = CvPADLIST(cv);
4475 PerlIO_printf(Perl_debug_log,
4476 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4478 (CvANON(cv) ? "ANON"
4479 : (cv == PL_main_cv) ? "MAIN"
4480 : CvUNIQUE(cv) ? "UNIQUE"
4481 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4484 : CvANON(outside) ? "ANON"
4485 : (outside == PL_main_cv) ? "MAIN"
4486 : CvUNIQUE(outside) ? "UNIQUE"
4487 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4492 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4493 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4494 pname = AvARRAY(pad_name);
4495 ppad = AvARRAY(pad);
4497 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4498 if (SvPOK(pname[ix]))
4499 PerlIO_printf(Perl_debug_log,
4500 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4501 (int)ix, PTR2UV(ppad[ix]),
4502 SvFAKE(pname[ix]) ? "FAKE " : "",
4504 (IV)I_32(SvNVX(pname[ix])),
4507 #endif /* DEBUGGING */
4509 #endif /* DEBUG_CLOSURES */
4512 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4516 AV* protopadlist = CvPADLIST(proto);
4517 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4518 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4519 SV** pname = AvARRAY(protopad_name);
4520 SV** ppad = AvARRAY(protopad);
4521 I32 fname = AvFILLp(protopad_name);
4522 I32 fpad = AvFILLp(protopad);
4526 assert(!CvUNIQUE(proto));
4530 SAVESPTR(PL_comppad_name);
4531 SAVESPTR(PL_compcv);
4533 cv = PL_compcv = (CV*)NEWSV(1104,0);
4534 sv_upgrade((SV *)cv, SvTYPE(proto));
4535 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4538 #ifdef USE_5005THREADS
4539 New(666, CvMUTEXP(cv), 1, perl_mutex);
4540 MUTEX_INIT(CvMUTEXP(cv));
4542 #endif /* USE_5005THREADS */
4544 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4545 : savepv(CvFILE(proto));
4547 CvFILE(cv) = CvFILE(proto);
4549 CvGV(cv) = CvGV(proto);
4550 CvSTASH(cv) = CvSTASH(proto);
4551 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4552 CvSTART(cv) = CvSTART(proto);
4554 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4557 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4559 PL_comppad_name = newAV();
4560 for (ix = fname; ix >= 0; ix--)
4561 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4563 PL_comppad = newAV();
4565 comppadlist = newAV();
4566 AvREAL_off(comppadlist);
4567 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4568 av_store(comppadlist, 1, (SV*)PL_comppad);
4569 CvPADLIST(cv) = comppadlist;
4570 av_fill(PL_comppad, AvFILLp(protopad));
4571 PL_curpad = AvARRAY(PL_comppad);
4573 av = newAV(); /* will be @_ */
4575 av_store(PL_comppad, 0, (SV*)av);
4576 AvFLAGS(av) = AVf_REIFY;
4578 for (ix = fpad; ix > 0; ix--) {
4579 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4580 if (namesv && namesv != &PL_sv_undef) {
4581 char *name = SvPVX(namesv); /* XXX */
4582 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4583 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4584 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4586 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4588 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4590 else { /* our own lexical */
4593 /* anon code -- we'll come back for it */
4594 sv = SvREFCNT_inc(ppad[ix]);
4596 else if (*name == '@')
4598 else if (*name == '%')
4607 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4608 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4611 SV* sv = NEWSV(0,0);
4617 /* Now that vars are all in place, clone nested closures. */
4619 for (ix = fpad; ix > 0; ix--) {
4620 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4622 && namesv != &PL_sv_undef
4623 && !(SvFLAGS(namesv) & SVf_FAKE)
4624 && *SvPVX(namesv) == '&'
4625 && CvCLONE(ppad[ix]))
4627 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4628 SvREFCNT_dec(ppad[ix]);
4631 PL_curpad[ix] = (SV*)kid;
4635 #ifdef DEBUG_CLOSURES
4636 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4638 PerlIO_printf(Perl_debug_log, " from:\n");
4640 PerlIO_printf(Perl_debug_log, " to:\n");
4647 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4649 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4651 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4658 Perl_cv_clone(pTHX_ CV *proto)
4661 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4662 cv = cv_clone2(proto, CvOUTSIDE(proto));
4663 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4668 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4670 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4671 SV* msg = sv_newmortal();
4675 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4676 sv_setpv(msg, "Prototype mismatch:");
4678 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4680 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4681 sv_catpv(msg, " vs ");
4683 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4685 sv_catpv(msg, "none");
4686 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4690 static void const_sv_xsub(pTHX_ CV* cv);
4694 =head1 Optree Manipulation Functions
4696 =for apidoc cv_const_sv
4698 If C<cv> is a constant sub eligible for inlining. returns the constant
4699 value returned by the sub. Otherwise, returns NULL.
4701 Constant subs can be created with C<newCONSTSUB> or as described in
4702 L<perlsub/"Constant Functions">.
4707 Perl_cv_const_sv(pTHX_ CV *cv)
4709 if (!cv || !CvCONST(cv))
4711 return (SV*)CvXSUBANY(cv).any_ptr;
4715 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4722 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4723 o = cLISTOPo->op_first->op_sibling;
4725 for (; o; o = o->op_next) {
4726 OPCODE type = o->op_type;
4728 if (sv && o->op_next == o)
4730 if (o->op_next != o) {
4731 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4733 if (type == OP_DBSTATE)
4736 if (type == OP_LEAVESUB || type == OP_RETURN)
4740 if (type == OP_CONST && cSVOPo->op_sv)
4742 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4743 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4744 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4748 /* We get here only from cv_clone2() while creating a closure.
4749 Copy the const value here instead of in cv_clone2 so that
4750 SvREADONLY_on doesn't lead to problems when leaving
4755 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4767 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4777 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4781 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4783 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4787 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4793 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4798 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4799 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4800 SV *sv = sv_newmortal();
4801 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4802 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4803 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4808 gv = gv_fetchpv(name ? name : (aname ? aname :
4809 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4810 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4820 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4821 maximum a prototype before. */
4822 if (SvTYPE(gv) > SVt_NULL) {
4823 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4824 && ckWARN_d(WARN_PROTOTYPE))
4826 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4828 cv_ckproto((CV*)gv, NULL, ps);
4831 sv_setpv((SV*)gv, ps);
4833 sv_setiv((SV*)gv, -1);
4834 SvREFCNT_dec(PL_compcv);
4835 cv = PL_compcv = NULL;
4836 PL_sub_generation++;
4840 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4842 #ifdef GV_UNIQUE_CHECK
4843 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4844 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4848 if (!block || !ps || *ps || attrs)
4851 const_sv = op_const_sv(block, Nullcv);
4854 bool exists = CvROOT(cv) || CvXSUB(cv);
4856 #ifdef GV_UNIQUE_CHECK
4857 if (exists && GvUNIQUE(gv)) {
4858 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4862 /* if the subroutine doesn't exist and wasn't pre-declared
4863 * with a prototype, assume it will be AUTOLOADed,
4864 * skipping the prototype check
4866 if (exists || SvPOK(cv))
4867 cv_ckproto(cv, gv, ps);
4868 /* already defined (or promised)? */
4869 if (exists || GvASSUMECV(gv)) {
4870 if (!block && !attrs) {
4871 if (CvFLAGS(PL_compcv)) {
4872 /* might have had built-in attrs applied */
4873 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4875 /* just a "sub foo;" when &foo is already defined */
4876 SAVEFREESV(PL_compcv);
4879 /* ahem, death to those who redefine active sort subs */
4880 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4881 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4883 if (ckWARN(WARN_REDEFINE)
4885 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4887 line_t oldline = CopLINE(PL_curcop);
4888 if (PL_copline != NOLINE)
4889 CopLINE_set(PL_curcop, PL_copline);
4890 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4891 CvCONST(cv) ? "Constant subroutine %s redefined"
4892 : "Subroutine %s redefined", name);
4893 CopLINE_set(PL_curcop, oldline);
4901 SvREFCNT_inc(const_sv);
4903 assert(!CvROOT(cv) && !CvCONST(cv));
4904 sv_setpv((SV*)cv, ""); /* prototype is "" */
4905 CvXSUBANY(cv).any_ptr = const_sv;
4906 CvXSUB(cv) = const_sv_xsub;
4911 cv = newCONSTSUB(NULL, name, const_sv);
4914 SvREFCNT_dec(PL_compcv);
4916 PL_sub_generation++;
4923 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4924 * before we clobber PL_compcv.
4928 /* Might have had built-in attributes applied -- propagate them. */
4929 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4930 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4931 stash = GvSTASH(CvGV(cv));
4932 else if (CvSTASH(cv))
4933 stash = CvSTASH(cv);
4935 stash = PL_curstash;
4938 /* possibly about to re-define existing subr -- ignore old cv */
4939 rcv = (SV*)PL_compcv;
4940 if (name && GvSTASH(gv))
4941 stash = GvSTASH(gv);
4943 stash = PL_curstash;
4945 apply_attrs(stash, rcv, attrs, FALSE);
4947 if (cv) { /* must reuse cv if autoloaded */
4949 /* got here with just attrs -- work done, so bug out */
4950 SAVEFREESV(PL_compcv);
4954 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4955 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4956 CvOUTSIDE(PL_compcv) = 0;
4957 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4958 CvPADLIST(PL_compcv) = 0;
4959 /* inner references to PL_compcv must be fixed up ... */
4961 AV *padlist = CvPADLIST(cv);
4962 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4963 AV *comppad = (AV*)AvARRAY(padlist)[1];
4964 SV **namepad = AvARRAY(comppad_name);
4965 SV **curpad = AvARRAY(comppad);
4966 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4967 SV *namesv = namepad[ix];
4968 if (namesv && namesv != &PL_sv_undef
4969 && *SvPVX(namesv) == '&')
4971 CV *innercv = (CV*)curpad[ix];
4972 if (CvOUTSIDE(innercv) == PL_compcv) {
4973 CvOUTSIDE(innercv) = cv;
4974 if (!CvANON(innercv) || CvCLONED(innercv)) {
4975 (void)SvREFCNT_inc(cv);
4976 SvREFCNT_dec(PL_compcv);
4982 /* ... before we throw it away */
4983 SvREFCNT_dec(PL_compcv);
4984 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4985 ++PL_sub_generation;
4992 PL_sub_generation++;
4996 CvFILE_set_from_cop(cv, PL_curcop);
4997 CvSTASH(cv) = PL_curstash;
4998 #ifdef USE_5005THREADS
5000 if (!CvMUTEXP(cv)) {
5001 New(666, CvMUTEXP(cv), 1, perl_mutex);
5002 MUTEX_INIT(CvMUTEXP(cv));
5004 #endif /* USE_5005THREADS */
5007 sv_setpv((SV*)cv, ps);
5009 if (PL_error_count) {
5013 char *s = strrchr(name, ':');
5015 if (strEQ(s, "BEGIN")) {
5017 "BEGIN not safe after errors--compilation aborted";
5018 if (PL_in_eval & EVAL_KEEPERR)
5019 Perl_croak(aTHX_ not_safe);
5021 /* force display of errors found but not reported */
5022 sv_catpv(ERRSV, not_safe);
5023 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
5031 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5032 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5035 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5036 mod(scalarseq(block), OP_LEAVESUBLV));
5039 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5041 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5042 OpREFCNT_set(CvROOT(cv), 1);
5043 CvSTART(cv) = LINKLIST(CvROOT(cv));
5044 CvROOT(cv)->op_next = 0;
5045 CALL_PEEP(CvSTART(cv));
5047 /* now that optimizer has done its work, adjust pad values */
5049 SV **namep = AvARRAY(PL_comppad_name);
5050 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5053 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5056 * The only things that a clonable function needs in its
5057 * pad are references to outer lexicals and anonymous subs.
5058 * The rest are created anew during cloning.
5060 if (!((namesv = namep[ix]) != Nullsv &&
5061 namesv != &PL_sv_undef &&
5063 *SvPVX(namesv) == '&')))
5065 SvREFCNT_dec(PL_curpad[ix]);
5066 PL_curpad[ix] = Nullsv;
5069 assert(!CvCONST(cv));
5070 if (ps && !*ps && op_const_sv(block, cv))
5074 AV *av = newAV(); /* Will be @_ */
5076 av_store(PL_comppad, 0, (SV*)av);
5077 AvFLAGS(av) = AVf_REIFY;
5079 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5080 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5082 if (!SvPADMY(PL_curpad[ix]))
5083 SvPADTMP_on(PL_curpad[ix]);
5087 /* If a potential closure prototype, don't keep a refcount on outer CV.
5088 * This is okay as the lifetime of the prototype is tied to the
5089 * lifetime of the outer CV. Avoids memory leak due to reference
5092 SvREFCNT_dec(CvOUTSIDE(cv));
5094 if (name || aname) {
5096 char *tname = (name ? name : aname);
5098 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5099 SV *sv = NEWSV(0,0);
5100 SV *tmpstr = sv_newmortal();
5101 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5105 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5107 (long)PL_subline, (long)CopLINE(PL_curcop));
5108 gv_efullname3(tmpstr, gv, Nullch);
5109 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5110 hv = GvHVn(db_postponed);
5111 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5112 && (pcv = GvCV(db_postponed)))
5118 call_sv((SV*)pcv, G_DISCARD);
5122 if ((s = strrchr(tname,':')))
5127 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5130 if (strEQ(s, "BEGIN")) {
5131 I32 oldscope = PL_scopestack_ix;
5133 SAVECOPFILE(&PL_compiling);
5134 SAVECOPLINE(&PL_compiling);
5137 PL_beginav = newAV();
5138 DEBUG_x( dump_sub(gv) );
5139 av_push(PL_beginav, (SV*)cv);
5140 GvCV(gv) = 0; /* cv has been hijacked */
5141 call_list(oldscope, PL_beginav);
5143 PL_curcop = &PL_compiling;
5144 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5147 else if (strEQ(s, "END") && !PL_error_count) {
5150 DEBUG_x( dump_sub(gv) );
5151 av_unshift(PL_endav, 1);
5152 av_store(PL_endav, 0, (SV*)cv);
5153 GvCV(gv) = 0; /* cv has been hijacked */
5155 else if (strEQ(s, "CHECK") && !PL_error_count) {
5157 PL_checkav = newAV();
5158 DEBUG_x( dump_sub(gv) );
5159 if (PL_main_start && ckWARN(WARN_VOID))
5160 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5161 av_unshift(PL_checkav, 1);
5162 av_store(PL_checkav, 0, (SV*)cv);
5163 GvCV(gv) = 0; /* cv has been hijacked */
5165 else if (strEQ(s, "INIT") && !PL_error_count) {
5167 PL_initav = newAV();
5168 DEBUG_x( dump_sub(gv) );
5169 if (PL_main_start && ckWARN(WARN_VOID))
5170 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5171 av_push(PL_initav, (SV*)cv);
5172 GvCV(gv) = 0; /* cv has been hijacked */
5177 PL_copline = NOLINE;
5182 /* XXX unsafe for threads if eval_owner isn't held */
5184 =for apidoc newCONSTSUB
5186 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5187 eligible for inlining at compile-time.
5193 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5199 SAVECOPLINE(PL_curcop);
5200 CopLINE_set(PL_curcop, PL_copline);
5203 PL_hints &= ~HINT_BLOCK_SCOPE;
5206 SAVESPTR(PL_curstash);
5207 SAVECOPSTASH(PL_curcop);
5208 PL_curstash = stash;
5209 CopSTASH_set(PL_curcop,stash);
5212 cv = newXS(name, const_sv_xsub, __FILE__);
5213 CvXSUBANY(cv).any_ptr = sv;
5215 sv_setpv((SV*)cv, ""); /* prototype is "" */
5223 =for apidoc U||newXS
5225 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5231 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5233 GV *gv = gv_fetchpv(name ? name :
5234 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5235 GV_ADDMULTI, SVt_PVCV);
5238 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5240 /* just a cached method */
5244 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5245 /* already defined (or promised) */
5246 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5247 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5248 line_t oldline = CopLINE(PL_curcop);
5249 if (PL_copline != NOLINE)
5250 CopLINE_set(PL_curcop, PL_copline);
5251 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5252 CvCONST(cv) ? "Constant subroutine %s redefined"
5253 : "Subroutine %s redefined"
5255 CopLINE_set(PL_curcop, oldline);
5262 if (cv) /* must reuse cv if autoloaded */
5265 cv = (CV*)NEWSV(1105,0);
5266 sv_upgrade((SV *)cv, SVt_PVCV);
5270 PL_sub_generation++;
5274 #ifdef USE_5005THREADS
5275 New(666, CvMUTEXP(cv), 1, perl_mutex);
5276 MUTEX_INIT(CvMUTEXP(cv));
5278 #endif /* USE_5005THREADS */
5279 (void)gv_fetchfile(filename);
5280 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5281 an external constant string */
5282 CvXSUB(cv) = subaddr;
5285 char *s = strrchr(name,':');
5291 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5294 if (strEQ(s, "BEGIN")) {
5296 PL_beginav = newAV();
5297 av_push(PL_beginav, (SV*)cv);
5298 GvCV(gv) = 0; /* cv has been hijacked */
5300 else if (strEQ(s, "END")) {
5303 av_unshift(PL_endav, 1);
5304 av_store(PL_endav, 0, (SV*)cv);
5305 GvCV(gv) = 0; /* cv has been hijacked */
5307 else if (strEQ(s, "CHECK")) {
5309 PL_checkav = newAV();
5310 if (PL_main_start && ckWARN(WARN_VOID))
5311 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5312 av_unshift(PL_checkav, 1);
5313 av_store(PL_checkav, 0, (SV*)cv);
5314 GvCV(gv) = 0; /* cv has been hijacked */
5316 else if (strEQ(s, "INIT")) {
5318 PL_initav = newAV();
5319 if (PL_main_start && ckWARN(WARN_VOID))
5320 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5321 av_push(PL_initav, (SV*)cv);
5322 GvCV(gv) = 0; /* cv has been hijacked */
5333 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5342 name = SvPVx(cSVOPo->op_sv, n_a);
5345 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5346 #ifdef GV_UNIQUE_CHECK
5348 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5352 if ((cv = GvFORM(gv))) {
5353 if (ckWARN(WARN_REDEFINE)) {
5354 line_t oldline = CopLINE(PL_curcop);
5355 if (PL_copline != NOLINE)
5356 CopLINE_set(PL_curcop, PL_copline);
5357 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
5358 CopLINE_set(PL_curcop, oldline);
5365 CvFILE_set_from_cop(cv, PL_curcop);
5367 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5368 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5369 SvPADTMP_on(PL_curpad[ix]);
5372 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5373 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5374 OpREFCNT_set(CvROOT(cv), 1);
5375 CvSTART(cv) = LINKLIST(CvROOT(cv));
5376 CvROOT(cv)->op_next = 0;
5377 CALL_PEEP(CvSTART(cv));
5379 PL_copline = NOLINE;
5384 Perl_newANONLIST(pTHX_ OP *o)
5386 return newUNOP(OP_REFGEN, 0,
5387 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5391 Perl_newANONHASH(pTHX_ OP *o)
5393 return newUNOP(OP_REFGEN, 0,
5394 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5398 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5400 return newANONATTRSUB(floor, proto, Nullop, block);
5404 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5406 return newUNOP(OP_REFGEN, 0,
5407 newSVOP(OP_ANONCODE, 0,
5408 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5412 Perl_oopsAV(pTHX_ OP *o)
5414 switch (o->op_type) {
5416 o->op_type = OP_PADAV;
5417 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5418 return ref(o, OP_RV2AV);
5421 o->op_type = OP_RV2AV;
5422 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5427 if (ckWARN_d(WARN_INTERNAL))
5428 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5435 Perl_oopsHV(pTHX_ OP *o)
5437 switch (o->op_type) {
5440 o->op_type = OP_PADHV;
5441 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5442 return ref(o, OP_RV2HV);
5446 o->op_type = OP_RV2HV;
5447 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5452 if (ckWARN_d(WARN_INTERNAL))
5453 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5460 Perl_newAVREF(pTHX_ OP *o)
5462 if (o->op_type == OP_PADANY) {
5463 o->op_type = OP_PADAV;
5464 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5467 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5468 && ckWARN(WARN_DEPRECATED)) {
5469 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5470 "Using an array as a reference is deprecated");
5472 return newUNOP(OP_RV2AV, 0, scalar(o));
5476 Perl_newGVREF(pTHX_ I32 type, OP *o)
5478 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5479 return newUNOP(OP_NULL, 0, o);
5480 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5484 Perl_newHVREF(pTHX_ OP *o)
5486 if (o->op_type == OP_PADANY) {
5487 o->op_type = OP_PADHV;
5488 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5491 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5492 && ckWARN(WARN_DEPRECATED)) {
5493 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5494 "Using a hash as a reference is deprecated");
5496 return newUNOP(OP_RV2HV, 0, scalar(o));
5500 Perl_oopsCV(pTHX_ OP *o)
5502 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5508 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5510 return newUNOP(OP_RV2CV, flags, scalar(o));
5514 Perl_newSVREF(pTHX_ OP *o)
5516 if (o->op_type == OP_PADANY) {
5517 o->op_type = OP_PADSV;
5518 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5521 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5522 o->op_flags |= OPpDONE_SVREF;
5525 return newUNOP(OP_RV2SV, 0, scalar(o));
5528 /* Check routines. */
5531 Perl_ck_anoncode(pTHX_ OP *o)
5536 name = NEWSV(1106,0);
5537 sv_upgrade(name, SVt_PVNV);
5538 sv_setpvn(name, "&", 1);
5541 ix = pad_alloc(o->op_type, SVs_PADMY);
5542 av_store(PL_comppad_name, ix, name);
5543 av_store(PL_comppad, ix, cSVOPo->op_sv);
5544 SvPADMY_on(cSVOPo->op_sv);
5545 cSVOPo->op_sv = Nullsv;
5546 cSVOPo->op_targ = ix;
5551 Perl_ck_bitop(pTHX_ OP *o)
5553 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5558 Perl_ck_concat(pTHX_ OP *o)
5560 if (cUNOPo->op_first->op_type == OP_CONCAT)
5561 o->op_flags |= OPf_STACKED;
5566 Perl_ck_spair(pTHX_ OP *o)
5568 if (o->op_flags & OPf_KIDS) {
5571 OPCODE type = o->op_type;
5572 o = modkids(ck_fun(o), type);
5573 kid = cUNOPo->op_first;
5574 newop = kUNOP->op_first->op_sibling;
5576 (newop->op_sibling ||
5577 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5578 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5579 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5583 op_free(kUNOP->op_first);
5584 kUNOP->op_first = newop;
5586 o->op_ppaddr = PL_ppaddr[++o->op_type];
5591 Perl_ck_delete(pTHX_ OP *o)
5595 if (o->op_flags & OPf_KIDS) {
5596 OP *kid = cUNOPo->op_first;
5597 switch (kid->op_type) {
5599 o->op_flags |= OPf_SPECIAL;
5602 o->op_private |= OPpSLICE;
5605 o->op_flags |= OPf_SPECIAL;
5610 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5619 Perl_ck_die(pTHX_ OP *o)
5622 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5628 Perl_ck_eof(pTHX_ OP *o)
5630 I32 type = o->op_type;
5632 if (o->op_flags & OPf_KIDS) {
5633 if (cLISTOPo->op_first->op_type == OP_STUB) {
5635 o = newUNOP(type, OPf_SPECIAL,
5636 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5644 Perl_ck_eval(pTHX_ OP *o)
5646 PL_hints |= HINT_BLOCK_SCOPE;
5647 if (o->op_flags & OPf_KIDS) {
5648 SVOP *kid = (SVOP*)cUNOPo->op_first;
5651 o->op_flags &= ~OPf_KIDS;
5654 else if (kid->op_type == OP_LINESEQ) {
5657 kid->op_next = o->op_next;
5658 cUNOPo->op_first = 0;
5661 NewOp(1101, enter, 1, LOGOP);
5662 enter->op_type = OP_ENTERTRY;
5663 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5664 enter->op_private = 0;
5666 /* establish postfix order */
5667 enter->op_next = (OP*)enter;
5669 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5670 o->op_type = OP_LEAVETRY;
5671 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5672 enter->op_other = o;
5680 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5682 o->op_targ = (PADOFFSET)PL_hints;
5687 Perl_ck_exit(pTHX_ OP *o)
5690 HV *table = GvHV(PL_hintgv);
5692 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5693 if (svp && *svp && SvTRUE(*svp))
5694 o->op_private |= OPpEXIT_VMSISH;
5696 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5702 Perl_ck_exec(pTHX_ OP *o)
5705 if (o->op_flags & OPf_STACKED) {
5707 kid = cUNOPo->op_first->op_sibling;
5708 if (kid->op_type == OP_RV2GV)
5717 Perl_ck_exists(pTHX_ OP *o)
5720 if (o->op_flags & OPf_KIDS) {
5721 OP *kid = cUNOPo->op_first;
5722 if (kid->op_type == OP_ENTERSUB) {
5723 (void) ref(kid, o->op_type);
5724 if (kid->op_type != OP_RV2CV && !PL_error_count)
5725 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5727 o->op_private |= OPpEXISTS_SUB;
5729 else if (kid->op_type == OP_AELEM)
5730 o->op_flags |= OPf_SPECIAL;
5731 else if (kid->op_type != OP_HELEM)
5732 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5741 Perl_ck_gvconst(pTHX_ register OP *o)
5743 o = fold_constants(o);
5744 if (o->op_type == OP_CONST)
5751 Perl_ck_rvconst(pTHX_ register OP *o)
5753 SVOP *kid = (SVOP*)cUNOPo->op_first;
5755 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5756 if (kid->op_type == OP_CONST) {
5760 SV *kidsv = kid->op_sv;
5763 /* Is it a constant from cv_const_sv()? */
5764 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5765 SV *rsv = SvRV(kidsv);
5766 int svtype = SvTYPE(rsv);
5767 char *badtype = Nullch;
5769 switch (o->op_type) {
5771 if (svtype > SVt_PVMG)
5772 badtype = "a SCALAR";
5775 if (svtype != SVt_PVAV)
5776 badtype = "an ARRAY";
5779 if (svtype != SVt_PVHV) {
5780 if (svtype == SVt_PVAV) { /* pseudohash? */
5781 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5782 if (ksv && SvROK(*ksv)
5783 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5792 if (svtype != SVt_PVCV)
5797 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5800 name = SvPV(kidsv, n_a);
5801 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5802 char *badthing = Nullch;
5803 switch (o->op_type) {
5805 badthing = "a SCALAR";
5808 badthing = "an ARRAY";
5811 badthing = "a HASH";
5816 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5820 * This is a little tricky. We only want to add the symbol if we
5821 * didn't add it in the lexer. Otherwise we get duplicate strict
5822 * warnings. But if we didn't add it in the lexer, we must at
5823 * least pretend like we wanted to add it even if it existed before,
5824 * or we get possible typo warnings. OPpCONST_ENTERED says
5825 * whether the lexer already added THIS instance of this symbol.
5827 iscv = (o->op_type == OP_RV2CV) * 2;
5829 gv = gv_fetchpv(name,
5830 iscv | !(kid->op_private & OPpCONST_ENTERED),
5833 : o->op_type == OP_RV2SV
5835 : o->op_type == OP_RV2AV
5837 : o->op_type == OP_RV2HV
5840 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5842 kid->op_type = OP_GV;
5843 SvREFCNT_dec(kid->op_sv);
5845 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5846 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5847 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5849 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5851 kid->op_sv = SvREFCNT_inc(gv);
5853 kid->op_private = 0;
5854 kid->op_ppaddr = PL_ppaddr[OP_GV];
5861 Perl_ck_ftst(pTHX_ OP *o)
5863 I32 type = o->op_type;
5865 if (o->op_flags & OPf_REF) {
5868 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5869 SVOP *kid = (SVOP*)cUNOPo->op_first;
5871 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5873 OP *newop = newGVOP(type, OPf_REF,
5874 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5881 if (type == OP_FTTTY)
5882 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5885 o = newUNOP(type, 0, newDEFSVOP());
5891 Perl_ck_fun(pTHX_ OP *o)
5897 int type = o->op_type;
5898 register I32 oa = PL_opargs[type] >> OASHIFT;
5900 if (o->op_flags & OPf_STACKED) {
5901 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5904 return no_fh_allowed(o);
5907 if (o->op_flags & OPf_KIDS) {
5909 tokid = &cLISTOPo->op_first;
5910 kid = cLISTOPo->op_first;
5911 if (kid->op_type == OP_PUSHMARK ||
5912 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5914 tokid = &kid->op_sibling;
5915 kid = kid->op_sibling;
5917 if (!kid && PL_opargs[type] & OA_DEFGV)
5918 *tokid = kid = newDEFSVOP();
5922 sibl = kid->op_sibling;
5925 /* list seen where single (scalar) arg expected? */
5926 if (numargs == 1 && !(oa >> 4)
5927 && kid->op_type == OP_LIST && type != OP_SCALAR)
5929 return too_many_arguments(o,PL_op_desc[type]);
5942 if ((type == OP_PUSH || type == OP_UNSHIFT)
5943 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5944 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5945 "Useless use of %s with no values",
5948 if (kid->op_type == OP_CONST &&
5949 (kid->op_private & OPpCONST_BARE))
5951 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5952 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5953 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5954 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5955 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5956 "Array @%s missing the @ in argument %"IVdf" of %s()",
5957 name, (IV)numargs, PL_op_desc[type]);
5960 kid->op_sibling = sibl;
5963 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5964 bad_type(numargs, "array", PL_op_desc[type], kid);
5968 if (kid->op_type == OP_CONST &&
5969 (kid->op_private & OPpCONST_BARE))
5971 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5972 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5973 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5974 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5975 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5976 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5977 name, (IV)numargs, PL_op_desc[type]);
5980 kid->op_sibling = sibl;
5983 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5984 bad_type(numargs, "hash", PL_op_desc[type], kid);
5989 OP *newop = newUNOP(OP_NULL, 0, kid);
5990 kid->op_sibling = 0;
5992 newop->op_next = newop;
5994 kid->op_sibling = sibl;
5999 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6000 if (kid->op_type == OP_CONST &&
6001 (kid->op_private & OPpCONST_BARE))
6003 OP *newop = newGVOP(OP_GV, 0,
6004 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
6006 if (!(o->op_private & 1) && /* if not unop */
6007 kid == cLISTOPo->op_last)
6008 cLISTOPo->op_last = newop;
6012 else if (kid->op_type == OP_READLINE) {
6013 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6014 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6017 I32 flags = OPf_SPECIAL;
6021 /* is this op a FH constructor? */
6022 if (is_handle_constructor(o,numargs)) {
6023 char *name = Nullch;
6027 /* Set a flag to tell rv2gv to vivify
6028 * need to "prove" flag does not mean something
6029 * else already - NI-S 1999/05/07
6032 if (kid->op_type == OP_PADSV) {
6033 SV **namep = av_fetch(PL_comppad_name,
6035 if (namep && *namep)
6036 name = SvPV(*namep, len);
6038 else if (kid->op_type == OP_RV2SV
6039 && kUNOP->op_first->op_type == OP_GV)
6041 GV *gv = cGVOPx_gv(kUNOP->op_first);
6043 len = GvNAMELEN(gv);
6045 else if (kid->op_type == OP_AELEM
6046 || kid->op_type == OP_HELEM)
6048 name = "__ANONIO__";
6054 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6055 namesv = PL_curpad[targ];
6056 (void)SvUPGRADE(namesv, SVt_PV);
6058 sv_setpvn(namesv, "$", 1);
6059 sv_catpvn(namesv, name, len);
6062 kid->op_sibling = 0;
6063 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6064 kid->op_targ = targ;
6065 kid->op_private |= priv;
6067 kid->op_sibling = sibl;
6073 mod(scalar(kid), type);
6077 tokid = &kid->op_sibling;
6078 kid = kid->op_sibling;
6080 o->op_private |= numargs;
6082 return too_many_arguments(o,OP_DESC(o));
6085 else if (PL_opargs[type] & OA_DEFGV) {
6087 return newUNOP(type, 0, newDEFSVOP());
6091 while (oa & OA_OPTIONAL)
6093 if (oa && oa != OA_LIST)
6094 return too_few_arguments(o,OP_DESC(o));
6100 Perl_ck_glob(pTHX_ OP *o)
6105 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6106 append_elem(OP_GLOB, o, newDEFSVOP());
6108 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6109 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6111 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6114 #if !defined(PERL_EXTERNAL_GLOB)
6115 /* XXX this can be tightened up and made more failsafe. */
6119 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6120 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6121 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6122 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6123 GvCV(gv) = GvCV(glob_gv);
6124 SvREFCNT_inc((SV*)GvCV(gv));
6125 GvIMPORTED_CV_on(gv);
6128 #endif /* PERL_EXTERNAL_GLOB */
6130 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6131 append_elem(OP_GLOB, o,
6132 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6133 o->op_type = OP_LIST;
6134 o->op_ppaddr = PL_ppaddr[OP_LIST];
6135 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6136 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6137 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6138 append_elem(OP_LIST, o,
6139 scalar(newUNOP(OP_RV2CV, 0,
6140 newGVOP(OP_GV, 0, gv)))));
6141 o = newUNOP(OP_NULL, 0, ck_subr(o));
6142 o->op_targ = OP_GLOB; /* hint at what it used to be */
6145 gv = newGVgen("main");
6147 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6153 Perl_ck_grep(pTHX_ OP *o)
6157 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6159 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6160 NewOp(1101, gwop, 1, LOGOP);
6162 if (o->op_flags & OPf_STACKED) {
6165 kid = cLISTOPo->op_first->op_sibling;
6166 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6169 kid->op_next = (OP*)gwop;
6170 o->op_flags &= ~OPf_STACKED;
6172 kid = cLISTOPo->op_first->op_sibling;
6173 if (type == OP_MAPWHILE)
6180 kid = cLISTOPo->op_first->op_sibling;
6181 if (kid->op_type != OP_NULL)
6182 Perl_croak(aTHX_ "panic: ck_grep");
6183 kid = kUNOP->op_first;
6185 gwop->op_type = type;
6186 gwop->op_ppaddr = PL_ppaddr[type];
6187 gwop->op_first = listkids(o);
6188 gwop->op_flags |= OPf_KIDS;
6189 gwop->op_private = 1;
6190 gwop->op_other = LINKLIST(kid);
6191 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6192 kid->op_next = (OP*)gwop;
6194 kid = cLISTOPo->op_first->op_sibling;
6195 if (!kid || !kid->op_sibling)
6196 return too_few_arguments(o,OP_DESC(o));
6197 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6198 mod(kid, OP_GREPSTART);
6204 Perl_ck_index(pTHX_ OP *o)
6206 if (o->op_flags & OPf_KIDS) {
6207 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6209 kid = kid->op_sibling; /* get past "big" */
6210 if (kid && kid->op_type == OP_CONST)
6211 fbm_compile(((SVOP*)kid)->op_sv, 0);
6217 Perl_ck_lengthconst(pTHX_ OP *o)
6219 /* XXX length optimization goes here */
6224 Perl_ck_lfun(pTHX_ OP *o)
6226 OPCODE type = o->op_type;
6227 return modkids(ck_fun(o), type);
6231 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6233 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6234 switch (cUNOPo->op_first->op_type) {
6236 /* This is needed for
6237 if (defined %stash::)
6238 to work. Do not break Tk.
6240 break; /* Globals via GV can be undef */
6242 case OP_AASSIGN: /* Is this a good idea? */
6243 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6244 "defined(@array) is deprecated");
6245 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6246 "\t(Maybe you should just omit the defined()?)\n");
6249 /* This is needed for
6250 if (defined %stash::)
6251 to work. Do not break Tk.
6253 break; /* Globals via GV can be undef */
6255 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6256 "defined(%%hash) is deprecated");
6257 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6258 "\t(Maybe you should just omit the defined()?)\n");
6269 Perl_ck_rfun(pTHX_ OP *o)
6271 OPCODE type = o->op_type;
6272 return refkids(ck_fun(o), type);
6276 Perl_ck_listiob(pTHX_ OP *o)
6280 kid = cLISTOPo->op_first;
6283 kid = cLISTOPo->op_first;
6285 if (kid->op_type == OP_PUSHMARK)
6286 kid = kid->op_sibling;
6287 if (kid && o->op_flags & OPf_STACKED)
6288 kid = kid->op_sibling;
6289 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6290 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6291 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6292 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6293 cLISTOPo->op_first->op_sibling = kid;
6294 cLISTOPo->op_last = kid;
6295 kid = kid->op_sibling;
6300 append_elem(o->op_type, o, newDEFSVOP());
6306 Perl_ck_sassign(pTHX_ OP *o)
6308 OP *kid = cLISTOPo->op_first;
6309 /* has a disposable target? */
6310 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6311 && !(kid->op_flags & OPf_STACKED)
6312 /* Cannot steal the second time! */
6313 && !(kid->op_private & OPpTARGET_MY))
6315 OP *kkid = kid->op_sibling;
6317 /* Can just relocate the target. */
6318 if (kkid && kkid->op_type == OP_PADSV
6319 && !(kkid->op_private & OPpLVAL_INTRO))
6321 kid->op_targ = kkid->op_targ;
6323 /* Now we do not need PADSV and SASSIGN. */
6324 kid->op_sibling = o->op_sibling; /* NULL */
6325 cLISTOPo->op_first = NULL;
6328 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6336 Perl_ck_match(pTHX_ OP *o)
6338 o->op_private |= OPpRUNTIME;
6343 Perl_ck_method(pTHX_ OP *o)
6345 OP *kid = cUNOPo->op_first;
6346 if (kid->op_type == OP_CONST) {
6347 SV* sv = kSVOP->op_sv;
6348 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6350 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6351 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6354 kSVOP->op_sv = Nullsv;
6356 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6365 Perl_ck_null(pTHX_ OP *o)
6371 Perl_ck_open(pTHX_ OP *o)
6373 HV *table = GvHV(PL_hintgv);
6377 svp = hv_fetch(table, "open_IN", 7, FALSE);
6379 mode = mode_from_discipline(*svp);
6380 if (mode & O_BINARY)
6381 o->op_private |= OPpOPEN_IN_RAW;
6382 else if (mode & O_TEXT)
6383 o->op_private |= OPpOPEN_IN_CRLF;
6386 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6388 mode = mode_from_discipline(*svp);
6389 if (mode & O_BINARY)
6390 o->op_private |= OPpOPEN_OUT_RAW;
6391 else if (mode & O_TEXT)
6392 o->op_private |= OPpOPEN_OUT_CRLF;
6395 if (o->op_type == OP_BACKTICK)
6401 Perl_ck_repeat(pTHX_ OP *o)
6403 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6404 o->op_private |= OPpREPEAT_DOLIST;
6405 cBINOPo->op_first = force_list(cBINOPo->op_first);
6413 Perl_ck_require(pTHX_ OP *o)
6417 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6418 SVOP *kid = (SVOP*)cUNOPo->op_first;
6420 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6422 for (s = SvPVX(kid->op_sv); *s; s++) {
6423 if (*s == ':' && s[1] == ':') {
6425 Move(s+2, s+1, strlen(s+2)+1, char);
6426 --SvCUR(kid->op_sv);
6429 if (SvREADONLY(kid->op_sv)) {
6430 SvREADONLY_off(kid->op_sv);
6431 sv_catpvn(kid->op_sv, ".pm", 3);
6432 SvREADONLY_on(kid->op_sv);
6435 sv_catpvn(kid->op_sv, ".pm", 3);
6439 /* handle override, if any */
6440 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6441 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6442 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6444 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6445 OP *kid = cUNOPo->op_first;
6446 cUNOPo->op_first = 0;
6448 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6449 append_elem(OP_LIST, kid,
6450 scalar(newUNOP(OP_RV2CV, 0,
6459 Perl_ck_return(pTHX_ OP *o)
6462 if (CvLVALUE(PL_compcv)) {
6463 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6464 mod(kid, OP_LEAVESUBLV);
6471 Perl_ck_retarget(pTHX_ OP *o)
6473 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6480 Perl_ck_select(pTHX_ OP *o)
6483 if (o->op_flags & OPf_KIDS) {
6484 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6485 if (kid && kid->op_sibling) {
6486 o->op_type = OP_SSELECT;
6487 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6489 return fold_constants(o);
6493 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6494 if (kid && kid->op_type == OP_RV2GV)
6495 kid->op_private &= ~HINT_STRICT_REFS;
6500 Perl_ck_shift(pTHX_ OP *o)
6502 I32 type = o->op_type;
6504 if (!(o->op_flags & OPf_KIDS)) {
6508 #ifdef USE_5005THREADS
6509 if (!CvUNIQUE(PL_compcv)) {
6510 argop = newOP(OP_PADAV, OPf_REF);
6511 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6514 argop = newUNOP(OP_RV2AV, 0,
6515 scalar(newGVOP(OP_GV, 0,
6516 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6519 argop = newUNOP(OP_RV2AV, 0,
6520 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6521 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6522 #endif /* USE_5005THREADS */
6523 return newUNOP(type, 0, scalar(argop));
6525 return scalar(modkids(ck_fun(o), type));
6529 Perl_ck_sort(pTHX_ OP *o)
6533 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6535 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6536 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6538 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6540 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6542 if (kid->op_type == OP_SCOPE) {
6546 else if (kid->op_type == OP_LEAVE) {
6547 if (o->op_type == OP_SORT) {
6548 op_null(kid); /* wipe out leave */
6551 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6552 if (k->op_next == kid)
6554 /* don't descend into loops */
6555 else if (k->op_type == OP_ENTERLOOP
6556 || k->op_type == OP_ENTERITER)
6558 k = cLOOPx(k)->op_lastop;
6563 kid->op_next = 0; /* just disconnect the leave */
6564 k = kLISTOP->op_first;
6569 if (o->op_type == OP_SORT) {
6570 /* provide scalar context for comparison function/block */
6576 o->op_flags |= OPf_SPECIAL;
6578 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6581 firstkid = firstkid->op_sibling;
6584 /* provide list context for arguments */
6585 if (o->op_type == OP_SORT)
6592 S_simplify_sort(pTHX_ OP *o)
6594 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6598 if (!(o->op_flags & OPf_STACKED))
6600 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6601 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6602 kid = kUNOP->op_first; /* get past null */
6603 if (kid->op_type != OP_SCOPE)
6605 kid = kLISTOP->op_last; /* get past scope */
6606 switch(kid->op_type) {
6614 k = kid; /* remember this node*/
6615 if (kBINOP->op_first->op_type != OP_RV2SV)
6617 kid = kBINOP->op_first; /* get past cmp */
6618 if (kUNOP->op_first->op_type != OP_GV)
6620 kid = kUNOP->op_first; /* get past rv2sv */
6622 if (GvSTASH(gv) != PL_curstash)
6624 if (strEQ(GvNAME(gv), "a"))
6626 else if (strEQ(GvNAME(gv), "b"))
6630 kid = k; /* back to cmp */
6631 if (kBINOP->op_last->op_type != OP_RV2SV)
6633 kid = kBINOP->op_last; /* down to 2nd arg */
6634 if (kUNOP->op_first->op_type != OP_GV)
6636 kid = kUNOP->op_first; /* get past rv2sv */
6638 if (GvSTASH(gv) != PL_curstash
6640 ? strNE(GvNAME(gv), "a")
6641 : strNE(GvNAME(gv), "b")))
6643 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6645 o->op_private |= OPpSORT_REVERSE;
6646 if (k->op_type == OP_NCMP)
6647 o->op_private |= OPpSORT_NUMERIC;
6648 if (k->op_type == OP_I_NCMP)
6649 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6650 kid = cLISTOPo->op_first->op_sibling;
6651 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6652 op_free(kid); /* then delete it */
6656 Perl_ck_split(pTHX_ OP *o)
6660 if (o->op_flags & OPf_STACKED)
6661 return no_fh_allowed(o);
6663 kid = cLISTOPo->op_first;
6664 if (kid->op_type != OP_NULL)
6665 Perl_croak(aTHX_ "panic: ck_split");
6666 kid = kid->op_sibling;
6667 op_free(cLISTOPo->op_first);
6668 cLISTOPo->op_first = kid;
6670 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6671 cLISTOPo->op_last = kid; /* There was only one element previously */
6674 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6675 OP *sibl = kid->op_sibling;
6676 kid->op_sibling = 0;
6677 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6678 if (cLISTOPo->op_first == cLISTOPo->op_last)
6679 cLISTOPo->op_last = kid;
6680 cLISTOPo->op_first = kid;
6681 kid->op_sibling = sibl;
6684 kid->op_type = OP_PUSHRE;
6685 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6687 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6688 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6689 "Use of /g modifier is meaningless in split");
6692 if (!kid->op_sibling)
6693 append_elem(OP_SPLIT, o, newDEFSVOP());
6695 kid = kid->op_sibling;
6698 if (!kid->op_sibling)
6699 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6701 kid = kid->op_sibling;
6704 if (kid->op_sibling)
6705 return too_many_arguments(o,OP_DESC(o));
6711 Perl_ck_join(pTHX_ OP *o)
6713 if (ckWARN(WARN_SYNTAX)) {
6714 OP *kid = cLISTOPo->op_first->op_sibling;
6715 if (kid && kid->op_type == OP_MATCH) {
6716 char *pmstr = "STRING";
6717 if (PM_GETRE(kPMOP))
6718 pmstr = PM_GETRE(kPMOP)->precomp;
6719 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6720 "/%s/ should probably be written as \"%s\"",
6728 Perl_ck_subr(pTHX_ OP *o)
6730 OP *prev = ((cUNOPo->op_first->op_sibling)
6731 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6732 OP *o2 = prev->op_sibling;
6739 I32 contextclass = 0;
6743 o->op_private |= OPpENTERSUB_HASTARG;
6744 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6745 if (cvop->op_type == OP_RV2CV) {
6747 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6748 op_null(cvop); /* disable rv2cv */
6749 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6750 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6751 GV *gv = cGVOPx_gv(tmpop);
6754 tmpop->op_private |= OPpEARLY_CV;
6755 else if (SvPOK(cv)) {
6756 namegv = CvANON(cv) ? gv : CvGV(cv);
6757 proto = SvPV((SV*)cv, n_a);
6761 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6762 if (o2->op_type == OP_CONST)
6763 o2->op_private &= ~OPpCONST_STRICT;
6764 else if (o2->op_type == OP_LIST) {
6765 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6766 if (o && o->op_type == OP_CONST)
6767 o->op_private &= ~OPpCONST_STRICT;
6770 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6771 if (PERLDB_SUB && PL_curstash != PL_debstash)
6772 o->op_private |= OPpENTERSUB_DB;
6773 while (o2 != cvop) {
6777 return too_many_arguments(o, gv_ename(namegv));
6795 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6797 arg == 1 ? "block or sub {}" : "sub {}",
6798 gv_ename(namegv), o2);
6801 /* '*' allows any scalar type, including bareword */
6804 if (o2->op_type == OP_RV2GV)
6805 goto wrapref; /* autoconvert GLOB -> GLOBref */
6806 else if (o2->op_type == OP_CONST)
6807 o2->op_private &= ~OPpCONST_STRICT;
6808 else if (o2->op_type == OP_ENTERSUB) {
6809 /* accidental subroutine, revert to bareword */
6810 OP *gvop = ((UNOP*)o2)->op_first;
6811 if (gvop && gvop->op_type == OP_NULL) {
6812 gvop = ((UNOP*)gvop)->op_first;
6814 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6817 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6818 (gvop = ((UNOP*)gvop)->op_first) &&
6819 gvop->op_type == OP_GV)
6821 GV *gv = cGVOPx_gv(gvop);
6822 OP *sibling = o2->op_sibling;
6823 SV *n = newSVpvn("",0);
6825 gv_fullname3(n, gv, "");
6826 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6827 sv_chop(n, SvPVX(n)+6);
6828 o2 = newSVOP(OP_CONST, 0, n);
6829 prev->op_sibling = o2;
6830 o2->op_sibling = sibling;
6846 if (contextclass++ == 0) {
6847 e = strchr(proto, ']');
6848 if (!e || e == proto)
6861 while (*--p != '[');
6862 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6863 gv_ename(namegv), o2);
6869 if (o2->op_type == OP_RV2GV)
6872 bad_type(arg, "symbol", gv_ename(namegv), o2);
6875 if (o2->op_type == OP_ENTERSUB)
6878 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6881 if (o2->op_type == OP_RV2SV ||
6882 o2->op_type == OP_PADSV ||
6883 o2->op_type == OP_HELEM ||
6884 o2->op_type == OP_AELEM ||
6885 o2->op_type == OP_THREADSV)
6888 bad_type(arg, "scalar", gv_ename(namegv), o2);
6891 if (o2->op_type == OP_RV2AV ||
6892 o2->op_type == OP_PADAV)
6895 bad_type(arg, "array", gv_ename(namegv), o2);
6898 if (o2->op_type == OP_RV2HV ||
6899 o2->op_type == OP_PADHV)
6902 bad_type(arg, "hash", gv_ename(namegv), o2);
6907 OP* sib = kid->op_sibling;
6908 kid->op_sibling = 0;
6909 o2 = newUNOP(OP_REFGEN, 0, kid);
6910 o2->op_sibling = sib;
6911 prev->op_sibling = o2;
6913 if (contextclass && e) {
6928 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6929 gv_ename(namegv), SvPV((SV*)cv, n_a));
6934 mod(o2, OP_ENTERSUB);
6936 o2 = o2->op_sibling;
6938 if (proto && !optional &&
6939 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6940 return too_few_arguments(o, gv_ename(namegv));
6945 Perl_ck_svconst(pTHX_ OP *o)
6947 SvREADONLY_on(cSVOPo->op_sv);
6952 Perl_ck_trunc(pTHX_ OP *o)
6954 if (o->op_flags & OPf_KIDS) {
6955 SVOP *kid = (SVOP*)cUNOPo->op_first;
6957 if (kid->op_type == OP_NULL)
6958 kid = (SVOP*)kid->op_sibling;
6959 if (kid && kid->op_type == OP_CONST &&
6960 (kid->op_private & OPpCONST_BARE))
6962 o->op_flags |= OPf_SPECIAL;
6963 kid->op_private &= ~OPpCONST_STRICT;
6970 Perl_ck_substr(pTHX_ OP *o)
6973 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6974 OP *kid = cLISTOPo->op_first;
6976 if (kid->op_type == OP_NULL)
6977 kid = kid->op_sibling;
6979 kid->op_flags |= OPf_MOD;
6985 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6988 Perl_peep(pTHX_ register OP *o)
6990 register OP* oldop = 0;
6993 if (!o || o->op_seq)
6997 SAVEVPTR(PL_curcop);
6998 for (; o; o = o->op_next) {
7004 switch (o->op_type) {
7008 PL_curcop = ((COP*)o); /* for warnings */
7009 o->op_seq = PL_op_seqmax++;
7013 if (cSVOPo->op_private & OPpCONST_STRICT)
7014 no_bareword_allowed(o);
7016 /* Relocate sv to the pad for thread safety.
7017 * Despite being a "constant", the SV is written to,
7018 * for reference counts, sv_upgrade() etc. */
7020 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7021 if (SvPADTMP(cSVOPo->op_sv)) {
7022 /* If op_sv is already a PADTMP then it is being used by
7023 * some pad, so make a copy. */
7024 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
7025 SvREADONLY_on(PL_curpad[ix]);
7026 SvREFCNT_dec(cSVOPo->op_sv);
7029 SvREFCNT_dec(PL_curpad[ix]);
7030 SvPADTMP_on(cSVOPo->op_sv);
7031 PL_curpad[ix] = cSVOPo->op_sv;
7032 /* XXX I don't know how this isn't readonly already. */
7033 SvREADONLY_on(PL_curpad[ix]);
7035 cSVOPo->op_sv = Nullsv;
7039 o->op_seq = PL_op_seqmax++;
7043 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7044 if (o->op_next->op_private & OPpTARGET_MY) {
7045 if (o->op_flags & OPf_STACKED) /* chained concats */
7046 goto ignore_optimization;
7048 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7049 o->op_targ = o->op_next->op_targ;
7050 o->op_next->op_targ = 0;
7051 o->op_private |= OPpTARGET_MY;
7054 op_null(o->op_next);
7056 ignore_optimization:
7057 o->op_seq = PL_op_seqmax++;
7060 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7061 o->op_seq = PL_op_seqmax++;
7062 break; /* Scalar stub must produce undef. List stub is noop */
7066 if (o->op_targ == OP_NEXTSTATE
7067 || o->op_targ == OP_DBSTATE
7068 || o->op_targ == OP_SETSTATE)
7070 PL_curcop = ((COP*)o);
7072 /* XXX: We avoid setting op_seq here to prevent later calls
7073 to peep() from mistakenly concluding that optimisation
7074 has already occurred. This doesn't fix the real problem,
7075 though (See 20010220.007). AMS 20010719 */
7076 if (oldop && o->op_next) {
7077 oldop->op_next = o->op_next;
7085 if (oldop && o->op_next) {
7086 oldop->op_next = o->op_next;
7089 o->op_seq = PL_op_seqmax++;
7093 if (o->op_next->op_type == OP_RV2SV) {
7094 if (!(o->op_next->op_private & OPpDEREF)) {
7095 op_null(o->op_next);
7096 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7098 o->op_next = o->op_next->op_next;
7099 o->op_type = OP_GVSV;
7100 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7103 else if (o->op_next->op_type == OP_RV2AV) {
7104 OP* pop = o->op_next->op_next;
7106 if (pop && pop->op_type == OP_CONST &&
7107 (PL_op = pop->op_next) &&
7108 pop->op_next->op_type == OP_AELEM &&
7109 !(pop->op_next->op_private &
7110 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7111 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7116 op_null(o->op_next);
7117 op_null(pop->op_next);
7119 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7120 o->op_next = pop->op_next->op_next;
7121 o->op_type = OP_AELEMFAST;
7122 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7123 o->op_private = (U8)i;
7128 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7130 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7131 /* XXX could check prototype here instead of just carping */
7132 SV *sv = sv_newmortal();
7133 gv_efullname3(sv, gv, Nullch);
7134 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7135 "%s() called too early to check prototype",
7139 else if (o->op_next->op_type == OP_READLINE
7140 && o->op_next->op_next->op_type == OP_CONCAT
7141 && (o->op_next->op_next->op_flags & OPf_STACKED))
7143 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7144 o->op_type = OP_RCATLINE;
7145 o->op_flags |= OPf_STACKED;
7146 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7147 op_null(o->op_next->op_next);
7148 op_null(o->op_next);
7151 o->op_seq = PL_op_seqmax++;
7162 o->op_seq = PL_op_seqmax++;
7163 while (cLOGOP->op_other->op_type == OP_NULL)
7164 cLOGOP->op_other = cLOGOP->op_other->op_next;
7165 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7170 o->op_seq = PL_op_seqmax++;
7171 while (cLOOP->op_redoop->op_type == OP_NULL)
7172 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7173 peep(cLOOP->op_redoop);
7174 while (cLOOP->op_nextop->op_type == OP_NULL)
7175 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7176 peep(cLOOP->op_nextop);
7177 while (cLOOP->op_lastop->op_type == OP_NULL)
7178 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7179 peep(cLOOP->op_lastop);
7185 o->op_seq = PL_op_seqmax++;
7186 while (cPMOP->op_pmreplstart &&
7187 cPMOP->op_pmreplstart->op_type == OP_NULL)
7188 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7189 peep(cPMOP->op_pmreplstart);
7193 o->op_seq = PL_op_seqmax++;
7194 if (ckWARN(WARN_SYNTAX) && o->op_next
7195 && o->op_next->op_type == OP_NEXTSTATE) {
7196 if (o->op_next->op_sibling &&
7197 o->op_next->op_sibling->op_type != OP_EXIT &&
7198 o->op_next->op_sibling->op_type != OP_WARN &&
7199 o->op_next->op_sibling->op_type != OP_DIE) {
7200 line_t oldline = CopLINE(PL_curcop);
7202 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7203 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7204 "Statement unlikely to be reached");
7205 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7206 "\t(Maybe you meant system() when you said exec()?)\n");
7207 CopLINE_set(PL_curcop, oldline);
7216 SV **svp, **indsvp, *sv;
7221 o->op_seq = PL_op_seqmax++;
7223 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7226 /* Make the CONST have a shared SV */
7227 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7228 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7229 key = SvPV(sv, keylen);
7230 lexname = newSVpvn_share(key,
7231 SvUTF8(sv) ? -(I32)keylen : keylen,
7237 if ((o->op_private & (OPpLVAL_INTRO)))
7240 rop = (UNOP*)((BINOP*)o)->op_first;
7241 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7243 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7244 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7246 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7247 if (!fields || !GvHV(*fields))
7249 key = SvPV(*svp, keylen);
7250 indsvp = hv_fetch(GvHV(*fields), key,
7251 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7253 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7254 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7256 ind = SvIV(*indsvp);
7258 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7259 rop->op_type = OP_RV2AV;
7260 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7261 o->op_type = OP_AELEM;
7262 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7264 if (SvREADONLY(*svp))
7266 SvFLAGS(sv) |= (SvFLAGS(*svp)
7267 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7277 SV **svp, **indsvp, *sv;
7281 SVOP *first_key_op, *key_op;
7283 o->op_seq = PL_op_seqmax++;
7284 if ((o->op_private & (OPpLVAL_INTRO))
7285 /* I bet there's always a pushmark... */
7286 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7287 /* hmmm, no optimization if list contains only one key. */
7289 rop = (UNOP*)((LISTOP*)o)->op_last;
7290 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7292 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7293 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7295 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7296 if (!fields || !GvHV(*fields))
7298 /* Again guessing that the pushmark can be jumped over.... */
7299 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7300 ->op_first->op_sibling;
7301 /* Check that the key list contains only constants. */
7302 for (key_op = first_key_op; key_op;
7303 key_op = (SVOP*)key_op->op_sibling)
7304 if (key_op->op_type != OP_CONST)
7308 rop->op_type = OP_RV2AV;
7309 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7310 o->op_type = OP_ASLICE;
7311 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7312 for (key_op = first_key_op; key_op;
7313 key_op = (SVOP*)key_op->op_sibling) {
7314 svp = cSVOPx_svp(key_op);
7315 key = SvPV(*svp, keylen);
7316 indsvp = hv_fetch(GvHV(*fields), key,
7317 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7319 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7320 "in variable %s of type %s",
7321 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7323 ind = SvIV(*indsvp);
7325 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7327 if (SvREADONLY(*svp))
7329 SvFLAGS(sv) |= (SvFLAGS(*svp)
7330 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7338 o->op_seq = PL_op_seqmax++;
7348 char* Perl_custom_op_name(pTHX_ OP* o)
7350 IV index = PTR2IV(o->op_ppaddr);
7354 if (!PL_custom_op_names) /* This probably shouldn't happen */
7355 return PL_op_name[OP_CUSTOM];
7357 keysv = sv_2mortal(newSViv(index));
7359 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7361 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7363 return SvPV_nolen(HeVAL(he));
7366 char* Perl_custom_op_desc(pTHX_ OP* o)
7368 IV index = PTR2IV(o->op_ppaddr);
7372 if (!PL_custom_op_descs)
7373 return PL_op_desc[OP_CUSTOM];
7375 keysv = sv_2mortal(newSViv(index));
7377 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7379 return PL_op_desc[OP_CUSTOM];
7381 return SvPV_nolen(HeVAL(he));
7387 /* Efficient sub that returns a constant scalar value. */
7389 const_sv_xsub(pTHX_ CV* cv)
7394 Perl_croak(aTHX_ "usage: %s::%s()",
7395 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7399 ST(0) = (SV*)XSANY.any_ptr;