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);
1032 Perl_scalarvoid(pTHX_ OP *o)
1039 if (o->op_type == OP_NEXTSTATE
1040 || o->op_type == OP_SETSTATE
1041 || o->op_type == OP_DBSTATE
1042 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1043 || o->op_targ == OP_SETSTATE
1044 || o->op_targ == OP_DBSTATE)))
1045 PL_curcop = (COP*)o; /* for warning below */
1047 /* assumes no premature commitment */
1048 want = o->op_flags & OPf_WANT;
1049 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1050 || o->op_type == OP_RETURN)
1055 if ((o->op_private & OPpTARGET_MY)
1056 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1058 return scalar(o); /* As if inside SASSIGN */
1061 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1063 switch (o->op_type) {
1065 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1069 if (o->op_flags & OPf_STACKED)
1073 if (o->op_private == 4)
1115 case OP_GETSOCKNAME:
1116 case OP_GETPEERNAME:
1121 case OP_GETPRIORITY:
1144 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1145 useless = OP_DESC(o);
1152 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1153 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1154 useless = "a variable";
1159 if (cSVOPo->op_private & OPpCONST_STRICT)
1160 no_bareword_allowed(o);
1162 if (ckWARN(WARN_VOID)) {
1163 useless = "a constant";
1164 /* the constants 0 and 1 are permitted as they are
1165 conventionally used as dummies in constructs like
1166 1 while some_condition_with_side_effects; */
1167 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1169 else if (SvPOK(sv)) {
1170 /* perl4's way of mixing documentation and code
1171 (before the invention of POD) was based on a
1172 trick to mix nroff and perl code. The trick was
1173 built upon these three nroff macros being used in
1174 void context. The pink camel has the details in
1175 the script wrapman near page 319. */
1176 if (strnEQ(SvPVX(sv), "di", 2) ||
1177 strnEQ(SvPVX(sv), "ds", 2) ||
1178 strnEQ(SvPVX(sv), "ig", 2))
1183 op_null(o); /* don't execute or even remember it */
1187 o->op_type = OP_PREINC; /* pre-increment is faster */
1188 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1192 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1193 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1199 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1204 if (o->op_flags & OPf_STACKED)
1211 if (!(o->op_flags & OPf_KIDS))
1220 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1227 /* all requires must return a boolean value */
1228 o->op_flags &= ~OPf_WANT;
1233 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1234 if (!kPMOP->op_pmreplroot)
1235 deprecate("implicit split to @_");
1239 if (useless && ckWARN(WARN_VOID))
1240 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1245 Perl_listkids(pTHX_ OP *o)
1248 if (o && o->op_flags & OPf_KIDS) {
1249 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1256 Perl_list(pTHX_ OP *o)
1260 /* assumes no premature commitment */
1261 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1262 || o->op_type == OP_RETURN)
1267 if ((o->op_private & OPpTARGET_MY)
1268 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1270 return o; /* As if inside SASSIGN */
1273 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1275 switch (o->op_type) {
1278 list(cBINOPo->op_first);
1283 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1291 if (!(o->op_flags & OPf_KIDS))
1293 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1294 list(cBINOPo->op_first);
1295 return gen_constant_list(o);
1302 kid = cLISTOPo->op_first;
1304 while ((kid = kid->op_sibling)) {
1305 if (kid->op_sibling)
1310 WITH_THR(PL_curcop = &PL_compiling);
1314 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1315 if (kid->op_sibling)
1320 WITH_THR(PL_curcop = &PL_compiling);
1323 /* all requires must return a boolean value */
1324 o->op_flags &= ~OPf_WANT;
1331 Perl_scalarseq(pTHX_ OP *o)
1336 if (o->op_type == OP_LINESEQ ||
1337 o->op_type == OP_SCOPE ||
1338 o->op_type == OP_LEAVE ||
1339 o->op_type == OP_LEAVETRY)
1341 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1342 if (kid->op_sibling) {
1346 PL_curcop = &PL_compiling;
1348 o->op_flags &= ~OPf_PARENS;
1349 if (PL_hints & HINT_BLOCK_SCOPE)
1350 o->op_flags |= OPf_PARENS;
1353 o = newOP(OP_STUB, 0);
1358 S_modkids(pTHX_ OP *o, I32 type)
1361 if (o && o->op_flags & OPf_KIDS) {
1362 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1369 Perl_mod(pTHX_ OP *o, I32 type)
1374 if (!o || PL_error_count)
1377 if ((o->op_private & OPpTARGET_MY)
1378 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1383 switch (o->op_type) {
1388 if (!(o->op_private & (OPpCONST_ARYBASE)))
1390 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1391 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1395 SAVEI32(PL_compiling.cop_arybase);
1396 PL_compiling.cop_arybase = 0;
1398 else if (type == OP_REFGEN)
1401 Perl_croak(aTHX_ "That use of $[ is unsupported");
1404 if (o->op_flags & OPf_PARENS)
1408 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1409 !(o->op_flags & OPf_STACKED)) {
1410 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1411 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1412 assert(cUNOPo->op_first->op_type == OP_NULL);
1413 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1416 else { /* lvalue subroutine call */
1417 o->op_private |= OPpLVAL_INTRO;
1418 PL_modcount = RETURN_UNLIMITED_NUMBER;
1419 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1420 /* Backward compatibility mode: */
1421 o->op_private |= OPpENTERSUB_INARGS;
1424 else { /* Compile-time error message: */
1425 OP *kid = cUNOPo->op_first;
1429 if (kid->op_type == OP_PUSHMARK)
1431 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1433 "panic: unexpected lvalue entersub "
1434 "args: type/targ %ld:%"UVuf,
1435 (long)kid->op_type, (UV)kid->op_targ);
1436 kid = kLISTOP->op_first;
1438 while (kid->op_sibling)
1439 kid = kid->op_sibling;
1440 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1442 if (kid->op_type == OP_METHOD_NAMED
1443 || kid->op_type == OP_METHOD)
1447 if (kid->op_sibling || kid->op_next != kid) {
1448 yyerror("panic: unexpected optree near method call");
1452 NewOp(1101, newop, 1, UNOP);
1453 newop->op_type = OP_RV2CV;
1454 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1455 newop->op_first = Nullop;
1456 newop->op_next = (OP*)newop;
1457 kid->op_sibling = (OP*)newop;
1458 newop->op_private |= OPpLVAL_INTRO;
1462 if (kid->op_type != OP_RV2CV)
1464 "panic: unexpected lvalue entersub "
1465 "entry via type/targ %ld:%"UVuf,
1466 (long)kid->op_type, (UV)kid->op_targ);
1467 kid->op_private |= OPpLVAL_INTRO;
1468 break; /* Postpone until runtime */
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1474 kid = kUNOP->op_first;
1475 if (kid->op_type == OP_NULL)
1477 "Unexpected constant lvalue entersub "
1478 "entry via type/targ %ld:%"UVuf,
1479 (long)kid->op_type, (UV)kid->op_targ);
1480 if (kid->op_type != OP_GV) {
1481 /* Restore RV2CV to check lvalueness */
1483 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1484 okid->op_next = kid->op_next;
1485 kid->op_next = okid;
1488 okid->op_next = Nullop;
1489 okid->op_type = OP_RV2CV;
1491 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1492 okid->op_private |= OPpLVAL_INTRO;
1496 cv = GvCV(kGVOP_gv);
1506 /* grep, foreach, subcalls, refgen */
1507 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1509 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1510 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1512 : (o->op_type == OP_ENTERSUB
1513 ? "non-lvalue subroutine call"
1515 type ? PL_op_desc[type] : "local"));
1529 case OP_RIGHT_SHIFT:
1538 if (!(o->op_flags & OPf_STACKED))
1544 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1550 if (!type && cUNOPo->op_first->op_type != OP_GV)
1551 Perl_croak(aTHX_ "Can't localize through a reference");
1552 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1553 PL_modcount = RETURN_UNLIMITED_NUMBER;
1554 return o; /* Treat \(@foo) like ordinary list. */
1558 if (scalar_mod_type(o, type))
1560 ref(cUNOPo->op_first, o->op_type);
1564 if (type == OP_LEAVESUBLV)
1565 o->op_private |= OPpMAYBE_LVSUB;
1571 PL_modcount = RETURN_UNLIMITED_NUMBER;
1574 if (!type && cUNOPo->op_first->op_type != OP_GV)
1575 Perl_croak(aTHX_ "Can't localize through a reference");
1576 ref(cUNOPo->op_first, o->op_type);
1580 PL_hints |= HINT_BLOCK_SCOPE;
1590 PL_modcount = RETURN_UNLIMITED_NUMBER;
1591 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1592 return o; /* Treat \(@foo) like ordinary list. */
1593 if (scalar_mod_type(o, type))
1595 if (type == OP_LEAVESUBLV)
1596 o->op_private |= OPpMAYBE_LVSUB;
1601 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1602 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1605 #ifdef USE_5005THREADS
1607 PL_modcount++; /* XXX ??? */
1609 #endif /* USE_5005THREADS */
1615 if (type != OP_SASSIGN)
1619 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1624 if (type == OP_LEAVESUBLV)
1625 o->op_private |= OPpMAYBE_LVSUB;
1627 pad_free(o->op_targ);
1628 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1629 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1630 if (o->op_flags & OPf_KIDS)
1631 mod(cBINOPo->op_first->op_sibling, type);
1636 ref(cBINOPo->op_first, o->op_type);
1637 if (type == OP_ENTERSUB &&
1638 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1639 o->op_private |= OPpLVAL_DEFER;
1640 if (type == OP_LEAVESUBLV)
1641 o->op_private |= OPpMAYBE_LVSUB;
1649 if (o->op_flags & OPf_KIDS)
1650 mod(cLISTOPo->op_last, type);
1654 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1656 else if (!(o->op_flags & OPf_KIDS))
1658 if (o->op_targ != OP_LIST) {
1659 mod(cBINOPo->op_first, type);
1664 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1669 if (type != OP_LEAVESUBLV)
1671 break; /* mod()ing was handled by ck_return() */
1674 /* [20011101.069] File test operators interpret OPf_REF to mean that
1675 their argument is a filehandle; thus \stat(".") should not set
1677 if (type == OP_REFGEN &&
1678 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1681 if (type != OP_LEAVESUBLV)
1682 o->op_flags |= OPf_MOD;
1684 if (type == OP_AASSIGN || type == OP_SASSIGN)
1685 o->op_flags |= OPf_SPECIAL|OPf_REF;
1687 o->op_private |= OPpLVAL_INTRO;
1688 o->op_flags &= ~OPf_SPECIAL;
1689 PL_hints |= HINT_BLOCK_SCOPE;
1691 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1692 && type != OP_LEAVESUBLV)
1693 o->op_flags |= OPf_REF;
1698 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1702 if (o->op_type == OP_RV2GV)
1726 case OP_RIGHT_SHIFT:
1745 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1747 switch (o->op_type) {
1755 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1768 Perl_refkids(pTHX_ OP *o, I32 type)
1771 if (o && o->op_flags & OPf_KIDS) {
1772 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1779 Perl_ref(pTHX_ OP *o, I32 type)
1783 if (!o || PL_error_count)
1786 switch (o->op_type) {
1788 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1789 !(o->op_flags & OPf_STACKED)) {
1790 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1791 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1792 assert(cUNOPo->op_first->op_type == OP_NULL);
1793 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1794 o->op_flags |= OPf_SPECIAL;
1799 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1803 if (type == OP_DEFINED)
1804 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1805 ref(cUNOPo->op_first, o->op_type);
1808 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1809 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1810 : type == OP_RV2HV ? OPpDEREF_HV
1812 o->op_flags |= OPf_MOD;
1817 o->op_flags |= OPf_MOD; /* XXX ??? */
1822 o->op_flags |= OPf_REF;
1825 if (type == OP_DEFINED)
1826 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1827 ref(cUNOPo->op_first, o->op_type);
1832 o->op_flags |= OPf_REF;
1837 if (!(o->op_flags & OPf_KIDS))
1839 ref(cBINOPo->op_first, type);
1843 ref(cBINOPo->op_first, o->op_type);
1844 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1845 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1846 : type == OP_RV2HV ? OPpDEREF_HV
1848 o->op_flags |= OPf_MOD;
1856 if (!(o->op_flags & OPf_KIDS))
1858 ref(cLISTOPo->op_last, type);
1868 S_dup_attrlist(pTHX_ OP *o)
1872 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1873 * where the first kid is OP_PUSHMARK and the remaining ones
1874 * are OP_CONST. We need to push the OP_CONST values.
1876 if (o->op_type == OP_CONST)
1877 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1879 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1880 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1881 if (o->op_type == OP_CONST)
1882 rop = append_elem(OP_LIST, rop,
1883 newSVOP(OP_CONST, o->op_flags,
1884 SvREFCNT_inc(cSVOPo->op_sv)));
1891 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1895 /* fake up C<use attributes $pkg,$rv,@attrs> */
1896 ENTER; /* need to protect against side-effects of 'use' */
1899 stashsv = newSVpv(HvNAME(stash), 0);
1901 stashsv = &PL_sv_no;
1903 #define ATTRSMODULE "attributes"
1905 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1906 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1908 prepend_elem(OP_LIST,
1909 newSVOP(OP_CONST, 0, stashsv),
1910 prepend_elem(OP_LIST,
1911 newSVOP(OP_CONST, 0,
1913 dup_attrlist(attrs))));
1918 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1919 char *attrstr, STRLEN len)
1924 len = strlen(attrstr);
1928 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1930 char *sstr = attrstr;
1931 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1932 attrs = append_elem(OP_LIST, attrs,
1933 newSVOP(OP_CONST, 0,
1934 newSVpvn(sstr, attrstr-sstr)));
1938 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1939 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1940 Nullsv, prepend_elem(OP_LIST,
1941 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1942 prepend_elem(OP_LIST,
1943 newSVOP(OP_CONST, 0,
1949 S_my_kid(pTHX_ OP *o, OP *attrs)
1954 if (!o || PL_error_count)
1958 if (type == OP_LIST) {
1959 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1961 } else if (type == OP_UNDEF) {
1963 } else if (type == OP_RV2SV || /* "our" declaration */
1965 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1967 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1969 PL_in_my_stash = Nullhv;
1970 apply_attrs(GvSTASH(gv),
1971 (type == OP_RV2SV ? GvSV(gv) :
1972 type == OP_RV2AV ? (SV*)GvAV(gv) :
1973 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1976 o->op_private |= OPpOUR_INTRO;
1978 } else if (type != OP_PADSV &&
1981 type != OP_PUSHMARK)
1983 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1985 PL_in_my == KEY_our ? "our" : "my"));
1988 else if (attrs && type != OP_PUSHMARK) {
1994 PL_in_my_stash = Nullhv;
1996 /* check for C<my Dog $spot> when deciding package */
1997 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1998 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1999 stash = SvSTASH(*namesvp);
2001 stash = PL_curstash;
2002 padsv = PAD_SV(o->op_targ);
2003 apply_attrs(stash, padsv, attrs);
2005 o->op_flags |= OPf_MOD;
2006 o->op_private |= OPpLVAL_INTRO;
2011 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2013 if (o->op_flags & OPf_PARENS)
2017 o = my_kid(o, attrs);
2019 PL_in_my_stash = Nullhv;
2024 Perl_my(pTHX_ OP *o)
2026 return my_kid(o, Nullop);
2030 Perl_sawparens(pTHX_ OP *o)
2033 o->op_flags |= OPf_PARENS;
2038 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2042 if (ckWARN(WARN_MISC) &&
2043 (left->op_type == OP_RV2AV ||
2044 left->op_type == OP_RV2HV ||
2045 left->op_type == OP_PADAV ||
2046 left->op_type == OP_PADHV)) {
2047 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2048 right->op_type == OP_TRANS)
2049 ? right->op_type : OP_MATCH];
2050 const char *sample = ((left->op_type == OP_RV2AV ||
2051 left->op_type == OP_PADAV)
2052 ? "@array" : "%hash");
2053 Perl_warner(aTHX_ WARN_MISC,
2054 "Applying %s to %s will act on scalar(%s)",
2055 desc, sample, sample);
2058 if (!(right->op_flags & OPf_STACKED) &&
2059 (right->op_type == OP_MATCH ||
2060 right->op_type == OP_SUBST ||
2061 right->op_type == OP_TRANS)) {
2062 right->op_flags |= OPf_STACKED;
2063 if ((right->op_type != OP_MATCH &&
2064 ! (right->op_type == OP_TRANS &&
2065 right->op_private & OPpTRANS_IDENTICAL)) ||
2066 /* if SV has magic, then match on original SV, not on its copy.
2067 see note in pp_helem() */
2068 (right->op_type == OP_MATCH &&
2069 (left->op_type == OP_AELEM ||
2070 left->op_type == OP_HELEM ||
2071 left->op_type == OP_AELEMFAST)))
2072 left = mod(left, right->op_type);
2073 if (right->op_type == OP_TRANS)
2074 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2076 o = prepend_elem(right->op_type, scalar(left), right);
2078 return newUNOP(OP_NOT, 0, scalar(o));
2082 return bind_match(type, left,
2083 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2087 Perl_invert(pTHX_ OP *o)
2091 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2092 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2096 Perl_scope(pTHX_ OP *o)
2099 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2100 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2101 o->op_type = OP_LEAVE;
2102 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2105 if (o->op_type == OP_LINESEQ) {
2107 o->op_type = OP_SCOPE;
2108 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2109 kid = ((LISTOP*)o)->op_first;
2110 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2114 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2121 Perl_save_hints(pTHX)
2124 SAVESPTR(GvHV(PL_hintgv));
2125 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2126 SAVEFREESV(GvHV(PL_hintgv));
2130 Perl_block_start(pTHX_ int full)
2132 int retval = PL_savestack_ix;
2134 SAVEI32(PL_comppad_name_floor);
2135 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2137 PL_comppad_name_fill = PL_comppad_name_floor;
2138 if (PL_comppad_name_floor < 0)
2139 PL_comppad_name_floor = 0;
2140 SAVEI32(PL_min_intro_pending);
2141 SAVEI32(PL_max_intro_pending);
2142 PL_min_intro_pending = 0;
2143 SAVEI32(PL_comppad_name_fill);
2144 SAVEI32(PL_padix_floor);
2145 PL_padix_floor = PL_padix;
2146 PL_pad_reset_pending = FALSE;
2148 PL_hints &= ~HINT_BLOCK_SCOPE;
2149 SAVESPTR(PL_compiling.cop_warnings);
2150 if (! specialWARN(PL_compiling.cop_warnings)) {
2151 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2152 SAVEFREESV(PL_compiling.cop_warnings) ;
2154 SAVESPTR(PL_compiling.cop_io);
2155 if (! specialCopIO(PL_compiling.cop_io)) {
2156 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2157 SAVEFREESV(PL_compiling.cop_io) ;
2163 Perl_block_end(pTHX_ I32 floor, OP *seq)
2165 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2166 line_t copline = PL_copline;
2167 /* there should be a nextstate in every block */
2168 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2169 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2171 PL_pad_reset_pending = FALSE;
2172 PL_compiling.op_private = PL_hints;
2174 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2175 pad_leavemy(PL_comppad_name_fill);
2183 #ifdef USE_5005THREADS
2184 OP *o = newOP(OP_THREADSV, 0);
2185 o->op_targ = find_threadsv("_");
2188 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2189 #endif /* USE_5005THREADS */
2193 Perl_newPROG(pTHX_ OP *o)
2198 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2199 ((PL_in_eval & EVAL_KEEPERR)
2200 ? OPf_SPECIAL : 0), o);
2201 PL_eval_start = linklist(PL_eval_root);
2202 PL_eval_root->op_private |= OPpREFCOUNTED;
2203 OpREFCNT_set(PL_eval_root, 1);
2204 PL_eval_root->op_next = 0;
2205 CALL_PEEP(PL_eval_start);
2210 PL_main_root = scope(sawparens(scalarvoid(o)));
2211 PL_curcop = &PL_compiling;
2212 PL_main_start = LINKLIST(PL_main_root);
2213 PL_main_root->op_private |= OPpREFCOUNTED;
2214 OpREFCNT_set(PL_main_root, 1);
2215 PL_main_root->op_next = 0;
2216 CALL_PEEP(PL_main_start);
2219 /* Register with debugger */
2221 CV *cv = get_cv("DB::postponed", FALSE);
2225 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2227 call_sv((SV*)cv, G_DISCARD);
2234 Perl_localize(pTHX_ OP *o, I32 lex)
2236 if (o->op_flags & OPf_PARENS)
2239 if (ckWARN(WARN_PARENTHESIS)
2240 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2242 char *s = PL_bufptr;
2244 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2247 if (*s == ';' || *s == '=')
2248 Perl_warner(aTHX_ WARN_PARENTHESIS,
2249 "Parentheses missing around \"%s\" list",
2250 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2256 o = mod(o, OP_NULL); /* a bit kludgey */
2258 PL_in_my_stash = Nullhv;
2263 Perl_jmaybe(pTHX_ OP *o)
2265 if (o->op_type == OP_LIST) {
2267 #ifdef USE_5005THREADS
2268 o2 = newOP(OP_THREADSV, 0);
2269 o2->op_targ = find_threadsv(";");
2271 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2272 #endif /* USE_5005THREADS */
2273 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2279 Perl_fold_constants(pTHX_ register OP *o)
2282 I32 type = o->op_type;
2285 if (PL_opargs[type] & OA_RETSCALAR)
2287 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2288 o->op_targ = pad_alloc(type, SVs_PADTMP);
2290 /* integerize op, unless it happens to be C<-foo>.
2291 * XXX should pp_i_negate() do magic string negation instead? */
2292 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2293 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2294 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2296 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2299 if (!(PL_opargs[type] & OA_FOLDCONST))
2304 /* XXX might want a ck_negate() for this */
2305 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2317 /* XXX what about the numeric ops? */
2318 if (PL_hints & HINT_LOCALE)
2323 goto nope; /* Don't try to run w/ errors */
2325 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2326 if ((curop->op_type != OP_CONST ||
2327 (curop->op_private & OPpCONST_BARE)) &&
2328 curop->op_type != OP_LIST &&
2329 curop->op_type != OP_SCALAR &&
2330 curop->op_type != OP_NULL &&
2331 curop->op_type != OP_PUSHMARK)
2337 curop = LINKLIST(o);
2341 sv = *(PL_stack_sp--);
2342 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2343 pad_swipe(o->op_targ);
2344 else if (SvTEMP(sv)) { /* grab mortal temp? */
2345 (void)SvREFCNT_inc(sv);
2349 if (type == OP_RV2GV)
2350 return newGVOP(OP_GV, 0, (GV*)sv);
2352 /* try to smush double to int, but don't smush -2.0 to -2 */
2353 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2356 #ifdef PERL_PRESERVE_IVUV
2357 /* Only bother to attempt to fold to IV if
2358 most operators will benefit */
2362 return newSVOP(OP_CONST, 0, sv);
2366 if (!(PL_opargs[type] & OA_OTHERINT))
2369 if (!(PL_hints & HINT_INTEGER)) {
2370 if (type == OP_MODULO
2371 || type == OP_DIVIDE
2372 || !(o->op_flags & OPf_KIDS))
2377 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2378 if (curop->op_type == OP_CONST) {
2379 if (SvIOK(((SVOP*)curop)->op_sv))
2383 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2387 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2394 Perl_gen_constant_list(pTHX_ register OP *o)
2397 I32 oldtmps_floor = PL_tmps_floor;
2401 return o; /* Don't attempt to run with errors */
2403 PL_op = curop = LINKLIST(o);
2410 PL_tmps_floor = oldtmps_floor;
2412 o->op_type = OP_RV2AV;
2413 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2414 curop = ((UNOP*)o)->op_first;
2415 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2422 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2424 if (!o || o->op_type != OP_LIST)
2425 o = newLISTOP(OP_LIST, 0, o, Nullop);
2427 o->op_flags &= ~OPf_WANT;
2429 if (!(PL_opargs[type] & OA_MARK))
2430 op_null(cLISTOPo->op_first);
2433 o->op_ppaddr = PL_ppaddr[type];
2434 o->op_flags |= flags;
2436 o = CHECKOP(type, o);
2437 if (o->op_type != type)
2440 return fold_constants(o);
2443 /* List constructors */
2446 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2454 if (first->op_type != type
2455 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2457 return newLISTOP(type, 0, first, last);
2460 if (first->op_flags & OPf_KIDS)
2461 ((LISTOP*)first)->op_last->op_sibling = last;
2463 first->op_flags |= OPf_KIDS;
2464 ((LISTOP*)first)->op_first = last;
2466 ((LISTOP*)first)->op_last = last;
2471 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2479 if (first->op_type != type)
2480 return prepend_elem(type, (OP*)first, (OP*)last);
2482 if (last->op_type != type)
2483 return append_elem(type, (OP*)first, (OP*)last);
2485 first->op_last->op_sibling = last->op_first;
2486 first->op_last = last->op_last;
2487 first->op_flags |= (last->op_flags & OPf_KIDS);
2489 #ifdef PL_OP_SLAB_ALLOC
2497 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2505 if (last->op_type == type) {
2506 if (type == OP_LIST) { /* already a PUSHMARK there */
2507 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2508 ((LISTOP*)last)->op_first->op_sibling = first;
2509 if (!(first->op_flags & OPf_PARENS))
2510 last->op_flags &= ~OPf_PARENS;
2513 if (!(last->op_flags & OPf_KIDS)) {
2514 ((LISTOP*)last)->op_last = first;
2515 last->op_flags |= OPf_KIDS;
2517 first->op_sibling = ((LISTOP*)last)->op_first;
2518 ((LISTOP*)last)->op_first = first;
2520 last->op_flags |= OPf_KIDS;
2524 return newLISTOP(type, 0, first, last);
2530 Perl_newNULLLIST(pTHX)
2532 return newOP(OP_STUB, 0);
2536 Perl_force_list(pTHX_ OP *o)
2538 if (!o || o->op_type != OP_LIST)
2539 o = newLISTOP(OP_LIST, 0, o, Nullop);
2545 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2549 NewOp(1101, listop, 1, LISTOP);
2551 listop->op_type = type;
2552 listop->op_ppaddr = PL_ppaddr[type];
2555 listop->op_flags = flags;
2559 else if (!first && last)
2562 first->op_sibling = last;
2563 listop->op_first = first;
2564 listop->op_last = last;
2565 if (type == OP_LIST) {
2567 pushop = newOP(OP_PUSHMARK, 0);
2568 pushop->op_sibling = first;
2569 listop->op_first = pushop;
2570 listop->op_flags |= OPf_KIDS;
2572 listop->op_last = pushop;
2579 Perl_newOP(pTHX_ I32 type, I32 flags)
2582 NewOp(1101, o, 1, OP);
2584 o->op_ppaddr = PL_ppaddr[type];
2585 o->op_flags = flags;
2588 o->op_private = 0 + (flags >> 8);
2589 if (PL_opargs[type] & OA_RETSCALAR)
2591 if (PL_opargs[type] & OA_TARGET)
2592 o->op_targ = pad_alloc(type, SVs_PADTMP);
2593 return CHECKOP(type, o);
2597 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2602 first = newOP(OP_STUB, 0);
2603 if (PL_opargs[type] & OA_MARK)
2604 first = force_list(first);
2606 NewOp(1101, unop, 1, UNOP);
2607 unop->op_type = type;
2608 unop->op_ppaddr = PL_ppaddr[type];
2609 unop->op_first = first;
2610 unop->op_flags = flags | OPf_KIDS;
2611 unop->op_private = 1 | (flags >> 8);
2612 unop = (UNOP*) CHECKOP(type, unop);
2616 return fold_constants((OP *) unop);
2620 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2623 NewOp(1101, binop, 1, BINOP);
2626 first = newOP(OP_NULL, 0);
2628 binop->op_type = type;
2629 binop->op_ppaddr = PL_ppaddr[type];
2630 binop->op_first = first;
2631 binop->op_flags = flags | OPf_KIDS;
2634 binop->op_private = 1 | (flags >> 8);
2637 binop->op_private = 2 | (flags >> 8);
2638 first->op_sibling = last;
2641 binop = (BINOP*)CHECKOP(type, binop);
2642 if (binop->op_next || binop->op_type != type)
2645 binop->op_last = binop->op_first->op_sibling;
2647 return fold_constants((OP *)binop);
2651 uvcompare(const void *a, const void *b)
2653 if (*((UV *)a) < (*(UV *)b))
2655 if (*((UV *)a) > (*(UV *)b))
2657 if (*((UV *)a+1) < (*(UV *)b+1))
2659 if (*((UV *)a+1) > (*(UV *)b+1))
2665 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2667 SV *tstr = ((SVOP*)expr)->op_sv;
2668 SV *rstr = ((SVOP*)repl)->op_sv;
2671 U8 *t = (U8*)SvPV(tstr, tlen);
2672 U8 *r = (U8*)SvPV(rstr, rlen);
2679 register short *tbl;
2681 PL_hints |= HINT_BLOCK_SCOPE;
2682 complement = o->op_private & OPpTRANS_COMPLEMENT;
2683 del = o->op_private & OPpTRANS_DELETE;
2684 squash = o->op_private & OPpTRANS_SQUASH;
2687 o->op_private |= OPpTRANS_FROM_UTF;
2690 o->op_private |= OPpTRANS_TO_UTF;
2692 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2693 SV* listsv = newSVpvn("# comment\n",10);
2695 U8* tend = t + tlen;
2696 U8* rend = r + rlen;
2710 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2711 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2717 tsave = t = bytes_to_utf8(t, &len);
2720 if (!to_utf && rlen) {
2722 rsave = r = bytes_to_utf8(r, &len);
2726 /* There are several snags with this code on EBCDIC:
2727 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2728 2. scan_const() in toke.c has encoded chars in native encoding which makes
2729 ranges at least in EBCDIC 0..255 range the bottom odd.
2733 U8 tmpbuf[UTF8_MAXLEN+1];
2736 New(1109, cp, 2*tlen, UV);
2738 transv = newSVpvn("",0);
2740 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2742 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2744 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2748 cp[2*i+1] = cp[2*i];
2752 qsort(cp, i, 2*sizeof(UV), uvcompare);
2753 for (j = 0; j < i; j++) {
2755 diff = val - nextmin;
2757 t = uvuni_to_utf8(tmpbuf,nextmin);
2758 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2760 U8 range_mark = UTF_TO_NATIVE(0xff);
2761 t = uvuni_to_utf8(tmpbuf, val - 1);
2762 sv_catpvn(transv, (char *)&range_mark, 1);
2763 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2770 t = uvuni_to_utf8(tmpbuf,nextmin);
2771 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2773 U8 range_mark = UTF_TO_NATIVE(0xff);
2774 sv_catpvn(transv, (char *)&range_mark, 1);
2776 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2777 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2778 t = (U8*)SvPVX(transv);
2779 tlen = SvCUR(transv);
2783 else if (!rlen && !del) {
2784 r = t; rlen = tlen; rend = tend;
2787 if ((!rlen && !del) || t == r ||
2788 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2790 o->op_private |= OPpTRANS_IDENTICAL;
2794 while (t < tend || tfirst <= tlast) {
2795 /* see if we need more "t" chars */
2796 if (tfirst > tlast) {
2797 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2799 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2801 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2808 /* now see if we need more "r" chars */
2809 if (rfirst > rlast) {
2811 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2813 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2815 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2824 rfirst = rlast = 0xffffffff;
2828 /* now see which range will peter our first, if either. */
2829 tdiff = tlast - tfirst;
2830 rdiff = rlast - rfirst;
2837 if (rfirst == 0xffffffff) {
2838 diff = tdiff; /* oops, pretend rdiff is infinite */
2840 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2841 (long)tfirst, (long)tlast);
2843 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2847 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2848 (long)tfirst, (long)(tfirst + diff),
2851 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2852 (long)tfirst, (long)rfirst);
2854 if (rfirst + diff > max)
2855 max = rfirst + diff;
2857 grows = (tfirst < rfirst &&
2858 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2870 else if (max > 0xff)
2875 Safefree(cPVOPo->op_pv);
2876 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2877 SvREFCNT_dec(listsv);
2879 SvREFCNT_dec(transv);
2881 if (!del && havefinal && rlen)
2882 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2883 newSVuv((UV)final), 0);
2886 o->op_private |= OPpTRANS_GROWS;
2898 tbl = (short*)cPVOPo->op_pv;
2900 Zero(tbl, 256, short);
2901 for (i = 0; i < tlen; i++)
2903 for (i = 0, j = 0; i < 256; i++) {
2914 if (i < 128 && r[j] >= 128)
2924 o->op_private |= OPpTRANS_IDENTICAL;
2929 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2930 tbl[0x100] = rlen - j;
2931 for (i=0; i < rlen - j; i++)
2932 tbl[0x101+i] = r[j+i];
2936 if (!rlen && !del) {
2939 o->op_private |= OPpTRANS_IDENTICAL;
2941 for (i = 0; i < 256; i++)
2943 for (i = 0, j = 0; i < tlen; i++,j++) {
2946 if (tbl[t[i]] == -1)
2952 if (tbl[t[i]] == -1) {
2953 if (t[i] < 128 && r[j] >= 128)
2960 o->op_private |= OPpTRANS_GROWS;
2968 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2972 NewOp(1101, pmop, 1, PMOP);
2973 pmop->op_type = type;
2974 pmop->op_ppaddr = PL_ppaddr[type];
2975 pmop->op_flags = flags;
2976 pmop->op_private = 0 | (flags >> 8);
2978 if (PL_hints & HINT_RE_TAINT)
2979 pmop->op_pmpermflags |= PMf_RETAINT;
2980 if (PL_hints & HINT_LOCALE)
2981 pmop->op_pmpermflags |= PMf_LOCALE;
2982 pmop->op_pmflags = pmop->op_pmpermflags;
2987 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2988 repointer = av_pop((AV*)PL_regex_pad[0]);
2989 pmop->op_pmoffset = SvIV(repointer);
2990 SvREPADTMP_off(repointer);
2991 sv_setiv(repointer,0);
2993 repointer = newSViv(0);
2994 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2995 pmop->op_pmoffset = av_len(PL_regex_padav);
2996 PL_regex_pad = AvARRAY(PL_regex_padav);
3001 /* link into pm list */
3002 if (type != OP_TRANS && PL_curstash) {
3003 pmop->op_pmnext = HvPMROOT(PL_curstash);
3004 HvPMROOT(PL_curstash) = pmop;
3005 PmopSTASH_set(pmop,PL_curstash);
3012 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3016 I32 repl_has_vars = 0;
3018 if (o->op_type == OP_TRANS)
3019 return pmtrans(o, expr, repl);
3021 PL_hints |= HINT_BLOCK_SCOPE;
3024 if (expr->op_type == OP_CONST) {
3026 SV *pat = ((SVOP*)expr)->op_sv;
3027 char *p = SvPV(pat, plen);
3028 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3029 sv_setpvn(pat, "\\s+", 3);
3030 p = SvPV(pat, plen);
3031 pm->op_pmflags |= PMf_SKIPWHITE;
3033 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3034 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3035 pm->op_pmflags |= PMf_WHITE;
3039 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3040 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3042 : OP_REGCMAYBE),0,expr);
3044 NewOp(1101, rcop, 1, LOGOP);
3045 rcop->op_type = OP_REGCOMP;
3046 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3047 rcop->op_first = scalar(expr);
3048 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3049 ? (OPf_SPECIAL | OPf_KIDS)
3051 rcop->op_private = 1;
3054 /* establish postfix order */
3055 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3057 rcop->op_next = expr;
3058 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3061 rcop->op_next = LINKLIST(expr);
3062 expr->op_next = (OP*)rcop;
3065 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3070 if (pm->op_pmflags & PMf_EVAL) {
3072 if (CopLINE(PL_curcop) < PL_multi_end)
3073 CopLINE_set(PL_curcop, PL_multi_end);
3075 #ifdef USE_5005THREADS
3076 else if (repl->op_type == OP_THREADSV
3077 && strchr("&`'123456789+",
3078 PL_threadsv_names[repl->op_targ]))
3082 #endif /* USE_5005THREADS */
3083 else if (repl->op_type == OP_CONST)
3087 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3088 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3089 #ifdef USE_5005THREADS
3090 if (curop->op_type == OP_THREADSV) {
3092 if (strchr("&`'123456789+", curop->op_private))
3096 if (curop->op_type == OP_GV) {
3097 GV *gv = cGVOPx_gv(curop);
3099 if (strchr("&`'123456789+", *GvENAME(gv)))
3102 #endif /* USE_5005THREADS */
3103 else if (curop->op_type == OP_RV2CV)
3105 else if (curop->op_type == OP_RV2SV ||
3106 curop->op_type == OP_RV2AV ||
3107 curop->op_type == OP_RV2HV ||
3108 curop->op_type == OP_RV2GV) {
3109 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3112 else if (curop->op_type == OP_PADSV ||
3113 curop->op_type == OP_PADAV ||
3114 curop->op_type == OP_PADHV ||
3115 curop->op_type == OP_PADANY) {
3118 else if (curop->op_type == OP_PUSHRE)
3119 ; /* Okay here, dangerous in newASSIGNOP */
3129 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3130 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3131 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3132 prepend_elem(o->op_type, scalar(repl), o);
3135 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3136 pm->op_pmflags |= PMf_MAYBE_CONST;
3137 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3139 NewOp(1101, rcop, 1, LOGOP);
3140 rcop->op_type = OP_SUBSTCONT;
3141 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3142 rcop->op_first = scalar(repl);
3143 rcop->op_flags |= OPf_KIDS;
3144 rcop->op_private = 1;
3147 /* establish postfix order */
3148 rcop->op_next = LINKLIST(repl);
3149 repl->op_next = (OP*)rcop;
3151 pm->op_pmreplroot = scalar((OP*)rcop);
3152 pm->op_pmreplstart = LINKLIST(rcop);
3161 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3164 NewOp(1101, svop, 1, SVOP);
3165 svop->op_type = type;
3166 svop->op_ppaddr = PL_ppaddr[type];
3168 svop->op_next = (OP*)svop;
3169 svop->op_flags = flags;
3170 if (PL_opargs[type] & OA_RETSCALAR)
3172 if (PL_opargs[type] & OA_TARGET)
3173 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3174 return CHECKOP(type, svop);
3178 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3181 NewOp(1101, padop, 1, PADOP);
3182 padop->op_type = type;
3183 padop->op_ppaddr = PL_ppaddr[type];
3184 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3185 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3186 PL_curpad[padop->op_padix] = sv;
3188 padop->op_next = (OP*)padop;
3189 padop->op_flags = flags;
3190 if (PL_opargs[type] & OA_RETSCALAR)
3192 if (PL_opargs[type] & OA_TARGET)
3193 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3194 return CHECKOP(type, padop);
3198 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3202 return newPADOP(type, flags, SvREFCNT_inc(gv));
3204 return newSVOP(type, flags, SvREFCNT_inc(gv));
3209 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3212 NewOp(1101, pvop, 1, PVOP);
3213 pvop->op_type = type;
3214 pvop->op_ppaddr = PL_ppaddr[type];
3216 pvop->op_next = (OP*)pvop;
3217 pvop->op_flags = flags;
3218 if (PL_opargs[type] & OA_RETSCALAR)
3220 if (PL_opargs[type] & OA_TARGET)
3221 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3222 return CHECKOP(type, pvop);
3226 Perl_package(pTHX_ OP *o)
3230 save_hptr(&PL_curstash);
3231 save_item(PL_curstname);
3236 name = SvPV(sv, len);
3237 PL_curstash = gv_stashpvn(name,len,TRUE);
3238 sv_setpvn(PL_curstname, name, len);
3242 deprecate("\"package\" with no arguments");
3243 sv_setpv(PL_curstname,"<none>");
3244 PL_curstash = Nullhv;
3246 PL_hints |= HINT_BLOCK_SCOPE;
3247 PL_copline = NOLINE;
3252 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3257 char *packname = Nullch;
3261 if (id->op_type != OP_CONST)
3262 Perl_croak(aTHX_ "Module name must be constant");
3266 if (version != Nullop) {
3267 SV *vesv = ((SVOP*)version)->op_sv;
3269 if (arg == Nullop && !SvNIOKp(vesv)) {
3276 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3277 Perl_croak(aTHX_ "Version number must be constant number");
3279 /* Make copy of id so we don't free it twice */
3280 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3282 /* Fake up a method call to VERSION */
3283 meth = newSVpvn("VERSION",7);
3284 sv_upgrade(meth, SVt_PVIV);
3285 (void)SvIOK_on(meth);
3286 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3287 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3288 append_elem(OP_LIST,
3289 prepend_elem(OP_LIST, pack, list(version)),
3290 newSVOP(OP_METHOD_NAMED, 0, meth)));
3294 /* Fake up an import/unimport */
3295 if (arg && arg->op_type == OP_STUB)
3296 imop = arg; /* no import on explicit () */
3297 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3298 imop = Nullop; /* use 5.0; */
3303 /* Make copy of id so we don't free it twice */
3304 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3306 /* Fake up a method call to import/unimport */
3307 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3308 sv_upgrade(meth, SVt_PVIV);
3309 (void)SvIOK_on(meth);
3310 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3311 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3312 append_elem(OP_LIST,
3313 prepend_elem(OP_LIST, pack, list(arg)),
3314 newSVOP(OP_METHOD_NAMED, 0, meth)));
3317 if (ckWARN(WARN_MISC) &&
3318 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3319 SvPOK(packsv = ((SVOP*)id)->op_sv))
3321 /* BEGIN will free the ops, so we need to make a copy */
3322 packlen = SvCUR(packsv);
3323 packname = savepvn(SvPVX(packsv), packlen);
3326 /* Fake up the BEGIN {}, which does its thing immediately. */
3328 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3331 append_elem(OP_LINESEQ,
3332 append_elem(OP_LINESEQ,
3333 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3334 newSTATEOP(0, Nullch, veop)),
3335 newSTATEOP(0, Nullch, imop) ));
3338 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3339 Perl_warner(aTHX_ WARN_MISC,
3340 "Package `%s' not found "
3341 "(did you use the incorrect case?)", packname);
3346 PL_hints |= HINT_BLOCK_SCOPE;
3347 PL_copline = NOLINE;
3352 =for apidoc load_module
3354 Loads the module whose name is pointed to by the string part of name.
3355 Note that the actual module name, not its filename, should be given.
3356 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3357 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3358 (or 0 for no flags). ver, if specified, provides version semantics
3359 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3360 arguments can be used to specify arguments to the module's import()
3361 method, similar to C<use Foo::Bar VERSION LIST>.
3366 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3369 va_start(args, ver);
3370 vload_module(flags, name, ver, &args);
3374 #ifdef PERL_IMPLICIT_CONTEXT
3376 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3380 va_start(args, ver);
3381 vload_module(flags, name, ver, &args);
3387 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3389 OP *modname, *veop, *imop;
3391 modname = newSVOP(OP_CONST, 0, name);
3392 modname->op_private |= OPpCONST_BARE;
3394 veop = newSVOP(OP_CONST, 0, ver);
3398 if (flags & PERL_LOADMOD_NOIMPORT) {
3399 imop = sawparens(newNULLLIST());
3401 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3402 imop = va_arg(*args, OP*);
3407 sv = va_arg(*args, SV*);
3409 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3410 sv = va_arg(*args, SV*);
3414 line_t ocopline = PL_copline;
3415 int oexpect = PL_expect;
3417 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3418 veop, modname, imop);
3419 PL_expect = oexpect;
3420 PL_copline = ocopline;
3425 Perl_dofile(pTHX_ OP *term)
3430 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3431 if (!(gv && GvIMPORTED_CV(gv)))
3432 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3434 if (gv && GvIMPORTED_CV(gv)) {
3435 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3436 append_elem(OP_LIST, term,
3437 scalar(newUNOP(OP_RV2CV, 0,
3442 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3448 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3450 return newBINOP(OP_LSLICE, flags,
3451 list(force_list(subscript)),
3452 list(force_list(listval)) );
3456 S_list_assignment(pTHX_ register OP *o)
3461 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3462 o = cUNOPo->op_first;
3464 if (o->op_type == OP_COND_EXPR) {
3465 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3466 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3471 yyerror("Assignment to both a list and a scalar");
3475 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3476 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3477 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3480 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3483 if (o->op_type == OP_RV2SV)
3490 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3495 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3496 return newLOGOP(optype, 0,
3497 mod(scalar(left), optype),
3498 newUNOP(OP_SASSIGN, 0, scalar(right)));
3501 return newBINOP(optype, OPf_STACKED,
3502 mod(scalar(left), optype), scalar(right));
3506 if (list_assignment(left)) {
3510 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3511 left = mod(left, OP_AASSIGN);
3519 curop = list(force_list(left));
3520 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3521 o->op_private = 0 | (flags >> 8);
3522 for (curop = ((LISTOP*)curop)->op_first;
3523 curop; curop = curop->op_sibling)
3525 if (curop->op_type == OP_RV2HV &&
3526 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3527 o->op_private |= OPpASSIGN_HASH;
3531 if (!(left->op_private & OPpLVAL_INTRO)) {
3534 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3535 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3536 if (curop->op_type == OP_GV) {
3537 GV *gv = cGVOPx_gv(curop);
3538 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3540 SvCUR(gv) = PL_generation;
3542 else if (curop->op_type == OP_PADSV ||
3543 curop->op_type == OP_PADAV ||
3544 curop->op_type == OP_PADHV ||
3545 curop->op_type == OP_PADANY) {
3546 SV **svp = AvARRAY(PL_comppad_name);
3547 SV *sv = svp[curop->op_targ];
3548 if (SvCUR(sv) == PL_generation)
3550 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3552 else if (curop->op_type == OP_RV2CV)
3554 else if (curop->op_type == OP_RV2SV ||
3555 curop->op_type == OP_RV2AV ||
3556 curop->op_type == OP_RV2HV ||
3557 curop->op_type == OP_RV2GV) {
3558 if (lastop->op_type != OP_GV) /* funny deref? */
3561 else if (curop->op_type == OP_PUSHRE) {
3562 if (((PMOP*)curop)->op_pmreplroot) {
3564 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3566 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3568 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3570 SvCUR(gv) = PL_generation;
3579 o->op_private |= OPpASSIGN_COMMON;
3581 if (right && right->op_type == OP_SPLIT) {
3583 if ((tmpop = ((LISTOP*)right)->op_first) &&
3584 tmpop->op_type == OP_PUSHRE)
3586 PMOP *pm = (PMOP*)tmpop;
3587 if (left->op_type == OP_RV2AV &&
3588 !(left->op_private & OPpLVAL_INTRO) &&
3589 !(o->op_private & OPpASSIGN_COMMON) )
3591 tmpop = ((UNOP*)left)->op_first;
3592 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3594 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3595 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3597 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3598 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3600 pm->op_pmflags |= PMf_ONCE;
3601 tmpop = cUNOPo->op_first; /* to list (nulled) */
3602 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3603 tmpop->op_sibling = Nullop; /* don't free split */
3604 right->op_next = tmpop->op_next; /* fix starting loc */
3605 op_free(o); /* blow off assign */
3606 right->op_flags &= ~OPf_WANT;
3607 /* "I don't know and I don't care." */
3612 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3613 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3615 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3617 sv_setiv(sv, PL_modcount+1);
3625 right = newOP(OP_UNDEF, 0);
3626 if (right->op_type == OP_READLINE) {
3627 right->op_flags |= OPf_STACKED;
3628 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3631 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3632 o = newBINOP(OP_SASSIGN, flags,
3633 scalar(right), mod(scalar(left), OP_SASSIGN) );
3645 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3647 U32 seq = intro_my();
3650 NewOp(1101, cop, 1, COP);
3651 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3652 cop->op_type = OP_DBSTATE;
3653 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3656 cop->op_type = OP_NEXTSTATE;
3657 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3659 cop->op_flags = flags;
3660 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3662 cop->op_private |= NATIVE_HINTS;
3664 PL_compiling.op_private = cop->op_private;
3665 cop->op_next = (OP*)cop;
3668 cop->cop_label = label;
3669 PL_hints |= HINT_BLOCK_SCOPE;
3672 cop->cop_arybase = PL_curcop->cop_arybase;
3673 if (specialWARN(PL_curcop->cop_warnings))
3674 cop->cop_warnings = PL_curcop->cop_warnings ;
3676 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3677 if (specialCopIO(PL_curcop->cop_io))
3678 cop->cop_io = PL_curcop->cop_io;
3680 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3683 if (PL_copline == NOLINE)
3684 CopLINE_set(cop, CopLINE(PL_curcop));
3686 CopLINE_set(cop, PL_copline);
3687 PL_copline = NOLINE;
3690 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3692 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3694 CopSTASH_set(cop, PL_curstash);
3696 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3697 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3698 if (svp && *svp != &PL_sv_undef ) {
3699 (void)SvIOK_on(*svp);
3700 SvIVX(*svp) = PTR2IV(cop);
3704 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3707 /* "Introduce" my variables to visible status. */
3715 if (! PL_min_intro_pending)
3716 return PL_cop_seqmax;
3718 svp = AvARRAY(PL_comppad_name);
3719 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3720 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3721 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3722 SvNVX(sv) = (NV)PL_cop_seqmax;
3725 PL_min_intro_pending = 0;
3726 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3727 return PL_cop_seqmax++;
3731 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3733 return new_logop(type, flags, &first, &other);
3737 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3741 OP *first = *firstp;
3742 OP *other = *otherp;
3744 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3745 return newBINOP(type, flags, scalar(first), scalar(other));
3747 scalarboolean(first);
3748 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3749 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3750 if (type == OP_AND || type == OP_OR) {
3756 first = *firstp = cUNOPo->op_first;
3758 first->op_next = o->op_next;
3759 cUNOPo->op_first = Nullop;
3763 if (first->op_type == OP_CONST) {
3764 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3765 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3766 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3777 else if (first->op_type == OP_WANTARRAY) {
3783 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3784 OP *k1 = ((UNOP*)first)->op_first;
3785 OP *k2 = k1->op_sibling;
3787 switch (first->op_type)
3790 if (k2 && k2->op_type == OP_READLINE
3791 && (k2->op_flags & OPf_STACKED)
3792 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3794 warnop = k2->op_type;
3799 if (k1->op_type == OP_READDIR
3800 || k1->op_type == OP_GLOB
3801 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3802 || k1->op_type == OP_EACH)
3804 warnop = ((k1->op_type == OP_NULL)
3805 ? k1->op_targ : k1->op_type);
3810 line_t oldline = CopLINE(PL_curcop);
3811 CopLINE_set(PL_curcop, PL_copline);
3812 Perl_warner(aTHX_ WARN_MISC,
3813 "Value of %s%s can be \"0\"; test with defined()",
3815 ((warnop == OP_READLINE || warnop == OP_GLOB)
3816 ? " construct" : "() operator"));
3817 CopLINE_set(PL_curcop, oldline);
3824 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3825 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3827 NewOp(1101, logop, 1, LOGOP);
3829 logop->op_type = type;
3830 logop->op_ppaddr = PL_ppaddr[type];
3831 logop->op_first = first;
3832 logop->op_flags = flags | OPf_KIDS;
3833 logop->op_other = LINKLIST(other);
3834 logop->op_private = 1 | (flags >> 8);
3836 /* establish postfix order */
3837 logop->op_next = LINKLIST(first);
3838 first->op_next = (OP*)logop;
3839 first->op_sibling = other;
3841 o = newUNOP(OP_NULL, 0, (OP*)logop);
3848 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3855 return newLOGOP(OP_AND, 0, first, trueop);
3857 return newLOGOP(OP_OR, 0, first, falseop);
3859 scalarboolean(first);
3860 if (first->op_type == OP_CONST) {
3861 if (SvTRUE(((SVOP*)first)->op_sv)) {
3872 else if (first->op_type == OP_WANTARRAY) {
3876 NewOp(1101, logop, 1, LOGOP);
3877 logop->op_type = OP_COND_EXPR;
3878 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3879 logop->op_first = first;
3880 logop->op_flags = flags | OPf_KIDS;
3881 logop->op_private = 1 | (flags >> 8);
3882 logop->op_other = LINKLIST(trueop);
3883 logop->op_next = LINKLIST(falseop);
3886 /* establish postfix order */
3887 start = LINKLIST(first);
3888 first->op_next = (OP*)logop;
3890 first->op_sibling = trueop;
3891 trueop->op_sibling = falseop;
3892 o = newUNOP(OP_NULL, 0, (OP*)logop);
3894 trueop->op_next = falseop->op_next = o;
3901 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3909 NewOp(1101, range, 1, LOGOP);
3911 range->op_type = OP_RANGE;
3912 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3913 range->op_first = left;
3914 range->op_flags = OPf_KIDS;
3915 leftstart = LINKLIST(left);
3916 range->op_other = LINKLIST(right);
3917 range->op_private = 1 | (flags >> 8);
3919 left->op_sibling = right;
3921 range->op_next = (OP*)range;
3922 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3923 flop = newUNOP(OP_FLOP, 0, flip);
3924 o = newUNOP(OP_NULL, 0, flop);
3926 range->op_next = leftstart;
3928 left->op_next = flip;
3929 right->op_next = flop;
3931 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3932 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3933 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3934 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3936 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3937 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3940 if (!flip->op_private || !flop->op_private)
3941 linklist(o); /* blow off optimizer unless constant */
3947 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3951 int once = block && block->op_flags & OPf_SPECIAL &&
3952 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3955 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3956 return block; /* do {} while 0 does once */
3957 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3958 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3959 expr = newUNOP(OP_DEFINED, 0,
3960 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3961 } else if (expr->op_flags & OPf_KIDS) {
3962 OP *k1 = ((UNOP*)expr)->op_first;
3963 OP *k2 = (k1) ? k1->op_sibling : NULL;
3964 switch (expr->op_type) {
3966 if (k2 && k2->op_type == OP_READLINE
3967 && (k2->op_flags & OPf_STACKED)
3968 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3969 expr = newUNOP(OP_DEFINED, 0, expr);
3973 if (k1->op_type == OP_READDIR
3974 || k1->op_type == OP_GLOB
3975 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3976 || k1->op_type == OP_EACH)
3977 expr = newUNOP(OP_DEFINED, 0, expr);
3983 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3984 o = new_logop(OP_AND, 0, &expr, &listop);
3987 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3989 if (once && o != listop)
3990 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3993 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3995 o->op_flags |= flags;
3997 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4002 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4010 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4011 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4012 expr = newUNOP(OP_DEFINED, 0,
4013 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4014 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4015 OP *k1 = ((UNOP*)expr)->op_first;
4016 OP *k2 = (k1) ? k1->op_sibling : NULL;
4017 switch (expr->op_type) {
4019 if (k2 && k2->op_type == OP_READLINE
4020 && (k2->op_flags & OPf_STACKED)
4021 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4022 expr = newUNOP(OP_DEFINED, 0, expr);
4026 if (k1->op_type == OP_READDIR
4027 || k1->op_type == OP_GLOB
4028 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4029 || k1->op_type == OP_EACH)
4030 expr = newUNOP(OP_DEFINED, 0, expr);
4036 block = newOP(OP_NULL, 0);
4038 block = scope(block);
4042 next = LINKLIST(cont);
4045 OP *unstack = newOP(OP_UNSTACK, 0);
4048 cont = append_elem(OP_LINESEQ, cont, unstack);
4049 if ((line_t)whileline != NOLINE) {
4050 PL_copline = whileline;
4051 cont = append_elem(OP_LINESEQ, cont,
4052 newSTATEOP(0, Nullch, Nullop));
4056 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4057 redo = LINKLIST(listop);
4060 PL_copline = whileline;
4062 o = new_logop(OP_AND, 0, &expr, &listop);
4063 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4064 op_free(expr); /* oops, it's a while (0) */
4066 return Nullop; /* listop already freed by new_logop */
4069 ((LISTOP*)listop)->op_last->op_next =
4070 (o == listop ? redo : LINKLIST(o));
4076 NewOp(1101,loop,1,LOOP);
4077 loop->op_type = OP_ENTERLOOP;
4078 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4079 loop->op_private = 0;
4080 loop->op_next = (OP*)loop;
4083 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4085 loop->op_redoop = redo;
4086 loop->op_lastop = o;
4087 o->op_private |= loopflags;
4090 loop->op_nextop = next;
4092 loop->op_nextop = o;
4094 o->op_flags |= flags;
4095 o->op_private |= (flags >> 8);
4100 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4108 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4109 sv->op_type = OP_RV2GV;
4110 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4112 else if (sv->op_type == OP_PADSV) { /* private variable */
4113 padoff = sv->op_targ;
4118 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4119 padoff = sv->op_targ;
4121 iterflags |= OPf_SPECIAL;
4126 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4129 #ifdef USE_5005THREADS
4130 padoff = find_threadsv("_");
4131 iterflags |= OPf_SPECIAL;
4133 sv = newGVOP(OP_GV, 0, PL_defgv);
4136 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4137 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4138 iterflags |= OPf_STACKED;
4140 else if (expr->op_type == OP_NULL &&
4141 (expr->op_flags & OPf_KIDS) &&
4142 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4144 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4145 * set the STACKED flag to indicate that these values are to be
4146 * treated as min/max values by 'pp_iterinit'.
4148 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4149 LOGOP* range = (LOGOP*) flip->op_first;
4150 OP* left = range->op_first;
4151 OP* right = left->op_sibling;
4154 range->op_flags &= ~OPf_KIDS;
4155 range->op_first = Nullop;
4157 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4158 listop->op_first->op_next = range->op_next;
4159 left->op_next = range->op_other;
4160 right->op_next = (OP*)listop;
4161 listop->op_next = listop->op_first;
4164 expr = (OP*)(listop);
4166 iterflags |= OPf_STACKED;
4169 expr = mod(force_list(expr), OP_GREPSTART);
4173 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4174 append_elem(OP_LIST, expr, scalar(sv))));
4175 assert(!loop->op_next);
4176 #ifdef PL_OP_SLAB_ALLOC
4179 NewOp(1234,tmp,1,LOOP);
4180 Copy(loop,tmp,1,LOOP);
4184 Renew(loop, 1, LOOP);
4186 loop->op_targ = padoff;
4187 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4188 PL_copline = forline;
4189 return newSTATEOP(0, label, wop);
4193 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4198 if (type != OP_GOTO || label->op_type == OP_CONST) {
4199 /* "last()" means "last" */
4200 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4201 o = newOP(type, OPf_SPECIAL);
4203 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4204 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4210 if (label->op_type == OP_ENTERSUB)
4211 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4212 o = newUNOP(type, OPf_STACKED, label);
4214 PL_hints |= HINT_BLOCK_SCOPE;
4219 Perl_cv_undef(pTHX_ CV *cv)
4221 #ifdef USE_5005THREADS
4223 MUTEX_DESTROY(CvMUTEXP(cv));
4224 Safefree(CvMUTEXP(cv));
4227 #endif /* USE_5005THREADS */
4230 if (CvFILE(cv) && !CvXSUB(cv)) {
4231 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4232 Safefree(CvFILE(cv));
4237 if (!CvXSUB(cv) && CvROOT(cv)) {
4238 #ifdef USE_5005THREADS
4239 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4240 Perl_croak(aTHX_ "Can't undef active subroutine");
4243 Perl_croak(aTHX_ "Can't undef active subroutine");
4244 #endif /* USE_5005THREADS */
4247 SAVEVPTR(PL_curpad);
4250 op_free(CvROOT(cv));
4251 CvROOT(cv) = Nullop;
4254 SvPOK_off((SV*)cv); /* forget prototype */
4256 /* Since closure prototypes have the same lifetime as the containing
4257 * CV, they don't hold a refcount on the outside CV. This avoids
4258 * the refcount loop between the outer CV (which keeps a refcount to
4259 * the closure prototype in the pad entry for pp_anoncode()) and the
4260 * closure prototype, and the ensuing memory leak. --GSAR */
4261 if (!CvANON(cv) || CvCLONED(cv))
4262 SvREFCNT_dec(CvOUTSIDE(cv));
4263 CvOUTSIDE(cv) = Nullcv;
4265 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4268 if (CvPADLIST(cv)) {
4269 /* may be during global destruction */
4270 if (SvREFCNT(CvPADLIST(cv))) {
4271 I32 i = AvFILLp(CvPADLIST(cv));
4273 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4274 SV* sv = svp ? *svp : Nullsv;
4277 if (sv == (SV*)PL_comppad_name)
4278 PL_comppad_name = Nullav;
4279 else if (sv == (SV*)PL_comppad) {
4280 PL_comppad = Nullav;
4281 PL_curpad = Null(SV**);
4285 SvREFCNT_dec((SV*)CvPADLIST(cv));
4287 CvPADLIST(cv) = Nullav;
4295 #ifdef DEBUG_CLOSURES
4297 S_cv_dump(pTHX_ CV *cv)
4300 CV *outside = CvOUTSIDE(cv);
4301 AV* padlist = CvPADLIST(cv);
4308 PerlIO_printf(Perl_debug_log,
4309 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4311 (CvANON(cv) ? "ANON"
4312 : (cv == PL_main_cv) ? "MAIN"
4313 : CvUNIQUE(cv) ? "UNIQUE"
4314 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4317 : CvANON(outside) ? "ANON"
4318 : (outside == PL_main_cv) ? "MAIN"
4319 : CvUNIQUE(outside) ? "UNIQUE"
4320 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4325 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4326 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4327 pname = AvARRAY(pad_name);
4328 ppad = AvARRAY(pad);
4330 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4331 if (SvPOK(pname[ix]))
4332 PerlIO_printf(Perl_debug_log,
4333 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4334 (int)ix, PTR2UV(ppad[ix]),
4335 SvFAKE(pname[ix]) ? "FAKE " : "",
4337 (IV)I_32(SvNVX(pname[ix])),
4340 #endif /* DEBUGGING */
4342 #endif /* DEBUG_CLOSURES */
4345 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4349 AV* protopadlist = CvPADLIST(proto);
4350 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4351 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4352 SV** pname = AvARRAY(protopad_name);
4353 SV** ppad = AvARRAY(protopad);
4354 I32 fname = AvFILLp(protopad_name);
4355 I32 fpad = AvFILLp(protopad);
4359 assert(!CvUNIQUE(proto));
4363 SAVESPTR(PL_comppad_name);
4364 SAVESPTR(PL_compcv);
4366 cv = PL_compcv = (CV*)NEWSV(1104,0);
4367 sv_upgrade((SV *)cv, SvTYPE(proto));
4368 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4371 #ifdef USE_5005THREADS
4372 New(666, CvMUTEXP(cv), 1, perl_mutex);
4373 MUTEX_INIT(CvMUTEXP(cv));
4375 #endif /* USE_5005THREADS */
4377 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4378 : savepv(CvFILE(proto));
4380 CvFILE(cv) = CvFILE(proto);
4382 CvGV(cv) = CvGV(proto);
4383 CvSTASH(cv) = CvSTASH(proto);
4384 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4385 CvSTART(cv) = CvSTART(proto);
4387 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4390 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4392 PL_comppad_name = newAV();
4393 for (ix = fname; ix >= 0; ix--)
4394 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4396 PL_comppad = newAV();
4398 comppadlist = newAV();
4399 AvREAL_off(comppadlist);
4400 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4401 av_store(comppadlist, 1, (SV*)PL_comppad);
4402 CvPADLIST(cv) = comppadlist;
4403 av_fill(PL_comppad, AvFILLp(protopad));
4404 PL_curpad = AvARRAY(PL_comppad);
4406 av = newAV(); /* will be @_ */
4408 av_store(PL_comppad, 0, (SV*)av);
4409 AvFLAGS(av) = AVf_REIFY;
4411 for (ix = fpad; ix > 0; ix--) {
4412 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4413 if (namesv && namesv != &PL_sv_undef) {
4414 char *name = SvPVX(namesv); /* XXX */
4415 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4416 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4417 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4419 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4421 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4423 else { /* our own lexical */
4426 /* anon code -- we'll come back for it */
4427 sv = SvREFCNT_inc(ppad[ix]);
4429 else if (*name == '@')
4431 else if (*name == '%')
4440 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4441 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4444 SV* sv = NEWSV(0,0);
4450 /* Now that vars are all in place, clone nested closures. */
4452 for (ix = fpad; ix > 0; ix--) {
4453 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4455 && namesv != &PL_sv_undef
4456 && !(SvFLAGS(namesv) & SVf_FAKE)
4457 && *SvPVX(namesv) == '&'
4458 && CvCLONE(ppad[ix]))
4460 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4461 SvREFCNT_dec(ppad[ix]);
4464 PL_curpad[ix] = (SV*)kid;
4468 #ifdef DEBUG_CLOSURES
4469 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4471 PerlIO_printf(Perl_debug_log, " from:\n");
4473 PerlIO_printf(Perl_debug_log, " to:\n");
4480 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4482 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4484 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4491 Perl_cv_clone(pTHX_ CV *proto)
4494 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4495 cv = cv_clone2(proto, CvOUTSIDE(proto));
4496 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4501 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4503 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4504 SV* msg = sv_newmortal();
4508 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4509 sv_setpv(msg, "Prototype mismatch:");
4511 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4513 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4514 sv_catpv(msg, " vs ");
4516 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4518 sv_catpv(msg, "none");
4519 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4523 static void const_sv_xsub(pTHX_ CV* cv);
4526 =for apidoc cv_const_sv
4528 If C<cv> is a constant sub eligible for inlining. returns the constant
4529 value returned by the sub. Otherwise, returns NULL.
4531 Constant subs can be created with C<newCONSTSUB> or as described in
4532 L<perlsub/"Constant Functions">.
4537 Perl_cv_const_sv(pTHX_ CV *cv)
4539 if (!cv || !CvCONST(cv))
4541 return (SV*)CvXSUBANY(cv).any_ptr;
4545 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4552 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4553 o = cLISTOPo->op_first->op_sibling;
4555 for (; o; o = o->op_next) {
4556 OPCODE type = o->op_type;
4558 if (sv && o->op_next == o)
4560 if (o->op_next != o) {
4561 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4563 if (type == OP_DBSTATE)
4566 if (type == OP_LEAVESUB || type == OP_RETURN)
4570 if (type == OP_CONST && cSVOPo->op_sv)
4572 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4573 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4574 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4578 /* We get here only from cv_clone2() while creating a closure.
4579 Copy the const value here instead of in cv_clone2 so that
4580 SvREADONLY_on doesn't lead to problems when leaving
4585 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4597 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4607 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4611 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4613 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4617 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4623 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4628 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4629 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4630 SV *sv = sv_newmortal();
4631 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4632 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4637 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4638 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4648 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4649 maximum a prototype before. */
4650 if (SvTYPE(gv) > SVt_NULL) {
4651 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4652 && ckWARN_d(WARN_PROTOTYPE))
4654 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4656 cv_ckproto((CV*)gv, NULL, ps);
4659 sv_setpv((SV*)gv, ps);
4661 sv_setiv((SV*)gv, -1);
4662 SvREFCNT_dec(PL_compcv);
4663 cv = PL_compcv = NULL;
4664 PL_sub_generation++;
4668 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4670 #ifdef GV_UNIQUE_CHECK
4671 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4672 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4676 if (!block || !ps || *ps || attrs)
4679 const_sv = op_const_sv(block, Nullcv);
4682 bool exists = CvROOT(cv) || CvXSUB(cv);
4684 #ifdef GV_UNIQUE_CHECK
4685 if (exists && GvUNIQUE(gv)) {
4686 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4690 /* if the subroutine doesn't exist and wasn't pre-declared
4691 * with a prototype, assume it will be AUTOLOADed,
4692 * skipping the prototype check
4694 if (exists || SvPOK(cv))
4695 cv_ckproto(cv, gv, ps);
4696 /* already defined (or promised)? */
4697 if (exists || GvASSUMECV(gv)) {
4698 if (!block && !attrs) {
4699 /* just a "sub foo;" when &foo is already defined */
4700 SAVEFREESV(PL_compcv);
4703 /* ahem, death to those who redefine active sort subs */
4704 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4705 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4707 if (ckWARN(WARN_REDEFINE)
4709 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4711 line_t oldline = CopLINE(PL_curcop);
4712 if (PL_copline != NOLINE)
4713 CopLINE_set(PL_curcop, PL_copline);
4714 Perl_warner(aTHX_ WARN_REDEFINE,
4715 CvCONST(cv) ? "Constant subroutine %s redefined"
4716 : "Subroutine %s redefined", name);
4717 CopLINE_set(PL_curcop, oldline);
4725 SvREFCNT_inc(const_sv);
4727 assert(!CvROOT(cv) && !CvCONST(cv));
4728 sv_setpv((SV*)cv, ""); /* prototype is "" */
4729 CvXSUBANY(cv).any_ptr = const_sv;
4730 CvXSUB(cv) = const_sv_xsub;
4735 cv = newCONSTSUB(NULL, name, const_sv);
4738 SvREFCNT_dec(PL_compcv);
4740 PL_sub_generation++;
4747 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4748 * before we clobber PL_compcv.
4752 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4753 stash = GvSTASH(CvGV(cv));
4754 else if (CvSTASH(cv))
4755 stash = CvSTASH(cv);
4757 stash = PL_curstash;
4760 /* possibly about to re-define existing subr -- ignore old cv */
4761 rcv = (SV*)PL_compcv;
4762 if (name && GvSTASH(gv))
4763 stash = GvSTASH(gv);
4765 stash = PL_curstash;
4767 apply_attrs(stash, rcv, attrs);
4769 if (cv) { /* must reuse cv if autoloaded */
4771 /* got here with just attrs -- work done, so bug out */
4772 SAVEFREESV(PL_compcv);
4776 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4777 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4778 CvOUTSIDE(PL_compcv) = 0;
4779 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4780 CvPADLIST(PL_compcv) = 0;
4781 /* inner references to PL_compcv must be fixed up ... */
4783 AV *padlist = CvPADLIST(cv);
4784 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4785 AV *comppad = (AV*)AvARRAY(padlist)[1];
4786 SV **namepad = AvARRAY(comppad_name);
4787 SV **curpad = AvARRAY(comppad);
4788 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4789 SV *namesv = namepad[ix];
4790 if (namesv && namesv != &PL_sv_undef
4791 && *SvPVX(namesv) == '&')
4793 CV *innercv = (CV*)curpad[ix];
4794 if (CvOUTSIDE(innercv) == PL_compcv) {
4795 CvOUTSIDE(innercv) = cv;
4796 if (!CvANON(innercv) || CvCLONED(innercv)) {
4797 (void)SvREFCNT_inc(cv);
4798 SvREFCNT_dec(PL_compcv);
4804 /* ... before we throw it away */
4805 SvREFCNT_dec(PL_compcv);
4806 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4807 ++PL_sub_generation;
4814 PL_sub_generation++;
4818 CvFILE_set_from_cop(cv, PL_curcop);
4819 CvSTASH(cv) = PL_curstash;
4820 #ifdef USE_5005THREADS
4822 if (!CvMUTEXP(cv)) {
4823 New(666, CvMUTEXP(cv), 1, perl_mutex);
4824 MUTEX_INIT(CvMUTEXP(cv));
4826 #endif /* USE_5005THREADS */
4829 sv_setpv((SV*)cv, ps);
4831 if (PL_error_count) {
4835 char *s = strrchr(name, ':');
4837 if (strEQ(s, "BEGIN")) {
4839 "BEGIN not safe after errors--compilation aborted";
4840 if (PL_in_eval & EVAL_KEEPERR)
4841 Perl_croak(aTHX_ not_safe);
4843 /* force display of errors found but not reported */
4844 sv_catpv(ERRSV, not_safe);
4845 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4853 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4854 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4857 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4858 mod(scalarseq(block), OP_LEAVESUBLV));
4861 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4863 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4864 OpREFCNT_set(CvROOT(cv), 1);
4865 CvSTART(cv) = LINKLIST(CvROOT(cv));
4866 CvROOT(cv)->op_next = 0;
4867 CALL_PEEP(CvSTART(cv));
4869 /* now that optimizer has done its work, adjust pad values */
4871 SV **namep = AvARRAY(PL_comppad_name);
4872 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4875 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4878 * The only things that a clonable function needs in its
4879 * pad are references to outer lexicals and anonymous subs.
4880 * The rest are created anew during cloning.
4882 if (!((namesv = namep[ix]) != Nullsv &&
4883 namesv != &PL_sv_undef &&
4885 *SvPVX(namesv) == '&')))
4887 SvREFCNT_dec(PL_curpad[ix]);
4888 PL_curpad[ix] = Nullsv;
4891 assert(!CvCONST(cv));
4892 if (ps && !*ps && op_const_sv(block, cv))
4896 AV *av = newAV(); /* Will be @_ */
4898 av_store(PL_comppad, 0, (SV*)av);
4899 AvFLAGS(av) = AVf_REIFY;
4901 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4902 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4904 if (!SvPADMY(PL_curpad[ix]))
4905 SvPADTMP_on(PL_curpad[ix]);
4909 /* If a potential closure prototype, don't keep a refcount on outer CV.
4910 * This is okay as the lifetime of the prototype is tied to the
4911 * lifetime of the outer CV. Avoids memory leak due to reference
4914 SvREFCNT_dec(CvOUTSIDE(cv));
4916 if (name || aname) {
4918 char *tname = (name ? name : aname);
4920 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4921 SV *sv = NEWSV(0,0);
4922 SV *tmpstr = sv_newmortal();
4923 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4927 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4929 (long)PL_subline, (long)CopLINE(PL_curcop));
4930 gv_efullname3(tmpstr, gv, Nullch);
4931 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4932 hv = GvHVn(db_postponed);
4933 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4934 && (pcv = GvCV(db_postponed)))
4940 call_sv((SV*)pcv, G_DISCARD);
4944 if ((s = strrchr(tname,':')))
4949 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4952 if (strEQ(s, "BEGIN")) {
4953 I32 oldscope = PL_scopestack_ix;
4955 SAVECOPFILE(&PL_compiling);
4956 SAVECOPLINE(&PL_compiling);
4959 PL_beginav = newAV();
4960 DEBUG_x( dump_sub(gv) );
4961 av_push(PL_beginav, (SV*)cv);
4962 GvCV(gv) = 0; /* cv has been hijacked */
4963 call_list(oldscope, PL_beginav);
4965 PL_curcop = &PL_compiling;
4966 PL_compiling.op_private = PL_hints;
4969 else if (strEQ(s, "END") && !PL_error_count) {
4972 DEBUG_x( dump_sub(gv) );
4973 av_unshift(PL_endav, 1);
4974 av_store(PL_endav, 0, (SV*)cv);
4975 GvCV(gv) = 0; /* cv has been hijacked */
4977 else if (strEQ(s, "CHECK") && !PL_error_count) {
4979 PL_checkav = newAV();
4980 DEBUG_x( dump_sub(gv) );
4981 if (PL_main_start && ckWARN(WARN_VOID))
4982 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4983 av_unshift(PL_checkav, 1);
4984 av_store(PL_checkav, 0, (SV*)cv);
4985 GvCV(gv) = 0; /* cv has been hijacked */
4987 else if (strEQ(s, "INIT") && !PL_error_count) {
4989 PL_initav = newAV();
4990 DEBUG_x( dump_sub(gv) );
4991 if (PL_main_start && ckWARN(WARN_VOID))
4992 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4993 av_push(PL_initav, (SV*)cv);
4994 GvCV(gv) = 0; /* cv has been hijacked */
4999 PL_copline = NOLINE;
5004 /* XXX unsafe for threads if eval_owner isn't held */
5006 =for apidoc newCONSTSUB
5008 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5009 eligible for inlining at compile-time.
5015 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5021 SAVECOPLINE(PL_curcop);
5022 CopLINE_set(PL_curcop, PL_copline);
5025 PL_hints &= ~HINT_BLOCK_SCOPE;
5028 SAVESPTR(PL_curstash);
5029 SAVECOPSTASH(PL_curcop);
5030 PL_curstash = stash;
5032 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5034 CopSTASH(PL_curcop) = stash;
5038 cv = newXS(name, const_sv_xsub, __FILE__);
5039 CvXSUBANY(cv).any_ptr = sv;
5041 sv_setpv((SV*)cv, ""); /* prototype is "" */
5049 =for apidoc U||newXS
5051 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5057 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5059 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5062 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5064 /* just a cached method */
5068 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5069 /* already defined (or promised) */
5070 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5071 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5072 line_t oldline = CopLINE(PL_curcop);
5073 if (PL_copline != NOLINE)
5074 CopLINE_set(PL_curcop, PL_copline);
5075 Perl_warner(aTHX_ WARN_REDEFINE,
5076 CvCONST(cv) ? "Constant subroutine %s redefined"
5077 : "Subroutine %s redefined"
5079 CopLINE_set(PL_curcop, oldline);
5086 if (cv) /* must reuse cv if autoloaded */
5089 cv = (CV*)NEWSV(1105,0);
5090 sv_upgrade((SV *)cv, SVt_PVCV);
5094 PL_sub_generation++;
5098 #ifdef USE_5005THREADS
5099 New(666, CvMUTEXP(cv), 1, perl_mutex);
5100 MUTEX_INIT(CvMUTEXP(cv));
5102 #endif /* USE_5005THREADS */
5103 (void)gv_fetchfile(filename);
5104 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5105 an external constant string */
5106 CvXSUB(cv) = subaddr;
5109 char *s = strrchr(name,':');
5115 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5118 if (strEQ(s, "BEGIN")) {
5120 PL_beginav = newAV();
5121 av_push(PL_beginav, (SV*)cv);
5122 GvCV(gv) = 0; /* cv has been hijacked */
5124 else if (strEQ(s, "END")) {
5127 av_unshift(PL_endav, 1);
5128 av_store(PL_endav, 0, (SV*)cv);
5129 GvCV(gv) = 0; /* cv has been hijacked */
5131 else if (strEQ(s, "CHECK")) {
5133 PL_checkav = newAV();
5134 if (PL_main_start && ckWARN(WARN_VOID))
5135 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5136 av_unshift(PL_checkav, 1);
5137 av_store(PL_checkav, 0, (SV*)cv);
5138 GvCV(gv) = 0; /* cv has been hijacked */
5140 else if (strEQ(s, "INIT")) {
5142 PL_initav = newAV();
5143 if (PL_main_start && ckWARN(WARN_VOID))
5144 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5145 av_push(PL_initav, (SV*)cv);
5146 GvCV(gv) = 0; /* cv has been hijacked */
5157 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5166 name = SvPVx(cSVOPo->op_sv, n_a);
5169 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5170 #ifdef GV_UNIQUE_CHECK
5172 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5176 if ((cv = GvFORM(gv))) {
5177 if (ckWARN(WARN_REDEFINE)) {
5178 line_t oldline = CopLINE(PL_curcop);
5179 if (PL_copline != NOLINE)
5180 CopLINE_set(PL_curcop, PL_copline);
5181 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5182 CopLINE_set(PL_curcop, oldline);
5189 CvFILE_set_from_cop(cv, PL_curcop);
5191 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5192 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5193 SvPADTMP_on(PL_curpad[ix]);
5196 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5197 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5198 OpREFCNT_set(CvROOT(cv), 1);
5199 CvSTART(cv) = LINKLIST(CvROOT(cv));
5200 CvROOT(cv)->op_next = 0;
5201 CALL_PEEP(CvSTART(cv));
5203 PL_copline = NOLINE;
5208 Perl_newANONLIST(pTHX_ OP *o)
5210 return newUNOP(OP_REFGEN, 0,
5211 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5215 Perl_newANONHASH(pTHX_ OP *o)
5217 return newUNOP(OP_REFGEN, 0,
5218 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5222 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5224 return newANONATTRSUB(floor, proto, Nullop, block);
5228 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5230 return newUNOP(OP_REFGEN, 0,
5231 newSVOP(OP_ANONCODE, 0,
5232 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5236 Perl_oopsAV(pTHX_ OP *o)
5238 switch (o->op_type) {
5240 o->op_type = OP_PADAV;
5241 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5242 return ref(o, OP_RV2AV);
5245 o->op_type = OP_RV2AV;
5246 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5251 if (ckWARN_d(WARN_INTERNAL))
5252 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5259 Perl_oopsHV(pTHX_ OP *o)
5261 switch (o->op_type) {
5264 o->op_type = OP_PADHV;
5265 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5266 return ref(o, OP_RV2HV);
5270 o->op_type = OP_RV2HV;
5271 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5276 if (ckWARN_d(WARN_INTERNAL))
5277 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5284 Perl_newAVREF(pTHX_ OP *o)
5286 if (o->op_type == OP_PADANY) {
5287 o->op_type = OP_PADAV;
5288 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5291 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5292 && ckWARN(WARN_DEPRECATED)) {
5293 Perl_warner(aTHX_ WARN_DEPRECATED,
5294 "Using an array as a reference is deprecated");
5296 return newUNOP(OP_RV2AV, 0, scalar(o));
5300 Perl_newGVREF(pTHX_ I32 type, OP *o)
5302 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5303 return newUNOP(OP_NULL, 0, o);
5304 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5308 Perl_newHVREF(pTHX_ OP *o)
5310 if (o->op_type == OP_PADANY) {
5311 o->op_type = OP_PADHV;
5312 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5315 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5316 && ckWARN(WARN_DEPRECATED)) {
5317 Perl_warner(aTHX_ WARN_DEPRECATED,
5318 "Using a hash as a reference is deprecated");
5320 return newUNOP(OP_RV2HV, 0, scalar(o));
5324 Perl_oopsCV(pTHX_ OP *o)
5326 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5332 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5334 return newUNOP(OP_RV2CV, flags, scalar(o));
5338 Perl_newSVREF(pTHX_ OP *o)
5340 if (o->op_type == OP_PADANY) {
5341 o->op_type = OP_PADSV;
5342 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5345 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5346 o->op_flags |= OPpDONE_SVREF;
5349 return newUNOP(OP_RV2SV, 0, scalar(o));
5352 /* Check routines. */
5355 Perl_ck_anoncode(pTHX_ OP *o)
5360 name = NEWSV(1106,0);
5361 sv_upgrade(name, SVt_PVNV);
5362 sv_setpvn(name, "&", 1);
5365 ix = pad_alloc(o->op_type, SVs_PADMY);
5366 av_store(PL_comppad_name, ix, name);
5367 av_store(PL_comppad, ix, cSVOPo->op_sv);
5368 SvPADMY_on(cSVOPo->op_sv);
5369 cSVOPo->op_sv = Nullsv;
5370 cSVOPo->op_targ = ix;
5375 Perl_ck_bitop(pTHX_ OP *o)
5377 o->op_private = PL_hints;
5382 Perl_ck_concat(pTHX_ OP *o)
5384 if (cUNOPo->op_first->op_type == OP_CONCAT)
5385 o->op_flags |= OPf_STACKED;
5390 Perl_ck_spair(pTHX_ OP *o)
5392 if (o->op_flags & OPf_KIDS) {
5395 OPCODE type = o->op_type;
5396 o = modkids(ck_fun(o), type);
5397 kid = cUNOPo->op_first;
5398 newop = kUNOP->op_first->op_sibling;
5400 (newop->op_sibling ||
5401 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5402 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5403 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5407 op_free(kUNOP->op_first);
5408 kUNOP->op_first = newop;
5410 o->op_ppaddr = PL_ppaddr[++o->op_type];
5415 Perl_ck_delete(pTHX_ OP *o)
5419 if (o->op_flags & OPf_KIDS) {
5420 OP *kid = cUNOPo->op_first;
5421 switch (kid->op_type) {
5423 o->op_flags |= OPf_SPECIAL;
5426 o->op_private |= OPpSLICE;
5429 o->op_flags |= OPf_SPECIAL;
5434 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5443 Perl_ck_die(pTHX_ OP *o)
5446 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5452 Perl_ck_eof(pTHX_ OP *o)
5454 I32 type = o->op_type;
5456 if (o->op_flags & OPf_KIDS) {
5457 if (cLISTOPo->op_first->op_type == OP_STUB) {
5459 o = newUNOP(type, OPf_SPECIAL,
5460 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5468 Perl_ck_eval(pTHX_ OP *o)
5470 PL_hints |= HINT_BLOCK_SCOPE;
5471 if (o->op_flags & OPf_KIDS) {
5472 SVOP *kid = (SVOP*)cUNOPo->op_first;
5475 o->op_flags &= ~OPf_KIDS;
5478 else if (kid->op_type == OP_LINESEQ) {
5481 kid->op_next = o->op_next;
5482 cUNOPo->op_first = 0;
5485 NewOp(1101, enter, 1, LOGOP);
5486 enter->op_type = OP_ENTERTRY;
5487 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5488 enter->op_private = 0;
5490 /* establish postfix order */
5491 enter->op_next = (OP*)enter;
5493 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5494 o->op_type = OP_LEAVETRY;
5495 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5496 enter->op_other = o;
5504 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5506 o->op_targ = (PADOFFSET)PL_hints;
5511 Perl_ck_exit(pTHX_ OP *o)
5514 HV *table = GvHV(PL_hintgv);
5516 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5517 if (svp && *svp && SvTRUE(*svp))
5518 o->op_private |= OPpEXIT_VMSISH;
5520 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5526 Perl_ck_exec(pTHX_ OP *o)
5529 if (o->op_flags & OPf_STACKED) {
5531 kid = cUNOPo->op_first->op_sibling;
5532 if (kid->op_type == OP_RV2GV)
5541 Perl_ck_exists(pTHX_ OP *o)
5544 if (o->op_flags & OPf_KIDS) {
5545 OP *kid = cUNOPo->op_first;
5546 if (kid->op_type == OP_ENTERSUB) {
5547 (void) ref(kid, o->op_type);
5548 if (kid->op_type != OP_RV2CV && !PL_error_count)
5549 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5551 o->op_private |= OPpEXISTS_SUB;
5553 else if (kid->op_type == OP_AELEM)
5554 o->op_flags |= OPf_SPECIAL;
5555 else if (kid->op_type != OP_HELEM)
5556 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5565 Perl_ck_gvconst(pTHX_ register OP *o)
5567 o = fold_constants(o);
5568 if (o->op_type == OP_CONST)
5575 Perl_ck_rvconst(pTHX_ register OP *o)
5577 SVOP *kid = (SVOP*)cUNOPo->op_first;
5579 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5580 if (kid->op_type == OP_CONST) {
5584 SV *kidsv = kid->op_sv;
5587 /* Is it a constant from cv_const_sv()? */
5588 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5589 SV *rsv = SvRV(kidsv);
5590 int svtype = SvTYPE(rsv);
5591 char *badtype = Nullch;
5593 switch (o->op_type) {
5595 if (svtype > SVt_PVMG)
5596 badtype = "a SCALAR";
5599 if (svtype != SVt_PVAV)
5600 badtype = "an ARRAY";
5603 if (svtype != SVt_PVHV) {
5604 if (svtype == SVt_PVAV) { /* pseudohash? */
5605 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5606 if (ksv && SvROK(*ksv)
5607 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5616 if (svtype != SVt_PVCV)
5621 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5624 name = SvPV(kidsv, n_a);
5625 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5626 char *badthing = Nullch;
5627 switch (o->op_type) {
5629 badthing = "a SCALAR";
5632 badthing = "an ARRAY";
5635 badthing = "a HASH";
5640 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5644 * This is a little tricky. We only want to add the symbol if we
5645 * didn't add it in the lexer. Otherwise we get duplicate strict
5646 * warnings. But if we didn't add it in the lexer, we must at
5647 * least pretend like we wanted to add it even if it existed before,
5648 * or we get possible typo warnings. OPpCONST_ENTERED says
5649 * whether the lexer already added THIS instance of this symbol.
5651 iscv = (o->op_type == OP_RV2CV) * 2;
5653 gv = gv_fetchpv(name,
5654 iscv | !(kid->op_private & OPpCONST_ENTERED),
5657 : o->op_type == OP_RV2SV
5659 : o->op_type == OP_RV2AV
5661 : o->op_type == OP_RV2HV
5664 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5666 kid->op_type = OP_GV;
5667 SvREFCNT_dec(kid->op_sv);
5669 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5670 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5671 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5673 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5675 kid->op_sv = SvREFCNT_inc(gv);
5677 kid->op_private = 0;
5678 kid->op_ppaddr = PL_ppaddr[OP_GV];
5685 Perl_ck_ftst(pTHX_ OP *o)
5687 I32 type = o->op_type;
5689 if (o->op_flags & OPf_REF) {
5692 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5693 SVOP *kid = (SVOP*)cUNOPo->op_first;
5695 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5697 OP *newop = newGVOP(type, OPf_REF,
5698 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5705 if (type == OP_FTTTY)
5706 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5709 o = newUNOP(type, 0, newDEFSVOP());
5715 Perl_ck_fun(pTHX_ OP *o)
5721 int type = o->op_type;
5722 register I32 oa = PL_opargs[type] >> OASHIFT;
5724 if (o->op_flags & OPf_STACKED) {
5725 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5728 return no_fh_allowed(o);
5731 if (o->op_flags & OPf_KIDS) {
5733 tokid = &cLISTOPo->op_first;
5734 kid = cLISTOPo->op_first;
5735 if (kid->op_type == OP_PUSHMARK ||
5736 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5738 tokid = &kid->op_sibling;
5739 kid = kid->op_sibling;
5741 if (!kid && PL_opargs[type] & OA_DEFGV)
5742 *tokid = kid = newDEFSVOP();
5746 sibl = kid->op_sibling;
5749 /* list seen where single (scalar) arg expected? */
5750 if (numargs == 1 && !(oa >> 4)
5751 && kid->op_type == OP_LIST && type != OP_SCALAR)
5753 return too_many_arguments(o,PL_op_desc[type]);
5766 if ((type == OP_PUSH || type == OP_UNSHIFT)
5767 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5768 Perl_warner(aTHX_ WARN_SYNTAX,
5769 "Useless use of %s with no values",
5772 if (kid->op_type == OP_CONST &&
5773 (kid->op_private & OPpCONST_BARE))
5775 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5776 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5777 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5778 if (ckWARN(WARN_DEPRECATED))
5779 Perl_warner(aTHX_ WARN_DEPRECATED,
5780 "Array @%s missing the @ in argument %"IVdf" of %s()",
5781 name, (IV)numargs, PL_op_desc[type]);
5784 kid->op_sibling = sibl;
5787 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5788 bad_type(numargs, "array", PL_op_desc[type], kid);
5792 if (kid->op_type == OP_CONST &&
5793 (kid->op_private & OPpCONST_BARE))
5795 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5796 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5797 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5798 if (ckWARN(WARN_DEPRECATED))
5799 Perl_warner(aTHX_ WARN_DEPRECATED,
5800 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5801 name, (IV)numargs, PL_op_desc[type]);
5804 kid->op_sibling = sibl;
5807 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5808 bad_type(numargs, "hash", PL_op_desc[type], kid);
5813 OP *newop = newUNOP(OP_NULL, 0, kid);
5814 kid->op_sibling = 0;
5816 newop->op_next = newop;
5818 kid->op_sibling = sibl;
5823 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5824 if (kid->op_type == OP_CONST &&
5825 (kid->op_private & OPpCONST_BARE))
5827 OP *newop = newGVOP(OP_GV, 0,
5828 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5833 else if (kid->op_type == OP_READLINE) {
5834 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5835 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5838 I32 flags = OPf_SPECIAL;
5842 /* is this op a FH constructor? */
5843 if (is_handle_constructor(o,numargs)) {
5844 char *name = Nullch;
5848 /* Set a flag to tell rv2gv to vivify
5849 * need to "prove" flag does not mean something
5850 * else already - NI-S 1999/05/07
5853 if (kid->op_type == OP_PADSV) {
5854 SV **namep = av_fetch(PL_comppad_name,
5856 if (namep && *namep)
5857 name = SvPV(*namep, len);
5859 else if (kid->op_type == OP_RV2SV
5860 && kUNOP->op_first->op_type == OP_GV)
5862 GV *gv = cGVOPx_gv(kUNOP->op_first);
5864 len = GvNAMELEN(gv);
5866 else if (kid->op_type == OP_AELEM
5867 || kid->op_type == OP_HELEM)
5869 name = "__ANONIO__";
5875 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5876 namesv = PL_curpad[targ];
5877 (void)SvUPGRADE(namesv, SVt_PV);
5879 sv_setpvn(namesv, "$", 1);
5880 sv_catpvn(namesv, name, len);
5883 kid->op_sibling = 0;
5884 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5885 kid->op_targ = targ;
5886 kid->op_private |= priv;
5888 kid->op_sibling = sibl;
5894 mod(scalar(kid), type);
5898 tokid = &kid->op_sibling;
5899 kid = kid->op_sibling;
5901 o->op_private |= numargs;
5903 return too_many_arguments(o,OP_DESC(o));
5906 else if (PL_opargs[type] & OA_DEFGV) {
5908 return newUNOP(type, 0, newDEFSVOP());
5912 while (oa & OA_OPTIONAL)
5914 if (oa && oa != OA_LIST)
5915 return too_few_arguments(o,OP_DESC(o));
5921 Perl_ck_glob(pTHX_ OP *o)
5926 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5927 append_elem(OP_GLOB, o, newDEFSVOP());
5929 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5930 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5932 #if !defined(PERL_EXTERNAL_GLOB)
5933 /* XXX this can be tightened up and made more failsafe. */
5937 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5939 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5940 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5941 GvCV(gv) = GvCV(glob_gv);
5942 SvREFCNT_inc((SV*)GvCV(gv));
5943 GvIMPORTED_CV_on(gv);
5946 #endif /* PERL_EXTERNAL_GLOB */
5948 if (gv && GvIMPORTED_CV(gv)) {
5949 append_elem(OP_GLOB, o,
5950 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5951 o->op_type = OP_LIST;
5952 o->op_ppaddr = PL_ppaddr[OP_LIST];
5953 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5954 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5955 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5956 append_elem(OP_LIST, o,
5957 scalar(newUNOP(OP_RV2CV, 0,
5958 newGVOP(OP_GV, 0, gv)))));
5959 o = newUNOP(OP_NULL, 0, ck_subr(o));
5960 o->op_targ = OP_GLOB; /* hint at what it used to be */
5963 gv = newGVgen("main");
5965 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5971 Perl_ck_grep(pTHX_ OP *o)
5975 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5977 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5978 NewOp(1101, gwop, 1, LOGOP);
5980 if (o->op_flags & OPf_STACKED) {
5983 kid = cLISTOPo->op_first->op_sibling;
5984 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5987 kid->op_next = (OP*)gwop;
5988 o->op_flags &= ~OPf_STACKED;
5990 kid = cLISTOPo->op_first->op_sibling;
5991 if (type == OP_MAPWHILE)
5998 kid = cLISTOPo->op_first->op_sibling;
5999 if (kid->op_type != OP_NULL)
6000 Perl_croak(aTHX_ "panic: ck_grep");
6001 kid = kUNOP->op_first;
6003 gwop->op_type = type;
6004 gwop->op_ppaddr = PL_ppaddr[type];
6005 gwop->op_first = listkids(o);
6006 gwop->op_flags |= OPf_KIDS;
6007 gwop->op_private = 1;
6008 gwop->op_other = LINKLIST(kid);
6009 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6010 kid->op_next = (OP*)gwop;
6012 kid = cLISTOPo->op_first->op_sibling;
6013 if (!kid || !kid->op_sibling)
6014 return too_few_arguments(o,OP_DESC(o));
6015 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6016 mod(kid, OP_GREPSTART);
6022 Perl_ck_index(pTHX_ OP *o)
6024 if (o->op_flags & OPf_KIDS) {
6025 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6027 kid = kid->op_sibling; /* get past "big" */
6028 if (kid && kid->op_type == OP_CONST)
6029 fbm_compile(((SVOP*)kid)->op_sv, 0);
6035 Perl_ck_lengthconst(pTHX_ OP *o)
6037 /* XXX length optimization goes here */
6042 Perl_ck_lfun(pTHX_ OP *o)
6044 OPCODE type = o->op_type;
6045 return modkids(ck_fun(o), type);
6049 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6051 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6052 switch (cUNOPo->op_first->op_type) {
6054 /* This is needed for
6055 if (defined %stash::)
6056 to work. Do not break Tk.
6058 break; /* Globals via GV can be undef */
6060 case OP_AASSIGN: /* Is this a good idea? */
6061 Perl_warner(aTHX_ WARN_DEPRECATED,
6062 "defined(@array) is deprecated");
6063 Perl_warner(aTHX_ WARN_DEPRECATED,
6064 "\t(Maybe you should just omit the defined()?)\n");
6067 /* This is needed for
6068 if (defined %stash::)
6069 to work. Do not break Tk.
6071 break; /* Globals via GV can be undef */
6073 Perl_warner(aTHX_ WARN_DEPRECATED,
6074 "defined(%%hash) is deprecated");
6075 Perl_warner(aTHX_ WARN_DEPRECATED,
6076 "\t(Maybe you should just omit the defined()?)\n");
6087 Perl_ck_rfun(pTHX_ OP *o)
6089 OPCODE type = o->op_type;
6090 return refkids(ck_fun(o), type);
6094 Perl_ck_listiob(pTHX_ OP *o)
6098 kid = cLISTOPo->op_first;
6101 kid = cLISTOPo->op_first;
6103 if (kid->op_type == OP_PUSHMARK)
6104 kid = kid->op_sibling;
6105 if (kid && o->op_flags & OPf_STACKED)
6106 kid = kid->op_sibling;
6107 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6108 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6109 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6110 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6111 cLISTOPo->op_first->op_sibling = kid;
6112 cLISTOPo->op_last = kid;
6113 kid = kid->op_sibling;
6118 append_elem(o->op_type, o, newDEFSVOP());
6124 Perl_ck_sassign(pTHX_ OP *o)
6126 OP *kid = cLISTOPo->op_first;
6127 /* has a disposable target? */
6128 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6129 && !(kid->op_flags & OPf_STACKED)
6130 /* Cannot steal the second time! */
6131 && !(kid->op_private & OPpTARGET_MY))
6133 OP *kkid = kid->op_sibling;
6135 /* Can just relocate the target. */
6136 if (kkid && kkid->op_type == OP_PADSV
6137 && !(kkid->op_private & OPpLVAL_INTRO))
6139 kid->op_targ = kkid->op_targ;
6141 /* Now we do not need PADSV and SASSIGN. */
6142 kid->op_sibling = o->op_sibling; /* NULL */
6143 cLISTOPo->op_first = NULL;
6146 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6154 Perl_ck_match(pTHX_ OP *o)
6156 o->op_private |= OPpRUNTIME;
6161 Perl_ck_method(pTHX_ OP *o)
6163 OP *kid = cUNOPo->op_first;
6164 if (kid->op_type == OP_CONST) {
6165 SV* sv = kSVOP->op_sv;
6166 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6168 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6169 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6172 kSVOP->op_sv = Nullsv;
6174 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6183 Perl_ck_null(pTHX_ OP *o)
6189 Perl_ck_open(pTHX_ OP *o)
6191 HV *table = GvHV(PL_hintgv);
6195 svp = hv_fetch(table, "open_IN", 7, FALSE);
6197 mode = mode_from_discipline(*svp);
6198 if (mode & O_BINARY)
6199 o->op_private |= OPpOPEN_IN_RAW;
6200 else if (mode & O_TEXT)
6201 o->op_private |= OPpOPEN_IN_CRLF;
6204 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6206 mode = mode_from_discipline(*svp);
6207 if (mode & O_BINARY)
6208 o->op_private |= OPpOPEN_OUT_RAW;
6209 else if (mode & O_TEXT)
6210 o->op_private |= OPpOPEN_OUT_CRLF;
6213 if (o->op_type == OP_BACKTICK)
6219 Perl_ck_repeat(pTHX_ OP *o)
6221 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6222 o->op_private |= OPpREPEAT_DOLIST;
6223 cBINOPo->op_first = force_list(cBINOPo->op_first);
6231 Perl_ck_require(pTHX_ OP *o)
6235 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6236 SVOP *kid = (SVOP*)cUNOPo->op_first;
6238 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6240 for (s = SvPVX(kid->op_sv); *s; s++) {
6241 if (*s == ':' && s[1] == ':') {
6243 Move(s+2, s+1, strlen(s+2)+1, char);
6244 --SvCUR(kid->op_sv);
6247 if (SvREADONLY(kid->op_sv)) {
6248 SvREADONLY_off(kid->op_sv);
6249 sv_catpvn(kid->op_sv, ".pm", 3);
6250 SvREADONLY_on(kid->op_sv);
6253 sv_catpvn(kid->op_sv, ".pm", 3);
6257 /* handle override, if any */
6258 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6259 if (!(gv && GvIMPORTED_CV(gv)))
6260 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6262 if (gv && GvIMPORTED_CV(gv)) {
6263 OP *kid = cUNOPo->op_first;
6264 cUNOPo->op_first = 0;
6266 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6267 append_elem(OP_LIST, kid,
6268 scalar(newUNOP(OP_RV2CV, 0,
6277 Perl_ck_return(pTHX_ OP *o)
6280 if (CvLVALUE(PL_compcv)) {
6281 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6282 mod(kid, OP_LEAVESUBLV);
6289 Perl_ck_retarget(pTHX_ OP *o)
6291 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6298 Perl_ck_select(pTHX_ OP *o)
6301 if (o->op_flags & OPf_KIDS) {
6302 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6303 if (kid && kid->op_sibling) {
6304 o->op_type = OP_SSELECT;
6305 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6307 return fold_constants(o);
6311 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6312 if (kid && kid->op_type == OP_RV2GV)
6313 kid->op_private &= ~HINT_STRICT_REFS;
6318 Perl_ck_shift(pTHX_ OP *o)
6320 I32 type = o->op_type;
6322 if (!(o->op_flags & OPf_KIDS)) {
6326 #ifdef USE_5005THREADS
6327 if (!CvUNIQUE(PL_compcv)) {
6328 argop = newOP(OP_PADAV, OPf_REF);
6329 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6332 argop = newUNOP(OP_RV2AV, 0,
6333 scalar(newGVOP(OP_GV, 0,
6334 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6337 argop = newUNOP(OP_RV2AV, 0,
6338 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6339 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6340 #endif /* USE_5005THREADS */
6341 return newUNOP(type, 0, scalar(argop));
6343 return scalar(modkids(ck_fun(o), type));
6347 Perl_ck_sort(pTHX_ OP *o)
6351 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6353 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6354 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6356 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6358 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6360 if (kid->op_type == OP_SCOPE) {
6364 else if (kid->op_type == OP_LEAVE) {
6365 if (o->op_type == OP_SORT) {
6366 op_null(kid); /* wipe out leave */
6369 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6370 if (k->op_next == kid)
6372 /* don't descend into loops */
6373 else if (k->op_type == OP_ENTERLOOP
6374 || k->op_type == OP_ENTERITER)
6376 k = cLOOPx(k)->op_lastop;
6381 kid->op_next = 0; /* just disconnect the leave */
6382 k = kLISTOP->op_first;
6387 if (o->op_type == OP_SORT) {
6388 /* provide scalar context for comparison function/block */
6394 o->op_flags |= OPf_SPECIAL;
6396 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6399 firstkid = firstkid->op_sibling;
6402 /* provide list context for arguments */
6403 if (o->op_type == OP_SORT)
6410 S_simplify_sort(pTHX_ OP *o)
6412 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6416 if (!(o->op_flags & OPf_STACKED))
6418 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6419 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6420 kid = kUNOP->op_first; /* get past null */
6421 if (kid->op_type != OP_SCOPE)
6423 kid = kLISTOP->op_last; /* get past scope */
6424 switch(kid->op_type) {
6432 k = kid; /* remember this node*/
6433 if (kBINOP->op_first->op_type != OP_RV2SV)
6435 kid = kBINOP->op_first; /* get past cmp */
6436 if (kUNOP->op_first->op_type != OP_GV)
6438 kid = kUNOP->op_first; /* get past rv2sv */
6440 if (GvSTASH(gv) != PL_curstash)
6442 if (strEQ(GvNAME(gv), "a"))
6444 else if (strEQ(GvNAME(gv), "b"))
6448 kid = k; /* back to cmp */
6449 if (kBINOP->op_last->op_type != OP_RV2SV)
6451 kid = kBINOP->op_last; /* down to 2nd arg */
6452 if (kUNOP->op_first->op_type != OP_GV)
6454 kid = kUNOP->op_first; /* get past rv2sv */
6456 if (GvSTASH(gv) != PL_curstash
6458 ? strNE(GvNAME(gv), "a")
6459 : strNE(GvNAME(gv), "b")))
6461 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6463 o->op_private |= OPpSORT_REVERSE;
6464 if (k->op_type == OP_NCMP)
6465 o->op_private |= OPpSORT_NUMERIC;
6466 if (k->op_type == OP_I_NCMP)
6467 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6468 kid = cLISTOPo->op_first->op_sibling;
6469 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6470 op_free(kid); /* then delete it */
6474 Perl_ck_split(pTHX_ OP *o)
6478 if (o->op_flags & OPf_STACKED)
6479 return no_fh_allowed(o);
6481 kid = cLISTOPo->op_first;
6482 if (kid->op_type != OP_NULL)
6483 Perl_croak(aTHX_ "panic: ck_split");
6484 kid = kid->op_sibling;
6485 op_free(cLISTOPo->op_first);
6486 cLISTOPo->op_first = kid;
6488 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6489 cLISTOPo->op_last = kid; /* There was only one element previously */
6492 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6493 OP *sibl = kid->op_sibling;
6494 kid->op_sibling = 0;
6495 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6496 if (cLISTOPo->op_first == cLISTOPo->op_last)
6497 cLISTOPo->op_last = kid;
6498 cLISTOPo->op_first = kid;
6499 kid->op_sibling = sibl;
6502 kid->op_type = OP_PUSHRE;
6503 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6506 if (!kid->op_sibling)
6507 append_elem(OP_SPLIT, o, newDEFSVOP());
6509 kid = kid->op_sibling;
6512 if (!kid->op_sibling)
6513 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6515 kid = kid->op_sibling;
6518 if (kid->op_sibling)
6519 return too_many_arguments(o,OP_DESC(o));
6525 Perl_ck_join(pTHX_ OP *o)
6527 if (ckWARN(WARN_SYNTAX)) {
6528 OP *kid = cLISTOPo->op_first->op_sibling;
6529 if (kid && kid->op_type == OP_MATCH) {
6530 char *pmstr = "STRING";
6531 if (PM_GETRE(kPMOP))
6532 pmstr = PM_GETRE(kPMOP)->precomp;
6533 Perl_warner(aTHX_ WARN_SYNTAX,
6534 "/%s/ should probably be written as \"%s\"",
6542 Perl_ck_subr(pTHX_ OP *o)
6544 OP *prev = ((cUNOPo->op_first->op_sibling)
6545 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6546 OP *o2 = prev->op_sibling;
6553 I32 contextclass = 0;
6557 o->op_private |= OPpENTERSUB_HASTARG;
6558 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6559 if (cvop->op_type == OP_RV2CV) {
6561 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6562 op_null(cvop); /* disable rv2cv */
6563 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6564 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6565 GV *gv = cGVOPx_gv(tmpop);
6568 tmpop->op_private |= OPpEARLY_CV;
6569 else if (SvPOK(cv)) {
6570 namegv = CvANON(cv) ? gv : CvGV(cv);
6571 proto = SvPV((SV*)cv, n_a);
6575 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6576 if (o2->op_type == OP_CONST)
6577 o2->op_private &= ~OPpCONST_STRICT;
6578 else if (o2->op_type == OP_LIST) {
6579 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6580 if (o && o->op_type == OP_CONST)
6581 o->op_private &= ~OPpCONST_STRICT;
6584 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6585 if (PERLDB_SUB && PL_curstash != PL_debstash)
6586 o->op_private |= OPpENTERSUB_DB;
6587 while (o2 != cvop) {
6591 return too_many_arguments(o, gv_ename(namegv));
6609 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6611 arg == 1 ? "block or sub {}" : "sub {}",
6612 gv_ename(namegv), o2);
6615 /* '*' allows any scalar type, including bareword */
6618 if (o2->op_type == OP_RV2GV)
6619 goto wrapref; /* autoconvert GLOB -> GLOBref */
6620 else if (o2->op_type == OP_CONST)
6621 o2->op_private &= ~OPpCONST_STRICT;
6622 else if (o2->op_type == OP_ENTERSUB) {
6623 /* accidental subroutine, revert to bareword */
6624 OP *gvop = ((UNOP*)o2)->op_first;
6625 if (gvop && gvop->op_type == OP_NULL) {
6626 gvop = ((UNOP*)gvop)->op_first;
6628 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6631 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6632 (gvop = ((UNOP*)gvop)->op_first) &&
6633 gvop->op_type == OP_GV)
6635 GV *gv = cGVOPx_gv(gvop);
6636 OP *sibling = o2->op_sibling;
6637 SV *n = newSVpvn("",0);
6639 gv_fullname3(n, gv, "");
6640 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6641 sv_chop(n, SvPVX(n)+6);
6642 o2 = newSVOP(OP_CONST, 0, n);
6643 prev->op_sibling = o2;
6644 o2->op_sibling = sibling;
6660 if (contextclass++ == 0) {
6661 e = strchr(proto, ']');
6662 if (!e || e == proto)
6676 if (o2->op_type == OP_RV2GV)
6679 bad_type(arg, "symbol", gv_ename(namegv), o2);
6682 if (o2->op_type == OP_ENTERSUB)
6685 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6688 if (o2->op_type == OP_RV2SV ||
6689 o2->op_type == OP_PADSV ||
6690 o2->op_type == OP_HELEM ||
6691 o2->op_type == OP_AELEM ||
6692 o2->op_type == OP_THREADSV)
6695 bad_type(arg, "scalar", gv_ename(namegv), o2);
6698 if (o2->op_type == OP_RV2AV ||
6699 o2->op_type == OP_PADAV)
6702 bad_type(arg, "array", gv_ename(namegv), o2);
6705 if (o2->op_type == OP_RV2HV ||
6706 o2->op_type == OP_PADHV)
6709 bad_type(arg, "hash", gv_ename(namegv), o2);
6714 OP* sib = kid->op_sibling;
6715 kid->op_sibling = 0;
6716 o2 = newUNOP(OP_REFGEN, 0, kid);
6717 o2->op_sibling = sib;
6718 prev->op_sibling = o2;
6720 if (contextclass && e) {
6735 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6736 gv_ename(namegv), SvPV((SV*)cv, n_a));
6741 mod(o2, OP_ENTERSUB);
6743 o2 = o2->op_sibling;
6745 if (proto && !optional &&
6746 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6747 return too_few_arguments(o, gv_ename(namegv));
6752 Perl_ck_svconst(pTHX_ OP *o)
6754 SvREADONLY_on(cSVOPo->op_sv);
6759 Perl_ck_trunc(pTHX_ OP *o)
6761 if (o->op_flags & OPf_KIDS) {
6762 SVOP *kid = (SVOP*)cUNOPo->op_first;
6764 if (kid->op_type == OP_NULL)
6765 kid = (SVOP*)kid->op_sibling;
6766 if (kid && kid->op_type == OP_CONST &&
6767 (kid->op_private & OPpCONST_BARE))
6769 o->op_flags |= OPf_SPECIAL;
6770 kid->op_private &= ~OPpCONST_STRICT;
6777 Perl_ck_substr(pTHX_ OP *o)
6780 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6781 OP *kid = cLISTOPo->op_first;
6783 if (kid->op_type == OP_NULL)
6784 kid = kid->op_sibling;
6786 kid->op_flags |= OPf_MOD;
6792 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6795 Perl_peep(pTHX_ register OP *o)
6797 register OP* oldop = 0;
6800 if (!o || o->op_seq)
6804 SAVEVPTR(PL_curcop);
6805 for (; o; o = o->op_next) {
6811 switch (o->op_type) {
6815 PL_curcop = ((COP*)o); /* for warnings */
6816 o->op_seq = PL_op_seqmax++;
6820 if (cSVOPo->op_private & OPpCONST_STRICT)
6821 no_bareword_allowed(o);
6823 /* Relocate sv to the pad for thread safety.
6824 * Despite being a "constant", the SV is written to,
6825 * for reference counts, sv_upgrade() etc. */
6827 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6828 if (SvPADTMP(cSVOPo->op_sv)) {
6829 /* If op_sv is already a PADTMP then it is being used by
6830 * some pad, so make a copy. */
6831 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6832 SvREADONLY_on(PL_curpad[ix]);
6833 SvREFCNT_dec(cSVOPo->op_sv);
6836 SvREFCNT_dec(PL_curpad[ix]);
6837 SvPADTMP_on(cSVOPo->op_sv);
6838 PL_curpad[ix] = cSVOPo->op_sv;
6839 /* XXX I don't know how this isn't readonly already. */
6840 SvREADONLY_on(PL_curpad[ix]);
6842 cSVOPo->op_sv = Nullsv;
6846 o->op_seq = PL_op_seqmax++;
6850 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6851 if (o->op_next->op_private & OPpTARGET_MY) {
6852 if (o->op_flags & OPf_STACKED) /* chained concats */
6853 goto ignore_optimization;
6855 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6856 o->op_targ = o->op_next->op_targ;
6857 o->op_next->op_targ = 0;
6858 o->op_private |= OPpTARGET_MY;
6861 op_null(o->op_next);
6863 ignore_optimization:
6864 o->op_seq = PL_op_seqmax++;
6867 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6868 o->op_seq = PL_op_seqmax++;
6869 break; /* Scalar stub must produce undef. List stub is noop */
6873 if (o->op_targ == OP_NEXTSTATE
6874 || o->op_targ == OP_DBSTATE
6875 || o->op_targ == OP_SETSTATE)
6877 PL_curcop = ((COP*)o);
6879 /* XXX: We avoid setting op_seq here to prevent later calls
6880 to peep() from mistakenly concluding that optimisation
6881 has already occurred. This doesn't fix the real problem,
6882 though (See 20010220.007). AMS 20010719 */
6883 if (oldop && o->op_next) {
6884 oldop->op_next = o->op_next;
6892 if (oldop && o->op_next) {
6893 oldop->op_next = o->op_next;
6896 o->op_seq = PL_op_seqmax++;
6900 if (o->op_next->op_type == OP_RV2SV) {
6901 if (!(o->op_next->op_private & OPpDEREF)) {
6902 op_null(o->op_next);
6903 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6905 o->op_next = o->op_next->op_next;
6906 o->op_type = OP_GVSV;
6907 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6910 else if (o->op_next->op_type == OP_RV2AV) {
6911 OP* pop = o->op_next->op_next;
6913 if (pop->op_type == OP_CONST &&
6914 (PL_op = pop->op_next) &&
6915 pop->op_next->op_type == OP_AELEM &&
6916 !(pop->op_next->op_private &
6917 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6918 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6923 op_null(o->op_next);
6924 op_null(pop->op_next);
6926 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6927 o->op_next = pop->op_next->op_next;
6928 o->op_type = OP_AELEMFAST;
6929 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6930 o->op_private = (U8)i;
6935 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6937 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6938 /* XXX could check prototype here instead of just carping */
6939 SV *sv = sv_newmortal();
6940 gv_efullname3(sv, gv, Nullch);
6941 Perl_warner(aTHX_ WARN_PROTOTYPE,
6942 "%s() called too early to check prototype",
6946 else if (o->op_next->op_type == OP_READLINE
6947 && o->op_next->op_next->op_type == OP_CONCAT
6948 && (o->op_next->op_next->op_flags & OPf_STACKED))
6950 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6951 o->op_type = OP_RCATLINE;
6952 o->op_flags |= OPf_STACKED;
6953 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6954 op_null(o->op_next->op_next);
6955 op_null(o->op_next);
6958 o->op_seq = PL_op_seqmax++;
6969 o->op_seq = PL_op_seqmax++;
6970 while (cLOGOP->op_other->op_type == OP_NULL)
6971 cLOGOP->op_other = cLOGOP->op_other->op_next;
6972 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6977 o->op_seq = PL_op_seqmax++;
6978 while (cLOOP->op_redoop->op_type == OP_NULL)
6979 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6980 peep(cLOOP->op_redoop);
6981 while (cLOOP->op_nextop->op_type == OP_NULL)
6982 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6983 peep(cLOOP->op_nextop);
6984 while (cLOOP->op_lastop->op_type == OP_NULL)
6985 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6986 peep(cLOOP->op_lastop);
6992 o->op_seq = PL_op_seqmax++;
6993 while (cPMOP->op_pmreplstart &&
6994 cPMOP->op_pmreplstart->op_type == OP_NULL)
6995 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6996 peep(cPMOP->op_pmreplstart);
7000 o->op_seq = PL_op_seqmax++;
7001 if (ckWARN(WARN_SYNTAX) && o->op_next
7002 && o->op_next->op_type == OP_NEXTSTATE) {
7003 if (o->op_next->op_sibling &&
7004 o->op_next->op_sibling->op_type != OP_EXIT &&
7005 o->op_next->op_sibling->op_type != OP_WARN &&
7006 o->op_next->op_sibling->op_type != OP_DIE) {
7007 line_t oldline = CopLINE(PL_curcop);
7009 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7010 Perl_warner(aTHX_ WARN_EXEC,
7011 "Statement unlikely to be reached");
7012 Perl_warner(aTHX_ WARN_EXEC,
7013 "\t(Maybe you meant system() when you said exec()?)\n");
7014 CopLINE_set(PL_curcop, oldline);
7023 SV **svp, **indsvp, *sv;
7028 o->op_seq = PL_op_seqmax++;
7030 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7033 /* Make the CONST have a shared SV */
7034 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7035 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7036 key = SvPV(sv, keylen);
7037 lexname = newSVpvn_share(key,
7038 SvUTF8(sv) ? -(I32)keylen : keylen,
7044 if ((o->op_private & (OPpLVAL_INTRO)))
7047 rop = (UNOP*)((BINOP*)o)->op_first;
7048 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7050 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7051 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7053 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7054 if (!fields || !GvHV(*fields))
7056 key = SvPV(*svp, keylen);
7057 indsvp = hv_fetch(GvHV(*fields), key,
7058 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7060 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7061 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7063 ind = SvIV(*indsvp);
7065 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7066 rop->op_type = OP_RV2AV;
7067 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7068 o->op_type = OP_AELEM;
7069 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7071 if (SvREADONLY(*svp))
7073 SvFLAGS(sv) |= (SvFLAGS(*svp)
7074 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7084 SV **svp, **indsvp, *sv;
7088 SVOP *first_key_op, *key_op;
7090 o->op_seq = PL_op_seqmax++;
7091 if ((o->op_private & (OPpLVAL_INTRO))
7092 /* I bet there's always a pushmark... */
7093 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7094 /* hmmm, no optimization if list contains only one key. */
7096 rop = (UNOP*)((LISTOP*)o)->op_last;
7097 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7099 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7100 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7102 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7103 if (!fields || !GvHV(*fields))
7105 /* Again guessing that the pushmark can be jumped over.... */
7106 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7107 ->op_first->op_sibling;
7108 /* Check that the key list contains only constants. */
7109 for (key_op = first_key_op; key_op;
7110 key_op = (SVOP*)key_op->op_sibling)
7111 if (key_op->op_type != OP_CONST)
7115 rop->op_type = OP_RV2AV;
7116 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7117 o->op_type = OP_ASLICE;
7118 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7119 for (key_op = first_key_op; key_op;
7120 key_op = (SVOP*)key_op->op_sibling) {
7121 svp = cSVOPx_svp(key_op);
7122 key = SvPV(*svp, keylen);
7123 indsvp = hv_fetch(GvHV(*fields), key,
7124 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7126 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7127 "in variable %s of type %s",
7128 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7130 ind = SvIV(*indsvp);
7132 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7134 if (SvREADONLY(*svp))
7136 SvFLAGS(sv) |= (SvFLAGS(*svp)
7137 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7145 o->op_seq = PL_op_seqmax++;
7155 char* Perl_custom_op_name(pTHX_ OP* o)
7157 IV index = PTR2IV(o->op_ppaddr);
7161 if (!PL_custom_op_names) /* This probably shouldn't happen */
7162 return PL_op_name[OP_CUSTOM];
7164 keysv = sv_2mortal(newSViv(index));
7166 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7168 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7170 return SvPV_nolen(HeVAL(he));
7173 char* Perl_custom_op_desc(pTHX_ OP* o)
7175 IV index = PTR2IV(o->op_ppaddr);
7179 if (!PL_custom_op_descs)
7180 return PL_op_desc[OP_CUSTOM];
7182 keysv = sv_2mortal(newSViv(index));
7184 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7186 return PL_op_desc[OP_CUSTOM];
7188 return SvPV_nolen(HeVAL(he));
7194 /* Efficient sub that returns a constant scalar value. */
7196 const_sv_xsub(pTHX_ CV* cv)
7201 Perl_croak(aTHX_ "usage: %s::%s()",
7202 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7206 ST(0) = (SV*)XSANY.any_ptr;