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_flags(tmpbuf, 0x7fffffff,
2870 UNICODE_ALLOW_SUPER);
2871 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2872 t = (U8*)SvPVX(transv);
2873 tlen = SvCUR(transv);
2877 else if (!rlen && !del) {
2878 r = t; rlen = tlen; rend = tend;
2881 if ((!rlen && !del) || t == r ||
2882 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2884 o->op_private |= OPpTRANS_IDENTICAL;
2888 while (t < tend || tfirst <= tlast) {
2889 /* see if we need more "t" chars */
2890 if (tfirst > tlast) {
2891 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2893 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2895 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2902 /* now see if we need more "r" chars */
2903 if (rfirst > rlast) {
2905 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2907 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2909 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2918 rfirst = rlast = 0xffffffff;
2922 /* now see which range will peter our first, if either. */
2923 tdiff = tlast - tfirst;
2924 rdiff = rlast - rfirst;
2931 if (rfirst == 0xffffffff) {
2932 diff = tdiff; /* oops, pretend rdiff is infinite */
2934 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2935 (long)tfirst, (long)tlast);
2937 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2941 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2942 (long)tfirst, (long)(tfirst + diff),
2945 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2946 (long)tfirst, (long)rfirst);
2948 if (rfirst + diff > max)
2949 max = rfirst + diff;
2951 grows = (tfirst < rfirst &&
2952 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2964 else if (max > 0xff)
2969 Safefree(cPVOPo->op_pv);
2970 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2971 SvREFCNT_dec(listsv);
2973 SvREFCNT_dec(transv);
2975 if (!del && havefinal && rlen)
2976 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2977 newSVuv((UV)final), 0);
2980 o->op_private |= OPpTRANS_GROWS;
2992 tbl = (short*)cPVOPo->op_pv;
2994 Zero(tbl, 256, short);
2995 for (i = 0; i < tlen; i++)
2997 for (i = 0, j = 0; i < 256; i++) {
3008 if (i < 128 && r[j] >= 128)
3018 o->op_private |= OPpTRANS_IDENTICAL;
3023 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3024 tbl[0x100] = rlen - j;
3025 for (i=0; i < rlen - j; i++)
3026 tbl[0x101+i] = r[j+i];
3030 if (!rlen && !del) {
3033 o->op_private |= OPpTRANS_IDENTICAL;
3035 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3036 o->op_private |= OPpTRANS_IDENTICAL;
3038 for (i = 0; i < 256; i++)
3040 for (i = 0, j = 0; i < tlen; i++,j++) {
3043 if (tbl[t[i]] == -1)
3049 if (tbl[t[i]] == -1) {
3050 if (t[i] < 128 && r[j] >= 128)
3057 o->op_private |= OPpTRANS_GROWS;
3065 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3069 NewOp(1101, pmop, 1, PMOP);
3070 pmop->op_type = type;
3071 pmop->op_ppaddr = PL_ppaddr[type];
3072 pmop->op_flags = flags;
3073 pmop->op_private = 0 | (flags >> 8);
3075 if (PL_hints & HINT_RE_TAINT)
3076 pmop->op_pmpermflags |= PMf_RETAINT;
3077 if (PL_hints & HINT_LOCALE)
3078 pmop->op_pmpermflags |= PMf_LOCALE;
3079 pmop->op_pmflags = pmop->op_pmpermflags;
3084 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3085 repointer = av_pop((AV*)PL_regex_pad[0]);
3086 pmop->op_pmoffset = SvIV(repointer);
3087 SvREPADTMP_off(repointer);
3088 sv_setiv(repointer,0);
3090 repointer = newSViv(0);
3091 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3092 pmop->op_pmoffset = av_len(PL_regex_padav);
3093 PL_regex_pad = AvARRAY(PL_regex_padav);
3098 /* link into pm list */
3099 if (type != OP_TRANS && PL_curstash) {
3100 pmop->op_pmnext = HvPMROOT(PL_curstash);
3101 HvPMROOT(PL_curstash) = pmop;
3102 PmopSTASH_set(pmop,PL_curstash);
3109 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3113 I32 repl_has_vars = 0;
3115 if (o->op_type == OP_TRANS)
3116 return pmtrans(o, expr, repl);
3118 PL_hints |= HINT_BLOCK_SCOPE;
3121 if (expr->op_type == OP_CONST) {
3123 SV *pat = ((SVOP*)expr)->op_sv;
3124 char *p = SvPV(pat, plen);
3125 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3126 sv_setpvn(pat, "\\s+", 3);
3127 p = SvPV(pat, plen);
3128 pm->op_pmflags |= PMf_SKIPWHITE;
3130 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3131 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3132 pm->op_pmflags |= PMf_WHITE;
3136 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3137 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3139 : OP_REGCMAYBE),0,expr);
3141 NewOp(1101, rcop, 1, LOGOP);
3142 rcop->op_type = OP_REGCOMP;
3143 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3144 rcop->op_first = scalar(expr);
3145 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3146 ? (OPf_SPECIAL | OPf_KIDS)
3148 rcop->op_private = 1;
3151 /* establish postfix order */
3152 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3154 rcop->op_next = expr;
3155 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3158 rcop->op_next = LINKLIST(expr);
3159 expr->op_next = (OP*)rcop;
3162 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3167 if (pm->op_pmflags & PMf_EVAL) {
3169 if (CopLINE(PL_curcop) < PL_multi_end)
3170 CopLINE_set(PL_curcop, PL_multi_end);
3172 #ifdef USE_5005THREADS
3173 else if (repl->op_type == OP_THREADSV
3174 && strchr("&`'123456789+",
3175 PL_threadsv_names[repl->op_targ]))
3179 #endif /* USE_5005THREADS */
3180 else if (repl->op_type == OP_CONST)
3184 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3185 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3186 #ifdef USE_5005THREADS
3187 if (curop->op_type == OP_THREADSV) {
3189 if (strchr("&`'123456789+", curop->op_private))
3193 if (curop->op_type == OP_GV) {
3194 GV *gv = cGVOPx_gv(curop);
3196 if (strchr("&`'123456789+", *GvENAME(gv)))
3199 #endif /* USE_5005THREADS */
3200 else if (curop->op_type == OP_RV2CV)
3202 else if (curop->op_type == OP_RV2SV ||
3203 curop->op_type == OP_RV2AV ||
3204 curop->op_type == OP_RV2HV ||
3205 curop->op_type == OP_RV2GV) {
3206 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3209 else if (curop->op_type == OP_PADSV ||
3210 curop->op_type == OP_PADAV ||
3211 curop->op_type == OP_PADHV ||
3212 curop->op_type == OP_PADANY) {
3215 else if (curop->op_type == OP_PUSHRE)
3216 ; /* Okay here, dangerous in newASSIGNOP */
3226 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3227 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3228 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3229 prepend_elem(o->op_type, scalar(repl), o);
3232 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3233 pm->op_pmflags |= PMf_MAYBE_CONST;
3234 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3236 NewOp(1101, rcop, 1, LOGOP);
3237 rcop->op_type = OP_SUBSTCONT;
3238 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3239 rcop->op_first = scalar(repl);
3240 rcop->op_flags |= OPf_KIDS;
3241 rcop->op_private = 1;
3244 /* establish postfix order */
3245 rcop->op_next = LINKLIST(repl);
3246 repl->op_next = (OP*)rcop;
3248 pm->op_pmreplroot = scalar((OP*)rcop);
3249 pm->op_pmreplstart = LINKLIST(rcop);
3258 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3261 NewOp(1101, svop, 1, SVOP);
3262 svop->op_type = type;
3263 svop->op_ppaddr = PL_ppaddr[type];
3265 svop->op_next = (OP*)svop;
3266 svop->op_flags = flags;
3267 if (PL_opargs[type] & OA_RETSCALAR)
3269 if (PL_opargs[type] & OA_TARGET)
3270 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3271 return CHECKOP(type, svop);
3275 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3278 NewOp(1101, padop, 1, PADOP);
3279 padop->op_type = type;
3280 padop->op_ppaddr = PL_ppaddr[type];
3281 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3282 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3283 PL_curpad[padop->op_padix] = sv;
3285 padop->op_next = (OP*)padop;
3286 padop->op_flags = flags;
3287 if (PL_opargs[type] & OA_RETSCALAR)
3289 if (PL_opargs[type] & OA_TARGET)
3290 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3291 return CHECKOP(type, padop);
3295 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3299 return newPADOP(type, flags, SvREFCNT_inc(gv));
3301 return newSVOP(type, flags, SvREFCNT_inc(gv));
3306 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3309 NewOp(1101, pvop, 1, PVOP);
3310 pvop->op_type = type;
3311 pvop->op_ppaddr = PL_ppaddr[type];
3313 pvop->op_next = (OP*)pvop;
3314 pvop->op_flags = flags;
3315 if (PL_opargs[type] & OA_RETSCALAR)
3317 if (PL_opargs[type] & OA_TARGET)
3318 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3319 return CHECKOP(type, pvop);
3323 Perl_package(pTHX_ OP *o)
3327 save_hptr(&PL_curstash);
3328 save_item(PL_curstname);
3333 name = SvPV(sv, len);
3334 PL_curstash = gv_stashpvn(name,len,TRUE);
3335 sv_setpvn(PL_curstname, name, len);
3339 deprecate("\"package\" with no arguments");
3340 sv_setpv(PL_curstname,"<none>");
3341 PL_curstash = Nullhv;
3343 PL_hints |= HINT_BLOCK_SCOPE;
3344 PL_copline = NOLINE;
3349 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3354 char *packname = Nullch;
3358 if (id->op_type != OP_CONST)
3359 Perl_croak(aTHX_ "Module name must be constant");
3363 if (version != Nullop) {
3364 SV *vesv = ((SVOP*)version)->op_sv;
3366 if (arg == Nullop && !SvNIOKp(vesv)) {
3373 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3374 Perl_croak(aTHX_ "Version number must be constant number");
3376 /* Make copy of id so we don't free it twice */
3377 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3379 /* Fake up a method call to VERSION */
3380 meth = newSVpvn("VERSION",7);
3381 sv_upgrade(meth, SVt_PVIV);
3382 (void)SvIOK_on(meth);
3383 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3384 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3385 append_elem(OP_LIST,
3386 prepend_elem(OP_LIST, pack, list(version)),
3387 newSVOP(OP_METHOD_NAMED, 0, meth)));
3391 /* Fake up an import/unimport */
3392 if (arg && arg->op_type == OP_STUB)
3393 imop = arg; /* no import on explicit () */
3394 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3395 imop = Nullop; /* use 5.0; */
3400 /* Make copy of id so we don't free it twice */
3401 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3403 /* Fake up a method call to import/unimport */
3404 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3405 (void)SvUPGRADE(meth, SVt_PVIV);
3406 (void)SvIOK_on(meth);
3407 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3408 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3409 append_elem(OP_LIST,
3410 prepend_elem(OP_LIST, pack, list(arg)),
3411 newSVOP(OP_METHOD_NAMED, 0, meth)));
3414 if (ckWARN(WARN_MISC) &&
3415 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3416 SvPOK(packsv = ((SVOP*)id)->op_sv))
3418 /* BEGIN will free the ops, so we need to make a copy */
3419 packlen = SvCUR(packsv);
3420 packname = savepvn(SvPVX(packsv), packlen);
3423 /* Fake up the BEGIN {}, which does its thing immediately. */
3425 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3428 append_elem(OP_LINESEQ,
3429 append_elem(OP_LINESEQ,
3430 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3431 newSTATEOP(0, Nullch, veop)),
3432 newSTATEOP(0, Nullch, imop) ));
3435 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3436 Perl_warner(aTHX_ WARN_MISC,
3437 "Package `%s' not found "
3438 "(did you use the incorrect case?)", packname);
3443 PL_hints |= HINT_BLOCK_SCOPE;
3444 PL_copline = NOLINE;
3449 =for apidoc load_module
3451 Loads the module whose name is pointed to by the string part of name.
3452 Note that the actual module name, not its filename, should be given.
3453 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3454 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3455 (or 0 for no flags). ver, if specified, provides version semantics
3456 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3457 arguments can be used to specify arguments to the module's import()
3458 method, similar to C<use Foo::Bar VERSION LIST>.
3463 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3466 va_start(args, ver);
3467 vload_module(flags, name, ver, &args);
3471 #ifdef PERL_IMPLICIT_CONTEXT
3473 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3477 va_start(args, ver);
3478 vload_module(flags, name, ver, &args);
3484 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3486 OP *modname, *veop, *imop;
3488 modname = newSVOP(OP_CONST, 0, name);
3489 modname->op_private |= OPpCONST_BARE;
3491 veop = newSVOP(OP_CONST, 0, ver);
3495 if (flags & PERL_LOADMOD_NOIMPORT) {
3496 imop = sawparens(newNULLLIST());
3498 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3499 imop = va_arg(*args, OP*);
3504 sv = va_arg(*args, SV*);
3506 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3507 sv = va_arg(*args, SV*);
3511 line_t ocopline = PL_copline;
3512 int oexpect = PL_expect;
3514 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3515 veop, modname, imop);
3516 PL_expect = oexpect;
3517 PL_copline = ocopline;
3522 Perl_dofile(pTHX_ OP *term)
3527 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3528 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3529 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3531 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3532 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3533 append_elem(OP_LIST, term,
3534 scalar(newUNOP(OP_RV2CV, 0,
3539 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3545 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3547 return newBINOP(OP_LSLICE, flags,
3548 list(force_list(subscript)),
3549 list(force_list(listval)) );
3553 S_list_assignment(pTHX_ register OP *o)
3558 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3559 o = cUNOPo->op_first;
3561 if (o->op_type == OP_COND_EXPR) {
3562 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3563 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3568 yyerror("Assignment to both a list and a scalar");
3572 if (o->op_type == OP_LIST &&
3573 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3574 o->op_private & OPpLVAL_INTRO)
3577 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3578 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3579 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3582 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3585 if (o->op_type == OP_RV2SV)
3592 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3597 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3598 return newLOGOP(optype, 0,
3599 mod(scalar(left), optype),
3600 newUNOP(OP_SASSIGN, 0, scalar(right)));
3603 return newBINOP(optype, OPf_STACKED,
3604 mod(scalar(left), optype), scalar(right));
3608 if (list_assignment(left)) {
3612 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3613 left = mod(left, OP_AASSIGN);
3621 curop = list(force_list(left));
3622 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3623 o->op_private = 0 | (flags >> 8);
3624 for (curop = ((LISTOP*)curop)->op_first;
3625 curop; curop = curop->op_sibling)
3627 if (curop->op_type == OP_RV2HV &&
3628 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3629 o->op_private |= OPpASSIGN_HASH;
3633 if (!(left->op_private & OPpLVAL_INTRO)) {
3636 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3637 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3638 if (curop->op_type == OP_GV) {
3639 GV *gv = cGVOPx_gv(curop);
3640 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3642 SvCUR(gv) = PL_generation;
3644 else if (curop->op_type == OP_PADSV ||
3645 curop->op_type == OP_PADAV ||
3646 curop->op_type == OP_PADHV ||
3647 curop->op_type == OP_PADANY) {
3648 SV **svp = AvARRAY(PL_comppad_name);
3649 SV *sv = svp[curop->op_targ];
3650 if (SvCUR(sv) == PL_generation)
3652 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3654 else if (curop->op_type == OP_RV2CV)
3656 else if (curop->op_type == OP_RV2SV ||
3657 curop->op_type == OP_RV2AV ||
3658 curop->op_type == OP_RV2HV ||
3659 curop->op_type == OP_RV2GV) {
3660 if (lastop->op_type != OP_GV) /* funny deref? */
3663 else if (curop->op_type == OP_PUSHRE) {
3664 if (((PMOP*)curop)->op_pmreplroot) {
3666 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3668 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3670 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3672 SvCUR(gv) = PL_generation;
3681 o->op_private |= OPpASSIGN_COMMON;
3683 if (right && right->op_type == OP_SPLIT) {
3685 if ((tmpop = ((LISTOP*)right)->op_first) &&
3686 tmpop->op_type == OP_PUSHRE)
3688 PMOP *pm = (PMOP*)tmpop;
3689 if (left->op_type == OP_RV2AV &&
3690 !(left->op_private & OPpLVAL_INTRO) &&
3691 !(o->op_private & OPpASSIGN_COMMON) )
3693 tmpop = ((UNOP*)left)->op_first;
3694 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3696 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3697 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3699 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3700 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3702 pm->op_pmflags |= PMf_ONCE;
3703 tmpop = cUNOPo->op_first; /* to list (nulled) */
3704 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3705 tmpop->op_sibling = Nullop; /* don't free split */
3706 right->op_next = tmpop->op_next; /* fix starting loc */
3707 op_free(o); /* blow off assign */
3708 right->op_flags &= ~OPf_WANT;
3709 /* "I don't know and I don't care." */
3714 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3715 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3717 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3719 sv_setiv(sv, PL_modcount+1);
3727 right = newOP(OP_UNDEF, 0);
3728 if (right->op_type == OP_READLINE) {
3729 right->op_flags |= OPf_STACKED;
3730 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3733 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3734 o = newBINOP(OP_SASSIGN, flags,
3735 scalar(right), mod(scalar(left), OP_SASSIGN) );
3747 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3749 U32 seq = intro_my();
3752 NewOp(1101, cop, 1, COP);
3753 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3754 cop->op_type = OP_DBSTATE;
3755 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3758 cop->op_type = OP_NEXTSTATE;
3759 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3761 cop->op_flags = flags;
3762 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3764 cop->op_private |= NATIVE_HINTS;
3766 PL_compiling.op_private = cop->op_private;
3767 cop->op_next = (OP*)cop;
3770 cop->cop_label = label;
3771 PL_hints |= HINT_BLOCK_SCOPE;
3774 cop->cop_arybase = PL_curcop->cop_arybase;
3775 if (specialWARN(PL_curcop->cop_warnings))
3776 cop->cop_warnings = PL_curcop->cop_warnings ;
3778 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3779 if (specialCopIO(PL_curcop->cop_io))
3780 cop->cop_io = PL_curcop->cop_io;
3782 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3785 if (PL_copline == NOLINE)
3786 CopLINE_set(cop, CopLINE(PL_curcop));
3788 CopLINE_set(cop, PL_copline);
3789 PL_copline = NOLINE;
3792 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3794 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3796 CopSTASH_set(cop, PL_curstash);
3798 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3799 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3800 if (svp && *svp != &PL_sv_undef ) {
3801 (void)SvIOK_on(*svp);
3802 SvIVX(*svp) = PTR2IV(cop);
3806 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3809 /* "Introduce" my variables to visible status. */
3817 if (! PL_min_intro_pending)
3818 return PL_cop_seqmax;
3820 svp = AvARRAY(PL_comppad_name);
3821 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3822 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3823 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3824 SvNVX(sv) = (NV)PL_cop_seqmax;
3827 PL_min_intro_pending = 0;
3828 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3829 return PL_cop_seqmax++;
3833 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3835 return new_logop(type, flags, &first, &other);
3839 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3843 OP *first = *firstp;
3844 OP *other = *otherp;
3846 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3847 return newBINOP(type, flags, scalar(first), scalar(other));
3849 scalarboolean(first);
3850 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3851 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3852 if (type == OP_AND || type == OP_OR) {
3858 first = *firstp = cUNOPo->op_first;
3860 first->op_next = o->op_next;
3861 cUNOPo->op_first = Nullop;
3865 if (first->op_type == OP_CONST) {
3866 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3867 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3868 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3879 else if (first->op_type == OP_WANTARRAY) {
3885 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3886 OP *k1 = ((UNOP*)first)->op_first;
3887 OP *k2 = k1->op_sibling;
3889 switch (first->op_type)
3892 if (k2 && k2->op_type == OP_READLINE
3893 && (k2->op_flags & OPf_STACKED)
3894 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3896 warnop = k2->op_type;
3901 if (k1->op_type == OP_READDIR
3902 || k1->op_type == OP_GLOB
3903 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3904 || k1->op_type == OP_EACH)
3906 warnop = ((k1->op_type == OP_NULL)
3907 ? k1->op_targ : k1->op_type);
3912 line_t oldline = CopLINE(PL_curcop);
3913 CopLINE_set(PL_curcop, PL_copline);
3914 Perl_warner(aTHX_ WARN_MISC,
3915 "Value of %s%s can be \"0\"; test with defined()",
3917 ((warnop == OP_READLINE || warnop == OP_GLOB)
3918 ? " construct" : "() operator"));
3919 CopLINE_set(PL_curcop, oldline);
3926 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3927 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3929 NewOp(1101, logop, 1, LOGOP);
3931 logop->op_type = type;
3932 logop->op_ppaddr = PL_ppaddr[type];
3933 logop->op_first = first;
3934 logop->op_flags = flags | OPf_KIDS;
3935 logop->op_other = LINKLIST(other);
3936 logop->op_private = 1 | (flags >> 8);
3938 /* establish postfix order */
3939 logop->op_next = LINKLIST(first);
3940 first->op_next = (OP*)logop;
3941 first->op_sibling = other;
3943 o = newUNOP(OP_NULL, 0, (OP*)logop);
3950 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3957 return newLOGOP(OP_AND, 0, first, trueop);
3959 return newLOGOP(OP_OR, 0, first, falseop);
3961 scalarboolean(first);
3962 if (first->op_type == OP_CONST) {
3963 if (SvTRUE(((SVOP*)first)->op_sv)) {
3974 else if (first->op_type == OP_WANTARRAY) {
3978 NewOp(1101, logop, 1, LOGOP);
3979 logop->op_type = OP_COND_EXPR;
3980 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3981 logop->op_first = first;
3982 logop->op_flags = flags | OPf_KIDS;
3983 logop->op_private = 1 | (flags >> 8);
3984 logop->op_other = LINKLIST(trueop);
3985 logop->op_next = LINKLIST(falseop);
3988 /* establish postfix order */
3989 start = LINKLIST(first);
3990 first->op_next = (OP*)logop;
3992 first->op_sibling = trueop;
3993 trueop->op_sibling = falseop;
3994 o = newUNOP(OP_NULL, 0, (OP*)logop);
3996 trueop->op_next = falseop->op_next = o;
4003 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4011 NewOp(1101, range, 1, LOGOP);
4013 range->op_type = OP_RANGE;
4014 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4015 range->op_first = left;
4016 range->op_flags = OPf_KIDS;
4017 leftstart = LINKLIST(left);
4018 range->op_other = LINKLIST(right);
4019 range->op_private = 1 | (flags >> 8);
4021 left->op_sibling = right;
4023 range->op_next = (OP*)range;
4024 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4025 flop = newUNOP(OP_FLOP, 0, flip);
4026 o = newUNOP(OP_NULL, 0, flop);
4028 range->op_next = leftstart;
4030 left->op_next = flip;
4031 right->op_next = flop;
4033 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4034 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4035 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4036 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4038 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4039 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4042 if (!flip->op_private || !flop->op_private)
4043 linklist(o); /* blow off optimizer unless constant */
4049 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4053 int once = block && block->op_flags & OPf_SPECIAL &&
4054 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4057 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4058 return block; /* do {} while 0 does once */
4059 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4060 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4061 expr = newUNOP(OP_DEFINED, 0,
4062 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4063 } else if (expr->op_flags & OPf_KIDS) {
4064 OP *k1 = ((UNOP*)expr)->op_first;
4065 OP *k2 = (k1) ? k1->op_sibling : NULL;
4066 switch (expr->op_type) {
4068 if (k2 && k2->op_type == OP_READLINE
4069 && (k2->op_flags & OPf_STACKED)
4070 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4071 expr = newUNOP(OP_DEFINED, 0, expr);
4075 if (k1->op_type == OP_READDIR
4076 || k1->op_type == OP_GLOB
4077 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4078 || k1->op_type == OP_EACH)
4079 expr = newUNOP(OP_DEFINED, 0, expr);
4085 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4086 o = new_logop(OP_AND, 0, &expr, &listop);
4089 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4091 if (once && o != listop)
4092 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4095 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4097 o->op_flags |= flags;
4099 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4104 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4112 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4113 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4114 expr = newUNOP(OP_DEFINED, 0,
4115 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4116 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4117 OP *k1 = ((UNOP*)expr)->op_first;
4118 OP *k2 = (k1) ? k1->op_sibling : NULL;
4119 switch (expr->op_type) {
4121 if (k2 && k2->op_type == OP_READLINE
4122 && (k2->op_flags & OPf_STACKED)
4123 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4124 expr = newUNOP(OP_DEFINED, 0, expr);
4128 if (k1->op_type == OP_READDIR
4129 || k1->op_type == OP_GLOB
4130 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4131 || k1->op_type == OP_EACH)
4132 expr = newUNOP(OP_DEFINED, 0, expr);
4138 block = newOP(OP_NULL, 0);
4140 block = scope(block);
4144 next = LINKLIST(cont);
4147 OP *unstack = newOP(OP_UNSTACK, 0);
4150 cont = append_elem(OP_LINESEQ, cont, unstack);
4151 if ((line_t)whileline != NOLINE) {
4152 PL_copline = whileline;
4153 cont = append_elem(OP_LINESEQ, cont,
4154 newSTATEOP(0, Nullch, Nullop));
4158 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4159 redo = LINKLIST(listop);
4162 PL_copline = whileline;
4164 o = new_logop(OP_AND, 0, &expr, &listop);
4165 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4166 op_free(expr); /* oops, it's a while (0) */
4168 return Nullop; /* listop already freed by new_logop */
4171 ((LISTOP*)listop)->op_last->op_next =
4172 (o == listop ? redo : LINKLIST(o));
4178 NewOp(1101,loop,1,LOOP);
4179 loop->op_type = OP_ENTERLOOP;
4180 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4181 loop->op_private = 0;
4182 loop->op_next = (OP*)loop;
4185 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4187 loop->op_redoop = redo;
4188 loop->op_lastop = o;
4189 o->op_private |= loopflags;
4192 loop->op_nextop = next;
4194 loop->op_nextop = o;
4196 o->op_flags |= flags;
4197 o->op_private |= (flags >> 8);
4202 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4210 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4211 sv->op_type = OP_RV2GV;
4212 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4214 else if (sv->op_type == OP_PADSV) { /* private variable */
4215 padoff = sv->op_targ;
4220 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4221 padoff = sv->op_targ;
4223 iterflags |= OPf_SPECIAL;
4228 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4231 #ifdef USE_5005THREADS
4232 padoff = find_threadsv("_");
4233 iterflags |= OPf_SPECIAL;
4235 sv = newGVOP(OP_GV, 0, PL_defgv);
4238 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4239 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4240 iterflags |= OPf_STACKED;
4242 else if (expr->op_type == OP_NULL &&
4243 (expr->op_flags & OPf_KIDS) &&
4244 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4246 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4247 * set the STACKED flag to indicate that these values are to be
4248 * treated as min/max values by 'pp_iterinit'.
4250 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4251 LOGOP* range = (LOGOP*) flip->op_first;
4252 OP* left = range->op_first;
4253 OP* right = left->op_sibling;
4256 range->op_flags &= ~OPf_KIDS;
4257 range->op_first = Nullop;
4259 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4260 listop->op_first->op_next = range->op_next;
4261 left->op_next = range->op_other;
4262 right->op_next = (OP*)listop;
4263 listop->op_next = listop->op_first;
4266 expr = (OP*)(listop);
4268 iterflags |= OPf_STACKED;
4271 expr = mod(force_list(expr), OP_GREPSTART);
4275 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4276 append_elem(OP_LIST, expr, scalar(sv))));
4277 assert(!loop->op_next);
4278 #ifdef PL_OP_SLAB_ALLOC
4281 NewOp(1234,tmp,1,LOOP);
4282 Copy(loop,tmp,1,LOOP);
4286 Renew(loop, 1, LOOP);
4288 loop->op_targ = padoff;
4289 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4290 PL_copline = forline;
4291 return newSTATEOP(0, label, wop);
4295 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4300 if (type != OP_GOTO || label->op_type == OP_CONST) {
4301 /* "last()" means "last" */
4302 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4303 o = newOP(type, OPf_SPECIAL);
4305 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4306 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4312 if (label->op_type == OP_ENTERSUB)
4313 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4314 o = newUNOP(type, OPf_STACKED, label);
4316 PL_hints |= HINT_BLOCK_SCOPE;
4321 Perl_cv_undef(pTHX_ CV *cv)
4323 #ifdef USE_5005THREADS
4325 MUTEX_DESTROY(CvMUTEXP(cv));
4326 Safefree(CvMUTEXP(cv));
4329 #endif /* USE_5005THREADS */
4332 if (CvFILE(cv) && !CvXSUB(cv)) {
4333 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4334 Safefree(CvFILE(cv));
4339 if (!CvXSUB(cv) && CvROOT(cv)) {
4340 #ifdef USE_5005THREADS
4341 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4342 Perl_croak(aTHX_ "Can't undef active subroutine");
4345 Perl_croak(aTHX_ "Can't undef active subroutine");
4346 #endif /* USE_5005THREADS */
4349 SAVEVPTR(PL_curpad);
4352 op_free(CvROOT(cv));
4353 CvROOT(cv) = Nullop;
4356 SvPOK_off((SV*)cv); /* forget prototype */
4358 /* Since closure prototypes have the same lifetime as the containing
4359 * CV, they don't hold a refcount on the outside CV. This avoids
4360 * the refcount loop between the outer CV (which keeps a refcount to
4361 * the closure prototype in the pad entry for pp_anoncode()) and the
4362 * closure prototype, and the ensuing memory leak. --GSAR */
4363 if (!CvANON(cv) || CvCLONED(cv))
4364 SvREFCNT_dec(CvOUTSIDE(cv));
4365 CvOUTSIDE(cv) = Nullcv;
4367 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4370 if (CvPADLIST(cv)) {
4371 /* may be during global destruction */
4372 if (SvREFCNT(CvPADLIST(cv))) {
4373 I32 i = AvFILLp(CvPADLIST(cv));
4375 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4376 SV* sv = svp ? *svp : Nullsv;
4379 if (sv == (SV*)PL_comppad_name)
4380 PL_comppad_name = Nullav;
4381 else if (sv == (SV*)PL_comppad) {
4382 PL_comppad = Nullav;
4383 PL_curpad = Null(SV**);
4387 SvREFCNT_dec((SV*)CvPADLIST(cv));
4389 CvPADLIST(cv) = Nullav;
4397 #ifdef DEBUG_CLOSURES
4399 S_cv_dump(pTHX_ CV *cv)
4402 CV *outside = CvOUTSIDE(cv);
4403 AV* padlist = CvPADLIST(cv);
4410 PerlIO_printf(Perl_debug_log,
4411 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4413 (CvANON(cv) ? "ANON"
4414 : (cv == PL_main_cv) ? "MAIN"
4415 : CvUNIQUE(cv) ? "UNIQUE"
4416 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4419 : CvANON(outside) ? "ANON"
4420 : (outside == PL_main_cv) ? "MAIN"
4421 : CvUNIQUE(outside) ? "UNIQUE"
4422 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4427 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4428 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4429 pname = AvARRAY(pad_name);
4430 ppad = AvARRAY(pad);
4432 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4433 if (SvPOK(pname[ix]))
4434 PerlIO_printf(Perl_debug_log,
4435 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4436 (int)ix, PTR2UV(ppad[ix]),
4437 SvFAKE(pname[ix]) ? "FAKE " : "",
4439 (IV)I_32(SvNVX(pname[ix])),
4442 #endif /* DEBUGGING */
4444 #endif /* DEBUG_CLOSURES */
4447 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4451 AV* protopadlist = CvPADLIST(proto);
4452 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4453 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4454 SV** pname = AvARRAY(protopad_name);
4455 SV** ppad = AvARRAY(protopad);
4456 I32 fname = AvFILLp(protopad_name);
4457 I32 fpad = AvFILLp(protopad);
4461 assert(!CvUNIQUE(proto));
4465 SAVESPTR(PL_comppad_name);
4466 SAVESPTR(PL_compcv);
4468 cv = PL_compcv = (CV*)NEWSV(1104,0);
4469 sv_upgrade((SV *)cv, SvTYPE(proto));
4470 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4473 #ifdef USE_5005THREADS
4474 New(666, CvMUTEXP(cv), 1, perl_mutex);
4475 MUTEX_INIT(CvMUTEXP(cv));
4477 #endif /* USE_5005THREADS */
4479 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4480 : savepv(CvFILE(proto));
4482 CvFILE(cv) = CvFILE(proto);
4484 CvGV(cv) = CvGV(proto);
4485 CvSTASH(cv) = CvSTASH(proto);
4486 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4487 CvSTART(cv) = CvSTART(proto);
4489 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4492 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4494 PL_comppad_name = newAV();
4495 for (ix = fname; ix >= 0; ix--)
4496 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4498 PL_comppad = newAV();
4500 comppadlist = newAV();
4501 AvREAL_off(comppadlist);
4502 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4503 av_store(comppadlist, 1, (SV*)PL_comppad);
4504 CvPADLIST(cv) = comppadlist;
4505 av_fill(PL_comppad, AvFILLp(protopad));
4506 PL_curpad = AvARRAY(PL_comppad);
4508 av = newAV(); /* will be @_ */
4510 av_store(PL_comppad, 0, (SV*)av);
4511 AvFLAGS(av) = AVf_REIFY;
4513 for (ix = fpad; ix > 0; ix--) {
4514 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4515 if (namesv && namesv != &PL_sv_undef) {
4516 char *name = SvPVX(namesv); /* XXX */
4517 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4518 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4519 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4521 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4523 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4525 else { /* our own lexical */
4528 /* anon code -- we'll come back for it */
4529 sv = SvREFCNT_inc(ppad[ix]);
4531 else if (*name == '@')
4533 else if (*name == '%')
4542 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4543 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4546 SV* sv = NEWSV(0,0);
4552 /* Now that vars are all in place, clone nested closures. */
4554 for (ix = fpad; ix > 0; ix--) {
4555 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4557 && namesv != &PL_sv_undef
4558 && !(SvFLAGS(namesv) & SVf_FAKE)
4559 && *SvPVX(namesv) == '&'
4560 && CvCLONE(ppad[ix]))
4562 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4563 SvREFCNT_dec(ppad[ix]);
4566 PL_curpad[ix] = (SV*)kid;
4570 #ifdef DEBUG_CLOSURES
4571 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4573 PerlIO_printf(Perl_debug_log, " from:\n");
4575 PerlIO_printf(Perl_debug_log, " to:\n");
4582 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4584 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4586 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4593 Perl_cv_clone(pTHX_ CV *proto)
4596 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4597 cv = cv_clone2(proto, CvOUTSIDE(proto));
4598 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4603 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4605 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4606 SV* msg = sv_newmortal();
4610 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4611 sv_setpv(msg, "Prototype mismatch:");
4613 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4615 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4616 sv_catpv(msg, " vs ");
4618 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4620 sv_catpv(msg, "none");
4621 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4625 static void const_sv_xsub(pTHX_ CV* cv);
4628 =for apidoc cv_const_sv
4630 If C<cv> is a constant sub eligible for inlining. returns the constant
4631 value returned by the sub. Otherwise, returns NULL.
4633 Constant subs can be created with C<newCONSTSUB> or as described in
4634 L<perlsub/"Constant Functions">.
4639 Perl_cv_const_sv(pTHX_ CV *cv)
4641 if (!cv || !CvCONST(cv))
4643 return (SV*)CvXSUBANY(cv).any_ptr;
4647 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4654 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4655 o = cLISTOPo->op_first->op_sibling;
4657 for (; o; o = o->op_next) {
4658 OPCODE type = o->op_type;
4660 if (sv && o->op_next == o)
4662 if (o->op_next != o) {
4663 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4665 if (type == OP_DBSTATE)
4668 if (type == OP_LEAVESUB || type == OP_RETURN)
4672 if (type == OP_CONST && cSVOPo->op_sv)
4674 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4675 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4676 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4680 /* We get here only from cv_clone2() while creating a closure.
4681 Copy the const value here instead of in cv_clone2 so that
4682 SvREADONLY_on doesn't lead to problems when leaving
4687 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4699 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4709 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4713 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4715 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4719 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4725 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4730 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4731 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4732 SV *sv = sv_newmortal();
4733 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4734 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4739 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4740 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4750 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4751 maximum a prototype before. */
4752 if (SvTYPE(gv) > SVt_NULL) {
4753 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4754 && ckWARN_d(WARN_PROTOTYPE))
4756 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4758 cv_ckproto((CV*)gv, NULL, ps);
4761 sv_setpv((SV*)gv, ps);
4763 sv_setiv((SV*)gv, -1);
4764 SvREFCNT_dec(PL_compcv);
4765 cv = PL_compcv = NULL;
4766 PL_sub_generation++;
4770 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4772 #ifdef GV_UNIQUE_CHECK
4773 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4774 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4778 if (!block || !ps || *ps || attrs)
4781 const_sv = op_const_sv(block, Nullcv);
4784 bool exists = CvROOT(cv) || CvXSUB(cv);
4786 #ifdef GV_UNIQUE_CHECK
4787 if (exists && GvUNIQUE(gv)) {
4788 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4792 /* if the subroutine doesn't exist and wasn't pre-declared
4793 * with a prototype, assume it will be AUTOLOADed,
4794 * skipping the prototype check
4796 if (exists || SvPOK(cv))
4797 cv_ckproto(cv, gv, ps);
4798 /* already defined (or promised)? */
4799 if (exists || GvASSUMECV(gv)) {
4800 if (!block && !attrs) {
4801 /* just a "sub foo;" when &foo is already defined */
4802 SAVEFREESV(PL_compcv);
4805 /* ahem, death to those who redefine active sort subs */
4806 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4807 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4809 if (ckWARN(WARN_REDEFINE)
4811 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4813 line_t oldline = CopLINE(PL_curcop);
4814 if (PL_copline != NOLINE)
4815 CopLINE_set(PL_curcop, PL_copline);
4816 Perl_warner(aTHX_ WARN_REDEFINE,
4817 CvCONST(cv) ? "Constant subroutine %s redefined"
4818 : "Subroutine %s redefined", name);
4819 CopLINE_set(PL_curcop, oldline);
4827 SvREFCNT_inc(const_sv);
4829 assert(!CvROOT(cv) && !CvCONST(cv));
4830 sv_setpv((SV*)cv, ""); /* prototype is "" */
4831 CvXSUBANY(cv).any_ptr = const_sv;
4832 CvXSUB(cv) = const_sv_xsub;
4837 cv = newCONSTSUB(NULL, name, const_sv);
4840 SvREFCNT_dec(PL_compcv);
4842 PL_sub_generation++;
4849 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4850 * before we clobber PL_compcv.
4854 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4855 stash = GvSTASH(CvGV(cv));
4856 else if (CvSTASH(cv))
4857 stash = CvSTASH(cv);
4859 stash = PL_curstash;
4862 /* possibly about to re-define existing subr -- ignore old cv */
4863 rcv = (SV*)PL_compcv;
4864 if (name && GvSTASH(gv))
4865 stash = GvSTASH(gv);
4867 stash = PL_curstash;
4869 apply_attrs(stash, rcv, attrs, FALSE);
4871 if (cv) { /* must reuse cv if autoloaded */
4873 /* got here with just attrs -- work done, so bug out */
4874 SAVEFREESV(PL_compcv);
4878 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4879 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4880 CvOUTSIDE(PL_compcv) = 0;
4881 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4882 CvPADLIST(PL_compcv) = 0;
4883 /* inner references to PL_compcv must be fixed up ... */
4885 AV *padlist = CvPADLIST(cv);
4886 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4887 AV *comppad = (AV*)AvARRAY(padlist)[1];
4888 SV **namepad = AvARRAY(comppad_name);
4889 SV **curpad = AvARRAY(comppad);
4890 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4891 SV *namesv = namepad[ix];
4892 if (namesv && namesv != &PL_sv_undef
4893 && *SvPVX(namesv) == '&')
4895 CV *innercv = (CV*)curpad[ix];
4896 if (CvOUTSIDE(innercv) == PL_compcv) {
4897 CvOUTSIDE(innercv) = cv;
4898 if (!CvANON(innercv) || CvCLONED(innercv)) {
4899 (void)SvREFCNT_inc(cv);
4900 SvREFCNT_dec(PL_compcv);
4906 /* ... before we throw it away */
4907 SvREFCNT_dec(PL_compcv);
4908 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4909 ++PL_sub_generation;
4916 PL_sub_generation++;
4920 CvFILE_set_from_cop(cv, PL_curcop);
4921 CvSTASH(cv) = PL_curstash;
4922 #ifdef USE_5005THREADS
4924 if (!CvMUTEXP(cv)) {
4925 New(666, CvMUTEXP(cv), 1, perl_mutex);
4926 MUTEX_INIT(CvMUTEXP(cv));
4928 #endif /* USE_5005THREADS */
4931 sv_setpv((SV*)cv, ps);
4933 if (PL_error_count) {
4937 char *s = strrchr(name, ':');
4939 if (strEQ(s, "BEGIN")) {
4941 "BEGIN not safe after errors--compilation aborted";
4942 if (PL_in_eval & EVAL_KEEPERR)
4943 Perl_croak(aTHX_ not_safe);
4945 /* force display of errors found but not reported */
4946 sv_catpv(ERRSV, not_safe);
4947 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4955 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4956 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4959 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4960 mod(scalarseq(block), OP_LEAVESUBLV));
4963 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4965 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4966 OpREFCNT_set(CvROOT(cv), 1);
4967 CvSTART(cv) = LINKLIST(CvROOT(cv));
4968 CvROOT(cv)->op_next = 0;
4969 CALL_PEEP(CvSTART(cv));
4971 /* now that optimizer has done its work, adjust pad values */
4973 SV **namep = AvARRAY(PL_comppad_name);
4974 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4977 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4980 * The only things that a clonable function needs in its
4981 * pad are references to outer lexicals and anonymous subs.
4982 * The rest are created anew during cloning.
4984 if (!((namesv = namep[ix]) != Nullsv &&
4985 namesv != &PL_sv_undef &&
4987 *SvPVX(namesv) == '&')))
4989 SvREFCNT_dec(PL_curpad[ix]);
4990 PL_curpad[ix] = Nullsv;
4993 assert(!CvCONST(cv));
4994 if (ps && !*ps && op_const_sv(block, cv))
4998 AV *av = newAV(); /* Will be @_ */
5000 av_store(PL_comppad, 0, (SV*)av);
5001 AvFLAGS(av) = AVf_REIFY;
5003 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5004 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5006 if (!SvPADMY(PL_curpad[ix]))
5007 SvPADTMP_on(PL_curpad[ix]);
5011 /* If a potential closure prototype, don't keep a refcount on outer CV.
5012 * This is okay as the lifetime of the prototype is tied to the
5013 * lifetime of the outer CV. Avoids memory leak due to reference
5016 SvREFCNT_dec(CvOUTSIDE(cv));
5018 if (name || aname) {
5020 char *tname = (name ? name : aname);
5022 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5023 SV *sv = NEWSV(0,0);
5024 SV *tmpstr = sv_newmortal();
5025 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5029 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5031 (long)PL_subline, (long)CopLINE(PL_curcop));
5032 gv_efullname3(tmpstr, gv, Nullch);
5033 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5034 hv = GvHVn(db_postponed);
5035 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5036 && (pcv = GvCV(db_postponed)))
5042 call_sv((SV*)pcv, G_DISCARD);
5046 if ((s = strrchr(tname,':')))
5051 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5054 if (strEQ(s, "BEGIN")) {
5055 I32 oldscope = PL_scopestack_ix;
5057 SAVECOPFILE(&PL_compiling);
5058 SAVECOPLINE(&PL_compiling);
5061 PL_beginav = newAV();
5062 DEBUG_x( dump_sub(gv) );
5063 av_push(PL_beginav, (SV*)cv);
5064 GvCV(gv) = 0; /* cv has been hijacked */
5065 call_list(oldscope, PL_beginav);
5067 PL_curcop = &PL_compiling;
5068 PL_compiling.op_private = PL_hints;
5071 else if (strEQ(s, "END") && !PL_error_count) {
5074 DEBUG_x( dump_sub(gv) );
5075 av_unshift(PL_endav, 1);
5076 av_store(PL_endav, 0, (SV*)cv);
5077 GvCV(gv) = 0; /* cv has been hijacked */
5079 else if (strEQ(s, "CHECK") && !PL_error_count) {
5081 PL_checkav = newAV();
5082 DEBUG_x( dump_sub(gv) );
5083 if (PL_main_start && ckWARN(WARN_VOID))
5084 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5085 av_unshift(PL_checkav, 1);
5086 av_store(PL_checkav, 0, (SV*)cv);
5087 GvCV(gv) = 0; /* cv has been hijacked */
5089 else if (strEQ(s, "INIT") && !PL_error_count) {
5091 PL_initav = newAV();
5092 DEBUG_x( dump_sub(gv) );
5093 if (PL_main_start && ckWARN(WARN_VOID))
5094 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5095 av_push(PL_initav, (SV*)cv);
5096 GvCV(gv) = 0; /* cv has been hijacked */
5101 PL_copline = NOLINE;
5106 /* XXX unsafe for threads if eval_owner isn't held */
5108 =for apidoc newCONSTSUB
5110 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5111 eligible for inlining at compile-time.
5117 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5123 SAVECOPLINE(PL_curcop);
5124 CopLINE_set(PL_curcop, PL_copline);
5127 PL_hints &= ~HINT_BLOCK_SCOPE;
5130 SAVESPTR(PL_curstash);
5131 SAVECOPSTASH(PL_curcop);
5132 PL_curstash = stash;
5134 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5136 CopSTASH(PL_curcop) = stash;
5140 cv = newXS(name, const_sv_xsub, __FILE__);
5141 CvXSUBANY(cv).any_ptr = sv;
5143 sv_setpv((SV*)cv, ""); /* prototype is "" */
5151 =for apidoc U||newXS
5153 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5159 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5161 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5164 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5166 /* just a cached method */
5170 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5171 /* already defined (or promised) */
5172 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5173 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5174 line_t oldline = CopLINE(PL_curcop);
5175 if (PL_copline != NOLINE)
5176 CopLINE_set(PL_curcop, PL_copline);
5177 Perl_warner(aTHX_ WARN_REDEFINE,
5178 CvCONST(cv) ? "Constant subroutine %s redefined"
5179 : "Subroutine %s redefined"
5181 CopLINE_set(PL_curcop, oldline);
5188 if (cv) /* must reuse cv if autoloaded */
5191 cv = (CV*)NEWSV(1105,0);
5192 sv_upgrade((SV *)cv, SVt_PVCV);
5196 PL_sub_generation++;
5200 #ifdef USE_5005THREADS
5201 New(666, CvMUTEXP(cv), 1, perl_mutex);
5202 MUTEX_INIT(CvMUTEXP(cv));
5204 #endif /* USE_5005THREADS */
5205 (void)gv_fetchfile(filename);
5206 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5207 an external constant string */
5208 CvXSUB(cv) = subaddr;
5211 char *s = strrchr(name,':');
5217 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5220 if (strEQ(s, "BEGIN")) {
5222 PL_beginav = newAV();
5223 av_push(PL_beginav, (SV*)cv);
5224 GvCV(gv) = 0; /* cv has been hijacked */
5226 else if (strEQ(s, "END")) {
5229 av_unshift(PL_endav, 1);
5230 av_store(PL_endav, 0, (SV*)cv);
5231 GvCV(gv) = 0; /* cv has been hijacked */
5233 else if (strEQ(s, "CHECK")) {
5235 PL_checkav = newAV();
5236 if (PL_main_start && ckWARN(WARN_VOID))
5237 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5238 av_unshift(PL_checkav, 1);
5239 av_store(PL_checkav, 0, (SV*)cv);
5240 GvCV(gv) = 0; /* cv has been hijacked */
5242 else if (strEQ(s, "INIT")) {
5244 PL_initav = newAV();
5245 if (PL_main_start && ckWARN(WARN_VOID))
5246 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5247 av_push(PL_initav, (SV*)cv);
5248 GvCV(gv) = 0; /* cv has been hijacked */
5259 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5268 name = SvPVx(cSVOPo->op_sv, n_a);
5271 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5272 #ifdef GV_UNIQUE_CHECK
5274 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5278 if ((cv = GvFORM(gv))) {
5279 if (ckWARN(WARN_REDEFINE)) {
5280 line_t oldline = CopLINE(PL_curcop);
5281 if (PL_copline != NOLINE)
5282 CopLINE_set(PL_curcop, PL_copline);
5283 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5284 CopLINE_set(PL_curcop, oldline);
5291 CvFILE_set_from_cop(cv, PL_curcop);
5293 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5294 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5295 SvPADTMP_on(PL_curpad[ix]);
5298 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5299 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5300 OpREFCNT_set(CvROOT(cv), 1);
5301 CvSTART(cv) = LINKLIST(CvROOT(cv));
5302 CvROOT(cv)->op_next = 0;
5303 CALL_PEEP(CvSTART(cv));
5305 PL_copline = NOLINE;
5310 Perl_newANONLIST(pTHX_ OP *o)
5312 return newUNOP(OP_REFGEN, 0,
5313 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5317 Perl_newANONHASH(pTHX_ OP *o)
5319 return newUNOP(OP_REFGEN, 0,
5320 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5324 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5326 return newANONATTRSUB(floor, proto, Nullop, block);
5330 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5332 return newUNOP(OP_REFGEN, 0,
5333 newSVOP(OP_ANONCODE, 0,
5334 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5338 Perl_oopsAV(pTHX_ OP *o)
5340 switch (o->op_type) {
5342 o->op_type = OP_PADAV;
5343 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5344 return ref(o, OP_RV2AV);
5347 o->op_type = OP_RV2AV;
5348 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5353 if (ckWARN_d(WARN_INTERNAL))
5354 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5361 Perl_oopsHV(pTHX_ OP *o)
5363 switch (o->op_type) {
5366 o->op_type = OP_PADHV;
5367 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5368 return ref(o, OP_RV2HV);
5372 o->op_type = OP_RV2HV;
5373 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5378 if (ckWARN_d(WARN_INTERNAL))
5379 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5386 Perl_newAVREF(pTHX_ OP *o)
5388 if (o->op_type == OP_PADANY) {
5389 o->op_type = OP_PADAV;
5390 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5393 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5394 && ckWARN(WARN_DEPRECATED)) {
5395 Perl_warner(aTHX_ WARN_DEPRECATED,
5396 "Using an array as a reference is deprecated");
5398 return newUNOP(OP_RV2AV, 0, scalar(o));
5402 Perl_newGVREF(pTHX_ I32 type, OP *o)
5404 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5405 return newUNOP(OP_NULL, 0, o);
5406 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5410 Perl_newHVREF(pTHX_ OP *o)
5412 if (o->op_type == OP_PADANY) {
5413 o->op_type = OP_PADHV;
5414 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5417 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5418 && ckWARN(WARN_DEPRECATED)) {
5419 Perl_warner(aTHX_ WARN_DEPRECATED,
5420 "Using a hash as a reference is deprecated");
5422 return newUNOP(OP_RV2HV, 0, scalar(o));
5426 Perl_oopsCV(pTHX_ OP *o)
5428 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5434 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5436 return newUNOP(OP_RV2CV, flags, scalar(o));
5440 Perl_newSVREF(pTHX_ OP *o)
5442 if (o->op_type == OP_PADANY) {
5443 o->op_type = OP_PADSV;
5444 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5447 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5448 o->op_flags |= OPpDONE_SVREF;
5451 return newUNOP(OP_RV2SV, 0, scalar(o));
5454 /* Check routines. */
5457 Perl_ck_anoncode(pTHX_ OP *o)
5462 name = NEWSV(1106,0);
5463 sv_upgrade(name, SVt_PVNV);
5464 sv_setpvn(name, "&", 1);
5467 ix = pad_alloc(o->op_type, SVs_PADMY);
5468 av_store(PL_comppad_name, ix, name);
5469 av_store(PL_comppad, ix, cSVOPo->op_sv);
5470 SvPADMY_on(cSVOPo->op_sv);
5471 cSVOPo->op_sv = Nullsv;
5472 cSVOPo->op_targ = ix;
5477 Perl_ck_bitop(pTHX_ OP *o)
5479 o->op_private = PL_hints;
5484 Perl_ck_concat(pTHX_ OP *o)
5486 if (cUNOPo->op_first->op_type == OP_CONCAT)
5487 o->op_flags |= OPf_STACKED;
5492 Perl_ck_spair(pTHX_ OP *o)
5494 if (o->op_flags & OPf_KIDS) {
5497 OPCODE type = o->op_type;
5498 o = modkids(ck_fun(o), type);
5499 kid = cUNOPo->op_first;
5500 newop = kUNOP->op_first->op_sibling;
5502 (newop->op_sibling ||
5503 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5504 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5505 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5509 op_free(kUNOP->op_first);
5510 kUNOP->op_first = newop;
5512 o->op_ppaddr = PL_ppaddr[++o->op_type];
5517 Perl_ck_delete(pTHX_ OP *o)
5521 if (o->op_flags & OPf_KIDS) {
5522 OP *kid = cUNOPo->op_first;
5523 switch (kid->op_type) {
5525 o->op_flags |= OPf_SPECIAL;
5528 o->op_private |= OPpSLICE;
5531 o->op_flags |= OPf_SPECIAL;
5536 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5545 Perl_ck_die(pTHX_ OP *o)
5548 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5554 Perl_ck_eof(pTHX_ OP *o)
5556 I32 type = o->op_type;
5558 if (o->op_flags & OPf_KIDS) {
5559 if (cLISTOPo->op_first->op_type == OP_STUB) {
5561 o = newUNOP(type, OPf_SPECIAL,
5562 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5570 Perl_ck_eval(pTHX_ OP *o)
5572 PL_hints |= HINT_BLOCK_SCOPE;
5573 if (o->op_flags & OPf_KIDS) {
5574 SVOP *kid = (SVOP*)cUNOPo->op_first;
5577 o->op_flags &= ~OPf_KIDS;
5580 else if (kid->op_type == OP_LINESEQ) {
5583 kid->op_next = o->op_next;
5584 cUNOPo->op_first = 0;
5587 NewOp(1101, enter, 1, LOGOP);
5588 enter->op_type = OP_ENTERTRY;
5589 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5590 enter->op_private = 0;
5592 /* establish postfix order */
5593 enter->op_next = (OP*)enter;
5595 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5596 o->op_type = OP_LEAVETRY;
5597 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5598 enter->op_other = o;
5606 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5608 o->op_targ = (PADOFFSET)PL_hints;
5613 Perl_ck_exit(pTHX_ OP *o)
5616 HV *table = GvHV(PL_hintgv);
5618 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5619 if (svp && *svp && SvTRUE(*svp))
5620 o->op_private |= OPpEXIT_VMSISH;
5622 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5628 Perl_ck_exec(pTHX_ OP *o)
5631 if (o->op_flags & OPf_STACKED) {
5633 kid = cUNOPo->op_first->op_sibling;
5634 if (kid->op_type == OP_RV2GV)
5643 Perl_ck_exists(pTHX_ OP *o)
5646 if (o->op_flags & OPf_KIDS) {
5647 OP *kid = cUNOPo->op_first;
5648 if (kid->op_type == OP_ENTERSUB) {
5649 (void) ref(kid, o->op_type);
5650 if (kid->op_type != OP_RV2CV && !PL_error_count)
5651 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5653 o->op_private |= OPpEXISTS_SUB;
5655 else if (kid->op_type == OP_AELEM)
5656 o->op_flags |= OPf_SPECIAL;
5657 else if (kid->op_type != OP_HELEM)
5658 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5667 Perl_ck_gvconst(pTHX_ register OP *o)
5669 o = fold_constants(o);
5670 if (o->op_type == OP_CONST)
5677 Perl_ck_rvconst(pTHX_ register OP *o)
5679 SVOP *kid = (SVOP*)cUNOPo->op_first;
5681 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5682 if (kid->op_type == OP_CONST) {
5686 SV *kidsv = kid->op_sv;
5689 /* Is it a constant from cv_const_sv()? */
5690 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5691 SV *rsv = SvRV(kidsv);
5692 int svtype = SvTYPE(rsv);
5693 char *badtype = Nullch;
5695 switch (o->op_type) {
5697 if (svtype > SVt_PVMG)
5698 badtype = "a SCALAR";
5701 if (svtype != SVt_PVAV)
5702 badtype = "an ARRAY";
5705 if (svtype != SVt_PVHV) {
5706 if (svtype == SVt_PVAV) { /* pseudohash? */
5707 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5708 if (ksv && SvROK(*ksv)
5709 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5718 if (svtype != SVt_PVCV)
5723 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5726 name = SvPV(kidsv, n_a);
5727 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5728 char *badthing = Nullch;
5729 switch (o->op_type) {
5731 badthing = "a SCALAR";
5734 badthing = "an ARRAY";
5737 badthing = "a HASH";
5742 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5746 * This is a little tricky. We only want to add the symbol if we
5747 * didn't add it in the lexer. Otherwise we get duplicate strict
5748 * warnings. But if we didn't add it in the lexer, we must at
5749 * least pretend like we wanted to add it even if it existed before,
5750 * or we get possible typo warnings. OPpCONST_ENTERED says
5751 * whether the lexer already added THIS instance of this symbol.
5753 iscv = (o->op_type == OP_RV2CV) * 2;
5755 gv = gv_fetchpv(name,
5756 iscv | !(kid->op_private & OPpCONST_ENTERED),
5759 : o->op_type == OP_RV2SV
5761 : o->op_type == OP_RV2AV
5763 : o->op_type == OP_RV2HV
5766 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5768 kid->op_type = OP_GV;
5769 SvREFCNT_dec(kid->op_sv);
5771 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5772 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5773 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5775 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5777 kid->op_sv = SvREFCNT_inc(gv);
5779 kid->op_private = 0;
5780 kid->op_ppaddr = PL_ppaddr[OP_GV];
5787 Perl_ck_ftst(pTHX_ OP *o)
5789 I32 type = o->op_type;
5791 if (o->op_flags & OPf_REF) {
5794 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5795 SVOP *kid = (SVOP*)cUNOPo->op_first;
5797 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5799 OP *newop = newGVOP(type, OPf_REF,
5800 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5807 if (type == OP_FTTTY)
5808 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5811 o = newUNOP(type, 0, newDEFSVOP());
5817 Perl_ck_fun(pTHX_ OP *o)
5823 int type = o->op_type;
5824 register I32 oa = PL_opargs[type] >> OASHIFT;
5826 if (o->op_flags & OPf_STACKED) {
5827 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5830 return no_fh_allowed(o);
5833 if (o->op_flags & OPf_KIDS) {
5835 tokid = &cLISTOPo->op_first;
5836 kid = cLISTOPo->op_first;
5837 if (kid->op_type == OP_PUSHMARK ||
5838 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5840 tokid = &kid->op_sibling;
5841 kid = kid->op_sibling;
5843 if (!kid && PL_opargs[type] & OA_DEFGV)
5844 *tokid = kid = newDEFSVOP();
5848 sibl = kid->op_sibling;
5851 /* list seen where single (scalar) arg expected? */
5852 if (numargs == 1 && !(oa >> 4)
5853 && kid->op_type == OP_LIST && type != OP_SCALAR)
5855 return too_many_arguments(o,PL_op_desc[type]);
5868 if ((type == OP_PUSH || type == OP_UNSHIFT)
5869 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5870 Perl_warner(aTHX_ WARN_SYNTAX,
5871 "Useless use of %s with no values",
5874 if (kid->op_type == OP_CONST &&
5875 (kid->op_private & OPpCONST_BARE))
5877 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5878 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5879 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5880 if (ckWARN(WARN_DEPRECATED))
5881 Perl_warner(aTHX_ WARN_DEPRECATED,
5882 "Array @%s missing the @ in argument %"IVdf" of %s()",
5883 name, (IV)numargs, PL_op_desc[type]);
5886 kid->op_sibling = sibl;
5889 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5890 bad_type(numargs, "array", PL_op_desc[type], kid);
5894 if (kid->op_type == OP_CONST &&
5895 (kid->op_private & OPpCONST_BARE))
5897 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5898 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5899 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5900 if (ckWARN(WARN_DEPRECATED))
5901 Perl_warner(aTHX_ WARN_DEPRECATED,
5902 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5903 name, (IV)numargs, PL_op_desc[type]);
5906 kid->op_sibling = sibl;
5909 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5910 bad_type(numargs, "hash", PL_op_desc[type], kid);
5915 OP *newop = newUNOP(OP_NULL, 0, kid);
5916 kid->op_sibling = 0;
5918 newop->op_next = newop;
5920 kid->op_sibling = sibl;
5925 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5926 if (kid->op_type == OP_CONST &&
5927 (kid->op_private & OPpCONST_BARE))
5929 OP *newop = newGVOP(OP_GV, 0,
5930 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5935 else if (kid->op_type == OP_READLINE) {
5936 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5937 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5940 I32 flags = OPf_SPECIAL;
5944 /* is this op a FH constructor? */
5945 if (is_handle_constructor(o,numargs)) {
5946 char *name = Nullch;
5950 /* Set a flag to tell rv2gv to vivify
5951 * need to "prove" flag does not mean something
5952 * else already - NI-S 1999/05/07
5955 if (kid->op_type == OP_PADSV) {
5956 SV **namep = av_fetch(PL_comppad_name,
5958 if (namep && *namep)
5959 name = SvPV(*namep, len);
5961 else if (kid->op_type == OP_RV2SV
5962 && kUNOP->op_first->op_type == OP_GV)
5964 GV *gv = cGVOPx_gv(kUNOP->op_first);
5966 len = GvNAMELEN(gv);
5968 else if (kid->op_type == OP_AELEM
5969 || kid->op_type == OP_HELEM)
5971 name = "__ANONIO__";
5977 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5978 namesv = PL_curpad[targ];
5979 (void)SvUPGRADE(namesv, SVt_PV);
5981 sv_setpvn(namesv, "$", 1);
5982 sv_catpvn(namesv, name, len);
5985 kid->op_sibling = 0;
5986 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5987 kid->op_targ = targ;
5988 kid->op_private |= priv;
5990 kid->op_sibling = sibl;
5996 mod(scalar(kid), type);
6000 tokid = &kid->op_sibling;
6001 kid = kid->op_sibling;
6003 o->op_private |= numargs;
6005 return too_many_arguments(o,OP_DESC(o));
6008 else if (PL_opargs[type] & OA_DEFGV) {
6010 return newUNOP(type, 0, newDEFSVOP());
6014 while (oa & OA_OPTIONAL)
6016 if (oa && oa != OA_LIST)
6017 return too_few_arguments(o,OP_DESC(o));
6023 Perl_ck_glob(pTHX_ OP *o)
6028 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6029 append_elem(OP_GLOB, o, newDEFSVOP());
6031 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6032 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6034 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6037 #if !defined(PERL_EXTERNAL_GLOB)
6038 /* XXX this can be tightened up and made more failsafe. */
6042 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
6044 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6045 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6046 GvCV(gv) = GvCV(glob_gv);
6047 SvREFCNT_inc((SV*)GvCV(gv));
6048 GvIMPORTED_CV_on(gv);
6051 #endif /* PERL_EXTERNAL_GLOB */
6053 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6054 append_elem(OP_GLOB, o,
6055 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6056 o->op_type = OP_LIST;
6057 o->op_ppaddr = PL_ppaddr[OP_LIST];
6058 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6059 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6060 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6061 append_elem(OP_LIST, o,
6062 scalar(newUNOP(OP_RV2CV, 0,
6063 newGVOP(OP_GV, 0, gv)))));
6064 o = newUNOP(OP_NULL, 0, ck_subr(o));
6065 o->op_targ = OP_GLOB; /* hint at what it used to be */
6068 gv = newGVgen("main");
6070 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6076 Perl_ck_grep(pTHX_ OP *o)
6080 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6082 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6083 NewOp(1101, gwop, 1, LOGOP);
6085 if (o->op_flags & OPf_STACKED) {
6088 kid = cLISTOPo->op_first->op_sibling;
6089 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6092 kid->op_next = (OP*)gwop;
6093 o->op_flags &= ~OPf_STACKED;
6095 kid = cLISTOPo->op_first->op_sibling;
6096 if (type == OP_MAPWHILE)
6103 kid = cLISTOPo->op_first->op_sibling;
6104 if (kid->op_type != OP_NULL)
6105 Perl_croak(aTHX_ "panic: ck_grep");
6106 kid = kUNOP->op_first;
6108 gwop->op_type = type;
6109 gwop->op_ppaddr = PL_ppaddr[type];
6110 gwop->op_first = listkids(o);
6111 gwop->op_flags |= OPf_KIDS;
6112 gwop->op_private = 1;
6113 gwop->op_other = LINKLIST(kid);
6114 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6115 kid->op_next = (OP*)gwop;
6117 kid = cLISTOPo->op_first->op_sibling;
6118 if (!kid || !kid->op_sibling)
6119 return too_few_arguments(o,OP_DESC(o));
6120 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6121 mod(kid, OP_GREPSTART);
6127 Perl_ck_index(pTHX_ OP *o)
6129 if (o->op_flags & OPf_KIDS) {
6130 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6132 kid = kid->op_sibling; /* get past "big" */
6133 if (kid && kid->op_type == OP_CONST)
6134 fbm_compile(((SVOP*)kid)->op_sv, 0);
6140 Perl_ck_lengthconst(pTHX_ OP *o)
6142 /* XXX length optimization goes here */
6147 Perl_ck_lfun(pTHX_ OP *o)
6149 OPCODE type = o->op_type;
6150 return modkids(ck_fun(o), type);
6154 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6156 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6157 switch (cUNOPo->op_first->op_type) {
6159 /* This is needed for
6160 if (defined %stash::)
6161 to work. Do not break Tk.
6163 break; /* Globals via GV can be undef */
6165 case OP_AASSIGN: /* Is this a good idea? */
6166 Perl_warner(aTHX_ WARN_DEPRECATED,
6167 "defined(@array) is deprecated");
6168 Perl_warner(aTHX_ WARN_DEPRECATED,
6169 "\t(Maybe you should just omit the defined()?)\n");
6172 /* This is needed for
6173 if (defined %stash::)
6174 to work. Do not break Tk.
6176 break; /* Globals via GV can be undef */
6178 Perl_warner(aTHX_ WARN_DEPRECATED,
6179 "defined(%%hash) is deprecated");
6180 Perl_warner(aTHX_ WARN_DEPRECATED,
6181 "\t(Maybe you should just omit the defined()?)\n");
6192 Perl_ck_rfun(pTHX_ OP *o)
6194 OPCODE type = o->op_type;
6195 return refkids(ck_fun(o), type);
6199 Perl_ck_listiob(pTHX_ OP *o)
6203 kid = cLISTOPo->op_first;
6206 kid = cLISTOPo->op_first;
6208 if (kid->op_type == OP_PUSHMARK)
6209 kid = kid->op_sibling;
6210 if (kid && o->op_flags & OPf_STACKED)
6211 kid = kid->op_sibling;
6212 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6213 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6214 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6215 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6216 cLISTOPo->op_first->op_sibling = kid;
6217 cLISTOPo->op_last = kid;
6218 kid = kid->op_sibling;
6223 append_elem(o->op_type, o, newDEFSVOP());
6229 Perl_ck_sassign(pTHX_ OP *o)
6231 OP *kid = cLISTOPo->op_first;
6232 /* has a disposable target? */
6233 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6234 && !(kid->op_flags & OPf_STACKED)
6235 /* Cannot steal the second time! */
6236 && !(kid->op_private & OPpTARGET_MY))
6238 OP *kkid = kid->op_sibling;
6240 /* Can just relocate the target. */
6241 if (kkid && kkid->op_type == OP_PADSV
6242 && !(kkid->op_private & OPpLVAL_INTRO))
6244 kid->op_targ = kkid->op_targ;
6246 /* Now we do not need PADSV and SASSIGN. */
6247 kid->op_sibling = o->op_sibling; /* NULL */
6248 cLISTOPo->op_first = NULL;
6251 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6259 Perl_ck_match(pTHX_ OP *o)
6261 o->op_private |= OPpRUNTIME;
6266 Perl_ck_method(pTHX_ OP *o)
6268 OP *kid = cUNOPo->op_first;
6269 if (kid->op_type == OP_CONST) {
6270 SV* sv = kSVOP->op_sv;
6271 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6273 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6274 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6277 kSVOP->op_sv = Nullsv;
6279 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6288 Perl_ck_null(pTHX_ OP *o)
6294 Perl_ck_open(pTHX_ OP *o)
6296 HV *table = GvHV(PL_hintgv);
6300 svp = hv_fetch(table, "open_IN", 7, FALSE);
6302 mode = mode_from_discipline(*svp);
6303 if (mode & O_BINARY)
6304 o->op_private |= OPpOPEN_IN_RAW;
6305 else if (mode & O_TEXT)
6306 o->op_private |= OPpOPEN_IN_CRLF;
6309 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6311 mode = mode_from_discipline(*svp);
6312 if (mode & O_BINARY)
6313 o->op_private |= OPpOPEN_OUT_RAW;
6314 else if (mode & O_TEXT)
6315 o->op_private |= OPpOPEN_OUT_CRLF;
6318 if (o->op_type == OP_BACKTICK)
6324 Perl_ck_repeat(pTHX_ OP *o)
6326 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6327 o->op_private |= OPpREPEAT_DOLIST;
6328 cBINOPo->op_first = force_list(cBINOPo->op_first);
6336 Perl_ck_require(pTHX_ OP *o)
6340 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6341 SVOP *kid = (SVOP*)cUNOPo->op_first;
6343 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6345 for (s = SvPVX(kid->op_sv); *s; s++) {
6346 if (*s == ':' && s[1] == ':') {
6348 Move(s+2, s+1, strlen(s+2)+1, char);
6349 --SvCUR(kid->op_sv);
6352 if (SvREADONLY(kid->op_sv)) {
6353 SvREADONLY_off(kid->op_sv);
6354 sv_catpvn(kid->op_sv, ".pm", 3);
6355 SvREADONLY_on(kid->op_sv);
6358 sv_catpvn(kid->op_sv, ".pm", 3);
6362 /* handle override, if any */
6363 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6364 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6365 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6367 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6368 OP *kid = cUNOPo->op_first;
6369 cUNOPo->op_first = 0;
6371 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6372 append_elem(OP_LIST, kid,
6373 scalar(newUNOP(OP_RV2CV, 0,
6382 Perl_ck_return(pTHX_ OP *o)
6385 if (CvLVALUE(PL_compcv)) {
6386 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6387 mod(kid, OP_LEAVESUBLV);
6394 Perl_ck_retarget(pTHX_ OP *o)
6396 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6403 Perl_ck_select(pTHX_ OP *o)
6406 if (o->op_flags & OPf_KIDS) {
6407 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6408 if (kid && kid->op_sibling) {
6409 o->op_type = OP_SSELECT;
6410 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6412 return fold_constants(o);
6416 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6417 if (kid && kid->op_type == OP_RV2GV)
6418 kid->op_private &= ~HINT_STRICT_REFS;
6423 Perl_ck_shift(pTHX_ OP *o)
6425 I32 type = o->op_type;
6427 if (!(o->op_flags & OPf_KIDS)) {
6431 #ifdef USE_5005THREADS
6432 if (!CvUNIQUE(PL_compcv)) {
6433 argop = newOP(OP_PADAV, OPf_REF);
6434 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6437 argop = newUNOP(OP_RV2AV, 0,
6438 scalar(newGVOP(OP_GV, 0,
6439 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6442 argop = newUNOP(OP_RV2AV, 0,
6443 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6444 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6445 #endif /* USE_5005THREADS */
6446 return newUNOP(type, 0, scalar(argop));
6448 return scalar(modkids(ck_fun(o), type));
6452 Perl_ck_sort(pTHX_ OP *o)
6456 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6458 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6459 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6461 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6463 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6465 if (kid->op_type == OP_SCOPE) {
6469 else if (kid->op_type == OP_LEAVE) {
6470 if (o->op_type == OP_SORT) {
6471 op_null(kid); /* wipe out leave */
6474 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6475 if (k->op_next == kid)
6477 /* don't descend into loops */
6478 else if (k->op_type == OP_ENTERLOOP
6479 || k->op_type == OP_ENTERITER)
6481 k = cLOOPx(k)->op_lastop;
6486 kid->op_next = 0; /* just disconnect the leave */
6487 k = kLISTOP->op_first;
6492 if (o->op_type == OP_SORT) {
6493 /* provide scalar context for comparison function/block */
6499 o->op_flags |= OPf_SPECIAL;
6501 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6504 firstkid = firstkid->op_sibling;
6507 /* provide list context for arguments */
6508 if (o->op_type == OP_SORT)
6515 S_simplify_sort(pTHX_ OP *o)
6517 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6521 if (!(o->op_flags & OPf_STACKED))
6523 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6524 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6525 kid = kUNOP->op_first; /* get past null */
6526 if (kid->op_type != OP_SCOPE)
6528 kid = kLISTOP->op_last; /* get past scope */
6529 switch(kid->op_type) {
6537 k = kid; /* remember this node*/
6538 if (kBINOP->op_first->op_type != OP_RV2SV)
6540 kid = kBINOP->op_first; /* get past cmp */
6541 if (kUNOP->op_first->op_type != OP_GV)
6543 kid = kUNOP->op_first; /* get past rv2sv */
6545 if (GvSTASH(gv) != PL_curstash)
6547 if (strEQ(GvNAME(gv), "a"))
6549 else if (strEQ(GvNAME(gv), "b"))
6553 kid = k; /* back to cmp */
6554 if (kBINOP->op_last->op_type != OP_RV2SV)
6556 kid = kBINOP->op_last; /* down to 2nd arg */
6557 if (kUNOP->op_first->op_type != OP_GV)
6559 kid = kUNOP->op_first; /* get past rv2sv */
6561 if (GvSTASH(gv) != PL_curstash
6563 ? strNE(GvNAME(gv), "a")
6564 : strNE(GvNAME(gv), "b")))
6566 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6568 o->op_private |= OPpSORT_REVERSE;
6569 if (k->op_type == OP_NCMP)
6570 o->op_private |= OPpSORT_NUMERIC;
6571 if (k->op_type == OP_I_NCMP)
6572 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6573 kid = cLISTOPo->op_first->op_sibling;
6574 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6575 op_free(kid); /* then delete it */
6579 Perl_ck_split(pTHX_ OP *o)
6583 if (o->op_flags & OPf_STACKED)
6584 return no_fh_allowed(o);
6586 kid = cLISTOPo->op_first;
6587 if (kid->op_type != OP_NULL)
6588 Perl_croak(aTHX_ "panic: ck_split");
6589 kid = kid->op_sibling;
6590 op_free(cLISTOPo->op_first);
6591 cLISTOPo->op_first = kid;
6593 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6594 cLISTOPo->op_last = kid; /* There was only one element previously */
6597 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6598 OP *sibl = kid->op_sibling;
6599 kid->op_sibling = 0;
6600 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6601 if (cLISTOPo->op_first == cLISTOPo->op_last)
6602 cLISTOPo->op_last = kid;
6603 cLISTOPo->op_first = kid;
6604 kid->op_sibling = sibl;
6607 kid->op_type = OP_PUSHRE;
6608 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6611 if (!kid->op_sibling)
6612 append_elem(OP_SPLIT, o, newDEFSVOP());
6614 kid = kid->op_sibling;
6617 if (!kid->op_sibling)
6618 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6620 kid = kid->op_sibling;
6623 if (kid->op_sibling)
6624 return too_many_arguments(o,OP_DESC(o));
6630 Perl_ck_join(pTHX_ OP *o)
6632 if (ckWARN(WARN_SYNTAX)) {
6633 OP *kid = cLISTOPo->op_first->op_sibling;
6634 if (kid && kid->op_type == OP_MATCH) {
6635 char *pmstr = "STRING";
6636 if (PM_GETRE(kPMOP))
6637 pmstr = PM_GETRE(kPMOP)->precomp;
6638 Perl_warner(aTHX_ WARN_SYNTAX,
6639 "/%s/ should probably be written as \"%s\"",
6647 Perl_ck_subr(pTHX_ OP *o)
6649 OP *prev = ((cUNOPo->op_first->op_sibling)
6650 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6651 OP *o2 = prev->op_sibling;
6658 I32 contextclass = 0;
6662 o->op_private |= OPpENTERSUB_HASTARG;
6663 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6664 if (cvop->op_type == OP_RV2CV) {
6666 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6667 op_null(cvop); /* disable rv2cv */
6668 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6669 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6670 GV *gv = cGVOPx_gv(tmpop);
6673 tmpop->op_private |= OPpEARLY_CV;
6674 else if (SvPOK(cv)) {
6675 namegv = CvANON(cv) ? gv : CvGV(cv);
6676 proto = SvPV((SV*)cv, n_a);
6680 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6681 if (o2->op_type == OP_CONST)
6682 o2->op_private &= ~OPpCONST_STRICT;
6683 else if (o2->op_type == OP_LIST) {
6684 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6685 if (o && o->op_type == OP_CONST)
6686 o->op_private &= ~OPpCONST_STRICT;
6689 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6690 if (PERLDB_SUB && PL_curstash != PL_debstash)
6691 o->op_private |= OPpENTERSUB_DB;
6692 while (o2 != cvop) {
6696 return too_many_arguments(o, gv_ename(namegv));
6714 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6716 arg == 1 ? "block or sub {}" : "sub {}",
6717 gv_ename(namegv), o2);
6720 /* '*' allows any scalar type, including bareword */
6723 if (o2->op_type == OP_RV2GV)
6724 goto wrapref; /* autoconvert GLOB -> GLOBref */
6725 else if (o2->op_type == OP_CONST)
6726 o2->op_private &= ~OPpCONST_STRICT;
6727 else if (o2->op_type == OP_ENTERSUB) {
6728 /* accidental subroutine, revert to bareword */
6729 OP *gvop = ((UNOP*)o2)->op_first;
6730 if (gvop && gvop->op_type == OP_NULL) {
6731 gvop = ((UNOP*)gvop)->op_first;
6733 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6736 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6737 (gvop = ((UNOP*)gvop)->op_first) &&
6738 gvop->op_type == OP_GV)
6740 GV *gv = cGVOPx_gv(gvop);
6741 OP *sibling = o2->op_sibling;
6742 SV *n = newSVpvn("",0);
6744 gv_fullname3(n, gv, "");
6745 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6746 sv_chop(n, SvPVX(n)+6);
6747 o2 = newSVOP(OP_CONST, 0, n);
6748 prev->op_sibling = o2;
6749 o2->op_sibling = sibling;
6765 if (contextclass++ == 0) {
6766 e = strchr(proto, ']');
6767 if (!e || e == proto)
6781 if (o2->op_type == OP_RV2GV)
6784 bad_type(arg, "symbol", gv_ename(namegv), o2);
6787 if (o2->op_type == OP_ENTERSUB)
6790 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6793 if (o2->op_type == OP_RV2SV ||
6794 o2->op_type == OP_PADSV ||
6795 o2->op_type == OP_HELEM ||
6796 o2->op_type == OP_AELEM ||
6797 o2->op_type == OP_THREADSV)
6800 bad_type(arg, "scalar", gv_ename(namegv), o2);
6803 if (o2->op_type == OP_RV2AV ||
6804 o2->op_type == OP_PADAV)
6807 bad_type(arg, "array", gv_ename(namegv), o2);
6810 if (o2->op_type == OP_RV2HV ||
6811 o2->op_type == OP_PADHV)
6814 bad_type(arg, "hash", gv_ename(namegv), o2);
6819 OP* sib = kid->op_sibling;
6820 kid->op_sibling = 0;
6821 o2 = newUNOP(OP_REFGEN, 0, kid);
6822 o2->op_sibling = sib;
6823 prev->op_sibling = o2;
6825 if (contextclass && e) {
6840 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6841 gv_ename(namegv), SvPV((SV*)cv, n_a));
6846 mod(o2, OP_ENTERSUB);
6848 o2 = o2->op_sibling;
6850 if (proto && !optional &&
6851 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6852 return too_few_arguments(o, gv_ename(namegv));
6857 Perl_ck_svconst(pTHX_ OP *o)
6859 SvREADONLY_on(cSVOPo->op_sv);
6864 Perl_ck_trunc(pTHX_ OP *o)
6866 if (o->op_flags & OPf_KIDS) {
6867 SVOP *kid = (SVOP*)cUNOPo->op_first;
6869 if (kid->op_type == OP_NULL)
6870 kid = (SVOP*)kid->op_sibling;
6871 if (kid && kid->op_type == OP_CONST &&
6872 (kid->op_private & OPpCONST_BARE))
6874 o->op_flags |= OPf_SPECIAL;
6875 kid->op_private &= ~OPpCONST_STRICT;
6882 Perl_ck_substr(pTHX_ OP *o)
6885 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6886 OP *kid = cLISTOPo->op_first;
6888 if (kid->op_type == OP_NULL)
6889 kid = kid->op_sibling;
6891 kid->op_flags |= OPf_MOD;
6897 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6900 Perl_peep(pTHX_ register OP *o)
6902 register OP* oldop = 0;
6905 if (!o || o->op_seq)
6909 SAVEVPTR(PL_curcop);
6910 for (; o; o = o->op_next) {
6916 switch (o->op_type) {
6920 PL_curcop = ((COP*)o); /* for warnings */
6921 o->op_seq = PL_op_seqmax++;
6925 if (cSVOPo->op_private & OPpCONST_STRICT)
6926 no_bareword_allowed(o);
6928 /* Relocate sv to the pad for thread safety.
6929 * Despite being a "constant", the SV is written to,
6930 * for reference counts, sv_upgrade() etc. */
6932 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6933 if (SvPADTMP(cSVOPo->op_sv)) {
6934 /* If op_sv is already a PADTMP then it is being used by
6935 * some pad, so make a copy. */
6936 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6937 SvREADONLY_on(PL_curpad[ix]);
6938 SvREFCNT_dec(cSVOPo->op_sv);
6941 SvREFCNT_dec(PL_curpad[ix]);
6942 SvPADTMP_on(cSVOPo->op_sv);
6943 PL_curpad[ix] = cSVOPo->op_sv;
6944 /* XXX I don't know how this isn't readonly already. */
6945 SvREADONLY_on(PL_curpad[ix]);
6947 cSVOPo->op_sv = Nullsv;
6951 o->op_seq = PL_op_seqmax++;
6955 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6956 if (o->op_next->op_private & OPpTARGET_MY) {
6957 if (o->op_flags & OPf_STACKED) /* chained concats */
6958 goto ignore_optimization;
6960 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6961 o->op_targ = o->op_next->op_targ;
6962 o->op_next->op_targ = 0;
6963 o->op_private |= OPpTARGET_MY;
6966 op_null(o->op_next);
6968 ignore_optimization:
6969 o->op_seq = PL_op_seqmax++;
6972 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6973 o->op_seq = PL_op_seqmax++;
6974 break; /* Scalar stub must produce undef. List stub is noop */
6978 if (o->op_targ == OP_NEXTSTATE
6979 || o->op_targ == OP_DBSTATE
6980 || o->op_targ == OP_SETSTATE)
6982 PL_curcop = ((COP*)o);
6984 /* XXX: We avoid setting op_seq here to prevent later calls
6985 to peep() from mistakenly concluding that optimisation
6986 has already occurred. This doesn't fix the real problem,
6987 though (See 20010220.007). AMS 20010719 */
6988 if (oldop && o->op_next) {
6989 oldop->op_next = o->op_next;
6997 if (oldop && o->op_next) {
6998 oldop->op_next = o->op_next;
7001 o->op_seq = PL_op_seqmax++;
7005 if (o->op_next->op_type == OP_RV2SV) {
7006 if (!(o->op_next->op_private & OPpDEREF)) {
7007 op_null(o->op_next);
7008 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7010 o->op_next = o->op_next->op_next;
7011 o->op_type = OP_GVSV;
7012 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7015 else if (o->op_next->op_type == OP_RV2AV) {
7016 OP* pop = o->op_next->op_next;
7018 if (pop->op_type == OP_CONST &&
7019 (PL_op = pop->op_next) &&
7020 pop->op_next->op_type == OP_AELEM &&
7021 !(pop->op_next->op_private &
7022 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7023 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7028 op_null(o->op_next);
7029 op_null(pop->op_next);
7031 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7032 o->op_next = pop->op_next->op_next;
7033 o->op_type = OP_AELEMFAST;
7034 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7035 o->op_private = (U8)i;
7040 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7042 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7043 /* XXX could check prototype here instead of just carping */
7044 SV *sv = sv_newmortal();
7045 gv_efullname3(sv, gv, Nullch);
7046 Perl_warner(aTHX_ WARN_PROTOTYPE,
7047 "%s() called too early to check prototype",
7051 else if (o->op_next->op_type == OP_READLINE
7052 && o->op_next->op_next->op_type == OP_CONCAT
7053 && (o->op_next->op_next->op_flags & OPf_STACKED))
7055 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7056 o->op_type = OP_RCATLINE;
7057 o->op_flags |= OPf_STACKED;
7058 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7059 op_null(o->op_next->op_next);
7060 op_null(o->op_next);
7063 o->op_seq = PL_op_seqmax++;
7074 o->op_seq = PL_op_seqmax++;
7075 while (cLOGOP->op_other->op_type == OP_NULL)
7076 cLOGOP->op_other = cLOGOP->op_other->op_next;
7077 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7082 o->op_seq = PL_op_seqmax++;
7083 while (cLOOP->op_redoop->op_type == OP_NULL)
7084 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7085 peep(cLOOP->op_redoop);
7086 while (cLOOP->op_nextop->op_type == OP_NULL)
7087 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7088 peep(cLOOP->op_nextop);
7089 while (cLOOP->op_lastop->op_type == OP_NULL)
7090 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7091 peep(cLOOP->op_lastop);
7097 o->op_seq = PL_op_seqmax++;
7098 while (cPMOP->op_pmreplstart &&
7099 cPMOP->op_pmreplstart->op_type == OP_NULL)
7100 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7101 peep(cPMOP->op_pmreplstart);
7105 o->op_seq = PL_op_seqmax++;
7106 if (ckWARN(WARN_SYNTAX) && o->op_next
7107 && o->op_next->op_type == OP_NEXTSTATE) {
7108 if (o->op_next->op_sibling &&
7109 o->op_next->op_sibling->op_type != OP_EXIT &&
7110 o->op_next->op_sibling->op_type != OP_WARN &&
7111 o->op_next->op_sibling->op_type != OP_DIE) {
7112 line_t oldline = CopLINE(PL_curcop);
7114 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7115 Perl_warner(aTHX_ WARN_EXEC,
7116 "Statement unlikely to be reached");
7117 Perl_warner(aTHX_ WARN_EXEC,
7118 "\t(Maybe you meant system() when you said exec()?)\n");
7119 CopLINE_set(PL_curcop, oldline);
7128 SV **svp, **indsvp, *sv;
7133 o->op_seq = PL_op_seqmax++;
7135 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7138 /* Make the CONST have a shared SV */
7139 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7140 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7141 key = SvPV(sv, keylen);
7142 lexname = newSVpvn_share(key,
7143 SvUTF8(sv) ? -(I32)keylen : keylen,
7149 if ((o->op_private & (OPpLVAL_INTRO)))
7152 rop = (UNOP*)((BINOP*)o)->op_first;
7153 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7155 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7156 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7158 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7159 if (!fields || !GvHV(*fields))
7161 key = SvPV(*svp, keylen);
7162 indsvp = hv_fetch(GvHV(*fields), key,
7163 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7165 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7166 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7168 ind = SvIV(*indsvp);
7170 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7171 rop->op_type = OP_RV2AV;
7172 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7173 o->op_type = OP_AELEM;
7174 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7176 if (SvREADONLY(*svp))
7178 SvFLAGS(sv) |= (SvFLAGS(*svp)
7179 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7189 SV **svp, **indsvp, *sv;
7193 SVOP *first_key_op, *key_op;
7195 o->op_seq = PL_op_seqmax++;
7196 if ((o->op_private & (OPpLVAL_INTRO))
7197 /* I bet there's always a pushmark... */
7198 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7199 /* hmmm, no optimization if list contains only one key. */
7201 rop = (UNOP*)((LISTOP*)o)->op_last;
7202 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7204 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7205 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7207 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7208 if (!fields || !GvHV(*fields))
7210 /* Again guessing that the pushmark can be jumped over.... */
7211 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7212 ->op_first->op_sibling;
7213 /* Check that the key list contains only constants. */
7214 for (key_op = first_key_op; key_op;
7215 key_op = (SVOP*)key_op->op_sibling)
7216 if (key_op->op_type != OP_CONST)
7220 rop->op_type = OP_RV2AV;
7221 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7222 o->op_type = OP_ASLICE;
7223 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7224 for (key_op = first_key_op; key_op;
7225 key_op = (SVOP*)key_op->op_sibling) {
7226 svp = cSVOPx_svp(key_op);
7227 key = SvPV(*svp, keylen);
7228 indsvp = hv_fetch(GvHV(*fields), key,
7229 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7231 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7232 "in variable %s of type %s",
7233 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7235 ind = SvIV(*indsvp);
7237 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7239 if (SvREADONLY(*svp))
7241 SvFLAGS(sv) |= (SvFLAGS(*svp)
7242 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7250 o->op_seq = PL_op_seqmax++;
7260 char* Perl_custom_op_name(pTHX_ OP* o)
7262 IV index = PTR2IV(o->op_ppaddr);
7266 if (!PL_custom_op_names) /* This probably shouldn't happen */
7267 return PL_op_name[OP_CUSTOM];
7269 keysv = sv_2mortal(newSViv(index));
7271 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7273 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7275 return SvPV_nolen(HeVAL(he));
7278 char* Perl_custom_op_desc(pTHX_ OP* o)
7280 IV index = PTR2IV(o->op_ppaddr);
7284 if (!PL_custom_op_descs)
7285 return PL_op_desc[OP_CUSTOM];
7287 keysv = sv_2mortal(newSViv(index));
7289 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7291 return PL_op_desc[OP_CUSTOM];
7293 return SvPV_nolen(HeVAL(he));
7299 /* Efficient sub that returns a constant scalar value. */
7301 const_sv_xsub(pTHX_ CV* cv)
7306 Perl_croak(aTHX_ "usage: %s::%s()",
7307 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7311 ST(0) = (SV*)XSANY.any_ptr;