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 #if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
28 #define SLAB_SIZE 8192
29 static char *PL_OpPtr = NULL; /* XXX threadead */
30 static int PL_OpSpace = 0; /* XXX threadead */
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);
1028 if (ckWARN(WARN_VOID))
1029 Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
1035 Perl_scalarvoid(pTHX_ OP *o)
1042 if (o->op_type == OP_NEXTSTATE
1043 || o->op_type == OP_SETSTATE
1044 || o->op_type == OP_DBSTATE
1045 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1046 || o->op_targ == OP_SETSTATE
1047 || o->op_targ == OP_DBSTATE)))
1048 PL_curcop = (COP*)o; /* for warning below */
1050 /* assumes no premature commitment */
1051 want = o->op_flags & OPf_WANT;
1052 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1053 || o->op_type == OP_RETURN)
1058 if ((o->op_private & OPpTARGET_MY)
1059 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1061 return scalar(o); /* As if inside SASSIGN */
1064 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1066 switch (o->op_type) {
1068 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1072 if (o->op_flags & OPf_STACKED)
1076 if (o->op_private == 4)
1118 case OP_GETSOCKNAME:
1119 case OP_GETPEERNAME:
1124 case OP_GETPRIORITY:
1147 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1148 useless = OP_DESC(o);
1155 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1156 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1157 useless = "a variable";
1162 if (cSVOPo->op_private & OPpCONST_STRICT)
1163 no_bareword_allowed(o);
1165 if (ckWARN(WARN_VOID)) {
1166 useless = "a constant";
1167 /* the constants 0 and 1 are permitted as they are
1168 conventionally used as dummies in constructs like
1169 1 while some_condition_with_side_effects; */
1170 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1172 else if (SvPOK(sv)) {
1173 /* perl4's way of mixing documentation and code
1174 (before the invention of POD) was based on a
1175 trick to mix nroff and perl code. The trick was
1176 built upon these three nroff macros being used in
1177 void context. The pink camel has the details in
1178 the script wrapman near page 319. */
1179 if (strnEQ(SvPVX(sv), "di", 2) ||
1180 strnEQ(SvPVX(sv), "ds", 2) ||
1181 strnEQ(SvPVX(sv), "ig", 2))
1186 op_null(o); /* don't execute or even remember it */
1190 o->op_type = OP_PREINC; /* pre-increment is faster */
1191 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1195 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1196 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1202 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1207 if (o->op_flags & OPf_STACKED)
1214 if (!(o->op_flags & OPf_KIDS))
1223 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1230 /* all requires must return a boolean value */
1231 o->op_flags &= ~OPf_WANT;
1236 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1237 if (!kPMOP->op_pmreplroot)
1238 deprecate("implicit split to @_");
1242 if (useless && ckWARN(WARN_VOID))
1243 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1248 Perl_listkids(pTHX_ OP *o)
1251 if (o && o->op_flags & OPf_KIDS) {
1252 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1259 Perl_list(pTHX_ OP *o)
1263 /* assumes no premature commitment */
1264 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1265 || o->op_type == OP_RETURN)
1270 if ((o->op_private & OPpTARGET_MY)
1271 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1273 return o; /* As if inside SASSIGN */
1276 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1278 switch (o->op_type) {
1281 list(cBINOPo->op_first);
1286 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1294 if (!(o->op_flags & OPf_KIDS))
1296 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1297 list(cBINOPo->op_first);
1298 return gen_constant_list(o);
1305 kid = cLISTOPo->op_first;
1307 while ((kid = kid->op_sibling)) {
1308 if (kid->op_sibling)
1313 WITH_THR(PL_curcop = &PL_compiling);
1317 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1318 if (kid->op_sibling)
1323 WITH_THR(PL_curcop = &PL_compiling);
1326 /* all requires must return a boolean value */
1327 o->op_flags &= ~OPf_WANT;
1334 Perl_scalarseq(pTHX_ OP *o)
1339 if (o->op_type == OP_LINESEQ ||
1340 o->op_type == OP_SCOPE ||
1341 o->op_type == OP_LEAVE ||
1342 o->op_type == OP_LEAVETRY)
1344 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1345 if (kid->op_sibling) {
1349 PL_curcop = &PL_compiling;
1351 o->op_flags &= ~OPf_PARENS;
1352 if (PL_hints & HINT_BLOCK_SCOPE)
1353 o->op_flags |= OPf_PARENS;
1356 o = newOP(OP_STUB, 0);
1361 S_modkids(pTHX_ OP *o, I32 type)
1364 if (o && o->op_flags & OPf_KIDS) {
1365 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1372 Perl_mod(pTHX_ OP *o, I32 type)
1377 if (!o || PL_error_count)
1380 if ((o->op_private & OPpTARGET_MY)
1381 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1386 switch (o->op_type) {
1391 if (!(o->op_private & (OPpCONST_ARYBASE)))
1393 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1394 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1398 SAVEI32(PL_compiling.cop_arybase);
1399 PL_compiling.cop_arybase = 0;
1401 else if (type == OP_REFGEN)
1404 Perl_croak(aTHX_ "That use of $[ is unsupported");
1407 if (o->op_flags & OPf_PARENS)
1411 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1412 !(o->op_flags & OPf_STACKED)) {
1413 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1414 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1415 assert(cUNOPo->op_first->op_type == OP_NULL);
1416 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1419 else { /* lvalue subroutine call */
1420 o->op_private |= OPpLVAL_INTRO;
1421 PL_modcount = RETURN_UNLIMITED_NUMBER;
1422 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1423 /* Backward compatibility mode: */
1424 o->op_private |= OPpENTERSUB_INARGS;
1427 else { /* Compile-time error message: */
1428 OP *kid = cUNOPo->op_first;
1432 if (kid->op_type == OP_PUSHMARK)
1434 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1436 "panic: unexpected lvalue entersub "
1437 "args: type/targ %ld:%"UVuf,
1438 (long)kid->op_type, (UV)kid->op_targ);
1439 kid = kLISTOP->op_first;
1441 while (kid->op_sibling)
1442 kid = kid->op_sibling;
1443 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1445 if (kid->op_type == OP_METHOD_NAMED
1446 || kid->op_type == OP_METHOD)
1450 NewOp(1101, newop, 1, UNOP);
1451 newop->op_type = OP_RV2CV;
1452 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1453 newop->op_first = Nullop;
1454 newop->op_next = (OP*)newop;
1455 kid->op_sibling = (OP*)newop;
1456 newop->op_private |= OPpLVAL_INTRO;
1460 if (kid->op_type != OP_RV2CV)
1462 "panic: unexpected lvalue entersub "
1463 "entry via type/targ %ld:%"UVuf,
1464 (long)kid->op_type, (UV)kid->op_targ);
1465 kid->op_private |= OPpLVAL_INTRO;
1466 break; /* Postpone until runtime */
1470 kid = kUNOP->op_first;
1471 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL)
1475 "Unexpected constant lvalue entersub "
1476 "entry via type/targ %ld:%"UVuf,
1477 (long)kid->op_type, (UV)kid->op_targ);
1478 if (kid->op_type != OP_GV) {
1479 /* Restore RV2CV to check lvalueness */
1481 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1482 okid->op_next = kid->op_next;
1483 kid->op_next = okid;
1486 okid->op_next = Nullop;
1487 okid->op_type = OP_RV2CV;
1489 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1490 okid->op_private |= OPpLVAL_INTRO;
1494 cv = GvCV(kGVOP_gv);
1504 /* grep, foreach, subcalls, refgen */
1505 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1507 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1508 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1510 : (o->op_type == OP_ENTERSUB
1511 ? "non-lvalue subroutine call"
1513 type ? PL_op_desc[type] : "local"));
1527 case OP_RIGHT_SHIFT:
1536 if (!(o->op_flags & OPf_STACKED))
1542 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1548 if (!type && cUNOPo->op_first->op_type != OP_GV)
1549 Perl_croak(aTHX_ "Can't localize through a reference");
1550 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1551 PL_modcount = RETURN_UNLIMITED_NUMBER;
1552 return o; /* Treat \(@foo) like ordinary list. */
1556 if (scalar_mod_type(o, type))
1558 ref(cUNOPo->op_first, o->op_type);
1562 if (type == OP_LEAVESUBLV)
1563 o->op_private |= OPpMAYBE_LVSUB;
1569 PL_modcount = RETURN_UNLIMITED_NUMBER;
1572 if (!type && cUNOPo->op_first->op_type != OP_GV)
1573 Perl_croak(aTHX_ "Can't localize through a reference");
1574 ref(cUNOPo->op_first, o->op_type);
1578 PL_hints |= HINT_BLOCK_SCOPE;
1588 PL_modcount = RETURN_UNLIMITED_NUMBER;
1589 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1590 return o; /* Treat \(@foo) like ordinary list. */
1591 if (scalar_mod_type(o, type))
1593 if (type == OP_LEAVESUBLV)
1594 o->op_private |= OPpMAYBE_LVSUB;
1599 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1600 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1603 #ifdef USE_5005THREADS
1605 PL_modcount++; /* XXX ??? */
1607 #endif /* USE_5005THREADS */
1613 if (type != OP_SASSIGN)
1617 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1622 if (type == OP_LEAVESUBLV)
1623 o->op_private |= OPpMAYBE_LVSUB;
1625 pad_free(o->op_targ);
1626 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1627 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1628 if (o->op_flags & OPf_KIDS)
1629 mod(cBINOPo->op_first->op_sibling, type);
1634 ref(cBINOPo->op_first, o->op_type);
1635 if (type == OP_ENTERSUB &&
1636 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1637 o->op_private |= OPpLVAL_DEFER;
1638 if (type == OP_LEAVESUBLV)
1639 o->op_private |= OPpMAYBE_LVSUB;
1647 if (o->op_flags & OPf_KIDS)
1648 mod(cLISTOPo->op_last, type);
1652 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1654 else if (!(o->op_flags & OPf_KIDS))
1656 if (o->op_targ != OP_LIST) {
1657 mod(cBINOPo->op_first, type);
1662 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1667 if (type != OP_LEAVESUBLV)
1669 break; /* mod()ing was handled by ck_return() */
1672 /* [20011101.069] File test operators interpret OPf_REF to mean that
1673 their argument is a filehandle; thus \stat(".") should not set
1675 if (type == OP_REFGEN &&
1676 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1679 if (type != OP_LEAVESUBLV)
1680 o->op_flags |= OPf_MOD;
1682 if (type == OP_AASSIGN || type == OP_SASSIGN)
1683 o->op_flags |= OPf_SPECIAL|OPf_REF;
1685 o->op_private |= OPpLVAL_INTRO;
1686 o->op_flags &= ~OPf_SPECIAL;
1687 PL_hints |= HINT_BLOCK_SCOPE;
1689 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1690 && type != OP_LEAVESUBLV)
1691 o->op_flags |= OPf_REF;
1696 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1700 if (o->op_type == OP_RV2GV)
1724 case OP_RIGHT_SHIFT:
1743 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1745 switch (o->op_type) {
1753 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1766 Perl_refkids(pTHX_ OP *o, I32 type)
1769 if (o && o->op_flags & OPf_KIDS) {
1770 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1777 Perl_ref(pTHX_ OP *o, I32 type)
1781 if (!o || PL_error_count)
1784 switch (o->op_type) {
1786 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1787 !(o->op_flags & OPf_STACKED)) {
1788 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1789 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1790 assert(cUNOPo->op_first->op_type == OP_NULL);
1791 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1792 o->op_flags |= OPf_SPECIAL;
1797 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1801 if (type == OP_DEFINED)
1802 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1803 ref(cUNOPo->op_first, o->op_type);
1806 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1807 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1808 : type == OP_RV2HV ? OPpDEREF_HV
1810 o->op_flags |= OPf_MOD;
1815 o->op_flags |= OPf_MOD; /* XXX ??? */
1820 o->op_flags |= OPf_REF;
1823 if (type == OP_DEFINED)
1824 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1825 ref(cUNOPo->op_first, o->op_type);
1830 o->op_flags |= OPf_REF;
1835 if (!(o->op_flags & OPf_KIDS))
1837 ref(cBINOPo->op_first, type);
1841 ref(cBINOPo->op_first, o->op_type);
1842 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1843 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1844 : type == OP_RV2HV ? OPpDEREF_HV
1846 o->op_flags |= OPf_MOD;
1854 if (!(o->op_flags & OPf_KIDS))
1856 ref(cLISTOPo->op_last, type);
1866 S_dup_attrlist(pTHX_ OP *o)
1870 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1871 * where the first kid is OP_PUSHMARK and the remaining ones
1872 * are OP_CONST. We need to push the OP_CONST values.
1874 if (o->op_type == OP_CONST)
1875 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1877 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1878 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1879 if (o->op_type == OP_CONST)
1880 rop = append_elem(OP_LIST, rop,
1881 newSVOP(OP_CONST, o->op_flags,
1882 SvREFCNT_inc(cSVOPo->op_sv)));
1889 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1893 /* fake up C<use attributes $pkg,$rv,@attrs> */
1894 ENTER; /* need to protect against side-effects of 'use' */
1897 stashsv = newSVpv(HvNAME(stash), 0);
1899 stashsv = &PL_sv_no;
1901 #define ATTRSMODULE "attributes"
1903 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1904 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1906 prepend_elem(OP_LIST,
1907 newSVOP(OP_CONST, 0, stashsv),
1908 prepend_elem(OP_LIST,
1909 newSVOP(OP_CONST, 0,
1911 dup_attrlist(attrs))));
1916 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1917 char *attrstr, STRLEN len)
1922 len = strlen(attrstr);
1926 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1928 char *sstr = attrstr;
1929 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1930 attrs = append_elem(OP_LIST, attrs,
1931 newSVOP(OP_CONST, 0,
1932 newSVpvn(sstr, attrstr-sstr)));
1936 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1937 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1938 Nullsv, prepend_elem(OP_LIST,
1939 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1940 prepend_elem(OP_LIST,
1941 newSVOP(OP_CONST, 0,
1947 S_my_kid(pTHX_ OP *o, OP *attrs)
1952 if (!o || PL_error_count)
1956 if (type == OP_LIST) {
1957 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1959 } else if (type == OP_UNDEF) {
1961 } else if (type == OP_RV2SV || /* "our" declaration */
1963 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1965 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1967 PL_in_my_stash = Nullhv;
1968 apply_attrs(GvSTASH(gv),
1969 (type == OP_RV2SV ? GvSV(gv) :
1970 type == OP_RV2AV ? (SV*)GvAV(gv) :
1971 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1974 o->op_private |= OPpOUR_INTRO;
1976 } else if (type != OP_PADSV &&
1979 type != OP_PUSHMARK)
1981 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1983 PL_in_my == KEY_our ? "our" : "my"));
1986 else if (attrs && type != OP_PUSHMARK) {
1992 PL_in_my_stash = Nullhv;
1994 /* check for C<my Dog $spot> when deciding package */
1995 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1996 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1997 stash = SvSTASH(*namesvp);
1999 stash = PL_curstash;
2000 padsv = PAD_SV(o->op_targ);
2001 apply_attrs(stash, padsv, attrs);
2003 o->op_flags |= OPf_MOD;
2004 o->op_private |= OPpLVAL_INTRO;
2009 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2011 if (o->op_flags & OPf_PARENS)
2015 o = my_kid(o, attrs);
2017 PL_in_my_stash = Nullhv;
2022 Perl_my(pTHX_ OP *o)
2024 return my_kid(o, Nullop);
2028 Perl_sawparens(pTHX_ OP *o)
2031 o->op_flags |= OPf_PARENS;
2036 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2040 if (ckWARN(WARN_MISC) &&
2041 (left->op_type == OP_RV2AV ||
2042 left->op_type == OP_RV2HV ||
2043 left->op_type == OP_PADAV ||
2044 left->op_type == OP_PADHV)) {
2045 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2046 right->op_type == OP_TRANS)
2047 ? right->op_type : OP_MATCH];
2048 const char *sample = ((left->op_type == OP_RV2AV ||
2049 left->op_type == OP_PADAV)
2050 ? "@array" : "%hash");
2051 Perl_warner(aTHX_ WARN_MISC,
2052 "Applying %s to %s will act on scalar(%s)",
2053 desc, sample, sample);
2056 if (!(right->op_flags & OPf_STACKED) &&
2057 (right->op_type == OP_MATCH ||
2058 right->op_type == OP_SUBST ||
2059 right->op_type == OP_TRANS)) {
2060 right->op_flags |= OPf_STACKED;
2061 if ((right->op_type != OP_MATCH &&
2062 ! (right->op_type == OP_TRANS &&
2063 right->op_private & OPpTRANS_IDENTICAL)) ||
2064 /* if SV has magic, then match on original SV, not on its copy.
2065 see note in pp_helem() */
2066 (right->op_type == OP_MATCH &&
2067 (left->op_type == OP_AELEM ||
2068 left->op_type == OP_HELEM ||
2069 left->op_type == OP_AELEMFAST)))
2070 left = mod(left, right->op_type);
2071 if (right->op_type == OP_TRANS)
2072 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2074 o = prepend_elem(right->op_type, scalar(left), right);
2076 return newUNOP(OP_NOT, 0, scalar(o));
2080 return bind_match(type, left,
2081 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2085 Perl_invert(pTHX_ OP *o)
2089 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2090 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2094 Perl_scope(pTHX_ OP *o)
2097 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2098 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2099 o->op_type = OP_LEAVE;
2100 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2103 if (o->op_type == OP_LINESEQ) {
2105 o->op_type = OP_SCOPE;
2106 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2107 kid = ((LISTOP*)o)->op_first;
2108 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2112 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2119 Perl_save_hints(pTHX)
2122 SAVESPTR(GvHV(PL_hintgv));
2123 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2124 SAVEFREESV(GvHV(PL_hintgv));
2128 Perl_block_start(pTHX_ int full)
2130 int retval = PL_savestack_ix;
2132 SAVEI32(PL_comppad_name_floor);
2133 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2135 PL_comppad_name_fill = PL_comppad_name_floor;
2136 if (PL_comppad_name_floor < 0)
2137 PL_comppad_name_floor = 0;
2138 SAVEI32(PL_min_intro_pending);
2139 SAVEI32(PL_max_intro_pending);
2140 PL_min_intro_pending = 0;
2141 SAVEI32(PL_comppad_name_fill);
2142 SAVEI32(PL_padix_floor);
2143 PL_padix_floor = PL_padix;
2144 PL_pad_reset_pending = FALSE;
2146 PL_hints &= ~HINT_BLOCK_SCOPE;
2147 SAVESPTR(PL_compiling.cop_warnings);
2148 if (! specialWARN(PL_compiling.cop_warnings)) {
2149 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2150 SAVEFREESV(PL_compiling.cop_warnings) ;
2152 SAVESPTR(PL_compiling.cop_io);
2153 if (! specialCopIO(PL_compiling.cop_io)) {
2154 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2155 SAVEFREESV(PL_compiling.cop_io) ;
2161 Perl_block_end(pTHX_ I32 floor, OP *seq)
2163 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2164 line_t copline = PL_copline;
2165 /* there should be a nextstate in every block */
2166 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2167 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2169 PL_pad_reset_pending = FALSE;
2170 PL_compiling.op_private = PL_hints;
2172 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2173 pad_leavemy(PL_comppad_name_fill);
2181 #ifdef USE_5005THREADS
2182 OP *o = newOP(OP_THREADSV, 0);
2183 o->op_targ = find_threadsv("_");
2186 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2187 #endif /* USE_5005THREADS */
2191 Perl_newPROG(pTHX_ OP *o)
2196 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2197 ((PL_in_eval & EVAL_KEEPERR)
2198 ? OPf_SPECIAL : 0), o);
2199 PL_eval_start = linklist(PL_eval_root);
2200 PL_eval_root->op_private |= OPpREFCOUNTED;
2201 OpREFCNT_set(PL_eval_root, 1);
2202 PL_eval_root->op_next = 0;
2203 CALL_PEEP(PL_eval_start);
2208 PL_main_root = scope(sawparens(scalarvoid(o)));
2209 PL_curcop = &PL_compiling;
2210 PL_main_start = LINKLIST(PL_main_root);
2211 PL_main_root->op_private |= OPpREFCOUNTED;
2212 OpREFCNT_set(PL_main_root, 1);
2213 PL_main_root->op_next = 0;
2214 CALL_PEEP(PL_main_start);
2217 /* Register with debugger */
2219 CV *cv = get_cv("DB::postponed", FALSE);
2223 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2225 call_sv((SV*)cv, G_DISCARD);
2232 Perl_localize(pTHX_ OP *o, I32 lex)
2234 if (o->op_flags & OPf_PARENS)
2237 if (ckWARN(WARN_PARENTHESIS)
2238 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2240 char *s = PL_bufptr;
2242 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2245 if (*s == ';' || *s == '=')
2246 Perl_warner(aTHX_ WARN_PARENTHESIS,
2247 "Parentheses missing around \"%s\" list",
2248 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2254 o = mod(o, OP_NULL); /* a bit kludgey */
2256 PL_in_my_stash = Nullhv;
2261 Perl_jmaybe(pTHX_ OP *o)
2263 if (o->op_type == OP_LIST) {
2265 #ifdef USE_5005THREADS
2266 o2 = newOP(OP_THREADSV, 0);
2267 o2->op_targ = find_threadsv(";");
2269 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2270 #endif /* USE_5005THREADS */
2271 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2277 Perl_fold_constants(pTHX_ register OP *o)
2280 I32 type = o->op_type;
2283 if (PL_opargs[type] & OA_RETSCALAR)
2285 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2286 o->op_targ = pad_alloc(type, SVs_PADTMP);
2288 /* integerize op, unless it happens to be C<-foo>.
2289 * XXX should pp_i_negate() do magic string negation instead? */
2290 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2291 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2292 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2294 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2297 if (!(PL_opargs[type] & OA_FOLDCONST))
2302 /* XXX might want a ck_negate() for this */
2303 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2315 /* XXX what about the numeric ops? */
2316 if (PL_hints & HINT_LOCALE)
2321 goto nope; /* Don't try to run w/ errors */
2323 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2324 if ((curop->op_type != OP_CONST ||
2325 (curop->op_private & OPpCONST_BARE)) &&
2326 curop->op_type != OP_LIST &&
2327 curop->op_type != OP_SCALAR &&
2328 curop->op_type != OP_NULL &&
2329 curop->op_type != OP_PUSHMARK)
2335 curop = LINKLIST(o);
2339 sv = *(PL_stack_sp--);
2340 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2341 pad_swipe(o->op_targ);
2342 else if (SvTEMP(sv)) { /* grab mortal temp? */
2343 (void)SvREFCNT_inc(sv);
2347 if (type == OP_RV2GV)
2348 return newGVOP(OP_GV, 0, (GV*)sv);
2350 /* try to smush double to int, but don't smush -2.0 to -2 */
2351 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2354 #ifdef PERL_PRESERVE_IVUV
2355 /* Only bother to attempt to fold to IV if
2356 most operators will benefit */
2360 return newSVOP(OP_CONST, 0, sv);
2364 if (!(PL_opargs[type] & OA_OTHERINT))
2367 if (!(PL_hints & HINT_INTEGER)) {
2368 if (type == OP_MODULO
2369 || type == OP_DIVIDE
2370 || !(o->op_flags & OPf_KIDS))
2375 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2376 if (curop->op_type == OP_CONST) {
2377 if (SvIOK(((SVOP*)curop)->op_sv))
2381 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2385 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2392 Perl_gen_constant_list(pTHX_ register OP *o)
2395 I32 oldtmps_floor = PL_tmps_floor;
2399 return o; /* Don't attempt to run with errors */
2401 PL_op = curop = LINKLIST(o);
2408 PL_tmps_floor = oldtmps_floor;
2410 o->op_type = OP_RV2AV;
2411 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2412 curop = ((UNOP*)o)->op_first;
2413 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2420 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2422 if (!o || o->op_type != OP_LIST)
2423 o = newLISTOP(OP_LIST, 0, o, Nullop);
2425 o->op_flags &= ~OPf_WANT;
2427 if (!(PL_opargs[type] & OA_MARK))
2428 op_null(cLISTOPo->op_first);
2431 o->op_ppaddr = PL_ppaddr[type];
2432 o->op_flags |= flags;
2434 o = CHECKOP(type, o);
2435 if (o->op_type != type)
2438 return fold_constants(o);
2441 /* List constructors */
2444 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2452 if (first->op_type != type
2453 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2455 return newLISTOP(type, 0, first, last);
2458 if (first->op_flags & OPf_KIDS)
2459 ((LISTOP*)first)->op_last->op_sibling = last;
2461 first->op_flags |= OPf_KIDS;
2462 ((LISTOP*)first)->op_first = last;
2464 ((LISTOP*)first)->op_last = last;
2469 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2477 if (first->op_type != type)
2478 return prepend_elem(type, (OP*)first, (OP*)last);
2480 if (last->op_type != type)
2481 return append_elem(type, (OP*)first, (OP*)last);
2483 first->op_last->op_sibling = last->op_first;
2484 first->op_last = last->op_last;
2485 first->op_flags |= (last->op_flags & OPf_KIDS);
2487 #ifdef PL_OP_SLAB_ALLOC
2495 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2503 if (last->op_type == type) {
2504 if (type == OP_LIST) { /* already a PUSHMARK there */
2505 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2506 ((LISTOP*)last)->op_first->op_sibling = first;
2507 if (!(first->op_flags & OPf_PARENS))
2508 last->op_flags &= ~OPf_PARENS;
2511 if (!(last->op_flags & OPf_KIDS)) {
2512 ((LISTOP*)last)->op_last = first;
2513 last->op_flags |= OPf_KIDS;
2515 first->op_sibling = ((LISTOP*)last)->op_first;
2516 ((LISTOP*)last)->op_first = first;
2518 last->op_flags |= OPf_KIDS;
2522 return newLISTOP(type, 0, first, last);
2528 Perl_newNULLLIST(pTHX)
2530 return newOP(OP_STUB, 0);
2534 Perl_force_list(pTHX_ OP *o)
2536 if (!o || o->op_type != OP_LIST)
2537 o = newLISTOP(OP_LIST, 0, o, Nullop);
2543 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2547 NewOp(1101, listop, 1, LISTOP);
2549 listop->op_type = type;
2550 listop->op_ppaddr = PL_ppaddr[type];
2553 listop->op_flags = flags;
2557 else if (!first && last)
2560 first->op_sibling = last;
2561 listop->op_first = first;
2562 listop->op_last = last;
2563 if (type == OP_LIST) {
2565 pushop = newOP(OP_PUSHMARK, 0);
2566 pushop->op_sibling = first;
2567 listop->op_first = pushop;
2568 listop->op_flags |= OPf_KIDS;
2570 listop->op_last = pushop;
2577 Perl_newOP(pTHX_ I32 type, I32 flags)
2580 NewOp(1101, o, 1, OP);
2582 o->op_ppaddr = PL_ppaddr[type];
2583 o->op_flags = flags;
2586 o->op_private = 0 + (flags >> 8);
2587 if (PL_opargs[type] & OA_RETSCALAR)
2589 if (PL_opargs[type] & OA_TARGET)
2590 o->op_targ = pad_alloc(type, SVs_PADTMP);
2591 return CHECKOP(type, o);
2595 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2600 first = newOP(OP_STUB, 0);
2601 if (PL_opargs[type] & OA_MARK)
2602 first = force_list(first);
2604 NewOp(1101, unop, 1, UNOP);
2605 unop->op_type = type;
2606 unop->op_ppaddr = PL_ppaddr[type];
2607 unop->op_first = first;
2608 unop->op_flags = flags | OPf_KIDS;
2609 unop->op_private = 1 | (flags >> 8);
2610 unop = (UNOP*) CHECKOP(type, unop);
2614 return fold_constants((OP *) unop);
2618 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2621 NewOp(1101, binop, 1, BINOP);
2624 first = newOP(OP_NULL, 0);
2626 binop->op_type = type;
2627 binop->op_ppaddr = PL_ppaddr[type];
2628 binop->op_first = first;
2629 binop->op_flags = flags | OPf_KIDS;
2632 binop->op_private = 1 | (flags >> 8);
2635 binop->op_private = 2 | (flags >> 8);
2636 first->op_sibling = last;
2639 binop = (BINOP*)CHECKOP(type, binop);
2640 if (binop->op_next || binop->op_type != type)
2643 binop->op_last = binop->op_first->op_sibling;
2645 return fold_constants((OP *)binop);
2649 uvcompare(const void *a, const void *b)
2651 if (*((UV *)a) < (*(UV *)b))
2653 if (*((UV *)a) > (*(UV *)b))
2655 if (*((UV *)a+1) < (*(UV *)b+1))
2657 if (*((UV *)a+1) > (*(UV *)b+1))
2663 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2665 SV *tstr = ((SVOP*)expr)->op_sv;
2666 SV *rstr = ((SVOP*)repl)->op_sv;
2669 U8 *t = (U8*)SvPV(tstr, tlen);
2670 U8 *r = (U8*)SvPV(rstr, rlen);
2677 register short *tbl;
2679 PL_hints |= HINT_BLOCK_SCOPE;
2680 complement = o->op_private & OPpTRANS_COMPLEMENT;
2681 del = o->op_private & OPpTRANS_DELETE;
2682 squash = o->op_private & OPpTRANS_SQUASH;
2685 o->op_private |= OPpTRANS_FROM_UTF;
2688 o->op_private |= OPpTRANS_TO_UTF;
2690 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2691 SV* listsv = newSVpvn("# comment\n",10);
2693 U8* tend = t + tlen;
2694 U8* rend = r + rlen;
2708 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2709 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2715 tsave = t = bytes_to_utf8(t, &len);
2718 if (!to_utf && rlen) {
2720 rsave = r = bytes_to_utf8(r, &len);
2724 /* There are several snags with this code on EBCDIC:
2725 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2726 2. scan_const() in toke.c has encoded chars in native encoding which makes
2727 ranges at least in EBCDIC 0..255 range the bottom odd.
2731 U8 tmpbuf[UTF8_MAXLEN+1];
2734 New(1109, cp, 2*tlen, UV);
2736 transv = newSVpvn("",0);
2738 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2740 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2742 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2746 cp[2*i+1] = cp[2*i];
2750 qsort(cp, i, 2*sizeof(UV), uvcompare);
2751 for (j = 0; j < i; j++) {
2753 diff = val - nextmin;
2755 t = uvuni_to_utf8(tmpbuf,nextmin);
2756 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2758 U8 range_mark = UTF_TO_NATIVE(0xff);
2759 t = uvuni_to_utf8(tmpbuf, val - 1);
2760 sv_catpvn(transv, (char *)&range_mark, 1);
2761 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2768 t = uvuni_to_utf8(tmpbuf,nextmin);
2769 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2771 U8 range_mark = UTF_TO_NATIVE(0xff);
2772 sv_catpvn(transv, (char *)&range_mark, 1);
2774 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2775 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2776 t = (U8*)SvPVX(transv);
2777 tlen = SvCUR(transv);
2781 else if (!rlen && !del) {
2782 r = t; rlen = tlen; rend = tend;
2785 if ((!rlen && !del) || t == r ||
2786 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2788 o->op_private |= OPpTRANS_IDENTICAL;
2792 while (t < tend || tfirst <= tlast) {
2793 /* see if we need more "t" chars */
2794 if (tfirst > tlast) {
2795 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2797 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2799 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2806 /* now see if we need more "r" chars */
2807 if (rfirst > rlast) {
2809 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2811 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2813 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2822 rfirst = rlast = 0xffffffff;
2826 /* now see which range will peter our first, if either. */
2827 tdiff = tlast - tfirst;
2828 rdiff = rlast - rfirst;
2835 if (rfirst == 0xffffffff) {
2836 diff = tdiff; /* oops, pretend rdiff is infinite */
2838 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2839 (long)tfirst, (long)tlast);
2841 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2845 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2846 (long)tfirst, (long)(tfirst + diff),
2849 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2850 (long)tfirst, (long)rfirst);
2852 if (rfirst + diff > max)
2853 max = rfirst + diff;
2855 grows = (tfirst < rfirst &&
2856 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2868 else if (max > 0xff)
2873 Safefree(cPVOPo->op_pv);
2874 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2875 SvREFCNT_dec(listsv);
2877 SvREFCNT_dec(transv);
2879 if (!del && havefinal && rlen)
2880 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2881 newSVuv((UV)final), 0);
2884 o->op_private |= OPpTRANS_GROWS;
2896 tbl = (short*)cPVOPo->op_pv;
2898 Zero(tbl, 256, short);
2899 for (i = 0; i < tlen; i++)
2901 for (i = 0, j = 0; i < 256; i++) {
2912 if (i < 128 && r[j] >= 128)
2922 o->op_private |= OPpTRANS_IDENTICAL;
2927 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2928 tbl[0x100] = rlen - j;
2929 for (i=0; i < rlen - j; i++)
2930 tbl[0x101+i] = r[j+i];
2934 if (!rlen && !del) {
2937 o->op_private |= OPpTRANS_IDENTICAL;
2939 for (i = 0; i < 256; i++)
2941 for (i = 0, j = 0; i < tlen; i++,j++) {
2944 if (tbl[t[i]] == -1)
2950 if (tbl[t[i]] == -1) {
2951 if (t[i] < 128 && r[j] >= 128)
2958 o->op_private |= OPpTRANS_GROWS;
2966 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2970 NewOp(1101, pmop, 1, PMOP);
2971 pmop->op_type = type;
2972 pmop->op_ppaddr = PL_ppaddr[type];
2973 pmop->op_flags = flags;
2974 pmop->op_private = 0 | (flags >> 8);
2976 if (PL_hints & HINT_RE_TAINT)
2977 pmop->op_pmpermflags |= PMf_RETAINT;
2978 if (PL_hints & HINT_LOCALE)
2979 pmop->op_pmpermflags |= PMf_LOCALE;
2980 pmop->op_pmflags = pmop->op_pmpermflags;
2985 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2986 repointer = av_pop((AV*)PL_regex_pad[0]);
2987 pmop->op_pmoffset = SvIV(repointer);
2988 SvREPADTMP_off(repointer);
2989 sv_setiv(repointer,0);
2991 repointer = newSViv(0);
2992 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2993 pmop->op_pmoffset = av_len(PL_regex_padav);
2994 PL_regex_pad = AvARRAY(PL_regex_padav);
2999 /* link into pm list */
3000 if (type != OP_TRANS && PL_curstash) {
3001 pmop->op_pmnext = HvPMROOT(PL_curstash);
3002 HvPMROOT(PL_curstash) = pmop;
3003 PmopSTASH_set(pmop,PL_curstash);
3010 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3014 I32 repl_has_vars = 0;
3016 if (o->op_type == OP_TRANS)
3017 return pmtrans(o, expr, repl);
3019 PL_hints |= HINT_BLOCK_SCOPE;
3022 if (expr->op_type == OP_CONST) {
3024 SV *pat = ((SVOP*)expr)->op_sv;
3025 char *p = SvPV(pat, plen);
3026 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3027 sv_setpvn(pat, "\\s+", 3);
3028 p = SvPV(pat, plen);
3029 pm->op_pmflags |= PMf_SKIPWHITE;
3031 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3032 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3033 pm->op_pmflags |= PMf_WHITE;
3037 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3038 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3040 : OP_REGCMAYBE),0,expr);
3042 NewOp(1101, rcop, 1, LOGOP);
3043 rcop->op_type = OP_REGCOMP;
3044 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3045 rcop->op_first = scalar(expr);
3046 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3047 ? (OPf_SPECIAL | OPf_KIDS)
3049 rcop->op_private = 1;
3052 /* establish postfix order */
3053 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3055 rcop->op_next = expr;
3056 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3059 rcop->op_next = LINKLIST(expr);
3060 expr->op_next = (OP*)rcop;
3063 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3068 if (pm->op_pmflags & PMf_EVAL) {
3070 if (CopLINE(PL_curcop) < PL_multi_end)
3071 CopLINE_set(PL_curcop, PL_multi_end);
3073 #ifdef USE_5005THREADS
3074 else if (repl->op_type == OP_THREADSV
3075 && strchr("&`'123456789+",
3076 PL_threadsv_names[repl->op_targ]))
3080 #endif /* USE_5005THREADS */
3081 else if (repl->op_type == OP_CONST)
3085 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3086 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3087 #ifdef USE_5005THREADS
3088 if (curop->op_type == OP_THREADSV) {
3090 if (strchr("&`'123456789+", curop->op_private))
3094 if (curop->op_type == OP_GV) {
3095 GV *gv = cGVOPx_gv(curop);
3097 if (strchr("&`'123456789+", *GvENAME(gv)))
3100 #endif /* USE_5005THREADS */
3101 else if (curop->op_type == OP_RV2CV)
3103 else if (curop->op_type == OP_RV2SV ||
3104 curop->op_type == OP_RV2AV ||
3105 curop->op_type == OP_RV2HV ||
3106 curop->op_type == OP_RV2GV) {
3107 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3110 else if (curop->op_type == OP_PADSV ||
3111 curop->op_type == OP_PADAV ||
3112 curop->op_type == OP_PADHV ||
3113 curop->op_type == OP_PADANY) {
3116 else if (curop->op_type == OP_PUSHRE)
3117 ; /* Okay here, dangerous in newASSIGNOP */
3127 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3128 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3129 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3130 prepend_elem(o->op_type, scalar(repl), o);
3133 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3134 pm->op_pmflags |= PMf_MAYBE_CONST;
3135 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3137 NewOp(1101, rcop, 1, LOGOP);
3138 rcop->op_type = OP_SUBSTCONT;
3139 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3140 rcop->op_first = scalar(repl);
3141 rcop->op_flags |= OPf_KIDS;
3142 rcop->op_private = 1;
3145 /* establish postfix order */
3146 rcop->op_next = LINKLIST(repl);
3147 repl->op_next = (OP*)rcop;
3149 pm->op_pmreplroot = scalar((OP*)rcop);
3150 pm->op_pmreplstart = LINKLIST(rcop);
3159 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3162 NewOp(1101, svop, 1, SVOP);
3163 svop->op_type = type;
3164 svop->op_ppaddr = PL_ppaddr[type];
3166 svop->op_next = (OP*)svop;
3167 svop->op_flags = flags;
3168 if (PL_opargs[type] & OA_RETSCALAR)
3170 if (PL_opargs[type] & OA_TARGET)
3171 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3172 return CHECKOP(type, svop);
3176 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3179 NewOp(1101, padop, 1, PADOP);
3180 padop->op_type = type;
3181 padop->op_ppaddr = PL_ppaddr[type];
3182 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3183 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3184 PL_curpad[padop->op_padix] = sv;
3186 padop->op_next = (OP*)padop;
3187 padop->op_flags = flags;
3188 if (PL_opargs[type] & OA_RETSCALAR)
3190 if (PL_opargs[type] & OA_TARGET)
3191 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3192 return CHECKOP(type, padop);
3196 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3200 return newPADOP(type, flags, SvREFCNT_inc(gv));
3202 return newSVOP(type, flags, SvREFCNT_inc(gv));
3207 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3210 NewOp(1101, pvop, 1, PVOP);
3211 pvop->op_type = type;
3212 pvop->op_ppaddr = PL_ppaddr[type];
3214 pvop->op_next = (OP*)pvop;
3215 pvop->op_flags = flags;
3216 if (PL_opargs[type] & OA_RETSCALAR)
3218 if (PL_opargs[type] & OA_TARGET)
3219 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3220 return CHECKOP(type, pvop);
3224 Perl_package(pTHX_ OP *o)
3228 save_hptr(&PL_curstash);
3229 save_item(PL_curstname);
3234 name = SvPV(sv, len);
3235 PL_curstash = gv_stashpvn(name,len,TRUE);
3236 sv_setpvn(PL_curstname, name, len);
3240 deprecate("\"package\" with no arguments");
3241 sv_setpv(PL_curstname,"<none>");
3242 PL_curstash = Nullhv;
3244 PL_hints |= HINT_BLOCK_SCOPE;
3245 PL_copline = NOLINE;
3250 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3255 char *packname = Nullch;
3259 if (id->op_type != OP_CONST)
3260 Perl_croak(aTHX_ "Module name must be constant");
3264 if (version != Nullop) {
3265 SV *vesv = ((SVOP*)version)->op_sv;
3267 if (arg == Nullop && !SvNIOKp(vesv)) {
3274 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3275 Perl_croak(aTHX_ "Version number must be constant number");
3277 /* Make copy of id so we don't free it twice */
3278 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3280 /* Fake up a method call to VERSION */
3281 meth = newSVpvn("VERSION",7);
3282 sv_upgrade(meth, SVt_PVIV);
3283 (void)SvIOK_on(meth);
3284 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3285 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3286 append_elem(OP_LIST,
3287 prepend_elem(OP_LIST, pack, list(version)),
3288 newSVOP(OP_METHOD_NAMED, 0, meth)));
3292 /* Fake up an import/unimport */
3293 if (arg && arg->op_type == OP_STUB)
3294 imop = arg; /* no import on explicit () */
3295 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3296 imop = Nullop; /* use 5.0; */
3301 /* Make copy of id so we don't free it twice */
3302 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3304 /* Fake up a method call to import/unimport */
3305 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3306 (void)SvUPGRADE(meth, SVt_PVIV);
3307 (void)SvIOK_on(meth);
3308 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3309 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3310 append_elem(OP_LIST,
3311 prepend_elem(OP_LIST, pack, list(arg)),
3312 newSVOP(OP_METHOD_NAMED, 0, meth)));
3315 if (ckWARN(WARN_MISC) &&
3316 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3317 SvPOK(packsv = ((SVOP*)id)->op_sv))
3319 /* BEGIN will free the ops, so we need to make a copy */
3320 packlen = SvCUR(packsv);
3321 packname = savepvn(SvPVX(packsv), packlen);
3324 /* Fake up the BEGIN {}, which does its thing immediately. */
3326 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3329 append_elem(OP_LINESEQ,
3330 append_elem(OP_LINESEQ,
3331 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3332 newSTATEOP(0, Nullch, veop)),
3333 newSTATEOP(0, Nullch, imop) ));
3336 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3337 Perl_warner(aTHX_ WARN_MISC,
3338 "Package `%s' not found "
3339 "(did you use the incorrect case?)", packname);
3344 PL_hints |= HINT_BLOCK_SCOPE;
3345 PL_copline = NOLINE;
3350 =for apidoc load_module
3352 Loads the module whose name is pointed to by the string part of name.
3353 Note that the actual module name, not its filename, should be given.
3354 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3355 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3356 (or 0 for no flags). ver, if specified, provides version semantics
3357 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3358 arguments can be used to specify arguments to the module's import()
3359 method, similar to C<use Foo::Bar VERSION LIST>.
3364 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3367 va_start(args, ver);
3368 vload_module(flags, name, ver, &args);
3372 #ifdef PERL_IMPLICIT_CONTEXT
3374 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3378 va_start(args, ver);
3379 vload_module(flags, name, ver, &args);
3385 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3387 OP *modname, *veop, *imop;
3389 modname = newSVOP(OP_CONST, 0, name);
3390 modname->op_private |= OPpCONST_BARE;
3392 veop = newSVOP(OP_CONST, 0, ver);
3396 if (flags & PERL_LOADMOD_NOIMPORT) {
3397 imop = sawparens(newNULLLIST());
3399 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3400 imop = va_arg(*args, OP*);
3405 sv = va_arg(*args, SV*);
3407 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3408 sv = va_arg(*args, SV*);
3412 line_t ocopline = PL_copline;
3413 int oexpect = PL_expect;
3415 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3416 veop, modname, imop);
3417 PL_expect = oexpect;
3418 PL_copline = ocopline;
3423 Perl_dofile(pTHX_ OP *term)
3428 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3429 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3430 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3432 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3433 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3434 append_elem(OP_LIST, term,
3435 scalar(newUNOP(OP_RV2CV, 0,
3440 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3446 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3448 return newBINOP(OP_LSLICE, flags,
3449 list(force_list(subscript)),
3450 list(force_list(listval)) );
3454 S_list_assignment(pTHX_ register OP *o)
3459 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3460 o = cUNOPo->op_first;
3462 if (o->op_type == OP_COND_EXPR) {
3463 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3464 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3469 yyerror("Assignment to both a list and a scalar");
3473 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3474 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3475 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3478 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3481 if (o->op_type == OP_RV2SV)
3488 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3493 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3494 return newLOGOP(optype, 0,
3495 mod(scalar(left), optype),
3496 newUNOP(OP_SASSIGN, 0, scalar(right)));
3499 return newBINOP(optype, OPf_STACKED,
3500 mod(scalar(left), optype), scalar(right));
3504 if (list_assignment(left)) {
3508 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3509 left = mod(left, OP_AASSIGN);
3517 curop = list(force_list(left));
3518 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3519 o->op_private = 0 | (flags >> 8);
3520 for (curop = ((LISTOP*)curop)->op_first;
3521 curop; curop = curop->op_sibling)
3523 if (curop->op_type == OP_RV2HV &&
3524 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3525 o->op_private |= OPpASSIGN_HASH;
3529 if (!(left->op_private & OPpLVAL_INTRO)) {
3532 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3533 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3534 if (curop->op_type == OP_GV) {
3535 GV *gv = cGVOPx_gv(curop);
3536 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3538 SvCUR(gv) = PL_generation;
3540 else if (curop->op_type == OP_PADSV ||
3541 curop->op_type == OP_PADAV ||
3542 curop->op_type == OP_PADHV ||
3543 curop->op_type == OP_PADANY) {
3544 SV **svp = AvARRAY(PL_comppad_name);
3545 SV *sv = svp[curop->op_targ];
3546 if (SvCUR(sv) == PL_generation)
3548 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3550 else if (curop->op_type == OP_RV2CV)
3552 else if (curop->op_type == OP_RV2SV ||
3553 curop->op_type == OP_RV2AV ||
3554 curop->op_type == OP_RV2HV ||
3555 curop->op_type == OP_RV2GV) {
3556 if (lastop->op_type != OP_GV) /* funny deref? */
3559 else if (curop->op_type == OP_PUSHRE) {
3560 if (((PMOP*)curop)->op_pmreplroot) {
3562 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3564 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3566 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3568 SvCUR(gv) = PL_generation;
3577 o->op_private |= OPpASSIGN_COMMON;
3579 if (right && right->op_type == OP_SPLIT) {
3581 if ((tmpop = ((LISTOP*)right)->op_first) &&
3582 tmpop->op_type == OP_PUSHRE)
3584 PMOP *pm = (PMOP*)tmpop;
3585 if (left->op_type == OP_RV2AV &&
3586 !(left->op_private & OPpLVAL_INTRO) &&
3587 !(o->op_private & OPpASSIGN_COMMON) )
3589 tmpop = ((UNOP*)left)->op_first;
3590 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3592 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3593 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3595 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3596 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3598 pm->op_pmflags |= PMf_ONCE;
3599 tmpop = cUNOPo->op_first; /* to list (nulled) */
3600 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3601 tmpop->op_sibling = Nullop; /* don't free split */
3602 right->op_next = tmpop->op_next; /* fix starting loc */
3603 op_free(o); /* blow off assign */
3604 right->op_flags &= ~OPf_WANT;
3605 /* "I don't know and I don't care." */
3610 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3611 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3613 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3615 sv_setiv(sv, PL_modcount+1);
3623 right = newOP(OP_UNDEF, 0);
3624 if (right->op_type == OP_READLINE) {
3625 right->op_flags |= OPf_STACKED;
3626 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3629 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3630 o = newBINOP(OP_SASSIGN, flags,
3631 scalar(right), mod(scalar(left), OP_SASSIGN) );
3643 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3645 U32 seq = intro_my();
3648 NewOp(1101, cop, 1, COP);
3649 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3650 cop->op_type = OP_DBSTATE;
3651 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3654 cop->op_type = OP_NEXTSTATE;
3655 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3657 cop->op_flags = flags;
3658 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3660 cop->op_private |= NATIVE_HINTS;
3662 PL_compiling.op_private = cop->op_private;
3663 cop->op_next = (OP*)cop;
3666 cop->cop_label = label;
3667 PL_hints |= HINT_BLOCK_SCOPE;
3670 cop->cop_arybase = PL_curcop->cop_arybase;
3671 if (specialWARN(PL_curcop->cop_warnings))
3672 cop->cop_warnings = PL_curcop->cop_warnings ;
3674 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3675 if (specialCopIO(PL_curcop->cop_io))
3676 cop->cop_io = PL_curcop->cop_io;
3678 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3681 if (PL_copline == NOLINE)
3682 CopLINE_set(cop, CopLINE(PL_curcop));
3684 CopLINE_set(cop, PL_copline);
3685 PL_copline = NOLINE;
3688 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3690 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3692 CopSTASH_set(cop, PL_curstash);
3694 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3695 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3696 if (svp && *svp != &PL_sv_undef ) {
3697 (void)SvIOK_on(*svp);
3698 SvIVX(*svp) = PTR2IV(cop);
3702 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3705 /* "Introduce" my variables to visible status. */
3713 if (! PL_min_intro_pending)
3714 return PL_cop_seqmax;
3716 svp = AvARRAY(PL_comppad_name);
3717 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3718 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3719 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3720 SvNVX(sv) = (NV)PL_cop_seqmax;
3723 PL_min_intro_pending = 0;
3724 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3725 return PL_cop_seqmax++;
3729 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3731 return new_logop(type, flags, &first, &other);
3735 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3739 OP *first = *firstp;
3740 OP *other = *otherp;
3742 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3743 return newBINOP(type, flags, scalar(first), scalar(other));
3745 scalarboolean(first);
3746 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3747 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3748 if (type == OP_AND || type == OP_OR) {
3754 first = *firstp = cUNOPo->op_first;
3756 first->op_next = o->op_next;
3757 cUNOPo->op_first = Nullop;
3761 if (first->op_type == OP_CONST) {
3762 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3763 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3764 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3775 else if (first->op_type == OP_WANTARRAY) {
3781 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3782 OP *k1 = ((UNOP*)first)->op_first;
3783 OP *k2 = k1->op_sibling;
3785 switch (first->op_type)
3788 if (k2 && k2->op_type == OP_READLINE
3789 && (k2->op_flags & OPf_STACKED)
3790 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3792 warnop = k2->op_type;
3797 if (k1->op_type == OP_READDIR
3798 || k1->op_type == OP_GLOB
3799 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3800 || k1->op_type == OP_EACH)
3802 warnop = ((k1->op_type == OP_NULL)
3803 ? k1->op_targ : k1->op_type);
3808 line_t oldline = CopLINE(PL_curcop);
3809 CopLINE_set(PL_curcop, PL_copline);
3810 Perl_warner(aTHX_ WARN_MISC,
3811 "Value of %s%s can be \"0\"; test with defined()",
3813 ((warnop == OP_READLINE || warnop == OP_GLOB)
3814 ? " construct" : "() operator"));
3815 CopLINE_set(PL_curcop, oldline);
3822 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3823 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3825 NewOp(1101, logop, 1, LOGOP);
3827 logop->op_type = type;
3828 logop->op_ppaddr = PL_ppaddr[type];
3829 logop->op_first = first;
3830 logop->op_flags = flags | OPf_KIDS;
3831 logop->op_other = LINKLIST(other);
3832 logop->op_private = 1 | (flags >> 8);
3834 /* establish postfix order */
3835 logop->op_next = LINKLIST(first);
3836 first->op_next = (OP*)logop;
3837 first->op_sibling = other;
3839 o = newUNOP(OP_NULL, 0, (OP*)logop);
3846 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3853 return newLOGOP(OP_AND, 0, first, trueop);
3855 return newLOGOP(OP_OR, 0, first, falseop);
3857 scalarboolean(first);
3858 if (first->op_type == OP_CONST) {
3859 if (SvTRUE(((SVOP*)first)->op_sv)) {
3870 else if (first->op_type == OP_WANTARRAY) {
3874 NewOp(1101, logop, 1, LOGOP);
3875 logop->op_type = OP_COND_EXPR;
3876 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3877 logop->op_first = first;
3878 logop->op_flags = flags | OPf_KIDS;
3879 logop->op_private = 1 | (flags >> 8);
3880 logop->op_other = LINKLIST(trueop);
3881 logop->op_next = LINKLIST(falseop);
3884 /* establish postfix order */
3885 start = LINKLIST(first);
3886 first->op_next = (OP*)logop;
3888 first->op_sibling = trueop;
3889 trueop->op_sibling = falseop;
3890 o = newUNOP(OP_NULL, 0, (OP*)logop);
3892 trueop->op_next = falseop->op_next = o;
3899 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3907 NewOp(1101, range, 1, LOGOP);
3909 range->op_type = OP_RANGE;
3910 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3911 range->op_first = left;
3912 range->op_flags = OPf_KIDS;
3913 leftstart = LINKLIST(left);
3914 range->op_other = LINKLIST(right);
3915 range->op_private = 1 | (flags >> 8);
3917 left->op_sibling = right;
3919 range->op_next = (OP*)range;
3920 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3921 flop = newUNOP(OP_FLOP, 0, flip);
3922 o = newUNOP(OP_NULL, 0, flop);
3924 range->op_next = leftstart;
3926 left->op_next = flip;
3927 right->op_next = flop;
3929 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3930 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3931 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3932 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3934 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3935 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3938 if (!flip->op_private || !flop->op_private)
3939 linklist(o); /* blow off optimizer unless constant */
3945 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3949 int once = block && block->op_flags & OPf_SPECIAL &&
3950 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3953 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3954 return block; /* do {} while 0 does once */
3955 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3956 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3957 expr = newUNOP(OP_DEFINED, 0,
3958 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3959 } else if (expr->op_flags & OPf_KIDS) {
3960 OP *k1 = ((UNOP*)expr)->op_first;
3961 OP *k2 = (k1) ? k1->op_sibling : NULL;
3962 switch (expr->op_type) {
3964 if (k2 && k2->op_type == OP_READLINE
3965 && (k2->op_flags & OPf_STACKED)
3966 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3967 expr = newUNOP(OP_DEFINED, 0, expr);
3971 if (k1->op_type == OP_READDIR
3972 || k1->op_type == OP_GLOB
3973 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3974 || k1->op_type == OP_EACH)
3975 expr = newUNOP(OP_DEFINED, 0, expr);
3981 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3982 o = new_logop(OP_AND, 0, &expr, &listop);
3985 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3987 if (once && o != listop)
3988 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3991 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3993 o->op_flags |= flags;
3995 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4000 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4008 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4009 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4010 expr = newUNOP(OP_DEFINED, 0,
4011 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4012 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4013 OP *k1 = ((UNOP*)expr)->op_first;
4014 OP *k2 = (k1) ? k1->op_sibling : NULL;
4015 switch (expr->op_type) {
4017 if (k2 && k2->op_type == OP_READLINE
4018 && (k2->op_flags & OPf_STACKED)
4019 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4020 expr = newUNOP(OP_DEFINED, 0, expr);
4024 if (k1->op_type == OP_READDIR
4025 || k1->op_type == OP_GLOB
4026 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4027 || k1->op_type == OP_EACH)
4028 expr = newUNOP(OP_DEFINED, 0, expr);
4034 block = newOP(OP_NULL, 0);
4036 block = scope(block);
4040 next = LINKLIST(cont);
4043 OP *unstack = newOP(OP_UNSTACK, 0);
4046 cont = append_elem(OP_LINESEQ, cont, unstack);
4047 if ((line_t)whileline != NOLINE) {
4048 PL_copline = whileline;
4049 cont = append_elem(OP_LINESEQ, cont,
4050 newSTATEOP(0, Nullch, Nullop));
4054 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4055 redo = LINKLIST(listop);
4058 PL_copline = whileline;
4060 o = new_logop(OP_AND, 0, &expr, &listop);
4061 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4062 op_free(expr); /* oops, it's a while (0) */
4064 return Nullop; /* listop already freed by new_logop */
4067 ((LISTOP*)listop)->op_last->op_next =
4068 (o == listop ? redo : LINKLIST(o));
4074 NewOp(1101,loop,1,LOOP);
4075 loop->op_type = OP_ENTERLOOP;
4076 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4077 loop->op_private = 0;
4078 loop->op_next = (OP*)loop;
4081 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4083 loop->op_redoop = redo;
4084 loop->op_lastop = o;
4085 o->op_private |= loopflags;
4088 loop->op_nextop = next;
4090 loop->op_nextop = o;
4092 o->op_flags |= flags;
4093 o->op_private |= (flags >> 8);
4098 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4106 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4107 sv->op_type = OP_RV2GV;
4108 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4110 else if (sv->op_type == OP_PADSV) { /* private variable */
4111 padoff = sv->op_targ;
4116 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4117 padoff = sv->op_targ;
4119 iterflags |= OPf_SPECIAL;
4124 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4127 #ifdef USE_5005THREADS
4128 padoff = find_threadsv("_");
4129 iterflags |= OPf_SPECIAL;
4131 sv = newGVOP(OP_GV, 0, PL_defgv);
4134 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4135 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4136 iterflags |= OPf_STACKED;
4138 else if (expr->op_type == OP_NULL &&
4139 (expr->op_flags & OPf_KIDS) &&
4140 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4142 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4143 * set the STACKED flag to indicate that these values are to be
4144 * treated as min/max values by 'pp_iterinit'.
4146 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4147 LOGOP* range = (LOGOP*) flip->op_first;
4148 OP* left = range->op_first;
4149 OP* right = left->op_sibling;
4152 range->op_flags &= ~OPf_KIDS;
4153 range->op_first = Nullop;
4155 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4156 listop->op_first->op_next = range->op_next;
4157 left->op_next = range->op_other;
4158 right->op_next = (OP*)listop;
4159 listop->op_next = listop->op_first;
4162 expr = (OP*)(listop);
4164 iterflags |= OPf_STACKED;
4167 expr = mod(force_list(expr), OP_GREPSTART);
4171 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4172 append_elem(OP_LIST, expr, scalar(sv))));
4173 assert(!loop->op_next);
4174 #ifdef PL_OP_SLAB_ALLOC
4177 NewOp(1234,tmp,1,LOOP);
4178 Copy(loop,tmp,1,LOOP);
4182 Renew(loop, 1, LOOP);
4184 loop->op_targ = padoff;
4185 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4186 PL_copline = forline;
4187 return newSTATEOP(0, label, wop);
4191 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4196 if (type != OP_GOTO || label->op_type == OP_CONST) {
4197 /* "last()" means "last" */
4198 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4199 o = newOP(type, OPf_SPECIAL);
4201 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4202 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4208 if (label->op_type == OP_ENTERSUB)
4209 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4210 o = newUNOP(type, OPf_STACKED, label);
4212 PL_hints |= HINT_BLOCK_SCOPE;
4217 Perl_cv_undef(pTHX_ CV *cv)
4219 #ifdef USE_5005THREADS
4221 MUTEX_DESTROY(CvMUTEXP(cv));
4222 Safefree(CvMUTEXP(cv));
4225 #endif /* USE_5005THREADS */
4228 if (CvFILE(cv) && !CvXSUB(cv)) {
4229 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4230 Safefree(CvFILE(cv));
4235 if (!CvXSUB(cv) && CvROOT(cv)) {
4236 #ifdef USE_5005THREADS
4237 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4238 Perl_croak(aTHX_ "Can't undef active subroutine");
4241 Perl_croak(aTHX_ "Can't undef active subroutine");
4242 #endif /* USE_5005THREADS */
4245 SAVEVPTR(PL_curpad);
4248 op_free(CvROOT(cv));
4249 CvROOT(cv) = Nullop;
4252 SvPOK_off((SV*)cv); /* forget prototype */
4254 /* Since closure prototypes have the same lifetime as the containing
4255 * CV, they don't hold a refcount on the outside CV. This avoids
4256 * the refcount loop between the outer CV (which keeps a refcount to
4257 * the closure prototype in the pad entry for pp_anoncode()) and the
4258 * closure prototype, and the ensuing memory leak. --GSAR */
4259 if (!CvANON(cv) || CvCLONED(cv))
4260 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 outer CV.
4908 * This is okay as the lifetime of the prototype is tied to the
4909 * lifetime of the outer CV. Avoids memory leak due to reference
4912 SvREFCNT_dec(CvOUTSIDE(cv));
4914 if (name || aname) {
4916 char *tname = (name ? name : aname);
4918 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4919 SV *sv = NEWSV(0,0);
4920 SV *tmpstr = sv_newmortal();
4921 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4925 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4927 (long)PL_subline, (long)CopLINE(PL_curcop));
4928 gv_efullname3(tmpstr, gv, Nullch);
4929 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4930 hv = GvHVn(db_postponed);
4931 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4932 && (pcv = GvCV(db_postponed)))
4938 call_sv((SV*)pcv, G_DISCARD);
4942 if ((s = strrchr(tname,':')))
4947 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4950 if (strEQ(s, "BEGIN")) {
4951 I32 oldscope = PL_scopestack_ix;
4953 SAVECOPFILE(&PL_compiling);
4954 SAVECOPLINE(&PL_compiling);
4957 PL_beginav = newAV();
4958 DEBUG_x( dump_sub(gv) );
4959 av_push(PL_beginav, (SV*)cv);
4960 GvCV(gv) = 0; /* cv has been hijacked */
4961 call_list(oldscope, PL_beginav);
4963 PL_curcop = &PL_compiling;
4964 PL_compiling.op_private = PL_hints;
4967 else if (strEQ(s, "END") && !PL_error_count) {
4970 DEBUG_x( dump_sub(gv) );
4971 av_unshift(PL_endav, 1);
4972 av_store(PL_endav, 0, (SV*)cv);
4973 GvCV(gv) = 0; /* cv has been hijacked */
4975 else if (strEQ(s, "CHECK") && !PL_error_count) {
4977 PL_checkav = newAV();
4978 DEBUG_x( dump_sub(gv) );
4979 if (PL_main_start && ckWARN(WARN_VOID))
4980 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4981 av_unshift(PL_checkav, 1);
4982 av_store(PL_checkav, 0, (SV*)cv);
4983 GvCV(gv) = 0; /* cv has been hijacked */
4985 else if (strEQ(s, "INIT") && !PL_error_count) {
4987 PL_initav = newAV();
4988 DEBUG_x( dump_sub(gv) );
4989 if (PL_main_start && ckWARN(WARN_VOID))
4990 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4991 av_push(PL_initav, (SV*)cv);
4992 GvCV(gv) = 0; /* cv has been hijacked */
4997 PL_copline = NOLINE;
5002 /* XXX unsafe for threads if eval_owner isn't held */
5004 =for apidoc newCONSTSUB
5006 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5007 eligible for inlining at compile-time.
5013 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5019 SAVECOPLINE(PL_curcop);
5020 CopLINE_set(PL_curcop, PL_copline);
5023 PL_hints &= ~HINT_BLOCK_SCOPE;
5026 SAVESPTR(PL_curstash);
5027 SAVECOPSTASH(PL_curcop);
5028 PL_curstash = stash;
5030 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5032 CopSTASH(PL_curcop) = stash;
5036 cv = newXS(name, const_sv_xsub, __FILE__);
5037 CvXSUBANY(cv).any_ptr = sv;
5039 sv_setpv((SV*)cv, ""); /* prototype is "" */
5047 =for apidoc U||newXS
5049 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5055 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5057 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5060 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5062 /* just a cached method */
5066 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5067 /* already defined (or promised) */
5068 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5069 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5070 line_t oldline = CopLINE(PL_curcop);
5071 if (PL_copline != NOLINE)
5072 CopLINE_set(PL_curcop, PL_copline);
5073 Perl_warner(aTHX_ WARN_REDEFINE,
5074 CvCONST(cv) ? "Constant subroutine %s redefined"
5075 : "Subroutine %s redefined"
5077 CopLINE_set(PL_curcop, oldline);
5084 if (cv) /* must reuse cv if autoloaded */
5087 cv = (CV*)NEWSV(1105,0);
5088 sv_upgrade((SV *)cv, SVt_PVCV);
5092 PL_sub_generation++;
5096 #ifdef USE_5005THREADS
5097 New(666, CvMUTEXP(cv), 1, perl_mutex);
5098 MUTEX_INIT(CvMUTEXP(cv));
5100 #endif /* USE_5005THREADS */
5101 (void)gv_fetchfile(filename);
5102 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5103 an external constant string */
5104 CvXSUB(cv) = subaddr;
5107 char *s = strrchr(name,':');
5113 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5116 if (strEQ(s, "BEGIN")) {
5118 PL_beginav = newAV();
5119 av_push(PL_beginav, (SV*)cv);
5120 GvCV(gv) = 0; /* cv has been hijacked */
5122 else if (strEQ(s, "END")) {
5125 av_unshift(PL_endav, 1);
5126 av_store(PL_endav, 0, (SV*)cv);
5127 GvCV(gv) = 0; /* cv has been hijacked */
5129 else if (strEQ(s, "CHECK")) {
5131 PL_checkav = newAV();
5132 if (PL_main_start && ckWARN(WARN_VOID))
5133 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5134 av_unshift(PL_checkav, 1);
5135 av_store(PL_checkav, 0, (SV*)cv);
5136 GvCV(gv) = 0; /* cv has been hijacked */
5138 else if (strEQ(s, "INIT")) {
5140 PL_initav = newAV();
5141 if (PL_main_start && ckWARN(WARN_VOID))
5142 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5143 av_push(PL_initav, (SV*)cv);
5144 GvCV(gv) = 0; /* cv has been hijacked */
5155 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5164 name = SvPVx(cSVOPo->op_sv, n_a);
5167 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5168 #ifdef GV_UNIQUE_CHECK
5170 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5174 if ((cv = GvFORM(gv))) {
5175 if (ckWARN(WARN_REDEFINE)) {
5176 line_t oldline = CopLINE(PL_curcop);
5177 if (PL_copline != NOLINE)
5178 CopLINE_set(PL_curcop, PL_copline);
5179 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5180 CopLINE_set(PL_curcop, oldline);
5187 CvFILE_set_from_cop(cv, PL_curcop);
5189 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5190 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5191 SvPADTMP_on(PL_curpad[ix]);
5194 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5195 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5196 OpREFCNT_set(CvROOT(cv), 1);
5197 CvSTART(cv) = LINKLIST(CvROOT(cv));
5198 CvROOT(cv)->op_next = 0;
5199 CALL_PEEP(CvSTART(cv));
5201 PL_copline = NOLINE;
5206 Perl_newANONLIST(pTHX_ OP *o)
5208 return newUNOP(OP_REFGEN, 0,
5209 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5213 Perl_newANONHASH(pTHX_ OP *o)
5215 return newUNOP(OP_REFGEN, 0,
5216 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5220 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5222 return newANONATTRSUB(floor, proto, Nullop, block);
5226 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5228 return newUNOP(OP_REFGEN, 0,
5229 newSVOP(OP_ANONCODE, 0,
5230 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5234 Perl_oopsAV(pTHX_ OP *o)
5236 switch (o->op_type) {
5238 o->op_type = OP_PADAV;
5239 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5240 return ref(o, OP_RV2AV);
5243 o->op_type = OP_RV2AV;
5244 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5249 if (ckWARN_d(WARN_INTERNAL))
5250 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5257 Perl_oopsHV(pTHX_ OP *o)
5259 switch (o->op_type) {
5262 o->op_type = OP_PADHV;
5263 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5264 return ref(o, OP_RV2HV);
5268 o->op_type = OP_RV2HV;
5269 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5274 if (ckWARN_d(WARN_INTERNAL))
5275 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5282 Perl_newAVREF(pTHX_ OP *o)
5284 if (o->op_type == OP_PADANY) {
5285 o->op_type = OP_PADAV;
5286 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5289 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5290 && ckWARN(WARN_DEPRECATED)) {
5291 Perl_warner(aTHX_ WARN_DEPRECATED,
5292 "Using an array as a reference is deprecated");
5294 return newUNOP(OP_RV2AV, 0, scalar(o));
5298 Perl_newGVREF(pTHX_ I32 type, OP *o)
5300 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5301 return newUNOP(OP_NULL, 0, o);
5302 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5306 Perl_newHVREF(pTHX_ OP *o)
5308 if (o->op_type == OP_PADANY) {
5309 o->op_type = OP_PADHV;
5310 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5313 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5314 && ckWARN(WARN_DEPRECATED)) {
5315 Perl_warner(aTHX_ WARN_DEPRECATED,
5316 "Using a hash as a reference is deprecated");
5318 return newUNOP(OP_RV2HV, 0, scalar(o));
5322 Perl_oopsCV(pTHX_ OP *o)
5324 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5330 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5332 return newUNOP(OP_RV2CV, flags, scalar(o));
5336 Perl_newSVREF(pTHX_ OP *o)
5338 if (o->op_type == OP_PADANY) {
5339 o->op_type = OP_PADSV;
5340 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5343 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5344 o->op_flags |= OPpDONE_SVREF;
5347 return newUNOP(OP_RV2SV, 0, scalar(o));
5350 /* Check routines. */
5353 Perl_ck_anoncode(pTHX_ OP *o)
5358 name = NEWSV(1106,0);
5359 sv_upgrade(name, SVt_PVNV);
5360 sv_setpvn(name, "&", 1);
5363 ix = pad_alloc(o->op_type, SVs_PADMY);
5364 av_store(PL_comppad_name, ix, name);
5365 av_store(PL_comppad, ix, cSVOPo->op_sv);
5366 SvPADMY_on(cSVOPo->op_sv);
5367 cSVOPo->op_sv = Nullsv;
5368 cSVOPo->op_targ = ix;
5373 Perl_ck_bitop(pTHX_ OP *o)
5375 o->op_private = PL_hints;
5380 Perl_ck_concat(pTHX_ OP *o)
5382 if (cUNOPo->op_first->op_type == OP_CONCAT)
5383 o->op_flags |= OPf_STACKED;
5388 Perl_ck_spair(pTHX_ OP *o)
5390 if (o->op_flags & OPf_KIDS) {
5393 OPCODE type = o->op_type;
5394 o = modkids(ck_fun(o), type);
5395 kid = cUNOPo->op_first;
5396 newop = kUNOP->op_first->op_sibling;
5398 (newop->op_sibling ||
5399 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5400 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5401 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5405 op_free(kUNOP->op_first);
5406 kUNOP->op_first = newop;
5408 o->op_ppaddr = PL_ppaddr[++o->op_type];
5413 Perl_ck_delete(pTHX_ OP *o)
5417 if (o->op_flags & OPf_KIDS) {
5418 OP *kid = cUNOPo->op_first;
5419 switch (kid->op_type) {
5421 o->op_flags |= OPf_SPECIAL;
5424 o->op_private |= OPpSLICE;
5427 o->op_flags |= OPf_SPECIAL;
5432 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5441 Perl_ck_die(pTHX_ OP *o)
5444 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5450 Perl_ck_eof(pTHX_ OP *o)
5452 I32 type = o->op_type;
5454 if (o->op_flags & OPf_KIDS) {
5455 if (cLISTOPo->op_first->op_type == OP_STUB) {
5457 o = newUNOP(type, OPf_SPECIAL,
5458 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5466 Perl_ck_eval(pTHX_ OP *o)
5468 PL_hints |= HINT_BLOCK_SCOPE;
5469 if (o->op_flags & OPf_KIDS) {
5470 SVOP *kid = (SVOP*)cUNOPo->op_first;
5473 o->op_flags &= ~OPf_KIDS;
5476 else if (kid->op_type == OP_LINESEQ) {
5479 kid->op_next = o->op_next;
5480 cUNOPo->op_first = 0;
5483 NewOp(1101, enter, 1, LOGOP);
5484 enter->op_type = OP_ENTERTRY;
5485 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5486 enter->op_private = 0;
5488 /* establish postfix order */
5489 enter->op_next = (OP*)enter;
5491 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5492 o->op_type = OP_LEAVETRY;
5493 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5494 enter->op_other = o;
5502 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5504 o->op_targ = (PADOFFSET)PL_hints;
5509 Perl_ck_exit(pTHX_ OP *o)
5512 HV *table = GvHV(PL_hintgv);
5514 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5515 if (svp && *svp && SvTRUE(*svp))
5516 o->op_private |= OPpEXIT_VMSISH;
5518 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5524 Perl_ck_exec(pTHX_ OP *o)
5527 if (o->op_flags & OPf_STACKED) {
5529 kid = cUNOPo->op_first->op_sibling;
5530 if (kid->op_type == OP_RV2GV)
5539 Perl_ck_exists(pTHX_ OP *o)
5542 if (o->op_flags & OPf_KIDS) {
5543 OP *kid = cUNOPo->op_first;
5544 if (kid->op_type == OP_ENTERSUB) {
5545 (void) ref(kid, o->op_type);
5546 if (kid->op_type != OP_RV2CV && !PL_error_count)
5547 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5549 o->op_private |= OPpEXISTS_SUB;
5551 else if (kid->op_type == OP_AELEM)
5552 o->op_flags |= OPf_SPECIAL;
5553 else if (kid->op_type != OP_HELEM)
5554 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5563 Perl_ck_gvconst(pTHX_ register OP *o)
5565 o = fold_constants(o);
5566 if (o->op_type == OP_CONST)
5573 Perl_ck_rvconst(pTHX_ register OP *o)
5575 SVOP *kid = (SVOP*)cUNOPo->op_first;
5577 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5578 if (kid->op_type == OP_CONST) {
5582 SV *kidsv = kid->op_sv;
5585 /* Is it a constant from cv_const_sv()? */
5586 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5587 SV *rsv = SvRV(kidsv);
5588 int svtype = SvTYPE(rsv);
5589 char *badtype = Nullch;
5591 switch (o->op_type) {
5593 if (svtype > SVt_PVMG)
5594 badtype = "a SCALAR";
5597 if (svtype != SVt_PVAV)
5598 badtype = "an ARRAY";
5601 if (svtype != SVt_PVHV) {
5602 if (svtype == SVt_PVAV) { /* pseudohash? */
5603 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5604 if (ksv && SvROK(*ksv)
5605 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5614 if (svtype != SVt_PVCV)
5619 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5622 name = SvPV(kidsv, n_a);
5623 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5624 char *badthing = Nullch;
5625 switch (o->op_type) {
5627 badthing = "a SCALAR";
5630 badthing = "an ARRAY";
5633 badthing = "a HASH";
5638 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5642 * This is a little tricky. We only want to add the symbol if we
5643 * didn't add it in the lexer. Otherwise we get duplicate strict
5644 * warnings. But if we didn't add it in the lexer, we must at
5645 * least pretend like we wanted to add it even if it existed before,
5646 * or we get possible typo warnings. OPpCONST_ENTERED says
5647 * whether the lexer already added THIS instance of this symbol.
5649 iscv = (o->op_type == OP_RV2CV) * 2;
5651 gv = gv_fetchpv(name,
5652 iscv | !(kid->op_private & OPpCONST_ENTERED),
5655 : o->op_type == OP_RV2SV
5657 : o->op_type == OP_RV2AV
5659 : o->op_type == OP_RV2HV
5662 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5664 kid->op_type = OP_GV;
5665 SvREFCNT_dec(kid->op_sv);
5667 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5668 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5669 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5671 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5673 kid->op_sv = SvREFCNT_inc(gv);
5675 kid->op_private = 0;
5676 kid->op_ppaddr = PL_ppaddr[OP_GV];
5683 Perl_ck_ftst(pTHX_ OP *o)
5685 I32 type = o->op_type;
5687 if (o->op_flags & OPf_REF) {
5690 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5691 SVOP *kid = (SVOP*)cUNOPo->op_first;
5693 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5695 OP *newop = newGVOP(type, OPf_REF,
5696 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5703 if (type == OP_FTTTY)
5704 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5707 o = newUNOP(type, 0, newDEFSVOP());
5713 Perl_ck_fun(pTHX_ OP *o)
5719 int type = o->op_type;
5720 register I32 oa = PL_opargs[type] >> OASHIFT;
5722 if (o->op_flags & OPf_STACKED) {
5723 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5726 return no_fh_allowed(o);
5729 if (o->op_flags & OPf_KIDS) {
5731 tokid = &cLISTOPo->op_first;
5732 kid = cLISTOPo->op_first;
5733 if (kid->op_type == OP_PUSHMARK ||
5734 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5736 tokid = &kid->op_sibling;
5737 kid = kid->op_sibling;
5739 if (!kid && PL_opargs[type] & OA_DEFGV)
5740 *tokid = kid = newDEFSVOP();
5744 sibl = kid->op_sibling;
5747 /* list seen where single (scalar) arg expected? */
5748 if (numargs == 1 && !(oa >> 4)
5749 && kid->op_type == OP_LIST && type != OP_SCALAR)
5751 return too_many_arguments(o,PL_op_desc[type]);
5764 if ((type == OP_PUSH || type == OP_UNSHIFT)
5765 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5766 Perl_warner(aTHX_ WARN_SYNTAX,
5767 "Useless use of %s with no values",
5770 if (kid->op_type == OP_CONST &&
5771 (kid->op_private & OPpCONST_BARE))
5773 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5774 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5775 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5776 if (ckWARN(WARN_DEPRECATED))
5777 Perl_warner(aTHX_ WARN_DEPRECATED,
5778 "Array @%s missing the @ in argument %"IVdf" of %s()",
5779 name, (IV)numargs, PL_op_desc[type]);
5782 kid->op_sibling = sibl;
5785 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5786 bad_type(numargs, "array", PL_op_desc[type], kid);
5790 if (kid->op_type == OP_CONST &&
5791 (kid->op_private & OPpCONST_BARE))
5793 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5794 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5795 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5796 if (ckWARN(WARN_DEPRECATED))
5797 Perl_warner(aTHX_ WARN_DEPRECATED,
5798 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5799 name, (IV)numargs, PL_op_desc[type]);
5802 kid->op_sibling = sibl;
5805 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5806 bad_type(numargs, "hash", PL_op_desc[type], kid);
5811 OP *newop = newUNOP(OP_NULL, 0, kid);
5812 kid->op_sibling = 0;
5814 newop->op_next = newop;
5816 kid->op_sibling = sibl;
5821 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5822 if (kid->op_type == OP_CONST &&
5823 (kid->op_private & OPpCONST_BARE))
5825 OP *newop = newGVOP(OP_GV, 0,
5826 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5831 else if (kid->op_type == OP_READLINE) {
5832 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5833 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5836 I32 flags = OPf_SPECIAL;
5840 /* is this op a FH constructor? */
5841 if (is_handle_constructor(o,numargs)) {
5842 char *name = Nullch;
5846 /* Set a flag to tell rv2gv to vivify
5847 * need to "prove" flag does not mean something
5848 * else already - NI-S 1999/05/07
5851 if (kid->op_type == OP_PADSV) {
5852 SV **namep = av_fetch(PL_comppad_name,
5854 if (namep && *namep)
5855 name = SvPV(*namep, len);
5857 else if (kid->op_type == OP_RV2SV
5858 && kUNOP->op_first->op_type == OP_GV)
5860 GV *gv = cGVOPx_gv(kUNOP->op_first);
5862 len = GvNAMELEN(gv);
5864 else if (kid->op_type == OP_AELEM
5865 || kid->op_type == OP_HELEM)
5867 name = "__ANONIO__";
5873 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5874 namesv = PL_curpad[targ];
5875 (void)SvUPGRADE(namesv, SVt_PV);
5877 sv_setpvn(namesv, "$", 1);
5878 sv_catpvn(namesv, name, len);
5881 kid->op_sibling = 0;
5882 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5883 kid->op_targ = targ;
5884 kid->op_private |= priv;
5886 kid->op_sibling = sibl;
5892 mod(scalar(kid), type);
5896 tokid = &kid->op_sibling;
5897 kid = kid->op_sibling;
5899 o->op_private |= numargs;
5901 return too_many_arguments(o,OP_DESC(o));
5904 else if (PL_opargs[type] & OA_DEFGV) {
5906 return newUNOP(type, 0, newDEFSVOP());
5910 while (oa & OA_OPTIONAL)
5912 if (oa && oa != OA_LIST)
5913 return too_few_arguments(o,OP_DESC(o));
5919 Perl_ck_glob(pTHX_ OP *o)
5924 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5925 append_elem(OP_GLOB, o, newDEFSVOP());
5927 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5928 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5930 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5933 #if !defined(PERL_EXTERNAL_GLOB)
5934 /* XXX this can be tightened up and made more failsafe. */
5938 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5940 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5941 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5942 GvCV(gv) = GvCV(glob_gv);
5943 SvREFCNT_inc((SV*)GvCV(gv));
5944 GvIMPORTED_CV_on(gv);
5947 #endif /* PERL_EXTERNAL_GLOB */
5949 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5950 append_elem(OP_GLOB, o,
5951 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5952 o->op_type = OP_LIST;
5953 o->op_ppaddr = PL_ppaddr[OP_LIST];
5954 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5955 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5956 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5957 append_elem(OP_LIST, o,
5958 scalar(newUNOP(OP_RV2CV, 0,
5959 newGVOP(OP_GV, 0, gv)))));
5960 o = newUNOP(OP_NULL, 0, ck_subr(o));
5961 o->op_targ = OP_GLOB; /* hint at what it used to be */
5964 gv = newGVgen("main");
5966 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5972 Perl_ck_grep(pTHX_ OP *o)
5976 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5978 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5979 NewOp(1101, gwop, 1, LOGOP);
5981 if (o->op_flags & OPf_STACKED) {
5984 kid = cLISTOPo->op_first->op_sibling;
5985 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5988 kid->op_next = (OP*)gwop;
5989 o->op_flags &= ~OPf_STACKED;
5991 kid = cLISTOPo->op_first->op_sibling;
5992 if (type == OP_MAPWHILE)
5999 kid = cLISTOPo->op_first->op_sibling;
6000 if (kid->op_type != OP_NULL)
6001 Perl_croak(aTHX_ "panic: ck_grep");
6002 kid = kUNOP->op_first;
6004 gwop->op_type = type;
6005 gwop->op_ppaddr = PL_ppaddr[type];
6006 gwop->op_first = listkids(o);
6007 gwop->op_flags |= OPf_KIDS;
6008 gwop->op_private = 1;
6009 gwop->op_other = LINKLIST(kid);
6010 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6011 kid->op_next = (OP*)gwop;
6013 kid = cLISTOPo->op_first->op_sibling;
6014 if (!kid || !kid->op_sibling)
6015 return too_few_arguments(o,OP_DESC(o));
6016 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6017 mod(kid, OP_GREPSTART);
6023 Perl_ck_index(pTHX_ OP *o)
6025 if (o->op_flags & OPf_KIDS) {
6026 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6028 kid = kid->op_sibling; /* get past "big" */
6029 if (kid && kid->op_type == OP_CONST)
6030 fbm_compile(((SVOP*)kid)->op_sv, 0);
6036 Perl_ck_lengthconst(pTHX_ OP *o)
6038 /* XXX length optimization goes here */
6043 Perl_ck_lfun(pTHX_ OP *o)
6045 OPCODE type = o->op_type;
6046 return modkids(ck_fun(o), type);
6050 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6052 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6053 switch (cUNOPo->op_first->op_type) {
6055 /* This is needed for
6056 if (defined %stash::)
6057 to work. Do not break Tk.
6059 break; /* Globals via GV can be undef */
6061 case OP_AASSIGN: /* Is this a good idea? */
6062 Perl_warner(aTHX_ WARN_DEPRECATED,
6063 "defined(@array) is deprecated");
6064 Perl_warner(aTHX_ WARN_DEPRECATED,
6065 "\t(Maybe you should just omit the defined()?)\n");
6068 /* This is needed for
6069 if (defined %stash::)
6070 to work. Do not break Tk.
6072 break; /* Globals via GV can be undef */
6074 Perl_warner(aTHX_ WARN_DEPRECATED,
6075 "defined(%%hash) is deprecated");
6076 Perl_warner(aTHX_ WARN_DEPRECATED,
6077 "\t(Maybe you should just omit the defined()?)\n");
6088 Perl_ck_rfun(pTHX_ OP *o)
6090 OPCODE type = o->op_type;
6091 return refkids(ck_fun(o), type);
6095 Perl_ck_listiob(pTHX_ OP *o)
6099 kid = cLISTOPo->op_first;
6102 kid = cLISTOPo->op_first;
6104 if (kid->op_type == OP_PUSHMARK)
6105 kid = kid->op_sibling;
6106 if (kid && o->op_flags & OPf_STACKED)
6107 kid = kid->op_sibling;
6108 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6109 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6110 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6111 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6112 cLISTOPo->op_first->op_sibling = kid;
6113 cLISTOPo->op_last = kid;
6114 kid = kid->op_sibling;
6119 append_elem(o->op_type, o, newDEFSVOP());
6125 Perl_ck_sassign(pTHX_ OP *o)
6127 OP *kid = cLISTOPo->op_first;
6128 /* has a disposable target? */
6129 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6130 && !(kid->op_flags & OPf_STACKED)
6131 /* Cannot steal the second time! */
6132 && !(kid->op_private & OPpTARGET_MY))
6134 OP *kkid = kid->op_sibling;
6136 /* Can just relocate the target. */
6137 if (kkid && kkid->op_type == OP_PADSV
6138 && !(kkid->op_private & OPpLVAL_INTRO))
6140 kid->op_targ = kkid->op_targ;
6142 /* Now we do not need PADSV and SASSIGN. */
6143 kid->op_sibling = o->op_sibling; /* NULL */
6144 cLISTOPo->op_first = NULL;
6147 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6155 Perl_ck_match(pTHX_ OP *o)
6157 o->op_private |= OPpRUNTIME;
6162 Perl_ck_method(pTHX_ OP *o)
6164 OP *kid = cUNOPo->op_first;
6165 if (kid->op_type == OP_CONST) {
6166 SV* sv = kSVOP->op_sv;
6167 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6169 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6170 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6173 kSVOP->op_sv = Nullsv;
6175 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6184 Perl_ck_null(pTHX_ OP *o)
6190 Perl_ck_open(pTHX_ OP *o)
6192 HV *table = GvHV(PL_hintgv);
6196 svp = hv_fetch(table, "open_IN", 7, FALSE);
6198 mode = mode_from_discipline(*svp);
6199 if (mode & O_BINARY)
6200 o->op_private |= OPpOPEN_IN_RAW;
6201 else if (mode & O_TEXT)
6202 o->op_private |= OPpOPEN_IN_CRLF;
6205 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6207 mode = mode_from_discipline(*svp);
6208 if (mode & O_BINARY)
6209 o->op_private |= OPpOPEN_OUT_RAW;
6210 else if (mode & O_TEXT)
6211 o->op_private |= OPpOPEN_OUT_CRLF;
6214 if (o->op_type == OP_BACKTICK)
6220 Perl_ck_repeat(pTHX_ OP *o)
6222 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6223 o->op_private |= OPpREPEAT_DOLIST;
6224 cBINOPo->op_first = force_list(cBINOPo->op_first);
6232 Perl_ck_require(pTHX_ OP *o)
6236 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6237 SVOP *kid = (SVOP*)cUNOPo->op_first;
6239 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6241 for (s = SvPVX(kid->op_sv); *s; s++) {
6242 if (*s == ':' && s[1] == ':') {
6244 Move(s+2, s+1, strlen(s+2)+1, char);
6245 --SvCUR(kid->op_sv);
6248 if (SvREADONLY(kid->op_sv)) {
6249 SvREADONLY_off(kid->op_sv);
6250 sv_catpvn(kid->op_sv, ".pm", 3);
6251 SvREADONLY_on(kid->op_sv);
6254 sv_catpvn(kid->op_sv, ".pm", 3);
6258 /* handle override, if any */
6259 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6260 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6261 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6263 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6264 OP *kid = cUNOPo->op_first;
6265 cUNOPo->op_first = 0;
6267 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6268 append_elem(OP_LIST, kid,
6269 scalar(newUNOP(OP_RV2CV, 0,
6278 Perl_ck_return(pTHX_ OP *o)
6281 if (CvLVALUE(PL_compcv)) {
6282 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6283 mod(kid, OP_LEAVESUBLV);
6290 Perl_ck_retarget(pTHX_ OP *o)
6292 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6299 Perl_ck_select(pTHX_ OP *o)
6302 if (o->op_flags & OPf_KIDS) {
6303 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6304 if (kid && kid->op_sibling) {
6305 o->op_type = OP_SSELECT;
6306 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6308 return fold_constants(o);
6312 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6313 if (kid && kid->op_type == OP_RV2GV)
6314 kid->op_private &= ~HINT_STRICT_REFS;
6319 Perl_ck_shift(pTHX_ OP *o)
6321 I32 type = o->op_type;
6323 if (!(o->op_flags & OPf_KIDS)) {
6327 #ifdef USE_5005THREADS
6328 if (!CvUNIQUE(PL_compcv)) {
6329 argop = newOP(OP_PADAV, OPf_REF);
6330 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6333 argop = newUNOP(OP_RV2AV, 0,
6334 scalar(newGVOP(OP_GV, 0,
6335 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6338 argop = newUNOP(OP_RV2AV, 0,
6339 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6340 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6341 #endif /* USE_5005THREADS */
6342 return newUNOP(type, 0, scalar(argop));
6344 return scalar(modkids(ck_fun(o), type));
6348 Perl_ck_sort(pTHX_ OP *o)
6352 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6354 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6355 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6357 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6359 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6361 if (kid->op_type == OP_SCOPE) {
6365 else if (kid->op_type == OP_LEAVE) {
6366 if (o->op_type == OP_SORT) {
6367 op_null(kid); /* wipe out leave */
6370 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6371 if (k->op_next == kid)
6373 /* don't descend into loops */
6374 else if (k->op_type == OP_ENTERLOOP
6375 || k->op_type == OP_ENTERITER)
6377 k = cLOOPx(k)->op_lastop;
6382 kid->op_next = 0; /* just disconnect the leave */
6383 k = kLISTOP->op_first;
6388 if (o->op_type == OP_SORT) {
6389 /* provide scalar context for comparison function/block */
6395 o->op_flags |= OPf_SPECIAL;
6397 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6400 firstkid = firstkid->op_sibling;
6403 /* provide list context for arguments */
6404 if (o->op_type == OP_SORT)
6411 S_simplify_sort(pTHX_ OP *o)
6413 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6417 if (!(o->op_flags & OPf_STACKED))
6419 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6420 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6421 kid = kUNOP->op_first; /* get past null */
6422 if (kid->op_type != OP_SCOPE)
6424 kid = kLISTOP->op_last; /* get past scope */
6425 switch(kid->op_type) {
6433 k = kid; /* remember this node*/
6434 if (kBINOP->op_first->op_type != OP_RV2SV)
6436 kid = kBINOP->op_first; /* get past cmp */
6437 if (kUNOP->op_first->op_type != OP_GV)
6439 kid = kUNOP->op_first; /* get past rv2sv */
6441 if (GvSTASH(gv) != PL_curstash)
6443 if (strEQ(GvNAME(gv), "a"))
6445 else if (strEQ(GvNAME(gv), "b"))
6449 kid = k; /* back to cmp */
6450 if (kBINOP->op_last->op_type != OP_RV2SV)
6452 kid = kBINOP->op_last; /* down to 2nd arg */
6453 if (kUNOP->op_first->op_type != OP_GV)
6455 kid = kUNOP->op_first; /* get past rv2sv */
6457 if (GvSTASH(gv) != PL_curstash
6459 ? strNE(GvNAME(gv), "a")
6460 : strNE(GvNAME(gv), "b")))
6462 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6464 o->op_private |= OPpSORT_REVERSE;
6465 if (k->op_type == OP_NCMP)
6466 o->op_private |= OPpSORT_NUMERIC;
6467 if (k->op_type == OP_I_NCMP)
6468 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6469 kid = cLISTOPo->op_first->op_sibling;
6470 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6471 op_free(kid); /* then delete it */
6475 Perl_ck_split(pTHX_ OP *o)
6479 if (o->op_flags & OPf_STACKED)
6480 return no_fh_allowed(o);
6482 kid = cLISTOPo->op_first;
6483 if (kid->op_type != OP_NULL)
6484 Perl_croak(aTHX_ "panic: ck_split");
6485 kid = kid->op_sibling;
6486 op_free(cLISTOPo->op_first);
6487 cLISTOPo->op_first = kid;
6489 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6490 cLISTOPo->op_last = kid; /* There was only one element previously */
6493 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6494 OP *sibl = kid->op_sibling;
6495 kid->op_sibling = 0;
6496 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6497 if (cLISTOPo->op_first == cLISTOPo->op_last)
6498 cLISTOPo->op_last = kid;
6499 cLISTOPo->op_first = kid;
6500 kid->op_sibling = sibl;
6503 kid->op_type = OP_PUSHRE;
6504 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6507 if (!kid->op_sibling)
6508 append_elem(OP_SPLIT, o, newDEFSVOP());
6510 kid = kid->op_sibling;
6513 if (!kid->op_sibling)
6514 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6516 kid = kid->op_sibling;
6519 if (kid->op_sibling)
6520 return too_many_arguments(o,OP_DESC(o));
6526 Perl_ck_join(pTHX_ OP *o)
6528 if (ckWARN(WARN_SYNTAX)) {
6529 OP *kid = cLISTOPo->op_first->op_sibling;
6530 if (kid && kid->op_type == OP_MATCH) {
6531 char *pmstr = "STRING";
6532 if (PM_GETRE(kPMOP))
6533 pmstr = PM_GETRE(kPMOP)->precomp;
6534 Perl_warner(aTHX_ WARN_SYNTAX,
6535 "/%s/ should probably be written as \"%s\"",
6543 Perl_ck_subr(pTHX_ OP *o)
6545 OP *prev = ((cUNOPo->op_first->op_sibling)
6546 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6547 OP *o2 = prev->op_sibling;
6554 I32 contextclass = 0;
6558 o->op_private |= OPpENTERSUB_HASTARG;
6559 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6560 if (cvop->op_type == OP_RV2CV) {
6562 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6563 op_null(cvop); /* disable rv2cv */
6564 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6565 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6566 GV *gv = cGVOPx_gv(tmpop);
6569 tmpop->op_private |= OPpEARLY_CV;
6570 else if (SvPOK(cv)) {
6571 namegv = CvANON(cv) ? gv : CvGV(cv);
6572 proto = SvPV((SV*)cv, n_a);
6576 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6577 if (o2->op_type == OP_CONST)
6578 o2->op_private &= ~OPpCONST_STRICT;
6579 else if (o2->op_type == OP_LIST) {
6580 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6581 if (o && o->op_type == OP_CONST)
6582 o->op_private &= ~OPpCONST_STRICT;
6585 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6586 if (PERLDB_SUB && PL_curstash != PL_debstash)
6587 o->op_private |= OPpENTERSUB_DB;
6588 while (o2 != cvop) {
6592 return too_many_arguments(o, gv_ename(namegv));
6610 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6612 arg == 1 ? "block or sub {}" : "sub {}",
6613 gv_ename(namegv), o2);
6616 /* '*' allows any scalar type, including bareword */
6619 if (o2->op_type == OP_RV2GV)
6620 goto wrapref; /* autoconvert GLOB -> GLOBref */
6621 else if (o2->op_type == OP_CONST)
6622 o2->op_private &= ~OPpCONST_STRICT;
6623 else if (o2->op_type == OP_ENTERSUB) {
6624 /* accidental subroutine, revert to bareword */
6625 OP *gvop = ((UNOP*)o2)->op_first;
6626 if (gvop && gvop->op_type == OP_NULL) {
6627 gvop = ((UNOP*)gvop)->op_first;
6629 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6632 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6633 (gvop = ((UNOP*)gvop)->op_first) &&
6634 gvop->op_type == OP_GV)
6636 GV *gv = cGVOPx_gv(gvop);
6637 OP *sibling = o2->op_sibling;
6638 SV *n = newSVpvn("",0);
6640 gv_fullname3(n, gv, "");
6641 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6642 sv_chop(n, SvPVX(n)+6);
6643 o2 = newSVOP(OP_CONST, 0, n);
6644 prev->op_sibling = o2;
6645 o2->op_sibling = sibling;
6661 if (contextclass++ == 0) {
6662 e = strchr(proto, ']');
6663 if (!e || e == proto)
6677 if (o2->op_type == OP_RV2GV)
6680 bad_type(arg, "symbol", gv_ename(namegv), o2);
6683 if (o2->op_type == OP_ENTERSUB)
6686 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6689 if (o2->op_type == OP_RV2SV ||
6690 o2->op_type == OP_PADSV ||
6691 o2->op_type == OP_HELEM ||
6692 o2->op_type == OP_AELEM ||
6693 o2->op_type == OP_THREADSV)
6696 bad_type(arg, "scalar", gv_ename(namegv), o2);
6699 if (o2->op_type == OP_RV2AV ||
6700 o2->op_type == OP_PADAV)
6703 bad_type(arg, "array", gv_ename(namegv), o2);
6706 if (o2->op_type == OP_RV2HV ||
6707 o2->op_type == OP_PADHV)
6710 bad_type(arg, "hash", gv_ename(namegv), o2);
6715 OP* sib = kid->op_sibling;
6716 kid->op_sibling = 0;
6717 o2 = newUNOP(OP_REFGEN, 0, kid);
6718 o2->op_sibling = sib;
6719 prev->op_sibling = o2;
6721 if (contextclass && e) {
6736 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6737 gv_ename(namegv), SvPV((SV*)cv, n_a));
6742 mod(o2, OP_ENTERSUB);
6744 o2 = o2->op_sibling;
6746 if (proto && !optional &&
6747 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6748 return too_few_arguments(o, gv_ename(namegv));
6753 Perl_ck_svconst(pTHX_ OP *o)
6755 SvREADONLY_on(cSVOPo->op_sv);
6760 Perl_ck_trunc(pTHX_ OP *o)
6762 if (o->op_flags & OPf_KIDS) {
6763 SVOP *kid = (SVOP*)cUNOPo->op_first;
6765 if (kid->op_type == OP_NULL)
6766 kid = (SVOP*)kid->op_sibling;
6767 if (kid && kid->op_type == OP_CONST &&
6768 (kid->op_private & OPpCONST_BARE))
6770 o->op_flags |= OPf_SPECIAL;
6771 kid->op_private &= ~OPpCONST_STRICT;
6778 Perl_ck_substr(pTHX_ OP *o)
6781 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6782 OP *kid = cLISTOPo->op_first;
6784 if (kid->op_type == OP_NULL)
6785 kid = kid->op_sibling;
6787 kid->op_flags |= OPf_MOD;
6793 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6796 Perl_peep(pTHX_ register OP *o)
6798 register OP* oldop = 0;
6801 if (!o || o->op_seq)
6805 SAVEVPTR(PL_curcop);
6806 for (; o; o = o->op_next) {
6812 switch (o->op_type) {
6816 PL_curcop = ((COP*)o); /* for warnings */
6817 o->op_seq = PL_op_seqmax++;
6821 if (cSVOPo->op_private & OPpCONST_STRICT)
6822 no_bareword_allowed(o);
6824 /* Relocate sv to the pad for thread safety.
6825 * Despite being a "constant", the SV is written to,
6826 * for reference counts, sv_upgrade() etc. */
6828 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6829 if (SvPADTMP(cSVOPo->op_sv)) {
6830 /* If op_sv is already a PADTMP then it is being used by
6831 * some pad, so make a copy. */
6832 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6833 SvREADONLY_on(PL_curpad[ix]);
6834 SvREFCNT_dec(cSVOPo->op_sv);
6837 SvREFCNT_dec(PL_curpad[ix]);
6838 SvPADTMP_on(cSVOPo->op_sv);
6839 PL_curpad[ix] = cSVOPo->op_sv;
6840 /* XXX I don't know how this isn't readonly already. */
6841 SvREADONLY_on(PL_curpad[ix]);
6843 cSVOPo->op_sv = Nullsv;
6847 o->op_seq = PL_op_seqmax++;
6851 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6852 if (o->op_next->op_private & OPpTARGET_MY) {
6853 if (o->op_flags & OPf_STACKED) /* chained concats */
6854 goto ignore_optimization;
6856 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6857 o->op_targ = o->op_next->op_targ;
6858 o->op_next->op_targ = 0;
6859 o->op_private |= OPpTARGET_MY;
6862 op_null(o->op_next);
6864 ignore_optimization:
6865 o->op_seq = PL_op_seqmax++;
6868 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6869 o->op_seq = PL_op_seqmax++;
6870 break; /* Scalar stub must produce undef. List stub is noop */
6874 if (o->op_targ == OP_NEXTSTATE
6875 || o->op_targ == OP_DBSTATE
6876 || o->op_targ == OP_SETSTATE)
6878 PL_curcop = ((COP*)o);
6880 /* XXX: We avoid setting op_seq here to prevent later calls
6881 to peep() from mistakenly concluding that optimisation
6882 has already occurred. This doesn't fix the real problem,
6883 though (See 20010220.007). AMS 20010719 */
6884 if (oldop && o->op_next) {
6885 oldop->op_next = o->op_next;
6893 if (oldop && o->op_next) {
6894 oldop->op_next = o->op_next;
6897 o->op_seq = PL_op_seqmax++;
6901 if (o->op_next->op_type == OP_RV2SV) {
6902 if (!(o->op_next->op_private & OPpDEREF)) {
6903 op_null(o->op_next);
6904 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6906 o->op_next = o->op_next->op_next;
6907 o->op_type = OP_GVSV;
6908 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6911 else if (o->op_next->op_type == OP_RV2AV) {
6912 OP* pop = o->op_next->op_next;
6914 if (pop->op_type == OP_CONST &&
6915 (PL_op = pop->op_next) &&
6916 pop->op_next->op_type == OP_AELEM &&
6917 !(pop->op_next->op_private &
6918 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6919 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6924 op_null(o->op_next);
6925 op_null(pop->op_next);
6927 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6928 o->op_next = pop->op_next->op_next;
6929 o->op_type = OP_AELEMFAST;
6930 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6931 o->op_private = (U8)i;
6936 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6938 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6939 /* XXX could check prototype here instead of just carping */
6940 SV *sv = sv_newmortal();
6941 gv_efullname3(sv, gv, Nullch);
6942 Perl_warner(aTHX_ WARN_PROTOTYPE,
6943 "%s() called too early to check prototype",
6947 else if (o->op_next->op_type == OP_READLINE
6948 && o->op_next->op_next->op_type == OP_CONCAT
6949 && (o->op_next->op_next->op_flags & OPf_STACKED))
6951 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6952 o->op_type = OP_RCATLINE;
6953 o->op_flags |= OPf_STACKED;
6954 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6955 op_null(o->op_next->op_next);
6956 op_null(o->op_next);
6959 o->op_seq = PL_op_seqmax++;
6970 o->op_seq = PL_op_seqmax++;
6971 while (cLOGOP->op_other->op_type == OP_NULL)
6972 cLOGOP->op_other = cLOGOP->op_other->op_next;
6973 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6978 o->op_seq = PL_op_seqmax++;
6979 while (cLOOP->op_redoop->op_type == OP_NULL)
6980 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6981 peep(cLOOP->op_redoop);
6982 while (cLOOP->op_nextop->op_type == OP_NULL)
6983 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6984 peep(cLOOP->op_nextop);
6985 while (cLOOP->op_lastop->op_type == OP_NULL)
6986 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6987 peep(cLOOP->op_lastop);
6993 o->op_seq = PL_op_seqmax++;
6994 while (cPMOP->op_pmreplstart &&
6995 cPMOP->op_pmreplstart->op_type == OP_NULL)
6996 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6997 peep(cPMOP->op_pmreplstart);
7001 o->op_seq = PL_op_seqmax++;
7002 if (ckWARN(WARN_SYNTAX) && o->op_next
7003 && o->op_next->op_type == OP_NEXTSTATE) {
7004 if (o->op_next->op_sibling &&
7005 o->op_next->op_sibling->op_type != OP_EXIT &&
7006 o->op_next->op_sibling->op_type != OP_WARN &&
7007 o->op_next->op_sibling->op_type != OP_DIE) {
7008 line_t oldline = CopLINE(PL_curcop);
7010 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7011 Perl_warner(aTHX_ WARN_EXEC,
7012 "Statement unlikely to be reached");
7013 Perl_warner(aTHX_ WARN_EXEC,
7014 "\t(Maybe you meant system() when you said exec()?)\n");
7015 CopLINE_set(PL_curcop, oldline);
7024 SV **svp, **indsvp, *sv;
7029 o->op_seq = PL_op_seqmax++;
7031 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7034 /* Make the CONST have a shared SV */
7035 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7036 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7037 key = SvPV(sv, keylen);
7038 lexname = newSVpvn_share(key,
7039 SvUTF8(sv) ? -(I32)keylen : keylen,
7045 if ((o->op_private & (OPpLVAL_INTRO)))
7048 rop = (UNOP*)((BINOP*)o)->op_first;
7049 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7051 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7052 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7054 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7055 if (!fields || !GvHV(*fields))
7057 key = SvPV(*svp, keylen);
7058 indsvp = hv_fetch(GvHV(*fields), key,
7059 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7061 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7062 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7064 ind = SvIV(*indsvp);
7066 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7067 rop->op_type = OP_RV2AV;
7068 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7069 o->op_type = OP_AELEM;
7070 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7072 if (SvREADONLY(*svp))
7074 SvFLAGS(sv) |= (SvFLAGS(*svp)
7075 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7085 SV **svp, **indsvp, *sv;
7089 SVOP *first_key_op, *key_op;
7091 o->op_seq = PL_op_seqmax++;
7092 if ((o->op_private & (OPpLVAL_INTRO))
7093 /* I bet there's always a pushmark... */
7094 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7095 /* hmmm, no optimization if list contains only one key. */
7097 rop = (UNOP*)((LISTOP*)o)->op_last;
7098 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7100 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7101 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7103 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7104 if (!fields || !GvHV(*fields))
7106 /* Again guessing that the pushmark can be jumped over.... */
7107 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7108 ->op_first->op_sibling;
7109 /* Check that the key list contains only constants. */
7110 for (key_op = first_key_op; key_op;
7111 key_op = (SVOP*)key_op->op_sibling)
7112 if (key_op->op_type != OP_CONST)
7116 rop->op_type = OP_RV2AV;
7117 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7118 o->op_type = OP_ASLICE;
7119 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7120 for (key_op = first_key_op; key_op;
7121 key_op = (SVOP*)key_op->op_sibling) {
7122 svp = cSVOPx_svp(key_op);
7123 key = SvPV(*svp, keylen);
7124 indsvp = hv_fetch(GvHV(*fields), key,
7125 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7127 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7128 "in variable %s of type %s",
7129 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7131 ind = SvIV(*indsvp);
7133 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7135 if (SvREADONLY(*svp))
7137 SvFLAGS(sv) |= (SvFLAGS(*svp)
7138 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7146 o->op_seq = PL_op_seqmax++;
7156 char* Perl_custom_op_name(pTHX_ OP* o)
7158 IV index = PTR2IV(o->op_ppaddr);
7162 if (!PL_custom_op_names) /* This probably shouldn't happen */
7163 return PL_op_name[OP_CUSTOM];
7165 keysv = sv_2mortal(newSViv(index));
7167 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7169 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7171 return SvPV_nolen(HeVAL(he));
7174 char* Perl_custom_op_desc(pTHX_ OP* o)
7176 IV index = PTR2IV(o->op_ppaddr);
7180 if (!PL_custom_op_descs)
7181 return PL_op_desc[OP_CUSTOM];
7183 keysv = sv_2mortal(newSViv(index));
7185 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7187 return PL_op_desc[OP_CUSTOM];
7189 return SvPV_nolen(HeVAL(he));
7195 /* Efficient sub that returns a constant scalar value. */
7197 const_sv_xsub(pTHX_ CV* cv)
7202 Perl_croak(aTHX_ "usage: %s::%s()",
7203 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7207 ST(0) = (SV*)XSANY.any_ptr;