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 if (o->op_private & OPpENTERSUB_NOMOD)
1421 else { /* lvalue subroutine call */
1422 o->op_private |= OPpLVAL_INTRO;
1423 PL_modcount = RETURN_UNLIMITED_NUMBER;
1424 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1425 /* Backward compatibility mode: */
1426 o->op_private |= OPpENTERSUB_INARGS;
1429 else { /* Compile-time error message: */
1430 OP *kid = cUNOPo->op_first;
1434 if (kid->op_type == OP_PUSHMARK)
1436 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1438 "panic: unexpected lvalue entersub "
1439 "args: type/targ %ld:%"UVuf,
1440 (long)kid->op_type, (UV)kid->op_targ);
1441 kid = kLISTOP->op_first;
1443 while (kid->op_sibling)
1444 kid = kid->op_sibling;
1445 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1447 if (kid->op_type == OP_METHOD_NAMED
1448 || kid->op_type == OP_METHOD)
1452 NewOp(1101, newop, 1, UNOP);
1453 newop->op_type = OP_RV2CV;
1454 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1455 newop->op_first = Nullop;
1456 newop->op_next = (OP*)newop;
1457 kid->op_sibling = (OP*)newop;
1458 newop->op_private |= OPpLVAL_INTRO;
1462 if (kid->op_type != OP_RV2CV)
1464 "panic: unexpected lvalue entersub "
1465 "entry via type/targ %ld:%"UVuf,
1466 (long)kid->op_type, (UV)kid->op_targ);
1467 kid->op_private |= OPpLVAL_INTRO;
1468 break; /* Postpone until runtime */
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1474 kid = kUNOP->op_first;
1475 if (kid->op_type == OP_NULL)
1477 "Unexpected constant lvalue entersub "
1478 "entry via type/targ %ld:%"UVuf,
1479 (long)kid->op_type, (UV)kid->op_targ);
1480 if (kid->op_type != OP_GV) {
1481 /* Restore RV2CV to check lvalueness */
1483 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1484 okid->op_next = kid->op_next;
1485 kid->op_next = okid;
1488 okid->op_next = Nullop;
1489 okid->op_type = OP_RV2CV;
1491 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1492 okid->op_private |= OPpLVAL_INTRO;
1496 cv = GvCV(kGVOP_gv);
1506 /* grep, foreach, subcalls, refgen */
1507 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1509 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1510 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1512 : (o->op_type == OP_ENTERSUB
1513 ? "non-lvalue subroutine call"
1515 type ? PL_op_desc[type] : "local"));
1529 case OP_RIGHT_SHIFT:
1538 if (!(o->op_flags & OPf_STACKED))
1544 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1550 if (!type && cUNOPo->op_first->op_type != OP_GV)
1551 Perl_croak(aTHX_ "Can't localize through a reference");
1552 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1553 PL_modcount = RETURN_UNLIMITED_NUMBER;
1554 return o; /* Treat \(@foo) like ordinary list. */
1558 if (scalar_mod_type(o, type))
1560 ref(cUNOPo->op_first, o->op_type);
1564 if (type == OP_LEAVESUBLV)
1565 o->op_private |= OPpMAYBE_LVSUB;
1571 PL_modcount = RETURN_UNLIMITED_NUMBER;
1574 if (!type && cUNOPo->op_first->op_type != OP_GV)
1575 Perl_croak(aTHX_ "Can't localize through a reference");
1576 ref(cUNOPo->op_first, o->op_type);
1580 PL_hints |= HINT_BLOCK_SCOPE;
1590 PL_modcount = RETURN_UNLIMITED_NUMBER;
1591 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1592 return o; /* Treat \(@foo) like ordinary list. */
1593 if (scalar_mod_type(o, type))
1595 if (type == OP_LEAVESUBLV)
1596 o->op_private |= OPpMAYBE_LVSUB;
1601 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1602 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1605 #ifdef USE_5005THREADS
1607 PL_modcount++; /* XXX ??? */
1609 #endif /* USE_5005THREADS */
1615 if (type != OP_SASSIGN)
1619 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1624 if (type == OP_LEAVESUBLV)
1625 o->op_private |= OPpMAYBE_LVSUB;
1627 pad_free(o->op_targ);
1628 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1629 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1630 if (o->op_flags & OPf_KIDS)
1631 mod(cBINOPo->op_first->op_sibling, type);
1636 ref(cBINOPo->op_first, o->op_type);
1637 if (type == OP_ENTERSUB &&
1638 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1639 o->op_private |= OPpLVAL_DEFER;
1640 if (type == OP_LEAVESUBLV)
1641 o->op_private |= OPpMAYBE_LVSUB;
1649 if (o->op_flags & OPf_KIDS)
1650 mod(cLISTOPo->op_last, type);
1654 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1656 else if (!(o->op_flags & OPf_KIDS))
1658 if (o->op_targ != OP_LIST) {
1659 mod(cBINOPo->op_first, type);
1664 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1669 if (type != OP_LEAVESUBLV)
1671 break; /* mod()ing was handled by ck_return() */
1674 /* [20011101.069] File test operators interpret OPf_REF to mean that
1675 their argument is a filehandle; thus \stat(".") should not set
1677 if (type == OP_REFGEN &&
1678 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1681 if (type != OP_LEAVESUBLV)
1682 o->op_flags |= OPf_MOD;
1684 if (type == OP_AASSIGN || type == OP_SASSIGN)
1685 o->op_flags |= OPf_SPECIAL|OPf_REF;
1687 o->op_private |= OPpLVAL_INTRO;
1688 o->op_flags &= ~OPf_SPECIAL;
1689 PL_hints |= HINT_BLOCK_SCOPE;
1691 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1692 && type != OP_LEAVESUBLV)
1693 o->op_flags |= OPf_REF;
1698 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1702 if (o->op_type == OP_RV2GV)
1726 case OP_RIGHT_SHIFT:
1745 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1747 switch (o->op_type) {
1755 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1768 Perl_refkids(pTHX_ OP *o, I32 type)
1771 if (o && o->op_flags & OPf_KIDS) {
1772 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1779 Perl_ref(pTHX_ OP *o, I32 type)
1783 if (!o || PL_error_count)
1786 switch (o->op_type) {
1788 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1789 !(o->op_flags & OPf_STACKED)) {
1790 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1791 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1792 assert(cUNOPo->op_first->op_type == OP_NULL);
1793 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1794 o->op_flags |= OPf_SPECIAL;
1799 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1803 if (type == OP_DEFINED)
1804 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1805 ref(cUNOPo->op_first, o->op_type);
1808 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1809 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1810 : type == OP_RV2HV ? OPpDEREF_HV
1812 o->op_flags |= OPf_MOD;
1817 o->op_flags |= OPf_MOD; /* XXX ??? */
1822 o->op_flags |= OPf_REF;
1825 if (type == OP_DEFINED)
1826 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1827 ref(cUNOPo->op_first, o->op_type);
1832 o->op_flags |= OPf_REF;
1837 if (!(o->op_flags & OPf_KIDS))
1839 ref(cBINOPo->op_first, type);
1843 ref(cBINOPo->op_first, o->op_type);
1844 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1845 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1846 : type == OP_RV2HV ? OPpDEREF_HV
1848 o->op_flags |= OPf_MOD;
1856 if (!(o->op_flags & OPf_KIDS))
1858 ref(cLISTOPo->op_last, type);
1868 S_dup_attrlist(pTHX_ OP *o)
1872 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1873 * where the first kid is OP_PUSHMARK and the remaining ones
1874 * are OP_CONST. We need to push the OP_CONST values.
1876 if (o->op_type == OP_CONST)
1877 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1879 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1880 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1881 if (o->op_type == OP_CONST)
1882 rop = append_elem(OP_LIST, rop,
1883 newSVOP(OP_CONST, o->op_flags,
1884 SvREFCNT_inc(cSVOPo->op_sv)));
1891 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1895 /* fake up C<use attributes $pkg,$rv,@attrs> */
1896 ENTER; /* need to protect against side-effects of 'use' */
1899 stashsv = newSVpv(HvNAME(stash), 0);
1901 stashsv = &PL_sv_no;
1903 #define ATTRSMODULE "attributes"
1904 #define ATTRSMODULE_PM "attributes.pm"
1908 /* Don't force the C<use> if we don't need it. */
1909 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1910 sizeof(ATTRSMODULE_PM)-1, 0);
1911 if (svp && *svp != &PL_sv_undef)
1912 ; /* already in %INC */
1914 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1915 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1919 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1920 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1922 prepend_elem(OP_LIST,
1923 newSVOP(OP_CONST, 0, stashsv),
1924 prepend_elem(OP_LIST,
1925 newSVOP(OP_CONST, 0,
1927 dup_attrlist(attrs))));
1933 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1935 OP *pack, *imop, *arg;
1941 assert(target->op_type == OP_PADSV ||
1942 target->op_type == OP_PADHV ||
1943 target->op_type == OP_PADAV);
1945 /* Ensure that attributes.pm is loaded. */
1946 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1948 /* Need package name for method call. */
1949 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1951 /* Build up the real arg-list. */
1953 stashsv = newSVpv(HvNAME(stash), 0);
1955 stashsv = &PL_sv_no;
1956 arg = newOP(OP_PADSV, 0);
1957 arg->op_targ = target->op_targ;
1958 arg = prepend_elem(OP_LIST,
1959 newSVOP(OP_CONST, 0, stashsv),
1960 prepend_elem(OP_LIST,
1961 newUNOP(OP_REFGEN, 0,
1962 mod(arg, OP_REFGEN)),
1963 dup_attrlist(attrs)));
1965 /* Fake up a method call to import */
1966 meth = newSVpvn("import", 6);
1967 (void)SvUPGRADE(meth, SVt_PVIV);
1968 (void)SvIOK_on(meth);
1969 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1970 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1971 append_elem(OP_LIST,
1972 prepend_elem(OP_LIST, pack, list(arg)),
1973 newSVOP(OP_METHOD_NAMED, 0, meth)));
1974 imop->op_private |= OPpENTERSUB_NOMOD;
1976 /* Combine the ops. */
1977 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1981 =notfor apidoc apply_attrs_string
1983 Attempts to apply a list of attributes specified by the C<attrstr> and
1984 C<len> arguments to the subroutine identified by the C<cv> argument which
1985 is expected to be associated with the package identified by the C<stashpv>
1986 argument (see L<attributes>). It gets this wrong, though, in that it
1987 does not correctly identify the boundaries of the individual attribute
1988 specifications within C<attrstr>. This is not really intended for the
1989 public API, but has to be listed here for systems such as AIX which
1990 need an explicit export list for symbols. (It's called from XS code
1991 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1992 to respect attribute syntax properly would be welcome.
1998 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1999 char *attrstr, STRLEN len)
2004 len = strlen(attrstr);
2008 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2010 char *sstr = attrstr;
2011 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2012 attrs = append_elem(OP_LIST, attrs,
2013 newSVOP(OP_CONST, 0,
2014 newSVpvn(sstr, attrstr-sstr)));
2018 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2019 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2020 Nullsv, prepend_elem(OP_LIST,
2021 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2022 prepend_elem(OP_LIST,
2023 newSVOP(OP_CONST, 0,
2029 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2034 if (!o || PL_error_count)
2038 if (type == OP_LIST) {
2039 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2040 my_kid(kid, attrs, imopsp);
2041 } else if (type == OP_UNDEF) {
2043 } else if (type == OP_RV2SV || /* "our" declaration */
2045 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2046 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2047 yyerror(form("Can't declare %s in my", OP_DESC(o)));
2050 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2052 PL_in_my_stash = Nullhv;
2053 apply_attrs(GvSTASH(gv),
2054 (type == OP_RV2SV ? GvSV(gv) :
2055 type == OP_RV2AV ? (SV*)GvAV(gv) :
2056 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2059 o->op_private |= OPpOUR_INTRO;
2062 else if (type != OP_PADSV &&
2065 type != OP_PUSHMARK)
2067 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2069 PL_in_my == KEY_our ? "our" : "my"));
2072 else if (attrs && type != OP_PUSHMARK) {
2077 PL_in_my_stash = Nullhv;
2079 /* check for C<my Dog $spot> when deciding package */
2080 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2081 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2082 stash = SvSTASH(*namesvp);
2084 stash = PL_curstash;
2085 apply_attrs_my(stash, o, attrs, imopsp);
2087 o->op_flags |= OPf_MOD;
2088 o->op_private |= OPpLVAL_INTRO;
2093 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2096 int maybe_scalar = 0;
2098 if (o->op_flags & OPf_PARENS)
2104 o = my_kid(o, attrs, &rops);
2106 if (maybe_scalar && o->op_type == OP_PADSV) {
2107 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2108 o->op_private |= OPpLVAL_INTRO;
2111 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2114 PL_in_my_stash = Nullhv;
2119 Perl_my(pTHX_ OP *o)
2121 return my_attrs(o, Nullop);
2125 Perl_sawparens(pTHX_ OP *o)
2128 o->op_flags |= OPf_PARENS;
2133 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2137 if (ckWARN(WARN_MISC) &&
2138 (left->op_type == OP_RV2AV ||
2139 left->op_type == OP_RV2HV ||
2140 left->op_type == OP_PADAV ||
2141 left->op_type == OP_PADHV)) {
2142 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2143 right->op_type == OP_TRANS)
2144 ? right->op_type : OP_MATCH];
2145 const char *sample = ((left->op_type == OP_RV2AV ||
2146 left->op_type == OP_PADAV)
2147 ? "@array" : "%hash");
2148 Perl_warner(aTHX_ WARN_MISC,
2149 "Applying %s to %s will act on scalar(%s)",
2150 desc, sample, sample);
2153 if (right->op_type == OP_CONST &&
2154 cSVOPx(right)->op_private & OPpCONST_BARE &&
2155 cSVOPx(right)->op_private & OPpCONST_STRICT)
2157 no_bareword_allowed(right);
2160 if (!(right->op_flags & OPf_STACKED) &&
2161 (right->op_type == OP_MATCH ||
2162 right->op_type == OP_SUBST ||
2163 right->op_type == OP_TRANS)) {
2164 right->op_flags |= OPf_STACKED;
2165 if (right->op_type != OP_MATCH &&
2166 ! (right->op_type == OP_TRANS &&
2167 right->op_private & OPpTRANS_IDENTICAL))
2168 left = mod(left, right->op_type);
2169 if (right->op_type == OP_TRANS)
2170 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2172 o = prepend_elem(right->op_type, scalar(left), right);
2174 return newUNOP(OP_NOT, 0, scalar(o));
2178 return bind_match(type, left,
2179 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2183 Perl_invert(pTHX_ OP *o)
2187 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2188 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2192 Perl_scope(pTHX_ OP *o)
2195 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2196 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2197 o->op_type = OP_LEAVE;
2198 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2201 if (o->op_type == OP_LINESEQ) {
2203 o->op_type = OP_SCOPE;
2204 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2205 kid = ((LISTOP*)o)->op_first;
2206 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2210 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2217 Perl_save_hints(pTHX)
2220 SAVESPTR(GvHV(PL_hintgv));
2221 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2222 SAVEFREESV(GvHV(PL_hintgv));
2226 Perl_block_start(pTHX_ int full)
2228 int retval = PL_savestack_ix;
2230 SAVEI32(PL_comppad_name_floor);
2231 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2233 PL_comppad_name_fill = PL_comppad_name_floor;
2234 if (PL_comppad_name_floor < 0)
2235 PL_comppad_name_floor = 0;
2236 SAVEI32(PL_min_intro_pending);
2237 SAVEI32(PL_max_intro_pending);
2238 PL_min_intro_pending = 0;
2239 SAVEI32(PL_comppad_name_fill);
2240 SAVEI32(PL_padix_floor);
2241 PL_padix_floor = PL_padix;
2242 PL_pad_reset_pending = FALSE;
2244 PL_hints &= ~HINT_BLOCK_SCOPE;
2245 SAVESPTR(PL_compiling.cop_warnings);
2246 if (! specialWARN(PL_compiling.cop_warnings)) {
2247 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2248 SAVEFREESV(PL_compiling.cop_warnings) ;
2250 SAVESPTR(PL_compiling.cop_io);
2251 if (! specialCopIO(PL_compiling.cop_io)) {
2252 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2253 SAVEFREESV(PL_compiling.cop_io) ;
2259 Perl_block_end(pTHX_ I32 floor, OP *seq)
2261 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2262 line_t copline = PL_copline;
2263 /* there should be a nextstate in every block */
2264 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2265 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2267 PL_pad_reset_pending = FALSE;
2268 PL_compiling.op_private = PL_hints;
2270 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2271 pad_leavemy(PL_comppad_name_fill);
2279 #ifdef USE_5005THREADS
2280 OP *o = newOP(OP_THREADSV, 0);
2281 o->op_targ = find_threadsv("_");
2284 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2285 #endif /* USE_5005THREADS */
2289 Perl_newPROG(pTHX_ OP *o)
2294 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2295 ((PL_in_eval & EVAL_KEEPERR)
2296 ? OPf_SPECIAL : 0), o);
2297 PL_eval_start = linklist(PL_eval_root);
2298 PL_eval_root->op_private |= OPpREFCOUNTED;
2299 OpREFCNT_set(PL_eval_root, 1);
2300 PL_eval_root->op_next = 0;
2301 CALL_PEEP(PL_eval_start);
2306 PL_main_root = scope(sawparens(scalarvoid(o)));
2307 PL_curcop = &PL_compiling;
2308 PL_main_start = LINKLIST(PL_main_root);
2309 PL_main_root->op_private |= OPpREFCOUNTED;
2310 OpREFCNT_set(PL_main_root, 1);
2311 PL_main_root->op_next = 0;
2312 CALL_PEEP(PL_main_start);
2315 /* Register with debugger */
2317 CV *cv = get_cv("DB::postponed", FALSE);
2321 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2323 call_sv((SV*)cv, G_DISCARD);
2330 Perl_localize(pTHX_ OP *o, I32 lex)
2332 if (o->op_flags & OPf_PARENS)
2335 if (ckWARN(WARN_PARENTHESIS)
2336 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2338 char *s = PL_bufptr;
2340 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2343 if (*s == ';' || *s == '=')
2344 Perl_warner(aTHX_ WARN_PARENTHESIS,
2345 "Parentheses missing around \"%s\" list",
2346 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2352 o = mod(o, OP_NULL); /* a bit kludgey */
2354 PL_in_my_stash = Nullhv;
2359 Perl_jmaybe(pTHX_ OP *o)
2361 if (o->op_type == OP_LIST) {
2363 #ifdef USE_5005THREADS
2364 o2 = newOP(OP_THREADSV, 0);
2365 o2->op_targ = find_threadsv(";");
2367 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2368 #endif /* USE_5005THREADS */
2369 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2375 Perl_fold_constants(pTHX_ register OP *o)
2378 I32 type = o->op_type;
2381 if (PL_opargs[type] & OA_RETSCALAR)
2383 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2384 o->op_targ = pad_alloc(type, SVs_PADTMP);
2386 /* integerize op, unless it happens to be C<-foo>.
2387 * XXX should pp_i_negate() do magic string negation instead? */
2388 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2389 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2390 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2392 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2395 if (!(PL_opargs[type] & OA_FOLDCONST))
2400 /* XXX might want a ck_negate() for this */
2401 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2413 /* XXX what about the numeric ops? */
2414 if (PL_hints & HINT_LOCALE)
2419 goto nope; /* Don't try to run w/ errors */
2421 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2422 if ((curop->op_type != OP_CONST ||
2423 (curop->op_private & OPpCONST_BARE)) &&
2424 curop->op_type != OP_LIST &&
2425 curop->op_type != OP_SCALAR &&
2426 curop->op_type != OP_NULL &&
2427 curop->op_type != OP_PUSHMARK)
2433 curop = LINKLIST(o);
2437 sv = *(PL_stack_sp--);
2438 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2439 pad_swipe(o->op_targ);
2440 else if (SvTEMP(sv)) { /* grab mortal temp? */
2441 (void)SvREFCNT_inc(sv);
2445 if (type == OP_RV2GV)
2446 return newGVOP(OP_GV, 0, (GV*)sv);
2448 /* try to smush double to int, but don't smush -2.0 to -2 */
2449 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2452 #ifdef PERL_PRESERVE_IVUV
2453 /* Only bother to attempt to fold to IV if
2454 most operators will benefit */
2458 return newSVOP(OP_CONST, 0, sv);
2462 if (!(PL_opargs[type] & OA_OTHERINT))
2465 if (!(PL_hints & HINT_INTEGER)) {
2466 if (type == OP_MODULO
2467 || type == OP_DIVIDE
2468 || !(o->op_flags & OPf_KIDS))
2473 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2474 if (curop->op_type == OP_CONST) {
2475 if (SvIOK(((SVOP*)curop)->op_sv))
2479 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2483 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2490 Perl_gen_constant_list(pTHX_ register OP *o)
2493 I32 oldtmps_floor = PL_tmps_floor;
2497 return o; /* Don't attempt to run with errors */
2499 PL_op = curop = LINKLIST(o);
2506 PL_tmps_floor = oldtmps_floor;
2508 o->op_type = OP_RV2AV;
2509 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2510 curop = ((UNOP*)o)->op_first;
2511 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2518 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2520 if (!o || o->op_type != OP_LIST)
2521 o = newLISTOP(OP_LIST, 0, o, Nullop);
2523 o->op_flags &= ~OPf_WANT;
2525 if (!(PL_opargs[type] & OA_MARK))
2526 op_null(cLISTOPo->op_first);
2529 o->op_ppaddr = PL_ppaddr[type];
2530 o->op_flags |= flags;
2532 o = CHECKOP(type, o);
2533 if (o->op_type != type)
2536 return fold_constants(o);
2539 /* List constructors */
2542 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2550 if (first->op_type != type
2551 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2553 return newLISTOP(type, 0, first, last);
2556 if (first->op_flags & OPf_KIDS)
2557 ((LISTOP*)first)->op_last->op_sibling = last;
2559 first->op_flags |= OPf_KIDS;
2560 ((LISTOP*)first)->op_first = last;
2562 ((LISTOP*)first)->op_last = last;
2567 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2575 if (first->op_type != type)
2576 return prepend_elem(type, (OP*)first, (OP*)last);
2578 if (last->op_type != type)
2579 return append_elem(type, (OP*)first, (OP*)last);
2581 first->op_last->op_sibling = last->op_first;
2582 first->op_last = last->op_last;
2583 first->op_flags |= (last->op_flags & OPf_KIDS);
2585 #ifdef PL_OP_SLAB_ALLOC
2593 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2601 if (last->op_type == type) {
2602 if (type == OP_LIST) { /* already a PUSHMARK there */
2603 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2604 ((LISTOP*)last)->op_first->op_sibling = first;
2605 if (!(first->op_flags & OPf_PARENS))
2606 last->op_flags &= ~OPf_PARENS;
2609 if (!(last->op_flags & OPf_KIDS)) {
2610 ((LISTOP*)last)->op_last = first;
2611 last->op_flags |= OPf_KIDS;
2613 first->op_sibling = ((LISTOP*)last)->op_first;
2614 ((LISTOP*)last)->op_first = first;
2616 last->op_flags |= OPf_KIDS;
2620 return newLISTOP(type, 0, first, last);
2626 Perl_newNULLLIST(pTHX)
2628 return newOP(OP_STUB, 0);
2632 Perl_force_list(pTHX_ OP *o)
2634 if (!o || o->op_type != OP_LIST)
2635 o = newLISTOP(OP_LIST, 0, o, Nullop);
2641 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2645 NewOp(1101, listop, 1, LISTOP);
2647 listop->op_type = type;
2648 listop->op_ppaddr = PL_ppaddr[type];
2651 listop->op_flags = flags;
2655 else if (!first && last)
2658 first->op_sibling = last;
2659 listop->op_first = first;
2660 listop->op_last = last;
2661 if (type == OP_LIST) {
2663 pushop = newOP(OP_PUSHMARK, 0);
2664 pushop->op_sibling = first;
2665 listop->op_first = pushop;
2666 listop->op_flags |= OPf_KIDS;
2668 listop->op_last = pushop;
2675 Perl_newOP(pTHX_ I32 type, I32 flags)
2678 NewOp(1101, o, 1, OP);
2680 o->op_ppaddr = PL_ppaddr[type];
2681 o->op_flags = flags;
2684 o->op_private = 0 + (flags >> 8);
2685 if (PL_opargs[type] & OA_RETSCALAR)
2687 if (PL_opargs[type] & OA_TARGET)
2688 o->op_targ = pad_alloc(type, SVs_PADTMP);
2689 return CHECKOP(type, o);
2693 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2698 first = newOP(OP_STUB, 0);
2699 if (PL_opargs[type] & OA_MARK)
2700 first = force_list(first);
2702 NewOp(1101, unop, 1, UNOP);
2703 unop->op_type = type;
2704 unop->op_ppaddr = PL_ppaddr[type];
2705 unop->op_first = first;
2706 unop->op_flags = flags | OPf_KIDS;
2707 unop->op_private = 1 | (flags >> 8);
2708 unop = (UNOP*) CHECKOP(type, unop);
2712 return fold_constants((OP *) unop);
2716 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2719 NewOp(1101, binop, 1, BINOP);
2722 first = newOP(OP_NULL, 0);
2724 binop->op_type = type;
2725 binop->op_ppaddr = PL_ppaddr[type];
2726 binop->op_first = first;
2727 binop->op_flags = flags | OPf_KIDS;
2730 binop->op_private = 1 | (flags >> 8);
2733 binop->op_private = 2 | (flags >> 8);
2734 first->op_sibling = last;
2737 binop = (BINOP*)CHECKOP(type, binop);
2738 if (binop->op_next || binop->op_type != type)
2741 binop->op_last = binop->op_first->op_sibling;
2743 return fold_constants((OP *)binop);
2747 uvcompare(const void *a, const void *b)
2749 if (*((UV *)a) < (*(UV *)b))
2751 if (*((UV *)a) > (*(UV *)b))
2753 if (*((UV *)a+1) < (*(UV *)b+1))
2755 if (*((UV *)a+1) > (*(UV *)b+1))
2761 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2763 SV *tstr = ((SVOP*)expr)->op_sv;
2764 SV *rstr = ((SVOP*)repl)->op_sv;
2767 U8 *t = (U8*)SvPV(tstr, tlen);
2768 U8 *r = (U8*)SvPV(rstr, rlen);
2775 register short *tbl;
2777 PL_hints |= HINT_BLOCK_SCOPE;
2778 complement = o->op_private & OPpTRANS_COMPLEMENT;
2779 del = o->op_private & OPpTRANS_DELETE;
2780 squash = o->op_private & OPpTRANS_SQUASH;
2783 o->op_private |= OPpTRANS_FROM_UTF;
2786 o->op_private |= OPpTRANS_TO_UTF;
2788 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2789 SV* listsv = newSVpvn("# comment\n",10);
2791 U8* tend = t + tlen;
2792 U8* rend = r + rlen;
2806 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2807 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2813 tsave = t = bytes_to_utf8(t, &len);
2816 if (!to_utf && rlen) {
2818 rsave = r = bytes_to_utf8(r, &len);
2822 /* There are several snags with this code on EBCDIC:
2823 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2824 2. scan_const() in toke.c has encoded chars in native encoding which makes
2825 ranges at least in EBCDIC 0..255 range the bottom odd.
2829 U8 tmpbuf[UTF8_MAXLEN+1];
2832 New(1109, cp, 2*tlen, UV);
2834 transv = newSVpvn("",0);
2836 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2838 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2840 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2844 cp[2*i+1] = cp[2*i];
2848 qsort(cp, i, 2*sizeof(UV), uvcompare);
2849 for (j = 0; j < i; j++) {
2851 diff = val - nextmin;
2853 t = uvuni_to_utf8(tmpbuf,nextmin);
2854 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2856 U8 range_mark = UTF_TO_NATIVE(0xff);
2857 t = uvuni_to_utf8(tmpbuf, val - 1);
2858 sv_catpvn(transv, (char *)&range_mark, 1);
2859 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2866 t = uvuni_to_utf8(tmpbuf,nextmin);
2867 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2869 U8 range_mark = UTF_TO_NATIVE(0xff);
2870 sv_catpvn(transv, (char *)&range_mark, 1);
2872 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2873 UNICODE_ALLOW_SUPER);
2874 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2875 t = (U8*)SvPVX(transv);
2876 tlen = SvCUR(transv);
2880 else if (!rlen && !del) {
2881 r = t; rlen = tlen; rend = tend;
2884 if ((!rlen && !del) || t == r ||
2885 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2887 o->op_private |= OPpTRANS_IDENTICAL;
2891 while (t < tend || tfirst <= tlast) {
2892 /* see if we need more "t" chars */
2893 if (tfirst > tlast) {
2894 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2896 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2898 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2905 /* now see if we need more "r" chars */
2906 if (rfirst > rlast) {
2908 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2910 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2912 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2921 rfirst = rlast = 0xffffffff;
2925 /* now see which range will peter our first, if either. */
2926 tdiff = tlast - tfirst;
2927 rdiff = rlast - rfirst;
2934 if (rfirst == 0xffffffff) {
2935 diff = tdiff; /* oops, pretend rdiff is infinite */
2937 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2938 (long)tfirst, (long)tlast);
2940 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2944 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2945 (long)tfirst, (long)(tfirst + diff),
2948 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2949 (long)tfirst, (long)rfirst);
2951 if (rfirst + diff > max)
2952 max = rfirst + diff;
2954 grows = (tfirst < rfirst &&
2955 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2967 else if (max > 0xff)
2972 Safefree(cPVOPo->op_pv);
2973 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2974 SvREFCNT_dec(listsv);
2976 SvREFCNT_dec(transv);
2978 if (!del && havefinal && rlen)
2979 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2980 newSVuv((UV)final), 0);
2983 o->op_private |= OPpTRANS_GROWS;
2995 tbl = (short*)cPVOPo->op_pv;
2997 Zero(tbl, 256, short);
2998 for (i = 0; i < tlen; i++)
3000 for (i = 0, j = 0; i < 256; i++) {
3011 if (i < 128 && r[j] >= 128)
3021 o->op_private |= OPpTRANS_IDENTICAL;
3026 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3027 tbl[0x100] = rlen - j;
3028 for (i=0; i < rlen - j; i++)
3029 tbl[0x101+i] = r[j+i];
3033 if (!rlen && !del) {
3036 o->op_private |= OPpTRANS_IDENTICAL;
3038 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3039 o->op_private |= OPpTRANS_IDENTICAL;
3041 for (i = 0; i < 256; i++)
3043 for (i = 0, j = 0; i < tlen; i++,j++) {
3046 if (tbl[t[i]] == -1)
3052 if (tbl[t[i]] == -1) {
3053 if (t[i] < 128 && r[j] >= 128)
3060 o->op_private |= OPpTRANS_GROWS;
3068 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3072 NewOp(1101, pmop, 1, PMOP);
3073 pmop->op_type = type;
3074 pmop->op_ppaddr = PL_ppaddr[type];
3075 pmop->op_flags = flags;
3076 pmop->op_private = 0 | (flags >> 8);
3078 if (PL_hints & HINT_RE_TAINT)
3079 pmop->op_pmpermflags |= PMf_RETAINT;
3080 if (PL_hints & HINT_LOCALE)
3081 pmop->op_pmpermflags |= PMf_LOCALE;
3082 pmop->op_pmflags = pmop->op_pmpermflags;
3087 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3088 repointer = av_pop((AV*)PL_regex_pad[0]);
3089 pmop->op_pmoffset = SvIV(repointer);
3090 SvREPADTMP_off(repointer);
3091 sv_setiv(repointer,0);
3093 repointer = newSViv(0);
3094 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3095 pmop->op_pmoffset = av_len(PL_regex_padav);
3096 PL_regex_pad = AvARRAY(PL_regex_padav);
3101 /* link into pm list */
3102 if (type != OP_TRANS && PL_curstash) {
3103 pmop->op_pmnext = HvPMROOT(PL_curstash);
3104 HvPMROOT(PL_curstash) = pmop;
3105 PmopSTASH_set(pmop,PL_curstash);
3112 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3116 I32 repl_has_vars = 0;
3118 if (o->op_type == OP_TRANS)
3119 return pmtrans(o, expr, repl);
3121 PL_hints |= HINT_BLOCK_SCOPE;
3124 if (expr->op_type == OP_CONST) {
3126 SV *pat = ((SVOP*)expr)->op_sv;
3127 char *p = SvPV(pat, plen);
3128 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3129 sv_setpvn(pat, "\\s+", 3);
3130 p = SvPV(pat, plen);
3131 pm->op_pmflags |= PMf_SKIPWHITE;
3133 if (DO_UTF8(pat) || (PL_hints & HINT_UTF8))
3134 pm->op_pmdynflags |= PMdf_UTF8;
3135 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3136 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3137 pm->op_pmflags |= PMf_WHITE;
3141 if (PL_hints & HINT_UTF8)
3142 pm->op_pmdynflags |= PMdf_UTF8;
3143 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3144 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3146 : OP_REGCMAYBE),0,expr);
3148 NewOp(1101, rcop, 1, LOGOP);
3149 rcop->op_type = OP_REGCOMP;
3150 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3151 rcop->op_first = scalar(expr);
3152 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3153 ? (OPf_SPECIAL | OPf_KIDS)
3155 rcop->op_private = 1;
3158 /* establish postfix order */
3159 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3161 rcop->op_next = expr;
3162 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3165 rcop->op_next = LINKLIST(expr);
3166 expr->op_next = (OP*)rcop;
3169 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3174 if (pm->op_pmflags & PMf_EVAL) {
3176 if (CopLINE(PL_curcop) < PL_multi_end)
3177 CopLINE_set(PL_curcop, PL_multi_end);
3179 #ifdef USE_5005THREADS
3180 else if (repl->op_type == OP_THREADSV
3181 && strchr("&`'123456789+",
3182 PL_threadsv_names[repl->op_targ]))
3186 #endif /* USE_5005THREADS */
3187 else if (repl->op_type == OP_CONST)
3191 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3192 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3193 #ifdef USE_5005THREADS
3194 if (curop->op_type == OP_THREADSV) {
3196 if (strchr("&`'123456789+", curop->op_private))
3200 if (curop->op_type == OP_GV) {
3201 GV *gv = cGVOPx_gv(curop);
3203 if (strchr("&`'123456789+", *GvENAME(gv)))
3206 #endif /* USE_5005THREADS */
3207 else if (curop->op_type == OP_RV2CV)
3209 else if (curop->op_type == OP_RV2SV ||
3210 curop->op_type == OP_RV2AV ||
3211 curop->op_type == OP_RV2HV ||
3212 curop->op_type == OP_RV2GV) {
3213 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3216 else if (curop->op_type == OP_PADSV ||
3217 curop->op_type == OP_PADAV ||
3218 curop->op_type == OP_PADHV ||
3219 curop->op_type == OP_PADANY) {
3222 else if (curop->op_type == OP_PUSHRE)
3223 ; /* Okay here, dangerous in newASSIGNOP */
3233 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3234 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3235 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3236 prepend_elem(o->op_type, scalar(repl), o);
3239 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3240 pm->op_pmflags |= PMf_MAYBE_CONST;
3241 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3243 NewOp(1101, rcop, 1, LOGOP);
3244 rcop->op_type = OP_SUBSTCONT;
3245 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3246 rcop->op_first = scalar(repl);
3247 rcop->op_flags |= OPf_KIDS;
3248 rcop->op_private = 1;
3251 /* establish postfix order */
3252 rcop->op_next = LINKLIST(repl);
3253 repl->op_next = (OP*)rcop;
3255 pm->op_pmreplroot = scalar((OP*)rcop);
3256 pm->op_pmreplstart = LINKLIST(rcop);
3265 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3268 NewOp(1101, svop, 1, SVOP);
3269 svop->op_type = type;
3270 svop->op_ppaddr = PL_ppaddr[type];
3272 svop->op_next = (OP*)svop;
3273 svop->op_flags = flags;
3274 if (PL_opargs[type] & OA_RETSCALAR)
3276 if (PL_opargs[type] & OA_TARGET)
3277 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3278 return CHECKOP(type, svop);
3282 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3285 NewOp(1101, padop, 1, PADOP);
3286 padop->op_type = type;
3287 padop->op_ppaddr = PL_ppaddr[type];
3288 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3289 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3290 PL_curpad[padop->op_padix] = sv;
3292 padop->op_next = (OP*)padop;
3293 padop->op_flags = flags;
3294 if (PL_opargs[type] & OA_RETSCALAR)
3296 if (PL_opargs[type] & OA_TARGET)
3297 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3298 return CHECKOP(type, padop);
3302 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3306 return newPADOP(type, flags, SvREFCNT_inc(gv));
3308 return newSVOP(type, flags, SvREFCNT_inc(gv));
3313 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3316 NewOp(1101, pvop, 1, PVOP);
3317 pvop->op_type = type;
3318 pvop->op_ppaddr = PL_ppaddr[type];
3320 pvop->op_next = (OP*)pvop;
3321 pvop->op_flags = flags;
3322 if (PL_opargs[type] & OA_RETSCALAR)
3324 if (PL_opargs[type] & OA_TARGET)
3325 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3326 return CHECKOP(type, pvop);
3330 Perl_package(pTHX_ OP *o)
3334 save_hptr(&PL_curstash);
3335 save_item(PL_curstname);
3340 name = SvPV(sv, len);
3341 PL_curstash = gv_stashpvn(name,len,TRUE);
3342 sv_setpvn(PL_curstname, name, len);
3346 deprecate("\"package\" with no arguments");
3347 sv_setpv(PL_curstname,"<none>");
3348 PL_curstash = Nullhv;
3350 PL_hints |= HINT_BLOCK_SCOPE;
3351 PL_copline = NOLINE;
3356 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3361 char *packname = Nullch;
3365 if (id->op_type != OP_CONST)
3366 Perl_croak(aTHX_ "Module name must be constant");
3370 if (version != Nullop) {
3371 SV *vesv = ((SVOP*)version)->op_sv;
3373 if (arg == Nullop && !SvNIOKp(vesv)) {
3380 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3381 Perl_croak(aTHX_ "Version number must be constant number");
3383 /* Make copy of id so we don't free it twice */
3384 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3386 /* Fake up a method call to VERSION */
3387 meth = newSVpvn("VERSION",7);
3388 sv_upgrade(meth, SVt_PVIV);
3389 (void)SvIOK_on(meth);
3390 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3391 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3392 append_elem(OP_LIST,
3393 prepend_elem(OP_LIST, pack, list(version)),
3394 newSVOP(OP_METHOD_NAMED, 0, meth)));
3398 /* Fake up an import/unimport */
3399 if (arg && arg->op_type == OP_STUB)
3400 imop = arg; /* no import on explicit () */
3401 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3402 imop = Nullop; /* use 5.0; */
3407 /* Make copy of id so we don't free it twice */
3408 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3410 /* Fake up a method call to import/unimport */
3411 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3412 (void)SvUPGRADE(meth, SVt_PVIV);
3413 (void)SvIOK_on(meth);
3414 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3415 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3416 append_elem(OP_LIST,
3417 prepend_elem(OP_LIST, pack, list(arg)),
3418 newSVOP(OP_METHOD_NAMED, 0, meth)));
3421 if (ckWARN(WARN_MISC) &&
3422 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3423 SvPOK(packsv = ((SVOP*)id)->op_sv))
3425 /* BEGIN will free the ops, so we need to make a copy */
3426 packlen = SvCUR(packsv);
3427 packname = savepvn(SvPVX(packsv), packlen);
3430 /* Fake up the BEGIN {}, which does its thing immediately. */
3432 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3435 append_elem(OP_LINESEQ,
3436 append_elem(OP_LINESEQ,
3437 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3438 newSTATEOP(0, Nullch, veop)),
3439 newSTATEOP(0, Nullch, imop) ));
3442 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3443 Perl_warner(aTHX_ WARN_MISC,
3444 "Package `%s' not found "
3445 "(did you use the incorrect case?)", packname);
3450 PL_hints |= HINT_BLOCK_SCOPE;
3451 PL_copline = NOLINE;
3456 =for apidoc load_module
3458 Loads the module whose name is pointed to by the string part of name.
3459 Note that the actual module name, not its filename, should be given.
3460 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3461 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3462 (or 0 for no flags). ver, if specified, provides version semantics
3463 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3464 arguments can be used to specify arguments to the module's import()
3465 method, similar to C<use Foo::Bar VERSION LIST>.
3470 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3473 va_start(args, ver);
3474 vload_module(flags, name, ver, &args);
3478 #ifdef PERL_IMPLICIT_CONTEXT
3480 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3484 va_start(args, ver);
3485 vload_module(flags, name, ver, &args);
3491 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3493 OP *modname, *veop, *imop;
3495 modname = newSVOP(OP_CONST, 0, name);
3496 modname->op_private |= OPpCONST_BARE;
3498 veop = newSVOP(OP_CONST, 0, ver);
3502 if (flags & PERL_LOADMOD_NOIMPORT) {
3503 imop = sawparens(newNULLLIST());
3505 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3506 imop = va_arg(*args, OP*);
3511 sv = va_arg(*args, SV*);
3513 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3514 sv = va_arg(*args, SV*);
3518 line_t ocopline = PL_copline;
3519 int oexpect = PL_expect;
3521 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3522 veop, modname, imop);
3523 PL_expect = oexpect;
3524 PL_copline = ocopline;
3529 Perl_dofile(pTHX_ OP *term)
3534 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3535 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3536 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3538 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3539 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3540 append_elem(OP_LIST, term,
3541 scalar(newUNOP(OP_RV2CV, 0,
3546 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3552 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3554 return newBINOP(OP_LSLICE, flags,
3555 list(force_list(subscript)),
3556 list(force_list(listval)) );
3560 S_list_assignment(pTHX_ register OP *o)
3565 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3566 o = cUNOPo->op_first;
3568 if (o->op_type == OP_COND_EXPR) {
3569 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3570 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3575 yyerror("Assignment to both a list and a scalar");
3579 if (o->op_type == OP_LIST &&
3580 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3581 o->op_private & OPpLVAL_INTRO)
3584 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3585 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3586 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3589 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3592 if (o->op_type == OP_RV2SV)
3599 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3604 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3605 return newLOGOP(optype, 0,
3606 mod(scalar(left), optype),
3607 newUNOP(OP_SASSIGN, 0, scalar(right)));
3610 return newBINOP(optype, OPf_STACKED,
3611 mod(scalar(left), optype), scalar(right));
3615 if (list_assignment(left)) {
3619 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3620 left = mod(left, OP_AASSIGN);
3628 curop = list(force_list(left));
3629 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3630 o->op_private = 0 | (flags >> 8);
3631 for (curop = ((LISTOP*)curop)->op_first;
3632 curop; curop = curop->op_sibling)
3634 if (curop->op_type == OP_RV2HV &&
3635 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3636 o->op_private |= OPpASSIGN_HASH;
3640 if (!(left->op_private & OPpLVAL_INTRO)) {
3643 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3644 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3645 if (curop->op_type == OP_GV) {
3646 GV *gv = cGVOPx_gv(curop);
3647 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3649 SvCUR(gv) = PL_generation;
3651 else if (curop->op_type == OP_PADSV ||
3652 curop->op_type == OP_PADAV ||
3653 curop->op_type == OP_PADHV ||
3654 curop->op_type == OP_PADANY) {
3655 SV **svp = AvARRAY(PL_comppad_name);
3656 SV *sv = svp[curop->op_targ];
3657 if (SvCUR(sv) == PL_generation)
3659 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3661 else if (curop->op_type == OP_RV2CV)
3663 else if (curop->op_type == OP_RV2SV ||
3664 curop->op_type == OP_RV2AV ||
3665 curop->op_type == OP_RV2HV ||
3666 curop->op_type == OP_RV2GV) {
3667 if (lastop->op_type != OP_GV) /* funny deref? */
3670 else if (curop->op_type == OP_PUSHRE) {
3671 if (((PMOP*)curop)->op_pmreplroot) {
3673 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3675 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3677 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3679 SvCUR(gv) = PL_generation;
3688 o->op_private |= OPpASSIGN_COMMON;
3690 if (right && right->op_type == OP_SPLIT) {
3692 if ((tmpop = ((LISTOP*)right)->op_first) &&
3693 tmpop->op_type == OP_PUSHRE)
3695 PMOP *pm = (PMOP*)tmpop;
3696 if (left->op_type == OP_RV2AV &&
3697 !(left->op_private & OPpLVAL_INTRO) &&
3698 !(o->op_private & OPpASSIGN_COMMON) )
3700 tmpop = ((UNOP*)left)->op_first;
3701 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3703 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3704 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3706 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3707 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3709 pm->op_pmflags |= PMf_ONCE;
3710 tmpop = cUNOPo->op_first; /* to list (nulled) */
3711 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3712 tmpop->op_sibling = Nullop; /* don't free split */
3713 right->op_next = tmpop->op_next; /* fix starting loc */
3714 op_free(o); /* blow off assign */
3715 right->op_flags &= ~OPf_WANT;
3716 /* "I don't know and I don't care." */
3721 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3722 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3724 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3726 sv_setiv(sv, PL_modcount+1);
3734 right = newOP(OP_UNDEF, 0);
3735 if (right->op_type == OP_READLINE) {
3736 right->op_flags |= OPf_STACKED;
3737 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3740 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3741 o = newBINOP(OP_SASSIGN, flags,
3742 scalar(right), mod(scalar(left), OP_SASSIGN) );
3754 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3756 U32 seq = intro_my();
3759 NewOp(1101, cop, 1, COP);
3760 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3761 cop->op_type = OP_DBSTATE;
3762 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3765 cop->op_type = OP_NEXTSTATE;
3766 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3768 cop->op_flags = flags;
3769 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3771 cop->op_private |= NATIVE_HINTS;
3773 PL_compiling.op_private = cop->op_private;
3774 cop->op_next = (OP*)cop;
3777 cop->cop_label = label;
3778 PL_hints |= HINT_BLOCK_SCOPE;
3781 cop->cop_arybase = PL_curcop->cop_arybase;
3782 if (specialWARN(PL_curcop->cop_warnings))
3783 cop->cop_warnings = PL_curcop->cop_warnings ;
3785 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3786 if (specialCopIO(PL_curcop->cop_io))
3787 cop->cop_io = PL_curcop->cop_io;
3789 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3792 if (PL_copline == NOLINE)
3793 CopLINE_set(cop, CopLINE(PL_curcop));
3795 CopLINE_set(cop, PL_copline);
3796 PL_copline = NOLINE;
3799 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3801 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3803 CopSTASH_set(cop, PL_curstash);
3805 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3806 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3807 if (svp && *svp != &PL_sv_undef ) {
3808 (void)SvIOK_on(*svp);
3809 SvIVX(*svp) = PTR2IV(cop);
3813 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3816 /* "Introduce" my variables to visible status. */
3824 if (! PL_min_intro_pending)
3825 return PL_cop_seqmax;
3827 svp = AvARRAY(PL_comppad_name);
3828 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3829 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3830 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3831 SvNVX(sv) = (NV)PL_cop_seqmax;
3834 PL_min_intro_pending = 0;
3835 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3836 return PL_cop_seqmax++;
3840 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3842 return new_logop(type, flags, &first, &other);
3846 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3850 OP *first = *firstp;
3851 OP *other = *otherp;
3853 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3854 return newBINOP(type, flags, scalar(first), scalar(other));
3856 scalarboolean(first);
3857 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3858 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3859 if (type == OP_AND || type == OP_OR) {
3865 first = *firstp = cUNOPo->op_first;
3867 first->op_next = o->op_next;
3868 cUNOPo->op_first = Nullop;
3872 if (first->op_type == OP_CONST) {
3873 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3874 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3875 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3886 else if (first->op_type == OP_WANTARRAY) {
3892 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3893 OP *k1 = ((UNOP*)first)->op_first;
3894 OP *k2 = k1->op_sibling;
3896 switch (first->op_type)
3899 if (k2 && k2->op_type == OP_READLINE
3900 && (k2->op_flags & OPf_STACKED)
3901 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3903 warnop = k2->op_type;
3908 if (k1->op_type == OP_READDIR
3909 || k1->op_type == OP_GLOB
3910 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3911 || k1->op_type == OP_EACH)
3913 warnop = ((k1->op_type == OP_NULL)
3914 ? k1->op_targ : k1->op_type);
3919 line_t oldline = CopLINE(PL_curcop);
3920 CopLINE_set(PL_curcop, PL_copline);
3921 Perl_warner(aTHX_ WARN_MISC,
3922 "Value of %s%s can be \"0\"; test with defined()",
3924 ((warnop == OP_READLINE || warnop == OP_GLOB)
3925 ? " construct" : "() operator"));
3926 CopLINE_set(PL_curcop, oldline);
3933 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3934 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3936 NewOp(1101, logop, 1, LOGOP);
3938 logop->op_type = type;
3939 logop->op_ppaddr = PL_ppaddr[type];
3940 logop->op_first = first;
3941 logop->op_flags = flags | OPf_KIDS;
3942 logop->op_other = LINKLIST(other);
3943 logop->op_private = 1 | (flags >> 8);
3945 /* establish postfix order */
3946 logop->op_next = LINKLIST(first);
3947 first->op_next = (OP*)logop;
3948 first->op_sibling = other;
3950 o = newUNOP(OP_NULL, 0, (OP*)logop);
3957 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3964 return newLOGOP(OP_AND, 0, first, trueop);
3966 return newLOGOP(OP_OR, 0, first, falseop);
3968 scalarboolean(first);
3969 if (first->op_type == OP_CONST) {
3970 if (SvTRUE(((SVOP*)first)->op_sv)) {
3981 else if (first->op_type == OP_WANTARRAY) {
3985 NewOp(1101, logop, 1, LOGOP);
3986 logop->op_type = OP_COND_EXPR;
3987 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3988 logop->op_first = first;
3989 logop->op_flags = flags | OPf_KIDS;
3990 logop->op_private = 1 | (flags >> 8);
3991 logop->op_other = LINKLIST(trueop);
3992 logop->op_next = LINKLIST(falseop);
3995 /* establish postfix order */
3996 start = LINKLIST(first);
3997 first->op_next = (OP*)logop;
3999 first->op_sibling = trueop;
4000 trueop->op_sibling = falseop;
4001 o = newUNOP(OP_NULL, 0, (OP*)logop);
4003 trueop->op_next = falseop->op_next = o;
4010 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4018 NewOp(1101, range, 1, LOGOP);
4020 range->op_type = OP_RANGE;
4021 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4022 range->op_first = left;
4023 range->op_flags = OPf_KIDS;
4024 leftstart = LINKLIST(left);
4025 range->op_other = LINKLIST(right);
4026 range->op_private = 1 | (flags >> 8);
4028 left->op_sibling = right;
4030 range->op_next = (OP*)range;
4031 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4032 flop = newUNOP(OP_FLOP, 0, flip);
4033 o = newUNOP(OP_NULL, 0, flop);
4035 range->op_next = leftstart;
4037 left->op_next = flip;
4038 right->op_next = flop;
4040 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4041 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4042 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4043 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4045 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4046 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4049 if (!flip->op_private || !flop->op_private)
4050 linklist(o); /* blow off optimizer unless constant */
4056 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4060 int once = block && block->op_flags & OPf_SPECIAL &&
4061 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4064 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4065 return block; /* do {} while 0 does once */
4066 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4067 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4068 expr = newUNOP(OP_DEFINED, 0,
4069 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4070 } else if (expr->op_flags & OPf_KIDS) {
4071 OP *k1 = ((UNOP*)expr)->op_first;
4072 OP *k2 = (k1) ? k1->op_sibling : NULL;
4073 switch (expr->op_type) {
4075 if (k2 && k2->op_type == OP_READLINE
4076 && (k2->op_flags & OPf_STACKED)
4077 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4078 expr = newUNOP(OP_DEFINED, 0, expr);
4082 if (k1->op_type == OP_READDIR
4083 || k1->op_type == OP_GLOB
4084 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4085 || k1->op_type == OP_EACH)
4086 expr = newUNOP(OP_DEFINED, 0, expr);
4092 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4093 o = new_logop(OP_AND, 0, &expr, &listop);
4096 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4098 if (once && o != listop)
4099 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4102 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4104 o->op_flags |= flags;
4106 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4111 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4119 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4120 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4121 expr = newUNOP(OP_DEFINED, 0,
4122 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4123 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4124 OP *k1 = ((UNOP*)expr)->op_first;
4125 OP *k2 = (k1) ? k1->op_sibling : NULL;
4126 switch (expr->op_type) {
4128 if (k2 && k2->op_type == OP_READLINE
4129 && (k2->op_flags & OPf_STACKED)
4130 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4131 expr = newUNOP(OP_DEFINED, 0, expr);
4135 if (k1->op_type == OP_READDIR
4136 || k1->op_type == OP_GLOB
4137 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4138 || k1->op_type == OP_EACH)
4139 expr = newUNOP(OP_DEFINED, 0, expr);
4145 block = newOP(OP_NULL, 0);
4147 block = scope(block);
4151 next = LINKLIST(cont);
4154 OP *unstack = newOP(OP_UNSTACK, 0);
4157 cont = append_elem(OP_LINESEQ, cont, unstack);
4158 if ((line_t)whileline != NOLINE) {
4159 PL_copline = whileline;
4160 cont = append_elem(OP_LINESEQ, cont,
4161 newSTATEOP(0, Nullch, Nullop));
4165 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4166 redo = LINKLIST(listop);
4169 PL_copline = whileline;
4171 o = new_logop(OP_AND, 0, &expr, &listop);
4172 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4173 op_free(expr); /* oops, it's a while (0) */
4175 return Nullop; /* listop already freed by new_logop */
4178 ((LISTOP*)listop)->op_last->op_next =
4179 (o == listop ? redo : LINKLIST(o));
4185 NewOp(1101,loop,1,LOOP);
4186 loop->op_type = OP_ENTERLOOP;
4187 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4188 loop->op_private = 0;
4189 loop->op_next = (OP*)loop;
4192 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4194 loop->op_redoop = redo;
4195 loop->op_lastop = o;
4196 o->op_private |= loopflags;
4199 loop->op_nextop = next;
4201 loop->op_nextop = o;
4203 o->op_flags |= flags;
4204 o->op_private |= (flags >> 8);
4209 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4217 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4218 sv->op_type = OP_RV2GV;
4219 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4221 else if (sv->op_type == OP_PADSV) { /* private variable */
4222 padoff = sv->op_targ;
4227 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4228 padoff = sv->op_targ;
4230 iterflags |= OPf_SPECIAL;
4235 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4238 #ifdef USE_5005THREADS
4239 padoff = find_threadsv("_");
4240 iterflags |= OPf_SPECIAL;
4242 sv = newGVOP(OP_GV, 0, PL_defgv);
4245 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4246 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4247 iterflags |= OPf_STACKED;
4249 else if (expr->op_type == OP_NULL &&
4250 (expr->op_flags & OPf_KIDS) &&
4251 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4253 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4254 * set the STACKED flag to indicate that these values are to be
4255 * treated as min/max values by 'pp_iterinit'.
4257 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4258 LOGOP* range = (LOGOP*) flip->op_first;
4259 OP* left = range->op_first;
4260 OP* right = left->op_sibling;
4263 range->op_flags &= ~OPf_KIDS;
4264 range->op_first = Nullop;
4266 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4267 listop->op_first->op_next = range->op_next;
4268 left->op_next = range->op_other;
4269 right->op_next = (OP*)listop;
4270 listop->op_next = listop->op_first;
4273 expr = (OP*)(listop);
4275 iterflags |= OPf_STACKED;
4278 expr = mod(force_list(expr), OP_GREPSTART);
4282 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4283 append_elem(OP_LIST, expr, scalar(sv))));
4284 assert(!loop->op_next);
4285 #ifdef PL_OP_SLAB_ALLOC
4288 NewOp(1234,tmp,1,LOOP);
4289 Copy(loop,tmp,1,LOOP);
4293 Renew(loop, 1, LOOP);
4295 loop->op_targ = padoff;
4296 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4297 PL_copline = forline;
4298 return newSTATEOP(0, label, wop);
4302 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4307 if (type != OP_GOTO || label->op_type == OP_CONST) {
4308 /* "last()" means "last" */
4309 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4310 o = newOP(type, OPf_SPECIAL);
4312 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4313 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4319 if (label->op_type == OP_ENTERSUB)
4320 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4321 o = newUNOP(type, OPf_STACKED, label);
4323 PL_hints |= HINT_BLOCK_SCOPE;
4328 Perl_cv_undef(pTHX_ CV *cv)
4330 #ifdef USE_5005THREADS
4332 MUTEX_DESTROY(CvMUTEXP(cv));
4333 Safefree(CvMUTEXP(cv));
4336 #endif /* USE_5005THREADS */
4339 if (CvFILE(cv) && !CvXSUB(cv)) {
4340 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4341 Safefree(CvFILE(cv));
4346 if (!CvXSUB(cv) && CvROOT(cv)) {
4347 #ifdef USE_5005THREADS
4348 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4349 Perl_croak(aTHX_ "Can't undef active subroutine");
4352 Perl_croak(aTHX_ "Can't undef active subroutine");
4353 #endif /* USE_5005THREADS */
4356 SAVEVPTR(PL_curpad);
4359 op_free(CvROOT(cv));
4360 CvROOT(cv) = Nullop;
4363 SvPOK_off((SV*)cv); /* forget prototype */
4365 /* Since closure prototypes have the same lifetime as the containing
4366 * CV, they don't hold a refcount on the outside CV. This avoids
4367 * the refcount loop between the outer CV (which keeps a refcount to
4368 * the closure prototype in the pad entry for pp_anoncode()) and the
4369 * closure prototype, and the ensuing memory leak. --GSAR */
4370 if (!CvANON(cv) || CvCLONED(cv))
4371 SvREFCNT_dec(CvOUTSIDE(cv));
4372 CvOUTSIDE(cv) = Nullcv;
4374 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4377 if (CvPADLIST(cv)) {
4378 /* may be during global destruction */
4379 if (SvREFCNT(CvPADLIST(cv))) {
4380 I32 i = AvFILLp(CvPADLIST(cv));
4382 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4383 SV* sv = svp ? *svp : Nullsv;
4386 if (sv == (SV*)PL_comppad_name)
4387 PL_comppad_name = Nullav;
4388 else if (sv == (SV*)PL_comppad) {
4389 PL_comppad = Nullav;
4390 PL_curpad = Null(SV**);
4394 SvREFCNT_dec((SV*)CvPADLIST(cv));
4396 CvPADLIST(cv) = Nullav;
4404 #ifdef DEBUG_CLOSURES
4406 S_cv_dump(pTHX_ CV *cv)
4409 CV *outside = CvOUTSIDE(cv);
4410 AV* padlist = CvPADLIST(cv);
4417 PerlIO_printf(Perl_debug_log,
4418 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4420 (CvANON(cv) ? "ANON"
4421 : (cv == PL_main_cv) ? "MAIN"
4422 : CvUNIQUE(cv) ? "UNIQUE"
4423 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4426 : CvANON(outside) ? "ANON"
4427 : (outside == PL_main_cv) ? "MAIN"
4428 : CvUNIQUE(outside) ? "UNIQUE"
4429 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4434 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4435 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4436 pname = AvARRAY(pad_name);
4437 ppad = AvARRAY(pad);
4439 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4440 if (SvPOK(pname[ix]))
4441 PerlIO_printf(Perl_debug_log,
4442 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4443 (int)ix, PTR2UV(ppad[ix]),
4444 SvFAKE(pname[ix]) ? "FAKE " : "",
4446 (IV)I_32(SvNVX(pname[ix])),
4449 #endif /* DEBUGGING */
4451 #endif /* DEBUG_CLOSURES */
4454 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4458 AV* protopadlist = CvPADLIST(proto);
4459 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4460 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4461 SV** pname = AvARRAY(protopad_name);
4462 SV** ppad = AvARRAY(protopad);
4463 I32 fname = AvFILLp(protopad_name);
4464 I32 fpad = AvFILLp(protopad);
4468 assert(!CvUNIQUE(proto));
4472 SAVESPTR(PL_comppad_name);
4473 SAVESPTR(PL_compcv);
4475 cv = PL_compcv = (CV*)NEWSV(1104,0);
4476 sv_upgrade((SV *)cv, SvTYPE(proto));
4477 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4480 #ifdef USE_5005THREADS
4481 New(666, CvMUTEXP(cv), 1, perl_mutex);
4482 MUTEX_INIT(CvMUTEXP(cv));
4484 #endif /* USE_5005THREADS */
4486 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4487 : savepv(CvFILE(proto));
4489 CvFILE(cv) = CvFILE(proto);
4491 CvGV(cv) = CvGV(proto);
4492 CvSTASH(cv) = CvSTASH(proto);
4493 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4494 CvSTART(cv) = CvSTART(proto);
4496 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4499 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4501 PL_comppad_name = newAV();
4502 for (ix = fname; ix >= 0; ix--)
4503 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4505 PL_comppad = newAV();
4507 comppadlist = newAV();
4508 AvREAL_off(comppadlist);
4509 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4510 av_store(comppadlist, 1, (SV*)PL_comppad);
4511 CvPADLIST(cv) = comppadlist;
4512 av_fill(PL_comppad, AvFILLp(protopad));
4513 PL_curpad = AvARRAY(PL_comppad);
4515 av = newAV(); /* will be @_ */
4517 av_store(PL_comppad, 0, (SV*)av);
4518 AvFLAGS(av) = AVf_REIFY;
4520 for (ix = fpad; ix > 0; ix--) {
4521 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4522 if (namesv && namesv != &PL_sv_undef) {
4523 char *name = SvPVX(namesv); /* XXX */
4524 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4525 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4526 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4528 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4530 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4532 else { /* our own lexical */
4535 /* anon code -- we'll come back for it */
4536 sv = SvREFCNT_inc(ppad[ix]);
4538 else if (*name == '@')
4540 else if (*name == '%')
4549 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4550 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4553 SV* sv = NEWSV(0,0);
4559 /* Now that vars are all in place, clone nested closures. */
4561 for (ix = fpad; ix > 0; ix--) {
4562 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4564 && namesv != &PL_sv_undef
4565 && !(SvFLAGS(namesv) & SVf_FAKE)
4566 && *SvPVX(namesv) == '&'
4567 && CvCLONE(ppad[ix]))
4569 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4570 SvREFCNT_dec(ppad[ix]);
4573 PL_curpad[ix] = (SV*)kid;
4577 #ifdef DEBUG_CLOSURES
4578 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4580 PerlIO_printf(Perl_debug_log, " from:\n");
4582 PerlIO_printf(Perl_debug_log, " to:\n");
4589 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4591 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4593 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4600 Perl_cv_clone(pTHX_ CV *proto)
4603 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4604 cv = cv_clone2(proto, CvOUTSIDE(proto));
4605 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4610 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4612 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4613 SV* msg = sv_newmortal();
4617 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4618 sv_setpv(msg, "Prototype mismatch:");
4620 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4622 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4623 sv_catpv(msg, " vs ");
4625 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4627 sv_catpv(msg, "none");
4628 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4632 static void const_sv_xsub(pTHX_ CV* cv);
4635 =for apidoc cv_const_sv
4637 If C<cv> is a constant sub eligible for inlining. returns the constant
4638 value returned by the sub. Otherwise, returns NULL.
4640 Constant subs can be created with C<newCONSTSUB> or as described in
4641 L<perlsub/"Constant Functions">.
4646 Perl_cv_const_sv(pTHX_ CV *cv)
4648 if (!cv || !CvCONST(cv))
4650 return (SV*)CvXSUBANY(cv).any_ptr;
4654 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4661 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4662 o = cLISTOPo->op_first->op_sibling;
4664 for (; o; o = o->op_next) {
4665 OPCODE type = o->op_type;
4667 if (sv && o->op_next == o)
4669 if (o->op_next != o) {
4670 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4672 if (type == OP_DBSTATE)
4675 if (type == OP_LEAVESUB || type == OP_RETURN)
4679 if (type == OP_CONST && cSVOPo->op_sv)
4681 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4682 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4683 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4687 /* We get here only from cv_clone2() while creating a closure.
4688 Copy the const value here instead of in cv_clone2 so that
4689 SvREADONLY_on doesn't lead to problems when leaving
4694 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4706 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4716 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4720 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4722 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4726 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4732 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4737 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4738 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4739 SV *sv = sv_newmortal();
4740 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4741 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4746 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4747 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4757 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4758 maximum a prototype before. */
4759 if (SvTYPE(gv) > SVt_NULL) {
4760 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4761 && ckWARN_d(WARN_PROTOTYPE))
4763 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4765 cv_ckproto((CV*)gv, NULL, ps);
4768 sv_setpv((SV*)gv, ps);
4770 sv_setiv((SV*)gv, -1);
4771 SvREFCNT_dec(PL_compcv);
4772 cv = PL_compcv = NULL;
4773 PL_sub_generation++;
4777 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4779 #ifdef GV_UNIQUE_CHECK
4780 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4781 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4785 if (!block || !ps || *ps || attrs)
4788 const_sv = op_const_sv(block, Nullcv);
4791 bool exists = CvROOT(cv) || CvXSUB(cv);
4793 #ifdef GV_UNIQUE_CHECK
4794 if (exists && GvUNIQUE(gv)) {
4795 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4799 /* if the subroutine doesn't exist and wasn't pre-declared
4800 * with a prototype, assume it will be AUTOLOADed,
4801 * skipping the prototype check
4803 if (exists || SvPOK(cv))
4804 cv_ckproto(cv, gv, ps);
4805 /* already defined (or promised)? */
4806 if (exists || GvASSUMECV(gv)) {
4807 if (!block && !attrs) {
4808 /* just a "sub foo;" when &foo is already defined */
4809 SAVEFREESV(PL_compcv);
4812 /* ahem, death to those who redefine active sort subs */
4813 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4814 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4816 if (ckWARN(WARN_REDEFINE)
4818 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4820 line_t oldline = CopLINE(PL_curcop);
4821 if (PL_copline != NOLINE)
4822 CopLINE_set(PL_curcop, PL_copline);
4823 Perl_warner(aTHX_ WARN_REDEFINE,
4824 CvCONST(cv) ? "Constant subroutine %s redefined"
4825 : "Subroutine %s redefined", name);
4826 CopLINE_set(PL_curcop, oldline);
4834 SvREFCNT_inc(const_sv);
4836 assert(!CvROOT(cv) && !CvCONST(cv));
4837 sv_setpv((SV*)cv, ""); /* prototype is "" */
4838 CvXSUBANY(cv).any_ptr = const_sv;
4839 CvXSUB(cv) = const_sv_xsub;
4844 cv = newCONSTSUB(NULL, name, const_sv);
4847 SvREFCNT_dec(PL_compcv);
4849 PL_sub_generation++;
4856 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4857 * before we clobber PL_compcv.
4861 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4862 stash = GvSTASH(CvGV(cv));
4863 else if (CvSTASH(cv))
4864 stash = CvSTASH(cv);
4866 stash = PL_curstash;
4869 /* possibly about to re-define existing subr -- ignore old cv */
4870 rcv = (SV*)PL_compcv;
4871 if (name && GvSTASH(gv))
4872 stash = GvSTASH(gv);
4874 stash = PL_curstash;
4876 apply_attrs(stash, rcv, attrs, FALSE);
4878 if (cv) { /* must reuse cv if autoloaded */
4880 /* got here with just attrs -- work done, so bug out */
4881 SAVEFREESV(PL_compcv);
4885 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4886 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4887 CvOUTSIDE(PL_compcv) = 0;
4888 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4889 CvPADLIST(PL_compcv) = 0;
4890 /* inner references to PL_compcv must be fixed up ... */
4892 AV *padlist = CvPADLIST(cv);
4893 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4894 AV *comppad = (AV*)AvARRAY(padlist)[1];
4895 SV **namepad = AvARRAY(comppad_name);
4896 SV **curpad = AvARRAY(comppad);
4897 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4898 SV *namesv = namepad[ix];
4899 if (namesv && namesv != &PL_sv_undef
4900 && *SvPVX(namesv) == '&')
4902 CV *innercv = (CV*)curpad[ix];
4903 if (CvOUTSIDE(innercv) == PL_compcv) {
4904 CvOUTSIDE(innercv) = cv;
4905 if (!CvANON(innercv) || CvCLONED(innercv)) {
4906 (void)SvREFCNT_inc(cv);
4907 SvREFCNT_dec(PL_compcv);
4913 /* ... before we throw it away */
4914 SvREFCNT_dec(PL_compcv);
4915 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4916 ++PL_sub_generation;
4923 PL_sub_generation++;
4927 CvFILE_set_from_cop(cv, PL_curcop);
4928 CvSTASH(cv) = PL_curstash;
4929 #ifdef USE_5005THREADS
4931 if (!CvMUTEXP(cv)) {
4932 New(666, CvMUTEXP(cv), 1, perl_mutex);
4933 MUTEX_INIT(CvMUTEXP(cv));
4935 #endif /* USE_5005THREADS */
4938 sv_setpv((SV*)cv, ps);
4940 if (PL_error_count) {
4944 char *s = strrchr(name, ':');
4946 if (strEQ(s, "BEGIN")) {
4948 "BEGIN not safe after errors--compilation aborted";
4949 if (PL_in_eval & EVAL_KEEPERR)
4950 Perl_croak(aTHX_ not_safe);
4952 /* force display of errors found but not reported */
4953 sv_catpv(ERRSV, not_safe);
4954 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4962 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4963 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4966 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4967 mod(scalarseq(block), OP_LEAVESUBLV));
4970 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4972 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4973 OpREFCNT_set(CvROOT(cv), 1);
4974 CvSTART(cv) = LINKLIST(CvROOT(cv));
4975 CvROOT(cv)->op_next = 0;
4976 CALL_PEEP(CvSTART(cv));
4978 /* now that optimizer has done its work, adjust pad values */
4980 SV **namep = AvARRAY(PL_comppad_name);
4981 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4984 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4987 * The only things that a clonable function needs in its
4988 * pad are references to outer lexicals and anonymous subs.
4989 * The rest are created anew during cloning.
4991 if (!((namesv = namep[ix]) != Nullsv &&
4992 namesv != &PL_sv_undef &&
4994 *SvPVX(namesv) == '&')))
4996 SvREFCNT_dec(PL_curpad[ix]);
4997 PL_curpad[ix] = Nullsv;
5000 assert(!CvCONST(cv));
5001 if (ps && !*ps && op_const_sv(block, cv))
5005 AV *av = newAV(); /* Will be @_ */
5007 av_store(PL_comppad, 0, (SV*)av);
5008 AvFLAGS(av) = AVf_REIFY;
5010 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5011 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5013 if (!SvPADMY(PL_curpad[ix]))
5014 SvPADTMP_on(PL_curpad[ix]);
5018 /* If a potential closure prototype, don't keep a refcount on outer CV.
5019 * This is okay as the lifetime of the prototype is tied to the
5020 * lifetime of the outer CV. Avoids memory leak due to reference
5023 SvREFCNT_dec(CvOUTSIDE(cv));
5025 if (name || aname) {
5027 char *tname = (name ? name : aname);
5029 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5030 SV *sv = NEWSV(0,0);
5031 SV *tmpstr = sv_newmortal();
5032 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5036 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5038 (long)PL_subline, (long)CopLINE(PL_curcop));
5039 gv_efullname3(tmpstr, gv, Nullch);
5040 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5041 hv = GvHVn(db_postponed);
5042 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5043 && (pcv = GvCV(db_postponed)))
5049 call_sv((SV*)pcv, G_DISCARD);
5053 if ((s = strrchr(tname,':')))
5058 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5061 if (strEQ(s, "BEGIN")) {
5062 I32 oldscope = PL_scopestack_ix;
5064 SAVECOPFILE(&PL_compiling);
5065 SAVECOPLINE(&PL_compiling);
5068 PL_beginav = newAV();
5069 DEBUG_x( dump_sub(gv) );
5070 av_push(PL_beginav, (SV*)cv);
5071 GvCV(gv) = 0; /* cv has been hijacked */
5072 call_list(oldscope, PL_beginav);
5074 PL_curcop = &PL_compiling;
5075 PL_compiling.op_private = PL_hints;
5078 else if (strEQ(s, "END") && !PL_error_count) {
5081 DEBUG_x( dump_sub(gv) );
5082 av_unshift(PL_endav, 1);
5083 av_store(PL_endav, 0, (SV*)cv);
5084 GvCV(gv) = 0; /* cv has been hijacked */
5086 else if (strEQ(s, "CHECK") && !PL_error_count) {
5088 PL_checkav = newAV();
5089 DEBUG_x( dump_sub(gv) );
5090 if (PL_main_start && ckWARN(WARN_VOID))
5091 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5092 av_unshift(PL_checkav, 1);
5093 av_store(PL_checkav, 0, (SV*)cv);
5094 GvCV(gv) = 0; /* cv has been hijacked */
5096 else if (strEQ(s, "INIT") && !PL_error_count) {
5098 PL_initav = newAV();
5099 DEBUG_x( dump_sub(gv) );
5100 if (PL_main_start && ckWARN(WARN_VOID))
5101 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5102 av_push(PL_initav, (SV*)cv);
5103 GvCV(gv) = 0; /* cv has been hijacked */
5108 PL_copline = NOLINE;
5113 /* XXX unsafe for threads if eval_owner isn't held */
5115 =for apidoc newCONSTSUB
5117 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5118 eligible for inlining at compile-time.
5124 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5130 SAVECOPLINE(PL_curcop);
5131 CopLINE_set(PL_curcop, PL_copline);
5134 PL_hints &= ~HINT_BLOCK_SCOPE;
5137 SAVESPTR(PL_curstash);
5138 SAVECOPSTASH(PL_curcop);
5139 PL_curstash = stash;
5141 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5143 CopSTASH(PL_curcop) = stash;
5147 cv = newXS(name, const_sv_xsub, __FILE__);
5148 CvXSUBANY(cv).any_ptr = sv;
5150 sv_setpv((SV*)cv, ""); /* prototype is "" */
5158 =for apidoc U||newXS
5160 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5166 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5168 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5171 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5173 /* just a cached method */
5177 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5178 /* already defined (or promised) */
5179 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5180 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5181 line_t oldline = CopLINE(PL_curcop);
5182 if (PL_copline != NOLINE)
5183 CopLINE_set(PL_curcop, PL_copline);
5184 Perl_warner(aTHX_ WARN_REDEFINE,
5185 CvCONST(cv) ? "Constant subroutine %s redefined"
5186 : "Subroutine %s redefined"
5188 CopLINE_set(PL_curcop, oldline);
5195 if (cv) /* must reuse cv if autoloaded */
5198 cv = (CV*)NEWSV(1105,0);
5199 sv_upgrade((SV *)cv, SVt_PVCV);
5203 PL_sub_generation++;
5207 #ifdef USE_5005THREADS
5208 New(666, CvMUTEXP(cv), 1, perl_mutex);
5209 MUTEX_INIT(CvMUTEXP(cv));
5211 #endif /* USE_5005THREADS */
5212 (void)gv_fetchfile(filename);
5213 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5214 an external constant string */
5215 CvXSUB(cv) = subaddr;
5218 char *s = strrchr(name,':');
5224 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5227 if (strEQ(s, "BEGIN")) {
5229 PL_beginav = newAV();
5230 av_push(PL_beginav, (SV*)cv);
5231 GvCV(gv) = 0; /* cv has been hijacked */
5233 else if (strEQ(s, "END")) {
5236 av_unshift(PL_endav, 1);
5237 av_store(PL_endav, 0, (SV*)cv);
5238 GvCV(gv) = 0; /* cv has been hijacked */
5240 else if (strEQ(s, "CHECK")) {
5242 PL_checkav = newAV();
5243 if (PL_main_start && ckWARN(WARN_VOID))
5244 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5245 av_unshift(PL_checkav, 1);
5246 av_store(PL_checkav, 0, (SV*)cv);
5247 GvCV(gv) = 0; /* cv has been hijacked */
5249 else if (strEQ(s, "INIT")) {
5251 PL_initav = newAV();
5252 if (PL_main_start && ckWARN(WARN_VOID))
5253 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5254 av_push(PL_initav, (SV*)cv);
5255 GvCV(gv) = 0; /* cv has been hijacked */
5266 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5275 name = SvPVx(cSVOPo->op_sv, n_a);
5278 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5279 #ifdef GV_UNIQUE_CHECK
5281 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5285 if ((cv = GvFORM(gv))) {
5286 if (ckWARN(WARN_REDEFINE)) {
5287 line_t oldline = CopLINE(PL_curcop);
5288 if (PL_copline != NOLINE)
5289 CopLINE_set(PL_curcop, PL_copline);
5290 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5291 CopLINE_set(PL_curcop, oldline);
5298 CvFILE_set_from_cop(cv, PL_curcop);
5300 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5301 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5302 SvPADTMP_on(PL_curpad[ix]);
5305 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5306 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5307 OpREFCNT_set(CvROOT(cv), 1);
5308 CvSTART(cv) = LINKLIST(CvROOT(cv));
5309 CvROOT(cv)->op_next = 0;
5310 CALL_PEEP(CvSTART(cv));
5312 PL_copline = NOLINE;
5317 Perl_newANONLIST(pTHX_ OP *o)
5319 return newUNOP(OP_REFGEN, 0,
5320 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5324 Perl_newANONHASH(pTHX_ OP *o)
5326 return newUNOP(OP_REFGEN, 0,
5327 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5331 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5333 return newANONATTRSUB(floor, proto, Nullop, block);
5337 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5339 return newUNOP(OP_REFGEN, 0,
5340 newSVOP(OP_ANONCODE, 0,
5341 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5345 Perl_oopsAV(pTHX_ OP *o)
5347 switch (o->op_type) {
5349 o->op_type = OP_PADAV;
5350 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5351 return ref(o, OP_RV2AV);
5354 o->op_type = OP_RV2AV;
5355 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5360 if (ckWARN_d(WARN_INTERNAL))
5361 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5368 Perl_oopsHV(pTHX_ OP *o)
5370 switch (o->op_type) {
5373 o->op_type = OP_PADHV;
5374 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5375 return ref(o, OP_RV2HV);
5379 o->op_type = OP_RV2HV;
5380 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5385 if (ckWARN_d(WARN_INTERNAL))
5386 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5393 Perl_newAVREF(pTHX_ OP *o)
5395 if (o->op_type == OP_PADANY) {
5396 o->op_type = OP_PADAV;
5397 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5400 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5401 && ckWARN(WARN_DEPRECATED)) {
5402 Perl_warner(aTHX_ WARN_DEPRECATED,
5403 "Using an array as a reference is deprecated");
5405 return newUNOP(OP_RV2AV, 0, scalar(o));
5409 Perl_newGVREF(pTHX_ I32 type, OP *o)
5411 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5412 return newUNOP(OP_NULL, 0, o);
5413 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5417 Perl_newHVREF(pTHX_ OP *o)
5419 if (o->op_type == OP_PADANY) {
5420 o->op_type = OP_PADHV;
5421 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5424 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5425 && ckWARN(WARN_DEPRECATED)) {
5426 Perl_warner(aTHX_ WARN_DEPRECATED,
5427 "Using a hash as a reference is deprecated");
5429 return newUNOP(OP_RV2HV, 0, scalar(o));
5433 Perl_oopsCV(pTHX_ OP *o)
5435 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5441 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5443 return newUNOP(OP_RV2CV, flags, scalar(o));
5447 Perl_newSVREF(pTHX_ OP *o)
5449 if (o->op_type == OP_PADANY) {
5450 o->op_type = OP_PADSV;
5451 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5454 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5455 o->op_flags |= OPpDONE_SVREF;
5458 return newUNOP(OP_RV2SV, 0, scalar(o));
5461 /* Check routines. */
5464 Perl_ck_anoncode(pTHX_ OP *o)
5469 name = NEWSV(1106,0);
5470 sv_upgrade(name, SVt_PVNV);
5471 sv_setpvn(name, "&", 1);
5474 ix = pad_alloc(o->op_type, SVs_PADMY);
5475 av_store(PL_comppad_name, ix, name);
5476 av_store(PL_comppad, ix, cSVOPo->op_sv);
5477 SvPADMY_on(cSVOPo->op_sv);
5478 cSVOPo->op_sv = Nullsv;
5479 cSVOPo->op_targ = ix;
5484 Perl_ck_bitop(pTHX_ OP *o)
5486 o->op_private = PL_hints;
5491 Perl_ck_concat(pTHX_ OP *o)
5493 if (cUNOPo->op_first->op_type == OP_CONCAT)
5494 o->op_flags |= OPf_STACKED;
5499 Perl_ck_spair(pTHX_ OP *o)
5501 if (o->op_flags & OPf_KIDS) {
5504 OPCODE type = o->op_type;
5505 o = modkids(ck_fun(o), type);
5506 kid = cUNOPo->op_first;
5507 newop = kUNOP->op_first->op_sibling;
5509 (newop->op_sibling ||
5510 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5511 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5512 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5516 op_free(kUNOP->op_first);
5517 kUNOP->op_first = newop;
5519 o->op_ppaddr = PL_ppaddr[++o->op_type];
5524 Perl_ck_delete(pTHX_ OP *o)
5528 if (o->op_flags & OPf_KIDS) {
5529 OP *kid = cUNOPo->op_first;
5530 switch (kid->op_type) {
5532 o->op_flags |= OPf_SPECIAL;
5535 o->op_private |= OPpSLICE;
5538 o->op_flags |= OPf_SPECIAL;
5543 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5552 Perl_ck_die(pTHX_ OP *o)
5555 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5561 Perl_ck_eof(pTHX_ OP *o)
5563 I32 type = o->op_type;
5565 if (o->op_flags & OPf_KIDS) {
5566 if (cLISTOPo->op_first->op_type == OP_STUB) {
5568 o = newUNOP(type, OPf_SPECIAL,
5569 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5577 Perl_ck_eval(pTHX_ OP *o)
5579 PL_hints |= HINT_BLOCK_SCOPE;
5580 if (o->op_flags & OPf_KIDS) {
5581 SVOP *kid = (SVOP*)cUNOPo->op_first;
5584 o->op_flags &= ~OPf_KIDS;
5587 else if (kid->op_type == OP_LINESEQ) {
5590 kid->op_next = o->op_next;
5591 cUNOPo->op_first = 0;
5594 NewOp(1101, enter, 1, LOGOP);
5595 enter->op_type = OP_ENTERTRY;
5596 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5597 enter->op_private = 0;
5599 /* establish postfix order */
5600 enter->op_next = (OP*)enter;
5602 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5603 o->op_type = OP_LEAVETRY;
5604 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5605 enter->op_other = o;
5613 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5615 o->op_targ = (PADOFFSET)PL_hints;
5620 Perl_ck_exit(pTHX_ OP *o)
5623 HV *table = GvHV(PL_hintgv);
5625 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5626 if (svp && *svp && SvTRUE(*svp))
5627 o->op_private |= OPpEXIT_VMSISH;
5629 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5635 Perl_ck_exec(pTHX_ OP *o)
5638 if (o->op_flags & OPf_STACKED) {
5640 kid = cUNOPo->op_first->op_sibling;
5641 if (kid->op_type == OP_RV2GV)
5650 Perl_ck_exists(pTHX_ OP *o)
5653 if (o->op_flags & OPf_KIDS) {
5654 OP *kid = cUNOPo->op_first;
5655 if (kid->op_type == OP_ENTERSUB) {
5656 (void) ref(kid, o->op_type);
5657 if (kid->op_type != OP_RV2CV && !PL_error_count)
5658 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5660 o->op_private |= OPpEXISTS_SUB;
5662 else if (kid->op_type == OP_AELEM)
5663 o->op_flags |= OPf_SPECIAL;
5664 else if (kid->op_type != OP_HELEM)
5665 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5674 Perl_ck_gvconst(pTHX_ register OP *o)
5676 o = fold_constants(o);
5677 if (o->op_type == OP_CONST)
5684 Perl_ck_rvconst(pTHX_ register OP *o)
5686 SVOP *kid = (SVOP*)cUNOPo->op_first;
5688 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5689 if (kid->op_type == OP_CONST) {
5693 SV *kidsv = kid->op_sv;
5696 /* Is it a constant from cv_const_sv()? */
5697 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5698 SV *rsv = SvRV(kidsv);
5699 int svtype = SvTYPE(rsv);
5700 char *badtype = Nullch;
5702 switch (o->op_type) {
5704 if (svtype > SVt_PVMG)
5705 badtype = "a SCALAR";
5708 if (svtype != SVt_PVAV)
5709 badtype = "an ARRAY";
5712 if (svtype != SVt_PVHV) {
5713 if (svtype == SVt_PVAV) { /* pseudohash? */
5714 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5715 if (ksv && SvROK(*ksv)
5716 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5725 if (svtype != SVt_PVCV)
5730 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5733 name = SvPV(kidsv, n_a);
5734 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5735 char *badthing = Nullch;
5736 switch (o->op_type) {
5738 badthing = "a SCALAR";
5741 badthing = "an ARRAY";
5744 badthing = "a HASH";
5749 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5753 * This is a little tricky. We only want to add the symbol if we
5754 * didn't add it in the lexer. Otherwise we get duplicate strict
5755 * warnings. But if we didn't add it in the lexer, we must at
5756 * least pretend like we wanted to add it even if it existed before,
5757 * or we get possible typo warnings. OPpCONST_ENTERED says
5758 * whether the lexer already added THIS instance of this symbol.
5760 iscv = (o->op_type == OP_RV2CV) * 2;
5762 gv = gv_fetchpv(name,
5763 iscv | !(kid->op_private & OPpCONST_ENTERED),
5766 : o->op_type == OP_RV2SV
5768 : o->op_type == OP_RV2AV
5770 : o->op_type == OP_RV2HV
5773 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5775 kid->op_type = OP_GV;
5776 SvREFCNT_dec(kid->op_sv);
5778 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5779 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5780 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5782 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5784 kid->op_sv = SvREFCNT_inc(gv);
5786 kid->op_private = 0;
5787 kid->op_ppaddr = PL_ppaddr[OP_GV];
5794 Perl_ck_ftst(pTHX_ OP *o)
5796 I32 type = o->op_type;
5798 if (o->op_flags & OPf_REF) {
5801 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5802 SVOP *kid = (SVOP*)cUNOPo->op_first;
5804 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5806 OP *newop = newGVOP(type, OPf_REF,
5807 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5814 if (type == OP_FTTTY)
5815 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5818 o = newUNOP(type, 0, newDEFSVOP());
5824 Perl_ck_fun(pTHX_ OP *o)
5830 int type = o->op_type;
5831 register I32 oa = PL_opargs[type] >> OASHIFT;
5833 if (o->op_flags & OPf_STACKED) {
5834 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5837 return no_fh_allowed(o);
5840 if (o->op_flags & OPf_KIDS) {
5842 tokid = &cLISTOPo->op_first;
5843 kid = cLISTOPo->op_first;
5844 if (kid->op_type == OP_PUSHMARK ||
5845 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5847 tokid = &kid->op_sibling;
5848 kid = kid->op_sibling;
5850 if (!kid && PL_opargs[type] & OA_DEFGV)
5851 *tokid = kid = newDEFSVOP();
5855 sibl = kid->op_sibling;
5858 /* list seen where single (scalar) arg expected? */
5859 if (numargs == 1 && !(oa >> 4)
5860 && kid->op_type == OP_LIST && type != OP_SCALAR)
5862 return too_many_arguments(o,PL_op_desc[type]);
5875 if ((type == OP_PUSH || type == OP_UNSHIFT)
5876 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5877 Perl_warner(aTHX_ WARN_SYNTAX,
5878 "Useless use of %s with no values",
5881 if (kid->op_type == OP_CONST &&
5882 (kid->op_private & OPpCONST_BARE))
5884 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5885 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5886 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5887 if (ckWARN(WARN_DEPRECATED))
5888 Perl_warner(aTHX_ WARN_DEPRECATED,
5889 "Array @%s missing the @ in argument %"IVdf" of %s()",
5890 name, (IV)numargs, PL_op_desc[type]);
5893 kid->op_sibling = sibl;
5896 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5897 bad_type(numargs, "array", PL_op_desc[type], kid);
5901 if (kid->op_type == OP_CONST &&
5902 (kid->op_private & OPpCONST_BARE))
5904 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5905 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5906 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5907 if (ckWARN(WARN_DEPRECATED))
5908 Perl_warner(aTHX_ WARN_DEPRECATED,
5909 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5910 name, (IV)numargs, PL_op_desc[type]);
5913 kid->op_sibling = sibl;
5916 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5917 bad_type(numargs, "hash", PL_op_desc[type], kid);
5922 OP *newop = newUNOP(OP_NULL, 0, kid);
5923 kid->op_sibling = 0;
5925 newop->op_next = newop;
5927 kid->op_sibling = sibl;
5932 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5933 if (kid->op_type == OP_CONST &&
5934 (kid->op_private & OPpCONST_BARE))
5936 OP *newop = newGVOP(OP_GV, 0,
5937 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5942 else if (kid->op_type == OP_READLINE) {
5943 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5944 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5947 I32 flags = OPf_SPECIAL;
5951 /* is this op a FH constructor? */
5952 if (is_handle_constructor(o,numargs)) {
5953 char *name = Nullch;
5957 /* Set a flag to tell rv2gv to vivify
5958 * need to "prove" flag does not mean something
5959 * else already - NI-S 1999/05/07
5962 if (kid->op_type == OP_PADSV) {
5963 SV **namep = av_fetch(PL_comppad_name,
5965 if (namep && *namep)
5966 name = SvPV(*namep, len);
5968 else if (kid->op_type == OP_RV2SV
5969 && kUNOP->op_first->op_type == OP_GV)
5971 GV *gv = cGVOPx_gv(kUNOP->op_first);
5973 len = GvNAMELEN(gv);
5975 else if (kid->op_type == OP_AELEM
5976 || kid->op_type == OP_HELEM)
5978 name = "__ANONIO__";
5984 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5985 namesv = PL_curpad[targ];
5986 (void)SvUPGRADE(namesv, SVt_PV);
5988 sv_setpvn(namesv, "$", 1);
5989 sv_catpvn(namesv, name, len);
5992 kid->op_sibling = 0;
5993 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5994 kid->op_targ = targ;
5995 kid->op_private |= priv;
5997 kid->op_sibling = sibl;
6003 mod(scalar(kid), type);
6007 tokid = &kid->op_sibling;
6008 kid = kid->op_sibling;
6010 o->op_private |= numargs;
6012 return too_many_arguments(o,OP_DESC(o));
6015 else if (PL_opargs[type] & OA_DEFGV) {
6017 return newUNOP(type, 0, newDEFSVOP());
6021 while (oa & OA_OPTIONAL)
6023 if (oa && oa != OA_LIST)
6024 return too_few_arguments(o,OP_DESC(o));
6030 Perl_ck_glob(pTHX_ OP *o)
6035 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6036 append_elem(OP_GLOB, o, newDEFSVOP());
6038 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6039 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6041 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6044 #if !defined(PERL_EXTERNAL_GLOB)
6045 /* XXX this can be tightened up and made more failsafe. */
6049 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
6051 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6052 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6053 GvCV(gv) = GvCV(glob_gv);
6054 SvREFCNT_inc((SV*)GvCV(gv));
6055 GvIMPORTED_CV_on(gv);
6058 #endif /* PERL_EXTERNAL_GLOB */
6060 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6061 append_elem(OP_GLOB, o,
6062 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6063 o->op_type = OP_LIST;
6064 o->op_ppaddr = PL_ppaddr[OP_LIST];
6065 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6066 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6067 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6068 append_elem(OP_LIST, o,
6069 scalar(newUNOP(OP_RV2CV, 0,
6070 newGVOP(OP_GV, 0, gv)))));
6071 o = newUNOP(OP_NULL, 0, ck_subr(o));
6072 o->op_targ = OP_GLOB; /* hint at what it used to be */
6075 gv = newGVgen("main");
6077 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6083 Perl_ck_grep(pTHX_ OP *o)
6087 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6089 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6090 NewOp(1101, gwop, 1, LOGOP);
6092 if (o->op_flags & OPf_STACKED) {
6095 kid = cLISTOPo->op_first->op_sibling;
6096 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6099 kid->op_next = (OP*)gwop;
6100 o->op_flags &= ~OPf_STACKED;
6102 kid = cLISTOPo->op_first->op_sibling;
6103 if (type == OP_MAPWHILE)
6110 kid = cLISTOPo->op_first->op_sibling;
6111 if (kid->op_type != OP_NULL)
6112 Perl_croak(aTHX_ "panic: ck_grep");
6113 kid = kUNOP->op_first;
6115 gwop->op_type = type;
6116 gwop->op_ppaddr = PL_ppaddr[type];
6117 gwop->op_first = listkids(o);
6118 gwop->op_flags |= OPf_KIDS;
6119 gwop->op_private = 1;
6120 gwop->op_other = LINKLIST(kid);
6121 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6122 kid->op_next = (OP*)gwop;
6124 kid = cLISTOPo->op_first->op_sibling;
6125 if (!kid || !kid->op_sibling)
6126 return too_few_arguments(o,OP_DESC(o));
6127 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6128 mod(kid, OP_GREPSTART);
6134 Perl_ck_index(pTHX_ OP *o)
6136 if (o->op_flags & OPf_KIDS) {
6137 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6139 kid = kid->op_sibling; /* get past "big" */
6140 if (kid && kid->op_type == OP_CONST)
6141 fbm_compile(((SVOP*)kid)->op_sv, 0);
6147 Perl_ck_lengthconst(pTHX_ OP *o)
6149 /* XXX length optimization goes here */
6154 Perl_ck_lfun(pTHX_ OP *o)
6156 OPCODE type = o->op_type;
6157 return modkids(ck_fun(o), type);
6161 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6163 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6164 switch (cUNOPo->op_first->op_type) {
6166 /* This is needed for
6167 if (defined %stash::)
6168 to work. Do not break Tk.
6170 break; /* Globals via GV can be undef */
6172 case OP_AASSIGN: /* Is this a good idea? */
6173 Perl_warner(aTHX_ WARN_DEPRECATED,
6174 "defined(@array) is deprecated");
6175 Perl_warner(aTHX_ WARN_DEPRECATED,
6176 "\t(Maybe you should just omit the defined()?)\n");
6179 /* This is needed for
6180 if (defined %stash::)
6181 to work. Do not break Tk.
6183 break; /* Globals via GV can be undef */
6185 Perl_warner(aTHX_ WARN_DEPRECATED,
6186 "defined(%%hash) is deprecated");
6187 Perl_warner(aTHX_ WARN_DEPRECATED,
6188 "\t(Maybe you should just omit the defined()?)\n");
6199 Perl_ck_rfun(pTHX_ OP *o)
6201 OPCODE type = o->op_type;
6202 return refkids(ck_fun(o), type);
6206 Perl_ck_listiob(pTHX_ OP *o)
6210 kid = cLISTOPo->op_first;
6213 kid = cLISTOPo->op_first;
6215 if (kid->op_type == OP_PUSHMARK)
6216 kid = kid->op_sibling;
6217 if (kid && o->op_flags & OPf_STACKED)
6218 kid = kid->op_sibling;
6219 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6220 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6221 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6222 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6223 cLISTOPo->op_first->op_sibling = kid;
6224 cLISTOPo->op_last = kid;
6225 kid = kid->op_sibling;
6230 append_elem(o->op_type, o, newDEFSVOP());
6236 Perl_ck_sassign(pTHX_ OP *o)
6238 OP *kid = cLISTOPo->op_first;
6239 /* has a disposable target? */
6240 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6241 && !(kid->op_flags & OPf_STACKED)
6242 /* Cannot steal the second time! */
6243 && !(kid->op_private & OPpTARGET_MY))
6245 OP *kkid = kid->op_sibling;
6247 /* Can just relocate the target. */
6248 if (kkid && kkid->op_type == OP_PADSV
6249 && !(kkid->op_private & OPpLVAL_INTRO))
6251 kid->op_targ = kkid->op_targ;
6253 /* Now we do not need PADSV and SASSIGN. */
6254 kid->op_sibling = o->op_sibling; /* NULL */
6255 cLISTOPo->op_first = NULL;
6258 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6266 Perl_ck_match(pTHX_ OP *o)
6268 o->op_private |= OPpRUNTIME;
6273 Perl_ck_method(pTHX_ OP *o)
6275 OP *kid = cUNOPo->op_first;
6276 if (kid->op_type == OP_CONST) {
6277 SV* sv = kSVOP->op_sv;
6278 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6280 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6281 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6284 kSVOP->op_sv = Nullsv;
6286 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6295 Perl_ck_null(pTHX_ OP *o)
6301 Perl_ck_open(pTHX_ OP *o)
6303 HV *table = GvHV(PL_hintgv);
6307 svp = hv_fetch(table, "open_IN", 7, FALSE);
6309 mode = mode_from_discipline(*svp);
6310 if (mode & O_BINARY)
6311 o->op_private |= OPpOPEN_IN_RAW;
6312 else if (mode & O_TEXT)
6313 o->op_private |= OPpOPEN_IN_CRLF;
6316 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6318 mode = mode_from_discipline(*svp);
6319 if (mode & O_BINARY)
6320 o->op_private |= OPpOPEN_OUT_RAW;
6321 else if (mode & O_TEXT)
6322 o->op_private |= OPpOPEN_OUT_CRLF;
6325 if (o->op_type == OP_BACKTICK)
6331 Perl_ck_repeat(pTHX_ OP *o)
6333 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6334 o->op_private |= OPpREPEAT_DOLIST;
6335 cBINOPo->op_first = force_list(cBINOPo->op_first);
6343 Perl_ck_require(pTHX_ OP *o)
6347 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6348 SVOP *kid = (SVOP*)cUNOPo->op_first;
6350 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6352 for (s = SvPVX(kid->op_sv); *s; s++) {
6353 if (*s == ':' && s[1] == ':') {
6355 Move(s+2, s+1, strlen(s+2)+1, char);
6356 --SvCUR(kid->op_sv);
6359 if (SvREADONLY(kid->op_sv)) {
6360 SvREADONLY_off(kid->op_sv);
6361 sv_catpvn(kid->op_sv, ".pm", 3);
6362 SvREADONLY_on(kid->op_sv);
6365 sv_catpvn(kid->op_sv, ".pm", 3);
6369 /* handle override, if any */
6370 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6371 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6372 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6374 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6375 OP *kid = cUNOPo->op_first;
6376 cUNOPo->op_first = 0;
6378 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6379 append_elem(OP_LIST, kid,
6380 scalar(newUNOP(OP_RV2CV, 0,
6389 Perl_ck_return(pTHX_ OP *o)
6392 if (CvLVALUE(PL_compcv)) {
6393 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6394 mod(kid, OP_LEAVESUBLV);
6401 Perl_ck_retarget(pTHX_ OP *o)
6403 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6410 Perl_ck_select(pTHX_ OP *o)
6413 if (o->op_flags & OPf_KIDS) {
6414 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6415 if (kid && kid->op_sibling) {
6416 o->op_type = OP_SSELECT;
6417 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6419 return fold_constants(o);
6423 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6424 if (kid && kid->op_type == OP_RV2GV)
6425 kid->op_private &= ~HINT_STRICT_REFS;
6430 Perl_ck_shift(pTHX_ OP *o)
6432 I32 type = o->op_type;
6434 if (!(o->op_flags & OPf_KIDS)) {
6438 #ifdef USE_5005THREADS
6439 if (!CvUNIQUE(PL_compcv)) {
6440 argop = newOP(OP_PADAV, OPf_REF);
6441 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6444 argop = newUNOP(OP_RV2AV, 0,
6445 scalar(newGVOP(OP_GV, 0,
6446 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6449 argop = newUNOP(OP_RV2AV, 0,
6450 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6451 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6452 #endif /* USE_5005THREADS */
6453 return newUNOP(type, 0, scalar(argop));
6455 return scalar(modkids(ck_fun(o), type));
6459 Perl_ck_sort(pTHX_ OP *o)
6463 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6465 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6466 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6468 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6470 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6472 if (kid->op_type == OP_SCOPE) {
6476 else if (kid->op_type == OP_LEAVE) {
6477 if (o->op_type == OP_SORT) {
6478 op_null(kid); /* wipe out leave */
6481 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6482 if (k->op_next == kid)
6484 /* don't descend into loops */
6485 else if (k->op_type == OP_ENTERLOOP
6486 || k->op_type == OP_ENTERITER)
6488 k = cLOOPx(k)->op_lastop;
6493 kid->op_next = 0; /* just disconnect the leave */
6494 k = kLISTOP->op_first;
6499 if (o->op_type == OP_SORT) {
6500 /* provide scalar context for comparison function/block */
6506 o->op_flags |= OPf_SPECIAL;
6508 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6511 firstkid = firstkid->op_sibling;
6514 /* provide list context for arguments */
6515 if (o->op_type == OP_SORT)
6522 S_simplify_sort(pTHX_ OP *o)
6524 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6528 if (!(o->op_flags & OPf_STACKED))
6530 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6531 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6532 kid = kUNOP->op_first; /* get past null */
6533 if (kid->op_type != OP_SCOPE)
6535 kid = kLISTOP->op_last; /* get past scope */
6536 switch(kid->op_type) {
6544 k = kid; /* remember this node*/
6545 if (kBINOP->op_first->op_type != OP_RV2SV)
6547 kid = kBINOP->op_first; /* get past cmp */
6548 if (kUNOP->op_first->op_type != OP_GV)
6550 kid = kUNOP->op_first; /* get past rv2sv */
6552 if (GvSTASH(gv) != PL_curstash)
6554 if (strEQ(GvNAME(gv), "a"))
6556 else if (strEQ(GvNAME(gv), "b"))
6560 kid = k; /* back to cmp */
6561 if (kBINOP->op_last->op_type != OP_RV2SV)
6563 kid = kBINOP->op_last; /* down to 2nd arg */
6564 if (kUNOP->op_first->op_type != OP_GV)
6566 kid = kUNOP->op_first; /* get past rv2sv */
6568 if (GvSTASH(gv) != PL_curstash
6570 ? strNE(GvNAME(gv), "a")
6571 : strNE(GvNAME(gv), "b")))
6573 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6575 o->op_private |= OPpSORT_REVERSE;
6576 if (k->op_type == OP_NCMP)
6577 o->op_private |= OPpSORT_NUMERIC;
6578 if (k->op_type == OP_I_NCMP)
6579 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6580 kid = cLISTOPo->op_first->op_sibling;
6581 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6582 op_free(kid); /* then delete it */
6586 Perl_ck_split(pTHX_ OP *o)
6590 if (o->op_flags & OPf_STACKED)
6591 return no_fh_allowed(o);
6593 kid = cLISTOPo->op_first;
6594 if (kid->op_type != OP_NULL)
6595 Perl_croak(aTHX_ "panic: ck_split");
6596 kid = kid->op_sibling;
6597 op_free(cLISTOPo->op_first);
6598 cLISTOPo->op_first = kid;
6600 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6601 cLISTOPo->op_last = kid; /* There was only one element previously */
6604 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6605 OP *sibl = kid->op_sibling;
6606 kid->op_sibling = 0;
6607 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6608 if (cLISTOPo->op_first == cLISTOPo->op_last)
6609 cLISTOPo->op_last = kid;
6610 cLISTOPo->op_first = kid;
6611 kid->op_sibling = sibl;
6614 kid->op_type = OP_PUSHRE;
6615 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6618 if (!kid->op_sibling)
6619 append_elem(OP_SPLIT, o, newDEFSVOP());
6621 kid = kid->op_sibling;
6624 if (!kid->op_sibling)
6625 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6627 kid = kid->op_sibling;
6630 if (kid->op_sibling)
6631 return too_many_arguments(o,OP_DESC(o));
6637 Perl_ck_join(pTHX_ OP *o)
6639 if (ckWARN(WARN_SYNTAX)) {
6640 OP *kid = cLISTOPo->op_first->op_sibling;
6641 if (kid && kid->op_type == OP_MATCH) {
6642 char *pmstr = "STRING";
6643 if (PM_GETRE(kPMOP))
6644 pmstr = PM_GETRE(kPMOP)->precomp;
6645 Perl_warner(aTHX_ WARN_SYNTAX,
6646 "/%s/ should probably be written as \"%s\"",
6654 Perl_ck_subr(pTHX_ OP *o)
6656 OP *prev = ((cUNOPo->op_first->op_sibling)
6657 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6658 OP *o2 = prev->op_sibling;
6665 I32 contextclass = 0;
6669 o->op_private |= OPpENTERSUB_HASTARG;
6670 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6671 if (cvop->op_type == OP_RV2CV) {
6673 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6674 op_null(cvop); /* disable rv2cv */
6675 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6676 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6677 GV *gv = cGVOPx_gv(tmpop);
6680 tmpop->op_private |= OPpEARLY_CV;
6681 else if (SvPOK(cv)) {
6682 namegv = CvANON(cv) ? gv : CvGV(cv);
6683 proto = SvPV((SV*)cv, n_a);
6687 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6688 if (o2->op_type == OP_CONST)
6689 o2->op_private &= ~OPpCONST_STRICT;
6690 else if (o2->op_type == OP_LIST) {
6691 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6692 if (o && o->op_type == OP_CONST)
6693 o->op_private &= ~OPpCONST_STRICT;
6696 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6697 if (PERLDB_SUB && PL_curstash != PL_debstash)
6698 o->op_private |= OPpENTERSUB_DB;
6699 while (o2 != cvop) {
6703 return too_many_arguments(o, gv_ename(namegv));
6721 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6723 arg == 1 ? "block or sub {}" : "sub {}",
6724 gv_ename(namegv), o2);
6727 /* '*' allows any scalar type, including bareword */
6730 if (o2->op_type == OP_RV2GV)
6731 goto wrapref; /* autoconvert GLOB -> GLOBref */
6732 else if (o2->op_type == OP_CONST)
6733 o2->op_private &= ~OPpCONST_STRICT;
6734 else if (o2->op_type == OP_ENTERSUB) {
6735 /* accidental subroutine, revert to bareword */
6736 OP *gvop = ((UNOP*)o2)->op_first;
6737 if (gvop && gvop->op_type == OP_NULL) {
6738 gvop = ((UNOP*)gvop)->op_first;
6740 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6743 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6744 (gvop = ((UNOP*)gvop)->op_first) &&
6745 gvop->op_type == OP_GV)
6747 GV *gv = cGVOPx_gv(gvop);
6748 OP *sibling = o2->op_sibling;
6749 SV *n = newSVpvn("",0);
6751 gv_fullname3(n, gv, "");
6752 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6753 sv_chop(n, SvPVX(n)+6);
6754 o2 = newSVOP(OP_CONST, 0, n);
6755 prev->op_sibling = o2;
6756 o2->op_sibling = sibling;
6772 if (contextclass++ == 0) {
6773 e = strchr(proto, ']');
6774 if (!e || e == proto)
6788 if (o2->op_type == OP_RV2GV)
6791 bad_type(arg, "symbol", gv_ename(namegv), o2);
6794 if (o2->op_type == OP_ENTERSUB)
6797 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6800 if (o2->op_type == OP_RV2SV ||
6801 o2->op_type == OP_PADSV ||
6802 o2->op_type == OP_HELEM ||
6803 o2->op_type == OP_AELEM ||
6804 o2->op_type == OP_THREADSV)
6807 bad_type(arg, "scalar", gv_ename(namegv), o2);
6810 if (o2->op_type == OP_RV2AV ||
6811 o2->op_type == OP_PADAV)
6814 bad_type(arg, "array", gv_ename(namegv), o2);
6817 if (o2->op_type == OP_RV2HV ||
6818 o2->op_type == OP_PADHV)
6821 bad_type(arg, "hash", gv_ename(namegv), o2);
6826 OP* sib = kid->op_sibling;
6827 kid->op_sibling = 0;
6828 o2 = newUNOP(OP_REFGEN, 0, kid);
6829 o2->op_sibling = sib;
6830 prev->op_sibling = o2;
6832 if (contextclass && e) {
6847 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6848 gv_ename(namegv), SvPV((SV*)cv, n_a));
6853 mod(o2, OP_ENTERSUB);
6855 o2 = o2->op_sibling;
6857 if (proto && !optional &&
6858 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6859 return too_few_arguments(o, gv_ename(namegv));
6864 Perl_ck_svconst(pTHX_ OP *o)
6866 SvREADONLY_on(cSVOPo->op_sv);
6871 Perl_ck_trunc(pTHX_ OP *o)
6873 if (o->op_flags & OPf_KIDS) {
6874 SVOP *kid = (SVOP*)cUNOPo->op_first;
6876 if (kid->op_type == OP_NULL)
6877 kid = (SVOP*)kid->op_sibling;
6878 if (kid && kid->op_type == OP_CONST &&
6879 (kid->op_private & OPpCONST_BARE))
6881 o->op_flags |= OPf_SPECIAL;
6882 kid->op_private &= ~OPpCONST_STRICT;
6889 Perl_ck_substr(pTHX_ OP *o)
6892 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6893 OP *kid = cLISTOPo->op_first;
6895 if (kid->op_type == OP_NULL)
6896 kid = kid->op_sibling;
6898 kid->op_flags |= OPf_MOD;
6904 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6907 Perl_peep(pTHX_ register OP *o)
6909 register OP* oldop = 0;
6912 if (!o || o->op_seq)
6916 SAVEVPTR(PL_curcop);
6917 for (; o; o = o->op_next) {
6923 switch (o->op_type) {
6927 PL_curcop = ((COP*)o); /* for warnings */
6928 o->op_seq = PL_op_seqmax++;
6932 if (cSVOPo->op_private & OPpCONST_STRICT)
6933 no_bareword_allowed(o);
6935 /* Relocate sv to the pad for thread safety.
6936 * Despite being a "constant", the SV is written to,
6937 * for reference counts, sv_upgrade() etc. */
6939 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6940 if (SvPADTMP(cSVOPo->op_sv)) {
6941 /* If op_sv is already a PADTMP then it is being used by
6942 * some pad, so make a copy. */
6943 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6944 SvREADONLY_on(PL_curpad[ix]);
6945 SvREFCNT_dec(cSVOPo->op_sv);
6948 SvREFCNT_dec(PL_curpad[ix]);
6949 SvPADTMP_on(cSVOPo->op_sv);
6950 PL_curpad[ix] = cSVOPo->op_sv;
6951 /* XXX I don't know how this isn't readonly already. */
6952 SvREADONLY_on(PL_curpad[ix]);
6954 cSVOPo->op_sv = Nullsv;
6958 o->op_seq = PL_op_seqmax++;
6962 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6963 if (o->op_next->op_private & OPpTARGET_MY) {
6964 if (o->op_flags & OPf_STACKED) /* chained concats */
6965 goto ignore_optimization;
6967 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6968 o->op_targ = o->op_next->op_targ;
6969 o->op_next->op_targ = 0;
6970 o->op_private |= OPpTARGET_MY;
6973 op_null(o->op_next);
6975 ignore_optimization:
6976 o->op_seq = PL_op_seqmax++;
6979 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6980 o->op_seq = PL_op_seqmax++;
6981 break; /* Scalar stub must produce undef. List stub is noop */
6985 if (o->op_targ == OP_NEXTSTATE
6986 || o->op_targ == OP_DBSTATE
6987 || o->op_targ == OP_SETSTATE)
6989 PL_curcop = ((COP*)o);
6991 /* XXX: We avoid setting op_seq here to prevent later calls
6992 to peep() from mistakenly concluding that optimisation
6993 has already occurred. This doesn't fix the real problem,
6994 though (See 20010220.007). AMS 20010719 */
6995 if (oldop && o->op_next) {
6996 oldop->op_next = o->op_next;
7004 if (oldop && o->op_next) {
7005 oldop->op_next = o->op_next;
7008 o->op_seq = PL_op_seqmax++;
7012 if (o->op_next->op_type == OP_RV2SV) {
7013 if (!(o->op_next->op_private & OPpDEREF)) {
7014 op_null(o->op_next);
7015 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7017 o->op_next = o->op_next->op_next;
7018 o->op_type = OP_GVSV;
7019 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7022 else if (o->op_next->op_type == OP_RV2AV) {
7023 OP* pop = o->op_next->op_next;
7025 if (pop->op_type == OP_CONST &&
7026 (PL_op = pop->op_next) &&
7027 pop->op_next->op_type == OP_AELEM &&
7028 !(pop->op_next->op_private &
7029 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7030 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7035 op_null(o->op_next);
7036 op_null(pop->op_next);
7038 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7039 o->op_next = pop->op_next->op_next;
7040 o->op_type = OP_AELEMFAST;
7041 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7042 o->op_private = (U8)i;
7047 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7049 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7050 /* XXX could check prototype here instead of just carping */
7051 SV *sv = sv_newmortal();
7052 gv_efullname3(sv, gv, Nullch);
7053 Perl_warner(aTHX_ WARN_PROTOTYPE,
7054 "%s() called too early to check prototype",
7058 else if (o->op_next->op_type == OP_READLINE
7059 && o->op_next->op_next->op_type == OP_CONCAT
7060 && (o->op_next->op_next->op_flags & OPf_STACKED))
7062 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7063 o->op_type = OP_RCATLINE;
7064 o->op_flags |= OPf_STACKED;
7065 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7066 op_null(o->op_next->op_next);
7067 op_null(o->op_next);
7070 o->op_seq = PL_op_seqmax++;
7081 o->op_seq = PL_op_seqmax++;
7082 while (cLOGOP->op_other->op_type == OP_NULL)
7083 cLOGOP->op_other = cLOGOP->op_other->op_next;
7084 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7089 o->op_seq = PL_op_seqmax++;
7090 while (cLOOP->op_redoop->op_type == OP_NULL)
7091 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7092 peep(cLOOP->op_redoop);
7093 while (cLOOP->op_nextop->op_type == OP_NULL)
7094 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7095 peep(cLOOP->op_nextop);
7096 while (cLOOP->op_lastop->op_type == OP_NULL)
7097 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7098 peep(cLOOP->op_lastop);
7104 o->op_seq = PL_op_seqmax++;
7105 while (cPMOP->op_pmreplstart &&
7106 cPMOP->op_pmreplstart->op_type == OP_NULL)
7107 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7108 peep(cPMOP->op_pmreplstart);
7112 o->op_seq = PL_op_seqmax++;
7113 if (ckWARN(WARN_SYNTAX) && o->op_next
7114 && o->op_next->op_type == OP_NEXTSTATE) {
7115 if (o->op_next->op_sibling &&
7116 o->op_next->op_sibling->op_type != OP_EXIT &&
7117 o->op_next->op_sibling->op_type != OP_WARN &&
7118 o->op_next->op_sibling->op_type != OP_DIE) {
7119 line_t oldline = CopLINE(PL_curcop);
7121 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7122 Perl_warner(aTHX_ WARN_EXEC,
7123 "Statement unlikely to be reached");
7124 Perl_warner(aTHX_ WARN_EXEC,
7125 "\t(Maybe you meant system() when you said exec()?)\n");
7126 CopLINE_set(PL_curcop, oldline);
7135 SV **svp, **indsvp, *sv;
7140 o->op_seq = PL_op_seqmax++;
7142 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7145 /* Make the CONST have a shared SV */
7146 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7147 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7148 key = SvPV(sv, keylen);
7149 lexname = newSVpvn_share(key,
7150 SvUTF8(sv) ? -(I32)keylen : keylen,
7156 if ((o->op_private & (OPpLVAL_INTRO)))
7159 rop = (UNOP*)((BINOP*)o)->op_first;
7160 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7162 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7163 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7165 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7166 if (!fields || !GvHV(*fields))
7168 key = SvPV(*svp, keylen);
7169 indsvp = hv_fetch(GvHV(*fields), key,
7170 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7172 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7173 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7175 ind = SvIV(*indsvp);
7177 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7178 rop->op_type = OP_RV2AV;
7179 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7180 o->op_type = OP_AELEM;
7181 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7183 if (SvREADONLY(*svp))
7185 SvFLAGS(sv) |= (SvFLAGS(*svp)
7186 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7196 SV **svp, **indsvp, *sv;
7200 SVOP *first_key_op, *key_op;
7202 o->op_seq = PL_op_seqmax++;
7203 if ((o->op_private & (OPpLVAL_INTRO))
7204 /* I bet there's always a pushmark... */
7205 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7206 /* hmmm, no optimization if list contains only one key. */
7208 rop = (UNOP*)((LISTOP*)o)->op_last;
7209 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7211 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7212 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7214 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7215 if (!fields || !GvHV(*fields))
7217 /* Again guessing that the pushmark can be jumped over.... */
7218 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7219 ->op_first->op_sibling;
7220 /* Check that the key list contains only constants. */
7221 for (key_op = first_key_op; key_op;
7222 key_op = (SVOP*)key_op->op_sibling)
7223 if (key_op->op_type != OP_CONST)
7227 rop->op_type = OP_RV2AV;
7228 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7229 o->op_type = OP_ASLICE;
7230 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7231 for (key_op = first_key_op; key_op;
7232 key_op = (SVOP*)key_op->op_sibling) {
7233 svp = cSVOPx_svp(key_op);
7234 key = SvPV(*svp, keylen);
7235 indsvp = hv_fetch(GvHV(*fields), key,
7236 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7238 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7239 "in variable %s of type %s",
7240 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7242 ind = SvIV(*indsvp);
7244 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7246 if (SvREADONLY(*svp))
7248 SvFLAGS(sv) |= (SvFLAGS(*svp)
7249 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7257 o->op_seq = PL_op_seqmax++;
7267 char* Perl_custom_op_name(pTHX_ OP* o)
7269 IV index = PTR2IV(o->op_ppaddr);
7273 if (!PL_custom_op_names) /* This probably shouldn't happen */
7274 return PL_op_name[OP_CUSTOM];
7276 keysv = sv_2mortal(newSViv(index));
7278 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7280 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7282 return SvPV_nolen(HeVAL(he));
7285 char* Perl_custom_op_desc(pTHX_ OP* o)
7287 IV index = PTR2IV(o->op_ppaddr);
7291 if (!PL_custom_op_descs)
7292 return PL_op_desc[OP_CUSTOM];
7294 keysv = sv_2mortal(newSViv(index));
7296 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7298 return PL_op_desc[OP_CUSTOM];
7300 return SvPV_nolen(HeVAL(he));
7306 /* Efficient sub that returns a constant scalar value. */
7308 const_sv_xsub(pTHX_ CV* cv)
7313 Perl_croak(aTHX_ "usage: %s::%s()",
7314 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7318 ST(0) = (SV*)XSANY.any_ptr;