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? */
2047 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2049 PL_in_my_stash = Nullhv;
2050 apply_attrs(GvSTASH(gv),
2051 (type == OP_RV2SV ? GvSV(gv) :
2052 type == OP_RV2AV ? (SV*)GvAV(gv) :
2053 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2056 o->op_private |= OPpOUR_INTRO;
2059 else if (type != OP_PADSV &&
2062 type != OP_PUSHMARK)
2064 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2066 PL_in_my == KEY_our ? "our" : "my"));
2069 else if (attrs && type != OP_PUSHMARK) {
2074 PL_in_my_stash = Nullhv;
2076 /* check for C<my Dog $spot> when deciding package */
2077 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2078 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2079 stash = SvSTASH(*namesvp);
2081 stash = PL_curstash;
2082 apply_attrs_my(stash, o, attrs, imopsp);
2084 o->op_flags |= OPf_MOD;
2085 o->op_private |= OPpLVAL_INTRO;
2090 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2093 int maybe_scalar = 0;
2095 if (o->op_flags & OPf_PARENS)
2101 o = my_kid(o, attrs, &rops);
2103 if (maybe_scalar && o->op_type == OP_PADSV) {
2104 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2105 o->op_private |= OPpLVAL_INTRO;
2108 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2111 PL_in_my_stash = Nullhv;
2116 Perl_my(pTHX_ OP *o)
2118 return my_attrs(o, Nullop);
2122 Perl_sawparens(pTHX_ OP *o)
2125 o->op_flags |= OPf_PARENS;
2130 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2134 if (ckWARN(WARN_MISC) &&
2135 (left->op_type == OP_RV2AV ||
2136 left->op_type == OP_RV2HV ||
2137 left->op_type == OP_PADAV ||
2138 left->op_type == OP_PADHV)) {
2139 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2140 right->op_type == OP_TRANS)
2141 ? right->op_type : OP_MATCH];
2142 const char *sample = ((left->op_type == OP_RV2AV ||
2143 left->op_type == OP_PADAV)
2144 ? "@array" : "%hash");
2145 Perl_warner(aTHX_ WARN_MISC,
2146 "Applying %s to %s will act on scalar(%s)",
2147 desc, sample, sample);
2150 if (right->op_type == OP_CONST &&
2151 cSVOPx(right)->op_private & OPpCONST_BARE &&
2152 cSVOPx(right)->op_private & OPpCONST_STRICT)
2154 no_bareword_allowed(right);
2157 if (!(right->op_flags & OPf_STACKED) &&
2158 (right->op_type == OP_MATCH ||
2159 right->op_type == OP_SUBST ||
2160 right->op_type == OP_TRANS)) {
2161 right->op_flags |= OPf_STACKED;
2162 if (right->op_type != OP_MATCH &&
2163 ! (right->op_type == OP_TRANS &&
2164 right->op_private & OPpTRANS_IDENTICAL))
2165 left = mod(left, right->op_type);
2166 if (right->op_type == OP_TRANS)
2167 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2169 o = prepend_elem(right->op_type, scalar(left), right);
2171 return newUNOP(OP_NOT, 0, scalar(o));
2175 return bind_match(type, left,
2176 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2180 Perl_invert(pTHX_ OP *o)
2184 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2185 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2189 Perl_scope(pTHX_ OP *o)
2192 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2193 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2194 o->op_type = OP_LEAVE;
2195 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2198 if (o->op_type == OP_LINESEQ) {
2200 o->op_type = OP_SCOPE;
2201 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2202 kid = ((LISTOP*)o)->op_first;
2203 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2207 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2214 Perl_save_hints(pTHX)
2217 SAVESPTR(GvHV(PL_hintgv));
2218 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2219 SAVEFREESV(GvHV(PL_hintgv));
2223 Perl_block_start(pTHX_ int full)
2225 int retval = PL_savestack_ix;
2227 SAVEI32(PL_comppad_name_floor);
2228 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2230 PL_comppad_name_fill = PL_comppad_name_floor;
2231 if (PL_comppad_name_floor < 0)
2232 PL_comppad_name_floor = 0;
2233 SAVEI32(PL_min_intro_pending);
2234 SAVEI32(PL_max_intro_pending);
2235 PL_min_intro_pending = 0;
2236 SAVEI32(PL_comppad_name_fill);
2237 SAVEI32(PL_padix_floor);
2238 PL_padix_floor = PL_padix;
2239 PL_pad_reset_pending = FALSE;
2241 PL_hints &= ~HINT_BLOCK_SCOPE;
2242 SAVESPTR(PL_compiling.cop_warnings);
2243 if (! specialWARN(PL_compiling.cop_warnings)) {
2244 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2245 SAVEFREESV(PL_compiling.cop_warnings) ;
2247 SAVESPTR(PL_compiling.cop_io);
2248 if (! specialCopIO(PL_compiling.cop_io)) {
2249 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2250 SAVEFREESV(PL_compiling.cop_io) ;
2256 Perl_block_end(pTHX_ I32 floor, OP *seq)
2258 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2259 line_t copline = PL_copline;
2260 /* there should be a nextstate in every block */
2261 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2262 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2264 PL_pad_reset_pending = FALSE;
2265 PL_compiling.op_private = PL_hints;
2267 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2268 pad_leavemy(PL_comppad_name_fill);
2276 #ifdef USE_5005THREADS
2277 OP *o = newOP(OP_THREADSV, 0);
2278 o->op_targ = find_threadsv("_");
2281 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2282 #endif /* USE_5005THREADS */
2286 Perl_newPROG(pTHX_ OP *o)
2291 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2292 ((PL_in_eval & EVAL_KEEPERR)
2293 ? OPf_SPECIAL : 0), o);
2294 PL_eval_start = linklist(PL_eval_root);
2295 PL_eval_root->op_private |= OPpREFCOUNTED;
2296 OpREFCNT_set(PL_eval_root, 1);
2297 PL_eval_root->op_next = 0;
2298 CALL_PEEP(PL_eval_start);
2303 PL_main_root = scope(sawparens(scalarvoid(o)));
2304 PL_curcop = &PL_compiling;
2305 PL_main_start = LINKLIST(PL_main_root);
2306 PL_main_root->op_private |= OPpREFCOUNTED;
2307 OpREFCNT_set(PL_main_root, 1);
2308 PL_main_root->op_next = 0;
2309 CALL_PEEP(PL_main_start);
2312 /* Register with debugger */
2314 CV *cv = get_cv("DB::postponed", FALSE);
2318 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2320 call_sv((SV*)cv, G_DISCARD);
2327 Perl_localize(pTHX_ OP *o, I32 lex)
2329 if (o->op_flags & OPf_PARENS)
2332 if (ckWARN(WARN_PARENTHESIS)
2333 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2335 char *s = PL_bufptr;
2337 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2340 if (*s == ';' || *s == '=')
2341 Perl_warner(aTHX_ WARN_PARENTHESIS,
2342 "Parentheses missing around \"%s\" list",
2343 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2349 o = mod(o, OP_NULL); /* a bit kludgey */
2351 PL_in_my_stash = Nullhv;
2356 Perl_jmaybe(pTHX_ OP *o)
2358 if (o->op_type == OP_LIST) {
2360 #ifdef USE_5005THREADS
2361 o2 = newOP(OP_THREADSV, 0);
2362 o2->op_targ = find_threadsv(";");
2364 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2365 #endif /* USE_5005THREADS */
2366 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2372 Perl_fold_constants(pTHX_ register OP *o)
2375 I32 type = o->op_type;
2378 if (PL_opargs[type] & OA_RETSCALAR)
2380 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2381 o->op_targ = pad_alloc(type, SVs_PADTMP);
2383 /* integerize op, unless it happens to be C<-foo>.
2384 * XXX should pp_i_negate() do magic string negation instead? */
2385 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2386 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2387 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2389 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2392 if (!(PL_opargs[type] & OA_FOLDCONST))
2397 /* XXX might want a ck_negate() for this */
2398 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2410 /* XXX what about the numeric ops? */
2411 if (PL_hints & HINT_LOCALE)
2416 goto nope; /* Don't try to run w/ errors */
2418 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2419 if ((curop->op_type != OP_CONST ||
2420 (curop->op_private & OPpCONST_BARE)) &&
2421 curop->op_type != OP_LIST &&
2422 curop->op_type != OP_SCALAR &&
2423 curop->op_type != OP_NULL &&
2424 curop->op_type != OP_PUSHMARK)
2430 curop = LINKLIST(o);
2434 sv = *(PL_stack_sp--);
2435 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2436 pad_swipe(o->op_targ);
2437 else if (SvTEMP(sv)) { /* grab mortal temp? */
2438 (void)SvREFCNT_inc(sv);
2442 if (type == OP_RV2GV)
2443 return newGVOP(OP_GV, 0, (GV*)sv);
2445 /* try to smush double to int, but don't smush -2.0 to -2 */
2446 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2449 #ifdef PERL_PRESERVE_IVUV
2450 /* Only bother to attempt to fold to IV if
2451 most operators will benefit */
2455 return newSVOP(OP_CONST, 0, sv);
2459 if (!(PL_opargs[type] & OA_OTHERINT))
2462 if (!(PL_hints & HINT_INTEGER)) {
2463 if (type == OP_MODULO
2464 || type == OP_DIVIDE
2465 || !(o->op_flags & OPf_KIDS))
2470 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2471 if (curop->op_type == OP_CONST) {
2472 if (SvIOK(((SVOP*)curop)->op_sv))
2476 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2480 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2487 Perl_gen_constant_list(pTHX_ register OP *o)
2490 I32 oldtmps_floor = PL_tmps_floor;
2494 return o; /* Don't attempt to run with errors */
2496 PL_op = curop = LINKLIST(o);
2503 PL_tmps_floor = oldtmps_floor;
2505 o->op_type = OP_RV2AV;
2506 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2507 curop = ((UNOP*)o)->op_first;
2508 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2515 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2517 if (!o || o->op_type != OP_LIST)
2518 o = newLISTOP(OP_LIST, 0, o, Nullop);
2520 o->op_flags &= ~OPf_WANT;
2522 if (!(PL_opargs[type] & OA_MARK))
2523 op_null(cLISTOPo->op_first);
2526 o->op_ppaddr = PL_ppaddr[type];
2527 o->op_flags |= flags;
2529 o = CHECKOP(type, o);
2530 if (o->op_type != type)
2533 return fold_constants(o);
2536 /* List constructors */
2539 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2547 if (first->op_type != type
2548 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2550 return newLISTOP(type, 0, first, last);
2553 if (first->op_flags & OPf_KIDS)
2554 ((LISTOP*)first)->op_last->op_sibling = last;
2556 first->op_flags |= OPf_KIDS;
2557 ((LISTOP*)first)->op_first = last;
2559 ((LISTOP*)first)->op_last = last;
2564 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2572 if (first->op_type != type)
2573 return prepend_elem(type, (OP*)first, (OP*)last);
2575 if (last->op_type != type)
2576 return append_elem(type, (OP*)first, (OP*)last);
2578 first->op_last->op_sibling = last->op_first;
2579 first->op_last = last->op_last;
2580 first->op_flags |= (last->op_flags & OPf_KIDS);
2582 #ifdef PL_OP_SLAB_ALLOC
2590 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2598 if (last->op_type == type) {
2599 if (type == OP_LIST) { /* already a PUSHMARK there */
2600 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2601 ((LISTOP*)last)->op_first->op_sibling = first;
2602 if (!(first->op_flags & OPf_PARENS))
2603 last->op_flags &= ~OPf_PARENS;
2606 if (!(last->op_flags & OPf_KIDS)) {
2607 ((LISTOP*)last)->op_last = first;
2608 last->op_flags |= OPf_KIDS;
2610 first->op_sibling = ((LISTOP*)last)->op_first;
2611 ((LISTOP*)last)->op_first = first;
2613 last->op_flags |= OPf_KIDS;
2617 return newLISTOP(type, 0, first, last);
2623 Perl_newNULLLIST(pTHX)
2625 return newOP(OP_STUB, 0);
2629 Perl_force_list(pTHX_ OP *o)
2631 if (!o || o->op_type != OP_LIST)
2632 o = newLISTOP(OP_LIST, 0, o, Nullop);
2638 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2642 NewOp(1101, listop, 1, LISTOP);
2644 listop->op_type = type;
2645 listop->op_ppaddr = PL_ppaddr[type];
2648 listop->op_flags = flags;
2652 else if (!first && last)
2655 first->op_sibling = last;
2656 listop->op_first = first;
2657 listop->op_last = last;
2658 if (type == OP_LIST) {
2660 pushop = newOP(OP_PUSHMARK, 0);
2661 pushop->op_sibling = first;
2662 listop->op_first = pushop;
2663 listop->op_flags |= OPf_KIDS;
2665 listop->op_last = pushop;
2672 Perl_newOP(pTHX_ I32 type, I32 flags)
2675 NewOp(1101, o, 1, OP);
2677 o->op_ppaddr = PL_ppaddr[type];
2678 o->op_flags = flags;
2681 o->op_private = 0 + (flags >> 8);
2682 if (PL_opargs[type] & OA_RETSCALAR)
2684 if (PL_opargs[type] & OA_TARGET)
2685 o->op_targ = pad_alloc(type, SVs_PADTMP);
2686 return CHECKOP(type, o);
2690 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2695 first = newOP(OP_STUB, 0);
2696 if (PL_opargs[type] & OA_MARK)
2697 first = force_list(first);
2699 NewOp(1101, unop, 1, UNOP);
2700 unop->op_type = type;
2701 unop->op_ppaddr = PL_ppaddr[type];
2702 unop->op_first = first;
2703 unop->op_flags = flags | OPf_KIDS;
2704 unop->op_private = 1 | (flags >> 8);
2705 unop = (UNOP*) CHECKOP(type, unop);
2709 return fold_constants((OP *) unop);
2713 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2716 NewOp(1101, binop, 1, BINOP);
2719 first = newOP(OP_NULL, 0);
2721 binop->op_type = type;
2722 binop->op_ppaddr = PL_ppaddr[type];
2723 binop->op_first = first;
2724 binop->op_flags = flags | OPf_KIDS;
2727 binop->op_private = 1 | (flags >> 8);
2730 binop->op_private = 2 | (flags >> 8);
2731 first->op_sibling = last;
2734 binop = (BINOP*)CHECKOP(type, binop);
2735 if (binop->op_next || binop->op_type != type)
2738 binop->op_last = binop->op_first->op_sibling;
2740 return fold_constants((OP *)binop);
2744 uvcompare(const void *a, const void *b)
2746 if (*((UV *)a) < (*(UV *)b))
2748 if (*((UV *)a) > (*(UV *)b))
2750 if (*((UV *)a+1) < (*(UV *)b+1))
2752 if (*((UV *)a+1) > (*(UV *)b+1))
2758 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2760 SV *tstr = ((SVOP*)expr)->op_sv;
2761 SV *rstr = ((SVOP*)repl)->op_sv;
2764 U8 *t = (U8*)SvPV(tstr, tlen);
2765 U8 *r = (U8*)SvPV(rstr, rlen);
2772 register short *tbl;
2774 PL_hints |= HINT_BLOCK_SCOPE;
2775 complement = o->op_private & OPpTRANS_COMPLEMENT;
2776 del = o->op_private & OPpTRANS_DELETE;
2777 squash = o->op_private & OPpTRANS_SQUASH;
2780 o->op_private |= OPpTRANS_FROM_UTF;
2783 o->op_private |= OPpTRANS_TO_UTF;
2785 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2786 SV* listsv = newSVpvn("# comment\n",10);
2788 U8* tend = t + tlen;
2789 U8* rend = r + rlen;
2803 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2804 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2810 tsave = t = bytes_to_utf8(t, &len);
2813 if (!to_utf && rlen) {
2815 rsave = r = bytes_to_utf8(r, &len);
2819 /* There are several snags with this code on EBCDIC:
2820 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2821 2. scan_const() in toke.c has encoded chars in native encoding which makes
2822 ranges at least in EBCDIC 0..255 range the bottom odd.
2826 U8 tmpbuf[UTF8_MAXLEN+1];
2829 New(1109, cp, 2*tlen, UV);
2831 transv = newSVpvn("",0);
2833 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2835 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2837 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2841 cp[2*i+1] = cp[2*i];
2845 qsort(cp, i, 2*sizeof(UV), uvcompare);
2846 for (j = 0; j < i; j++) {
2848 diff = val - nextmin;
2850 t = uvuni_to_utf8(tmpbuf,nextmin);
2851 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2853 U8 range_mark = UTF_TO_NATIVE(0xff);
2854 t = uvuni_to_utf8(tmpbuf, val - 1);
2855 sv_catpvn(transv, (char *)&range_mark, 1);
2856 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2863 t = uvuni_to_utf8(tmpbuf,nextmin);
2864 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2866 U8 range_mark = UTF_TO_NATIVE(0xff);
2867 sv_catpvn(transv, (char *)&range_mark, 1);
2869 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2870 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2871 t = (U8*)SvPVX(transv);
2872 tlen = SvCUR(transv);
2876 else if (!rlen && !del) {
2877 r = t; rlen = tlen; rend = tend;
2880 if ((!rlen && !del) || t == r ||
2881 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2883 o->op_private |= OPpTRANS_IDENTICAL;
2887 while (t < tend || tfirst <= tlast) {
2888 /* see if we need more "t" chars */
2889 if (tfirst > tlast) {
2890 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2892 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2894 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2901 /* now see if we need more "r" chars */
2902 if (rfirst > rlast) {
2904 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2906 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2908 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2917 rfirst = rlast = 0xffffffff;
2921 /* now see which range will peter our first, if either. */
2922 tdiff = tlast - tfirst;
2923 rdiff = rlast - rfirst;
2930 if (rfirst == 0xffffffff) {
2931 diff = tdiff; /* oops, pretend rdiff is infinite */
2933 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2934 (long)tfirst, (long)tlast);
2936 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2940 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2941 (long)tfirst, (long)(tfirst + diff),
2944 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2945 (long)tfirst, (long)rfirst);
2947 if (rfirst + diff > max)
2948 max = rfirst + diff;
2950 grows = (tfirst < rfirst &&
2951 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2963 else if (max > 0xff)
2968 Safefree(cPVOPo->op_pv);
2969 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2970 SvREFCNT_dec(listsv);
2972 SvREFCNT_dec(transv);
2974 if (!del && havefinal && rlen)
2975 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2976 newSVuv((UV)final), 0);
2979 o->op_private |= OPpTRANS_GROWS;
2991 tbl = (short*)cPVOPo->op_pv;
2993 Zero(tbl, 256, short);
2994 for (i = 0; i < tlen; i++)
2996 for (i = 0, j = 0; i < 256; i++) {
3007 if (i < 128 && r[j] >= 128)
3017 o->op_private |= OPpTRANS_IDENTICAL;
3022 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3023 tbl[0x100] = rlen - j;
3024 for (i=0; i < rlen - j; i++)
3025 tbl[0x101+i] = r[j+i];
3029 if (!rlen && !del) {
3032 o->op_private |= OPpTRANS_IDENTICAL;
3034 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3035 o->op_private |= OPpTRANS_IDENTICAL;
3037 for (i = 0; i < 256; i++)
3039 for (i = 0, j = 0; i < tlen; i++,j++) {
3042 if (tbl[t[i]] == -1)
3048 if (tbl[t[i]] == -1) {
3049 if (t[i] < 128 && r[j] >= 128)
3056 o->op_private |= OPpTRANS_GROWS;
3064 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3068 NewOp(1101, pmop, 1, PMOP);
3069 pmop->op_type = type;
3070 pmop->op_ppaddr = PL_ppaddr[type];
3071 pmop->op_flags = flags;
3072 pmop->op_private = 0 | (flags >> 8);
3074 if (PL_hints & HINT_RE_TAINT)
3075 pmop->op_pmpermflags |= PMf_RETAINT;
3076 if (PL_hints & HINT_LOCALE)
3077 pmop->op_pmpermflags |= PMf_LOCALE;
3078 pmop->op_pmflags = pmop->op_pmpermflags;
3083 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3084 repointer = av_pop((AV*)PL_regex_pad[0]);
3085 pmop->op_pmoffset = SvIV(repointer);
3086 SvREPADTMP_off(repointer);
3087 sv_setiv(repointer,0);
3089 repointer = newSViv(0);
3090 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3091 pmop->op_pmoffset = av_len(PL_regex_padav);
3092 PL_regex_pad = AvARRAY(PL_regex_padav);
3097 /* link into pm list */
3098 if (type != OP_TRANS && PL_curstash) {
3099 pmop->op_pmnext = HvPMROOT(PL_curstash);
3100 HvPMROOT(PL_curstash) = pmop;
3101 PmopSTASH_set(pmop,PL_curstash);
3108 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3112 I32 repl_has_vars = 0;
3114 if (o->op_type == OP_TRANS)
3115 return pmtrans(o, expr, repl);
3117 PL_hints |= HINT_BLOCK_SCOPE;
3120 if (expr->op_type == OP_CONST) {
3122 SV *pat = ((SVOP*)expr)->op_sv;
3123 char *p = SvPV(pat, plen);
3124 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3125 sv_setpvn(pat, "\\s+", 3);
3126 p = SvPV(pat, plen);
3127 pm->op_pmflags |= PMf_SKIPWHITE;
3129 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3130 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3131 pm->op_pmflags |= PMf_WHITE;
3135 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3136 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3138 : OP_REGCMAYBE),0,expr);
3140 NewOp(1101, rcop, 1, LOGOP);
3141 rcop->op_type = OP_REGCOMP;
3142 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3143 rcop->op_first = scalar(expr);
3144 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3145 ? (OPf_SPECIAL | OPf_KIDS)
3147 rcop->op_private = 1;
3150 /* establish postfix order */
3151 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3153 rcop->op_next = expr;
3154 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3157 rcop->op_next = LINKLIST(expr);
3158 expr->op_next = (OP*)rcop;
3161 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3166 if (pm->op_pmflags & PMf_EVAL) {
3168 if (CopLINE(PL_curcop) < PL_multi_end)
3169 CopLINE_set(PL_curcop, PL_multi_end);
3171 #ifdef USE_5005THREADS
3172 else if (repl->op_type == OP_THREADSV
3173 && strchr("&`'123456789+",
3174 PL_threadsv_names[repl->op_targ]))
3178 #endif /* USE_5005THREADS */
3179 else if (repl->op_type == OP_CONST)
3183 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3184 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3185 #ifdef USE_5005THREADS
3186 if (curop->op_type == OP_THREADSV) {
3188 if (strchr("&`'123456789+", curop->op_private))
3192 if (curop->op_type == OP_GV) {
3193 GV *gv = cGVOPx_gv(curop);
3195 if (strchr("&`'123456789+", *GvENAME(gv)))
3198 #endif /* USE_5005THREADS */
3199 else if (curop->op_type == OP_RV2CV)
3201 else if (curop->op_type == OP_RV2SV ||
3202 curop->op_type == OP_RV2AV ||
3203 curop->op_type == OP_RV2HV ||
3204 curop->op_type == OP_RV2GV) {
3205 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3208 else if (curop->op_type == OP_PADSV ||
3209 curop->op_type == OP_PADAV ||
3210 curop->op_type == OP_PADHV ||
3211 curop->op_type == OP_PADANY) {
3214 else if (curop->op_type == OP_PUSHRE)
3215 ; /* Okay here, dangerous in newASSIGNOP */
3225 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3226 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3227 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3228 prepend_elem(o->op_type, scalar(repl), o);
3231 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3232 pm->op_pmflags |= PMf_MAYBE_CONST;
3233 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3235 NewOp(1101, rcop, 1, LOGOP);
3236 rcop->op_type = OP_SUBSTCONT;
3237 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3238 rcop->op_first = scalar(repl);
3239 rcop->op_flags |= OPf_KIDS;
3240 rcop->op_private = 1;
3243 /* establish postfix order */
3244 rcop->op_next = LINKLIST(repl);
3245 repl->op_next = (OP*)rcop;
3247 pm->op_pmreplroot = scalar((OP*)rcop);
3248 pm->op_pmreplstart = LINKLIST(rcop);
3257 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3260 NewOp(1101, svop, 1, SVOP);
3261 svop->op_type = type;
3262 svop->op_ppaddr = PL_ppaddr[type];
3264 svop->op_next = (OP*)svop;
3265 svop->op_flags = flags;
3266 if (PL_opargs[type] & OA_RETSCALAR)
3268 if (PL_opargs[type] & OA_TARGET)
3269 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3270 return CHECKOP(type, svop);
3274 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3277 NewOp(1101, padop, 1, PADOP);
3278 padop->op_type = type;
3279 padop->op_ppaddr = PL_ppaddr[type];
3280 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3281 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3282 PL_curpad[padop->op_padix] = sv;
3284 padop->op_next = (OP*)padop;
3285 padop->op_flags = flags;
3286 if (PL_opargs[type] & OA_RETSCALAR)
3288 if (PL_opargs[type] & OA_TARGET)
3289 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3290 return CHECKOP(type, padop);
3294 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3298 return newPADOP(type, flags, SvREFCNT_inc(gv));
3300 return newSVOP(type, flags, SvREFCNT_inc(gv));
3305 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3308 NewOp(1101, pvop, 1, PVOP);
3309 pvop->op_type = type;
3310 pvop->op_ppaddr = PL_ppaddr[type];
3312 pvop->op_next = (OP*)pvop;
3313 pvop->op_flags = flags;
3314 if (PL_opargs[type] & OA_RETSCALAR)
3316 if (PL_opargs[type] & OA_TARGET)
3317 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3318 return CHECKOP(type, pvop);
3322 Perl_package(pTHX_ OP *o)
3326 save_hptr(&PL_curstash);
3327 save_item(PL_curstname);
3332 name = SvPV(sv, len);
3333 PL_curstash = gv_stashpvn(name,len,TRUE);
3334 sv_setpvn(PL_curstname, name, len);
3338 deprecate("\"package\" with no arguments");
3339 sv_setpv(PL_curstname,"<none>");
3340 PL_curstash = Nullhv;
3342 PL_hints |= HINT_BLOCK_SCOPE;
3343 PL_copline = NOLINE;
3348 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3353 char *packname = Nullch;
3357 if (id->op_type != OP_CONST)
3358 Perl_croak(aTHX_ "Module name must be constant");
3362 if (version != Nullop) {
3363 SV *vesv = ((SVOP*)version)->op_sv;
3365 if (arg == Nullop && !SvNIOKp(vesv)) {
3372 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3373 Perl_croak(aTHX_ "Version number must be constant number");
3375 /* Make copy of id so we don't free it twice */
3376 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3378 /* Fake up a method call to VERSION */
3379 meth = newSVpvn("VERSION",7);
3380 sv_upgrade(meth, SVt_PVIV);
3381 (void)SvIOK_on(meth);
3382 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3383 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3384 append_elem(OP_LIST,
3385 prepend_elem(OP_LIST, pack, list(version)),
3386 newSVOP(OP_METHOD_NAMED, 0, meth)));
3390 /* Fake up an import/unimport */
3391 if (arg && arg->op_type == OP_STUB)
3392 imop = arg; /* no import on explicit () */
3393 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3394 imop = Nullop; /* use 5.0; */
3399 /* Make copy of id so we don't free it twice */
3400 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3402 /* Fake up a method call to import/unimport */
3403 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3404 (void)SvUPGRADE(meth, SVt_PVIV);
3405 (void)SvIOK_on(meth);
3406 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3407 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3408 append_elem(OP_LIST,
3409 prepend_elem(OP_LIST, pack, list(arg)),
3410 newSVOP(OP_METHOD_NAMED, 0, meth)));
3413 if (ckWARN(WARN_MISC) &&
3414 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3415 SvPOK(packsv = ((SVOP*)id)->op_sv))
3417 /* BEGIN will free the ops, so we need to make a copy */
3418 packlen = SvCUR(packsv);
3419 packname = savepvn(SvPVX(packsv), packlen);
3422 /* Fake up the BEGIN {}, which does its thing immediately. */
3424 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3427 append_elem(OP_LINESEQ,
3428 append_elem(OP_LINESEQ,
3429 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3430 newSTATEOP(0, Nullch, veop)),
3431 newSTATEOP(0, Nullch, imop) ));
3434 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3435 Perl_warner(aTHX_ WARN_MISC,
3436 "Package `%s' not found "
3437 "(did you use the incorrect case?)", packname);
3442 PL_hints |= HINT_BLOCK_SCOPE;
3443 PL_copline = NOLINE;
3448 =for apidoc load_module
3450 Loads the module whose name is pointed to by the string part of name.
3451 Note that the actual module name, not its filename, should be given.
3452 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3453 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3454 (or 0 for no flags). ver, if specified, provides version semantics
3455 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3456 arguments can be used to specify arguments to the module's import()
3457 method, similar to C<use Foo::Bar VERSION LIST>.
3462 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3465 va_start(args, ver);
3466 vload_module(flags, name, ver, &args);
3470 #ifdef PERL_IMPLICIT_CONTEXT
3472 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3476 va_start(args, ver);
3477 vload_module(flags, name, ver, &args);
3483 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3485 OP *modname, *veop, *imop;
3487 modname = newSVOP(OP_CONST, 0, name);
3488 modname->op_private |= OPpCONST_BARE;
3490 veop = newSVOP(OP_CONST, 0, ver);
3494 if (flags & PERL_LOADMOD_NOIMPORT) {
3495 imop = sawparens(newNULLLIST());
3497 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3498 imop = va_arg(*args, OP*);
3503 sv = va_arg(*args, SV*);
3505 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3506 sv = va_arg(*args, SV*);
3510 line_t ocopline = PL_copline;
3511 int oexpect = PL_expect;
3513 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3514 veop, modname, imop);
3515 PL_expect = oexpect;
3516 PL_copline = ocopline;
3521 Perl_dofile(pTHX_ OP *term)
3526 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3527 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3528 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3530 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3531 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3532 append_elem(OP_LIST, term,
3533 scalar(newUNOP(OP_RV2CV, 0,
3538 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3544 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3546 return newBINOP(OP_LSLICE, flags,
3547 list(force_list(subscript)),
3548 list(force_list(listval)) );
3552 S_list_assignment(pTHX_ register OP *o)
3557 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3558 o = cUNOPo->op_first;
3560 if (o->op_type == OP_COND_EXPR) {
3561 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3562 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3567 yyerror("Assignment to both a list and a scalar");
3571 if (o->op_type == OP_LIST &&
3572 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3573 o->op_private & OPpLVAL_INTRO)
3576 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3577 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3578 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3581 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3584 if (o->op_type == OP_RV2SV)
3591 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3596 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3597 return newLOGOP(optype, 0,
3598 mod(scalar(left), optype),
3599 newUNOP(OP_SASSIGN, 0, scalar(right)));
3602 return newBINOP(optype, OPf_STACKED,
3603 mod(scalar(left), optype), scalar(right));
3607 if (list_assignment(left)) {
3611 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3612 left = mod(left, OP_AASSIGN);
3620 curop = list(force_list(left));
3621 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3622 o->op_private = 0 | (flags >> 8);
3623 for (curop = ((LISTOP*)curop)->op_first;
3624 curop; curop = curop->op_sibling)
3626 if (curop->op_type == OP_RV2HV &&
3627 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3628 o->op_private |= OPpASSIGN_HASH;
3632 if (!(left->op_private & OPpLVAL_INTRO)) {
3635 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3636 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3637 if (curop->op_type == OP_GV) {
3638 GV *gv = cGVOPx_gv(curop);
3639 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3641 SvCUR(gv) = PL_generation;
3643 else if (curop->op_type == OP_PADSV ||
3644 curop->op_type == OP_PADAV ||
3645 curop->op_type == OP_PADHV ||
3646 curop->op_type == OP_PADANY) {
3647 SV **svp = AvARRAY(PL_comppad_name);
3648 SV *sv = svp[curop->op_targ];
3649 if (SvCUR(sv) == PL_generation)
3651 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3653 else if (curop->op_type == OP_RV2CV)
3655 else if (curop->op_type == OP_RV2SV ||
3656 curop->op_type == OP_RV2AV ||
3657 curop->op_type == OP_RV2HV ||
3658 curop->op_type == OP_RV2GV) {
3659 if (lastop->op_type != OP_GV) /* funny deref? */
3662 else if (curop->op_type == OP_PUSHRE) {
3663 if (((PMOP*)curop)->op_pmreplroot) {
3665 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3667 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3669 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3671 SvCUR(gv) = PL_generation;
3680 o->op_private |= OPpASSIGN_COMMON;
3682 if (right && right->op_type == OP_SPLIT) {
3684 if ((tmpop = ((LISTOP*)right)->op_first) &&
3685 tmpop->op_type == OP_PUSHRE)
3687 PMOP *pm = (PMOP*)tmpop;
3688 if (left->op_type == OP_RV2AV &&
3689 !(left->op_private & OPpLVAL_INTRO) &&
3690 !(o->op_private & OPpASSIGN_COMMON) )
3692 tmpop = ((UNOP*)left)->op_first;
3693 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3695 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3696 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3698 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3699 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3701 pm->op_pmflags |= PMf_ONCE;
3702 tmpop = cUNOPo->op_first; /* to list (nulled) */
3703 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3704 tmpop->op_sibling = Nullop; /* don't free split */
3705 right->op_next = tmpop->op_next; /* fix starting loc */
3706 op_free(o); /* blow off assign */
3707 right->op_flags &= ~OPf_WANT;
3708 /* "I don't know and I don't care." */
3713 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3714 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3716 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3718 sv_setiv(sv, PL_modcount+1);
3726 right = newOP(OP_UNDEF, 0);
3727 if (right->op_type == OP_READLINE) {
3728 right->op_flags |= OPf_STACKED;
3729 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3732 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3733 o = newBINOP(OP_SASSIGN, flags,
3734 scalar(right), mod(scalar(left), OP_SASSIGN) );
3746 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3748 U32 seq = intro_my();
3751 NewOp(1101, cop, 1, COP);
3752 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3753 cop->op_type = OP_DBSTATE;
3754 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3757 cop->op_type = OP_NEXTSTATE;
3758 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3760 cop->op_flags = flags;
3761 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3763 cop->op_private |= NATIVE_HINTS;
3765 PL_compiling.op_private = cop->op_private;
3766 cop->op_next = (OP*)cop;
3769 cop->cop_label = label;
3770 PL_hints |= HINT_BLOCK_SCOPE;
3773 cop->cop_arybase = PL_curcop->cop_arybase;
3774 if (specialWARN(PL_curcop->cop_warnings))
3775 cop->cop_warnings = PL_curcop->cop_warnings ;
3777 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3778 if (specialCopIO(PL_curcop->cop_io))
3779 cop->cop_io = PL_curcop->cop_io;
3781 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3784 if (PL_copline == NOLINE)
3785 CopLINE_set(cop, CopLINE(PL_curcop));
3787 CopLINE_set(cop, PL_copline);
3788 PL_copline = NOLINE;
3791 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3793 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3795 CopSTASH_set(cop, PL_curstash);
3797 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3798 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3799 if (svp && *svp != &PL_sv_undef ) {
3800 (void)SvIOK_on(*svp);
3801 SvIVX(*svp) = PTR2IV(cop);
3805 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3808 /* "Introduce" my variables to visible status. */
3816 if (! PL_min_intro_pending)
3817 return PL_cop_seqmax;
3819 svp = AvARRAY(PL_comppad_name);
3820 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3821 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3822 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3823 SvNVX(sv) = (NV)PL_cop_seqmax;
3826 PL_min_intro_pending = 0;
3827 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3828 return PL_cop_seqmax++;
3832 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3834 return new_logop(type, flags, &first, &other);
3838 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3842 OP *first = *firstp;
3843 OP *other = *otherp;
3845 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3846 return newBINOP(type, flags, scalar(first), scalar(other));
3848 scalarboolean(first);
3849 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3850 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3851 if (type == OP_AND || type == OP_OR) {
3857 first = *firstp = cUNOPo->op_first;
3859 first->op_next = o->op_next;
3860 cUNOPo->op_first = Nullop;
3864 if (first->op_type == OP_CONST) {
3865 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3866 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3867 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3878 else if (first->op_type == OP_WANTARRAY) {
3884 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3885 OP *k1 = ((UNOP*)first)->op_first;
3886 OP *k2 = k1->op_sibling;
3888 switch (first->op_type)
3891 if (k2 && k2->op_type == OP_READLINE
3892 && (k2->op_flags & OPf_STACKED)
3893 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3895 warnop = k2->op_type;
3900 if (k1->op_type == OP_READDIR
3901 || k1->op_type == OP_GLOB
3902 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3903 || k1->op_type == OP_EACH)
3905 warnop = ((k1->op_type == OP_NULL)
3906 ? k1->op_targ : k1->op_type);
3911 line_t oldline = CopLINE(PL_curcop);
3912 CopLINE_set(PL_curcop, PL_copline);
3913 Perl_warner(aTHX_ WARN_MISC,
3914 "Value of %s%s can be \"0\"; test with defined()",
3916 ((warnop == OP_READLINE || warnop == OP_GLOB)
3917 ? " construct" : "() operator"));
3918 CopLINE_set(PL_curcop, oldline);
3925 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3926 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3928 NewOp(1101, logop, 1, LOGOP);
3930 logop->op_type = type;
3931 logop->op_ppaddr = PL_ppaddr[type];
3932 logop->op_first = first;
3933 logop->op_flags = flags | OPf_KIDS;
3934 logop->op_other = LINKLIST(other);
3935 logop->op_private = 1 | (flags >> 8);
3937 /* establish postfix order */
3938 logop->op_next = LINKLIST(first);
3939 first->op_next = (OP*)logop;
3940 first->op_sibling = other;
3942 o = newUNOP(OP_NULL, 0, (OP*)logop);
3949 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3956 return newLOGOP(OP_AND, 0, first, trueop);
3958 return newLOGOP(OP_OR, 0, first, falseop);
3960 scalarboolean(first);
3961 if (first->op_type == OP_CONST) {
3962 if (SvTRUE(((SVOP*)first)->op_sv)) {
3973 else if (first->op_type == OP_WANTARRAY) {
3977 NewOp(1101, logop, 1, LOGOP);
3978 logop->op_type = OP_COND_EXPR;
3979 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3980 logop->op_first = first;
3981 logop->op_flags = flags | OPf_KIDS;
3982 logop->op_private = 1 | (flags >> 8);
3983 logop->op_other = LINKLIST(trueop);
3984 logop->op_next = LINKLIST(falseop);
3987 /* establish postfix order */
3988 start = LINKLIST(first);
3989 first->op_next = (OP*)logop;
3991 first->op_sibling = trueop;
3992 trueop->op_sibling = falseop;
3993 o = newUNOP(OP_NULL, 0, (OP*)logop);
3995 trueop->op_next = falseop->op_next = o;
4002 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4010 NewOp(1101, range, 1, LOGOP);
4012 range->op_type = OP_RANGE;
4013 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4014 range->op_first = left;
4015 range->op_flags = OPf_KIDS;
4016 leftstart = LINKLIST(left);
4017 range->op_other = LINKLIST(right);
4018 range->op_private = 1 | (flags >> 8);
4020 left->op_sibling = right;
4022 range->op_next = (OP*)range;
4023 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4024 flop = newUNOP(OP_FLOP, 0, flip);
4025 o = newUNOP(OP_NULL, 0, flop);
4027 range->op_next = leftstart;
4029 left->op_next = flip;
4030 right->op_next = flop;
4032 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4033 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4034 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4035 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4037 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4038 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4041 if (!flip->op_private || !flop->op_private)
4042 linklist(o); /* blow off optimizer unless constant */
4048 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4052 int once = block && block->op_flags & OPf_SPECIAL &&
4053 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4056 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4057 return block; /* do {} while 0 does once */
4058 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4059 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4060 expr = newUNOP(OP_DEFINED, 0,
4061 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4062 } else if (expr->op_flags & OPf_KIDS) {
4063 OP *k1 = ((UNOP*)expr)->op_first;
4064 OP *k2 = (k1) ? k1->op_sibling : NULL;
4065 switch (expr->op_type) {
4067 if (k2 && k2->op_type == OP_READLINE
4068 && (k2->op_flags & OPf_STACKED)
4069 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4070 expr = newUNOP(OP_DEFINED, 0, expr);
4074 if (k1->op_type == OP_READDIR
4075 || k1->op_type == OP_GLOB
4076 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4077 || k1->op_type == OP_EACH)
4078 expr = newUNOP(OP_DEFINED, 0, expr);
4084 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4085 o = new_logop(OP_AND, 0, &expr, &listop);
4088 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4090 if (once && o != listop)
4091 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4094 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4096 o->op_flags |= flags;
4098 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4103 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4111 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4112 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4113 expr = newUNOP(OP_DEFINED, 0,
4114 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4115 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4116 OP *k1 = ((UNOP*)expr)->op_first;
4117 OP *k2 = (k1) ? k1->op_sibling : NULL;
4118 switch (expr->op_type) {
4120 if (k2 && k2->op_type == OP_READLINE
4121 && (k2->op_flags & OPf_STACKED)
4122 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4123 expr = newUNOP(OP_DEFINED, 0, expr);
4127 if (k1->op_type == OP_READDIR
4128 || k1->op_type == OP_GLOB
4129 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4130 || k1->op_type == OP_EACH)
4131 expr = newUNOP(OP_DEFINED, 0, expr);
4137 block = newOP(OP_NULL, 0);
4139 block = scope(block);
4143 next = LINKLIST(cont);
4146 OP *unstack = newOP(OP_UNSTACK, 0);
4149 cont = append_elem(OP_LINESEQ, cont, unstack);
4150 if ((line_t)whileline != NOLINE) {
4151 PL_copline = whileline;
4152 cont = append_elem(OP_LINESEQ, cont,
4153 newSTATEOP(0, Nullch, Nullop));
4157 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4158 redo = LINKLIST(listop);
4161 PL_copline = whileline;
4163 o = new_logop(OP_AND, 0, &expr, &listop);
4164 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4165 op_free(expr); /* oops, it's a while (0) */
4167 return Nullop; /* listop already freed by new_logop */
4170 ((LISTOP*)listop)->op_last->op_next =
4171 (o == listop ? redo : LINKLIST(o));
4177 NewOp(1101,loop,1,LOOP);
4178 loop->op_type = OP_ENTERLOOP;
4179 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4180 loop->op_private = 0;
4181 loop->op_next = (OP*)loop;
4184 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4186 loop->op_redoop = redo;
4187 loop->op_lastop = o;
4188 o->op_private |= loopflags;
4191 loop->op_nextop = next;
4193 loop->op_nextop = o;
4195 o->op_flags |= flags;
4196 o->op_private |= (flags >> 8);
4201 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4209 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4210 sv->op_type = OP_RV2GV;
4211 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4213 else if (sv->op_type == OP_PADSV) { /* private variable */
4214 padoff = sv->op_targ;
4219 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4220 padoff = sv->op_targ;
4222 iterflags |= OPf_SPECIAL;
4227 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4230 #ifdef USE_5005THREADS
4231 padoff = find_threadsv("_");
4232 iterflags |= OPf_SPECIAL;
4234 sv = newGVOP(OP_GV, 0, PL_defgv);
4237 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4238 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4239 iterflags |= OPf_STACKED;
4241 else if (expr->op_type == OP_NULL &&
4242 (expr->op_flags & OPf_KIDS) &&
4243 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4245 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4246 * set the STACKED flag to indicate that these values are to be
4247 * treated as min/max values by 'pp_iterinit'.
4249 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4250 LOGOP* range = (LOGOP*) flip->op_first;
4251 OP* left = range->op_first;
4252 OP* right = left->op_sibling;
4255 range->op_flags &= ~OPf_KIDS;
4256 range->op_first = Nullop;
4258 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4259 listop->op_first->op_next = range->op_next;
4260 left->op_next = range->op_other;
4261 right->op_next = (OP*)listop;
4262 listop->op_next = listop->op_first;
4265 expr = (OP*)(listop);
4267 iterflags |= OPf_STACKED;
4270 expr = mod(force_list(expr), OP_GREPSTART);
4274 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4275 append_elem(OP_LIST, expr, scalar(sv))));
4276 assert(!loop->op_next);
4277 #ifdef PL_OP_SLAB_ALLOC
4280 NewOp(1234,tmp,1,LOOP);
4281 Copy(loop,tmp,1,LOOP);
4285 Renew(loop, 1, LOOP);
4287 loop->op_targ = padoff;
4288 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4289 PL_copline = forline;
4290 return newSTATEOP(0, label, wop);
4294 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4299 if (type != OP_GOTO || label->op_type == OP_CONST) {
4300 /* "last()" means "last" */
4301 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4302 o = newOP(type, OPf_SPECIAL);
4304 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4305 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4311 if (label->op_type == OP_ENTERSUB)
4312 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4313 o = newUNOP(type, OPf_STACKED, label);
4315 PL_hints |= HINT_BLOCK_SCOPE;
4320 Perl_cv_undef(pTHX_ CV *cv)
4322 #ifdef USE_5005THREADS
4324 MUTEX_DESTROY(CvMUTEXP(cv));
4325 Safefree(CvMUTEXP(cv));
4328 #endif /* USE_5005THREADS */
4331 if (CvFILE(cv) && !CvXSUB(cv)) {
4332 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4333 Safefree(CvFILE(cv));
4338 if (!CvXSUB(cv) && CvROOT(cv)) {
4339 #ifdef USE_5005THREADS
4340 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4341 Perl_croak(aTHX_ "Can't undef active subroutine");
4344 Perl_croak(aTHX_ "Can't undef active subroutine");
4345 #endif /* USE_5005THREADS */
4348 SAVEVPTR(PL_curpad);
4351 op_free(CvROOT(cv));
4352 CvROOT(cv) = Nullop;
4355 SvPOK_off((SV*)cv); /* forget prototype */
4357 /* Since closure prototypes have the same lifetime as the containing
4358 * CV, they don't hold a refcount on the outside CV. This avoids
4359 * the refcount loop between the outer CV (which keeps a refcount to
4360 * the closure prototype in the pad entry for pp_anoncode()) and the
4361 * closure prototype, and the ensuing memory leak. --GSAR */
4362 if (!CvANON(cv) || CvCLONED(cv))
4363 SvREFCNT_dec(CvOUTSIDE(cv));
4364 CvOUTSIDE(cv) = Nullcv;
4366 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4369 if (CvPADLIST(cv)) {
4370 /* may be during global destruction */
4371 if (SvREFCNT(CvPADLIST(cv))) {
4372 I32 i = AvFILLp(CvPADLIST(cv));
4374 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4375 SV* sv = svp ? *svp : Nullsv;
4378 if (sv == (SV*)PL_comppad_name)
4379 PL_comppad_name = Nullav;
4380 else if (sv == (SV*)PL_comppad) {
4381 PL_comppad = Nullav;
4382 PL_curpad = Null(SV**);
4386 SvREFCNT_dec((SV*)CvPADLIST(cv));
4388 CvPADLIST(cv) = Nullav;
4396 #ifdef DEBUG_CLOSURES
4398 S_cv_dump(pTHX_ CV *cv)
4401 CV *outside = CvOUTSIDE(cv);
4402 AV* padlist = CvPADLIST(cv);
4409 PerlIO_printf(Perl_debug_log,
4410 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4412 (CvANON(cv) ? "ANON"
4413 : (cv == PL_main_cv) ? "MAIN"
4414 : CvUNIQUE(cv) ? "UNIQUE"
4415 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4418 : CvANON(outside) ? "ANON"
4419 : (outside == PL_main_cv) ? "MAIN"
4420 : CvUNIQUE(outside) ? "UNIQUE"
4421 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4426 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4427 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4428 pname = AvARRAY(pad_name);
4429 ppad = AvARRAY(pad);
4431 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4432 if (SvPOK(pname[ix]))
4433 PerlIO_printf(Perl_debug_log,
4434 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4435 (int)ix, PTR2UV(ppad[ix]),
4436 SvFAKE(pname[ix]) ? "FAKE " : "",
4438 (IV)I_32(SvNVX(pname[ix])),
4441 #endif /* DEBUGGING */
4443 #endif /* DEBUG_CLOSURES */
4446 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4450 AV* protopadlist = CvPADLIST(proto);
4451 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4452 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4453 SV** pname = AvARRAY(protopad_name);
4454 SV** ppad = AvARRAY(protopad);
4455 I32 fname = AvFILLp(protopad_name);
4456 I32 fpad = AvFILLp(protopad);
4460 assert(!CvUNIQUE(proto));
4464 SAVESPTR(PL_comppad_name);
4465 SAVESPTR(PL_compcv);
4467 cv = PL_compcv = (CV*)NEWSV(1104,0);
4468 sv_upgrade((SV *)cv, SvTYPE(proto));
4469 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4472 #ifdef USE_5005THREADS
4473 New(666, CvMUTEXP(cv), 1, perl_mutex);
4474 MUTEX_INIT(CvMUTEXP(cv));
4476 #endif /* USE_5005THREADS */
4478 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4479 : savepv(CvFILE(proto));
4481 CvFILE(cv) = CvFILE(proto);
4483 CvGV(cv) = CvGV(proto);
4484 CvSTASH(cv) = CvSTASH(proto);
4485 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4486 CvSTART(cv) = CvSTART(proto);
4488 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4491 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4493 PL_comppad_name = newAV();
4494 for (ix = fname; ix >= 0; ix--)
4495 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4497 PL_comppad = newAV();
4499 comppadlist = newAV();
4500 AvREAL_off(comppadlist);
4501 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4502 av_store(comppadlist, 1, (SV*)PL_comppad);
4503 CvPADLIST(cv) = comppadlist;
4504 av_fill(PL_comppad, AvFILLp(protopad));
4505 PL_curpad = AvARRAY(PL_comppad);
4507 av = newAV(); /* will be @_ */
4509 av_store(PL_comppad, 0, (SV*)av);
4510 AvFLAGS(av) = AVf_REIFY;
4512 for (ix = fpad; ix > 0; ix--) {
4513 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4514 if (namesv && namesv != &PL_sv_undef) {
4515 char *name = SvPVX(namesv); /* XXX */
4516 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4517 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4518 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4520 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4522 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4524 else { /* our own lexical */
4527 /* anon code -- we'll come back for it */
4528 sv = SvREFCNT_inc(ppad[ix]);
4530 else if (*name == '@')
4532 else if (*name == '%')
4541 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4542 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4545 SV* sv = NEWSV(0,0);
4551 /* Now that vars are all in place, clone nested closures. */
4553 for (ix = fpad; ix > 0; ix--) {
4554 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4556 && namesv != &PL_sv_undef
4557 && !(SvFLAGS(namesv) & SVf_FAKE)
4558 && *SvPVX(namesv) == '&'
4559 && CvCLONE(ppad[ix]))
4561 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4562 SvREFCNT_dec(ppad[ix]);
4565 PL_curpad[ix] = (SV*)kid;
4569 #ifdef DEBUG_CLOSURES
4570 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4572 PerlIO_printf(Perl_debug_log, " from:\n");
4574 PerlIO_printf(Perl_debug_log, " to:\n");
4581 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4583 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4585 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4592 Perl_cv_clone(pTHX_ CV *proto)
4595 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4596 cv = cv_clone2(proto, CvOUTSIDE(proto));
4597 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4602 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4604 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4605 SV* msg = sv_newmortal();
4609 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4610 sv_setpv(msg, "Prototype mismatch:");
4612 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4614 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4615 sv_catpv(msg, " vs ");
4617 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4619 sv_catpv(msg, "none");
4620 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4624 static void const_sv_xsub(pTHX_ CV* cv);
4627 =for apidoc cv_const_sv
4629 If C<cv> is a constant sub eligible for inlining. returns the constant
4630 value returned by the sub. Otherwise, returns NULL.
4632 Constant subs can be created with C<newCONSTSUB> or as described in
4633 L<perlsub/"Constant Functions">.
4638 Perl_cv_const_sv(pTHX_ CV *cv)
4640 if (!cv || !CvCONST(cv))
4642 return (SV*)CvXSUBANY(cv).any_ptr;
4646 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4653 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4654 o = cLISTOPo->op_first->op_sibling;
4656 for (; o; o = o->op_next) {
4657 OPCODE type = o->op_type;
4659 if (sv && o->op_next == o)
4661 if (o->op_next != o) {
4662 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4664 if (type == OP_DBSTATE)
4667 if (type == OP_LEAVESUB || type == OP_RETURN)
4671 if (type == OP_CONST && cSVOPo->op_sv)
4673 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4674 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4675 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4679 /* We get here only from cv_clone2() while creating a closure.
4680 Copy the const value here instead of in cv_clone2 so that
4681 SvREADONLY_on doesn't lead to problems when leaving
4686 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4698 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4708 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4712 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4714 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4718 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4724 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4729 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4730 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4731 SV *sv = sv_newmortal();
4732 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4733 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4738 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4739 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4749 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4750 maximum a prototype before. */
4751 if (SvTYPE(gv) > SVt_NULL) {
4752 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4753 && ckWARN_d(WARN_PROTOTYPE))
4755 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4757 cv_ckproto((CV*)gv, NULL, ps);
4760 sv_setpv((SV*)gv, ps);
4762 sv_setiv((SV*)gv, -1);
4763 SvREFCNT_dec(PL_compcv);
4764 cv = PL_compcv = NULL;
4765 PL_sub_generation++;
4769 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4771 #ifdef GV_UNIQUE_CHECK
4772 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4773 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4777 if (!block || !ps || *ps || attrs)
4780 const_sv = op_const_sv(block, Nullcv);
4783 bool exists = CvROOT(cv) || CvXSUB(cv);
4785 #ifdef GV_UNIQUE_CHECK
4786 if (exists && GvUNIQUE(gv)) {
4787 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4791 /* if the subroutine doesn't exist and wasn't pre-declared
4792 * with a prototype, assume it will be AUTOLOADed,
4793 * skipping the prototype check
4795 if (exists || SvPOK(cv))
4796 cv_ckproto(cv, gv, ps);
4797 /* already defined (or promised)? */
4798 if (exists || GvASSUMECV(gv)) {
4799 if (!block && !attrs) {
4800 /* just a "sub foo;" when &foo is already defined */
4801 SAVEFREESV(PL_compcv);
4804 /* ahem, death to those who redefine active sort subs */
4805 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4806 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4808 if (ckWARN(WARN_REDEFINE)
4810 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4812 line_t oldline = CopLINE(PL_curcop);
4813 if (PL_copline != NOLINE)
4814 CopLINE_set(PL_curcop, PL_copline);
4815 Perl_warner(aTHX_ WARN_REDEFINE,
4816 CvCONST(cv) ? "Constant subroutine %s redefined"
4817 : "Subroutine %s redefined", name);
4818 CopLINE_set(PL_curcop, oldline);
4826 SvREFCNT_inc(const_sv);
4828 assert(!CvROOT(cv) && !CvCONST(cv));
4829 sv_setpv((SV*)cv, ""); /* prototype is "" */
4830 CvXSUBANY(cv).any_ptr = const_sv;
4831 CvXSUB(cv) = const_sv_xsub;
4836 cv = newCONSTSUB(NULL, name, const_sv);
4839 SvREFCNT_dec(PL_compcv);
4841 PL_sub_generation++;
4848 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4849 * before we clobber PL_compcv.
4853 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4854 stash = GvSTASH(CvGV(cv));
4855 else if (CvSTASH(cv))
4856 stash = CvSTASH(cv);
4858 stash = PL_curstash;
4861 /* possibly about to re-define existing subr -- ignore old cv */
4862 rcv = (SV*)PL_compcv;
4863 if (name && GvSTASH(gv))
4864 stash = GvSTASH(gv);
4866 stash = PL_curstash;
4868 apply_attrs(stash, rcv, attrs, FALSE);
4870 if (cv) { /* must reuse cv if autoloaded */
4872 /* got here with just attrs -- work done, so bug out */
4873 SAVEFREESV(PL_compcv);
4877 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4878 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4879 CvOUTSIDE(PL_compcv) = 0;
4880 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4881 CvPADLIST(PL_compcv) = 0;
4882 /* inner references to PL_compcv must be fixed up ... */
4884 AV *padlist = CvPADLIST(cv);
4885 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4886 AV *comppad = (AV*)AvARRAY(padlist)[1];
4887 SV **namepad = AvARRAY(comppad_name);
4888 SV **curpad = AvARRAY(comppad);
4889 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4890 SV *namesv = namepad[ix];
4891 if (namesv && namesv != &PL_sv_undef
4892 && *SvPVX(namesv) == '&')
4894 CV *innercv = (CV*)curpad[ix];
4895 if (CvOUTSIDE(innercv) == PL_compcv) {
4896 CvOUTSIDE(innercv) = cv;
4897 if (!CvANON(innercv) || CvCLONED(innercv)) {
4898 (void)SvREFCNT_inc(cv);
4899 SvREFCNT_dec(PL_compcv);
4905 /* ... before we throw it away */
4906 SvREFCNT_dec(PL_compcv);
4907 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4908 ++PL_sub_generation;
4915 PL_sub_generation++;
4919 CvFILE_set_from_cop(cv, PL_curcop);
4920 CvSTASH(cv) = PL_curstash;
4921 #ifdef USE_5005THREADS
4923 if (!CvMUTEXP(cv)) {
4924 New(666, CvMUTEXP(cv), 1, perl_mutex);
4925 MUTEX_INIT(CvMUTEXP(cv));
4927 #endif /* USE_5005THREADS */
4930 sv_setpv((SV*)cv, ps);
4932 if (PL_error_count) {
4936 char *s = strrchr(name, ':');
4938 if (strEQ(s, "BEGIN")) {
4940 "BEGIN not safe after errors--compilation aborted";
4941 if (PL_in_eval & EVAL_KEEPERR)
4942 Perl_croak(aTHX_ not_safe);
4944 /* force display of errors found but not reported */
4945 sv_catpv(ERRSV, not_safe);
4946 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4954 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4955 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4958 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4959 mod(scalarseq(block), OP_LEAVESUBLV));
4962 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4964 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4965 OpREFCNT_set(CvROOT(cv), 1);
4966 CvSTART(cv) = LINKLIST(CvROOT(cv));
4967 CvROOT(cv)->op_next = 0;
4968 CALL_PEEP(CvSTART(cv));
4970 /* now that optimizer has done its work, adjust pad values */
4972 SV **namep = AvARRAY(PL_comppad_name);
4973 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4976 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4979 * The only things that a clonable function needs in its
4980 * pad are references to outer lexicals and anonymous subs.
4981 * The rest are created anew during cloning.
4983 if (!((namesv = namep[ix]) != Nullsv &&
4984 namesv != &PL_sv_undef &&
4986 *SvPVX(namesv) == '&')))
4988 SvREFCNT_dec(PL_curpad[ix]);
4989 PL_curpad[ix] = Nullsv;
4992 assert(!CvCONST(cv));
4993 if (ps && !*ps && op_const_sv(block, cv))
4997 AV *av = newAV(); /* Will be @_ */
4999 av_store(PL_comppad, 0, (SV*)av);
5000 AvFLAGS(av) = AVf_REIFY;
5002 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5003 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5005 if (!SvPADMY(PL_curpad[ix]))
5006 SvPADTMP_on(PL_curpad[ix]);
5010 /* If a potential closure prototype, don't keep a refcount on outer CV.
5011 * This is okay as the lifetime of the prototype is tied to the
5012 * lifetime of the outer CV. Avoids memory leak due to reference
5015 SvREFCNT_dec(CvOUTSIDE(cv));
5017 if (name || aname) {
5019 char *tname = (name ? name : aname);
5021 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5022 SV *sv = NEWSV(0,0);
5023 SV *tmpstr = sv_newmortal();
5024 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5028 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5030 (long)PL_subline, (long)CopLINE(PL_curcop));
5031 gv_efullname3(tmpstr, gv, Nullch);
5032 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5033 hv = GvHVn(db_postponed);
5034 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5035 && (pcv = GvCV(db_postponed)))
5041 call_sv((SV*)pcv, G_DISCARD);
5045 if ((s = strrchr(tname,':')))
5050 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5053 if (strEQ(s, "BEGIN")) {
5054 I32 oldscope = PL_scopestack_ix;
5056 SAVECOPFILE(&PL_compiling);
5057 SAVECOPLINE(&PL_compiling);
5060 PL_beginav = newAV();
5061 DEBUG_x( dump_sub(gv) );
5062 av_push(PL_beginav, (SV*)cv);
5063 GvCV(gv) = 0; /* cv has been hijacked */
5064 call_list(oldscope, PL_beginav);
5066 PL_curcop = &PL_compiling;
5067 PL_compiling.op_private = PL_hints;
5070 else if (strEQ(s, "END") && !PL_error_count) {
5073 DEBUG_x( dump_sub(gv) );
5074 av_unshift(PL_endav, 1);
5075 av_store(PL_endav, 0, (SV*)cv);
5076 GvCV(gv) = 0; /* cv has been hijacked */
5078 else if (strEQ(s, "CHECK") && !PL_error_count) {
5080 PL_checkav = newAV();
5081 DEBUG_x( dump_sub(gv) );
5082 if (PL_main_start && ckWARN(WARN_VOID))
5083 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5084 av_unshift(PL_checkav, 1);
5085 av_store(PL_checkav, 0, (SV*)cv);
5086 GvCV(gv) = 0; /* cv has been hijacked */
5088 else if (strEQ(s, "INIT") && !PL_error_count) {
5090 PL_initav = newAV();
5091 DEBUG_x( dump_sub(gv) );
5092 if (PL_main_start && ckWARN(WARN_VOID))
5093 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5094 av_push(PL_initav, (SV*)cv);
5095 GvCV(gv) = 0; /* cv has been hijacked */
5100 PL_copline = NOLINE;
5105 /* XXX unsafe for threads if eval_owner isn't held */
5107 =for apidoc newCONSTSUB
5109 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5110 eligible for inlining at compile-time.
5116 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5122 SAVECOPLINE(PL_curcop);
5123 CopLINE_set(PL_curcop, PL_copline);
5126 PL_hints &= ~HINT_BLOCK_SCOPE;
5129 SAVESPTR(PL_curstash);
5130 SAVECOPSTASH(PL_curcop);
5131 PL_curstash = stash;
5133 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5135 CopSTASH(PL_curcop) = stash;
5139 cv = newXS(name, const_sv_xsub, __FILE__);
5140 CvXSUBANY(cv).any_ptr = sv;
5142 sv_setpv((SV*)cv, ""); /* prototype is "" */
5150 =for apidoc U||newXS
5152 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5158 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5160 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5163 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5165 /* just a cached method */
5169 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5170 /* already defined (or promised) */
5171 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5172 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5173 line_t oldline = CopLINE(PL_curcop);
5174 if (PL_copline != NOLINE)
5175 CopLINE_set(PL_curcop, PL_copline);
5176 Perl_warner(aTHX_ WARN_REDEFINE,
5177 CvCONST(cv) ? "Constant subroutine %s redefined"
5178 : "Subroutine %s redefined"
5180 CopLINE_set(PL_curcop, oldline);
5187 if (cv) /* must reuse cv if autoloaded */
5190 cv = (CV*)NEWSV(1105,0);
5191 sv_upgrade((SV *)cv, SVt_PVCV);
5195 PL_sub_generation++;
5199 #ifdef USE_5005THREADS
5200 New(666, CvMUTEXP(cv), 1, perl_mutex);
5201 MUTEX_INIT(CvMUTEXP(cv));
5203 #endif /* USE_5005THREADS */
5204 (void)gv_fetchfile(filename);
5205 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5206 an external constant string */
5207 CvXSUB(cv) = subaddr;
5210 char *s = strrchr(name,':');
5216 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5219 if (strEQ(s, "BEGIN")) {
5221 PL_beginav = newAV();
5222 av_push(PL_beginav, (SV*)cv);
5223 GvCV(gv) = 0; /* cv has been hijacked */
5225 else if (strEQ(s, "END")) {
5228 av_unshift(PL_endav, 1);
5229 av_store(PL_endav, 0, (SV*)cv);
5230 GvCV(gv) = 0; /* cv has been hijacked */
5232 else if (strEQ(s, "CHECK")) {
5234 PL_checkav = newAV();
5235 if (PL_main_start && ckWARN(WARN_VOID))
5236 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5237 av_unshift(PL_checkav, 1);
5238 av_store(PL_checkav, 0, (SV*)cv);
5239 GvCV(gv) = 0; /* cv has been hijacked */
5241 else if (strEQ(s, "INIT")) {
5243 PL_initav = newAV();
5244 if (PL_main_start && ckWARN(WARN_VOID))
5245 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5246 av_push(PL_initav, (SV*)cv);
5247 GvCV(gv) = 0; /* cv has been hijacked */
5258 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5267 name = SvPVx(cSVOPo->op_sv, n_a);
5270 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5271 #ifdef GV_UNIQUE_CHECK
5273 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5277 if ((cv = GvFORM(gv))) {
5278 if (ckWARN(WARN_REDEFINE)) {
5279 line_t oldline = CopLINE(PL_curcop);
5280 if (PL_copline != NOLINE)
5281 CopLINE_set(PL_curcop, PL_copline);
5282 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5283 CopLINE_set(PL_curcop, oldline);
5290 CvFILE_set_from_cop(cv, PL_curcop);
5292 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5293 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5294 SvPADTMP_on(PL_curpad[ix]);
5297 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5298 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5299 OpREFCNT_set(CvROOT(cv), 1);
5300 CvSTART(cv) = LINKLIST(CvROOT(cv));
5301 CvROOT(cv)->op_next = 0;
5302 CALL_PEEP(CvSTART(cv));
5304 PL_copline = NOLINE;
5309 Perl_newANONLIST(pTHX_ OP *o)
5311 return newUNOP(OP_REFGEN, 0,
5312 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5316 Perl_newANONHASH(pTHX_ OP *o)
5318 return newUNOP(OP_REFGEN, 0,
5319 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5323 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5325 return newANONATTRSUB(floor, proto, Nullop, block);
5329 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5331 return newUNOP(OP_REFGEN, 0,
5332 newSVOP(OP_ANONCODE, 0,
5333 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5337 Perl_oopsAV(pTHX_ OP *o)
5339 switch (o->op_type) {
5341 o->op_type = OP_PADAV;
5342 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5343 return ref(o, OP_RV2AV);
5346 o->op_type = OP_RV2AV;
5347 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5352 if (ckWARN_d(WARN_INTERNAL))
5353 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5360 Perl_oopsHV(pTHX_ OP *o)
5362 switch (o->op_type) {
5365 o->op_type = OP_PADHV;
5366 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5367 return ref(o, OP_RV2HV);
5371 o->op_type = OP_RV2HV;
5372 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5377 if (ckWARN_d(WARN_INTERNAL))
5378 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5385 Perl_newAVREF(pTHX_ OP *o)
5387 if (o->op_type == OP_PADANY) {
5388 o->op_type = OP_PADAV;
5389 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5392 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5393 && ckWARN(WARN_DEPRECATED)) {
5394 Perl_warner(aTHX_ WARN_DEPRECATED,
5395 "Using an array as a reference is deprecated");
5397 return newUNOP(OP_RV2AV, 0, scalar(o));
5401 Perl_newGVREF(pTHX_ I32 type, OP *o)
5403 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5404 return newUNOP(OP_NULL, 0, o);
5405 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5409 Perl_newHVREF(pTHX_ OP *o)
5411 if (o->op_type == OP_PADANY) {
5412 o->op_type = OP_PADHV;
5413 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5416 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5417 && ckWARN(WARN_DEPRECATED)) {
5418 Perl_warner(aTHX_ WARN_DEPRECATED,
5419 "Using a hash as a reference is deprecated");
5421 return newUNOP(OP_RV2HV, 0, scalar(o));
5425 Perl_oopsCV(pTHX_ OP *o)
5427 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5433 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5435 return newUNOP(OP_RV2CV, flags, scalar(o));
5439 Perl_newSVREF(pTHX_ OP *o)
5441 if (o->op_type == OP_PADANY) {
5442 o->op_type = OP_PADSV;
5443 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5446 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5447 o->op_flags |= OPpDONE_SVREF;
5450 return newUNOP(OP_RV2SV, 0, scalar(o));
5453 /* Check routines. */
5456 Perl_ck_anoncode(pTHX_ OP *o)
5461 name = NEWSV(1106,0);
5462 sv_upgrade(name, SVt_PVNV);
5463 sv_setpvn(name, "&", 1);
5466 ix = pad_alloc(o->op_type, SVs_PADMY);
5467 av_store(PL_comppad_name, ix, name);
5468 av_store(PL_comppad, ix, cSVOPo->op_sv);
5469 SvPADMY_on(cSVOPo->op_sv);
5470 cSVOPo->op_sv = Nullsv;
5471 cSVOPo->op_targ = ix;
5476 Perl_ck_bitop(pTHX_ OP *o)
5478 o->op_private = PL_hints;
5483 Perl_ck_concat(pTHX_ OP *o)
5485 if (cUNOPo->op_first->op_type == OP_CONCAT)
5486 o->op_flags |= OPf_STACKED;
5491 Perl_ck_spair(pTHX_ OP *o)
5493 if (o->op_flags & OPf_KIDS) {
5496 OPCODE type = o->op_type;
5497 o = modkids(ck_fun(o), type);
5498 kid = cUNOPo->op_first;
5499 newop = kUNOP->op_first->op_sibling;
5501 (newop->op_sibling ||
5502 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5503 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5504 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5508 op_free(kUNOP->op_first);
5509 kUNOP->op_first = newop;
5511 o->op_ppaddr = PL_ppaddr[++o->op_type];
5516 Perl_ck_delete(pTHX_ OP *o)
5520 if (o->op_flags & OPf_KIDS) {
5521 OP *kid = cUNOPo->op_first;
5522 switch (kid->op_type) {
5524 o->op_flags |= OPf_SPECIAL;
5527 o->op_private |= OPpSLICE;
5530 o->op_flags |= OPf_SPECIAL;
5535 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5544 Perl_ck_die(pTHX_ OP *o)
5547 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5553 Perl_ck_eof(pTHX_ OP *o)
5555 I32 type = o->op_type;
5557 if (o->op_flags & OPf_KIDS) {
5558 if (cLISTOPo->op_first->op_type == OP_STUB) {
5560 o = newUNOP(type, OPf_SPECIAL,
5561 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5569 Perl_ck_eval(pTHX_ OP *o)
5571 PL_hints |= HINT_BLOCK_SCOPE;
5572 if (o->op_flags & OPf_KIDS) {
5573 SVOP *kid = (SVOP*)cUNOPo->op_first;
5576 o->op_flags &= ~OPf_KIDS;
5579 else if (kid->op_type == OP_LINESEQ) {
5582 kid->op_next = o->op_next;
5583 cUNOPo->op_first = 0;
5586 NewOp(1101, enter, 1, LOGOP);
5587 enter->op_type = OP_ENTERTRY;
5588 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5589 enter->op_private = 0;
5591 /* establish postfix order */
5592 enter->op_next = (OP*)enter;
5594 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5595 o->op_type = OP_LEAVETRY;
5596 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5597 enter->op_other = o;
5605 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5607 o->op_targ = (PADOFFSET)PL_hints;
5612 Perl_ck_exit(pTHX_ OP *o)
5615 HV *table = GvHV(PL_hintgv);
5617 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5618 if (svp && *svp && SvTRUE(*svp))
5619 o->op_private |= OPpEXIT_VMSISH;
5621 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5627 Perl_ck_exec(pTHX_ OP *o)
5630 if (o->op_flags & OPf_STACKED) {
5632 kid = cUNOPo->op_first->op_sibling;
5633 if (kid->op_type == OP_RV2GV)
5642 Perl_ck_exists(pTHX_ OP *o)
5645 if (o->op_flags & OPf_KIDS) {
5646 OP *kid = cUNOPo->op_first;
5647 if (kid->op_type == OP_ENTERSUB) {
5648 (void) ref(kid, o->op_type);
5649 if (kid->op_type != OP_RV2CV && !PL_error_count)
5650 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5652 o->op_private |= OPpEXISTS_SUB;
5654 else if (kid->op_type == OP_AELEM)
5655 o->op_flags |= OPf_SPECIAL;
5656 else if (kid->op_type != OP_HELEM)
5657 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5666 Perl_ck_gvconst(pTHX_ register OP *o)
5668 o = fold_constants(o);
5669 if (o->op_type == OP_CONST)
5676 Perl_ck_rvconst(pTHX_ register OP *o)
5678 SVOP *kid = (SVOP*)cUNOPo->op_first;
5680 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5681 if (kid->op_type == OP_CONST) {
5685 SV *kidsv = kid->op_sv;
5688 /* Is it a constant from cv_const_sv()? */
5689 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5690 SV *rsv = SvRV(kidsv);
5691 int svtype = SvTYPE(rsv);
5692 char *badtype = Nullch;
5694 switch (o->op_type) {
5696 if (svtype > SVt_PVMG)
5697 badtype = "a SCALAR";
5700 if (svtype != SVt_PVAV)
5701 badtype = "an ARRAY";
5704 if (svtype != SVt_PVHV) {
5705 if (svtype == SVt_PVAV) { /* pseudohash? */
5706 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5707 if (ksv && SvROK(*ksv)
5708 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5717 if (svtype != SVt_PVCV)
5722 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5725 name = SvPV(kidsv, n_a);
5726 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5727 char *badthing = Nullch;
5728 switch (o->op_type) {
5730 badthing = "a SCALAR";
5733 badthing = "an ARRAY";
5736 badthing = "a HASH";
5741 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5745 * This is a little tricky. We only want to add the symbol if we
5746 * didn't add it in the lexer. Otherwise we get duplicate strict
5747 * warnings. But if we didn't add it in the lexer, we must at
5748 * least pretend like we wanted to add it even if it existed before,
5749 * or we get possible typo warnings. OPpCONST_ENTERED says
5750 * whether the lexer already added THIS instance of this symbol.
5752 iscv = (o->op_type == OP_RV2CV) * 2;
5754 gv = gv_fetchpv(name,
5755 iscv | !(kid->op_private & OPpCONST_ENTERED),
5758 : o->op_type == OP_RV2SV
5760 : o->op_type == OP_RV2AV
5762 : o->op_type == OP_RV2HV
5765 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5767 kid->op_type = OP_GV;
5768 SvREFCNT_dec(kid->op_sv);
5770 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5771 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5772 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5774 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5776 kid->op_sv = SvREFCNT_inc(gv);
5778 kid->op_private = 0;
5779 kid->op_ppaddr = PL_ppaddr[OP_GV];
5786 Perl_ck_ftst(pTHX_ OP *o)
5788 I32 type = o->op_type;
5790 if (o->op_flags & OPf_REF) {
5793 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5794 SVOP *kid = (SVOP*)cUNOPo->op_first;
5796 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5798 OP *newop = newGVOP(type, OPf_REF,
5799 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5806 if (type == OP_FTTTY)
5807 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5810 o = newUNOP(type, 0, newDEFSVOP());
5816 Perl_ck_fun(pTHX_ OP *o)
5822 int type = o->op_type;
5823 register I32 oa = PL_opargs[type] >> OASHIFT;
5825 if (o->op_flags & OPf_STACKED) {
5826 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5829 return no_fh_allowed(o);
5832 if (o->op_flags & OPf_KIDS) {
5834 tokid = &cLISTOPo->op_first;
5835 kid = cLISTOPo->op_first;
5836 if (kid->op_type == OP_PUSHMARK ||
5837 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5839 tokid = &kid->op_sibling;
5840 kid = kid->op_sibling;
5842 if (!kid && PL_opargs[type] & OA_DEFGV)
5843 *tokid = kid = newDEFSVOP();
5847 sibl = kid->op_sibling;
5850 /* list seen where single (scalar) arg expected? */
5851 if (numargs == 1 && !(oa >> 4)
5852 && kid->op_type == OP_LIST && type != OP_SCALAR)
5854 return too_many_arguments(o,PL_op_desc[type]);
5867 if ((type == OP_PUSH || type == OP_UNSHIFT)
5868 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5869 Perl_warner(aTHX_ WARN_SYNTAX,
5870 "Useless use of %s with no values",
5873 if (kid->op_type == OP_CONST &&
5874 (kid->op_private & OPpCONST_BARE))
5876 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5877 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5878 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5879 if (ckWARN(WARN_DEPRECATED))
5880 Perl_warner(aTHX_ WARN_DEPRECATED,
5881 "Array @%s missing the @ in argument %"IVdf" of %s()",
5882 name, (IV)numargs, PL_op_desc[type]);
5885 kid->op_sibling = sibl;
5888 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5889 bad_type(numargs, "array", PL_op_desc[type], kid);
5893 if (kid->op_type == OP_CONST &&
5894 (kid->op_private & OPpCONST_BARE))
5896 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5897 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5898 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5899 if (ckWARN(WARN_DEPRECATED))
5900 Perl_warner(aTHX_ WARN_DEPRECATED,
5901 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5902 name, (IV)numargs, PL_op_desc[type]);
5905 kid->op_sibling = sibl;
5908 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5909 bad_type(numargs, "hash", PL_op_desc[type], kid);
5914 OP *newop = newUNOP(OP_NULL, 0, kid);
5915 kid->op_sibling = 0;
5917 newop->op_next = newop;
5919 kid->op_sibling = sibl;
5924 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5925 if (kid->op_type == OP_CONST &&
5926 (kid->op_private & OPpCONST_BARE))
5928 OP *newop = newGVOP(OP_GV, 0,
5929 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5934 else if (kid->op_type == OP_READLINE) {
5935 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5936 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5939 I32 flags = OPf_SPECIAL;
5943 /* is this op a FH constructor? */
5944 if (is_handle_constructor(o,numargs)) {
5945 char *name = Nullch;
5949 /* Set a flag to tell rv2gv to vivify
5950 * need to "prove" flag does not mean something
5951 * else already - NI-S 1999/05/07
5954 if (kid->op_type == OP_PADSV) {
5955 SV **namep = av_fetch(PL_comppad_name,
5957 if (namep && *namep)
5958 name = SvPV(*namep, len);
5960 else if (kid->op_type == OP_RV2SV
5961 && kUNOP->op_first->op_type == OP_GV)
5963 GV *gv = cGVOPx_gv(kUNOP->op_first);
5965 len = GvNAMELEN(gv);
5967 else if (kid->op_type == OP_AELEM
5968 || kid->op_type == OP_HELEM)
5970 name = "__ANONIO__";
5976 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5977 namesv = PL_curpad[targ];
5978 (void)SvUPGRADE(namesv, SVt_PV);
5980 sv_setpvn(namesv, "$", 1);
5981 sv_catpvn(namesv, name, len);
5984 kid->op_sibling = 0;
5985 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5986 kid->op_targ = targ;
5987 kid->op_private |= priv;
5989 kid->op_sibling = sibl;
5995 mod(scalar(kid), type);
5999 tokid = &kid->op_sibling;
6000 kid = kid->op_sibling;
6002 o->op_private |= numargs;
6004 return too_many_arguments(o,OP_DESC(o));
6007 else if (PL_opargs[type] & OA_DEFGV) {
6009 return newUNOP(type, 0, newDEFSVOP());
6013 while (oa & OA_OPTIONAL)
6015 if (oa && oa != OA_LIST)
6016 return too_few_arguments(o,OP_DESC(o));
6022 Perl_ck_glob(pTHX_ OP *o)
6027 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6028 append_elem(OP_GLOB, o, newDEFSVOP());
6030 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6031 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6033 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6036 #if !defined(PERL_EXTERNAL_GLOB)
6037 /* XXX this can be tightened up and made more failsafe. */
6041 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
6043 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6044 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6045 GvCV(gv) = GvCV(glob_gv);
6046 SvREFCNT_inc((SV*)GvCV(gv));
6047 GvIMPORTED_CV_on(gv);
6050 #endif /* PERL_EXTERNAL_GLOB */
6052 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6053 append_elem(OP_GLOB, o,
6054 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6055 o->op_type = OP_LIST;
6056 o->op_ppaddr = PL_ppaddr[OP_LIST];
6057 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6058 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6059 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6060 append_elem(OP_LIST, o,
6061 scalar(newUNOP(OP_RV2CV, 0,
6062 newGVOP(OP_GV, 0, gv)))));
6063 o = newUNOP(OP_NULL, 0, ck_subr(o));
6064 o->op_targ = OP_GLOB; /* hint at what it used to be */
6067 gv = newGVgen("main");
6069 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6075 Perl_ck_grep(pTHX_ OP *o)
6079 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6081 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6082 NewOp(1101, gwop, 1, LOGOP);
6084 if (o->op_flags & OPf_STACKED) {
6087 kid = cLISTOPo->op_first->op_sibling;
6088 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6091 kid->op_next = (OP*)gwop;
6092 o->op_flags &= ~OPf_STACKED;
6094 kid = cLISTOPo->op_first->op_sibling;
6095 if (type == OP_MAPWHILE)
6102 kid = cLISTOPo->op_first->op_sibling;
6103 if (kid->op_type != OP_NULL)
6104 Perl_croak(aTHX_ "panic: ck_grep");
6105 kid = kUNOP->op_first;
6107 gwop->op_type = type;
6108 gwop->op_ppaddr = PL_ppaddr[type];
6109 gwop->op_first = listkids(o);
6110 gwop->op_flags |= OPf_KIDS;
6111 gwop->op_private = 1;
6112 gwop->op_other = LINKLIST(kid);
6113 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6114 kid->op_next = (OP*)gwop;
6116 kid = cLISTOPo->op_first->op_sibling;
6117 if (!kid || !kid->op_sibling)
6118 return too_few_arguments(o,OP_DESC(o));
6119 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6120 mod(kid, OP_GREPSTART);
6126 Perl_ck_index(pTHX_ OP *o)
6128 if (o->op_flags & OPf_KIDS) {
6129 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6131 kid = kid->op_sibling; /* get past "big" */
6132 if (kid && kid->op_type == OP_CONST)
6133 fbm_compile(((SVOP*)kid)->op_sv, 0);
6139 Perl_ck_lengthconst(pTHX_ OP *o)
6141 /* XXX length optimization goes here */
6146 Perl_ck_lfun(pTHX_ OP *o)
6148 OPCODE type = o->op_type;
6149 return modkids(ck_fun(o), type);
6153 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6155 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6156 switch (cUNOPo->op_first->op_type) {
6158 /* This is needed for
6159 if (defined %stash::)
6160 to work. Do not break Tk.
6162 break; /* Globals via GV can be undef */
6164 case OP_AASSIGN: /* Is this a good idea? */
6165 Perl_warner(aTHX_ WARN_DEPRECATED,
6166 "defined(@array) is deprecated");
6167 Perl_warner(aTHX_ WARN_DEPRECATED,
6168 "\t(Maybe you should just omit the defined()?)\n");
6171 /* This is needed for
6172 if (defined %stash::)
6173 to work. Do not break Tk.
6175 break; /* Globals via GV can be undef */
6177 Perl_warner(aTHX_ WARN_DEPRECATED,
6178 "defined(%%hash) is deprecated");
6179 Perl_warner(aTHX_ WARN_DEPRECATED,
6180 "\t(Maybe you should just omit the defined()?)\n");
6191 Perl_ck_rfun(pTHX_ OP *o)
6193 OPCODE type = o->op_type;
6194 return refkids(ck_fun(o), type);
6198 Perl_ck_listiob(pTHX_ OP *o)
6202 kid = cLISTOPo->op_first;
6205 kid = cLISTOPo->op_first;
6207 if (kid->op_type == OP_PUSHMARK)
6208 kid = kid->op_sibling;
6209 if (kid && o->op_flags & OPf_STACKED)
6210 kid = kid->op_sibling;
6211 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6212 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6213 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6214 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6215 cLISTOPo->op_first->op_sibling = kid;
6216 cLISTOPo->op_last = kid;
6217 kid = kid->op_sibling;
6222 append_elem(o->op_type, o, newDEFSVOP());
6228 Perl_ck_sassign(pTHX_ OP *o)
6230 OP *kid = cLISTOPo->op_first;
6231 /* has a disposable target? */
6232 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6233 && !(kid->op_flags & OPf_STACKED)
6234 /* Cannot steal the second time! */
6235 && !(kid->op_private & OPpTARGET_MY))
6237 OP *kkid = kid->op_sibling;
6239 /* Can just relocate the target. */
6240 if (kkid && kkid->op_type == OP_PADSV
6241 && !(kkid->op_private & OPpLVAL_INTRO))
6243 kid->op_targ = kkid->op_targ;
6245 /* Now we do not need PADSV and SASSIGN. */
6246 kid->op_sibling = o->op_sibling; /* NULL */
6247 cLISTOPo->op_first = NULL;
6250 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6258 Perl_ck_match(pTHX_ OP *o)
6260 o->op_private |= OPpRUNTIME;
6265 Perl_ck_method(pTHX_ OP *o)
6267 OP *kid = cUNOPo->op_first;
6268 if (kid->op_type == OP_CONST) {
6269 SV* sv = kSVOP->op_sv;
6270 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6272 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6273 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6276 kSVOP->op_sv = Nullsv;
6278 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6287 Perl_ck_null(pTHX_ OP *o)
6293 Perl_ck_open(pTHX_ OP *o)
6295 HV *table = GvHV(PL_hintgv);
6299 svp = hv_fetch(table, "open_IN", 7, FALSE);
6301 mode = mode_from_discipline(*svp);
6302 if (mode & O_BINARY)
6303 o->op_private |= OPpOPEN_IN_RAW;
6304 else if (mode & O_TEXT)
6305 o->op_private |= OPpOPEN_IN_CRLF;
6308 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6310 mode = mode_from_discipline(*svp);
6311 if (mode & O_BINARY)
6312 o->op_private |= OPpOPEN_OUT_RAW;
6313 else if (mode & O_TEXT)
6314 o->op_private |= OPpOPEN_OUT_CRLF;
6317 if (o->op_type == OP_BACKTICK)
6323 Perl_ck_repeat(pTHX_ OP *o)
6325 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6326 o->op_private |= OPpREPEAT_DOLIST;
6327 cBINOPo->op_first = force_list(cBINOPo->op_first);
6335 Perl_ck_require(pTHX_ OP *o)
6339 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6340 SVOP *kid = (SVOP*)cUNOPo->op_first;
6342 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6344 for (s = SvPVX(kid->op_sv); *s; s++) {
6345 if (*s == ':' && s[1] == ':') {
6347 Move(s+2, s+1, strlen(s+2)+1, char);
6348 --SvCUR(kid->op_sv);
6351 if (SvREADONLY(kid->op_sv)) {
6352 SvREADONLY_off(kid->op_sv);
6353 sv_catpvn(kid->op_sv, ".pm", 3);
6354 SvREADONLY_on(kid->op_sv);
6357 sv_catpvn(kid->op_sv, ".pm", 3);
6361 /* handle override, if any */
6362 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6363 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6364 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6366 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6367 OP *kid = cUNOPo->op_first;
6368 cUNOPo->op_first = 0;
6370 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6371 append_elem(OP_LIST, kid,
6372 scalar(newUNOP(OP_RV2CV, 0,
6381 Perl_ck_return(pTHX_ OP *o)
6384 if (CvLVALUE(PL_compcv)) {
6385 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6386 mod(kid, OP_LEAVESUBLV);
6393 Perl_ck_retarget(pTHX_ OP *o)
6395 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6402 Perl_ck_select(pTHX_ OP *o)
6405 if (o->op_flags & OPf_KIDS) {
6406 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6407 if (kid && kid->op_sibling) {
6408 o->op_type = OP_SSELECT;
6409 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6411 return fold_constants(o);
6415 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6416 if (kid && kid->op_type == OP_RV2GV)
6417 kid->op_private &= ~HINT_STRICT_REFS;
6422 Perl_ck_shift(pTHX_ OP *o)
6424 I32 type = o->op_type;
6426 if (!(o->op_flags & OPf_KIDS)) {
6430 #ifdef USE_5005THREADS
6431 if (!CvUNIQUE(PL_compcv)) {
6432 argop = newOP(OP_PADAV, OPf_REF);
6433 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6436 argop = newUNOP(OP_RV2AV, 0,
6437 scalar(newGVOP(OP_GV, 0,
6438 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6441 argop = newUNOP(OP_RV2AV, 0,
6442 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6443 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6444 #endif /* USE_5005THREADS */
6445 return newUNOP(type, 0, scalar(argop));
6447 return scalar(modkids(ck_fun(o), type));
6451 Perl_ck_sort(pTHX_ OP *o)
6455 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6457 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6458 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6460 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6462 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6464 if (kid->op_type == OP_SCOPE) {
6468 else if (kid->op_type == OP_LEAVE) {
6469 if (o->op_type == OP_SORT) {
6470 op_null(kid); /* wipe out leave */
6473 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6474 if (k->op_next == kid)
6476 /* don't descend into loops */
6477 else if (k->op_type == OP_ENTERLOOP
6478 || k->op_type == OP_ENTERITER)
6480 k = cLOOPx(k)->op_lastop;
6485 kid->op_next = 0; /* just disconnect the leave */
6486 k = kLISTOP->op_first;
6491 if (o->op_type == OP_SORT) {
6492 /* provide scalar context for comparison function/block */
6498 o->op_flags |= OPf_SPECIAL;
6500 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6503 firstkid = firstkid->op_sibling;
6506 /* provide list context for arguments */
6507 if (o->op_type == OP_SORT)
6514 S_simplify_sort(pTHX_ OP *o)
6516 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6520 if (!(o->op_flags & OPf_STACKED))
6522 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6523 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6524 kid = kUNOP->op_first; /* get past null */
6525 if (kid->op_type != OP_SCOPE)
6527 kid = kLISTOP->op_last; /* get past scope */
6528 switch(kid->op_type) {
6536 k = kid; /* remember this node*/
6537 if (kBINOP->op_first->op_type != OP_RV2SV)
6539 kid = kBINOP->op_first; /* get past cmp */
6540 if (kUNOP->op_first->op_type != OP_GV)
6542 kid = kUNOP->op_first; /* get past rv2sv */
6544 if (GvSTASH(gv) != PL_curstash)
6546 if (strEQ(GvNAME(gv), "a"))
6548 else if (strEQ(GvNAME(gv), "b"))
6552 kid = k; /* back to cmp */
6553 if (kBINOP->op_last->op_type != OP_RV2SV)
6555 kid = kBINOP->op_last; /* down to 2nd arg */
6556 if (kUNOP->op_first->op_type != OP_GV)
6558 kid = kUNOP->op_first; /* get past rv2sv */
6560 if (GvSTASH(gv) != PL_curstash
6562 ? strNE(GvNAME(gv), "a")
6563 : strNE(GvNAME(gv), "b")))
6565 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6567 o->op_private |= OPpSORT_REVERSE;
6568 if (k->op_type == OP_NCMP)
6569 o->op_private |= OPpSORT_NUMERIC;
6570 if (k->op_type == OP_I_NCMP)
6571 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6572 kid = cLISTOPo->op_first->op_sibling;
6573 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6574 op_free(kid); /* then delete it */
6578 Perl_ck_split(pTHX_ OP *o)
6582 if (o->op_flags & OPf_STACKED)
6583 return no_fh_allowed(o);
6585 kid = cLISTOPo->op_first;
6586 if (kid->op_type != OP_NULL)
6587 Perl_croak(aTHX_ "panic: ck_split");
6588 kid = kid->op_sibling;
6589 op_free(cLISTOPo->op_first);
6590 cLISTOPo->op_first = kid;
6592 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6593 cLISTOPo->op_last = kid; /* There was only one element previously */
6596 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6597 OP *sibl = kid->op_sibling;
6598 kid->op_sibling = 0;
6599 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6600 if (cLISTOPo->op_first == cLISTOPo->op_last)
6601 cLISTOPo->op_last = kid;
6602 cLISTOPo->op_first = kid;
6603 kid->op_sibling = sibl;
6606 kid->op_type = OP_PUSHRE;
6607 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6610 if (!kid->op_sibling)
6611 append_elem(OP_SPLIT, o, newDEFSVOP());
6613 kid = kid->op_sibling;
6616 if (!kid->op_sibling)
6617 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6619 kid = kid->op_sibling;
6622 if (kid->op_sibling)
6623 return too_many_arguments(o,OP_DESC(o));
6629 Perl_ck_join(pTHX_ OP *o)
6631 if (ckWARN(WARN_SYNTAX)) {
6632 OP *kid = cLISTOPo->op_first->op_sibling;
6633 if (kid && kid->op_type == OP_MATCH) {
6634 char *pmstr = "STRING";
6635 if (PM_GETRE(kPMOP))
6636 pmstr = PM_GETRE(kPMOP)->precomp;
6637 Perl_warner(aTHX_ WARN_SYNTAX,
6638 "/%s/ should probably be written as \"%s\"",
6646 Perl_ck_subr(pTHX_ OP *o)
6648 OP *prev = ((cUNOPo->op_first->op_sibling)
6649 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6650 OP *o2 = prev->op_sibling;
6657 I32 contextclass = 0;
6661 o->op_private |= OPpENTERSUB_HASTARG;
6662 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6663 if (cvop->op_type == OP_RV2CV) {
6665 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6666 op_null(cvop); /* disable rv2cv */
6667 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6668 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6669 GV *gv = cGVOPx_gv(tmpop);
6672 tmpop->op_private |= OPpEARLY_CV;
6673 else if (SvPOK(cv)) {
6674 namegv = CvANON(cv) ? gv : CvGV(cv);
6675 proto = SvPV((SV*)cv, n_a);
6679 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6680 if (o2->op_type == OP_CONST)
6681 o2->op_private &= ~OPpCONST_STRICT;
6682 else if (o2->op_type == OP_LIST) {
6683 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6684 if (o && o->op_type == OP_CONST)
6685 o->op_private &= ~OPpCONST_STRICT;
6688 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6689 if (PERLDB_SUB && PL_curstash != PL_debstash)
6690 o->op_private |= OPpENTERSUB_DB;
6691 while (o2 != cvop) {
6695 return too_many_arguments(o, gv_ename(namegv));
6713 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6715 arg == 1 ? "block or sub {}" : "sub {}",
6716 gv_ename(namegv), o2);
6719 /* '*' allows any scalar type, including bareword */
6722 if (o2->op_type == OP_RV2GV)
6723 goto wrapref; /* autoconvert GLOB -> GLOBref */
6724 else if (o2->op_type == OP_CONST)
6725 o2->op_private &= ~OPpCONST_STRICT;
6726 else if (o2->op_type == OP_ENTERSUB) {
6727 /* accidental subroutine, revert to bareword */
6728 OP *gvop = ((UNOP*)o2)->op_first;
6729 if (gvop && gvop->op_type == OP_NULL) {
6730 gvop = ((UNOP*)gvop)->op_first;
6732 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6735 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6736 (gvop = ((UNOP*)gvop)->op_first) &&
6737 gvop->op_type == OP_GV)
6739 GV *gv = cGVOPx_gv(gvop);
6740 OP *sibling = o2->op_sibling;
6741 SV *n = newSVpvn("",0);
6743 gv_fullname3(n, gv, "");
6744 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6745 sv_chop(n, SvPVX(n)+6);
6746 o2 = newSVOP(OP_CONST, 0, n);
6747 prev->op_sibling = o2;
6748 o2->op_sibling = sibling;
6764 if (contextclass++ == 0) {
6765 e = strchr(proto, ']');
6766 if (!e || e == proto)
6780 if (o2->op_type == OP_RV2GV)
6783 bad_type(arg, "symbol", gv_ename(namegv), o2);
6786 if (o2->op_type == OP_ENTERSUB)
6789 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6792 if (o2->op_type == OP_RV2SV ||
6793 o2->op_type == OP_PADSV ||
6794 o2->op_type == OP_HELEM ||
6795 o2->op_type == OP_AELEM ||
6796 o2->op_type == OP_THREADSV)
6799 bad_type(arg, "scalar", gv_ename(namegv), o2);
6802 if (o2->op_type == OP_RV2AV ||
6803 o2->op_type == OP_PADAV)
6806 bad_type(arg, "array", gv_ename(namegv), o2);
6809 if (o2->op_type == OP_RV2HV ||
6810 o2->op_type == OP_PADHV)
6813 bad_type(arg, "hash", gv_ename(namegv), o2);
6818 OP* sib = kid->op_sibling;
6819 kid->op_sibling = 0;
6820 o2 = newUNOP(OP_REFGEN, 0, kid);
6821 o2->op_sibling = sib;
6822 prev->op_sibling = o2;
6824 if (contextclass && e) {
6839 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6840 gv_ename(namegv), SvPV((SV*)cv, n_a));
6845 mod(o2, OP_ENTERSUB);
6847 o2 = o2->op_sibling;
6849 if (proto && !optional &&
6850 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6851 return too_few_arguments(o, gv_ename(namegv));
6856 Perl_ck_svconst(pTHX_ OP *o)
6858 SvREADONLY_on(cSVOPo->op_sv);
6863 Perl_ck_trunc(pTHX_ OP *o)
6865 if (o->op_flags & OPf_KIDS) {
6866 SVOP *kid = (SVOP*)cUNOPo->op_first;
6868 if (kid->op_type == OP_NULL)
6869 kid = (SVOP*)kid->op_sibling;
6870 if (kid && kid->op_type == OP_CONST &&
6871 (kid->op_private & OPpCONST_BARE))
6873 o->op_flags |= OPf_SPECIAL;
6874 kid->op_private &= ~OPpCONST_STRICT;
6881 Perl_ck_substr(pTHX_ OP *o)
6884 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6885 OP *kid = cLISTOPo->op_first;
6887 if (kid->op_type == OP_NULL)
6888 kid = kid->op_sibling;
6890 kid->op_flags |= OPf_MOD;
6896 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6899 Perl_peep(pTHX_ register OP *o)
6901 register OP* oldop = 0;
6904 if (!o || o->op_seq)
6908 SAVEVPTR(PL_curcop);
6909 for (; o; o = o->op_next) {
6915 switch (o->op_type) {
6919 PL_curcop = ((COP*)o); /* for warnings */
6920 o->op_seq = PL_op_seqmax++;
6924 if (cSVOPo->op_private & OPpCONST_STRICT)
6925 no_bareword_allowed(o);
6927 /* Relocate sv to the pad for thread safety.
6928 * Despite being a "constant", the SV is written to,
6929 * for reference counts, sv_upgrade() etc. */
6931 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6932 if (SvPADTMP(cSVOPo->op_sv)) {
6933 /* If op_sv is already a PADTMP then it is being used by
6934 * some pad, so make a copy. */
6935 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6936 SvREADONLY_on(PL_curpad[ix]);
6937 SvREFCNT_dec(cSVOPo->op_sv);
6940 SvREFCNT_dec(PL_curpad[ix]);
6941 SvPADTMP_on(cSVOPo->op_sv);
6942 PL_curpad[ix] = cSVOPo->op_sv;
6943 /* XXX I don't know how this isn't readonly already. */
6944 SvREADONLY_on(PL_curpad[ix]);
6946 cSVOPo->op_sv = Nullsv;
6950 o->op_seq = PL_op_seqmax++;
6954 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6955 if (o->op_next->op_private & OPpTARGET_MY) {
6956 if (o->op_flags & OPf_STACKED) /* chained concats */
6957 goto ignore_optimization;
6959 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6960 o->op_targ = o->op_next->op_targ;
6961 o->op_next->op_targ = 0;
6962 o->op_private |= OPpTARGET_MY;
6965 op_null(o->op_next);
6967 ignore_optimization:
6968 o->op_seq = PL_op_seqmax++;
6971 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6972 o->op_seq = PL_op_seqmax++;
6973 break; /* Scalar stub must produce undef. List stub is noop */
6977 if (o->op_targ == OP_NEXTSTATE
6978 || o->op_targ == OP_DBSTATE
6979 || o->op_targ == OP_SETSTATE)
6981 PL_curcop = ((COP*)o);
6983 /* XXX: We avoid setting op_seq here to prevent later calls
6984 to peep() from mistakenly concluding that optimisation
6985 has already occurred. This doesn't fix the real problem,
6986 though (See 20010220.007). AMS 20010719 */
6987 if (oldop && o->op_next) {
6988 oldop->op_next = o->op_next;
6996 if (oldop && o->op_next) {
6997 oldop->op_next = o->op_next;
7000 o->op_seq = PL_op_seqmax++;
7004 if (o->op_next->op_type == OP_RV2SV) {
7005 if (!(o->op_next->op_private & OPpDEREF)) {
7006 op_null(o->op_next);
7007 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7009 o->op_next = o->op_next->op_next;
7010 o->op_type = OP_GVSV;
7011 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7014 else if (o->op_next->op_type == OP_RV2AV) {
7015 OP* pop = o->op_next->op_next;
7017 if (pop->op_type == OP_CONST &&
7018 (PL_op = pop->op_next) &&
7019 pop->op_next->op_type == OP_AELEM &&
7020 !(pop->op_next->op_private &
7021 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7022 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7027 op_null(o->op_next);
7028 op_null(pop->op_next);
7030 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7031 o->op_next = pop->op_next->op_next;
7032 o->op_type = OP_AELEMFAST;
7033 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7034 o->op_private = (U8)i;
7039 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7041 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7042 /* XXX could check prototype here instead of just carping */
7043 SV *sv = sv_newmortal();
7044 gv_efullname3(sv, gv, Nullch);
7045 Perl_warner(aTHX_ WARN_PROTOTYPE,
7046 "%s() called too early to check prototype",
7050 else if (o->op_next->op_type == OP_READLINE
7051 && o->op_next->op_next->op_type == OP_CONCAT
7052 && (o->op_next->op_next->op_flags & OPf_STACKED))
7054 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7055 o->op_type = OP_RCATLINE;
7056 o->op_flags |= OPf_STACKED;
7057 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7058 op_null(o->op_next->op_next);
7059 op_null(o->op_next);
7062 o->op_seq = PL_op_seqmax++;
7073 o->op_seq = PL_op_seqmax++;
7074 while (cLOGOP->op_other->op_type == OP_NULL)
7075 cLOGOP->op_other = cLOGOP->op_other->op_next;
7076 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7081 o->op_seq = PL_op_seqmax++;
7082 while (cLOOP->op_redoop->op_type == OP_NULL)
7083 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7084 peep(cLOOP->op_redoop);
7085 while (cLOOP->op_nextop->op_type == OP_NULL)
7086 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7087 peep(cLOOP->op_nextop);
7088 while (cLOOP->op_lastop->op_type == OP_NULL)
7089 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7090 peep(cLOOP->op_lastop);
7096 o->op_seq = PL_op_seqmax++;
7097 while (cPMOP->op_pmreplstart &&
7098 cPMOP->op_pmreplstart->op_type == OP_NULL)
7099 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7100 peep(cPMOP->op_pmreplstart);
7104 o->op_seq = PL_op_seqmax++;
7105 if (ckWARN(WARN_SYNTAX) && o->op_next
7106 && o->op_next->op_type == OP_NEXTSTATE) {
7107 if (o->op_next->op_sibling &&
7108 o->op_next->op_sibling->op_type != OP_EXIT &&
7109 o->op_next->op_sibling->op_type != OP_WARN &&
7110 o->op_next->op_sibling->op_type != OP_DIE) {
7111 line_t oldline = CopLINE(PL_curcop);
7113 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7114 Perl_warner(aTHX_ WARN_EXEC,
7115 "Statement unlikely to be reached");
7116 Perl_warner(aTHX_ WARN_EXEC,
7117 "\t(Maybe you meant system() when you said exec()?)\n");
7118 CopLINE_set(PL_curcop, oldline);
7127 SV **svp, **indsvp, *sv;
7132 o->op_seq = PL_op_seqmax++;
7134 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7137 /* Make the CONST have a shared SV */
7138 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7139 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7140 key = SvPV(sv, keylen);
7141 lexname = newSVpvn_share(key,
7142 SvUTF8(sv) ? -(I32)keylen : keylen,
7148 if ((o->op_private & (OPpLVAL_INTRO)))
7151 rop = (UNOP*)((BINOP*)o)->op_first;
7152 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7154 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7155 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7157 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7158 if (!fields || !GvHV(*fields))
7160 key = SvPV(*svp, keylen);
7161 indsvp = hv_fetch(GvHV(*fields), key,
7162 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7164 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7165 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7167 ind = SvIV(*indsvp);
7169 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7170 rop->op_type = OP_RV2AV;
7171 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7172 o->op_type = OP_AELEM;
7173 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7175 if (SvREADONLY(*svp))
7177 SvFLAGS(sv) |= (SvFLAGS(*svp)
7178 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7188 SV **svp, **indsvp, *sv;
7192 SVOP *first_key_op, *key_op;
7194 o->op_seq = PL_op_seqmax++;
7195 if ((o->op_private & (OPpLVAL_INTRO))
7196 /* I bet there's always a pushmark... */
7197 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7198 /* hmmm, no optimization if list contains only one key. */
7200 rop = (UNOP*)((LISTOP*)o)->op_last;
7201 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7203 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7204 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7206 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7207 if (!fields || !GvHV(*fields))
7209 /* Again guessing that the pushmark can be jumped over.... */
7210 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7211 ->op_first->op_sibling;
7212 /* Check that the key list contains only constants. */
7213 for (key_op = first_key_op; key_op;
7214 key_op = (SVOP*)key_op->op_sibling)
7215 if (key_op->op_type != OP_CONST)
7219 rop->op_type = OP_RV2AV;
7220 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7221 o->op_type = OP_ASLICE;
7222 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7223 for (key_op = first_key_op; key_op;
7224 key_op = (SVOP*)key_op->op_sibling) {
7225 svp = cSVOPx_svp(key_op);
7226 key = SvPV(*svp, keylen);
7227 indsvp = hv_fetch(GvHV(*fields), key,
7228 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7230 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7231 "in variable %s of type %s",
7232 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7234 ind = SvIV(*indsvp);
7236 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7238 if (SvREADONLY(*svp))
7240 SvFLAGS(sv) |= (SvFLAGS(*svp)
7241 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7249 o->op_seq = PL_op_seqmax++;
7259 char* Perl_custom_op_name(pTHX_ OP* o)
7261 IV index = PTR2IV(o->op_ppaddr);
7265 if (!PL_custom_op_names) /* This probably shouldn't happen */
7266 return PL_op_name[OP_CUSTOM];
7268 keysv = sv_2mortal(newSViv(index));
7270 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7272 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7274 return SvPV_nolen(HeVAL(he));
7277 char* Perl_custom_op_desc(pTHX_ OP* o)
7279 IV index = PTR2IV(o->op_ppaddr);
7283 if (!PL_custom_op_descs)
7284 return PL_op_desc[OP_CUSTOM];
7286 keysv = sv_2mortal(newSViv(index));
7288 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7290 return PL_op_desc[OP_CUSTOM];
7292 return SvPV_nolen(HeVAL(he));
7298 /* Efficient sub that returns a constant scalar value. */
7300 const_sv_xsub(pTHX_ CV* cv)
7305 Perl_croak(aTHX_ "usage: %s::%s()",
7306 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7310 ST(0) = (SV*)XSANY.any_ptr;