3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
25 /* #define PL_OP_SLAB_ALLOC */
27 #if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
28 #define SLAB_SIZE 8192
29 static char *PL_OpPtr = NULL; /* XXX threadead */
30 static int PL_OpSpace = 0; /* XXX threadead */
31 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
32 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
34 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
40 Newz(m,PL_OpPtr,SLAB_SIZE,char);
41 PL_OpSpace = SLAB_SIZE - sz;
42 return PL_OpPtr += PL_OpSpace;
46 #define NewOp(m, var, c, type) Newz(m, var, c, type)
49 * In the following definition, the ", Nullop" is just to make the compiler
50 * think the expression is of the right type: croak actually does a Siglongjmp.
52 #define CHECKOP(type,o) \
53 ((PL_op_mask && PL_op_mask[type]) \
54 ? ( op_free((OP*)o), \
55 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
57 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
59 #define PAD_MAX 999999999
60 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
63 S_gv_ename(pTHX_ GV *gv)
66 SV* tmpsv = sv_newmortal();
67 gv_efullname3(tmpsv, gv, Nullch);
68 return SvPV(tmpsv,n_a);
72 S_no_fh_allowed(pTHX_ OP *o)
74 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
80 S_too_few_arguments(pTHX_ OP *o, char *name)
82 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
87 S_too_many_arguments(pTHX_ OP *o, char *name)
89 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
94 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
96 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
97 (int)n, name, t, OP_DESC(kid)));
101 S_no_bareword_allowed(pTHX_ OP *o)
103 qerror(Perl_mess(aTHX_
104 "Bareword \"%s\" not allowed while \"strict subs\" in use",
105 SvPV_nolen(cSVOPo_sv)));
108 /* "register" allocation */
111 Perl_pad_allocmy(pTHX_ char *name)
116 if (!(PL_in_my == KEY_our ||
118 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
119 (name[1] == '_' && (int)strlen(name) > 2)))
121 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
122 /* 1999-02-27 mjd@plover.com */
124 p = strchr(name, '\0');
125 /* The next block assumes the buffer is at least 205 chars
126 long. At present, it's always at least 256 chars. */
128 strcpy(name+200, "...");
134 /* Move everything else down one character */
135 for (; p-name > 2; p--)
137 name[2] = toCTRL(name[1]);
140 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
142 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
143 SV **svp = AvARRAY(PL_comppad_name);
144 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
145 PADOFFSET top = AvFILLp(PL_comppad_name);
146 for (off = top; off > PL_comppad_name_floor; off--) {
148 && sv != &PL_sv_undef
149 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
150 && (PL_in_my != KEY_our
151 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
152 && strEQ(name, SvPVX(sv)))
154 Perl_warner(aTHX_ WARN_MISC,
155 "\"%s\" variable %s masks earlier declaration in same %s",
156 (PL_in_my == KEY_our ? "our" : "my"),
158 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
163 if (PL_in_my == KEY_our) {
166 && sv != &PL_sv_undef
167 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
168 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
169 && strEQ(name, SvPVX(sv)))
171 Perl_warner(aTHX_ WARN_MISC,
172 "\"our\" variable %s redeclared", name);
173 Perl_warner(aTHX_ WARN_MISC,
174 "\t(Did you mean \"local\" instead of \"our\"?)\n");
177 } while ( off-- > 0 );
180 off = pad_alloc(OP_PADSV, SVs_PADMY);
182 sv_upgrade(sv, SVt_PVNV);
184 if (PL_in_my_stash) {
186 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
187 name, PL_in_my == KEY_our ? "our" : "my"));
188 SvFLAGS(sv) |= SVpad_TYPED;
189 (void)SvUPGRADE(sv, SVt_PVMG);
190 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
192 if (PL_in_my == KEY_our) {
193 (void)SvUPGRADE(sv, SVt_PVGV);
194 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
195 SvFLAGS(sv) |= SVpad_OUR;
197 av_store(PL_comppad_name, off, sv);
198 SvNVX(sv) = (NV)PAD_MAX;
199 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
200 if (!PL_min_intro_pending)
201 PL_min_intro_pending = off;
202 PL_max_intro_pending = off;
204 av_store(PL_comppad, off, (SV*)newAV());
205 else if (*name == '%')
206 av_store(PL_comppad, off, (SV*)newHV());
207 SvPADMY_on(PL_curpad[off]);
212 S_pad_addlex(pTHX_ SV *proto_namesv)
214 SV *namesv = NEWSV(1103,0);
215 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
216 sv_upgrade(namesv, SVt_PVNV);
217 sv_setpv(namesv, SvPVX(proto_namesv));
218 av_store(PL_comppad_name, newoff, namesv);
219 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
220 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
221 SvFAKE_on(namesv); /* A ref, not a real var */
222 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
223 SvFLAGS(namesv) |= SVpad_OUR;
224 (void)SvUPGRADE(namesv, SVt_PVGV);
225 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
227 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
228 SvFLAGS(namesv) |= SVpad_TYPED;
229 (void)SvUPGRADE(namesv, SVt_PVMG);
230 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
235 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
238 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
239 I32 cx_ix, I32 saweval, U32 flags)
245 register PERL_CONTEXT *cx;
247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
252 if (!svp || *svp == &PL_sv_undef)
255 svp = AvARRAY(curname);
256 for (off = AvFILLp(curname); off > 0; off--) {
257 if ((sv = svp[off]) &&
258 sv != &PL_sv_undef &&
260 seq > I_32(SvNVX(sv)) &&
261 strEQ(SvPVX(sv), name))
272 return 0; /* don't clone from inactive stack frame */
276 oldpad = (AV*)AvARRAY(curlist)[depth];
277 oldsv = *av_fetch(oldpad, off, TRUE);
278 if (!newoff) { /* Not a mere clone operation. */
279 newoff = pad_addlex(sv);
280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
281 /* "It's closures all the way down." */
282 CvCLONE_on(PL_compcv);
284 if (CvANON(PL_compcv))
285 oldsv = Nullsv; /* no need to keep ref */
290 bcv && bcv != cv && !CvCLONE(bcv);
291 bcv = CvOUTSIDE(bcv))
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
314 Perl_warner(aTHX_ WARN_CLOSURE,
315 "Variable \"%s\" may be unavailable",
323 else if (!CvUNIQUE(PL_compcv)) {
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
327 Perl_warner(aTHX_ WARN_CLOSURE,
328 "Variable \"%s\" will not stay shared", name);
332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
338 if (flags & FINDLEX_NOSEARCH)
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
346 for (i = cx_ix; i >= 0; i--) {
348 switch (CxTYPE(cx)) {
350 if (i == 0 && saweval) {
351 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
355 switch (cx->blk_eval.old_op_type) {
357 if (CxREALEVAL(cx)) {
360 seq = cxstack[i].blk_oldcop->cop_seq;
361 startcv = cxstack[i].blk_eval.cv;
362 if (startcv && CvOUTSIDE(startcv)) {
363 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
365 if (off) /* continue looking if not found here */
372 /* require/do must have their own scope */
381 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
382 saweval = i; /* so we know where we were called from */
383 seq = cxstack[i].blk_oldcop->cop_seq;
386 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
394 Perl_pad_findmy(pTHX_ char *name)
399 SV **svp = AvARRAY(PL_comppad_name);
400 U32 seq = PL_cop_seqmax;
404 #ifdef USE_5005THREADS
406 * Special case to get lexical (and hence per-thread) @_.
407 * XXX I need to find out how to tell at parse-time whether use
408 * of @_ should refer to a lexical (from a sub) or defgv (global
409 * scope and maybe weird sub-ish things like formats). See
410 * startsub in perly.y. It's possible that @_ could be lexical
411 * (at least from subs) even in non-threaded perl.
413 if (strEQ(name, "@_"))
414 return 0; /* success. (NOT_IN_PAD indicates failure) */
415 #endif /* USE_5005THREADS */
417 /* The one we're looking for is probably just before comppad_name_fill. */
418 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
419 if ((sv = svp[off]) &&
420 sv != &PL_sv_undef &&
423 seq > I_32(SvNVX(sv)))) &&
424 strEQ(SvPVX(sv), name))
426 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
427 return (PADOFFSET)off;
428 pendoff = off; /* this pending def. will override import */
432 outside = CvOUTSIDE(PL_compcv);
434 /* Check if if we're compiling an eval'', and adjust seq to be the
435 * eval's seq number. This depends on eval'' having a non-null
436 * CvOUTSIDE() while it is being compiled. The eval'' itself is
437 * identified by CvEVAL being true and CvGV being null. */
438 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
439 cx = &cxstack[cxstack_ix];
441 seq = cx->blk_oldcop->cop_seq;
444 /* See if it's in a nested scope */
445 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
447 /* If there is a pending local definition, this new alias must die */
449 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
450 return off; /* pad_findlex returns 0 for failure...*/
452 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
456 Perl_pad_leavemy(pTHX_ I32 fill)
459 SV **svp = AvARRAY(PL_comppad_name);
461 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
462 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
463 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
464 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
467 /* "Deintroduce" my variables that are leaving with this scope. */
468 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
469 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
470 SvIVX(sv) = PL_cop_seqmax;
475 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
480 if (AvARRAY(PL_comppad) != PL_curpad)
481 Perl_croak(aTHX_ "panic: pad_alloc");
482 if (PL_pad_reset_pending)
484 if (tmptype & SVs_PADMY) {
486 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
487 } while (SvPADBUSY(sv)); /* need a fresh one */
488 retval = AvFILLp(PL_comppad);
491 SV **names = AvARRAY(PL_comppad_name);
492 SSize_t names_fill = AvFILLp(PL_comppad_name);
495 * "foreach" index vars temporarily become aliases to non-"my"
496 * values. Thus we must skip, not just pad values that are
497 * marked as current pad values, but also those with names.
499 if (++PL_padix <= names_fill &&
500 (sv = names[PL_padix]) && sv != &PL_sv_undef)
502 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
503 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
504 !IS_PADGV(sv) && !IS_PADCONST(sv))
509 SvFLAGS(sv) |= tmptype;
510 PL_curpad = AvARRAY(PL_comppad);
511 #ifdef USE_5005THREADS
512 DEBUG_X(PerlIO_printf(Perl_debug_log,
513 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
514 PTR2UV(thr), PTR2UV(PL_curpad),
515 (long) retval, PL_op_name[optype]));
517 DEBUG_X(PerlIO_printf(Perl_debug_log,
518 "Pad 0x%"UVxf" alloc %ld for %s\n",
520 (long) retval, PL_op_name[optype]));
521 #endif /* USE_5005THREADS */
522 return (PADOFFSET)retval;
526 Perl_pad_sv(pTHX_ PADOFFSET po)
528 #ifdef USE_5005THREADS
529 DEBUG_X(PerlIO_printf(Perl_debug_log,
530 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
531 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
534 Perl_croak(aTHX_ "panic: pad_sv po");
535 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
536 PTR2UV(PL_curpad), (IV)po));
537 #endif /* USE_5005THREADS */
538 return PL_curpad[po]; /* eventually we'll turn this into a macro */
542 Perl_pad_free(pTHX_ PADOFFSET po)
546 if (AvARRAY(PL_comppad) != PL_curpad)
547 Perl_croak(aTHX_ "panic: pad_free curpad");
549 Perl_croak(aTHX_ "panic: pad_free po");
550 #ifdef USE_5005THREADS
551 DEBUG_X(PerlIO_printf(Perl_debug_log,
552 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
553 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
555 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
556 PTR2UV(PL_curpad), (IV)po));
557 #endif /* USE_5005THREADS */
558 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
559 SvPADTMP_off(PL_curpad[po]);
561 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
564 if ((I32)po < PL_padix)
569 Perl_pad_swipe(pTHX_ PADOFFSET po)
571 if (AvARRAY(PL_comppad) != PL_curpad)
572 Perl_croak(aTHX_ "panic: pad_swipe curpad");
574 Perl_croak(aTHX_ "panic: pad_swipe po");
575 #ifdef USE_5005THREADS
576 DEBUG_X(PerlIO_printf(Perl_debug_log,
577 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
580 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
581 PTR2UV(PL_curpad), (IV)po));
582 #endif /* USE_5005THREADS */
583 SvPADTMP_off(PL_curpad[po]);
584 PL_curpad[po] = NEWSV(1107,0);
585 SvPADTMP_on(PL_curpad[po]);
586 if ((I32)po < PL_padix)
590 /* XXX pad_reset() is currently disabled because it results in serious bugs.
591 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
592 * on the stack by OPs that use them, there are several ways to get an alias
593 * to a shared TARG. Such an alias will change randomly and unpredictably.
594 * We avoid doing this until we can think of a Better Way.
599 #ifdef USE_BROKEN_PAD_RESET
602 if (AvARRAY(PL_comppad) != PL_curpad)
603 Perl_croak(aTHX_ "panic: pad_reset curpad");
604 #ifdef USE_5005THREADS
605 DEBUG_X(PerlIO_printf(Perl_debug_log,
606 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
607 PTR2UV(thr), PTR2UV(PL_curpad)));
609 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
611 #endif /* USE_5005THREADS */
612 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
613 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
614 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
615 SvPADTMP_off(PL_curpad[po]);
617 PL_padix = PL_padix_floor;
620 PL_pad_reset_pending = FALSE;
623 #ifdef USE_5005THREADS
624 /* find_threadsv is not reentrant */
626 Perl_find_threadsv(pTHX_ const char *name)
631 /* We currently only handle names of a single character */
632 p = strchr(PL_threadsv_names, *name);
635 key = p - PL_threadsv_names;
636 MUTEX_LOCK(&thr->mutex);
637 svp = av_fetch(thr->threadsv, key, FALSE);
639 MUTEX_UNLOCK(&thr->mutex);
641 SV *sv = NEWSV(0, 0);
642 av_store(thr->threadsv, key, sv);
643 thr->threadsvp = AvARRAY(thr->threadsv);
644 MUTEX_UNLOCK(&thr->mutex);
646 * Some magic variables used to be automagically initialised
647 * in gv_fetchpv. Those which are now per-thread magicals get
648 * initialised here instead.
654 sv_setpv(sv, "\034");
655 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
660 PL_sawampersand = TRUE;
674 /* XXX %! tied to Errno.pm needs to be added here.
675 * See gv_fetchpv(). */
679 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
681 DEBUG_S(PerlIO_printf(Perl_error_log,
682 "find_threadsv: new SV %p for $%s%c\n",
683 sv, (*name < 32) ? "^" : "",
684 (*name < 32) ? toCTRL(*name) : *name));
688 #endif /* USE_5005THREADS */
693 Perl_op_free(pTHX_ OP *o)
695 register OP *kid, *nextkid;
698 if (!o || o->op_seq == (U16)-1)
701 if (o->op_private & OPpREFCOUNTED) {
702 switch (o->op_type) {
710 if (OpREFCNT_dec(o)) {
721 if (o->op_flags & OPf_KIDS) {
722 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
723 nextkid = kid->op_sibling; /* Get before next freeing kid */
731 /* COP* is not cleared by op_clear() so that we may track line
732 * numbers etc even after null() */
733 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
738 #ifdef PL_OP_SLAB_ALLOC
739 if ((char *) o == PL_OpPtr)
748 Perl_op_clear(pTHX_ OP *o)
751 switch (o->op_type) {
752 case OP_NULL: /* Was holding old type, if any. */
753 case OP_ENTEREVAL: /* Was holding hints. */
754 #ifdef USE_5005THREADS
755 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
759 #ifdef USE_5005THREADS
761 if (!(o->op_flags & OPf_SPECIAL))
764 #endif /* USE_5005THREADS */
766 if (!(o->op_flags & OPf_REF)
767 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
774 if (cPADOPo->op_padix > 0) {
777 pad_swipe(cPADOPo->op_padix);
778 /* No GvIN_PAD_off(gv) here, because other references may still
779 * exist on the pad */
782 cPADOPo->op_padix = 0;
785 SvREFCNT_dec(cSVOPo->op_sv);
786 cSVOPo->op_sv = Nullsv;
789 case OP_METHOD_NAMED:
791 SvREFCNT_dec(cSVOPo->op_sv);
792 cSVOPo->op_sv = Nullsv;
798 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
802 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
803 SvREFCNT_dec(cSVOPo->op_sv);
804 cSVOPo->op_sv = Nullsv;
807 Safefree(cPVOPo->op_pv);
808 cPVOPo->op_pv = Nullch;
812 op_free(cPMOPo->op_pmreplroot);
816 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
818 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
819 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
820 /* No GvIN_PAD_off(gv) here, because other references may still
821 * exist on the pad */
826 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
833 HV *pmstash = PmopSTASH(cPMOPo);
834 if (pmstash && SvREFCNT(pmstash)) {
835 PMOP *pmop = HvPMROOT(pmstash);
836 PMOP *lastpmop = NULL;
838 if (cPMOPo == pmop) {
840 lastpmop->op_pmnext = pmop->op_pmnext;
842 HvPMROOT(pmstash) = pmop->op_pmnext;
846 pmop = pmop->op_pmnext;
850 Safefree(PmopSTASHPV(cPMOPo));
852 /* NOTE: PMOP.op_pmstash is not refcounted */
855 cPMOPo->op_pmreplroot = Nullop;
856 /* we use the "SAFE" version of the PM_ macros here
857 * since sv_clean_all might release some PMOPs
858 * after PL_regex_padav has been cleared
859 * and the clearing of PL_regex_padav needs to
860 * happen before sv_clean_all
862 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
863 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
865 if(PL_regex_pad) { /* We could be in destruction */
866 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
867 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
868 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
875 if (o->op_targ > 0) {
876 pad_free(o->op_targ);
882 S_cop_free(pTHX_ COP* cop)
884 Safefree(cop->cop_label);
886 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
887 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
889 /* NOTE: COP.cop_stash is not refcounted */
890 SvREFCNT_dec(CopFILEGV(cop));
892 if (! specialWARN(cop->cop_warnings))
893 SvREFCNT_dec(cop->cop_warnings);
894 if (! specialCopIO(cop->cop_io))
895 SvREFCNT_dec(cop->cop_io);
899 Perl_op_null(pTHX_ OP *o)
901 if (o->op_type == OP_NULL)
904 o->op_targ = o->op_type;
905 o->op_type = OP_NULL;
906 o->op_ppaddr = PL_ppaddr[OP_NULL];
909 /* Contextualizers */
911 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
914 Perl_linklist(pTHX_ OP *o)
921 /* establish postfix order */
922 if (cUNOPo->op_first) {
923 o->op_next = LINKLIST(cUNOPo->op_first);
924 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
926 kid->op_next = LINKLIST(kid->op_sibling);
938 Perl_scalarkids(pTHX_ OP *o)
941 if (o && o->op_flags & OPf_KIDS) {
942 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
949 S_scalarboolean(pTHX_ OP *o)
951 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
952 if (ckWARN(WARN_SYNTAX)) {
953 line_t oldline = CopLINE(PL_curcop);
955 if (PL_copline != NOLINE)
956 CopLINE_set(PL_curcop, PL_copline);
957 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
958 CopLINE_set(PL_curcop, oldline);
965 Perl_scalar(pTHX_ OP *o)
969 /* assumes no premature commitment */
970 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
971 || o->op_type == OP_RETURN)
976 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
978 switch (o->op_type) {
980 scalar(cBINOPo->op_first);
985 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
989 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
990 if (!kPMOP->op_pmreplroot)
991 deprecate("implicit split to @_");
999 if (o->op_flags & OPf_KIDS) {
1000 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1006 kid = cLISTOPo->op_first;
1008 while ((kid = kid->op_sibling)) {
1009 if (kid->op_sibling)
1014 WITH_THR(PL_curcop = &PL_compiling);
1019 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1020 if (kid->op_sibling)
1025 WITH_THR(PL_curcop = &PL_compiling);
1028 if (ckWARN(WARN_VOID))
1029 Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
1035 Perl_scalarvoid(pTHX_ OP *o)
1042 if (o->op_type == OP_NEXTSTATE
1043 || o->op_type == OP_SETSTATE
1044 || o->op_type == OP_DBSTATE
1045 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1046 || o->op_targ == OP_SETSTATE
1047 || o->op_targ == OP_DBSTATE)))
1048 PL_curcop = (COP*)o; /* for warning below */
1050 /* assumes no premature commitment */
1051 want = o->op_flags & OPf_WANT;
1052 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1053 || o->op_type == OP_RETURN)
1058 if ((o->op_private & OPpTARGET_MY)
1059 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1061 return scalar(o); /* As if inside SASSIGN */
1064 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1066 switch (o->op_type) {
1068 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1072 if (o->op_flags & OPf_STACKED)
1076 if (o->op_private == 4)
1118 case OP_GETSOCKNAME:
1119 case OP_GETPEERNAME:
1124 case OP_GETPRIORITY:
1147 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1148 useless = OP_DESC(o);
1155 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1156 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1157 useless = "a variable";
1162 if (cSVOPo->op_private & OPpCONST_STRICT)
1163 no_bareword_allowed(o);
1165 if (ckWARN(WARN_VOID)) {
1166 useless = "a constant";
1167 /* the constants 0 and 1 are permitted as they are
1168 conventionally used as dummies in constructs like
1169 1 while some_condition_with_side_effects; */
1170 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1172 else if (SvPOK(sv)) {
1173 /* perl4's way of mixing documentation and code
1174 (before the invention of POD) was based on a
1175 trick to mix nroff and perl code. The trick was
1176 built upon these three nroff macros being used in
1177 void context. The pink camel has the details in
1178 the script wrapman near page 319. */
1179 if (strnEQ(SvPVX(sv), "di", 2) ||
1180 strnEQ(SvPVX(sv), "ds", 2) ||
1181 strnEQ(SvPVX(sv), "ig", 2))
1186 op_null(o); /* don't execute or even remember it */
1190 o->op_type = OP_PREINC; /* pre-increment is faster */
1191 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1195 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1196 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1202 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1207 if (o->op_flags & OPf_STACKED)
1214 if (!(o->op_flags & OPf_KIDS))
1223 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1230 /* all requires must return a boolean value */
1231 o->op_flags &= ~OPf_WANT;
1236 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1237 if (!kPMOP->op_pmreplroot)
1238 deprecate("implicit split to @_");
1242 if (useless && ckWARN(WARN_VOID))
1243 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1248 Perl_listkids(pTHX_ OP *o)
1251 if (o && o->op_flags & OPf_KIDS) {
1252 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1259 Perl_list(pTHX_ OP *o)
1263 /* assumes no premature commitment */
1264 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1265 || o->op_type == OP_RETURN)
1270 if ((o->op_private & OPpTARGET_MY)
1271 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1273 return o; /* As if inside SASSIGN */
1276 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1278 switch (o->op_type) {
1281 list(cBINOPo->op_first);
1286 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1294 if (!(o->op_flags & OPf_KIDS))
1296 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1297 list(cBINOPo->op_first);
1298 return gen_constant_list(o);
1305 kid = cLISTOPo->op_first;
1307 while ((kid = kid->op_sibling)) {
1308 if (kid->op_sibling)
1313 WITH_THR(PL_curcop = &PL_compiling);
1317 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1318 if (kid->op_sibling)
1323 WITH_THR(PL_curcop = &PL_compiling);
1326 /* all requires must return a boolean value */
1327 o->op_flags &= ~OPf_WANT;
1334 Perl_scalarseq(pTHX_ OP *o)
1339 if (o->op_type == OP_LINESEQ ||
1340 o->op_type == OP_SCOPE ||
1341 o->op_type == OP_LEAVE ||
1342 o->op_type == OP_LEAVETRY)
1344 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1345 if (kid->op_sibling) {
1349 PL_curcop = &PL_compiling;
1351 o->op_flags &= ~OPf_PARENS;
1352 if (PL_hints & HINT_BLOCK_SCOPE)
1353 o->op_flags |= OPf_PARENS;
1356 o = newOP(OP_STUB, 0);
1361 S_modkids(pTHX_ OP *o, I32 type)
1364 if (o && o->op_flags & OPf_KIDS) {
1365 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1372 Perl_mod(pTHX_ OP *o, I32 type)
1377 if (!o || PL_error_count)
1380 if ((o->op_private & OPpTARGET_MY)
1381 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1386 switch (o->op_type) {
1391 if (!(o->op_private & (OPpCONST_ARYBASE)))
1393 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1394 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1398 SAVEI32(PL_compiling.cop_arybase);
1399 PL_compiling.cop_arybase = 0;
1401 else if (type == OP_REFGEN)
1404 Perl_croak(aTHX_ "That use of $[ is unsupported");
1407 if (o->op_flags & OPf_PARENS)
1411 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1412 !(o->op_flags & OPf_STACKED)) {
1413 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1414 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1415 assert(cUNOPo->op_first->op_type == OP_NULL);
1416 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1419 else { /* lvalue subroutine call */
1420 o->op_private |= OPpLVAL_INTRO;
1421 PL_modcount = RETURN_UNLIMITED_NUMBER;
1422 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1423 /* Backward compatibility mode: */
1424 o->op_private |= OPpENTERSUB_INARGS;
1427 else { /* Compile-time error message: */
1428 OP *kid = cUNOPo->op_first;
1432 if (kid->op_type == OP_PUSHMARK)
1434 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1436 "panic: unexpected lvalue entersub "
1437 "args: type/targ %ld:%"UVuf,
1438 (long)kid->op_type, (UV)kid->op_targ);
1439 kid = kLISTOP->op_first;
1441 while (kid->op_sibling)
1442 kid = kid->op_sibling;
1443 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1445 if (kid->op_type == OP_METHOD_NAMED
1446 || kid->op_type == OP_METHOD)
1450 NewOp(1101, newop, 1, UNOP);
1451 newop->op_type = OP_RV2CV;
1452 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1453 newop->op_first = Nullop;
1454 newop->op_next = (OP*)newop;
1455 kid->op_sibling = (OP*)newop;
1456 newop->op_private |= OPpLVAL_INTRO;
1460 if (kid->op_type != OP_RV2CV)
1462 "panic: unexpected lvalue entersub "
1463 "entry via type/targ %ld:%"UVuf,
1464 (long)kid->op_type, (UV)kid->op_targ);
1465 kid->op_private |= OPpLVAL_INTRO;
1466 break; /* Postpone until runtime */
1470 kid = kUNOP->op_first;
1471 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL)
1475 "Unexpected constant lvalue entersub "
1476 "entry via type/targ %ld:%"UVuf,
1477 (long)kid->op_type, (UV)kid->op_targ);
1478 if (kid->op_type != OP_GV) {
1479 /* Restore RV2CV to check lvalueness */
1481 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1482 okid->op_next = kid->op_next;
1483 kid->op_next = okid;
1486 okid->op_next = Nullop;
1487 okid->op_type = OP_RV2CV;
1489 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1490 okid->op_private |= OPpLVAL_INTRO;
1494 cv = GvCV(kGVOP_gv);
1504 /* grep, foreach, subcalls, refgen */
1505 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1507 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1508 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1510 : (o->op_type == OP_ENTERSUB
1511 ? "non-lvalue subroutine call"
1513 type ? PL_op_desc[type] : "local"));
1527 case OP_RIGHT_SHIFT:
1536 if (!(o->op_flags & OPf_STACKED))
1542 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1548 if (!type && cUNOPo->op_first->op_type != OP_GV)
1549 Perl_croak(aTHX_ "Can't localize through a reference");
1550 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1551 PL_modcount = RETURN_UNLIMITED_NUMBER;
1552 return o; /* Treat \(@foo) like ordinary list. */
1556 if (scalar_mod_type(o, type))
1558 ref(cUNOPo->op_first, o->op_type);
1562 if (type == OP_LEAVESUBLV)
1563 o->op_private |= OPpMAYBE_LVSUB;
1569 PL_modcount = RETURN_UNLIMITED_NUMBER;
1572 if (!type && cUNOPo->op_first->op_type != OP_GV)
1573 Perl_croak(aTHX_ "Can't localize through a reference");
1574 ref(cUNOPo->op_first, o->op_type);
1578 PL_hints |= HINT_BLOCK_SCOPE;
1588 PL_modcount = RETURN_UNLIMITED_NUMBER;
1589 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1590 return o; /* Treat \(@foo) like ordinary list. */
1591 if (scalar_mod_type(o, type))
1593 if (type == OP_LEAVESUBLV)
1594 o->op_private |= OPpMAYBE_LVSUB;
1599 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1600 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1603 #ifdef USE_5005THREADS
1605 PL_modcount++; /* XXX ??? */
1607 #endif /* USE_5005THREADS */
1613 if (type != OP_SASSIGN)
1617 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1622 if (type == OP_LEAVESUBLV)
1623 o->op_private |= OPpMAYBE_LVSUB;
1625 pad_free(o->op_targ);
1626 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1627 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1628 if (o->op_flags & OPf_KIDS)
1629 mod(cBINOPo->op_first->op_sibling, type);
1634 ref(cBINOPo->op_first, o->op_type);
1635 if (type == OP_ENTERSUB &&
1636 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1637 o->op_private |= OPpLVAL_DEFER;
1638 if (type == OP_LEAVESUBLV)
1639 o->op_private |= OPpMAYBE_LVSUB;
1647 if (o->op_flags & OPf_KIDS)
1648 mod(cLISTOPo->op_last, type);
1652 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1654 else if (!(o->op_flags & OPf_KIDS))
1656 if (o->op_targ != OP_LIST) {
1657 mod(cBINOPo->op_first, type);
1662 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1667 if (type != OP_LEAVESUBLV)
1669 break; /* mod()ing was handled by ck_return() */
1672 /* [20011101.069] File test operators interpret OPf_REF to mean that
1673 their argument is a filehandle; thus \stat(".") should not set
1675 if (type == OP_REFGEN &&
1676 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1679 if (type != OP_LEAVESUBLV)
1680 o->op_flags |= OPf_MOD;
1682 if (type == OP_AASSIGN || type == OP_SASSIGN)
1683 o->op_flags |= OPf_SPECIAL|OPf_REF;
1685 o->op_private |= OPpLVAL_INTRO;
1686 o->op_flags &= ~OPf_SPECIAL;
1687 PL_hints |= HINT_BLOCK_SCOPE;
1689 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1690 && type != OP_LEAVESUBLV)
1691 o->op_flags |= OPf_REF;
1696 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1700 if (o->op_type == OP_RV2GV)
1724 case OP_RIGHT_SHIFT:
1743 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1745 switch (o->op_type) {
1753 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1766 Perl_refkids(pTHX_ OP *o, I32 type)
1769 if (o && o->op_flags & OPf_KIDS) {
1770 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1777 Perl_ref(pTHX_ OP *o, I32 type)
1781 if (!o || PL_error_count)
1784 switch (o->op_type) {
1786 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1787 !(o->op_flags & OPf_STACKED)) {
1788 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1789 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1790 assert(cUNOPo->op_first->op_type == OP_NULL);
1791 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1792 o->op_flags |= OPf_SPECIAL;
1797 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1801 if (type == OP_DEFINED)
1802 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1803 ref(cUNOPo->op_first, o->op_type);
1806 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1807 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1808 : type == OP_RV2HV ? OPpDEREF_HV
1810 o->op_flags |= OPf_MOD;
1815 o->op_flags |= OPf_MOD; /* XXX ??? */
1820 o->op_flags |= OPf_REF;
1823 if (type == OP_DEFINED)
1824 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1825 ref(cUNOPo->op_first, o->op_type);
1830 o->op_flags |= OPf_REF;
1835 if (!(o->op_flags & OPf_KIDS))
1837 ref(cBINOPo->op_first, type);
1841 ref(cBINOPo->op_first, o->op_type);
1842 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1843 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1844 : type == OP_RV2HV ? OPpDEREF_HV
1846 o->op_flags |= OPf_MOD;
1854 if (!(o->op_flags & OPf_KIDS))
1856 ref(cLISTOPo->op_last, type);
1866 S_dup_attrlist(pTHX_ OP *o)
1870 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1871 * where the first kid is OP_PUSHMARK and the remaining ones
1872 * are OP_CONST. We need to push the OP_CONST values.
1874 if (o->op_type == OP_CONST)
1875 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1877 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1878 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1879 if (o->op_type == OP_CONST)
1880 rop = append_elem(OP_LIST, rop,
1881 newSVOP(OP_CONST, o->op_flags,
1882 SvREFCNT_inc(cSVOPo->op_sv)));
1889 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1893 /* fake up C<use attributes $pkg,$rv,@attrs> */
1894 ENTER; /* need to protect against side-effects of 'use' */
1897 stashsv = newSVpv(HvNAME(stash), 0);
1899 stashsv = &PL_sv_no;
1901 #define ATTRSMODULE "attributes"
1903 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1904 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1906 prepend_elem(OP_LIST,
1907 newSVOP(OP_CONST, 0, stashsv),
1908 prepend_elem(OP_LIST,
1909 newSVOP(OP_CONST, 0,
1911 dup_attrlist(attrs))));
1916 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1917 char *attrstr, STRLEN len)
1922 len = strlen(attrstr);
1926 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1928 char *sstr = attrstr;
1929 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1930 attrs = append_elem(OP_LIST, attrs,
1931 newSVOP(OP_CONST, 0,
1932 newSVpvn(sstr, attrstr-sstr)));
1936 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1937 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1938 Nullsv, prepend_elem(OP_LIST,
1939 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1940 prepend_elem(OP_LIST,
1941 newSVOP(OP_CONST, 0,
1947 S_my_kid(pTHX_ OP *o, OP *attrs)
1952 if (!o || PL_error_count)
1956 if (type == OP_LIST) {
1957 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1959 } else if (type == OP_UNDEF) {
1961 } else if (type == OP_RV2SV || /* "our" declaration */
1963 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1965 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1967 PL_in_my_stash = Nullhv;
1968 apply_attrs(GvSTASH(gv),
1969 (type == OP_RV2SV ? GvSV(gv) :
1970 type == OP_RV2AV ? (SV*)GvAV(gv) :
1971 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1974 o->op_private |= OPpOUR_INTRO;
1976 } else if (type != OP_PADSV &&
1979 type != OP_PUSHMARK)
1981 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1983 PL_in_my == KEY_our ? "our" : "my"));
1986 else if (attrs && type != OP_PUSHMARK) {
1992 PL_in_my_stash = Nullhv;
1994 /* check for C<my Dog $spot> when deciding package */
1995 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1996 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1997 stash = SvSTASH(*namesvp);
1999 stash = PL_curstash;
2000 padsv = PAD_SV(o->op_targ);
2001 apply_attrs(stash, padsv, attrs);
2003 o->op_flags |= OPf_MOD;
2004 o->op_private |= OPpLVAL_INTRO;
2009 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2011 if (o->op_flags & OPf_PARENS)
2015 o = my_kid(o, attrs);
2017 PL_in_my_stash = Nullhv;
2022 Perl_my(pTHX_ OP *o)
2024 return my_kid(o, Nullop);
2028 Perl_sawparens(pTHX_ OP *o)
2031 o->op_flags |= OPf_PARENS;
2036 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2040 if (ckWARN(WARN_MISC) &&
2041 (left->op_type == OP_RV2AV ||
2042 left->op_type == OP_RV2HV ||
2043 left->op_type == OP_PADAV ||
2044 left->op_type == OP_PADHV)) {
2045 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2046 right->op_type == OP_TRANS)
2047 ? right->op_type : OP_MATCH];
2048 const char *sample = ((left->op_type == OP_RV2AV ||
2049 left->op_type == OP_PADAV)
2050 ? "@array" : "%hash");
2051 Perl_warner(aTHX_ WARN_MISC,
2052 "Applying %s to %s will act on scalar(%s)",
2053 desc, sample, sample);
2056 if (right->op_type == OP_CONST &&
2057 cSVOPx(right)->op_private & OPpCONST_BARE &&
2058 cSVOPx(right)->op_private & OPpCONST_STRICT)
2060 no_bareword_allowed(right);
2063 if (!(right->op_flags & OPf_STACKED) &&
2064 (right->op_type == OP_MATCH ||
2065 right->op_type == OP_SUBST ||
2066 right->op_type == OP_TRANS)) {
2067 right->op_flags |= OPf_STACKED;
2068 if (right->op_type != OP_MATCH &&
2069 ! (right->op_type == OP_TRANS &&
2070 right->op_private & OPpTRANS_IDENTICAL))
2071 left = mod(left, right->op_type);
2072 if (right->op_type == OP_TRANS)
2073 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2075 o = prepend_elem(right->op_type, scalar(left), right);
2077 return newUNOP(OP_NOT, 0, scalar(o));
2081 return bind_match(type, left,
2082 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2086 Perl_invert(pTHX_ OP *o)
2090 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2091 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2095 Perl_scope(pTHX_ OP *o)
2098 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2099 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2100 o->op_type = OP_LEAVE;
2101 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2104 if (o->op_type == OP_LINESEQ) {
2106 o->op_type = OP_SCOPE;
2107 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2108 kid = ((LISTOP*)o)->op_first;
2109 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2113 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2120 Perl_save_hints(pTHX)
2123 SAVESPTR(GvHV(PL_hintgv));
2124 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2125 SAVEFREESV(GvHV(PL_hintgv));
2129 Perl_block_start(pTHX_ int full)
2131 int retval = PL_savestack_ix;
2133 SAVEI32(PL_comppad_name_floor);
2134 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2136 PL_comppad_name_fill = PL_comppad_name_floor;
2137 if (PL_comppad_name_floor < 0)
2138 PL_comppad_name_floor = 0;
2139 SAVEI32(PL_min_intro_pending);
2140 SAVEI32(PL_max_intro_pending);
2141 PL_min_intro_pending = 0;
2142 SAVEI32(PL_comppad_name_fill);
2143 SAVEI32(PL_padix_floor);
2144 PL_padix_floor = PL_padix;
2145 PL_pad_reset_pending = FALSE;
2147 PL_hints &= ~HINT_BLOCK_SCOPE;
2148 SAVESPTR(PL_compiling.cop_warnings);
2149 if (! specialWARN(PL_compiling.cop_warnings)) {
2150 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2151 SAVEFREESV(PL_compiling.cop_warnings) ;
2153 SAVESPTR(PL_compiling.cop_io);
2154 if (! specialCopIO(PL_compiling.cop_io)) {
2155 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2156 SAVEFREESV(PL_compiling.cop_io) ;
2162 Perl_block_end(pTHX_ I32 floor, OP *seq)
2164 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2165 line_t copline = PL_copline;
2166 /* there should be a nextstate in every block */
2167 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2168 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2170 PL_pad_reset_pending = FALSE;
2171 PL_compiling.op_private = PL_hints;
2173 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2174 pad_leavemy(PL_comppad_name_fill);
2182 #ifdef USE_5005THREADS
2183 OP *o = newOP(OP_THREADSV, 0);
2184 o->op_targ = find_threadsv("_");
2187 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2188 #endif /* USE_5005THREADS */
2192 Perl_newPROG(pTHX_ OP *o)
2197 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2198 ((PL_in_eval & EVAL_KEEPERR)
2199 ? OPf_SPECIAL : 0), o);
2200 PL_eval_start = linklist(PL_eval_root);
2201 PL_eval_root->op_private |= OPpREFCOUNTED;
2202 OpREFCNT_set(PL_eval_root, 1);
2203 PL_eval_root->op_next = 0;
2204 CALL_PEEP(PL_eval_start);
2209 PL_main_root = scope(sawparens(scalarvoid(o)));
2210 PL_curcop = &PL_compiling;
2211 PL_main_start = LINKLIST(PL_main_root);
2212 PL_main_root->op_private |= OPpREFCOUNTED;
2213 OpREFCNT_set(PL_main_root, 1);
2214 PL_main_root->op_next = 0;
2215 CALL_PEEP(PL_main_start);
2218 /* Register with debugger */
2220 CV *cv = get_cv("DB::postponed", FALSE);
2224 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2226 call_sv((SV*)cv, G_DISCARD);
2233 Perl_localize(pTHX_ OP *o, I32 lex)
2235 if (o->op_flags & OPf_PARENS)
2238 if (ckWARN(WARN_PARENTHESIS)
2239 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2241 char *s = PL_bufptr;
2243 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2246 if (*s == ';' || *s == '=')
2247 Perl_warner(aTHX_ WARN_PARENTHESIS,
2248 "Parentheses missing around \"%s\" list",
2249 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2255 o = mod(o, OP_NULL); /* a bit kludgey */
2257 PL_in_my_stash = Nullhv;
2262 Perl_jmaybe(pTHX_ OP *o)
2264 if (o->op_type == OP_LIST) {
2266 #ifdef USE_5005THREADS
2267 o2 = newOP(OP_THREADSV, 0);
2268 o2->op_targ = find_threadsv(";");
2270 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2271 #endif /* USE_5005THREADS */
2272 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2278 Perl_fold_constants(pTHX_ register OP *o)
2281 I32 type = o->op_type;
2284 if (PL_opargs[type] & OA_RETSCALAR)
2286 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2287 o->op_targ = pad_alloc(type, SVs_PADTMP);
2289 /* integerize op, unless it happens to be C<-foo>.
2290 * XXX should pp_i_negate() do magic string negation instead? */
2291 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2292 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2293 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2295 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2298 if (!(PL_opargs[type] & OA_FOLDCONST))
2303 /* XXX might want a ck_negate() for this */
2304 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2316 /* XXX what about the numeric ops? */
2317 if (PL_hints & HINT_LOCALE)
2322 goto nope; /* Don't try to run w/ errors */
2324 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2325 if ((curop->op_type != OP_CONST ||
2326 (curop->op_private & OPpCONST_BARE)) &&
2327 curop->op_type != OP_LIST &&
2328 curop->op_type != OP_SCALAR &&
2329 curop->op_type != OP_NULL &&
2330 curop->op_type != OP_PUSHMARK)
2336 curop = LINKLIST(o);
2340 sv = *(PL_stack_sp--);
2341 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2342 pad_swipe(o->op_targ);
2343 else if (SvTEMP(sv)) { /* grab mortal temp? */
2344 (void)SvREFCNT_inc(sv);
2348 if (type == OP_RV2GV)
2349 return newGVOP(OP_GV, 0, (GV*)sv);
2351 /* try to smush double to int, but don't smush -2.0 to -2 */
2352 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2355 #ifdef PERL_PRESERVE_IVUV
2356 /* Only bother to attempt to fold to IV if
2357 most operators will benefit */
2361 return newSVOP(OP_CONST, 0, sv);
2365 if (!(PL_opargs[type] & OA_OTHERINT))
2368 if (!(PL_hints & HINT_INTEGER)) {
2369 if (type == OP_MODULO
2370 || type == OP_DIVIDE
2371 || !(o->op_flags & OPf_KIDS))
2376 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2377 if (curop->op_type == OP_CONST) {
2378 if (SvIOK(((SVOP*)curop)->op_sv))
2382 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2386 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2393 Perl_gen_constant_list(pTHX_ register OP *o)
2396 I32 oldtmps_floor = PL_tmps_floor;
2400 return o; /* Don't attempt to run with errors */
2402 PL_op = curop = LINKLIST(o);
2409 PL_tmps_floor = oldtmps_floor;
2411 o->op_type = OP_RV2AV;
2412 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2413 curop = ((UNOP*)o)->op_first;
2414 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2421 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2423 if (!o || o->op_type != OP_LIST)
2424 o = newLISTOP(OP_LIST, 0, o, Nullop);
2426 o->op_flags &= ~OPf_WANT;
2428 if (!(PL_opargs[type] & OA_MARK))
2429 op_null(cLISTOPo->op_first);
2432 o->op_ppaddr = PL_ppaddr[type];
2433 o->op_flags |= flags;
2435 o = CHECKOP(type, o);
2436 if (o->op_type != type)
2439 return fold_constants(o);
2442 /* List constructors */
2445 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2453 if (first->op_type != type
2454 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2456 return newLISTOP(type, 0, first, last);
2459 if (first->op_flags & OPf_KIDS)
2460 ((LISTOP*)first)->op_last->op_sibling = last;
2462 first->op_flags |= OPf_KIDS;
2463 ((LISTOP*)first)->op_first = last;
2465 ((LISTOP*)first)->op_last = last;
2470 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2478 if (first->op_type != type)
2479 return prepend_elem(type, (OP*)first, (OP*)last);
2481 if (last->op_type != type)
2482 return append_elem(type, (OP*)first, (OP*)last);
2484 first->op_last->op_sibling = last->op_first;
2485 first->op_last = last->op_last;
2486 first->op_flags |= (last->op_flags & OPf_KIDS);
2488 #ifdef PL_OP_SLAB_ALLOC
2496 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2504 if (last->op_type == type) {
2505 if (type == OP_LIST) { /* already a PUSHMARK there */
2506 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2507 ((LISTOP*)last)->op_first->op_sibling = first;
2508 if (!(first->op_flags & OPf_PARENS))
2509 last->op_flags &= ~OPf_PARENS;
2512 if (!(last->op_flags & OPf_KIDS)) {
2513 ((LISTOP*)last)->op_last = first;
2514 last->op_flags |= OPf_KIDS;
2516 first->op_sibling = ((LISTOP*)last)->op_first;
2517 ((LISTOP*)last)->op_first = first;
2519 last->op_flags |= OPf_KIDS;
2523 return newLISTOP(type, 0, first, last);
2529 Perl_newNULLLIST(pTHX)
2531 return newOP(OP_STUB, 0);
2535 Perl_force_list(pTHX_ OP *o)
2537 if (!o || o->op_type != OP_LIST)
2538 o = newLISTOP(OP_LIST, 0, o, Nullop);
2544 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2548 NewOp(1101, listop, 1, LISTOP);
2550 listop->op_type = type;
2551 listop->op_ppaddr = PL_ppaddr[type];
2554 listop->op_flags = flags;
2558 else if (!first && last)
2561 first->op_sibling = last;
2562 listop->op_first = first;
2563 listop->op_last = last;
2564 if (type == OP_LIST) {
2566 pushop = newOP(OP_PUSHMARK, 0);
2567 pushop->op_sibling = first;
2568 listop->op_first = pushop;
2569 listop->op_flags |= OPf_KIDS;
2571 listop->op_last = pushop;
2578 Perl_newOP(pTHX_ I32 type, I32 flags)
2581 NewOp(1101, o, 1, OP);
2583 o->op_ppaddr = PL_ppaddr[type];
2584 o->op_flags = flags;
2587 o->op_private = 0 + (flags >> 8);
2588 if (PL_opargs[type] & OA_RETSCALAR)
2590 if (PL_opargs[type] & OA_TARGET)
2591 o->op_targ = pad_alloc(type, SVs_PADTMP);
2592 return CHECKOP(type, o);
2596 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2601 first = newOP(OP_STUB, 0);
2602 if (PL_opargs[type] & OA_MARK)
2603 first = force_list(first);
2605 NewOp(1101, unop, 1, UNOP);
2606 unop->op_type = type;
2607 unop->op_ppaddr = PL_ppaddr[type];
2608 unop->op_first = first;
2609 unop->op_flags = flags | OPf_KIDS;
2610 unop->op_private = 1 | (flags >> 8);
2611 unop = (UNOP*) CHECKOP(type, unop);
2615 return fold_constants((OP *) unop);
2619 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2622 NewOp(1101, binop, 1, BINOP);
2625 first = newOP(OP_NULL, 0);
2627 binop->op_type = type;
2628 binop->op_ppaddr = PL_ppaddr[type];
2629 binop->op_first = first;
2630 binop->op_flags = flags | OPf_KIDS;
2633 binop->op_private = 1 | (flags >> 8);
2636 binop->op_private = 2 | (flags >> 8);
2637 first->op_sibling = last;
2640 binop = (BINOP*)CHECKOP(type, binop);
2641 if (binop->op_next || binop->op_type != type)
2644 binop->op_last = binop->op_first->op_sibling;
2646 return fold_constants((OP *)binop);
2650 uvcompare(const void *a, const void *b)
2652 if (*((UV *)a) < (*(UV *)b))
2654 if (*((UV *)a) > (*(UV *)b))
2656 if (*((UV *)a+1) < (*(UV *)b+1))
2658 if (*((UV *)a+1) > (*(UV *)b+1))
2664 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2666 SV *tstr = ((SVOP*)expr)->op_sv;
2667 SV *rstr = ((SVOP*)repl)->op_sv;
2670 U8 *t = (U8*)SvPV(tstr, tlen);
2671 U8 *r = (U8*)SvPV(rstr, rlen);
2678 register short *tbl;
2680 PL_hints |= HINT_BLOCK_SCOPE;
2681 complement = o->op_private & OPpTRANS_COMPLEMENT;
2682 del = o->op_private & OPpTRANS_DELETE;
2683 squash = o->op_private & OPpTRANS_SQUASH;
2686 o->op_private |= OPpTRANS_FROM_UTF;
2689 o->op_private |= OPpTRANS_TO_UTF;
2691 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2692 SV* listsv = newSVpvn("# comment\n",10);
2694 U8* tend = t + tlen;
2695 U8* rend = r + rlen;
2709 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2710 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2716 tsave = t = bytes_to_utf8(t, &len);
2719 if (!to_utf && rlen) {
2721 rsave = r = bytes_to_utf8(r, &len);
2725 /* There are several snags with this code on EBCDIC:
2726 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2727 2. scan_const() in toke.c has encoded chars in native encoding which makes
2728 ranges at least in EBCDIC 0..255 range the bottom odd.
2732 U8 tmpbuf[UTF8_MAXLEN+1];
2735 New(1109, cp, 2*tlen, UV);
2737 transv = newSVpvn("",0);
2739 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2741 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2743 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2747 cp[2*i+1] = cp[2*i];
2751 qsort(cp, i, 2*sizeof(UV), uvcompare);
2752 for (j = 0; j < i; j++) {
2754 diff = val - nextmin;
2756 t = uvuni_to_utf8(tmpbuf,nextmin);
2757 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2759 U8 range_mark = UTF_TO_NATIVE(0xff);
2760 t = uvuni_to_utf8(tmpbuf, val - 1);
2761 sv_catpvn(transv, (char *)&range_mark, 1);
2762 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2769 t = uvuni_to_utf8(tmpbuf,nextmin);
2770 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2772 U8 range_mark = UTF_TO_NATIVE(0xff);
2773 sv_catpvn(transv, (char *)&range_mark, 1);
2775 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2776 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2777 t = (U8*)SvPVX(transv);
2778 tlen = SvCUR(transv);
2782 else if (!rlen && !del) {
2783 r = t; rlen = tlen; rend = tend;
2786 if ((!rlen && !del) || t == r ||
2787 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2789 o->op_private |= OPpTRANS_IDENTICAL;
2793 while (t < tend || tfirst <= tlast) {
2794 /* see if we need more "t" chars */
2795 if (tfirst > tlast) {
2796 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2798 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2800 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2807 /* now see if we need more "r" chars */
2808 if (rfirst > rlast) {
2810 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2812 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2814 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2823 rfirst = rlast = 0xffffffff;
2827 /* now see which range will peter our first, if either. */
2828 tdiff = tlast - tfirst;
2829 rdiff = rlast - rfirst;
2836 if (rfirst == 0xffffffff) {
2837 diff = tdiff; /* oops, pretend rdiff is infinite */
2839 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2840 (long)tfirst, (long)tlast);
2842 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2846 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2847 (long)tfirst, (long)(tfirst + diff),
2850 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2851 (long)tfirst, (long)rfirst);
2853 if (rfirst + diff > max)
2854 max = rfirst + diff;
2856 grows = (tfirst < rfirst &&
2857 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2869 else if (max > 0xff)
2874 Safefree(cPVOPo->op_pv);
2875 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2876 SvREFCNT_dec(listsv);
2878 SvREFCNT_dec(transv);
2880 if (!del && havefinal && rlen)
2881 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2882 newSVuv((UV)final), 0);
2885 o->op_private |= OPpTRANS_GROWS;
2897 tbl = (short*)cPVOPo->op_pv;
2899 Zero(tbl, 256, short);
2900 for (i = 0; i < tlen; i++)
2902 for (i = 0, j = 0; i < 256; i++) {
2913 if (i < 128 && r[j] >= 128)
2923 o->op_private |= OPpTRANS_IDENTICAL;
2928 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2929 tbl[0x100] = rlen - j;
2930 for (i=0; i < rlen - j; i++)
2931 tbl[0x101+i] = r[j+i];
2935 if (!rlen && !del) {
2938 o->op_private |= OPpTRANS_IDENTICAL;
2940 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2941 o->op_private |= OPpTRANS_IDENTICAL;
2943 for (i = 0; i < 256; i++)
2945 for (i = 0, j = 0; i < tlen; i++,j++) {
2948 if (tbl[t[i]] == -1)
2954 if (tbl[t[i]] == -1) {
2955 if (t[i] < 128 && r[j] >= 128)
2962 o->op_private |= OPpTRANS_GROWS;
2970 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2974 NewOp(1101, pmop, 1, PMOP);
2975 pmop->op_type = type;
2976 pmop->op_ppaddr = PL_ppaddr[type];
2977 pmop->op_flags = flags;
2978 pmop->op_private = 0 | (flags >> 8);
2980 if (PL_hints & HINT_RE_TAINT)
2981 pmop->op_pmpermflags |= PMf_RETAINT;
2982 if (PL_hints & HINT_LOCALE)
2983 pmop->op_pmpermflags |= PMf_LOCALE;
2984 pmop->op_pmflags = pmop->op_pmpermflags;
2989 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2990 repointer = av_pop((AV*)PL_regex_pad[0]);
2991 pmop->op_pmoffset = SvIV(repointer);
2992 SvREPADTMP_off(repointer);
2993 sv_setiv(repointer,0);
2995 repointer = newSViv(0);
2996 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2997 pmop->op_pmoffset = av_len(PL_regex_padav);
2998 PL_regex_pad = AvARRAY(PL_regex_padav);
3003 /* link into pm list */
3004 if (type != OP_TRANS && PL_curstash) {
3005 pmop->op_pmnext = HvPMROOT(PL_curstash);
3006 HvPMROOT(PL_curstash) = pmop;
3007 PmopSTASH_set(pmop,PL_curstash);
3014 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3018 I32 repl_has_vars = 0;
3020 if (o->op_type == OP_TRANS)
3021 return pmtrans(o, expr, repl);
3023 PL_hints |= HINT_BLOCK_SCOPE;
3026 if (expr->op_type == OP_CONST) {
3028 SV *pat = ((SVOP*)expr)->op_sv;
3029 char *p = SvPV(pat, plen);
3030 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3031 sv_setpvn(pat, "\\s+", 3);
3032 p = SvPV(pat, plen);
3033 pm->op_pmflags |= PMf_SKIPWHITE;
3035 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3036 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3037 pm->op_pmflags |= PMf_WHITE;
3041 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3042 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3044 : OP_REGCMAYBE),0,expr);
3046 NewOp(1101, rcop, 1, LOGOP);
3047 rcop->op_type = OP_REGCOMP;
3048 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3049 rcop->op_first = scalar(expr);
3050 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3051 ? (OPf_SPECIAL | OPf_KIDS)
3053 rcop->op_private = 1;
3056 /* establish postfix order */
3057 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3059 rcop->op_next = expr;
3060 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3063 rcop->op_next = LINKLIST(expr);
3064 expr->op_next = (OP*)rcop;
3067 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3072 if (pm->op_pmflags & PMf_EVAL) {
3074 if (CopLINE(PL_curcop) < PL_multi_end)
3075 CopLINE_set(PL_curcop, PL_multi_end);
3077 #ifdef USE_5005THREADS
3078 else if (repl->op_type == OP_THREADSV
3079 && strchr("&`'123456789+",
3080 PL_threadsv_names[repl->op_targ]))
3084 #endif /* USE_5005THREADS */
3085 else if (repl->op_type == OP_CONST)
3089 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3090 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3091 #ifdef USE_5005THREADS
3092 if (curop->op_type == OP_THREADSV) {
3094 if (strchr("&`'123456789+", curop->op_private))
3098 if (curop->op_type == OP_GV) {
3099 GV *gv = cGVOPx_gv(curop);
3101 if (strchr("&`'123456789+", *GvENAME(gv)))
3104 #endif /* USE_5005THREADS */
3105 else if (curop->op_type == OP_RV2CV)
3107 else if (curop->op_type == OP_RV2SV ||
3108 curop->op_type == OP_RV2AV ||
3109 curop->op_type == OP_RV2HV ||
3110 curop->op_type == OP_RV2GV) {
3111 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3114 else if (curop->op_type == OP_PADSV ||
3115 curop->op_type == OP_PADAV ||
3116 curop->op_type == OP_PADHV ||
3117 curop->op_type == OP_PADANY) {
3120 else if (curop->op_type == OP_PUSHRE)
3121 ; /* Okay here, dangerous in newASSIGNOP */
3131 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3132 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3133 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3134 prepend_elem(o->op_type, scalar(repl), o);
3137 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3138 pm->op_pmflags |= PMf_MAYBE_CONST;
3139 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3141 NewOp(1101, rcop, 1, LOGOP);
3142 rcop->op_type = OP_SUBSTCONT;
3143 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3144 rcop->op_first = scalar(repl);
3145 rcop->op_flags |= OPf_KIDS;
3146 rcop->op_private = 1;
3149 /* establish postfix order */
3150 rcop->op_next = LINKLIST(repl);
3151 repl->op_next = (OP*)rcop;
3153 pm->op_pmreplroot = scalar((OP*)rcop);
3154 pm->op_pmreplstart = LINKLIST(rcop);
3163 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3166 NewOp(1101, svop, 1, SVOP);
3167 svop->op_type = type;
3168 svop->op_ppaddr = PL_ppaddr[type];
3170 svop->op_next = (OP*)svop;
3171 svop->op_flags = flags;
3172 if (PL_opargs[type] & OA_RETSCALAR)
3174 if (PL_opargs[type] & OA_TARGET)
3175 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3176 return CHECKOP(type, svop);
3180 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3183 NewOp(1101, padop, 1, PADOP);
3184 padop->op_type = type;
3185 padop->op_ppaddr = PL_ppaddr[type];
3186 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3187 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3188 PL_curpad[padop->op_padix] = sv;
3190 padop->op_next = (OP*)padop;
3191 padop->op_flags = flags;
3192 if (PL_opargs[type] & OA_RETSCALAR)
3194 if (PL_opargs[type] & OA_TARGET)
3195 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3196 return CHECKOP(type, padop);
3200 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3204 return newPADOP(type, flags, SvREFCNT_inc(gv));
3206 return newSVOP(type, flags, SvREFCNT_inc(gv));
3211 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3214 NewOp(1101, pvop, 1, PVOP);
3215 pvop->op_type = type;
3216 pvop->op_ppaddr = PL_ppaddr[type];
3218 pvop->op_next = (OP*)pvop;
3219 pvop->op_flags = flags;
3220 if (PL_opargs[type] & OA_RETSCALAR)
3222 if (PL_opargs[type] & OA_TARGET)
3223 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3224 return CHECKOP(type, pvop);
3228 Perl_package(pTHX_ OP *o)
3232 save_hptr(&PL_curstash);
3233 save_item(PL_curstname);
3238 name = SvPV(sv, len);
3239 PL_curstash = gv_stashpvn(name,len,TRUE);
3240 sv_setpvn(PL_curstname, name, len);
3244 deprecate("\"package\" with no arguments");
3245 sv_setpv(PL_curstname,"<none>");
3246 PL_curstash = Nullhv;
3248 PL_hints |= HINT_BLOCK_SCOPE;
3249 PL_copline = NOLINE;
3254 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3259 char *packname = Nullch;
3263 if (id->op_type != OP_CONST)
3264 Perl_croak(aTHX_ "Module name must be constant");
3268 if (version != Nullop) {
3269 SV *vesv = ((SVOP*)version)->op_sv;
3271 if (arg == Nullop && !SvNIOKp(vesv)) {
3278 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3279 Perl_croak(aTHX_ "Version number must be constant number");
3281 /* Make copy of id so we don't free it twice */
3282 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3284 /* Fake up a method call to VERSION */
3285 meth = newSVpvn("VERSION",7);
3286 sv_upgrade(meth, SVt_PVIV);
3287 (void)SvIOK_on(meth);
3288 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3289 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3290 append_elem(OP_LIST,
3291 prepend_elem(OP_LIST, pack, list(version)),
3292 newSVOP(OP_METHOD_NAMED, 0, meth)));
3296 /* Fake up an import/unimport */
3297 if (arg && arg->op_type == OP_STUB)
3298 imop = arg; /* no import on explicit () */
3299 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3300 imop = Nullop; /* use 5.0; */
3305 /* Make copy of id so we don't free it twice */
3306 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3308 /* Fake up a method call to import/unimport */
3309 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3310 (void)SvUPGRADE(meth, SVt_PVIV);
3311 (void)SvIOK_on(meth);
3312 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3313 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3314 append_elem(OP_LIST,
3315 prepend_elem(OP_LIST, pack, list(arg)),
3316 newSVOP(OP_METHOD_NAMED, 0, meth)));
3319 if (ckWARN(WARN_MISC) &&
3320 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3321 SvPOK(packsv = ((SVOP*)id)->op_sv))
3323 /* BEGIN will free the ops, so we need to make a copy */
3324 packlen = SvCUR(packsv);
3325 packname = savepvn(SvPVX(packsv), packlen);
3328 /* Fake up the BEGIN {}, which does its thing immediately. */
3330 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3333 append_elem(OP_LINESEQ,
3334 append_elem(OP_LINESEQ,
3335 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3336 newSTATEOP(0, Nullch, veop)),
3337 newSTATEOP(0, Nullch, imop) ));
3340 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3341 Perl_warner(aTHX_ WARN_MISC,
3342 "Package `%s' not found "
3343 "(did you use the incorrect case?)", packname);
3348 PL_hints |= HINT_BLOCK_SCOPE;
3349 PL_copline = NOLINE;
3354 =for apidoc load_module
3356 Loads the module whose name is pointed to by the string part of name.
3357 Note that the actual module name, not its filename, should be given.
3358 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3359 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3360 (or 0 for no flags). ver, if specified, provides version semantics
3361 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3362 arguments can be used to specify arguments to the module's import()
3363 method, similar to C<use Foo::Bar VERSION LIST>.
3368 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3371 va_start(args, ver);
3372 vload_module(flags, name, ver, &args);
3376 #ifdef PERL_IMPLICIT_CONTEXT
3378 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3382 va_start(args, ver);
3383 vload_module(flags, name, ver, &args);
3389 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3391 OP *modname, *veop, *imop;
3393 modname = newSVOP(OP_CONST, 0, name);
3394 modname->op_private |= OPpCONST_BARE;
3396 veop = newSVOP(OP_CONST, 0, ver);
3400 if (flags & PERL_LOADMOD_NOIMPORT) {
3401 imop = sawparens(newNULLLIST());
3403 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3404 imop = va_arg(*args, OP*);
3409 sv = va_arg(*args, SV*);
3411 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3412 sv = va_arg(*args, SV*);
3416 line_t ocopline = PL_copline;
3417 int oexpect = PL_expect;
3419 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3420 veop, modname, imop);
3421 PL_expect = oexpect;
3422 PL_copline = ocopline;
3427 Perl_dofile(pTHX_ OP *term)
3432 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3433 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3434 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3436 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3437 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3438 append_elem(OP_LIST, term,
3439 scalar(newUNOP(OP_RV2CV, 0,
3444 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3450 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3452 return newBINOP(OP_LSLICE, flags,
3453 list(force_list(subscript)),
3454 list(force_list(listval)) );
3458 S_list_assignment(pTHX_ register OP *o)
3463 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3464 o = cUNOPo->op_first;
3466 if (o->op_type == OP_COND_EXPR) {
3467 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3468 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3473 yyerror("Assignment to both a list and a scalar");
3477 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3478 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3479 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3482 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3485 if (o->op_type == OP_RV2SV)
3492 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3497 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3498 return newLOGOP(optype, 0,
3499 mod(scalar(left), optype),
3500 newUNOP(OP_SASSIGN, 0, scalar(right)));
3503 return newBINOP(optype, OPf_STACKED,
3504 mod(scalar(left), optype), scalar(right));
3508 if (list_assignment(left)) {
3512 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3513 left = mod(left, OP_AASSIGN);
3521 curop = list(force_list(left));
3522 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3523 o->op_private = 0 | (flags >> 8);
3524 for (curop = ((LISTOP*)curop)->op_first;
3525 curop; curop = curop->op_sibling)
3527 if (curop->op_type == OP_RV2HV &&
3528 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3529 o->op_private |= OPpASSIGN_HASH;
3533 if (!(left->op_private & OPpLVAL_INTRO)) {
3536 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3537 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3538 if (curop->op_type == OP_GV) {
3539 GV *gv = cGVOPx_gv(curop);
3540 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3542 SvCUR(gv) = PL_generation;
3544 else if (curop->op_type == OP_PADSV ||
3545 curop->op_type == OP_PADAV ||
3546 curop->op_type == OP_PADHV ||
3547 curop->op_type == OP_PADANY) {
3548 SV **svp = AvARRAY(PL_comppad_name);
3549 SV *sv = svp[curop->op_targ];
3550 if (SvCUR(sv) == PL_generation)
3552 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3554 else if (curop->op_type == OP_RV2CV)
3556 else if (curop->op_type == OP_RV2SV ||
3557 curop->op_type == OP_RV2AV ||
3558 curop->op_type == OP_RV2HV ||
3559 curop->op_type == OP_RV2GV) {
3560 if (lastop->op_type != OP_GV) /* funny deref? */
3563 else if (curop->op_type == OP_PUSHRE) {
3564 if (((PMOP*)curop)->op_pmreplroot) {
3566 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3568 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3570 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3572 SvCUR(gv) = PL_generation;
3581 o->op_private |= OPpASSIGN_COMMON;
3583 if (right && right->op_type == OP_SPLIT) {
3585 if ((tmpop = ((LISTOP*)right)->op_first) &&
3586 tmpop->op_type == OP_PUSHRE)
3588 PMOP *pm = (PMOP*)tmpop;
3589 if (left->op_type == OP_RV2AV &&
3590 !(left->op_private & OPpLVAL_INTRO) &&
3591 !(o->op_private & OPpASSIGN_COMMON) )
3593 tmpop = ((UNOP*)left)->op_first;
3594 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3596 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3597 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3599 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3600 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3602 pm->op_pmflags |= PMf_ONCE;
3603 tmpop = cUNOPo->op_first; /* to list (nulled) */
3604 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3605 tmpop->op_sibling = Nullop; /* don't free split */
3606 right->op_next = tmpop->op_next; /* fix starting loc */
3607 op_free(o); /* blow off assign */
3608 right->op_flags &= ~OPf_WANT;
3609 /* "I don't know and I don't care." */
3614 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3615 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3617 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3619 sv_setiv(sv, PL_modcount+1);
3627 right = newOP(OP_UNDEF, 0);
3628 if (right->op_type == OP_READLINE) {
3629 right->op_flags |= OPf_STACKED;
3630 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3633 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3634 o = newBINOP(OP_SASSIGN, flags,
3635 scalar(right), mod(scalar(left), OP_SASSIGN) );
3647 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3649 U32 seq = intro_my();
3652 NewOp(1101, cop, 1, COP);
3653 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3654 cop->op_type = OP_DBSTATE;
3655 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3658 cop->op_type = OP_NEXTSTATE;
3659 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3661 cop->op_flags = flags;
3662 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3664 cop->op_private |= NATIVE_HINTS;
3666 PL_compiling.op_private = cop->op_private;
3667 cop->op_next = (OP*)cop;
3670 cop->cop_label = label;
3671 PL_hints |= HINT_BLOCK_SCOPE;
3674 cop->cop_arybase = PL_curcop->cop_arybase;
3675 if (specialWARN(PL_curcop->cop_warnings))
3676 cop->cop_warnings = PL_curcop->cop_warnings ;
3678 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3679 if (specialCopIO(PL_curcop->cop_io))
3680 cop->cop_io = PL_curcop->cop_io;
3682 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3685 if (PL_copline == NOLINE)
3686 CopLINE_set(cop, CopLINE(PL_curcop));
3688 CopLINE_set(cop, PL_copline);
3689 PL_copline = NOLINE;
3692 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3694 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3696 CopSTASH_set(cop, PL_curstash);
3698 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3699 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3700 if (svp && *svp != &PL_sv_undef ) {
3701 (void)SvIOK_on(*svp);
3702 SvIVX(*svp) = PTR2IV(cop);
3706 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3709 /* "Introduce" my variables to visible status. */
3717 if (! PL_min_intro_pending)
3718 return PL_cop_seqmax;
3720 svp = AvARRAY(PL_comppad_name);
3721 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3722 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3723 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3724 SvNVX(sv) = (NV)PL_cop_seqmax;
3727 PL_min_intro_pending = 0;
3728 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3729 return PL_cop_seqmax++;
3733 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3735 return new_logop(type, flags, &first, &other);
3739 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3743 OP *first = *firstp;
3744 OP *other = *otherp;
3746 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3747 return newBINOP(type, flags, scalar(first), scalar(other));
3749 scalarboolean(first);
3750 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3751 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3752 if (type == OP_AND || type == OP_OR) {
3758 first = *firstp = cUNOPo->op_first;
3760 first->op_next = o->op_next;
3761 cUNOPo->op_first = Nullop;
3765 if (first->op_type == OP_CONST) {
3766 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3767 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3768 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3779 else if (first->op_type == OP_WANTARRAY) {
3785 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3786 OP *k1 = ((UNOP*)first)->op_first;
3787 OP *k2 = k1->op_sibling;
3789 switch (first->op_type)
3792 if (k2 && k2->op_type == OP_READLINE
3793 && (k2->op_flags & OPf_STACKED)
3794 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3796 warnop = k2->op_type;
3801 if (k1->op_type == OP_READDIR
3802 || k1->op_type == OP_GLOB
3803 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3804 || k1->op_type == OP_EACH)
3806 warnop = ((k1->op_type == OP_NULL)
3807 ? k1->op_targ : k1->op_type);
3812 line_t oldline = CopLINE(PL_curcop);
3813 CopLINE_set(PL_curcop, PL_copline);
3814 Perl_warner(aTHX_ WARN_MISC,
3815 "Value of %s%s can be \"0\"; test with defined()",
3817 ((warnop == OP_READLINE || warnop == OP_GLOB)
3818 ? " construct" : "() operator"));
3819 CopLINE_set(PL_curcop, oldline);
3826 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3827 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3829 NewOp(1101, logop, 1, LOGOP);
3831 logop->op_type = type;
3832 logop->op_ppaddr = PL_ppaddr[type];
3833 logop->op_first = first;
3834 logop->op_flags = flags | OPf_KIDS;
3835 logop->op_other = LINKLIST(other);
3836 logop->op_private = 1 | (flags >> 8);
3838 /* establish postfix order */
3839 logop->op_next = LINKLIST(first);
3840 first->op_next = (OP*)logop;
3841 first->op_sibling = other;
3843 o = newUNOP(OP_NULL, 0, (OP*)logop);
3850 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3857 return newLOGOP(OP_AND, 0, first, trueop);
3859 return newLOGOP(OP_OR, 0, first, falseop);
3861 scalarboolean(first);
3862 if (first->op_type == OP_CONST) {
3863 if (SvTRUE(((SVOP*)first)->op_sv)) {
3874 else if (first->op_type == OP_WANTARRAY) {
3878 NewOp(1101, logop, 1, LOGOP);
3879 logop->op_type = OP_COND_EXPR;
3880 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3881 logop->op_first = first;
3882 logop->op_flags = flags | OPf_KIDS;
3883 logop->op_private = 1 | (flags >> 8);
3884 logop->op_other = LINKLIST(trueop);
3885 logop->op_next = LINKLIST(falseop);
3888 /* establish postfix order */
3889 start = LINKLIST(first);
3890 first->op_next = (OP*)logop;
3892 first->op_sibling = trueop;
3893 trueop->op_sibling = falseop;
3894 o = newUNOP(OP_NULL, 0, (OP*)logop);
3896 trueop->op_next = falseop->op_next = o;
3903 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3911 NewOp(1101, range, 1, LOGOP);
3913 range->op_type = OP_RANGE;
3914 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3915 range->op_first = left;
3916 range->op_flags = OPf_KIDS;
3917 leftstart = LINKLIST(left);
3918 range->op_other = LINKLIST(right);
3919 range->op_private = 1 | (flags >> 8);
3921 left->op_sibling = right;
3923 range->op_next = (OP*)range;
3924 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3925 flop = newUNOP(OP_FLOP, 0, flip);
3926 o = newUNOP(OP_NULL, 0, flop);
3928 range->op_next = leftstart;
3930 left->op_next = flip;
3931 right->op_next = flop;
3933 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3934 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3935 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3936 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3938 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3939 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3942 if (!flip->op_private || !flop->op_private)
3943 linklist(o); /* blow off optimizer unless constant */
3949 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3953 int once = block && block->op_flags & OPf_SPECIAL &&
3954 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3957 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3958 return block; /* do {} while 0 does once */
3959 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3960 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3961 expr = newUNOP(OP_DEFINED, 0,
3962 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3963 } else if (expr->op_flags & OPf_KIDS) {
3964 OP *k1 = ((UNOP*)expr)->op_first;
3965 OP *k2 = (k1) ? k1->op_sibling : NULL;
3966 switch (expr->op_type) {
3968 if (k2 && k2->op_type == OP_READLINE
3969 && (k2->op_flags & OPf_STACKED)
3970 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3971 expr = newUNOP(OP_DEFINED, 0, expr);
3975 if (k1->op_type == OP_READDIR
3976 || k1->op_type == OP_GLOB
3977 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3978 || k1->op_type == OP_EACH)
3979 expr = newUNOP(OP_DEFINED, 0, expr);
3985 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3986 o = new_logop(OP_AND, 0, &expr, &listop);
3989 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3991 if (once && o != listop)
3992 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3995 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3997 o->op_flags |= flags;
3999 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4004 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4012 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4013 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4014 expr = newUNOP(OP_DEFINED, 0,
4015 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4016 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4017 OP *k1 = ((UNOP*)expr)->op_first;
4018 OP *k2 = (k1) ? k1->op_sibling : NULL;
4019 switch (expr->op_type) {
4021 if (k2 && k2->op_type == OP_READLINE
4022 && (k2->op_flags & OPf_STACKED)
4023 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4024 expr = newUNOP(OP_DEFINED, 0, expr);
4028 if (k1->op_type == OP_READDIR
4029 || k1->op_type == OP_GLOB
4030 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4031 || k1->op_type == OP_EACH)
4032 expr = newUNOP(OP_DEFINED, 0, expr);
4038 block = newOP(OP_NULL, 0);
4040 block = scope(block);
4044 next = LINKLIST(cont);
4047 OP *unstack = newOP(OP_UNSTACK, 0);
4050 cont = append_elem(OP_LINESEQ, cont, unstack);
4051 if ((line_t)whileline != NOLINE) {
4052 PL_copline = whileline;
4053 cont = append_elem(OP_LINESEQ, cont,
4054 newSTATEOP(0, Nullch, Nullop));
4058 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4059 redo = LINKLIST(listop);
4062 PL_copline = whileline;
4064 o = new_logop(OP_AND, 0, &expr, &listop);
4065 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4066 op_free(expr); /* oops, it's a while (0) */
4068 return Nullop; /* listop already freed by new_logop */
4071 ((LISTOP*)listop)->op_last->op_next =
4072 (o == listop ? redo : LINKLIST(o));
4078 NewOp(1101,loop,1,LOOP);
4079 loop->op_type = OP_ENTERLOOP;
4080 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4081 loop->op_private = 0;
4082 loop->op_next = (OP*)loop;
4085 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4087 loop->op_redoop = redo;
4088 loop->op_lastop = o;
4089 o->op_private |= loopflags;
4092 loop->op_nextop = next;
4094 loop->op_nextop = o;
4096 o->op_flags |= flags;
4097 o->op_private |= (flags >> 8);
4102 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4110 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4111 sv->op_type = OP_RV2GV;
4112 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4114 else if (sv->op_type == OP_PADSV) { /* private variable */
4115 padoff = sv->op_targ;
4120 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4121 padoff = sv->op_targ;
4123 iterflags |= OPf_SPECIAL;
4128 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4131 #ifdef USE_5005THREADS
4132 padoff = find_threadsv("_");
4133 iterflags |= OPf_SPECIAL;
4135 sv = newGVOP(OP_GV, 0, PL_defgv);
4138 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4139 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4140 iterflags |= OPf_STACKED;
4142 else if (expr->op_type == OP_NULL &&
4143 (expr->op_flags & OPf_KIDS) &&
4144 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4146 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4147 * set the STACKED flag to indicate that these values are to be
4148 * treated as min/max values by 'pp_iterinit'.
4150 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4151 LOGOP* range = (LOGOP*) flip->op_first;
4152 OP* left = range->op_first;
4153 OP* right = left->op_sibling;
4156 range->op_flags &= ~OPf_KIDS;
4157 range->op_first = Nullop;
4159 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4160 listop->op_first->op_next = range->op_next;
4161 left->op_next = range->op_other;
4162 right->op_next = (OP*)listop;
4163 listop->op_next = listop->op_first;
4166 expr = (OP*)(listop);
4168 iterflags |= OPf_STACKED;
4171 expr = mod(force_list(expr), OP_GREPSTART);
4175 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4176 append_elem(OP_LIST, expr, scalar(sv))));
4177 assert(!loop->op_next);
4178 #ifdef PL_OP_SLAB_ALLOC
4181 NewOp(1234,tmp,1,LOOP);
4182 Copy(loop,tmp,1,LOOP);
4186 Renew(loop, 1, LOOP);
4188 loop->op_targ = padoff;
4189 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4190 PL_copline = forline;
4191 return newSTATEOP(0, label, wop);
4195 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4200 if (type != OP_GOTO || label->op_type == OP_CONST) {
4201 /* "last()" means "last" */
4202 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4203 o = newOP(type, OPf_SPECIAL);
4205 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4206 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4212 if (label->op_type == OP_ENTERSUB)
4213 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4214 o = newUNOP(type, OPf_STACKED, label);
4216 PL_hints |= HINT_BLOCK_SCOPE;
4221 Perl_cv_undef(pTHX_ CV *cv)
4223 #ifdef USE_5005THREADS
4225 MUTEX_DESTROY(CvMUTEXP(cv));
4226 Safefree(CvMUTEXP(cv));
4229 #endif /* USE_5005THREADS */
4232 if (CvFILE(cv) && !CvXSUB(cv)) {
4233 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4234 Safefree(CvFILE(cv));
4239 if (!CvXSUB(cv) && CvROOT(cv)) {
4240 #ifdef USE_5005THREADS
4241 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4242 Perl_croak(aTHX_ "Can't undef active subroutine");
4245 Perl_croak(aTHX_ "Can't undef active subroutine");
4246 #endif /* USE_5005THREADS */
4249 SAVEVPTR(PL_curpad);
4252 op_free(CvROOT(cv));
4253 CvROOT(cv) = Nullop;
4256 SvPOK_off((SV*)cv); /* forget prototype */
4258 /* Since closure prototypes have the same lifetime as the containing
4259 * CV, they don't hold a refcount on the outside CV. This avoids
4260 * the refcount loop between the outer CV (which keeps a refcount to
4261 * the closure prototype in the pad entry for pp_anoncode()) and the
4262 * closure prototype, and the ensuing memory leak. --GSAR */
4263 if (!CvANON(cv) || CvCLONED(cv))
4264 SvREFCNT_dec(CvOUTSIDE(cv));
4265 CvOUTSIDE(cv) = Nullcv;
4267 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4270 if (CvPADLIST(cv)) {
4271 /* may be during global destruction */
4272 if (SvREFCNT(CvPADLIST(cv))) {
4273 I32 i = AvFILLp(CvPADLIST(cv));
4275 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4276 SV* sv = svp ? *svp : Nullsv;
4279 if (sv == (SV*)PL_comppad_name)
4280 PL_comppad_name = Nullav;
4281 else if (sv == (SV*)PL_comppad) {
4282 PL_comppad = Nullav;
4283 PL_curpad = Null(SV**);
4287 SvREFCNT_dec((SV*)CvPADLIST(cv));
4289 CvPADLIST(cv) = Nullav;
4297 #ifdef DEBUG_CLOSURES
4299 S_cv_dump(pTHX_ CV *cv)
4302 CV *outside = CvOUTSIDE(cv);
4303 AV* padlist = CvPADLIST(cv);
4310 PerlIO_printf(Perl_debug_log,
4311 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4313 (CvANON(cv) ? "ANON"
4314 : (cv == PL_main_cv) ? "MAIN"
4315 : CvUNIQUE(cv) ? "UNIQUE"
4316 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4319 : CvANON(outside) ? "ANON"
4320 : (outside == PL_main_cv) ? "MAIN"
4321 : CvUNIQUE(outside) ? "UNIQUE"
4322 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4327 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4328 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4329 pname = AvARRAY(pad_name);
4330 ppad = AvARRAY(pad);
4332 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4333 if (SvPOK(pname[ix]))
4334 PerlIO_printf(Perl_debug_log,
4335 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4336 (int)ix, PTR2UV(ppad[ix]),
4337 SvFAKE(pname[ix]) ? "FAKE " : "",
4339 (IV)I_32(SvNVX(pname[ix])),
4342 #endif /* DEBUGGING */
4344 #endif /* DEBUG_CLOSURES */
4347 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4351 AV* protopadlist = CvPADLIST(proto);
4352 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4353 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4354 SV** pname = AvARRAY(protopad_name);
4355 SV** ppad = AvARRAY(protopad);
4356 I32 fname = AvFILLp(protopad_name);
4357 I32 fpad = AvFILLp(protopad);
4361 assert(!CvUNIQUE(proto));
4365 SAVESPTR(PL_comppad_name);
4366 SAVESPTR(PL_compcv);
4368 cv = PL_compcv = (CV*)NEWSV(1104,0);
4369 sv_upgrade((SV *)cv, SvTYPE(proto));
4370 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4373 #ifdef USE_5005THREADS
4374 New(666, CvMUTEXP(cv), 1, perl_mutex);
4375 MUTEX_INIT(CvMUTEXP(cv));
4377 #endif /* USE_5005THREADS */
4379 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4380 : savepv(CvFILE(proto));
4382 CvFILE(cv) = CvFILE(proto);
4384 CvGV(cv) = CvGV(proto);
4385 CvSTASH(cv) = CvSTASH(proto);
4386 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4387 CvSTART(cv) = CvSTART(proto);
4389 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4392 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4394 PL_comppad_name = newAV();
4395 for (ix = fname; ix >= 0; ix--)
4396 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4398 PL_comppad = newAV();
4400 comppadlist = newAV();
4401 AvREAL_off(comppadlist);
4402 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4403 av_store(comppadlist, 1, (SV*)PL_comppad);
4404 CvPADLIST(cv) = comppadlist;
4405 av_fill(PL_comppad, AvFILLp(protopad));
4406 PL_curpad = AvARRAY(PL_comppad);
4408 av = newAV(); /* will be @_ */
4410 av_store(PL_comppad, 0, (SV*)av);
4411 AvFLAGS(av) = AVf_REIFY;
4413 for (ix = fpad; ix > 0; ix--) {
4414 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4415 if (namesv && namesv != &PL_sv_undef) {
4416 char *name = SvPVX(namesv); /* XXX */
4417 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4418 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4419 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4421 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4423 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4425 else { /* our own lexical */
4428 /* anon code -- we'll come back for it */
4429 sv = SvREFCNT_inc(ppad[ix]);
4431 else if (*name == '@')
4433 else if (*name == '%')
4442 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4443 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4446 SV* sv = NEWSV(0,0);
4452 /* Now that vars are all in place, clone nested closures. */
4454 for (ix = fpad; ix > 0; ix--) {
4455 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4457 && namesv != &PL_sv_undef
4458 && !(SvFLAGS(namesv) & SVf_FAKE)
4459 && *SvPVX(namesv) == '&'
4460 && CvCLONE(ppad[ix]))
4462 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4463 SvREFCNT_dec(ppad[ix]);
4466 PL_curpad[ix] = (SV*)kid;
4470 #ifdef DEBUG_CLOSURES
4471 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4473 PerlIO_printf(Perl_debug_log, " from:\n");
4475 PerlIO_printf(Perl_debug_log, " to:\n");
4482 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4484 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4486 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4493 Perl_cv_clone(pTHX_ CV *proto)
4496 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4497 cv = cv_clone2(proto, CvOUTSIDE(proto));
4498 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4503 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4505 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4506 SV* msg = sv_newmortal();
4510 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4511 sv_setpv(msg, "Prototype mismatch:");
4513 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4515 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4516 sv_catpv(msg, " vs ");
4518 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4520 sv_catpv(msg, "none");
4521 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4525 static void const_sv_xsub(pTHX_ CV* cv);
4528 =for apidoc cv_const_sv
4530 If C<cv> is a constant sub eligible for inlining. returns the constant
4531 value returned by the sub. Otherwise, returns NULL.
4533 Constant subs can be created with C<newCONSTSUB> or as described in
4534 L<perlsub/"Constant Functions">.
4539 Perl_cv_const_sv(pTHX_ CV *cv)
4541 if (!cv || !CvCONST(cv))
4543 return (SV*)CvXSUBANY(cv).any_ptr;
4547 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4554 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4555 o = cLISTOPo->op_first->op_sibling;
4557 for (; o; o = o->op_next) {
4558 OPCODE type = o->op_type;
4560 if (sv && o->op_next == o)
4562 if (o->op_next != o) {
4563 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4565 if (type == OP_DBSTATE)
4568 if (type == OP_LEAVESUB || type == OP_RETURN)
4572 if (type == OP_CONST && cSVOPo->op_sv)
4574 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4575 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4576 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4580 /* We get here only from cv_clone2() while creating a closure.
4581 Copy the const value here instead of in cv_clone2 so that
4582 SvREADONLY_on doesn't lead to problems when leaving
4587 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4599 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4609 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4613 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4615 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4619 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4625 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4630 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4631 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4632 SV *sv = sv_newmortal();
4633 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4634 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4639 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4640 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4650 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4651 maximum a prototype before. */
4652 if (SvTYPE(gv) > SVt_NULL) {
4653 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4654 && ckWARN_d(WARN_PROTOTYPE))
4656 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4658 cv_ckproto((CV*)gv, NULL, ps);
4661 sv_setpv((SV*)gv, ps);
4663 sv_setiv((SV*)gv, -1);
4664 SvREFCNT_dec(PL_compcv);
4665 cv = PL_compcv = NULL;
4666 PL_sub_generation++;
4670 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4672 #ifdef GV_UNIQUE_CHECK
4673 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4674 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4678 if (!block || !ps || *ps || attrs)
4681 const_sv = op_const_sv(block, Nullcv);
4684 bool exists = CvROOT(cv) || CvXSUB(cv);
4686 #ifdef GV_UNIQUE_CHECK
4687 if (exists && GvUNIQUE(gv)) {
4688 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4692 /* if the subroutine doesn't exist and wasn't pre-declared
4693 * with a prototype, assume it will be AUTOLOADed,
4694 * skipping the prototype check
4696 if (exists || SvPOK(cv))
4697 cv_ckproto(cv, gv, ps);
4698 /* already defined (or promised)? */
4699 if (exists || GvASSUMECV(gv)) {
4700 if (!block && !attrs) {
4701 /* just a "sub foo;" when &foo is already defined */
4702 SAVEFREESV(PL_compcv);
4705 /* ahem, death to those who redefine active sort subs */
4706 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4707 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4709 if (ckWARN(WARN_REDEFINE)
4711 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4713 line_t oldline = CopLINE(PL_curcop);
4714 if (PL_copline != NOLINE)
4715 CopLINE_set(PL_curcop, PL_copline);
4716 Perl_warner(aTHX_ WARN_REDEFINE,
4717 CvCONST(cv) ? "Constant subroutine %s redefined"
4718 : "Subroutine %s redefined", name);
4719 CopLINE_set(PL_curcop, oldline);
4727 SvREFCNT_inc(const_sv);
4729 assert(!CvROOT(cv) && !CvCONST(cv));
4730 sv_setpv((SV*)cv, ""); /* prototype is "" */
4731 CvXSUBANY(cv).any_ptr = const_sv;
4732 CvXSUB(cv) = const_sv_xsub;
4737 cv = newCONSTSUB(NULL, name, const_sv);
4740 SvREFCNT_dec(PL_compcv);
4742 PL_sub_generation++;
4749 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4750 * before we clobber PL_compcv.
4754 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4755 stash = GvSTASH(CvGV(cv));
4756 else if (CvSTASH(cv))
4757 stash = CvSTASH(cv);
4759 stash = PL_curstash;
4762 /* possibly about to re-define existing subr -- ignore old cv */
4763 rcv = (SV*)PL_compcv;
4764 if (name && GvSTASH(gv))
4765 stash = GvSTASH(gv);
4767 stash = PL_curstash;
4769 apply_attrs(stash, rcv, attrs);
4771 if (cv) { /* must reuse cv if autoloaded */
4773 /* got here with just attrs -- work done, so bug out */
4774 SAVEFREESV(PL_compcv);
4778 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4779 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4780 CvOUTSIDE(PL_compcv) = 0;
4781 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4782 CvPADLIST(PL_compcv) = 0;
4783 /* inner references to PL_compcv must be fixed up ... */
4785 AV *padlist = CvPADLIST(cv);
4786 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4787 AV *comppad = (AV*)AvARRAY(padlist)[1];
4788 SV **namepad = AvARRAY(comppad_name);
4789 SV **curpad = AvARRAY(comppad);
4790 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4791 SV *namesv = namepad[ix];
4792 if (namesv && namesv != &PL_sv_undef
4793 && *SvPVX(namesv) == '&')
4795 CV *innercv = (CV*)curpad[ix];
4796 if (CvOUTSIDE(innercv) == PL_compcv) {
4797 CvOUTSIDE(innercv) = cv;
4798 if (!CvANON(innercv) || CvCLONED(innercv)) {
4799 (void)SvREFCNT_inc(cv);
4800 SvREFCNT_dec(PL_compcv);
4806 /* ... before we throw it away */
4807 SvREFCNT_dec(PL_compcv);
4808 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4809 ++PL_sub_generation;
4816 PL_sub_generation++;
4820 CvFILE_set_from_cop(cv, PL_curcop);
4821 CvSTASH(cv) = PL_curstash;
4822 #ifdef USE_5005THREADS
4824 if (!CvMUTEXP(cv)) {
4825 New(666, CvMUTEXP(cv), 1, perl_mutex);
4826 MUTEX_INIT(CvMUTEXP(cv));
4828 #endif /* USE_5005THREADS */
4831 sv_setpv((SV*)cv, ps);
4833 if (PL_error_count) {
4837 char *s = strrchr(name, ':');
4839 if (strEQ(s, "BEGIN")) {
4841 "BEGIN not safe after errors--compilation aborted";
4842 if (PL_in_eval & EVAL_KEEPERR)
4843 Perl_croak(aTHX_ not_safe);
4845 /* force display of errors found but not reported */
4846 sv_catpv(ERRSV, not_safe);
4847 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4855 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4856 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4859 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4860 mod(scalarseq(block), OP_LEAVESUBLV));
4863 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4865 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4866 OpREFCNT_set(CvROOT(cv), 1);
4867 CvSTART(cv) = LINKLIST(CvROOT(cv));
4868 CvROOT(cv)->op_next = 0;
4869 CALL_PEEP(CvSTART(cv));
4871 /* now that optimizer has done its work, adjust pad values */
4873 SV **namep = AvARRAY(PL_comppad_name);
4874 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4877 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4880 * The only things that a clonable function needs in its
4881 * pad are references to outer lexicals and anonymous subs.
4882 * The rest are created anew during cloning.
4884 if (!((namesv = namep[ix]) != Nullsv &&
4885 namesv != &PL_sv_undef &&
4887 *SvPVX(namesv) == '&')))
4889 SvREFCNT_dec(PL_curpad[ix]);
4890 PL_curpad[ix] = Nullsv;
4893 assert(!CvCONST(cv));
4894 if (ps && !*ps && op_const_sv(block, cv))
4898 AV *av = newAV(); /* Will be @_ */
4900 av_store(PL_comppad, 0, (SV*)av);
4901 AvFLAGS(av) = AVf_REIFY;
4903 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4904 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4906 if (!SvPADMY(PL_curpad[ix]))
4907 SvPADTMP_on(PL_curpad[ix]);
4911 /* If a potential closure prototype, don't keep a refcount on outer CV.
4912 * This is okay as the lifetime of the prototype is tied to the
4913 * lifetime of the outer CV. Avoids memory leak due to reference
4916 SvREFCNT_dec(CvOUTSIDE(cv));
4918 if (name || aname) {
4920 char *tname = (name ? name : aname);
4922 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4923 SV *sv = NEWSV(0,0);
4924 SV *tmpstr = sv_newmortal();
4925 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4929 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4931 (long)PL_subline, (long)CopLINE(PL_curcop));
4932 gv_efullname3(tmpstr, gv, Nullch);
4933 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4934 hv = GvHVn(db_postponed);
4935 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4936 && (pcv = GvCV(db_postponed)))
4942 call_sv((SV*)pcv, G_DISCARD);
4946 if ((s = strrchr(tname,':')))
4951 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4954 if (strEQ(s, "BEGIN")) {
4955 I32 oldscope = PL_scopestack_ix;
4957 SAVECOPFILE(&PL_compiling);
4958 SAVECOPLINE(&PL_compiling);
4961 PL_beginav = newAV();
4962 DEBUG_x( dump_sub(gv) );
4963 av_push(PL_beginav, (SV*)cv);
4964 GvCV(gv) = 0; /* cv has been hijacked */
4965 call_list(oldscope, PL_beginav);
4967 PL_curcop = &PL_compiling;
4968 PL_compiling.op_private = PL_hints;
4971 else if (strEQ(s, "END") && !PL_error_count) {
4974 DEBUG_x( dump_sub(gv) );
4975 av_unshift(PL_endav, 1);
4976 av_store(PL_endav, 0, (SV*)cv);
4977 GvCV(gv) = 0; /* cv has been hijacked */
4979 else if (strEQ(s, "CHECK") && !PL_error_count) {
4981 PL_checkav = newAV();
4982 DEBUG_x( dump_sub(gv) );
4983 if (PL_main_start && ckWARN(WARN_VOID))
4984 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4985 av_unshift(PL_checkav, 1);
4986 av_store(PL_checkav, 0, (SV*)cv);
4987 GvCV(gv) = 0; /* cv has been hijacked */
4989 else if (strEQ(s, "INIT") && !PL_error_count) {
4991 PL_initav = newAV();
4992 DEBUG_x( dump_sub(gv) );
4993 if (PL_main_start && ckWARN(WARN_VOID))
4994 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4995 av_push(PL_initav, (SV*)cv);
4996 GvCV(gv) = 0; /* cv has been hijacked */
5001 PL_copline = NOLINE;
5006 /* XXX unsafe for threads if eval_owner isn't held */
5008 =for apidoc newCONSTSUB
5010 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5011 eligible for inlining at compile-time.
5017 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5023 SAVECOPLINE(PL_curcop);
5024 CopLINE_set(PL_curcop, PL_copline);
5027 PL_hints &= ~HINT_BLOCK_SCOPE;
5030 SAVESPTR(PL_curstash);
5031 SAVECOPSTASH(PL_curcop);
5032 PL_curstash = stash;
5034 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5036 CopSTASH(PL_curcop) = stash;
5040 cv = newXS(name, const_sv_xsub, __FILE__);
5041 CvXSUBANY(cv).any_ptr = sv;
5043 sv_setpv((SV*)cv, ""); /* prototype is "" */
5051 =for apidoc U||newXS
5053 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5059 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5061 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5064 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5066 /* just a cached method */
5070 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5071 /* already defined (or promised) */
5072 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5073 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5074 line_t oldline = CopLINE(PL_curcop);
5075 if (PL_copline != NOLINE)
5076 CopLINE_set(PL_curcop, PL_copline);
5077 Perl_warner(aTHX_ WARN_REDEFINE,
5078 CvCONST(cv) ? "Constant subroutine %s redefined"
5079 : "Subroutine %s redefined"
5081 CopLINE_set(PL_curcop, oldline);
5088 if (cv) /* must reuse cv if autoloaded */
5091 cv = (CV*)NEWSV(1105,0);
5092 sv_upgrade((SV *)cv, SVt_PVCV);
5096 PL_sub_generation++;
5100 #ifdef USE_5005THREADS
5101 New(666, CvMUTEXP(cv), 1, perl_mutex);
5102 MUTEX_INIT(CvMUTEXP(cv));
5104 #endif /* USE_5005THREADS */
5105 (void)gv_fetchfile(filename);
5106 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5107 an external constant string */
5108 CvXSUB(cv) = subaddr;
5111 char *s = strrchr(name,':');
5117 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5120 if (strEQ(s, "BEGIN")) {
5122 PL_beginav = newAV();
5123 av_push(PL_beginav, (SV*)cv);
5124 GvCV(gv) = 0; /* cv has been hijacked */
5126 else if (strEQ(s, "END")) {
5129 av_unshift(PL_endav, 1);
5130 av_store(PL_endav, 0, (SV*)cv);
5131 GvCV(gv) = 0; /* cv has been hijacked */
5133 else if (strEQ(s, "CHECK")) {
5135 PL_checkav = newAV();
5136 if (PL_main_start && ckWARN(WARN_VOID))
5137 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5138 av_unshift(PL_checkav, 1);
5139 av_store(PL_checkav, 0, (SV*)cv);
5140 GvCV(gv) = 0; /* cv has been hijacked */
5142 else if (strEQ(s, "INIT")) {
5144 PL_initav = newAV();
5145 if (PL_main_start && ckWARN(WARN_VOID))
5146 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5147 av_push(PL_initav, (SV*)cv);
5148 GvCV(gv) = 0; /* cv has been hijacked */
5159 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5168 name = SvPVx(cSVOPo->op_sv, n_a);
5171 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5172 #ifdef GV_UNIQUE_CHECK
5174 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5178 if ((cv = GvFORM(gv))) {
5179 if (ckWARN(WARN_REDEFINE)) {
5180 line_t oldline = CopLINE(PL_curcop);
5181 if (PL_copline != NOLINE)
5182 CopLINE_set(PL_curcop, PL_copline);
5183 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5184 CopLINE_set(PL_curcop, oldline);
5191 CvFILE_set_from_cop(cv, PL_curcop);
5193 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5194 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5195 SvPADTMP_on(PL_curpad[ix]);
5198 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5199 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5200 OpREFCNT_set(CvROOT(cv), 1);
5201 CvSTART(cv) = LINKLIST(CvROOT(cv));
5202 CvROOT(cv)->op_next = 0;
5203 CALL_PEEP(CvSTART(cv));
5205 PL_copline = NOLINE;
5210 Perl_newANONLIST(pTHX_ OP *o)
5212 return newUNOP(OP_REFGEN, 0,
5213 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5217 Perl_newANONHASH(pTHX_ OP *o)
5219 return newUNOP(OP_REFGEN, 0,
5220 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5224 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5226 return newANONATTRSUB(floor, proto, Nullop, block);
5230 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5232 return newUNOP(OP_REFGEN, 0,
5233 newSVOP(OP_ANONCODE, 0,
5234 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5238 Perl_oopsAV(pTHX_ OP *o)
5240 switch (o->op_type) {
5242 o->op_type = OP_PADAV;
5243 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5244 return ref(o, OP_RV2AV);
5247 o->op_type = OP_RV2AV;
5248 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5253 if (ckWARN_d(WARN_INTERNAL))
5254 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5261 Perl_oopsHV(pTHX_ OP *o)
5263 switch (o->op_type) {
5266 o->op_type = OP_PADHV;
5267 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5268 return ref(o, OP_RV2HV);
5272 o->op_type = OP_RV2HV;
5273 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5278 if (ckWARN_d(WARN_INTERNAL))
5279 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5286 Perl_newAVREF(pTHX_ OP *o)
5288 if (o->op_type == OP_PADANY) {
5289 o->op_type = OP_PADAV;
5290 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5293 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5294 && ckWARN(WARN_DEPRECATED)) {
5295 Perl_warner(aTHX_ WARN_DEPRECATED,
5296 "Using an array as a reference is deprecated");
5298 return newUNOP(OP_RV2AV, 0, scalar(o));
5302 Perl_newGVREF(pTHX_ I32 type, OP *o)
5304 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5305 return newUNOP(OP_NULL, 0, o);
5306 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5310 Perl_newHVREF(pTHX_ OP *o)
5312 if (o->op_type == OP_PADANY) {
5313 o->op_type = OP_PADHV;
5314 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5317 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5318 && ckWARN(WARN_DEPRECATED)) {
5319 Perl_warner(aTHX_ WARN_DEPRECATED,
5320 "Using a hash as a reference is deprecated");
5322 return newUNOP(OP_RV2HV, 0, scalar(o));
5326 Perl_oopsCV(pTHX_ OP *o)
5328 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5334 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5336 return newUNOP(OP_RV2CV, flags, scalar(o));
5340 Perl_newSVREF(pTHX_ OP *o)
5342 if (o->op_type == OP_PADANY) {
5343 o->op_type = OP_PADSV;
5344 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5347 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5348 o->op_flags |= OPpDONE_SVREF;
5351 return newUNOP(OP_RV2SV, 0, scalar(o));
5354 /* Check routines. */
5357 Perl_ck_anoncode(pTHX_ OP *o)
5362 name = NEWSV(1106,0);
5363 sv_upgrade(name, SVt_PVNV);
5364 sv_setpvn(name, "&", 1);
5367 ix = pad_alloc(o->op_type, SVs_PADMY);
5368 av_store(PL_comppad_name, ix, name);
5369 av_store(PL_comppad, ix, cSVOPo->op_sv);
5370 SvPADMY_on(cSVOPo->op_sv);
5371 cSVOPo->op_sv = Nullsv;
5372 cSVOPo->op_targ = ix;
5377 Perl_ck_bitop(pTHX_ OP *o)
5379 o->op_private = PL_hints;
5384 Perl_ck_concat(pTHX_ OP *o)
5386 if (cUNOPo->op_first->op_type == OP_CONCAT)
5387 o->op_flags |= OPf_STACKED;
5392 Perl_ck_spair(pTHX_ OP *o)
5394 if (o->op_flags & OPf_KIDS) {
5397 OPCODE type = o->op_type;
5398 o = modkids(ck_fun(o), type);
5399 kid = cUNOPo->op_first;
5400 newop = kUNOP->op_first->op_sibling;
5402 (newop->op_sibling ||
5403 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5404 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5405 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5409 op_free(kUNOP->op_first);
5410 kUNOP->op_first = newop;
5412 o->op_ppaddr = PL_ppaddr[++o->op_type];
5417 Perl_ck_delete(pTHX_ OP *o)
5421 if (o->op_flags & OPf_KIDS) {
5422 OP *kid = cUNOPo->op_first;
5423 switch (kid->op_type) {
5425 o->op_flags |= OPf_SPECIAL;
5428 o->op_private |= OPpSLICE;
5431 o->op_flags |= OPf_SPECIAL;
5436 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5445 Perl_ck_die(pTHX_ OP *o)
5448 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5454 Perl_ck_eof(pTHX_ OP *o)
5456 I32 type = o->op_type;
5458 if (o->op_flags & OPf_KIDS) {
5459 if (cLISTOPo->op_first->op_type == OP_STUB) {
5461 o = newUNOP(type, OPf_SPECIAL,
5462 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5470 Perl_ck_eval(pTHX_ OP *o)
5472 PL_hints |= HINT_BLOCK_SCOPE;
5473 if (o->op_flags & OPf_KIDS) {
5474 SVOP *kid = (SVOP*)cUNOPo->op_first;
5477 o->op_flags &= ~OPf_KIDS;
5480 else if (kid->op_type == OP_LINESEQ) {
5483 kid->op_next = o->op_next;
5484 cUNOPo->op_first = 0;
5487 NewOp(1101, enter, 1, LOGOP);
5488 enter->op_type = OP_ENTERTRY;
5489 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5490 enter->op_private = 0;
5492 /* establish postfix order */
5493 enter->op_next = (OP*)enter;
5495 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5496 o->op_type = OP_LEAVETRY;
5497 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5498 enter->op_other = o;
5506 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5508 o->op_targ = (PADOFFSET)PL_hints;
5513 Perl_ck_exit(pTHX_ OP *o)
5516 HV *table = GvHV(PL_hintgv);
5518 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5519 if (svp && *svp && SvTRUE(*svp))
5520 o->op_private |= OPpEXIT_VMSISH;
5522 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5528 Perl_ck_exec(pTHX_ OP *o)
5531 if (o->op_flags & OPf_STACKED) {
5533 kid = cUNOPo->op_first->op_sibling;
5534 if (kid->op_type == OP_RV2GV)
5543 Perl_ck_exists(pTHX_ OP *o)
5546 if (o->op_flags & OPf_KIDS) {
5547 OP *kid = cUNOPo->op_first;
5548 if (kid->op_type == OP_ENTERSUB) {
5549 (void) ref(kid, o->op_type);
5550 if (kid->op_type != OP_RV2CV && !PL_error_count)
5551 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5553 o->op_private |= OPpEXISTS_SUB;
5555 else if (kid->op_type == OP_AELEM)
5556 o->op_flags |= OPf_SPECIAL;
5557 else if (kid->op_type != OP_HELEM)
5558 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5567 Perl_ck_gvconst(pTHX_ register OP *o)
5569 o = fold_constants(o);
5570 if (o->op_type == OP_CONST)
5577 Perl_ck_rvconst(pTHX_ register OP *o)
5579 SVOP *kid = (SVOP*)cUNOPo->op_first;
5581 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5582 if (kid->op_type == OP_CONST) {
5586 SV *kidsv = kid->op_sv;
5589 /* Is it a constant from cv_const_sv()? */
5590 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5591 SV *rsv = SvRV(kidsv);
5592 int svtype = SvTYPE(rsv);
5593 char *badtype = Nullch;
5595 switch (o->op_type) {
5597 if (svtype > SVt_PVMG)
5598 badtype = "a SCALAR";
5601 if (svtype != SVt_PVAV)
5602 badtype = "an ARRAY";
5605 if (svtype != SVt_PVHV) {
5606 if (svtype == SVt_PVAV) { /* pseudohash? */
5607 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5608 if (ksv && SvROK(*ksv)
5609 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5618 if (svtype != SVt_PVCV)
5623 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5626 name = SvPV(kidsv, n_a);
5627 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5628 char *badthing = Nullch;
5629 switch (o->op_type) {
5631 badthing = "a SCALAR";
5634 badthing = "an ARRAY";
5637 badthing = "a HASH";
5642 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5646 * This is a little tricky. We only want to add the symbol if we
5647 * didn't add it in the lexer. Otherwise we get duplicate strict
5648 * warnings. But if we didn't add it in the lexer, we must at
5649 * least pretend like we wanted to add it even if it existed before,
5650 * or we get possible typo warnings. OPpCONST_ENTERED says
5651 * whether the lexer already added THIS instance of this symbol.
5653 iscv = (o->op_type == OP_RV2CV) * 2;
5655 gv = gv_fetchpv(name,
5656 iscv | !(kid->op_private & OPpCONST_ENTERED),
5659 : o->op_type == OP_RV2SV
5661 : o->op_type == OP_RV2AV
5663 : o->op_type == OP_RV2HV
5666 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5668 kid->op_type = OP_GV;
5669 SvREFCNT_dec(kid->op_sv);
5671 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5672 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5673 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5675 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5677 kid->op_sv = SvREFCNT_inc(gv);
5679 kid->op_private = 0;
5680 kid->op_ppaddr = PL_ppaddr[OP_GV];
5687 Perl_ck_ftst(pTHX_ OP *o)
5689 I32 type = o->op_type;
5691 if (o->op_flags & OPf_REF) {
5694 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5695 SVOP *kid = (SVOP*)cUNOPo->op_first;
5697 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5699 OP *newop = newGVOP(type, OPf_REF,
5700 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5707 if (type == OP_FTTTY)
5708 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5711 o = newUNOP(type, 0, newDEFSVOP());
5717 Perl_ck_fun(pTHX_ OP *o)
5723 int type = o->op_type;
5724 register I32 oa = PL_opargs[type] >> OASHIFT;
5726 if (o->op_flags & OPf_STACKED) {
5727 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5730 return no_fh_allowed(o);
5733 if (o->op_flags & OPf_KIDS) {
5735 tokid = &cLISTOPo->op_first;
5736 kid = cLISTOPo->op_first;
5737 if (kid->op_type == OP_PUSHMARK ||
5738 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5740 tokid = &kid->op_sibling;
5741 kid = kid->op_sibling;
5743 if (!kid && PL_opargs[type] & OA_DEFGV)
5744 *tokid = kid = newDEFSVOP();
5748 sibl = kid->op_sibling;
5751 /* list seen where single (scalar) arg expected? */
5752 if (numargs == 1 && !(oa >> 4)
5753 && kid->op_type == OP_LIST && type != OP_SCALAR)
5755 return too_many_arguments(o,PL_op_desc[type]);
5768 if ((type == OP_PUSH || type == OP_UNSHIFT)
5769 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5770 Perl_warner(aTHX_ WARN_SYNTAX,
5771 "Useless use of %s with no values",
5774 if (kid->op_type == OP_CONST &&
5775 (kid->op_private & OPpCONST_BARE))
5777 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5778 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5779 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5780 if (ckWARN(WARN_DEPRECATED))
5781 Perl_warner(aTHX_ WARN_DEPRECATED,
5782 "Array @%s missing the @ in argument %"IVdf" of %s()",
5783 name, (IV)numargs, PL_op_desc[type]);
5786 kid->op_sibling = sibl;
5789 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5790 bad_type(numargs, "array", PL_op_desc[type], kid);
5794 if (kid->op_type == OP_CONST &&
5795 (kid->op_private & OPpCONST_BARE))
5797 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5798 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5799 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5800 if (ckWARN(WARN_DEPRECATED))
5801 Perl_warner(aTHX_ WARN_DEPRECATED,
5802 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5803 name, (IV)numargs, PL_op_desc[type]);
5806 kid->op_sibling = sibl;
5809 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5810 bad_type(numargs, "hash", PL_op_desc[type], kid);
5815 OP *newop = newUNOP(OP_NULL, 0, kid);
5816 kid->op_sibling = 0;
5818 newop->op_next = newop;
5820 kid->op_sibling = sibl;
5825 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5826 if (kid->op_type == OP_CONST &&
5827 (kid->op_private & OPpCONST_BARE))
5829 OP *newop = newGVOP(OP_GV, 0,
5830 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5835 else if (kid->op_type == OP_READLINE) {
5836 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5837 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5840 I32 flags = OPf_SPECIAL;
5844 /* is this op a FH constructor? */
5845 if (is_handle_constructor(o,numargs)) {
5846 char *name = Nullch;
5850 /* Set a flag to tell rv2gv to vivify
5851 * need to "prove" flag does not mean something
5852 * else already - NI-S 1999/05/07
5855 if (kid->op_type == OP_PADSV) {
5856 SV **namep = av_fetch(PL_comppad_name,
5858 if (namep && *namep)
5859 name = SvPV(*namep, len);
5861 else if (kid->op_type == OP_RV2SV
5862 && kUNOP->op_first->op_type == OP_GV)
5864 GV *gv = cGVOPx_gv(kUNOP->op_first);
5866 len = GvNAMELEN(gv);
5868 else if (kid->op_type == OP_AELEM
5869 || kid->op_type == OP_HELEM)
5871 name = "__ANONIO__";
5877 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5878 namesv = PL_curpad[targ];
5879 (void)SvUPGRADE(namesv, SVt_PV);
5881 sv_setpvn(namesv, "$", 1);
5882 sv_catpvn(namesv, name, len);
5885 kid->op_sibling = 0;
5886 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5887 kid->op_targ = targ;
5888 kid->op_private |= priv;
5890 kid->op_sibling = sibl;
5896 mod(scalar(kid), type);
5900 tokid = &kid->op_sibling;
5901 kid = kid->op_sibling;
5903 o->op_private |= numargs;
5905 return too_many_arguments(o,OP_DESC(o));
5908 else if (PL_opargs[type] & OA_DEFGV) {
5910 return newUNOP(type, 0, newDEFSVOP());
5914 while (oa & OA_OPTIONAL)
5916 if (oa && oa != OA_LIST)
5917 return too_few_arguments(o,OP_DESC(o));
5923 Perl_ck_glob(pTHX_ OP *o)
5928 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5929 append_elem(OP_GLOB, o, newDEFSVOP());
5931 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5932 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5934 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5937 #if !defined(PERL_EXTERNAL_GLOB)
5938 /* XXX this can be tightened up and made more failsafe. */
5942 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5944 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5945 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5946 GvCV(gv) = GvCV(glob_gv);
5947 SvREFCNT_inc((SV*)GvCV(gv));
5948 GvIMPORTED_CV_on(gv);
5951 #endif /* PERL_EXTERNAL_GLOB */
5953 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5954 append_elem(OP_GLOB, o,
5955 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5956 o->op_type = OP_LIST;
5957 o->op_ppaddr = PL_ppaddr[OP_LIST];
5958 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5959 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5960 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5961 append_elem(OP_LIST, o,
5962 scalar(newUNOP(OP_RV2CV, 0,
5963 newGVOP(OP_GV, 0, gv)))));
5964 o = newUNOP(OP_NULL, 0, ck_subr(o));
5965 o->op_targ = OP_GLOB; /* hint at what it used to be */
5968 gv = newGVgen("main");
5970 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5976 Perl_ck_grep(pTHX_ OP *o)
5980 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5982 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5983 NewOp(1101, gwop, 1, LOGOP);
5985 if (o->op_flags & OPf_STACKED) {
5988 kid = cLISTOPo->op_first->op_sibling;
5989 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5992 kid->op_next = (OP*)gwop;
5993 o->op_flags &= ~OPf_STACKED;
5995 kid = cLISTOPo->op_first->op_sibling;
5996 if (type == OP_MAPWHILE)
6003 kid = cLISTOPo->op_first->op_sibling;
6004 if (kid->op_type != OP_NULL)
6005 Perl_croak(aTHX_ "panic: ck_grep");
6006 kid = kUNOP->op_first;
6008 gwop->op_type = type;
6009 gwop->op_ppaddr = PL_ppaddr[type];
6010 gwop->op_first = listkids(o);
6011 gwop->op_flags |= OPf_KIDS;
6012 gwop->op_private = 1;
6013 gwop->op_other = LINKLIST(kid);
6014 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6015 kid->op_next = (OP*)gwop;
6017 kid = cLISTOPo->op_first->op_sibling;
6018 if (!kid || !kid->op_sibling)
6019 return too_few_arguments(o,OP_DESC(o));
6020 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6021 mod(kid, OP_GREPSTART);
6027 Perl_ck_index(pTHX_ OP *o)
6029 if (o->op_flags & OPf_KIDS) {
6030 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6032 kid = kid->op_sibling; /* get past "big" */
6033 if (kid && kid->op_type == OP_CONST)
6034 fbm_compile(((SVOP*)kid)->op_sv, 0);
6040 Perl_ck_lengthconst(pTHX_ OP *o)
6042 /* XXX length optimization goes here */
6047 Perl_ck_lfun(pTHX_ OP *o)
6049 OPCODE type = o->op_type;
6050 return modkids(ck_fun(o), type);
6054 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6056 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6057 switch (cUNOPo->op_first->op_type) {
6059 /* This is needed for
6060 if (defined %stash::)
6061 to work. Do not break Tk.
6063 break; /* Globals via GV can be undef */
6065 case OP_AASSIGN: /* Is this a good idea? */
6066 Perl_warner(aTHX_ WARN_DEPRECATED,
6067 "defined(@array) is deprecated");
6068 Perl_warner(aTHX_ WARN_DEPRECATED,
6069 "\t(Maybe you should just omit the defined()?)\n");
6072 /* This is needed for
6073 if (defined %stash::)
6074 to work. Do not break Tk.
6076 break; /* Globals via GV can be undef */
6078 Perl_warner(aTHX_ WARN_DEPRECATED,
6079 "defined(%%hash) is deprecated");
6080 Perl_warner(aTHX_ WARN_DEPRECATED,
6081 "\t(Maybe you should just omit the defined()?)\n");
6092 Perl_ck_rfun(pTHX_ OP *o)
6094 OPCODE type = o->op_type;
6095 return refkids(ck_fun(o), type);
6099 Perl_ck_listiob(pTHX_ OP *o)
6103 kid = cLISTOPo->op_first;
6106 kid = cLISTOPo->op_first;
6108 if (kid->op_type == OP_PUSHMARK)
6109 kid = kid->op_sibling;
6110 if (kid && o->op_flags & OPf_STACKED)
6111 kid = kid->op_sibling;
6112 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6113 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6114 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6115 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6116 cLISTOPo->op_first->op_sibling = kid;
6117 cLISTOPo->op_last = kid;
6118 kid = kid->op_sibling;
6123 append_elem(o->op_type, o, newDEFSVOP());
6129 Perl_ck_sassign(pTHX_ OP *o)
6131 OP *kid = cLISTOPo->op_first;
6132 /* has a disposable target? */
6133 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6134 && !(kid->op_flags & OPf_STACKED)
6135 /* Cannot steal the second time! */
6136 && !(kid->op_private & OPpTARGET_MY))
6138 OP *kkid = kid->op_sibling;
6140 /* Can just relocate the target. */
6141 if (kkid && kkid->op_type == OP_PADSV
6142 && !(kkid->op_private & OPpLVAL_INTRO))
6144 kid->op_targ = kkid->op_targ;
6146 /* Now we do not need PADSV and SASSIGN. */
6147 kid->op_sibling = o->op_sibling; /* NULL */
6148 cLISTOPo->op_first = NULL;
6151 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6159 Perl_ck_match(pTHX_ OP *o)
6161 o->op_private |= OPpRUNTIME;
6166 Perl_ck_method(pTHX_ OP *o)
6168 OP *kid = cUNOPo->op_first;
6169 if (kid->op_type == OP_CONST) {
6170 SV* sv = kSVOP->op_sv;
6171 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6173 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6174 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6177 kSVOP->op_sv = Nullsv;
6179 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6188 Perl_ck_null(pTHX_ OP *o)
6194 Perl_ck_open(pTHX_ OP *o)
6196 HV *table = GvHV(PL_hintgv);
6200 svp = hv_fetch(table, "open_IN", 7, FALSE);
6202 mode = mode_from_discipline(*svp);
6203 if (mode & O_BINARY)
6204 o->op_private |= OPpOPEN_IN_RAW;
6205 else if (mode & O_TEXT)
6206 o->op_private |= OPpOPEN_IN_CRLF;
6209 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6211 mode = mode_from_discipline(*svp);
6212 if (mode & O_BINARY)
6213 o->op_private |= OPpOPEN_OUT_RAW;
6214 else if (mode & O_TEXT)
6215 o->op_private |= OPpOPEN_OUT_CRLF;
6218 if (o->op_type == OP_BACKTICK)
6224 Perl_ck_repeat(pTHX_ OP *o)
6226 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6227 o->op_private |= OPpREPEAT_DOLIST;
6228 cBINOPo->op_first = force_list(cBINOPo->op_first);
6236 Perl_ck_require(pTHX_ OP *o)
6240 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6241 SVOP *kid = (SVOP*)cUNOPo->op_first;
6243 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6245 for (s = SvPVX(kid->op_sv); *s; s++) {
6246 if (*s == ':' && s[1] == ':') {
6248 Move(s+2, s+1, strlen(s+2)+1, char);
6249 --SvCUR(kid->op_sv);
6252 if (SvREADONLY(kid->op_sv)) {
6253 SvREADONLY_off(kid->op_sv);
6254 sv_catpvn(kid->op_sv, ".pm", 3);
6255 SvREADONLY_on(kid->op_sv);
6258 sv_catpvn(kid->op_sv, ".pm", 3);
6262 /* handle override, if any */
6263 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6264 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6265 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6267 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6268 OP *kid = cUNOPo->op_first;
6269 cUNOPo->op_first = 0;
6271 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6272 append_elem(OP_LIST, kid,
6273 scalar(newUNOP(OP_RV2CV, 0,
6282 Perl_ck_return(pTHX_ OP *o)
6285 if (CvLVALUE(PL_compcv)) {
6286 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6287 mod(kid, OP_LEAVESUBLV);
6294 Perl_ck_retarget(pTHX_ OP *o)
6296 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6303 Perl_ck_select(pTHX_ OP *o)
6306 if (o->op_flags & OPf_KIDS) {
6307 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6308 if (kid && kid->op_sibling) {
6309 o->op_type = OP_SSELECT;
6310 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6312 return fold_constants(o);
6316 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6317 if (kid && kid->op_type == OP_RV2GV)
6318 kid->op_private &= ~HINT_STRICT_REFS;
6323 Perl_ck_shift(pTHX_ OP *o)
6325 I32 type = o->op_type;
6327 if (!(o->op_flags & OPf_KIDS)) {
6331 #ifdef USE_5005THREADS
6332 if (!CvUNIQUE(PL_compcv)) {
6333 argop = newOP(OP_PADAV, OPf_REF);
6334 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6337 argop = newUNOP(OP_RV2AV, 0,
6338 scalar(newGVOP(OP_GV, 0,
6339 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6342 argop = newUNOP(OP_RV2AV, 0,
6343 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6344 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6345 #endif /* USE_5005THREADS */
6346 return newUNOP(type, 0, scalar(argop));
6348 return scalar(modkids(ck_fun(o), type));
6352 Perl_ck_sort(pTHX_ OP *o)
6356 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6358 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6359 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6361 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6363 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6365 if (kid->op_type == OP_SCOPE) {
6369 else if (kid->op_type == OP_LEAVE) {
6370 if (o->op_type == OP_SORT) {
6371 op_null(kid); /* wipe out leave */
6374 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6375 if (k->op_next == kid)
6377 /* don't descend into loops */
6378 else if (k->op_type == OP_ENTERLOOP
6379 || k->op_type == OP_ENTERITER)
6381 k = cLOOPx(k)->op_lastop;
6386 kid->op_next = 0; /* just disconnect the leave */
6387 k = kLISTOP->op_first;
6392 if (o->op_type == OP_SORT) {
6393 /* provide scalar context for comparison function/block */
6399 o->op_flags |= OPf_SPECIAL;
6401 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6404 firstkid = firstkid->op_sibling;
6407 /* provide list context for arguments */
6408 if (o->op_type == OP_SORT)
6415 S_simplify_sort(pTHX_ OP *o)
6417 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6421 if (!(o->op_flags & OPf_STACKED))
6423 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6424 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6425 kid = kUNOP->op_first; /* get past null */
6426 if (kid->op_type != OP_SCOPE)
6428 kid = kLISTOP->op_last; /* get past scope */
6429 switch(kid->op_type) {
6437 k = kid; /* remember this node*/
6438 if (kBINOP->op_first->op_type != OP_RV2SV)
6440 kid = kBINOP->op_first; /* get past cmp */
6441 if (kUNOP->op_first->op_type != OP_GV)
6443 kid = kUNOP->op_first; /* get past rv2sv */
6445 if (GvSTASH(gv) != PL_curstash)
6447 if (strEQ(GvNAME(gv), "a"))
6449 else if (strEQ(GvNAME(gv), "b"))
6453 kid = k; /* back to cmp */
6454 if (kBINOP->op_last->op_type != OP_RV2SV)
6456 kid = kBINOP->op_last; /* down to 2nd arg */
6457 if (kUNOP->op_first->op_type != OP_GV)
6459 kid = kUNOP->op_first; /* get past rv2sv */
6461 if (GvSTASH(gv) != PL_curstash
6463 ? strNE(GvNAME(gv), "a")
6464 : strNE(GvNAME(gv), "b")))
6466 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6468 o->op_private |= OPpSORT_REVERSE;
6469 if (k->op_type == OP_NCMP)
6470 o->op_private |= OPpSORT_NUMERIC;
6471 if (k->op_type == OP_I_NCMP)
6472 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6473 kid = cLISTOPo->op_first->op_sibling;
6474 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6475 op_free(kid); /* then delete it */
6479 Perl_ck_split(pTHX_ OP *o)
6483 if (o->op_flags & OPf_STACKED)
6484 return no_fh_allowed(o);
6486 kid = cLISTOPo->op_first;
6487 if (kid->op_type != OP_NULL)
6488 Perl_croak(aTHX_ "panic: ck_split");
6489 kid = kid->op_sibling;
6490 op_free(cLISTOPo->op_first);
6491 cLISTOPo->op_first = kid;
6493 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6494 cLISTOPo->op_last = kid; /* There was only one element previously */
6497 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6498 OP *sibl = kid->op_sibling;
6499 kid->op_sibling = 0;
6500 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6501 if (cLISTOPo->op_first == cLISTOPo->op_last)
6502 cLISTOPo->op_last = kid;
6503 cLISTOPo->op_first = kid;
6504 kid->op_sibling = sibl;
6507 kid->op_type = OP_PUSHRE;
6508 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6511 if (!kid->op_sibling)
6512 append_elem(OP_SPLIT, o, newDEFSVOP());
6514 kid = kid->op_sibling;
6517 if (!kid->op_sibling)
6518 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6520 kid = kid->op_sibling;
6523 if (kid->op_sibling)
6524 return too_many_arguments(o,OP_DESC(o));
6530 Perl_ck_join(pTHX_ OP *o)
6532 if (ckWARN(WARN_SYNTAX)) {
6533 OP *kid = cLISTOPo->op_first->op_sibling;
6534 if (kid && kid->op_type == OP_MATCH) {
6535 char *pmstr = "STRING";
6536 if (PM_GETRE(kPMOP))
6537 pmstr = PM_GETRE(kPMOP)->precomp;
6538 Perl_warner(aTHX_ WARN_SYNTAX,
6539 "/%s/ should probably be written as \"%s\"",
6547 Perl_ck_subr(pTHX_ OP *o)
6549 OP *prev = ((cUNOPo->op_first->op_sibling)
6550 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6551 OP *o2 = prev->op_sibling;
6558 I32 contextclass = 0;
6562 o->op_private |= OPpENTERSUB_HASTARG;
6563 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6564 if (cvop->op_type == OP_RV2CV) {
6566 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6567 op_null(cvop); /* disable rv2cv */
6568 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6569 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6570 GV *gv = cGVOPx_gv(tmpop);
6573 tmpop->op_private |= OPpEARLY_CV;
6574 else if (SvPOK(cv)) {
6575 namegv = CvANON(cv) ? gv : CvGV(cv);
6576 proto = SvPV((SV*)cv, n_a);
6580 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6581 if (o2->op_type == OP_CONST)
6582 o2->op_private &= ~OPpCONST_STRICT;
6583 else if (o2->op_type == OP_LIST) {
6584 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6585 if (o && o->op_type == OP_CONST)
6586 o->op_private &= ~OPpCONST_STRICT;
6589 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6590 if (PERLDB_SUB && PL_curstash != PL_debstash)
6591 o->op_private |= OPpENTERSUB_DB;
6592 while (o2 != cvop) {
6596 return too_many_arguments(o, gv_ename(namegv));
6614 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6616 arg == 1 ? "block or sub {}" : "sub {}",
6617 gv_ename(namegv), o2);
6620 /* '*' allows any scalar type, including bareword */
6623 if (o2->op_type == OP_RV2GV)
6624 goto wrapref; /* autoconvert GLOB -> GLOBref */
6625 else if (o2->op_type == OP_CONST)
6626 o2->op_private &= ~OPpCONST_STRICT;
6627 else if (o2->op_type == OP_ENTERSUB) {
6628 /* accidental subroutine, revert to bareword */
6629 OP *gvop = ((UNOP*)o2)->op_first;
6630 if (gvop && gvop->op_type == OP_NULL) {
6631 gvop = ((UNOP*)gvop)->op_first;
6633 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6636 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6637 (gvop = ((UNOP*)gvop)->op_first) &&
6638 gvop->op_type == OP_GV)
6640 GV *gv = cGVOPx_gv(gvop);
6641 OP *sibling = o2->op_sibling;
6642 SV *n = newSVpvn("",0);
6644 gv_fullname3(n, gv, "");
6645 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6646 sv_chop(n, SvPVX(n)+6);
6647 o2 = newSVOP(OP_CONST, 0, n);
6648 prev->op_sibling = o2;
6649 o2->op_sibling = sibling;
6665 if (contextclass++ == 0) {
6666 e = strchr(proto, ']');
6667 if (!e || e == proto)
6681 if (o2->op_type == OP_RV2GV)
6684 bad_type(arg, "symbol", gv_ename(namegv), o2);
6687 if (o2->op_type == OP_ENTERSUB)
6690 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6693 if (o2->op_type == OP_RV2SV ||
6694 o2->op_type == OP_PADSV ||
6695 o2->op_type == OP_HELEM ||
6696 o2->op_type == OP_AELEM ||
6697 o2->op_type == OP_THREADSV)
6700 bad_type(arg, "scalar", gv_ename(namegv), o2);
6703 if (o2->op_type == OP_RV2AV ||
6704 o2->op_type == OP_PADAV)
6707 bad_type(arg, "array", gv_ename(namegv), o2);
6710 if (o2->op_type == OP_RV2HV ||
6711 o2->op_type == OP_PADHV)
6714 bad_type(arg, "hash", gv_ename(namegv), o2);
6719 OP* sib = kid->op_sibling;
6720 kid->op_sibling = 0;
6721 o2 = newUNOP(OP_REFGEN, 0, kid);
6722 o2->op_sibling = sib;
6723 prev->op_sibling = o2;
6725 if (contextclass && e) {
6740 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6741 gv_ename(namegv), SvPV((SV*)cv, n_a));
6746 mod(o2, OP_ENTERSUB);
6748 o2 = o2->op_sibling;
6750 if (proto && !optional &&
6751 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6752 return too_few_arguments(o, gv_ename(namegv));
6757 Perl_ck_svconst(pTHX_ OP *o)
6759 SvREADONLY_on(cSVOPo->op_sv);
6764 Perl_ck_trunc(pTHX_ OP *o)
6766 if (o->op_flags & OPf_KIDS) {
6767 SVOP *kid = (SVOP*)cUNOPo->op_first;
6769 if (kid->op_type == OP_NULL)
6770 kid = (SVOP*)kid->op_sibling;
6771 if (kid && kid->op_type == OP_CONST &&
6772 (kid->op_private & OPpCONST_BARE))
6774 o->op_flags |= OPf_SPECIAL;
6775 kid->op_private &= ~OPpCONST_STRICT;
6782 Perl_ck_substr(pTHX_ OP *o)
6785 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6786 OP *kid = cLISTOPo->op_first;
6788 if (kid->op_type == OP_NULL)
6789 kid = kid->op_sibling;
6791 kid->op_flags |= OPf_MOD;
6797 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6800 Perl_peep(pTHX_ register OP *o)
6802 register OP* oldop = 0;
6805 if (!o || o->op_seq)
6809 SAVEVPTR(PL_curcop);
6810 for (; o; o = o->op_next) {
6816 switch (o->op_type) {
6820 PL_curcop = ((COP*)o); /* for warnings */
6821 o->op_seq = PL_op_seqmax++;
6825 if (cSVOPo->op_private & OPpCONST_STRICT)
6826 no_bareword_allowed(o);
6828 /* Relocate sv to the pad for thread safety.
6829 * Despite being a "constant", the SV is written to,
6830 * for reference counts, sv_upgrade() etc. */
6832 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6833 if (SvPADTMP(cSVOPo->op_sv)) {
6834 /* If op_sv is already a PADTMP then it is being used by
6835 * some pad, so make a copy. */
6836 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6837 SvREADONLY_on(PL_curpad[ix]);
6838 SvREFCNT_dec(cSVOPo->op_sv);
6841 SvREFCNT_dec(PL_curpad[ix]);
6842 SvPADTMP_on(cSVOPo->op_sv);
6843 PL_curpad[ix] = cSVOPo->op_sv;
6844 /* XXX I don't know how this isn't readonly already. */
6845 SvREADONLY_on(PL_curpad[ix]);
6847 cSVOPo->op_sv = Nullsv;
6851 o->op_seq = PL_op_seqmax++;
6855 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6856 if (o->op_next->op_private & OPpTARGET_MY) {
6857 if (o->op_flags & OPf_STACKED) /* chained concats */
6858 goto ignore_optimization;
6860 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6861 o->op_targ = o->op_next->op_targ;
6862 o->op_next->op_targ = 0;
6863 o->op_private |= OPpTARGET_MY;
6866 op_null(o->op_next);
6868 ignore_optimization:
6869 o->op_seq = PL_op_seqmax++;
6872 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6873 o->op_seq = PL_op_seqmax++;
6874 break; /* Scalar stub must produce undef. List stub is noop */
6878 if (o->op_targ == OP_NEXTSTATE
6879 || o->op_targ == OP_DBSTATE
6880 || o->op_targ == OP_SETSTATE)
6882 PL_curcop = ((COP*)o);
6884 /* XXX: We avoid setting op_seq here to prevent later calls
6885 to peep() from mistakenly concluding that optimisation
6886 has already occurred. This doesn't fix the real problem,
6887 though (See 20010220.007). AMS 20010719 */
6888 if (oldop && o->op_next) {
6889 oldop->op_next = o->op_next;
6897 if (oldop && o->op_next) {
6898 oldop->op_next = o->op_next;
6901 o->op_seq = PL_op_seqmax++;
6905 if (o->op_next->op_type == OP_RV2SV) {
6906 if (!(o->op_next->op_private & OPpDEREF)) {
6907 op_null(o->op_next);
6908 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6910 o->op_next = o->op_next->op_next;
6911 o->op_type = OP_GVSV;
6912 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6915 else if (o->op_next->op_type == OP_RV2AV) {
6916 OP* pop = o->op_next->op_next;
6918 if (pop->op_type == OP_CONST &&
6919 (PL_op = pop->op_next) &&
6920 pop->op_next->op_type == OP_AELEM &&
6921 !(pop->op_next->op_private &
6922 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6923 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6928 op_null(o->op_next);
6929 op_null(pop->op_next);
6931 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6932 o->op_next = pop->op_next->op_next;
6933 o->op_type = OP_AELEMFAST;
6934 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6935 o->op_private = (U8)i;
6940 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6942 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6943 /* XXX could check prototype here instead of just carping */
6944 SV *sv = sv_newmortal();
6945 gv_efullname3(sv, gv, Nullch);
6946 Perl_warner(aTHX_ WARN_PROTOTYPE,
6947 "%s() called too early to check prototype",
6951 else if (o->op_next->op_type == OP_READLINE
6952 && o->op_next->op_next->op_type == OP_CONCAT
6953 && (o->op_next->op_next->op_flags & OPf_STACKED))
6955 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6956 o->op_type = OP_RCATLINE;
6957 o->op_flags |= OPf_STACKED;
6958 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6959 op_null(o->op_next->op_next);
6960 op_null(o->op_next);
6963 o->op_seq = PL_op_seqmax++;
6974 o->op_seq = PL_op_seqmax++;
6975 while (cLOGOP->op_other->op_type == OP_NULL)
6976 cLOGOP->op_other = cLOGOP->op_other->op_next;
6977 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6982 o->op_seq = PL_op_seqmax++;
6983 while (cLOOP->op_redoop->op_type == OP_NULL)
6984 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6985 peep(cLOOP->op_redoop);
6986 while (cLOOP->op_nextop->op_type == OP_NULL)
6987 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6988 peep(cLOOP->op_nextop);
6989 while (cLOOP->op_lastop->op_type == OP_NULL)
6990 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6991 peep(cLOOP->op_lastop);
6997 o->op_seq = PL_op_seqmax++;
6998 while (cPMOP->op_pmreplstart &&
6999 cPMOP->op_pmreplstart->op_type == OP_NULL)
7000 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7001 peep(cPMOP->op_pmreplstart);
7005 o->op_seq = PL_op_seqmax++;
7006 if (ckWARN(WARN_SYNTAX) && o->op_next
7007 && o->op_next->op_type == OP_NEXTSTATE) {
7008 if (o->op_next->op_sibling &&
7009 o->op_next->op_sibling->op_type != OP_EXIT &&
7010 o->op_next->op_sibling->op_type != OP_WARN &&
7011 o->op_next->op_sibling->op_type != OP_DIE) {
7012 line_t oldline = CopLINE(PL_curcop);
7014 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7015 Perl_warner(aTHX_ WARN_EXEC,
7016 "Statement unlikely to be reached");
7017 Perl_warner(aTHX_ WARN_EXEC,
7018 "\t(Maybe you meant system() when you said exec()?)\n");
7019 CopLINE_set(PL_curcop, oldline);
7028 SV **svp, **indsvp, *sv;
7033 o->op_seq = PL_op_seqmax++;
7035 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7038 /* Make the CONST have a shared SV */
7039 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7040 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7041 key = SvPV(sv, keylen);
7042 lexname = newSVpvn_share(key,
7043 SvUTF8(sv) ? -(I32)keylen : keylen,
7049 if ((o->op_private & (OPpLVAL_INTRO)))
7052 rop = (UNOP*)((BINOP*)o)->op_first;
7053 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7055 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7056 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7058 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7059 if (!fields || !GvHV(*fields))
7061 key = SvPV(*svp, keylen);
7062 indsvp = hv_fetch(GvHV(*fields), key,
7063 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7065 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7066 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7068 ind = SvIV(*indsvp);
7070 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7071 rop->op_type = OP_RV2AV;
7072 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7073 o->op_type = OP_AELEM;
7074 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7076 if (SvREADONLY(*svp))
7078 SvFLAGS(sv) |= (SvFLAGS(*svp)
7079 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7089 SV **svp, **indsvp, *sv;
7093 SVOP *first_key_op, *key_op;
7095 o->op_seq = PL_op_seqmax++;
7096 if ((o->op_private & (OPpLVAL_INTRO))
7097 /* I bet there's always a pushmark... */
7098 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7099 /* hmmm, no optimization if list contains only one key. */
7101 rop = (UNOP*)((LISTOP*)o)->op_last;
7102 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7104 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7105 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7107 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7108 if (!fields || !GvHV(*fields))
7110 /* Again guessing that the pushmark can be jumped over.... */
7111 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7112 ->op_first->op_sibling;
7113 /* Check that the key list contains only constants. */
7114 for (key_op = first_key_op; key_op;
7115 key_op = (SVOP*)key_op->op_sibling)
7116 if (key_op->op_type != OP_CONST)
7120 rop->op_type = OP_RV2AV;
7121 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7122 o->op_type = OP_ASLICE;
7123 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7124 for (key_op = first_key_op; key_op;
7125 key_op = (SVOP*)key_op->op_sibling) {
7126 svp = cSVOPx_svp(key_op);
7127 key = SvPV(*svp, keylen);
7128 indsvp = hv_fetch(GvHV(*fields), key,
7129 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7131 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7132 "in variable %s of type %s",
7133 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7135 ind = SvIV(*indsvp);
7137 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7139 if (SvREADONLY(*svp))
7141 SvFLAGS(sv) |= (SvFLAGS(*svp)
7142 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7150 o->op_seq = PL_op_seqmax++;
7160 char* Perl_custom_op_name(pTHX_ OP* o)
7162 IV index = PTR2IV(o->op_ppaddr);
7166 if (!PL_custom_op_names) /* This probably shouldn't happen */
7167 return PL_op_name[OP_CUSTOM];
7169 keysv = sv_2mortal(newSViv(index));
7171 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7173 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7175 return SvPV_nolen(HeVAL(he));
7178 char* Perl_custom_op_desc(pTHX_ OP* o)
7180 IV index = PTR2IV(o->op_ppaddr);
7184 if (!PL_custom_op_descs)
7185 return PL_op_desc[OP_CUSTOM];
7187 keysv = sv_2mortal(newSViv(index));
7189 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7191 return PL_op_desc[OP_CUSTOM];
7193 return SvPV_nolen(HeVAL(he));
7199 /* Efficient sub that returns a constant scalar value. */
7201 const_sv_xsub(pTHX_ CV* cv)
7206 Perl_croak(aTHX_ "usage: %s::%s()",
7207 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7211 ST(0) = (SV*)XSANY.any_ptr;