3 * Copyright (c) 1991-2001, 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
23 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
25 /* #define PL_OP_SLAB_ALLOC */
27 #ifdef PL_OP_SLAB_ALLOC
28 #define SLAB_SIZE 8192
29 static char *PL_OpPtr = NULL;
30 static int PL_OpSpace = 0;
31 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
32 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
34 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
40 Newz(m,PL_OpPtr,SLAB_SIZE,char);
41 PL_OpSpace = SLAB_SIZE - sz;
42 return PL_OpPtr += PL_OpSpace;
46 #define NewOp(m, var, c, type) Newz(m, var, c, type)
49 * In the following definition, the ", Nullop" is just to make the compiler
50 * think the expression is of the right type: croak actually does a Siglongjmp.
52 #define CHECKOP(type,o) \
53 ((PL_op_mask && PL_op_mask[type]) \
54 ? ( op_free((OP*)o), \
55 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
57 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
59 #define PAD_MAX 999999999
60 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
63 S_gv_ename(pTHX_ GV *gv)
66 SV* tmpsv = sv_newmortal();
67 gv_efullname3(tmpsv, gv, Nullch);
68 return SvPV(tmpsv,n_a);
72 S_no_fh_allowed(pTHX_ OP *o)
74 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
80 S_too_few_arguments(pTHX_ OP *o, char *name)
82 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
87 S_too_many_arguments(pTHX_ OP *o, char *name)
89 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
94 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
96 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
97 (int)n, name, t, OP_DESC(kid)));
101 S_no_bareword_allowed(pTHX_ OP *o)
103 qerror(Perl_mess(aTHX_
104 "Bareword \"%s\" not allowed while \"strict subs\" in use",
105 SvPV_nolen(cSVOPo_sv)));
108 /* "register" allocation */
111 Perl_pad_allocmy(pTHX_ char *name)
116 if (!(PL_in_my == KEY_our ||
118 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
119 (name[1] == '_' && (int)strlen(name) > 2)))
121 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
122 /* 1999-02-27 mjd@plover.com */
124 p = strchr(name, '\0');
125 /* The next block assumes the buffer is at least 205 chars
126 long. At present, it's always at least 256 chars. */
128 strcpy(name+200, "...");
134 /* Move everything else down one character */
135 for (; p-name > 2; p--)
137 name[2] = toCTRL(name[1]);
140 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
142 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
143 SV **svp = AvARRAY(PL_comppad_name);
144 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
145 PADOFFSET top = AvFILLp(PL_comppad_name);
146 for (off = top; off > PL_comppad_name_floor; off--) {
148 && sv != &PL_sv_undef
149 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
150 && (PL_in_my != KEY_our
151 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
152 && strEQ(name, SvPVX(sv)))
154 Perl_warner(aTHX_ WARN_MISC,
155 "\"%s\" variable %s masks earlier declaration in same %s",
156 (PL_in_my == KEY_our ? "our" : "my"),
158 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
163 if (PL_in_my == KEY_our) {
166 && sv != &PL_sv_undef
167 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
168 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
169 && strEQ(name, SvPVX(sv)))
171 Perl_warner(aTHX_ WARN_MISC,
172 "\"our\" variable %s redeclared", name);
173 Perl_warner(aTHX_ WARN_MISC,
174 "\t(Did you mean \"local\" instead of \"our\"?)\n");
177 } while ( off-- > 0 );
180 off = pad_alloc(OP_PADSV, SVs_PADMY);
182 sv_upgrade(sv, SVt_PVNV);
184 if (PL_in_my_stash) {
186 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
187 name, PL_in_my == KEY_our ? "our" : "my"));
188 SvFLAGS(sv) |= SVpad_TYPED;
189 (void)SvUPGRADE(sv, SVt_PVMG);
190 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
192 if (PL_in_my == KEY_our) {
193 (void)SvUPGRADE(sv, SVt_PVGV);
194 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
195 SvFLAGS(sv) |= SVpad_OUR;
197 av_store(PL_comppad_name, off, sv);
198 SvNVX(sv) = (NV)PAD_MAX;
199 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
200 if (!PL_min_intro_pending)
201 PL_min_intro_pending = off;
202 PL_max_intro_pending = off;
204 av_store(PL_comppad, off, (SV*)newAV());
205 else if (*name == '%')
206 av_store(PL_comppad, off, (SV*)newHV());
207 SvPADMY_on(PL_curpad[off]);
212 S_pad_addlex(pTHX_ SV *proto_namesv)
214 SV *namesv = NEWSV(1103,0);
215 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
216 sv_upgrade(namesv, SVt_PVNV);
217 sv_setpv(namesv, SvPVX(proto_namesv));
218 av_store(PL_comppad_name, newoff, namesv);
219 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
220 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
221 SvFAKE_on(namesv); /* A ref, not a real var */
222 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
223 SvFLAGS(namesv) |= SVpad_OUR;
224 (void)SvUPGRADE(namesv, SVt_PVGV);
225 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
227 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
228 SvFLAGS(namesv) |= SVpad_TYPED;
229 (void)SvUPGRADE(namesv, SVt_PVMG);
230 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
235 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
238 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
239 I32 cx_ix, I32 saweval, U32 flags)
245 register PERL_CONTEXT *cx;
247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
252 if (!svp || *svp == &PL_sv_undef)
255 svp = AvARRAY(curname);
256 for (off = AvFILLp(curname); off > 0; off--) {
257 if ((sv = svp[off]) &&
258 sv != &PL_sv_undef &&
260 seq > I_32(SvNVX(sv)) &&
261 strEQ(SvPVX(sv), name))
272 return 0; /* don't clone from inactive stack frame */
276 oldpad = (AV*)AvARRAY(curlist)[depth];
277 oldsv = *av_fetch(oldpad, off, TRUE);
278 if (!newoff) { /* Not a mere clone operation. */
279 newoff = pad_addlex(sv);
280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
281 /* "It's closures all the way down." */
282 CvCLONE_on(PL_compcv);
284 if (CvANON(PL_compcv))
285 oldsv = Nullsv; /* no need to keep ref */
290 bcv && bcv != cv && !CvCLONE(bcv);
291 bcv = CvOUTSIDE(bcv))
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
314 Perl_warner(aTHX_ WARN_CLOSURE,
315 "Variable \"%s\" may be unavailable",
323 else if (!CvUNIQUE(PL_compcv)) {
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
327 Perl_warner(aTHX_ WARN_CLOSURE,
328 "Variable \"%s\" will not stay shared", name);
332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
338 if (flags & FINDLEX_NOSEARCH)
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
346 for (i = cx_ix; i >= 0; i--) {
348 switch (CxTYPE(cx)) {
350 if (i == 0 && saweval) {
351 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
355 switch (cx->blk_eval.old_op_type) {
357 if (CxREALEVAL(cx)) {
360 seq = cxstack[i].blk_oldcop->cop_seq;
361 startcv = cxstack[i].blk_eval.cv;
362 if (startcv && CvOUTSIDE(startcv)) {
363 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
365 if (off) /* continue looking if not found here */
372 /* require/do must have their own scope */
381 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
382 saweval = i; /* so we know where we were called from */
383 seq = cxstack[i].blk_oldcop->cop_seq;
386 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
394 Perl_pad_findmy(pTHX_ char *name)
399 SV **svp = AvARRAY(PL_comppad_name);
400 U32 seq = PL_cop_seqmax;
404 #ifdef USE_5005THREADS
406 * Special case to get lexical (and hence per-thread) @_.
407 * XXX I need to find out how to tell at parse-time whether use
408 * of @_ should refer to a lexical (from a sub) or defgv (global
409 * scope and maybe weird sub-ish things like formats). See
410 * startsub in perly.y. It's possible that @_ could be lexical
411 * (at least from subs) even in non-threaded perl.
413 if (strEQ(name, "@_"))
414 return 0; /* success. (NOT_IN_PAD indicates failure) */
415 #endif /* USE_5005THREADS */
417 /* The one we're looking for is probably just before comppad_name_fill. */
418 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
419 if ((sv = svp[off]) &&
420 sv != &PL_sv_undef &&
423 seq > I_32(SvNVX(sv)))) &&
424 strEQ(SvPVX(sv), name))
426 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
427 return (PADOFFSET)off;
428 pendoff = off; /* this pending def. will override import */
432 outside = CvOUTSIDE(PL_compcv);
434 /* Check if if we're compiling an eval'', and adjust seq to be the
435 * eval's seq number. This depends on eval'' having a non-null
436 * CvOUTSIDE() while it is being compiled. The eval'' itself is
437 * identified by CvEVAL being true and CvGV being null. */
438 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
439 cx = &cxstack[cxstack_ix];
441 seq = cx->blk_oldcop->cop_seq;
444 /* See if it's in a nested scope */
445 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
447 /* If there is a pending local definition, this new alias must die */
449 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
450 return off; /* pad_findlex returns 0 for failure...*/
452 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
456 Perl_pad_leavemy(pTHX_ I32 fill)
459 SV **svp = AvARRAY(PL_comppad_name);
461 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
462 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
463 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
464 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
467 /* "Deintroduce" my variables that are leaving with this scope. */
468 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
469 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
470 SvIVX(sv) = PL_cop_seqmax;
475 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
480 if (AvARRAY(PL_comppad) != PL_curpad)
481 Perl_croak(aTHX_ "panic: pad_alloc");
482 if (PL_pad_reset_pending)
484 if (tmptype & SVs_PADMY) {
486 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
487 } while (SvPADBUSY(sv)); /* need a fresh one */
488 retval = AvFILLp(PL_comppad);
491 SV **names = AvARRAY(PL_comppad_name);
492 SSize_t names_fill = AvFILLp(PL_comppad_name);
495 * "foreach" index vars temporarily become aliases to non-"my"
496 * values. Thus we must skip, not just pad values that are
497 * marked as current pad values, but also those with names.
499 if (++PL_padix <= names_fill &&
500 (sv = names[PL_padix]) && sv != &PL_sv_undef)
502 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
503 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
504 !IS_PADGV(sv) && !IS_PADCONST(sv))
509 SvFLAGS(sv) |= tmptype;
510 PL_curpad = AvARRAY(PL_comppad);
511 #ifdef USE_5005THREADS
512 DEBUG_X(PerlIO_printf(Perl_debug_log,
513 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
514 PTR2UV(thr), PTR2UV(PL_curpad),
515 (long) retval, PL_op_name[optype]));
517 DEBUG_X(PerlIO_printf(Perl_debug_log,
518 "Pad 0x%"UVxf" alloc %ld for %s\n",
520 (long) retval, PL_op_name[optype]));
521 #endif /* USE_5005THREADS */
522 return (PADOFFSET)retval;
526 Perl_pad_sv(pTHX_ PADOFFSET po)
528 #ifdef USE_5005THREADS
529 DEBUG_X(PerlIO_printf(Perl_debug_log,
530 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
531 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
534 Perl_croak(aTHX_ "panic: pad_sv po");
535 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
536 PTR2UV(PL_curpad), (IV)po));
537 #endif /* USE_5005THREADS */
538 return PL_curpad[po]; /* eventually we'll turn this into a macro */
542 Perl_pad_free(pTHX_ PADOFFSET po)
546 if (AvARRAY(PL_comppad) != PL_curpad)
547 Perl_croak(aTHX_ "panic: pad_free curpad");
549 Perl_croak(aTHX_ "panic: pad_free po");
550 #ifdef USE_5005THREADS
551 DEBUG_X(PerlIO_printf(Perl_debug_log,
552 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
553 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
555 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
556 PTR2UV(PL_curpad), (IV)po));
557 #endif /* USE_5005THREADS */
558 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
559 SvPADTMP_off(PL_curpad[po]);
561 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
564 if ((I32)po < PL_padix)
569 Perl_pad_swipe(pTHX_ PADOFFSET po)
571 if (AvARRAY(PL_comppad) != PL_curpad)
572 Perl_croak(aTHX_ "panic: pad_swipe curpad");
574 Perl_croak(aTHX_ "panic: pad_swipe po");
575 #ifdef USE_5005THREADS
576 DEBUG_X(PerlIO_printf(Perl_debug_log,
577 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
580 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
581 PTR2UV(PL_curpad), (IV)po));
582 #endif /* USE_5005THREADS */
583 SvPADTMP_off(PL_curpad[po]);
584 PL_curpad[po] = NEWSV(1107,0);
585 SvPADTMP_on(PL_curpad[po]);
586 if ((I32)po < PL_padix)
590 /* XXX pad_reset() is currently disabled because it results in serious bugs.
591 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
592 * on the stack by OPs that use them, there are several ways to get an alias
593 * to a shared TARG. Such an alias will change randomly and unpredictably.
594 * We avoid doing this until we can think of a Better Way.
599 #ifdef USE_BROKEN_PAD_RESET
602 if (AvARRAY(PL_comppad) != PL_curpad)
603 Perl_croak(aTHX_ "panic: pad_reset curpad");
604 #ifdef USE_5005THREADS
605 DEBUG_X(PerlIO_printf(Perl_debug_log,
606 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
607 PTR2UV(thr), PTR2UV(PL_curpad)));
609 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
611 #endif /* USE_5005THREADS */
612 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
613 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
614 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
615 SvPADTMP_off(PL_curpad[po]);
617 PL_padix = PL_padix_floor;
620 PL_pad_reset_pending = FALSE;
623 #ifdef USE_5005THREADS
624 /* find_threadsv is not reentrant */
626 Perl_find_threadsv(pTHX_ const char *name)
631 /* We currently only handle names of a single character */
632 p = strchr(PL_threadsv_names, *name);
635 key = p - PL_threadsv_names;
636 MUTEX_LOCK(&thr->mutex);
637 svp = av_fetch(thr->threadsv, key, FALSE);
639 MUTEX_UNLOCK(&thr->mutex);
641 SV *sv = NEWSV(0, 0);
642 av_store(thr->threadsv, key, sv);
643 thr->threadsvp = AvARRAY(thr->threadsv);
644 MUTEX_UNLOCK(&thr->mutex);
646 * Some magic variables used to be automagically initialised
647 * in gv_fetchpv. Those which are now per-thread magicals get
648 * initialised here instead.
654 sv_setpv(sv, "\034");
655 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
660 PL_sawampersand = TRUE;
674 /* XXX %! tied to Errno.pm needs to be added here.
675 * See gv_fetchpv(). */
679 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
681 DEBUG_S(PerlIO_printf(Perl_error_log,
682 "find_threadsv: new SV %p for $%s%c\n",
683 sv, (*name < 32) ? "^" : "",
684 (*name < 32) ? toCTRL(*name) : *name));
688 #endif /* USE_5005THREADS */
693 Perl_op_free(pTHX_ OP *o)
695 register OP *kid, *nextkid;
698 if (!o || o->op_seq == (U16)-1)
701 if (o->op_private & OPpREFCOUNTED) {
702 switch (o->op_type) {
710 if (OpREFCNT_dec(o)) {
721 if (o->op_flags & OPf_KIDS) {
722 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
723 nextkid = kid->op_sibling; /* Get before next freeing kid */
731 /* COP* is not cleared by op_clear() so that we may track line
732 * numbers etc even after null() */
733 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
738 #ifdef PL_OP_SLAB_ALLOC
739 if ((char *) o == PL_OpPtr)
748 Perl_op_clear(pTHX_ OP *o)
751 switch (o->op_type) {
752 case OP_NULL: /* Was holding old type, if any. */
753 case OP_ENTEREVAL: /* Was holding hints. */
754 #ifdef USE_5005THREADS
755 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
759 #ifdef USE_5005THREADS
761 if (!(o->op_flags & OPf_SPECIAL))
764 #endif /* USE_5005THREADS */
766 if (!(o->op_flags & OPf_REF)
767 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
774 if (cPADOPo->op_padix > 0) {
777 pad_swipe(cPADOPo->op_padix);
778 /* No GvIN_PAD_off(gv) here, because other references may still
779 * exist on the pad */
782 cPADOPo->op_padix = 0;
785 SvREFCNT_dec(cSVOPo->op_sv);
786 cSVOPo->op_sv = Nullsv;
789 case OP_METHOD_NAMED:
791 SvREFCNT_dec(cSVOPo->op_sv);
792 cSVOPo->op_sv = Nullsv;
798 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
802 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
803 SvREFCNT_dec(cSVOPo->op_sv);
804 cSVOPo->op_sv = Nullsv;
807 Safefree(cPVOPo->op_pv);
808 cPVOPo->op_pv = Nullch;
812 op_free(cPMOPo->op_pmreplroot);
816 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
818 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
819 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
820 /* No GvIN_PAD_off(gv) here, because other references may still
821 * exist on the pad */
826 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
833 HV *pmstash = PmopSTASH(cPMOPo);
834 if (pmstash && SvREFCNT(pmstash)) {
835 PMOP *pmop = HvPMROOT(pmstash);
836 PMOP *lastpmop = NULL;
838 if (cPMOPo == pmop) {
840 lastpmop->op_pmnext = pmop->op_pmnext;
842 HvPMROOT(pmstash) = pmop->op_pmnext;
846 pmop = pmop->op_pmnext;
850 Safefree(PmopSTASHPV(cPMOPo));
852 /* NOTE: PMOP.op_pmstash is not refcounted */
855 cPMOPo->op_pmreplroot = Nullop;
856 /* we use the "SAFE" version of the PM_ macros here
857 * since sv_clean_all might release some PMOPs
858 * after PL_regex_padav has been cleared
859 * and the clearing of PL_regex_padav needs to
860 * happen before sv_clean_all
862 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
863 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
865 if(PL_regex_pad) { /* We could be in destruction */
866 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
867 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
868 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
875 if (o->op_targ > 0) {
876 pad_free(o->op_targ);
882 S_cop_free(pTHX_ COP* cop)
884 Safefree(cop->cop_label);
886 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
887 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
889 /* NOTE: COP.cop_stash is not refcounted */
890 SvREFCNT_dec(CopFILEGV(cop));
892 if (! specialWARN(cop->cop_warnings))
893 SvREFCNT_dec(cop->cop_warnings);
894 if (! specialCopIO(cop->cop_io))
895 SvREFCNT_dec(cop->cop_io);
899 Perl_op_null(pTHX_ OP *o)
901 if (o->op_type == OP_NULL)
904 o->op_targ = o->op_type;
905 o->op_type = OP_NULL;
906 o->op_ppaddr = PL_ppaddr[OP_NULL];
909 /* Contextualizers */
911 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
914 Perl_linklist(pTHX_ OP *o)
921 /* establish postfix order */
922 if (cUNOPo->op_first) {
923 o->op_next = LINKLIST(cUNOPo->op_first);
924 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
926 kid->op_next = LINKLIST(kid->op_sibling);
938 Perl_scalarkids(pTHX_ OP *o)
941 if (o && o->op_flags & OPf_KIDS) {
942 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
949 S_scalarboolean(pTHX_ OP *o)
951 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
952 if (ckWARN(WARN_SYNTAX)) {
953 line_t oldline = CopLINE(PL_curcop);
955 if (PL_copline != NOLINE)
956 CopLINE_set(PL_curcop, PL_copline);
957 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
958 CopLINE_set(PL_curcop, oldline);
965 Perl_scalar(pTHX_ OP *o)
969 /* assumes no premature commitment */
970 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
971 || o->op_type == OP_RETURN)
976 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
978 switch (o->op_type) {
980 scalar(cBINOPo->op_first);
985 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
989 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
990 if (!kPMOP->op_pmreplroot)
991 deprecate("implicit split to @_");
999 if (o->op_flags & OPf_KIDS) {
1000 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1006 kid = cLISTOPo->op_first;
1008 while ((kid = kid->op_sibling)) {
1009 if (kid->op_sibling)
1014 WITH_THR(PL_curcop = &PL_compiling);
1019 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1020 if (kid->op_sibling)
1025 WITH_THR(PL_curcop = &PL_compiling);
1032 Perl_scalarvoid(pTHX_ OP *o)
1039 if (o->op_type == OP_NEXTSTATE
1040 || o->op_type == OP_SETSTATE
1041 || o->op_type == OP_DBSTATE
1042 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1043 || o->op_targ == OP_SETSTATE
1044 || o->op_targ == OP_DBSTATE)))
1045 PL_curcop = (COP*)o; /* for warning below */
1047 /* assumes no premature commitment */
1048 want = o->op_flags & OPf_WANT;
1049 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1050 || o->op_type == OP_RETURN)
1055 if ((o->op_private & OPpTARGET_MY)
1056 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1058 return scalar(o); /* As if inside SASSIGN */
1061 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1063 switch (o->op_type) {
1065 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1069 if (o->op_flags & OPf_STACKED)
1073 if (o->op_private == 4)
1115 case OP_GETSOCKNAME:
1116 case OP_GETPEERNAME:
1121 case OP_GETPRIORITY:
1144 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1145 useless = OP_DESC(o);
1152 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1153 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1154 useless = "a variable";
1159 if (cSVOPo->op_private & OPpCONST_STRICT)
1160 no_bareword_allowed(o);
1162 if (ckWARN(WARN_VOID)) {
1163 useless = "a constant";
1164 /* the constants 0 and 1 are permitted as they are
1165 conventionally used as dummies in constructs like
1166 1 while some_condition_with_side_effects; */
1167 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1169 else if (SvPOK(sv)) {
1170 /* perl4's way of mixing documentation and code
1171 (before the invention of POD) was based on a
1172 trick to mix nroff and perl code. The trick was
1173 built upon these three nroff macros being used in
1174 void context. The pink camel has the details in
1175 the script wrapman near page 319. */
1176 if (strnEQ(SvPVX(sv), "di", 2) ||
1177 strnEQ(SvPVX(sv), "ds", 2) ||
1178 strnEQ(SvPVX(sv), "ig", 2))
1183 op_null(o); /* don't execute or even remember it */
1187 o->op_type = OP_PREINC; /* pre-increment is faster */
1188 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1192 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1193 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1199 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1204 if (o->op_flags & OPf_STACKED)
1211 if (!(o->op_flags & OPf_KIDS))
1220 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1227 /* all requires must return a boolean value */
1228 o->op_flags &= ~OPf_WANT;
1233 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1234 if (!kPMOP->op_pmreplroot)
1235 deprecate("implicit split to @_");
1239 if (useless && ckWARN(WARN_VOID))
1240 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1245 Perl_listkids(pTHX_ OP *o)
1248 if (o && o->op_flags & OPf_KIDS) {
1249 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1256 Perl_list(pTHX_ OP *o)
1260 /* assumes no premature commitment */
1261 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1262 || o->op_type == OP_RETURN)
1267 if ((o->op_private & OPpTARGET_MY)
1268 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1270 return o; /* As if inside SASSIGN */
1273 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1275 switch (o->op_type) {
1278 list(cBINOPo->op_first);
1283 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1291 if (!(o->op_flags & OPf_KIDS))
1293 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1294 list(cBINOPo->op_first);
1295 return gen_constant_list(o);
1302 kid = cLISTOPo->op_first;
1304 while ((kid = kid->op_sibling)) {
1305 if (kid->op_sibling)
1310 WITH_THR(PL_curcop = &PL_compiling);
1314 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1315 if (kid->op_sibling)
1320 WITH_THR(PL_curcop = &PL_compiling);
1323 /* all requires must return a boolean value */
1324 o->op_flags &= ~OPf_WANT;
1331 Perl_scalarseq(pTHX_ OP *o)
1336 if (o->op_type == OP_LINESEQ ||
1337 o->op_type == OP_SCOPE ||
1338 o->op_type == OP_LEAVE ||
1339 o->op_type == OP_LEAVETRY)
1341 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1342 if (kid->op_sibling) {
1346 PL_curcop = &PL_compiling;
1348 o->op_flags &= ~OPf_PARENS;
1349 if (PL_hints & HINT_BLOCK_SCOPE)
1350 o->op_flags |= OPf_PARENS;
1353 o = newOP(OP_STUB, 0);
1358 S_modkids(pTHX_ OP *o, I32 type)
1361 if (o && o->op_flags & OPf_KIDS) {
1362 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1369 Perl_mod(pTHX_ OP *o, I32 type)
1374 if (!o || PL_error_count)
1377 if ((o->op_private & OPpTARGET_MY)
1378 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1383 switch (o->op_type) {
1388 if (!(o->op_private & (OPpCONST_ARYBASE)))
1390 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1391 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1395 SAVEI32(PL_compiling.cop_arybase);
1396 PL_compiling.cop_arybase = 0;
1398 else if (type == OP_REFGEN)
1401 Perl_croak(aTHX_ "That use of $[ is unsupported");
1404 if (o->op_flags & OPf_PARENS)
1408 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1409 !(o->op_flags & OPf_STACKED)) {
1410 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1411 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1412 assert(cUNOPo->op_first->op_type == OP_NULL);
1413 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1416 else { /* lvalue subroutine call */
1417 o->op_private |= OPpLVAL_INTRO;
1418 PL_modcount = RETURN_UNLIMITED_NUMBER;
1419 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1420 /* Backward compatibility mode: */
1421 o->op_private |= OPpENTERSUB_INARGS;
1424 else { /* Compile-time error message: */
1425 OP *kid = cUNOPo->op_first;
1429 if (kid->op_type == OP_PUSHMARK)
1431 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1433 "panic: unexpected lvalue entersub "
1434 "args: type/targ %ld:%ld",
1435 (long)kid->op_type,kid->op_targ);
1436 kid = kLISTOP->op_first;
1438 while (kid->op_sibling)
1439 kid = kid->op_sibling;
1440 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1442 if (kid->op_type == OP_METHOD_NAMED
1443 || kid->op_type == OP_METHOD)
1447 if (kid->op_sibling || kid->op_next != kid) {
1448 yyerror("panic: unexpected optree near method call");
1452 NewOp(1101, newop, 1, UNOP);
1453 newop->op_type = OP_RV2CV;
1454 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1455 newop->op_first = Nullop;
1456 newop->op_next = (OP*)newop;
1457 kid->op_sibling = (OP*)newop;
1458 newop->op_private |= OPpLVAL_INTRO;
1462 if (kid->op_type != OP_RV2CV)
1464 "panic: unexpected lvalue entersub "
1465 "entry via type/targ %ld:%ld",
1466 (long)kid->op_type,kid->op_targ);
1467 kid->op_private |= OPpLVAL_INTRO;
1468 break; /* Postpone until runtime */
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1474 kid = kUNOP->op_first;
1475 if (kid->op_type == OP_NULL)
1477 "Unexpected constant lvalue entersub "
1478 "entry via type/targ %ld:%ld",
1479 (long)kid->op_type,kid->op_targ);
1480 if (kid->op_type != OP_GV) {
1481 /* Restore RV2CV to check lvalueness */
1483 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1484 okid->op_next = kid->op_next;
1485 kid->op_next = okid;
1488 okid->op_next = Nullop;
1489 okid->op_type = OP_RV2CV;
1491 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1492 okid->op_private |= OPpLVAL_INTRO;
1496 cv = GvCV(kGVOP_gv);
1506 /* grep, foreach, subcalls, refgen */
1507 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1509 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1510 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1512 : (o->op_type == OP_ENTERSUB
1513 ? "non-lvalue subroutine call"
1515 type ? PL_op_desc[type] : "local"));
1529 case OP_RIGHT_SHIFT:
1538 if (!(o->op_flags & OPf_STACKED))
1544 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1550 if (!type && cUNOPo->op_first->op_type != OP_GV)
1551 Perl_croak(aTHX_ "Can't localize through a reference");
1552 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1553 PL_modcount = RETURN_UNLIMITED_NUMBER;
1554 return o; /* Treat \(@foo) like ordinary list. */
1558 if (scalar_mod_type(o, type))
1560 ref(cUNOPo->op_first, o->op_type);
1564 if (type == OP_LEAVESUBLV)
1565 o->op_private |= OPpMAYBE_LVSUB;
1571 PL_modcount = RETURN_UNLIMITED_NUMBER;
1574 if (!type && cUNOPo->op_first->op_type != OP_GV)
1575 Perl_croak(aTHX_ "Can't localize through a reference");
1576 ref(cUNOPo->op_first, o->op_type);
1580 PL_hints |= HINT_BLOCK_SCOPE;
1590 PL_modcount = RETURN_UNLIMITED_NUMBER;
1591 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1592 return o; /* Treat \(@foo) like ordinary list. */
1593 if (scalar_mod_type(o, type))
1595 if (type == OP_LEAVESUBLV)
1596 o->op_private |= OPpMAYBE_LVSUB;
1601 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1602 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1605 #ifdef USE_5005THREADS
1607 PL_modcount++; /* XXX ??? */
1609 #endif /* USE_5005THREADS */
1615 if (type != OP_SASSIGN)
1619 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1624 if (type == OP_LEAVESUBLV)
1625 o->op_private |= OPpMAYBE_LVSUB;
1627 pad_free(o->op_targ);
1628 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1629 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1630 if (o->op_flags & OPf_KIDS)
1631 mod(cBINOPo->op_first->op_sibling, type);
1636 ref(cBINOPo->op_first, o->op_type);
1637 if (type == OP_ENTERSUB &&
1638 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1639 o->op_private |= OPpLVAL_DEFER;
1640 if (type == OP_LEAVESUBLV)
1641 o->op_private |= OPpMAYBE_LVSUB;
1649 if (o->op_flags & OPf_KIDS)
1650 mod(cLISTOPo->op_last, type);
1654 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1656 else if (!(o->op_flags & OPf_KIDS))
1658 if (o->op_targ != OP_LIST) {
1659 mod(cBINOPo->op_first, type);
1664 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1669 if (type != OP_LEAVESUBLV)
1671 break; /* mod()ing was handled by ck_return() */
1673 if (type != OP_LEAVESUBLV)
1674 o->op_flags |= OPf_MOD;
1676 if (type == OP_AASSIGN || type == OP_SASSIGN)
1677 o->op_flags |= OPf_SPECIAL|OPf_REF;
1679 o->op_private |= OPpLVAL_INTRO;
1680 o->op_flags &= ~OPf_SPECIAL;
1681 PL_hints |= HINT_BLOCK_SCOPE;
1683 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1684 && type != OP_LEAVESUBLV)
1685 o->op_flags |= OPf_REF;
1690 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1694 if (o->op_type == OP_RV2GV)
1718 case OP_RIGHT_SHIFT:
1737 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1739 switch (o->op_type) {
1747 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1760 Perl_refkids(pTHX_ OP *o, I32 type)
1763 if (o && o->op_flags & OPf_KIDS) {
1764 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1771 Perl_ref(pTHX_ OP *o, I32 type)
1775 if (!o || PL_error_count)
1778 switch (o->op_type) {
1780 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1781 !(o->op_flags & OPf_STACKED)) {
1782 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1783 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1784 assert(cUNOPo->op_first->op_type == OP_NULL);
1785 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1786 o->op_flags |= OPf_SPECIAL;
1791 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1795 if (type == OP_DEFINED)
1796 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1797 ref(cUNOPo->op_first, o->op_type);
1800 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1801 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1802 : type == OP_RV2HV ? OPpDEREF_HV
1804 o->op_flags |= OPf_MOD;
1809 o->op_flags |= OPf_MOD; /* XXX ??? */
1814 o->op_flags |= OPf_REF;
1817 if (type == OP_DEFINED)
1818 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1819 ref(cUNOPo->op_first, o->op_type);
1824 o->op_flags |= OPf_REF;
1829 if (!(o->op_flags & OPf_KIDS))
1831 ref(cBINOPo->op_first, type);
1835 ref(cBINOPo->op_first, o->op_type);
1836 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1837 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1838 : type == OP_RV2HV ? OPpDEREF_HV
1840 o->op_flags |= OPf_MOD;
1848 if (!(o->op_flags & OPf_KIDS))
1850 ref(cLISTOPo->op_last, type);
1860 S_dup_attrlist(pTHX_ OP *o)
1864 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1865 * where the first kid is OP_PUSHMARK and the remaining ones
1866 * are OP_CONST. We need to push the OP_CONST values.
1868 if (o->op_type == OP_CONST)
1869 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1871 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1872 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1873 if (o->op_type == OP_CONST)
1874 rop = append_elem(OP_LIST, rop,
1875 newSVOP(OP_CONST, o->op_flags,
1876 SvREFCNT_inc(cSVOPo->op_sv)));
1883 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1887 /* fake up C<use attributes $pkg,$rv,@attrs> */
1888 ENTER; /* need to protect against side-effects of 'use' */
1891 stashsv = newSVpv(HvNAME(stash), 0);
1893 stashsv = &PL_sv_no;
1895 #define ATTRSMODULE "attributes"
1897 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1898 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1900 prepend_elem(OP_LIST,
1901 newSVOP(OP_CONST, 0, stashsv),
1902 prepend_elem(OP_LIST,
1903 newSVOP(OP_CONST, 0,
1905 dup_attrlist(attrs))));
1910 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1911 char *attrstr, STRLEN len)
1916 len = strlen(attrstr);
1920 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1922 char *sstr = attrstr;
1923 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1924 attrs = append_elem(OP_LIST, attrs,
1925 newSVOP(OP_CONST, 0,
1926 newSVpvn(sstr, attrstr-sstr)));
1930 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1931 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1932 Nullsv, prepend_elem(OP_LIST,
1933 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1934 prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0,
1941 S_my_kid(pTHX_ OP *o, OP *attrs)
1946 if (!o || PL_error_count)
1950 if (type == OP_LIST) {
1951 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1953 } else if (type == OP_UNDEF) {
1955 } else if (type == OP_RV2SV || /* "our" declaration */
1957 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1959 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1961 PL_in_my_stash = Nullhv;
1962 apply_attrs(GvSTASH(gv),
1963 (type == OP_RV2SV ? GvSV(gv) :
1964 type == OP_RV2AV ? (SV*)GvAV(gv) :
1965 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1968 o->op_private |= OPpOUR_INTRO;
1970 } else if (type != OP_PADSV &&
1973 type != OP_PUSHMARK)
1975 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1977 PL_in_my == KEY_our ? "our" : "my"));
1980 else if (attrs && type != OP_PUSHMARK) {
1986 PL_in_my_stash = Nullhv;
1988 /* check for C<my Dog $spot> when deciding package */
1989 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1990 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1991 stash = SvSTASH(*namesvp);
1993 stash = PL_curstash;
1994 padsv = PAD_SV(o->op_targ);
1995 apply_attrs(stash, padsv, attrs);
1997 o->op_flags |= OPf_MOD;
1998 o->op_private |= OPpLVAL_INTRO;
2003 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2005 if (o->op_flags & OPf_PARENS)
2009 o = my_kid(o, attrs);
2011 PL_in_my_stash = Nullhv;
2016 Perl_my(pTHX_ OP *o)
2018 return my_kid(o, Nullop);
2022 Perl_sawparens(pTHX_ OP *o)
2025 o->op_flags |= OPf_PARENS;
2030 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2034 if (ckWARN(WARN_MISC) &&
2035 (left->op_type == OP_RV2AV ||
2036 left->op_type == OP_RV2HV ||
2037 left->op_type == OP_PADAV ||
2038 left->op_type == OP_PADHV)) {
2039 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2040 right->op_type == OP_TRANS)
2041 ? right->op_type : OP_MATCH];
2042 const char *sample = ((left->op_type == OP_RV2AV ||
2043 left->op_type == OP_PADAV)
2044 ? "@array" : "%hash");
2045 Perl_warner(aTHX_ WARN_MISC,
2046 "Applying %s to %s will act on scalar(%s)",
2047 desc, sample, sample);
2050 if (!(right->op_flags & OPf_STACKED) &&
2051 (right->op_type == OP_MATCH ||
2052 right->op_type == OP_SUBST ||
2053 right->op_type == OP_TRANS)) {
2054 right->op_flags |= OPf_STACKED;
2055 if ((right->op_type != OP_MATCH &&
2056 ! (right->op_type == OP_TRANS &&
2057 right->op_private & OPpTRANS_IDENTICAL)) ||
2058 /* if SV has magic, then match on original SV, not on its copy.
2059 see note in pp_helem() */
2060 (right->op_type == OP_MATCH &&
2061 (left->op_type == OP_AELEM ||
2062 left->op_type == OP_HELEM ||
2063 left->op_type == OP_AELEMFAST)))
2064 left = mod(left, right->op_type);
2065 if (right->op_type == OP_TRANS)
2066 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2068 o = prepend_elem(right->op_type, scalar(left), right);
2070 return newUNOP(OP_NOT, 0, scalar(o));
2074 return bind_match(type, left,
2075 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2079 Perl_invert(pTHX_ OP *o)
2083 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2084 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2088 Perl_scope(pTHX_ OP *o)
2091 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2092 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2093 o->op_type = OP_LEAVE;
2094 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2097 if (o->op_type == OP_LINESEQ) {
2099 o->op_type = OP_SCOPE;
2100 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2101 kid = ((LISTOP*)o)->op_first;
2102 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2106 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2113 Perl_save_hints(pTHX)
2116 SAVESPTR(GvHV(PL_hintgv));
2117 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2118 SAVEFREESV(GvHV(PL_hintgv));
2122 Perl_block_start(pTHX_ int full)
2124 int retval = PL_savestack_ix;
2126 SAVEI32(PL_comppad_name_floor);
2127 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2129 PL_comppad_name_fill = PL_comppad_name_floor;
2130 if (PL_comppad_name_floor < 0)
2131 PL_comppad_name_floor = 0;
2132 SAVEI32(PL_min_intro_pending);
2133 SAVEI32(PL_max_intro_pending);
2134 PL_min_intro_pending = 0;
2135 SAVEI32(PL_comppad_name_fill);
2136 SAVEI32(PL_padix_floor);
2137 PL_padix_floor = PL_padix;
2138 PL_pad_reset_pending = FALSE;
2140 PL_hints &= ~HINT_BLOCK_SCOPE;
2141 SAVESPTR(PL_compiling.cop_warnings);
2142 if (! specialWARN(PL_compiling.cop_warnings)) {
2143 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2144 SAVEFREESV(PL_compiling.cop_warnings) ;
2146 SAVESPTR(PL_compiling.cop_io);
2147 if (! specialCopIO(PL_compiling.cop_io)) {
2148 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2149 SAVEFREESV(PL_compiling.cop_io) ;
2155 Perl_block_end(pTHX_ I32 floor, OP *seq)
2157 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2158 line_t copline = PL_copline;
2159 /* there should be a nextstate in every block */
2160 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2161 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2163 PL_pad_reset_pending = FALSE;
2164 PL_compiling.op_private = PL_hints;
2166 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2167 pad_leavemy(PL_comppad_name_fill);
2175 #ifdef USE_5005THREADS
2176 OP *o = newOP(OP_THREADSV, 0);
2177 o->op_targ = find_threadsv("_");
2180 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2181 #endif /* USE_5005THREADS */
2185 Perl_newPROG(pTHX_ OP *o)
2190 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2191 ((PL_in_eval & EVAL_KEEPERR)
2192 ? OPf_SPECIAL : 0), o);
2193 PL_eval_start = linklist(PL_eval_root);
2194 PL_eval_root->op_private |= OPpREFCOUNTED;
2195 OpREFCNT_set(PL_eval_root, 1);
2196 PL_eval_root->op_next = 0;
2197 CALL_PEEP(PL_eval_start);
2202 PL_main_root = scope(sawparens(scalarvoid(o)));
2203 PL_curcop = &PL_compiling;
2204 PL_main_start = LINKLIST(PL_main_root);
2205 PL_main_root->op_private |= OPpREFCOUNTED;
2206 OpREFCNT_set(PL_main_root, 1);
2207 PL_main_root->op_next = 0;
2208 CALL_PEEP(PL_main_start);
2211 /* Register with debugger */
2213 CV *cv = get_cv("DB::postponed", FALSE);
2217 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2219 call_sv((SV*)cv, G_DISCARD);
2226 Perl_localize(pTHX_ OP *o, I32 lex)
2228 if (o->op_flags & OPf_PARENS)
2231 if (ckWARN(WARN_PARENTHESIS)
2232 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2234 char *s = PL_bufptr;
2236 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2239 if (*s == ';' || *s == '=')
2240 Perl_warner(aTHX_ WARN_PARENTHESIS,
2241 "Parentheses missing around \"%s\" list",
2242 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2248 o = mod(o, OP_NULL); /* a bit kludgey */
2250 PL_in_my_stash = Nullhv;
2255 Perl_jmaybe(pTHX_ OP *o)
2257 if (o->op_type == OP_LIST) {
2259 #ifdef USE_5005THREADS
2260 o2 = newOP(OP_THREADSV, 0);
2261 o2->op_targ = find_threadsv(";");
2263 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2264 #endif /* USE_5005THREADS */
2265 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2271 Perl_fold_constants(pTHX_ register OP *o)
2274 I32 type = o->op_type;
2277 if (PL_opargs[type] & OA_RETSCALAR)
2279 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2280 o->op_targ = pad_alloc(type, SVs_PADTMP);
2282 /* integerize op, unless it happens to be C<-foo>.
2283 * XXX should pp_i_negate() do magic string negation instead? */
2284 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2285 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2286 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2288 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2291 if (!(PL_opargs[type] & OA_FOLDCONST))
2296 /* XXX might want a ck_negate() for this */
2297 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2309 /* XXX what about the numeric ops? */
2310 if (PL_hints & HINT_LOCALE)
2315 goto nope; /* Don't try to run w/ errors */
2317 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2318 if ((curop->op_type != OP_CONST ||
2319 (curop->op_private & OPpCONST_BARE)) &&
2320 curop->op_type != OP_LIST &&
2321 curop->op_type != OP_SCALAR &&
2322 curop->op_type != OP_NULL &&
2323 curop->op_type != OP_PUSHMARK)
2329 curop = LINKLIST(o);
2333 sv = *(PL_stack_sp--);
2334 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2335 pad_swipe(o->op_targ);
2336 else if (SvTEMP(sv)) { /* grab mortal temp? */
2337 (void)SvREFCNT_inc(sv);
2341 if (type == OP_RV2GV)
2342 return newGVOP(OP_GV, 0, (GV*)sv);
2344 /* try to smush double to int, but don't smush -2.0 to -2 */
2345 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2348 #ifdef PERL_PRESERVE_IVUV
2349 /* Only bother to attempt to fold to IV if
2350 most operators will benefit */
2354 return newSVOP(OP_CONST, 0, sv);
2358 if (!(PL_opargs[type] & OA_OTHERINT))
2361 if (!(PL_hints & HINT_INTEGER)) {
2362 if (type == OP_MODULO
2363 || type == OP_DIVIDE
2364 || !(o->op_flags & OPf_KIDS))
2369 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2370 if (curop->op_type == OP_CONST) {
2371 if (SvIOK(((SVOP*)curop)->op_sv))
2375 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2379 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2386 Perl_gen_constant_list(pTHX_ register OP *o)
2389 I32 oldtmps_floor = PL_tmps_floor;
2393 return o; /* Don't attempt to run with errors */
2395 PL_op = curop = LINKLIST(o);
2402 PL_tmps_floor = oldtmps_floor;
2404 o->op_type = OP_RV2AV;
2405 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2406 curop = ((UNOP*)o)->op_first;
2407 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2414 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2416 if (!o || o->op_type != OP_LIST)
2417 o = newLISTOP(OP_LIST, 0, o, Nullop);
2419 o->op_flags &= ~OPf_WANT;
2421 if (!(PL_opargs[type] & OA_MARK))
2422 op_null(cLISTOPo->op_first);
2425 o->op_ppaddr = PL_ppaddr[type];
2426 o->op_flags |= flags;
2428 o = CHECKOP(type, o);
2429 if (o->op_type != type)
2432 return fold_constants(o);
2435 /* List constructors */
2438 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2446 if (first->op_type != type
2447 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2449 return newLISTOP(type, 0, first, last);
2452 if (first->op_flags & OPf_KIDS)
2453 ((LISTOP*)first)->op_last->op_sibling = last;
2455 first->op_flags |= OPf_KIDS;
2456 ((LISTOP*)first)->op_first = last;
2458 ((LISTOP*)first)->op_last = last;
2463 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2471 if (first->op_type != type)
2472 return prepend_elem(type, (OP*)first, (OP*)last);
2474 if (last->op_type != type)
2475 return append_elem(type, (OP*)first, (OP*)last);
2477 first->op_last->op_sibling = last->op_first;
2478 first->op_last = last->op_last;
2479 first->op_flags |= (last->op_flags & OPf_KIDS);
2481 #ifdef PL_OP_SLAB_ALLOC
2489 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2497 if (last->op_type == type) {
2498 if (type == OP_LIST) { /* already a PUSHMARK there */
2499 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2500 ((LISTOP*)last)->op_first->op_sibling = first;
2501 if (!(first->op_flags & OPf_PARENS))
2502 last->op_flags &= ~OPf_PARENS;
2505 if (!(last->op_flags & OPf_KIDS)) {
2506 ((LISTOP*)last)->op_last = first;
2507 last->op_flags |= OPf_KIDS;
2509 first->op_sibling = ((LISTOP*)last)->op_first;
2510 ((LISTOP*)last)->op_first = first;
2512 last->op_flags |= OPf_KIDS;
2516 return newLISTOP(type, 0, first, last);
2522 Perl_newNULLLIST(pTHX)
2524 return newOP(OP_STUB, 0);
2528 Perl_force_list(pTHX_ OP *o)
2530 if (!o || o->op_type != OP_LIST)
2531 o = newLISTOP(OP_LIST, 0, o, Nullop);
2537 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2541 NewOp(1101, listop, 1, LISTOP);
2543 listop->op_type = type;
2544 listop->op_ppaddr = PL_ppaddr[type];
2547 listop->op_flags = flags;
2551 else if (!first && last)
2554 first->op_sibling = last;
2555 listop->op_first = first;
2556 listop->op_last = last;
2557 if (type == OP_LIST) {
2559 pushop = newOP(OP_PUSHMARK, 0);
2560 pushop->op_sibling = first;
2561 listop->op_first = pushop;
2562 listop->op_flags |= OPf_KIDS;
2564 listop->op_last = pushop;
2571 Perl_newOP(pTHX_ I32 type, I32 flags)
2574 NewOp(1101, o, 1, OP);
2576 o->op_ppaddr = PL_ppaddr[type];
2577 o->op_flags = flags;
2580 o->op_private = 0 + (flags >> 8);
2581 if (PL_opargs[type] & OA_RETSCALAR)
2583 if (PL_opargs[type] & OA_TARGET)
2584 o->op_targ = pad_alloc(type, SVs_PADTMP);
2585 return CHECKOP(type, o);
2589 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2594 first = newOP(OP_STUB, 0);
2595 if (PL_opargs[type] & OA_MARK)
2596 first = force_list(first);
2598 NewOp(1101, unop, 1, UNOP);
2599 unop->op_type = type;
2600 unop->op_ppaddr = PL_ppaddr[type];
2601 unop->op_first = first;
2602 unop->op_flags = flags | OPf_KIDS;
2603 unop->op_private = 1 | (flags >> 8);
2604 unop = (UNOP*) CHECKOP(type, unop);
2608 return fold_constants((OP *) unop);
2612 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2615 NewOp(1101, binop, 1, BINOP);
2618 first = newOP(OP_NULL, 0);
2620 binop->op_type = type;
2621 binop->op_ppaddr = PL_ppaddr[type];
2622 binop->op_first = first;
2623 binop->op_flags = flags | OPf_KIDS;
2626 binop->op_private = 1 | (flags >> 8);
2629 binop->op_private = 2 | (flags >> 8);
2630 first->op_sibling = last;
2633 binop = (BINOP*)CHECKOP(type, binop);
2634 if (binop->op_next || binop->op_type != type)
2637 binop->op_last = binop->op_first->op_sibling;
2639 return fold_constants((OP *)binop);
2643 uvcompare(const void *a, const void *b)
2645 if (*((UV *)a) < (*(UV *)b))
2647 if (*((UV *)a) > (*(UV *)b))
2649 if (*((UV *)a+1) < (*(UV *)b+1))
2651 if (*((UV *)a+1) > (*(UV *)b+1))
2657 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2659 SV *tstr = ((SVOP*)expr)->op_sv;
2660 SV *rstr = ((SVOP*)repl)->op_sv;
2663 U8 *t = (U8*)SvPV(tstr, tlen);
2664 U8 *r = (U8*)SvPV(rstr, rlen);
2671 register short *tbl;
2673 PL_hints |= HINT_BLOCK_SCOPE;
2674 complement = o->op_private & OPpTRANS_COMPLEMENT;
2675 del = o->op_private & OPpTRANS_DELETE;
2676 squash = o->op_private & OPpTRANS_SQUASH;
2679 o->op_private |= OPpTRANS_FROM_UTF;
2682 o->op_private |= OPpTRANS_TO_UTF;
2684 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2685 SV* listsv = newSVpvn("# comment\n",10);
2687 U8* tend = t + tlen;
2688 U8* rend = r + rlen;
2702 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2703 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2709 tsave = t = bytes_to_utf8(t, &len);
2712 if (!to_utf && rlen) {
2714 rsave = r = bytes_to_utf8(r, &len);
2718 /* There are several snags with this code on EBCDIC:
2719 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2720 2. scan_const() in toke.c has encoded chars in native encoding which makes
2721 ranges at least in EBCDIC 0..255 range the bottom odd.
2725 U8 tmpbuf[UTF8_MAXLEN+1];
2728 New(1109, cp, 2*tlen, UV);
2730 transv = newSVpvn("",0);
2732 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2734 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2736 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2740 cp[2*i+1] = cp[2*i];
2744 qsort(cp, i, 2*sizeof(UV), uvcompare);
2745 for (j = 0; j < i; j++) {
2747 diff = val - nextmin;
2749 t = uvuni_to_utf8(tmpbuf,nextmin);
2750 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2752 U8 range_mark = UTF_TO_NATIVE(0xff);
2753 t = uvuni_to_utf8(tmpbuf, val - 1);
2754 sv_catpvn(transv, (char *)&range_mark, 1);
2755 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2762 t = uvuni_to_utf8(tmpbuf,nextmin);
2763 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2765 U8 range_mark = UTF_TO_NATIVE(0xff);
2766 sv_catpvn(transv, (char *)&range_mark, 1);
2768 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2769 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2770 t = (U8*)SvPVX(transv);
2771 tlen = SvCUR(transv);
2775 else if (!rlen && !del) {
2776 r = t; rlen = tlen; rend = tend;
2779 if ((!rlen && !del) || t == r ||
2780 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2782 o->op_private |= OPpTRANS_IDENTICAL;
2786 while (t < tend || tfirst <= tlast) {
2787 /* see if we need more "t" chars */
2788 if (tfirst > tlast) {
2789 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2791 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2793 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2800 /* now see if we need more "r" chars */
2801 if (rfirst > rlast) {
2803 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2805 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2807 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2816 rfirst = rlast = 0xffffffff;
2820 /* now see which range will peter our first, if either. */
2821 tdiff = tlast - tfirst;
2822 rdiff = rlast - rfirst;
2829 if (rfirst == 0xffffffff) {
2830 diff = tdiff; /* oops, pretend rdiff is infinite */
2832 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2833 (long)tfirst, (long)tlast);
2835 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2839 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2840 (long)tfirst, (long)(tfirst + diff),
2843 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2844 (long)tfirst, (long)rfirst);
2846 if (rfirst + diff > max)
2847 max = rfirst + diff;
2849 grows = (tfirst < rfirst &&
2850 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2862 else if (max > 0xff)
2867 Safefree(cPVOPo->op_pv);
2868 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2869 SvREFCNT_dec(listsv);
2871 SvREFCNT_dec(transv);
2873 if (!del && havefinal && rlen)
2874 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2875 newSVuv((UV)final), 0);
2878 o->op_private |= OPpTRANS_GROWS;
2890 tbl = (short*)cPVOPo->op_pv;
2892 Zero(tbl, 256, short);
2893 for (i = 0; i < tlen; i++)
2895 for (i = 0, j = 0; i < 256; i++) {
2906 if (i < 128 && r[j] >= 128)
2916 o->op_private |= OPpTRANS_IDENTICAL;
2921 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2922 tbl[0x100] = rlen - j;
2923 for (i=0; i < rlen - j; i++)
2924 tbl[0x101+i] = r[j+i];
2928 if (!rlen && !del) {
2931 o->op_private |= OPpTRANS_IDENTICAL;
2933 for (i = 0; i < 256; i++)
2935 for (i = 0, j = 0; i < tlen; i++,j++) {
2938 if (tbl[t[i]] == -1)
2944 if (tbl[t[i]] == -1) {
2945 if (t[i] < 128 && r[j] >= 128)
2952 o->op_private |= OPpTRANS_GROWS;
2960 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2964 NewOp(1101, pmop, 1, PMOP);
2965 pmop->op_type = type;
2966 pmop->op_ppaddr = PL_ppaddr[type];
2967 pmop->op_flags = flags;
2968 pmop->op_private = 0 | (flags >> 8);
2970 if (PL_hints & HINT_RE_TAINT)
2971 pmop->op_pmpermflags |= PMf_RETAINT;
2972 if (PL_hints & HINT_LOCALE)
2973 pmop->op_pmpermflags |= PMf_LOCALE;
2974 pmop->op_pmflags = pmop->op_pmpermflags;
2979 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2980 repointer = av_pop((AV*)PL_regex_pad[0]);
2981 pmop->op_pmoffset = SvIV(repointer);
2982 SvREPADTMP_off(repointer);
2983 sv_setiv(repointer,0);
2985 repointer = newSViv(0);
2986 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2987 pmop->op_pmoffset = av_len(PL_regex_padav);
2988 PL_regex_pad = AvARRAY(PL_regex_padav);
2993 /* link into pm list */
2994 if (type != OP_TRANS && PL_curstash) {
2995 pmop->op_pmnext = HvPMROOT(PL_curstash);
2996 HvPMROOT(PL_curstash) = pmop;
2997 PmopSTASH_set(pmop,PL_curstash);
3004 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3008 I32 repl_has_vars = 0;
3010 if (o->op_type == OP_TRANS)
3011 return pmtrans(o, expr, repl);
3013 PL_hints |= HINT_BLOCK_SCOPE;
3016 if (expr->op_type == OP_CONST) {
3018 SV *pat = ((SVOP*)expr)->op_sv;
3019 char *p = SvPV(pat, plen);
3020 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3021 sv_setpvn(pat, "\\s+", 3);
3022 p = SvPV(pat, plen);
3023 pm->op_pmflags |= PMf_SKIPWHITE;
3025 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3026 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3027 pm->op_pmflags |= PMf_WHITE;
3031 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3032 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3034 : OP_REGCMAYBE),0,expr);
3036 NewOp(1101, rcop, 1, LOGOP);
3037 rcop->op_type = OP_REGCOMP;
3038 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3039 rcop->op_first = scalar(expr);
3040 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3041 ? (OPf_SPECIAL | OPf_KIDS)
3043 rcop->op_private = 1;
3046 /* establish postfix order */
3047 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3049 rcop->op_next = expr;
3050 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3053 rcop->op_next = LINKLIST(expr);
3054 expr->op_next = (OP*)rcop;
3057 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3062 if (pm->op_pmflags & PMf_EVAL) {
3064 if (CopLINE(PL_curcop) < PL_multi_end)
3065 CopLINE_set(PL_curcop, PL_multi_end);
3067 #ifdef USE_5005THREADS
3068 else if (repl->op_type == OP_THREADSV
3069 && strchr("&`'123456789+",
3070 PL_threadsv_names[repl->op_targ]))
3074 #endif /* USE_5005THREADS */
3075 else if (repl->op_type == OP_CONST)
3079 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3080 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3081 #ifdef USE_5005THREADS
3082 if (curop->op_type == OP_THREADSV) {
3084 if (strchr("&`'123456789+", curop->op_private))
3088 if (curop->op_type == OP_GV) {
3089 GV *gv = cGVOPx_gv(curop);
3091 if (strchr("&`'123456789+", *GvENAME(gv)))
3094 #endif /* USE_5005THREADS */
3095 else if (curop->op_type == OP_RV2CV)
3097 else if (curop->op_type == OP_RV2SV ||
3098 curop->op_type == OP_RV2AV ||
3099 curop->op_type == OP_RV2HV ||
3100 curop->op_type == OP_RV2GV) {
3101 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3104 else if (curop->op_type == OP_PADSV ||
3105 curop->op_type == OP_PADAV ||
3106 curop->op_type == OP_PADHV ||
3107 curop->op_type == OP_PADANY) {
3110 else if (curop->op_type == OP_PUSHRE)
3111 ; /* Okay here, dangerous in newASSIGNOP */
3121 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3122 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3123 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3124 prepend_elem(o->op_type, scalar(repl), o);
3127 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3128 pm->op_pmflags |= PMf_MAYBE_CONST;
3129 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3131 NewOp(1101, rcop, 1, LOGOP);
3132 rcop->op_type = OP_SUBSTCONT;
3133 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3134 rcop->op_first = scalar(repl);
3135 rcop->op_flags |= OPf_KIDS;
3136 rcop->op_private = 1;
3139 /* establish postfix order */
3140 rcop->op_next = LINKLIST(repl);
3141 repl->op_next = (OP*)rcop;
3143 pm->op_pmreplroot = scalar((OP*)rcop);
3144 pm->op_pmreplstart = LINKLIST(rcop);
3153 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3156 NewOp(1101, svop, 1, SVOP);
3157 svop->op_type = type;
3158 svop->op_ppaddr = PL_ppaddr[type];
3160 svop->op_next = (OP*)svop;
3161 svop->op_flags = flags;
3162 if (PL_opargs[type] & OA_RETSCALAR)
3164 if (PL_opargs[type] & OA_TARGET)
3165 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3166 return CHECKOP(type, svop);
3170 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3173 NewOp(1101, padop, 1, PADOP);
3174 padop->op_type = type;
3175 padop->op_ppaddr = PL_ppaddr[type];
3176 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3177 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3178 PL_curpad[padop->op_padix] = sv;
3180 padop->op_next = (OP*)padop;
3181 padop->op_flags = flags;
3182 if (PL_opargs[type] & OA_RETSCALAR)
3184 if (PL_opargs[type] & OA_TARGET)
3185 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3186 return CHECKOP(type, padop);
3190 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3194 return newPADOP(type, flags, SvREFCNT_inc(gv));
3196 return newSVOP(type, flags, SvREFCNT_inc(gv));
3201 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3204 NewOp(1101, pvop, 1, PVOP);
3205 pvop->op_type = type;
3206 pvop->op_ppaddr = PL_ppaddr[type];
3208 pvop->op_next = (OP*)pvop;
3209 pvop->op_flags = flags;
3210 if (PL_opargs[type] & OA_RETSCALAR)
3212 if (PL_opargs[type] & OA_TARGET)
3213 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3214 return CHECKOP(type, pvop);
3218 Perl_package(pTHX_ OP *o)
3222 save_hptr(&PL_curstash);
3223 save_item(PL_curstname);
3228 name = SvPV(sv, len);
3229 PL_curstash = gv_stashpvn(name,len,TRUE);
3230 sv_setpvn(PL_curstname, name, len);
3234 deprecate("\"package\" with no arguments");
3235 sv_setpv(PL_curstname,"<none>");
3236 PL_curstash = Nullhv;
3238 PL_hints |= HINT_BLOCK_SCOPE;
3239 PL_copline = NOLINE;
3244 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3249 char *packname = Nullch;
3253 if (id->op_type != OP_CONST)
3254 Perl_croak(aTHX_ "Module name must be constant");
3258 if (version != Nullop) {
3259 SV *vesv = ((SVOP*)version)->op_sv;
3261 if (arg == Nullop && !SvNIOKp(vesv)) {
3268 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3269 Perl_croak(aTHX_ "Version number must be constant number");
3271 /* Make copy of id so we don't free it twice */
3272 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3274 /* Fake up a method call to VERSION */
3275 meth = newSVpvn("VERSION",7);
3276 sv_upgrade(meth, SVt_PVIV);
3277 (void)SvIOK_on(meth);
3278 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3279 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3280 append_elem(OP_LIST,
3281 prepend_elem(OP_LIST, pack, list(version)),
3282 newSVOP(OP_METHOD_NAMED, 0, meth)));
3286 /* Fake up an import/unimport */
3287 if (arg && arg->op_type == OP_STUB)
3288 imop = arg; /* no import on explicit () */
3289 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3290 imop = Nullop; /* use 5.0; */
3295 /* Make copy of id so we don't free it twice */
3296 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3298 /* Fake up a method call to import/unimport */
3299 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3300 sv_upgrade(meth, SVt_PVIV);
3301 (void)SvIOK_on(meth);
3302 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3303 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3304 append_elem(OP_LIST,
3305 prepend_elem(OP_LIST, pack, list(arg)),
3306 newSVOP(OP_METHOD_NAMED, 0, meth)));
3309 if (ckWARN(WARN_MISC) &&
3310 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3311 SvPOK(packsv = ((SVOP*)id)->op_sv))
3313 /* BEGIN will free the ops, so we need to make a copy */
3314 packlen = SvCUR(packsv);
3315 packname = savepvn(SvPVX(packsv), packlen);
3318 /* Fake up the BEGIN {}, which does its thing immediately. */
3320 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3323 append_elem(OP_LINESEQ,
3324 append_elem(OP_LINESEQ,
3325 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3326 newSTATEOP(0, Nullch, veop)),
3327 newSTATEOP(0, Nullch, imop) ));
3330 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3331 Perl_warner(aTHX_ WARN_MISC,
3332 "Package `%s' not found "
3333 "(did you use the incorrect case?)", packname);
3338 PL_hints |= HINT_BLOCK_SCOPE;
3339 PL_copline = NOLINE;
3344 =for apidoc load_module
3346 Loads the module whose name is pointed to by the string part of name.
3347 Note that the actual module name, not its filename, should be given.
3348 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3349 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3350 (or 0 for no flags). ver, if specified, provides version semantics
3351 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3352 arguments can be used to specify arguments to the module's import()
3353 method, similar to C<use Foo::Bar VERSION LIST>.
3358 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3361 va_start(args, ver);
3362 vload_module(flags, name, ver, &args);
3366 #ifdef PERL_IMPLICIT_CONTEXT
3368 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3372 va_start(args, ver);
3373 vload_module(flags, name, ver, &args);
3379 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3381 OP *modname, *veop, *imop;
3383 modname = newSVOP(OP_CONST, 0, name);
3384 modname->op_private |= OPpCONST_BARE;
3386 veop = newSVOP(OP_CONST, 0, ver);
3390 if (flags & PERL_LOADMOD_NOIMPORT) {
3391 imop = sawparens(newNULLLIST());
3393 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3394 imop = va_arg(*args, OP*);
3399 sv = va_arg(*args, SV*);
3401 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3402 sv = va_arg(*args, SV*);
3406 line_t ocopline = PL_copline;
3407 int oexpect = PL_expect;
3409 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3410 veop, modname, imop);
3411 PL_expect = oexpect;
3412 PL_copline = ocopline;
3417 Perl_dofile(pTHX_ OP *term)
3422 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3423 if (!(gv && GvIMPORTED_CV(gv)))
3424 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3426 if (gv && GvIMPORTED_CV(gv)) {
3427 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3428 append_elem(OP_LIST, term,
3429 scalar(newUNOP(OP_RV2CV, 0,
3434 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3440 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3442 return newBINOP(OP_LSLICE, flags,
3443 list(force_list(subscript)),
3444 list(force_list(listval)) );
3448 S_list_assignment(pTHX_ register OP *o)
3453 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3454 o = cUNOPo->op_first;
3456 if (o->op_type == OP_COND_EXPR) {
3457 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3458 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3463 yyerror("Assignment to both a list and a scalar");
3467 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3468 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3469 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3472 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3475 if (o->op_type == OP_RV2SV)
3482 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3487 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3488 return newLOGOP(optype, 0,
3489 mod(scalar(left), optype),
3490 newUNOP(OP_SASSIGN, 0, scalar(right)));
3493 return newBINOP(optype, OPf_STACKED,
3494 mod(scalar(left), optype), scalar(right));
3498 if (list_assignment(left)) {
3502 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3503 left = mod(left, OP_AASSIGN);
3511 curop = list(force_list(left));
3512 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3513 o->op_private = 0 | (flags >> 8);
3514 for (curop = ((LISTOP*)curop)->op_first;
3515 curop; curop = curop->op_sibling)
3517 if (curop->op_type == OP_RV2HV &&
3518 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3519 o->op_private |= OPpASSIGN_HASH;
3523 if (!(left->op_private & OPpLVAL_INTRO)) {
3526 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3527 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3528 if (curop->op_type == OP_GV) {
3529 GV *gv = cGVOPx_gv(curop);
3530 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3532 SvCUR(gv) = PL_generation;
3534 else if (curop->op_type == OP_PADSV ||
3535 curop->op_type == OP_PADAV ||
3536 curop->op_type == OP_PADHV ||
3537 curop->op_type == OP_PADANY) {
3538 SV **svp = AvARRAY(PL_comppad_name);
3539 SV *sv = svp[curop->op_targ];
3540 if (SvCUR(sv) == PL_generation)
3542 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3544 else if (curop->op_type == OP_RV2CV)
3546 else if (curop->op_type == OP_RV2SV ||
3547 curop->op_type == OP_RV2AV ||
3548 curop->op_type == OP_RV2HV ||
3549 curop->op_type == OP_RV2GV) {
3550 if (lastop->op_type != OP_GV) /* funny deref? */
3553 else if (curop->op_type == OP_PUSHRE) {
3554 if (((PMOP*)curop)->op_pmreplroot) {
3556 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3558 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3560 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3562 SvCUR(gv) = PL_generation;
3571 o->op_private |= OPpASSIGN_COMMON;
3573 if (right && right->op_type == OP_SPLIT) {
3575 if ((tmpop = ((LISTOP*)right)->op_first) &&
3576 tmpop->op_type == OP_PUSHRE)
3578 PMOP *pm = (PMOP*)tmpop;
3579 if (left->op_type == OP_RV2AV &&
3580 !(left->op_private & OPpLVAL_INTRO) &&
3581 !(o->op_private & OPpASSIGN_COMMON) )
3583 tmpop = ((UNOP*)left)->op_first;
3584 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3586 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3587 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3589 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3590 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3592 pm->op_pmflags |= PMf_ONCE;
3593 tmpop = cUNOPo->op_first; /* to list (nulled) */
3594 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3595 tmpop->op_sibling = Nullop; /* don't free split */
3596 right->op_next = tmpop->op_next; /* fix starting loc */
3597 op_free(o); /* blow off assign */
3598 right->op_flags &= ~OPf_WANT;
3599 /* "I don't know and I don't care." */
3604 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3605 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3607 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3609 sv_setiv(sv, PL_modcount+1);
3617 right = newOP(OP_UNDEF, 0);
3618 if (right->op_type == OP_READLINE) {
3619 right->op_flags |= OPf_STACKED;
3620 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3623 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3624 o = newBINOP(OP_SASSIGN, flags,
3625 scalar(right), mod(scalar(left), OP_SASSIGN) );
3637 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3639 U32 seq = intro_my();
3642 NewOp(1101, cop, 1, COP);
3643 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3644 cop->op_type = OP_DBSTATE;
3645 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3648 cop->op_type = OP_NEXTSTATE;
3649 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3651 cop->op_flags = flags;
3652 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3654 cop->op_private |= NATIVE_HINTS;
3656 PL_compiling.op_private = cop->op_private;
3657 cop->op_next = (OP*)cop;
3660 cop->cop_label = label;
3661 PL_hints |= HINT_BLOCK_SCOPE;
3664 cop->cop_arybase = PL_curcop->cop_arybase;
3665 if (specialWARN(PL_curcop->cop_warnings))
3666 cop->cop_warnings = PL_curcop->cop_warnings ;
3668 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3669 if (specialCopIO(PL_curcop->cop_io))
3670 cop->cop_io = PL_curcop->cop_io;
3672 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3675 if (PL_copline == NOLINE)
3676 CopLINE_set(cop, CopLINE(PL_curcop));
3678 CopLINE_set(cop, PL_copline);
3679 PL_copline = NOLINE;
3682 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3684 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3686 CopSTASH_set(cop, PL_curstash);
3688 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3689 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3690 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3691 (void)SvIOK_on(*svp);
3692 SvIVX(*svp) = PTR2IV(cop);
3696 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3699 /* "Introduce" my variables to visible status. */
3707 if (! PL_min_intro_pending)
3708 return PL_cop_seqmax;
3710 svp = AvARRAY(PL_comppad_name);
3711 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3712 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3713 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3714 SvNVX(sv) = (NV)PL_cop_seqmax;
3717 PL_min_intro_pending = 0;
3718 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3719 return PL_cop_seqmax++;
3723 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3725 return new_logop(type, flags, &first, &other);
3729 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3733 OP *first = *firstp;
3734 OP *other = *otherp;
3736 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3737 return newBINOP(type, flags, scalar(first), scalar(other));
3739 scalarboolean(first);
3740 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3741 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3742 if (type == OP_AND || type == OP_OR) {
3748 first = *firstp = cUNOPo->op_first;
3750 first->op_next = o->op_next;
3751 cUNOPo->op_first = Nullop;
3755 if (first->op_type == OP_CONST) {
3756 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3757 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3758 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3769 else if (first->op_type == OP_WANTARRAY) {
3775 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3776 OP *k1 = ((UNOP*)first)->op_first;
3777 OP *k2 = k1->op_sibling;
3779 switch (first->op_type)
3782 if (k2 && k2->op_type == OP_READLINE
3783 && (k2->op_flags & OPf_STACKED)
3784 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3786 warnop = k2->op_type;
3791 if (k1->op_type == OP_READDIR
3792 || k1->op_type == OP_GLOB
3793 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3794 || k1->op_type == OP_EACH)
3796 warnop = ((k1->op_type == OP_NULL)
3797 ? k1->op_targ : k1->op_type);
3802 line_t oldline = CopLINE(PL_curcop);
3803 CopLINE_set(PL_curcop, PL_copline);
3804 Perl_warner(aTHX_ WARN_MISC,
3805 "Value of %s%s can be \"0\"; test with defined()",
3807 ((warnop == OP_READLINE || warnop == OP_GLOB)
3808 ? " construct" : "() operator"));
3809 CopLINE_set(PL_curcop, oldline);
3816 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3817 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3819 NewOp(1101, logop, 1, LOGOP);
3821 logop->op_type = type;
3822 logop->op_ppaddr = PL_ppaddr[type];
3823 logop->op_first = first;
3824 logop->op_flags = flags | OPf_KIDS;
3825 logop->op_other = LINKLIST(other);
3826 logop->op_private = 1 | (flags >> 8);
3828 /* establish postfix order */
3829 logop->op_next = LINKLIST(first);
3830 first->op_next = (OP*)logop;
3831 first->op_sibling = other;
3833 o = newUNOP(OP_NULL, 0, (OP*)logop);
3840 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3847 return newLOGOP(OP_AND, 0, first, trueop);
3849 return newLOGOP(OP_OR, 0, first, falseop);
3851 scalarboolean(first);
3852 if (first->op_type == OP_CONST) {
3853 if (SvTRUE(((SVOP*)first)->op_sv)) {
3864 else if (first->op_type == OP_WANTARRAY) {
3868 NewOp(1101, logop, 1, LOGOP);
3869 logop->op_type = OP_COND_EXPR;
3870 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3871 logop->op_first = first;
3872 logop->op_flags = flags | OPf_KIDS;
3873 logop->op_private = 1 | (flags >> 8);
3874 logop->op_other = LINKLIST(trueop);
3875 logop->op_next = LINKLIST(falseop);
3878 /* establish postfix order */
3879 start = LINKLIST(first);
3880 first->op_next = (OP*)logop;
3882 first->op_sibling = trueop;
3883 trueop->op_sibling = falseop;
3884 o = newUNOP(OP_NULL, 0, (OP*)logop);
3886 trueop->op_next = falseop->op_next = o;
3893 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3901 NewOp(1101, range, 1, LOGOP);
3903 range->op_type = OP_RANGE;
3904 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3905 range->op_first = left;
3906 range->op_flags = OPf_KIDS;
3907 leftstart = LINKLIST(left);
3908 range->op_other = LINKLIST(right);
3909 range->op_private = 1 | (flags >> 8);
3911 left->op_sibling = right;
3913 range->op_next = (OP*)range;
3914 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3915 flop = newUNOP(OP_FLOP, 0, flip);
3916 o = newUNOP(OP_NULL, 0, flop);
3918 range->op_next = leftstart;
3920 left->op_next = flip;
3921 right->op_next = flop;
3923 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3924 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3925 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3926 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3928 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3929 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3932 if (!flip->op_private || !flop->op_private)
3933 linklist(o); /* blow off optimizer unless constant */
3939 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3943 int once = block && block->op_flags & OPf_SPECIAL &&
3944 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3947 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3948 return block; /* do {} while 0 does once */
3949 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3950 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3951 expr = newUNOP(OP_DEFINED, 0,
3952 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3953 } else if (expr->op_flags & OPf_KIDS) {
3954 OP *k1 = ((UNOP*)expr)->op_first;
3955 OP *k2 = (k1) ? k1->op_sibling : NULL;
3956 switch (expr->op_type) {
3958 if (k2 && k2->op_type == OP_READLINE
3959 && (k2->op_flags & OPf_STACKED)
3960 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3961 expr = newUNOP(OP_DEFINED, 0, expr);
3965 if (k1->op_type == OP_READDIR
3966 || k1->op_type == OP_GLOB
3967 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3968 || k1->op_type == OP_EACH)
3969 expr = newUNOP(OP_DEFINED, 0, expr);
3975 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3976 o = new_logop(OP_AND, 0, &expr, &listop);
3979 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3981 if (once && o != listop)
3982 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3985 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3987 o->op_flags |= flags;
3989 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3994 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4002 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4003 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4004 expr = newUNOP(OP_DEFINED, 0,
4005 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4006 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4007 OP *k1 = ((UNOP*)expr)->op_first;
4008 OP *k2 = (k1) ? k1->op_sibling : NULL;
4009 switch (expr->op_type) {
4011 if (k2 && k2->op_type == OP_READLINE
4012 && (k2->op_flags & OPf_STACKED)
4013 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4014 expr = newUNOP(OP_DEFINED, 0, expr);
4018 if (k1->op_type == OP_READDIR
4019 || k1->op_type == OP_GLOB
4020 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4021 || k1->op_type == OP_EACH)
4022 expr = newUNOP(OP_DEFINED, 0, expr);
4028 block = newOP(OP_NULL, 0);
4030 block = scope(block);
4034 next = LINKLIST(cont);
4037 OP *unstack = newOP(OP_UNSTACK, 0);
4040 cont = append_elem(OP_LINESEQ, cont, unstack);
4041 if ((line_t)whileline != NOLINE) {
4042 PL_copline = whileline;
4043 cont = append_elem(OP_LINESEQ, cont,
4044 newSTATEOP(0, Nullch, Nullop));
4048 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4049 redo = LINKLIST(listop);
4052 PL_copline = whileline;
4054 o = new_logop(OP_AND, 0, &expr, &listop);
4055 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4056 op_free(expr); /* oops, it's a while (0) */
4058 return Nullop; /* listop already freed by new_logop */
4061 ((LISTOP*)listop)->op_last->op_next =
4062 (o == listop ? redo : LINKLIST(o));
4068 NewOp(1101,loop,1,LOOP);
4069 loop->op_type = OP_ENTERLOOP;
4070 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4071 loop->op_private = 0;
4072 loop->op_next = (OP*)loop;
4075 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4077 loop->op_redoop = redo;
4078 loop->op_lastop = o;
4079 o->op_private |= loopflags;
4082 loop->op_nextop = next;
4084 loop->op_nextop = o;
4086 o->op_flags |= flags;
4087 o->op_private |= (flags >> 8);
4092 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4100 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4101 sv->op_type = OP_RV2GV;
4102 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4104 else if (sv->op_type == OP_PADSV) { /* private variable */
4105 padoff = sv->op_targ;
4110 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4111 padoff = sv->op_targ;
4113 iterflags |= OPf_SPECIAL;
4118 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4121 #ifdef USE_5005THREADS
4122 padoff = find_threadsv("_");
4123 iterflags |= OPf_SPECIAL;
4125 sv = newGVOP(OP_GV, 0, PL_defgv);
4128 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4129 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4130 iterflags |= OPf_STACKED;
4132 else if (expr->op_type == OP_NULL &&
4133 (expr->op_flags & OPf_KIDS) &&
4134 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4136 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4137 * set the STACKED flag to indicate that these values are to be
4138 * treated as min/max values by 'pp_iterinit'.
4140 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4141 LOGOP* range = (LOGOP*) flip->op_first;
4142 OP* left = range->op_first;
4143 OP* right = left->op_sibling;
4146 range->op_flags &= ~OPf_KIDS;
4147 range->op_first = Nullop;
4149 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4150 listop->op_first->op_next = range->op_next;
4151 left->op_next = range->op_other;
4152 right->op_next = (OP*)listop;
4153 listop->op_next = listop->op_first;
4156 expr = (OP*)(listop);
4158 iterflags |= OPf_STACKED;
4161 expr = mod(force_list(expr), OP_GREPSTART);
4165 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4166 append_elem(OP_LIST, expr, scalar(sv))));
4167 assert(!loop->op_next);
4168 #ifdef PL_OP_SLAB_ALLOC
4171 NewOp(1234,tmp,1,LOOP);
4172 Copy(loop,tmp,1,LOOP);
4176 Renew(loop, 1, LOOP);
4178 loop->op_targ = padoff;
4179 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4180 PL_copline = forline;
4181 return newSTATEOP(0, label, wop);
4185 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4190 if (type != OP_GOTO || label->op_type == OP_CONST) {
4191 /* "last()" means "last" */
4192 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4193 o = newOP(type, OPf_SPECIAL);
4195 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4196 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4202 if (label->op_type == OP_ENTERSUB)
4203 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4204 o = newUNOP(type, OPf_STACKED, label);
4206 PL_hints |= HINT_BLOCK_SCOPE;
4211 Perl_cv_undef(pTHX_ CV *cv)
4213 #ifdef USE_5005THREADS
4215 MUTEX_DESTROY(CvMUTEXP(cv));
4216 Safefree(CvMUTEXP(cv));
4219 #endif /* USE_5005THREADS */
4222 if (CvFILE(cv) && !CvXSUB(cv)) {
4223 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4224 Safefree(CvFILE(cv));
4229 if (!CvXSUB(cv) && CvROOT(cv)) {
4230 #ifdef USE_5005THREADS
4231 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4232 Perl_croak(aTHX_ "Can't undef active subroutine");
4235 Perl_croak(aTHX_ "Can't undef active subroutine");
4236 #endif /* USE_5005THREADS */
4239 SAVEVPTR(PL_curpad);
4242 op_free(CvROOT(cv));
4243 CvROOT(cv) = Nullop;
4246 SvPOK_off((SV*)cv); /* forget prototype */
4248 /* Since closure prototypes have the same lifetime as the containing
4249 * CV, they don't hold a refcount on the outside CV. This avoids
4250 * the refcount loop between the outer CV (which keeps a refcount to
4251 * the closure prototype in the pad entry for pp_anoncode()) and the
4252 * closure prototype, and the ensuing memory leak. This does not
4253 * apply to closures generated within eval"", since eval"" CVs are
4254 * ephemeral. --GSAR */
4255 if (!CvANON(cv) || CvCLONED(cv)
4256 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4257 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4259 SvREFCNT_dec(CvOUTSIDE(cv));
4261 CvOUTSIDE(cv) = Nullcv;
4263 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4266 if (CvPADLIST(cv)) {
4267 /* may be during global destruction */
4268 if (SvREFCNT(CvPADLIST(cv))) {
4269 I32 i = AvFILLp(CvPADLIST(cv));
4271 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4272 SV* sv = svp ? *svp : Nullsv;
4275 if (sv == (SV*)PL_comppad_name)
4276 PL_comppad_name = Nullav;
4277 else if (sv == (SV*)PL_comppad) {
4278 PL_comppad = Nullav;
4279 PL_curpad = Null(SV**);
4283 SvREFCNT_dec((SV*)CvPADLIST(cv));
4285 CvPADLIST(cv) = Nullav;
4293 #ifdef DEBUG_CLOSURES
4295 S_cv_dump(pTHX_ CV *cv)
4298 CV *outside = CvOUTSIDE(cv);
4299 AV* padlist = CvPADLIST(cv);
4306 PerlIO_printf(Perl_debug_log,
4307 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4309 (CvANON(cv) ? "ANON"
4310 : (cv == PL_main_cv) ? "MAIN"
4311 : CvUNIQUE(cv) ? "UNIQUE"
4312 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4315 : CvANON(outside) ? "ANON"
4316 : (outside == PL_main_cv) ? "MAIN"
4317 : CvUNIQUE(outside) ? "UNIQUE"
4318 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4323 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4324 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4325 pname = AvARRAY(pad_name);
4326 ppad = AvARRAY(pad);
4328 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4329 if (SvPOK(pname[ix]))
4330 PerlIO_printf(Perl_debug_log,
4331 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4332 (int)ix, PTR2UV(ppad[ix]),
4333 SvFAKE(pname[ix]) ? "FAKE " : "",
4335 (IV)I_32(SvNVX(pname[ix])),
4338 #endif /* DEBUGGING */
4340 #endif /* DEBUG_CLOSURES */
4343 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4347 AV* protopadlist = CvPADLIST(proto);
4348 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4349 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4350 SV** pname = AvARRAY(protopad_name);
4351 SV** ppad = AvARRAY(protopad);
4352 I32 fname = AvFILLp(protopad_name);
4353 I32 fpad = AvFILLp(protopad);
4357 assert(!CvUNIQUE(proto));
4361 SAVESPTR(PL_comppad_name);
4362 SAVESPTR(PL_compcv);
4364 cv = PL_compcv = (CV*)NEWSV(1104,0);
4365 sv_upgrade((SV *)cv, SvTYPE(proto));
4366 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4369 #ifdef USE_5005THREADS
4370 New(666, CvMUTEXP(cv), 1, perl_mutex);
4371 MUTEX_INIT(CvMUTEXP(cv));
4373 #endif /* USE_5005THREADS */
4375 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4376 : savepv(CvFILE(proto));
4378 CvFILE(cv) = CvFILE(proto);
4380 CvGV(cv) = CvGV(proto);
4381 CvSTASH(cv) = CvSTASH(proto);
4382 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4383 CvSTART(cv) = CvSTART(proto);
4385 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4388 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4390 PL_comppad_name = newAV();
4391 for (ix = fname; ix >= 0; ix--)
4392 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4394 PL_comppad = newAV();
4396 comppadlist = newAV();
4397 AvREAL_off(comppadlist);
4398 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4399 av_store(comppadlist, 1, (SV*)PL_comppad);
4400 CvPADLIST(cv) = comppadlist;
4401 av_fill(PL_comppad, AvFILLp(protopad));
4402 PL_curpad = AvARRAY(PL_comppad);
4404 av = newAV(); /* will be @_ */
4406 av_store(PL_comppad, 0, (SV*)av);
4407 AvFLAGS(av) = AVf_REIFY;
4409 for (ix = fpad; ix > 0; ix--) {
4410 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4411 if (namesv && namesv != &PL_sv_undef) {
4412 char *name = SvPVX(namesv); /* XXX */
4413 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4414 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4415 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4417 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4419 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4421 else { /* our own lexical */
4424 /* anon code -- we'll come back for it */
4425 sv = SvREFCNT_inc(ppad[ix]);
4427 else if (*name == '@')
4429 else if (*name == '%')
4438 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4439 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4442 SV* sv = NEWSV(0,0);
4448 /* Now that vars are all in place, clone nested closures. */
4450 for (ix = fpad; ix > 0; ix--) {
4451 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4453 && namesv != &PL_sv_undef
4454 && !(SvFLAGS(namesv) & SVf_FAKE)
4455 && *SvPVX(namesv) == '&'
4456 && CvCLONE(ppad[ix]))
4458 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4459 SvREFCNT_dec(ppad[ix]);
4462 PL_curpad[ix] = (SV*)kid;
4466 #ifdef DEBUG_CLOSURES
4467 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4469 PerlIO_printf(Perl_debug_log, " from:\n");
4471 PerlIO_printf(Perl_debug_log, " to:\n");
4478 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4480 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4482 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4489 Perl_cv_clone(pTHX_ CV *proto)
4492 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4493 cv = cv_clone2(proto, CvOUTSIDE(proto));
4494 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4499 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4501 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4502 SV* msg = sv_newmortal();
4506 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4507 sv_setpv(msg, "Prototype mismatch:");
4509 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4511 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4512 sv_catpv(msg, " vs ");
4514 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4516 sv_catpv(msg, "none");
4517 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4521 static void const_sv_xsub(pTHX_ CV* cv);
4524 =for apidoc cv_const_sv
4526 If C<cv> is a constant sub eligible for inlining. returns the constant
4527 value returned by the sub. Otherwise, returns NULL.
4529 Constant subs can be created with C<newCONSTSUB> or as described in
4530 L<perlsub/"Constant Functions">.
4535 Perl_cv_const_sv(pTHX_ CV *cv)
4537 if (!cv || !CvCONST(cv))
4539 return (SV*)CvXSUBANY(cv).any_ptr;
4543 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4550 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4551 o = cLISTOPo->op_first->op_sibling;
4553 for (; o; o = o->op_next) {
4554 OPCODE type = o->op_type;
4556 if (sv && o->op_next == o)
4558 if (o->op_next != o) {
4559 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4561 if (type == OP_DBSTATE)
4564 if (type == OP_LEAVESUB || type == OP_RETURN)
4568 if (type == OP_CONST && cSVOPo->op_sv)
4570 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4571 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4572 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4576 /* We get here only from cv_clone2() while creating a closure.
4577 Copy the const value here instead of in cv_clone2 so that
4578 SvREADONLY_on doesn't lead to problems when leaving
4583 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4595 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4605 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4609 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4611 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4615 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4621 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4626 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4627 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4628 SV *sv = sv_newmortal();
4629 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4630 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4635 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4636 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4646 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4647 maximum a prototype before. */
4648 if (SvTYPE(gv) > SVt_NULL) {
4649 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4650 && ckWARN_d(WARN_PROTOTYPE))
4652 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4654 cv_ckproto((CV*)gv, NULL, ps);
4657 sv_setpv((SV*)gv, ps);
4659 sv_setiv((SV*)gv, -1);
4660 SvREFCNT_dec(PL_compcv);
4661 cv = PL_compcv = NULL;
4662 PL_sub_generation++;
4666 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4668 #ifdef GV_UNIQUE_CHECK
4669 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4670 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4674 if (!block || !ps || *ps || attrs)
4677 const_sv = op_const_sv(block, Nullcv);
4680 bool exists = CvROOT(cv) || CvXSUB(cv);
4682 #ifdef GV_UNIQUE_CHECK
4683 if (exists && GvUNIQUE(gv)) {
4684 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4688 /* if the subroutine doesn't exist and wasn't pre-declared
4689 * with a prototype, assume it will be AUTOLOADed,
4690 * skipping the prototype check
4692 if (exists || SvPOK(cv))
4693 cv_ckproto(cv, gv, ps);
4694 /* already defined (or promised)? */
4695 if (exists || GvASSUMECV(gv)) {
4696 if (!block && !attrs) {
4697 /* just a "sub foo;" when &foo is already defined */
4698 SAVEFREESV(PL_compcv);
4701 /* ahem, death to those who redefine active sort subs */
4702 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4703 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4705 if (ckWARN(WARN_REDEFINE)
4707 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4709 line_t oldline = CopLINE(PL_curcop);
4710 if (PL_copline != NOLINE)
4711 CopLINE_set(PL_curcop, PL_copline);
4712 Perl_warner(aTHX_ WARN_REDEFINE,
4713 CvCONST(cv) ? "Constant subroutine %s redefined"
4714 : "Subroutine %s redefined", name);
4715 CopLINE_set(PL_curcop, oldline);
4723 SvREFCNT_inc(const_sv);
4725 assert(!CvROOT(cv) && !CvCONST(cv));
4726 sv_setpv((SV*)cv, ""); /* prototype is "" */
4727 CvXSUBANY(cv).any_ptr = const_sv;
4728 CvXSUB(cv) = const_sv_xsub;
4733 cv = newCONSTSUB(NULL, name, const_sv);
4736 SvREFCNT_dec(PL_compcv);
4738 PL_sub_generation++;
4745 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4746 * before we clobber PL_compcv.
4750 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4751 stash = GvSTASH(CvGV(cv));
4752 else if (CvSTASH(cv))
4753 stash = CvSTASH(cv);
4755 stash = PL_curstash;
4758 /* possibly about to re-define existing subr -- ignore old cv */
4759 rcv = (SV*)PL_compcv;
4760 if (name && GvSTASH(gv))
4761 stash = GvSTASH(gv);
4763 stash = PL_curstash;
4765 apply_attrs(stash, rcv, attrs);
4767 if (cv) { /* must reuse cv if autoloaded */
4769 /* got here with just attrs -- work done, so bug out */
4770 SAVEFREESV(PL_compcv);
4774 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4775 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4776 CvOUTSIDE(PL_compcv) = 0;
4777 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4778 CvPADLIST(PL_compcv) = 0;
4779 /* inner references to PL_compcv must be fixed up ... */
4781 AV *padlist = CvPADLIST(cv);
4782 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4783 AV *comppad = (AV*)AvARRAY(padlist)[1];
4784 SV **namepad = AvARRAY(comppad_name);
4785 SV **curpad = AvARRAY(comppad);
4786 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4787 SV *namesv = namepad[ix];
4788 if (namesv && namesv != &PL_sv_undef
4789 && *SvPVX(namesv) == '&')
4791 CV *innercv = (CV*)curpad[ix];
4792 if (CvOUTSIDE(innercv) == PL_compcv) {
4793 CvOUTSIDE(innercv) = cv;
4794 if (!CvANON(innercv) || CvCLONED(innercv)) {
4795 (void)SvREFCNT_inc(cv);
4796 SvREFCNT_dec(PL_compcv);
4802 /* ... before we throw it away */
4803 SvREFCNT_dec(PL_compcv);
4804 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4805 ++PL_sub_generation;
4812 PL_sub_generation++;
4816 CvFILE_set_from_cop(cv, PL_curcop);
4817 CvSTASH(cv) = PL_curstash;
4818 #ifdef USE_5005THREADS
4820 if (!CvMUTEXP(cv)) {
4821 New(666, CvMUTEXP(cv), 1, perl_mutex);
4822 MUTEX_INIT(CvMUTEXP(cv));
4824 #endif /* USE_5005THREADS */
4827 sv_setpv((SV*)cv, ps);
4829 if (PL_error_count) {
4833 char *s = strrchr(name, ':');
4835 if (strEQ(s, "BEGIN")) {
4837 "BEGIN not safe after errors--compilation aborted";
4838 if (PL_in_eval & EVAL_KEEPERR)
4839 Perl_croak(aTHX_ not_safe);
4841 /* force display of errors found but not reported */
4842 sv_catpv(ERRSV, not_safe);
4843 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4851 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4852 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4855 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4856 mod(scalarseq(block), OP_LEAVESUBLV));
4859 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4861 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4862 OpREFCNT_set(CvROOT(cv), 1);
4863 CvSTART(cv) = LINKLIST(CvROOT(cv));
4864 CvROOT(cv)->op_next = 0;
4865 CALL_PEEP(CvSTART(cv));
4867 /* now that optimizer has done its work, adjust pad values */
4869 SV **namep = AvARRAY(PL_comppad_name);
4870 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4873 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4876 * The only things that a clonable function needs in its
4877 * pad are references to outer lexicals and anonymous subs.
4878 * The rest are created anew during cloning.
4880 if (!((namesv = namep[ix]) != Nullsv &&
4881 namesv != &PL_sv_undef &&
4883 *SvPVX(namesv) == '&')))
4885 SvREFCNT_dec(PL_curpad[ix]);
4886 PL_curpad[ix] = Nullsv;
4889 assert(!CvCONST(cv));
4890 if (ps && !*ps && op_const_sv(block, cv))
4894 AV *av = newAV(); /* Will be @_ */
4896 av_store(PL_comppad, 0, (SV*)av);
4897 AvFLAGS(av) = AVf_REIFY;
4899 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4900 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4902 if (!SvPADMY(PL_curpad[ix]))
4903 SvPADTMP_on(PL_curpad[ix]);
4907 /* If a potential closure prototype, don't keep a refcount on
4908 * outer CV, unless the latter happens to be a passing eval"".
4909 * This is okay as the lifetime of the prototype is tied to the
4910 * lifetime of the outer CV. Avoids memory leak due to reference
4912 if (!name && CvOUTSIDE(cv)
4913 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4914 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4916 SvREFCNT_dec(CvOUTSIDE(cv));
4919 if (name || aname) {
4921 char *tname = (name ? name : aname);
4923 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4924 SV *sv = NEWSV(0,0);
4925 SV *tmpstr = sv_newmortal();
4926 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4930 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4932 (long)PL_subline, (long)CopLINE(PL_curcop));
4933 gv_efullname3(tmpstr, gv, Nullch);
4934 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4935 hv = GvHVn(db_postponed);
4936 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4937 && (pcv = GvCV(db_postponed)))
4943 call_sv((SV*)pcv, G_DISCARD);
4947 if ((s = strrchr(tname,':')))
4952 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4955 if (strEQ(s, "BEGIN")) {
4956 I32 oldscope = PL_scopestack_ix;
4958 SAVECOPFILE(&PL_compiling);
4959 SAVECOPLINE(&PL_compiling);
4961 sv_setsv(PL_rs, PL_nrs);
4964 PL_beginav = newAV();
4965 DEBUG_x( dump_sub(gv) );
4966 av_push(PL_beginav, (SV*)cv);
4967 GvCV(gv) = 0; /* cv has been hijacked */
4968 call_list(oldscope, PL_beginav);
4970 PL_curcop = &PL_compiling;
4971 PL_compiling.op_private = PL_hints;
4974 else if (strEQ(s, "END") && !PL_error_count) {
4977 DEBUG_x( dump_sub(gv) );
4978 av_unshift(PL_endav, 1);
4979 av_store(PL_endav, 0, (SV*)cv);
4980 GvCV(gv) = 0; /* cv has been hijacked */
4982 else if (strEQ(s, "CHECK") && !PL_error_count) {
4984 PL_checkav = newAV();
4985 DEBUG_x( dump_sub(gv) );
4986 if (PL_main_start && ckWARN(WARN_VOID))
4987 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4988 av_unshift(PL_checkav, 1);
4989 av_store(PL_checkav, 0, (SV*)cv);
4990 GvCV(gv) = 0; /* cv has been hijacked */
4992 else if (strEQ(s, "INIT") && !PL_error_count) {
4994 PL_initav = newAV();
4995 DEBUG_x( dump_sub(gv) );
4996 if (PL_main_start && ckWARN(WARN_VOID))
4997 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4998 av_push(PL_initav, (SV*)cv);
4999 GvCV(gv) = 0; /* cv has been hijacked */
5004 PL_copline = NOLINE;
5009 /* XXX unsafe for threads if eval_owner isn't held */
5011 =for apidoc newCONSTSUB
5013 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5014 eligible for inlining at compile-time.
5020 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5026 SAVECOPLINE(PL_curcop);
5027 CopLINE_set(PL_curcop, PL_copline);
5030 PL_hints &= ~HINT_BLOCK_SCOPE;
5033 SAVESPTR(PL_curstash);
5034 SAVECOPSTASH(PL_curcop);
5035 PL_curstash = stash;
5037 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5039 CopSTASH(PL_curcop) = stash;
5043 cv = newXS(name, const_sv_xsub, __FILE__);
5044 CvXSUBANY(cv).any_ptr = sv;
5046 sv_setpv((SV*)cv, ""); /* prototype is "" */
5054 =for apidoc U||newXS
5056 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5062 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5064 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5067 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5069 /* just a cached method */
5073 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5074 /* already defined (or promised) */
5075 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5076 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5077 line_t oldline = CopLINE(PL_curcop);
5078 if (PL_copline != NOLINE)
5079 CopLINE_set(PL_curcop, PL_copline);
5080 Perl_warner(aTHX_ WARN_REDEFINE,
5081 CvCONST(cv) ? "Constant subroutine %s redefined"
5082 : "Subroutine %s redefined"
5084 CopLINE_set(PL_curcop, oldline);
5091 if (cv) /* must reuse cv if autoloaded */
5094 cv = (CV*)NEWSV(1105,0);
5095 sv_upgrade((SV *)cv, SVt_PVCV);
5099 PL_sub_generation++;
5103 #ifdef USE_5005THREADS
5104 New(666, CvMUTEXP(cv), 1, perl_mutex);
5105 MUTEX_INIT(CvMUTEXP(cv));
5107 #endif /* USE_5005THREADS */
5108 (void)gv_fetchfile(filename);
5109 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5110 an external constant string */
5111 CvXSUB(cv) = subaddr;
5114 char *s = strrchr(name,':');
5120 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5123 if (strEQ(s, "BEGIN")) {
5125 PL_beginav = newAV();
5126 av_push(PL_beginav, (SV*)cv);
5127 GvCV(gv) = 0; /* cv has been hijacked */
5129 else if (strEQ(s, "END")) {
5132 av_unshift(PL_endav, 1);
5133 av_store(PL_endav, 0, (SV*)cv);
5134 GvCV(gv) = 0; /* cv has been hijacked */
5136 else if (strEQ(s, "CHECK")) {
5138 PL_checkav = newAV();
5139 if (PL_main_start && ckWARN(WARN_VOID))
5140 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5141 av_unshift(PL_checkav, 1);
5142 av_store(PL_checkav, 0, (SV*)cv);
5143 GvCV(gv) = 0; /* cv has been hijacked */
5145 else if (strEQ(s, "INIT")) {
5147 PL_initav = newAV();
5148 if (PL_main_start && ckWARN(WARN_VOID))
5149 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5150 av_push(PL_initav, (SV*)cv);
5151 GvCV(gv) = 0; /* cv has been hijacked */
5162 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5171 name = SvPVx(cSVOPo->op_sv, n_a);
5174 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5175 #ifdef GV_UNIQUE_CHECK
5177 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5181 if ((cv = GvFORM(gv))) {
5182 if (ckWARN(WARN_REDEFINE)) {
5183 line_t oldline = CopLINE(PL_curcop);
5184 if (PL_copline != NOLINE)
5185 CopLINE_set(PL_curcop, PL_copline);
5186 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5187 CopLINE_set(PL_curcop, oldline);
5194 CvFILE_set_from_cop(cv, PL_curcop);
5196 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5197 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5198 SvPADTMP_on(PL_curpad[ix]);
5201 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5202 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5203 OpREFCNT_set(CvROOT(cv), 1);
5204 CvSTART(cv) = LINKLIST(CvROOT(cv));
5205 CvROOT(cv)->op_next = 0;
5206 CALL_PEEP(CvSTART(cv));
5208 PL_copline = NOLINE;
5213 Perl_newANONLIST(pTHX_ OP *o)
5215 return newUNOP(OP_REFGEN, 0,
5216 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5220 Perl_newANONHASH(pTHX_ OP *o)
5222 return newUNOP(OP_REFGEN, 0,
5223 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5227 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5229 return newANONATTRSUB(floor, proto, Nullop, block);
5233 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5235 return newUNOP(OP_REFGEN, 0,
5236 newSVOP(OP_ANONCODE, 0,
5237 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5241 Perl_oopsAV(pTHX_ OP *o)
5243 switch (o->op_type) {
5245 o->op_type = OP_PADAV;
5246 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5247 return ref(o, OP_RV2AV);
5250 o->op_type = OP_RV2AV;
5251 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5256 if (ckWARN_d(WARN_INTERNAL))
5257 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5264 Perl_oopsHV(pTHX_ OP *o)
5266 switch (o->op_type) {
5269 o->op_type = OP_PADHV;
5270 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5271 return ref(o, OP_RV2HV);
5275 o->op_type = OP_RV2HV;
5276 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5281 if (ckWARN_d(WARN_INTERNAL))
5282 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5289 Perl_newAVREF(pTHX_ OP *o)
5291 if (o->op_type == OP_PADANY) {
5292 o->op_type = OP_PADAV;
5293 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5296 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5297 && ckWARN(WARN_DEPRECATED)) {
5298 Perl_warner(aTHX_ WARN_DEPRECATED,
5299 "Using an array as a reference is deprecated");
5301 return newUNOP(OP_RV2AV, 0, scalar(o));
5305 Perl_newGVREF(pTHX_ I32 type, OP *o)
5307 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5308 return newUNOP(OP_NULL, 0, o);
5309 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5313 Perl_newHVREF(pTHX_ OP *o)
5315 if (o->op_type == OP_PADANY) {
5316 o->op_type = OP_PADHV;
5317 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5320 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5321 && ckWARN(WARN_DEPRECATED)) {
5322 Perl_warner(aTHX_ WARN_DEPRECATED,
5323 "Using a hash as a reference is deprecated");
5325 return newUNOP(OP_RV2HV, 0, scalar(o));
5329 Perl_oopsCV(pTHX_ OP *o)
5331 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5337 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5339 return newUNOP(OP_RV2CV, flags, scalar(o));
5343 Perl_newSVREF(pTHX_ OP *o)
5345 if (o->op_type == OP_PADANY) {
5346 o->op_type = OP_PADSV;
5347 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5350 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5351 o->op_flags |= OPpDONE_SVREF;
5354 return newUNOP(OP_RV2SV, 0, scalar(o));
5357 /* Check routines. */
5360 Perl_ck_anoncode(pTHX_ OP *o)
5365 name = NEWSV(1106,0);
5366 sv_upgrade(name, SVt_PVNV);
5367 sv_setpvn(name, "&", 1);
5370 ix = pad_alloc(o->op_type, SVs_PADMY);
5371 av_store(PL_comppad_name, ix, name);
5372 av_store(PL_comppad, ix, cSVOPo->op_sv);
5373 SvPADMY_on(cSVOPo->op_sv);
5374 cSVOPo->op_sv = Nullsv;
5375 cSVOPo->op_targ = ix;
5380 Perl_ck_bitop(pTHX_ OP *o)
5382 o->op_private = PL_hints;
5387 Perl_ck_concat(pTHX_ OP *o)
5389 if (cUNOPo->op_first->op_type == OP_CONCAT)
5390 o->op_flags |= OPf_STACKED;
5395 Perl_ck_spair(pTHX_ OP *o)
5397 if (o->op_flags & OPf_KIDS) {
5400 OPCODE type = o->op_type;
5401 o = modkids(ck_fun(o), type);
5402 kid = cUNOPo->op_first;
5403 newop = kUNOP->op_first->op_sibling;
5405 (newop->op_sibling ||
5406 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5407 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5408 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5412 op_free(kUNOP->op_first);
5413 kUNOP->op_first = newop;
5415 o->op_ppaddr = PL_ppaddr[++o->op_type];
5420 Perl_ck_delete(pTHX_ OP *o)
5424 if (o->op_flags & OPf_KIDS) {
5425 OP *kid = cUNOPo->op_first;
5426 switch (kid->op_type) {
5428 o->op_flags |= OPf_SPECIAL;
5431 o->op_private |= OPpSLICE;
5434 o->op_flags |= OPf_SPECIAL;
5439 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5448 Perl_ck_eof(pTHX_ OP *o)
5450 I32 type = o->op_type;
5452 if (o->op_flags & OPf_KIDS) {
5453 if (cLISTOPo->op_first->op_type == OP_STUB) {
5455 o = newUNOP(type, OPf_SPECIAL,
5456 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5464 Perl_ck_eval(pTHX_ OP *o)
5466 PL_hints |= HINT_BLOCK_SCOPE;
5467 if (o->op_flags & OPf_KIDS) {
5468 SVOP *kid = (SVOP*)cUNOPo->op_first;
5471 o->op_flags &= ~OPf_KIDS;
5474 else if (kid->op_type == OP_LINESEQ) {
5477 kid->op_next = o->op_next;
5478 cUNOPo->op_first = 0;
5481 NewOp(1101, enter, 1, LOGOP);
5482 enter->op_type = OP_ENTERTRY;
5483 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5484 enter->op_private = 0;
5486 /* establish postfix order */
5487 enter->op_next = (OP*)enter;
5489 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5490 o->op_type = OP_LEAVETRY;
5491 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5492 enter->op_other = o;
5500 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5502 o->op_targ = (PADOFFSET)PL_hints;
5507 Perl_ck_exit(pTHX_ OP *o)
5510 HV *table = GvHV(PL_hintgv);
5512 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5513 if (svp && *svp && SvTRUE(*svp))
5514 o->op_private |= OPpEXIT_VMSISH;
5521 Perl_ck_exec(pTHX_ OP *o)
5524 if (o->op_flags & OPf_STACKED) {
5526 kid = cUNOPo->op_first->op_sibling;
5527 if (kid->op_type == OP_RV2GV)
5536 Perl_ck_exists(pTHX_ OP *o)
5539 if (o->op_flags & OPf_KIDS) {
5540 OP *kid = cUNOPo->op_first;
5541 if (kid->op_type == OP_ENTERSUB) {
5542 (void) ref(kid, o->op_type);
5543 if (kid->op_type != OP_RV2CV && !PL_error_count)
5544 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5546 o->op_private |= OPpEXISTS_SUB;
5548 else if (kid->op_type == OP_AELEM)
5549 o->op_flags |= OPf_SPECIAL;
5550 else if (kid->op_type != OP_HELEM)
5551 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5560 Perl_ck_gvconst(pTHX_ register OP *o)
5562 o = fold_constants(o);
5563 if (o->op_type == OP_CONST)
5570 Perl_ck_rvconst(pTHX_ register OP *o)
5572 SVOP *kid = (SVOP*)cUNOPo->op_first;
5574 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5575 if (kid->op_type == OP_CONST) {
5579 SV *kidsv = kid->op_sv;
5582 /* Is it a constant from cv_const_sv()? */
5583 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5584 SV *rsv = SvRV(kidsv);
5585 int svtype = SvTYPE(rsv);
5586 char *badtype = Nullch;
5588 switch (o->op_type) {
5590 if (svtype > SVt_PVMG)
5591 badtype = "a SCALAR";
5594 if (svtype != SVt_PVAV)
5595 badtype = "an ARRAY";
5598 if (svtype != SVt_PVHV) {
5599 if (svtype == SVt_PVAV) { /* pseudohash? */
5600 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5601 if (ksv && SvROK(*ksv)
5602 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5611 if (svtype != SVt_PVCV)
5616 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5619 name = SvPV(kidsv, n_a);
5620 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5621 char *badthing = Nullch;
5622 switch (o->op_type) {
5624 badthing = "a SCALAR";
5627 badthing = "an ARRAY";
5630 badthing = "a HASH";
5635 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5639 * This is a little tricky. We only want to add the symbol if we
5640 * didn't add it in the lexer. Otherwise we get duplicate strict
5641 * warnings. But if we didn't add it in the lexer, we must at
5642 * least pretend like we wanted to add it even if it existed before,
5643 * or we get possible typo warnings. OPpCONST_ENTERED says
5644 * whether the lexer already added THIS instance of this symbol.
5646 iscv = (o->op_type == OP_RV2CV) * 2;
5648 gv = gv_fetchpv(name,
5649 iscv | !(kid->op_private & OPpCONST_ENTERED),
5652 : o->op_type == OP_RV2SV
5654 : o->op_type == OP_RV2AV
5656 : o->op_type == OP_RV2HV
5659 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5661 kid->op_type = OP_GV;
5662 SvREFCNT_dec(kid->op_sv);
5664 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5665 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5666 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5668 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5670 kid->op_sv = SvREFCNT_inc(gv);
5672 kid->op_private = 0;
5673 kid->op_ppaddr = PL_ppaddr[OP_GV];
5680 Perl_ck_ftst(pTHX_ OP *o)
5682 I32 type = o->op_type;
5684 if (o->op_flags & OPf_REF) {
5687 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5688 SVOP *kid = (SVOP*)cUNOPo->op_first;
5690 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5692 OP *newop = newGVOP(type, OPf_REF,
5693 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5700 if (type == OP_FTTTY)
5701 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5704 o = newUNOP(type, 0, newDEFSVOP());
5710 Perl_ck_fun(pTHX_ OP *o)
5716 int type = o->op_type;
5717 register I32 oa = PL_opargs[type] >> OASHIFT;
5719 if (o->op_flags & OPf_STACKED) {
5720 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5723 return no_fh_allowed(o);
5726 if (o->op_flags & OPf_KIDS) {
5728 tokid = &cLISTOPo->op_first;
5729 kid = cLISTOPo->op_first;
5730 if (kid->op_type == OP_PUSHMARK ||
5731 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5733 tokid = &kid->op_sibling;
5734 kid = kid->op_sibling;
5736 if (!kid && PL_opargs[type] & OA_DEFGV)
5737 *tokid = kid = newDEFSVOP();
5741 sibl = kid->op_sibling;
5744 /* list seen where single (scalar) arg expected? */
5745 if (numargs == 1 && !(oa >> 4)
5746 && kid->op_type == OP_LIST && type != OP_SCALAR)
5748 return too_many_arguments(o,PL_op_desc[type]);
5761 if ((type == OP_PUSH || type == OP_UNSHIFT)
5762 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5763 Perl_warner(aTHX_ WARN_SYNTAX,
5764 "Useless use of %s with no values",
5767 if (kid->op_type == OP_CONST &&
5768 (kid->op_private & OPpCONST_BARE))
5770 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5771 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5772 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5773 if (ckWARN(WARN_DEPRECATED))
5774 Perl_warner(aTHX_ WARN_DEPRECATED,
5775 "Array @%s missing the @ in argument %"IVdf" of %s()",
5776 name, (IV)numargs, PL_op_desc[type]);
5779 kid->op_sibling = sibl;
5782 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5783 bad_type(numargs, "array", PL_op_desc[type], kid);
5787 if (kid->op_type == OP_CONST &&
5788 (kid->op_private & OPpCONST_BARE))
5790 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5791 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5792 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5793 if (ckWARN(WARN_DEPRECATED))
5794 Perl_warner(aTHX_ WARN_DEPRECATED,
5795 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5796 name, (IV)numargs, PL_op_desc[type]);
5799 kid->op_sibling = sibl;
5802 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5803 bad_type(numargs, "hash", PL_op_desc[type], kid);
5808 OP *newop = newUNOP(OP_NULL, 0, kid);
5809 kid->op_sibling = 0;
5811 newop->op_next = newop;
5813 kid->op_sibling = sibl;
5818 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5819 if (kid->op_type == OP_CONST &&
5820 (kid->op_private & OPpCONST_BARE))
5822 OP *newop = newGVOP(OP_GV, 0,
5823 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5828 else if (kid->op_type == OP_READLINE) {
5829 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5830 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5833 I32 flags = OPf_SPECIAL;
5837 /* is this op a FH constructor? */
5838 if (is_handle_constructor(o,numargs)) {
5839 char *name = Nullch;
5843 /* Set a flag to tell rv2gv to vivify
5844 * need to "prove" flag does not mean something
5845 * else already - NI-S 1999/05/07
5848 if (kid->op_type == OP_PADSV) {
5849 SV **namep = av_fetch(PL_comppad_name,
5851 if (namep && *namep)
5852 name = SvPV(*namep, len);
5854 else if (kid->op_type == OP_RV2SV
5855 && kUNOP->op_first->op_type == OP_GV)
5857 GV *gv = cGVOPx_gv(kUNOP->op_first);
5859 len = GvNAMELEN(gv);
5861 else if (kid->op_type == OP_AELEM
5862 || kid->op_type == OP_HELEM)
5864 name = "__ANONIO__";
5870 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5871 namesv = PL_curpad[targ];
5872 (void)SvUPGRADE(namesv, SVt_PV);
5874 sv_setpvn(namesv, "$", 1);
5875 sv_catpvn(namesv, name, len);
5878 kid->op_sibling = 0;
5879 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5880 kid->op_targ = targ;
5881 kid->op_private |= priv;
5883 kid->op_sibling = sibl;
5889 mod(scalar(kid), type);
5893 tokid = &kid->op_sibling;
5894 kid = kid->op_sibling;
5896 o->op_private |= numargs;
5898 return too_many_arguments(o,OP_DESC(o));
5901 else if (PL_opargs[type] & OA_DEFGV) {
5903 return newUNOP(type, 0, newDEFSVOP());
5907 while (oa & OA_OPTIONAL)
5909 if (oa && oa != OA_LIST)
5910 return too_few_arguments(o,OP_DESC(o));
5916 Perl_ck_glob(pTHX_ OP *o)
5921 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5922 append_elem(OP_GLOB, o, newDEFSVOP());
5924 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5925 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5927 #if !defined(PERL_EXTERNAL_GLOB)
5928 /* XXX this can be tightened up and made more failsafe. */
5932 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5934 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5935 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5936 GvCV(gv) = GvCV(glob_gv);
5937 SvREFCNT_inc((SV*)GvCV(gv));
5938 GvIMPORTED_CV_on(gv);
5941 #endif /* PERL_EXTERNAL_GLOB */
5943 if (gv && GvIMPORTED_CV(gv)) {
5944 append_elem(OP_GLOB, o,
5945 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5946 o->op_type = OP_LIST;
5947 o->op_ppaddr = PL_ppaddr[OP_LIST];
5948 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5949 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5950 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5951 append_elem(OP_LIST, o,
5952 scalar(newUNOP(OP_RV2CV, 0,
5953 newGVOP(OP_GV, 0, gv)))));
5954 o = newUNOP(OP_NULL, 0, ck_subr(o));
5955 o->op_targ = OP_GLOB; /* hint at what it used to be */
5958 gv = newGVgen("main");
5960 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5966 Perl_ck_grep(pTHX_ OP *o)
5970 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5972 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5973 NewOp(1101, gwop, 1, LOGOP);
5975 if (o->op_flags & OPf_STACKED) {
5978 kid = cLISTOPo->op_first->op_sibling;
5979 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5982 kid->op_next = (OP*)gwop;
5983 o->op_flags &= ~OPf_STACKED;
5985 kid = cLISTOPo->op_first->op_sibling;
5986 if (type == OP_MAPWHILE)
5993 kid = cLISTOPo->op_first->op_sibling;
5994 if (kid->op_type != OP_NULL)
5995 Perl_croak(aTHX_ "panic: ck_grep");
5996 kid = kUNOP->op_first;
5998 gwop->op_type = type;
5999 gwop->op_ppaddr = PL_ppaddr[type];
6000 gwop->op_first = listkids(o);
6001 gwop->op_flags |= OPf_KIDS;
6002 gwop->op_private = 1;
6003 gwop->op_other = LINKLIST(kid);
6004 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6005 kid->op_next = (OP*)gwop;
6007 kid = cLISTOPo->op_first->op_sibling;
6008 if (!kid || !kid->op_sibling)
6009 return too_few_arguments(o,OP_DESC(o));
6010 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6011 mod(kid, OP_GREPSTART);
6017 Perl_ck_index(pTHX_ OP *o)
6019 if (o->op_flags & OPf_KIDS) {
6020 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6022 kid = kid->op_sibling; /* get past "big" */
6023 if (kid && kid->op_type == OP_CONST)
6024 fbm_compile(((SVOP*)kid)->op_sv, 0);
6030 Perl_ck_lengthconst(pTHX_ OP *o)
6032 /* XXX length optimization goes here */
6037 Perl_ck_lfun(pTHX_ OP *o)
6039 OPCODE type = o->op_type;
6040 return modkids(ck_fun(o), type);
6044 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6046 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6047 switch (cUNOPo->op_first->op_type) {
6049 /* This is needed for
6050 if (defined %stash::)
6051 to work. Do not break Tk.
6053 break; /* Globals via GV can be undef */
6055 case OP_AASSIGN: /* Is this a good idea? */
6056 Perl_warner(aTHX_ WARN_DEPRECATED,
6057 "defined(@array) is deprecated");
6058 Perl_warner(aTHX_ WARN_DEPRECATED,
6059 "\t(Maybe you should just omit the defined()?)\n");
6062 /* This is needed for
6063 if (defined %stash::)
6064 to work. Do not break Tk.
6066 break; /* Globals via GV can be undef */
6068 Perl_warner(aTHX_ WARN_DEPRECATED,
6069 "defined(%%hash) is deprecated");
6070 Perl_warner(aTHX_ WARN_DEPRECATED,
6071 "\t(Maybe you should just omit the defined()?)\n");
6082 Perl_ck_rfun(pTHX_ OP *o)
6084 OPCODE type = o->op_type;
6085 return refkids(ck_fun(o), type);
6089 Perl_ck_listiob(pTHX_ OP *o)
6093 kid = cLISTOPo->op_first;
6096 kid = cLISTOPo->op_first;
6098 if (kid->op_type == OP_PUSHMARK)
6099 kid = kid->op_sibling;
6100 if (kid && o->op_flags & OPf_STACKED)
6101 kid = kid->op_sibling;
6102 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6103 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6104 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6105 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6106 cLISTOPo->op_first->op_sibling = kid;
6107 cLISTOPo->op_last = kid;
6108 kid = kid->op_sibling;
6113 append_elem(o->op_type, o, newDEFSVOP());
6119 Perl_ck_sassign(pTHX_ OP *o)
6121 OP *kid = cLISTOPo->op_first;
6122 /* has a disposable target? */
6123 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6124 && !(kid->op_flags & OPf_STACKED)
6125 /* Cannot steal the second time! */
6126 && !(kid->op_private & OPpTARGET_MY))
6128 OP *kkid = kid->op_sibling;
6130 /* Can just relocate the target. */
6131 if (kkid && kkid->op_type == OP_PADSV
6132 && !(kkid->op_private & OPpLVAL_INTRO))
6134 kid->op_targ = kkid->op_targ;
6136 /* Now we do not need PADSV and SASSIGN. */
6137 kid->op_sibling = o->op_sibling; /* NULL */
6138 cLISTOPo->op_first = NULL;
6141 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6149 Perl_ck_match(pTHX_ OP *o)
6151 o->op_private |= OPpRUNTIME;
6156 Perl_ck_method(pTHX_ OP *o)
6158 OP *kid = cUNOPo->op_first;
6159 if (kid->op_type == OP_CONST) {
6160 SV* sv = kSVOP->op_sv;
6161 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6163 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6164 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6167 kSVOP->op_sv = Nullsv;
6169 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6178 Perl_ck_null(pTHX_ OP *o)
6184 Perl_ck_open(pTHX_ OP *o)
6186 HV *table = GvHV(PL_hintgv);
6190 svp = hv_fetch(table, "open_IN", 7, FALSE);
6192 mode = mode_from_discipline(*svp);
6193 if (mode & O_BINARY)
6194 o->op_private |= OPpOPEN_IN_RAW;
6195 else if (mode & O_TEXT)
6196 o->op_private |= OPpOPEN_IN_CRLF;
6199 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6201 mode = mode_from_discipline(*svp);
6202 if (mode & O_BINARY)
6203 o->op_private |= OPpOPEN_OUT_RAW;
6204 else if (mode & O_TEXT)
6205 o->op_private |= OPpOPEN_OUT_CRLF;
6208 if (o->op_type == OP_BACKTICK)
6214 Perl_ck_repeat(pTHX_ OP *o)
6216 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6217 o->op_private |= OPpREPEAT_DOLIST;
6218 cBINOPo->op_first = force_list(cBINOPo->op_first);
6226 Perl_ck_require(pTHX_ OP *o)
6230 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6231 SVOP *kid = (SVOP*)cUNOPo->op_first;
6233 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6235 for (s = SvPVX(kid->op_sv); *s; s++) {
6236 if (*s == ':' && s[1] == ':') {
6238 Move(s+2, s+1, strlen(s+2)+1, char);
6239 --SvCUR(kid->op_sv);
6242 if (SvREADONLY(kid->op_sv)) {
6243 SvREADONLY_off(kid->op_sv);
6244 sv_catpvn(kid->op_sv, ".pm", 3);
6245 SvREADONLY_on(kid->op_sv);
6248 sv_catpvn(kid->op_sv, ".pm", 3);
6252 /* handle override, if any */
6253 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6254 if (!(gv && GvIMPORTED_CV(gv)))
6255 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6257 if (gv && GvIMPORTED_CV(gv)) {
6258 OP *kid = cUNOPo->op_first;
6259 cUNOPo->op_first = 0;
6261 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6262 append_elem(OP_LIST, kid,
6263 scalar(newUNOP(OP_RV2CV, 0,
6272 Perl_ck_return(pTHX_ OP *o)
6275 if (CvLVALUE(PL_compcv)) {
6276 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6277 mod(kid, OP_LEAVESUBLV);
6284 Perl_ck_retarget(pTHX_ OP *o)
6286 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6293 Perl_ck_select(pTHX_ OP *o)
6296 if (o->op_flags & OPf_KIDS) {
6297 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6298 if (kid && kid->op_sibling) {
6299 o->op_type = OP_SSELECT;
6300 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6302 return fold_constants(o);
6306 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6307 if (kid && kid->op_type == OP_RV2GV)
6308 kid->op_private &= ~HINT_STRICT_REFS;
6313 Perl_ck_shift(pTHX_ OP *o)
6315 I32 type = o->op_type;
6317 if (!(o->op_flags & OPf_KIDS)) {
6321 #ifdef USE_5005THREADS
6322 if (!CvUNIQUE(PL_compcv)) {
6323 argop = newOP(OP_PADAV, OPf_REF);
6324 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6327 argop = newUNOP(OP_RV2AV, 0,
6328 scalar(newGVOP(OP_GV, 0,
6329 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6332 argop = newUNOP(OP_RV2AV, 0,
6333 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6334 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6335 #endif /* USE_5005THREADS */
6336 return newUNOP(type, 0, scalar(argop));
6338 return scalar(modkids(ck_fun(o), type));
6342 Perl_ck_sort(pTHX_ OP *o)
6346 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6348 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6349 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6351 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6353 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6355 if (kid->op_type == OP_SCOPE) {
6359 else if (kid->op_type == OP_LEAVE) {
6360 if (o->op_type == OP_SORT) {
6361 op_null(kid); /* wipe out leave */
6364 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6365 if (k->op_next == kid)
6367 /* don't descend into loops */
6368 else if (k->op_type == OP_ENTERLOOP
6369 || k->op_type == OP_ENTERITER)
6371 k = cLOOPx(k)->op_lastop;
6376 kid->op_next = 0; /* just disconnect the leave */
6377 k = kLISTOP->op_first;
6382 if (o->op_type == OP_SORT) {
6383 /* provide scalar context for comparison function/block */
6389 o->op_flags |= OPf_SPECIAL;
6391 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6394 firstkid = firstkid->op_sibling;
6397 /* provide list context for arguments */
6398 if (o->op_type == OP_SORT)
6405 S_simplify_sort(pTHX_ OP *o)
6407 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6411 if (!(o->op_flags & OPf_STACKED))
6413 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6414 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6415 kid = kUNOP->op_first; /* get past null */
6416 if (kid->op_type != OP_SCOPE)
6418 kid = kLISTOP->op_last; /* get past scope */
6419 switch(kid->op_type) {
6427 k = kid; /* remember this node*/
6428 if (kBINOP->op_first->op_type != OP_RV2SV)
6430 kid = kBINOP->op_first; /* get past cmp */
6431 if (kUNOP->op_first->op_type != OP_GV)
6433 kid = kUNOP->op_first; /* get past rv2sv */
6435 if (GvSTASH(gv) != PL_curstash)
6437 if (strEQ(GvNAME(gv), "a"))
6439 else if (strEQ(GvNAME(gv), "b"))
6443 kid = k; /* back to cmp */
6444 if (kBINOP->op_last->op_type != OP_RV2SV)
6446 kid = kBINOP->op_last; /* down to 2nd arg */
6447 if (kUNOP->op_first->op_type != OP_GV)
6449 kid = kUNOP->op_first; /* get past rv2sv */
6451 if (GvSTASH(gv) != PL_curstash
6453 ? strNE(GvNAME(gv), "a")
6454 : strNE(GvNAME(gv), "b")))
6456 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6458 o->op_private |= OPpSORT_REVERSE;
6459 if (k->op_type == OP_NCMP)
6460 o->op_private |= OPpSORT_NUMERIC;
6461 if (k->op_type == OP_I_NCMP)
6462 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6463 kid = cLISTOPo->op_first->op_sibling;
6464 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6465 op_free(kid); /* then delete it */
6469 Perl_ck_split(pTHX_ OP *o)
6473 if (o->op_flags & OPf_STACKED)
6474 return no_fh_allowed(o);
6476 kid = cLISTOPo->op_first;
6477 if (kid->op_type != OP_NULL)
6478 Perl_croak(aTHX_ "panic: ck_split");
6479 kid = kid->op_sibling;
6480 op_free(cLISTOPo->op_first);
6481 cLISTOPo->op_first = kid;
6483 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6484 cLISTOPo->op_last = kid; /* There was only one element previously */
6487 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6488 OP *sibl = kid->op_sibling;
6489 kid->op_sibling = 0;
6490 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6491 if (cLISTOPo->op_first == cLISTOPo->op_last)
6492 cLISTOPo->op_last = kid;
6493 cLISTOPo->op_first = kid;
6494 kid->op_sibling = sibl;
6497 kid->op_type = OP_PUSHRE;
6498 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6501 if (!kid->op_sibling)
6502 append_elem(OP_SPLIT, o, newDEFSVOP());
6504 kid = kid->op_sibling;
6507 if (!kid->op_sibling)
6508 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6510 kid = kid->op_sibling;
6513 if (kid->op_sibling)
6514 return too_many_arguments(o,OP_DESC(o));
6520 Perl_ck_join(pTHX_ OP *o)
6522 if (ckWARN(WARN_SYNTAX)) {
6523 OP *kid = cLISTOPo->op_first->op_sibling;
6524 if (kid && kid->op_type == OP_MATCH) {
6525 char *pmstr = "STRING";
6526 if (PM_GETRE(kPMOP))
6527 pmstr = PM_GETRE(kPMOP)->precomp;
6528 Perl_warner(aTHX_ WARN_SYNTAX,
6529 "/%s/ should probably be written as \"%s\"",
6537 Perl_ck_subr(pTHX_ OP *o)
6539 OP *prev = ((cUNOPo->op_first->op_sibling)
6540 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6541 OP *o2 = prev->op_sibling;
6548 I32 contextclass = 0;
6552 o->op_private |= OPpENTERSUB_HASTARG;
6553 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6554 if (cvop->op_type == OP_RV2CV) {
6556 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6557 op_null(cvop); /* disable rv2cv */
6558 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6559 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6560 GV *gv = cGVOPx_gv(tmpop);
6563 tmpop->op_private |= OPpEARLY_CV;
6564 else if (SvPOK(cv)) {
6565 namegv = CvANON(cv) ? gv : CvGV(cv);
6566 proto = SvPV((SV*)cv, n_a);
6570 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6571 if (o2->op_type == OP_CONST)
6572 o2->op_private &= ~OPpCONST_STRICT;
6573 else if (o2->op_type == OP_LIST) {
6574 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6575 if (o && o->op_type == OP_CONST)
6576 o->op_private &= ~OPpCONST_STRICT;
6579 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6580 if (PERLDB_SUB && PL_curstash != PL_debstash)
6581 o->op_private |= OPpENTERSUB_DB;
6582 while (o2 != cvop) {
6586 return too_many_arguments(o, gv_ename(namegv));
6604 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6606 arg == 1 ? "block or sub {}" : "sub {}",
6607 gv_ename(namegv), o2);
6610 /* '*' allows any scalar type, including bareword */
6613 if (o2->op_type == OP_RV2GV)
6614 goto wrapref; /* autoconvert GLOB -> GLOBref */
6615 else if (o2->op_type == OP_CONST)
6616 o2->op_private &= ~OPpCONST_STRICT;
6617 else if (o2->op_type == OP_ENTERSUB) {
6618 /* accidental subroutine, revert to bareword */
6619 OP *gvop = ((UNOP*)o2)->op_first;
6620 if (gvop && gvop->op_type == OP_NULL) {
6621 gvop = ((UNOP*)gvop)->op_first;
6623 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6626 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6627 (gvop = ((UNOP*)gvop)->op_first) &&
6628 gvop->op_type == OP_GV)
6630 GV *gv = cGVOPx_gv(gvop);
6631 OP *sibling = o2->op_sibling;
6632 SV *n = newSVpvn("",0);
6634 gv_fullname3(n, gv, "");
6635 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6636 sv_chop(n, SvPVX(n)+6);
6637 o2 = newSVOP(OP_CONST, 0, n);
6638 prev->op_sibling = o2;
6639 o2->op_sibling = sibling;
6655 if (contextclass++ == 0) {
6656 e = strchr(proto, ']');
6657 if (!e || e == proto)
6671 if (o2->op_type == OP_RV2GV)
6674 bad_type(arg, "symbol", gv_ename(namegv), o2);
6677 if (o2->op_type == OP_ENTERSUB)
6680 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6683 if (o2->op_type == OP_RV2SV ||
6684 o2->op_type == OP_PADSV ||
6685 o2->op_type == OP_HELEM ||
6686 o2->op_type == OP_AELEM ||
6687 o2->op_type == OP_THREADSV)
6690 bad_type(arg, "scalar", gv_ename(namegv), o2);
6693 if (o2->op_type == OP_RV2AV ||
6694 o2->op_type == OP_PADAV)
6697 bad_type(arg, "array", gv_ename(namegv), o2);
6700 if (o2->op_type == OP_RV2HV ||
6701 o2->op_type == OP_PADHV)
6704 bad_type(arg, "hash", gv_ename(namegv), o2);
6709 OP* sib = kid->op_sibling;
6710 kid->op_sibling = 0;
6711 o2 = newUNOP(OP_REFGEN, 0, kid);
6712 o2->op_sibling = sib;
6713 prev->op_sibling = o2;
6715 if (contextclass && e) {
6730 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6731 gv_ename(namegv), SvPV((SV*)cv, n_a));
6736 mod(o2, OP_ENTERSUB);
6738 o2 = o2->op_sibling;
6740 if (proto && !optional &&
6741 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6742 return too_few_arguments(o, gv_ename(namegv));
6747 Perl_ck_svconst(pTHX_ OP *o)
6749 SvREADONLY_on(cSVOPo->op_sv);
6754 Perl_ck_trunc(pTHX_ OP *o)
6756 if (o->op_flags & OPf_KIDS) {
6757 SVOP *kid = (SVOP*)cUNOPo->op_first;
6759 if (kid->op_type == OP_NULL)
6760 kid = (SVOP*)kid->op_sibling;
6761 if (kid && kid->op_type == OP_CONST &&
6762 (kid->op_private & OPpCONST_BARE))
6764 o->op_flags |= OPf_SPECIAL;
6765 kid->op_private &= ~OPpCONST_STRICT;
6772 Perl_ck_substr(pTHX_ OP *o)
6775 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6776 OP *kid = cLISTOPo->op_first;
6778 if (kid->op_type == OP_NULL)
6779 kid = kid->op_sibling;
6781 kid->op_flags |= OPf_MOD;
6787 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6790 Perl_peep(pTHX_ register OP *o)
6792 register OP* oldop = 0;
6795 if (!o || o->op_seq)
6799 SAVEVPTR(PL_curcop);
6800 for (; o; o = o->op_next) {
6806 switch (o->op_type) {
6810 PL_curcop = ((COP*)o); /* for warnings */
6811 o->op_seq = PL_op_seqmax++;
6815 if (cSVOPo->op_private & OPpCONST_STRICT)
6816 no_bareword_allowed(o);
6818 /* Relocate sv to the pad for thread safety.
6819 * Despite being a "constant", the SV is written to,
6820 * for reference counts, sv_upgrade() etc. */
6822 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6823 if (SvPADTMP(cSVOPo->op_sv)) {
6824 /* If op_sv is already a PADTMP then it is being used by
6825 * some pad, so make a copy. */
6826 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6827 SvREADONLY_on(PL_curpad[ix]);
6828 SvREFCNT_dec(cSVOPo->op_sv);
6831 SvREFCNT_dec(PL_curpad[ix]);
6832 SvPADTMP_on(cSVOPo->op_sv);
6833 PL_curpad[ix] = cSVOPo->op_sv;
6834 /* XXX I don't know how this isn't readonly already. */
6835 SvREADONLY_on(PL_curpad[ix]);
6837 cSVOPo->op_sv = Nullsv;
6841 o->op_seq = PL_op_seqmax++;
6845 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6846 if (o->op_next->op_private & OPpTARGET_MY) {
6847 if (o->op_flags & OPf_STACKED) /* chained concats */
6848 goto ignore_optimization;
6850 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6851 o->op_targ = o->op_next->op_targ;
6852 o->op_next->op_targ = 0;
6853 o->op_private |= OPpTARGET_MY;
6856 op_null(o->op_next);
6858 ignore_optimization:
6859 o->op_seq = PL_op_seqmax++;
6862 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6863 o->op_seq = PL_op_seqmax++;
6864 break; /* Scalar stub must produce undef. List stub is noop */
6868 if (o->op_targ == OP_NEXTSTATE
6869 || o->op_targ == OP_DBSTATE
6870 || o->op_targ == OP_SETSTATE)
6872 PL_curcop = ((COP*)o);
6874 /* XXX: We avoid setting op_seq here to prevent later calls
6875 to peep() from mistakenly concluding that optimisation
6876 has already occurred. This doesn't fix the real problem,
6877 though (See 20010220.007). AMS 20010719 */
6878 if (oldop && o->op_next) {
6879 oldop->op_next = o->op_next;
6887 if (oldop && o->op_next) {
6888 oldop->op_next = o->op_next;
6891 o->op_seq = PL_op_seqmax++;
6895 if (o->op_next->op_type == OP_RV2SV) {
6896 if (!(o->op_next->op_private & OPpDEREF)) {
6897 op_null(o->op_next);
6898 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6900 o->op_next = o->op_next->op_next;
6901 o->op_type = OP_GVSV;
6902 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6905 else if (o->op_next->op_type == OP_RV2AV) {
6906 OP* pop = o->op_next->op_next;
6908 if (pop->op_type == OP_CONST &&
6909 (PL_op = pop->op_next) &&
6910 pop->op_next->op_type == OP_AELEM &&
6911 !(pop->op_next->op_private &
6912 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6913 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6918 op_null(o->op_next);
6919 op_null(pop->op_next);
6921 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6922 o->op_next = pop->op_next->op_next;
6923 o->op_type = OP_AELEMFAST;
6924 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6925 o->op_private = (U8)i;
6930 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6932 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6933 /* XXX could check prototype here instead of just carping */
6934 SV *sv = sv_newmortal();
6935 gv_efullname3(sv, gv, Nullch);
6936 Perl_warner(aTHX_ WARN_PROTOTYPE,
6937 "%s() called too early to check prototype",
6941 else if (o->op_next->op_type == OP_READLINE
6942 && o->op_next->op_next->op_type == OP_CONCAT
6943 && (o->op_next->op_next->op_flags & OPf_STACKED))
6945 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010811 */
6946 o->op_next->op_type = OP_RCATLINE;
6947 o->op_next->op_flags |= OPf_STACKED;
6948 op_null(o->op_next->op_next);
6951 o->op_seq = PL_op_seqmax++;
6962 o->op_seq = PL_op_seqmax++;
6963 while (cLOGOP->op_other->op_type == OP_NULL)
6964 cLOGOP->op_other = cLOGOP->op_other->op_next;
6965 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6970 o->op_seq = PL_op_seqmax++;
6971 while (cLOOP->op_redoop->op_type == OP_NULL)
6972 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6973 peep(cLOOP->op_redoop);
6974 while (cLOOP->op_nextop->op_type == OP_NULL)
6975 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6976 peep(cLOOP->op_nextop);
6977 while (cLOOP->op_lastop->op_type == OP_NULL)
6978 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6979 peep(cLOOP->op_lastop);
6985 o->op_seq = PL_op_seqmax++;
6986 while (cPMOP->op_pmreplstart &&
6987 cPMOP->op_pmreplstart->op_type == OP_NULL)
6988 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6989 peep(cPMOP->op_pmreplstart);
6993 o->op_seq = PL_op_seqmax++;
6994 if (ckWARN(WARN_SYNTAX) && o->op_next
6995 && o->op_next->op_type == OP_NEXTSTATE) {
6996 if (o->op_next->op_sibling &&
6997 o->op_next->op_sibling->op_type != OP_EXIT &&
6998 o->op_next->op_sibling->op_type != OP_WARN &&
6999 o->op_next->op_sibling->op_type != OP_DIE) {
7000 line_t oldline = CopLINE(PL_curcop);
7002 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7003 Perl_warner(aTHX_ WARN_EXEC,
7004 "Statement unlikely to be reached");
7005 Perl_warner(aTHX_ WARN_EXEC,
7006 "\t(Maybe you meant system() when you said exec()?)\n");
7007 CopLINE_set(PL_curcop, oldline);
7016 SV **svp, **indsvp, *sv;
7021 o->op_seq = PL_op_seqmax++;
7023 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7026 /* Make the CONST have a shared SV */
7027 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7028 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7029 key = SvPV(sv, keylen);
7030 lexname = newSVpvn_share(key,
7031 SvUTF8(sv) ? -(I32)keylen : keylen,
7037 if ((o->op_private & (OPpLVAL_INTRO)))
7040 rop = (UNOP*)((BINOP*)o)->op_first;
7041 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7043 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7044 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7046 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7047 if (!fields || !GvHV(*fields))
7049 key = SvPV(*svp, keylen);
7050 indsvp = hv_fetch(GvHV(*fields), key,
7051 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7053 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7054 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7056 ind = SvIV(*indsvp);
7058 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7059 rop->op_type = OP_RV2AV;
7060 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7061 o->op_type = OP_AELEM;
7062 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7064 if (SvREADONLY(*svp))
7066 SvFLAGS(sv) |= (SvFLAGS(*svp)
7067 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7077 SV **svp, **indsvp, *sv;
7081 SVOP *first_key_op, *key_op;
7083 o->op_seq = PL_op_seqmax++;
7084 if ((o->op_private & (OPpLVAL_INTRO))
7085 /* I bet there's always a pushmark... */
7086 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7087 /* hmmm, no optimization if list contains only one key. */
7089 rop = (UNOP*)((LISTOP*)o)->op_last;
7090 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7092 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7093 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7095 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7096 if (!fields || !GvHV(*fields))
7098 /* Again guessing that the pushmark can be jumped over.... */
7099 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7100 ->op_first->op_sibling;
7101 /* Check that the key list contains only constants. */
7102 for (key_op = first_key_op; key_op;
7103 key_op = (SVOP*)key_op->op_sibling)
7104 if (key_op->op_type != OP_CONST)
7108 rop->op_type = OP_RV2AV;
7109 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7110 o->op_type = OP_ASLICE;
7111 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7112 for (key_op = first_key_op; key_op;
7113 key_op = (SVOP*)key_op->op_sibling) {
7114 svp = cSVOPx_svp(key_op);
7115 key = SvPV(*svp, keylen);
7116 indsvp = hv_fetch(GvHV(*fields), key,
7117 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7119 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7120 "in variable %s of type %s",
7121 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7123 ind = SvIV(*indsvp);
7125 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7127 if (SvREADONLY(*svp))
7129 SvFLAGS(sv) |= (SvFLAGS(*svp)
7130 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7138 o->op_seq = PL_op_seqmax++;
7148 char* Perl_custom_op_name(pTHX_ OP* o)
7150 IV index = PTR2IV(o->op_ppaddr);
7154 if (!PL_custom_op_names) /* This probably shouldn't happen */
7155 return PL_op_name[OP_CUSTOM];
7157 keysv = sv_2mortal(newSViv(index));
7159 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7161 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7163 return SvPV_nolen(HeVAL(he));
7166 char* Perl_custom_op_desc(pTHX_ OP* o)
7168 IV index = PTR2IV(o->op_ppaddr);
7172 if (!PL_custom_op_descs)
7173 return PL_op_desc[OP_CUSTOM];
7175 keysv = sv_2mortal(newSViv(index));
7177 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7179 return PL_op_desc[OP_CUSTOM];
7181 return SvPV_nolen(HeVAL(he));
7187 /* Efficient sub that returns a constant scalar value. */
7189 const_sv_xsub(pTHX_ CV* cv)
7194 Perl_croak(aTHX_ "usage: %s::%s()",
7195 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7199 ST(0) = (SV*)XSANY.any_ptr;