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 if (DO_UTF8(pat) || (PL_hints & HINT_UTF8))
3131 pm->op_pmdynflags |= PMdf_UTF8;
3132 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3133 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3134 pm->op_pmflags |= PMf_WHITE;
3138 if (PL_hints & HINT_UTF8)
3139 pm->op_pmdynflags |= PMdf_UTF8;
3140 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3141 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3143 : OP_REGCMAYBE),0,expr);
3145 NewOp(1101, rcop, 1, LOGOP);
3146 rcop->op_type = OP_REGCOMP;
3147 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3148 rcop->op_first = scalar(expr);
3149 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3150 ? (OPf_SPECIAL | OPf_KIDS)
3152 rcop->op_private = 1;
3155 /* establish postfix order */
3156 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3158 rcop->op_next = expr;
3159 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3162 rcop->op_next = LINKLIST(expr);
3163 expr->op_next = (OP*)rcop;
3166 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3171 if (pm->op_pmflags & PMf_EVAL) {
3173 if (CopLINE(PL_curcop) < PL_multi_end)
3174 CopLINE_set(PL_curcop, PL_multi_end);
3176 #ifdef USE_5005THREADS
3177 else if (repl->op_type == OP_THREADSV
3178 && strchr("&`'123456789+",
3179 PL_threadsv_names[repl->op_targ]))
3183 #endif /* USE_5005THREADS */
3184 else if (repl->op_type == OP_CONST)
3188 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3189 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3190 #ifdef USE_5005THREADS
3191 if (curop->op_type == OP_THREADSV) {
3193 if (strchr("&`'123456789+", curop->op_private))
3197 if (curop->op_type == OP_GV) {
3198 GV *gv = cGVOPx_gv(curop);
3200 if (strchr("&`'123456789+", *GvENAME(gv)))
3203 #endif /* USE_5005THREADS */
3204 else if (curop->op_type == OP_RV2CV)
3206 else if (curop->op_type == OP_RV2SV ||
3207 curop->op_type == OP_RV2AV ||
3208 curop->op_type == OP_RV2HV ||
3209 curop->op_type == OP_RV2GV) {
3210 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3213 else if (curop->op_type == OP_PADSV ||
3214 curop->op_type == OP_PADAV ||
3215 curop->op_type == OP_PADHV ||
3216 curop->op_type == OP_PADANY) {
3219 else if (curop->op_type == OP_PUSHRE)
3220 ; /* Okay here, dangerous in newASSIGNOP */
3230 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3231 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3232 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3233 prepend_elem(o->op_type, scalar(repl), o);
3236 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3237 pm->op_pmflags |= PMf_MAYBE_CONST;
3238 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3240 NewOp(1101, rcop, 1, LOGOP);
3241 rcop->op_type = OP_SUBSTCONT;
3242 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3243 rcop->op_first = scalar(repl);
3244 rcop->op_flags |= OPf_KIDS;
3245 rcop->op_private = 1;
3248 /* establish postfix order */
3249 rcop->op_next = LINKLIST(repl);
3250 repl->op_next = (OP*)rcop;
3252 pm->op_pmreplroot = scalar((OP*)rcop);
3253 pm->op_pmreplstart = LINKLIST(rcop);
3262 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3265 NewOp(1101, svop, 1, SVOP);
3266 svop->op_type = type;
3267 svop->op_ppaddr = PL_ppaddr[type];
3269 svop->op_next = (OP*)svop;
3270 svop->op_flags = flags;
3271 if (PL_opargs[type] & OA_RETSCALAR)
3273 if (PL_opargs[type] & OA_TARGET)
3274 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3275 return CHECKOP(type, svop);
3279 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3282 NewOp(1101, padop, 1, PADOP);
3283 padop->op_type = type;
3284 padop->op_ppaddr = PL_ppaddr[type];
3285 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3286 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3287 PL_curpad[padop->op_padix] = sv;
3289 padop->op_next = (OP*)padop;
3290 padop->op_flags = flags;
3291 if (PL_opargs[type] & OA_RETSCALAR)
3293 if (PL_opargs[type] & OA_TARGET)
3294 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3295 return CHECKOP(type, padop);
3299 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3303 return newPADOP(type, flags, SvREFCNT_inc(gv));
3305 return newSVOP(type, flags, SvREFCNT_inc(gv));
3310 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3313 NewOp(1101, pvop, 1, PVOP);
3314 pvop->op_type = type;
3315 pvop->op_ppaddr = PL_ppaddr[type];
3317 pvop->op_next = (OP*)pvop;
3318 pvop->op_flags = flags;
3319 if (PL_opargs[type] & OA_RETSCALAR)
3321 if (PL_opargs[type] & OA_TARGET)
3322 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3323 return CHECKOP(type, pvop);
3327 Perl_package(pTHX_ OP *o)
3331 save_hptr(&PL_curstash);
3332 save_item(PL_curstname);
3337 name = SvPV(sv, len);
3338 PL_curstash = gv_stashpvn(name,len,TRUE);
3339 sv_setpvn(PL_curstname, name, len);
3343 deprecate("\"package\" with no arguments");
3344 sv_setpv(PL_curstname,"<none>");
3345 PL_curstash = Nullhv;
3347 PL_hints |= HINT_BLOCK_SCOPE;
3348 PL_copline = NOLINE;
3353 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3358 char *packname = Nullch;
3362 if (id->op_type != OP_CONST)
3363 Perl_croak(aTHX_ "Module name must be constant");
3367 if (version != Nullop) {
3368 SV *vesv = ((SVOP*)version)->op_sv;
3370 if (arg == Nullop && !SvNIOKp(vesv)) {
3377 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3378 Perl_croak(aTHX_ "Version number must be constant number");
3380 /* Make copy of id so we don't free it twice */
3381 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3383 /* Fake up a method call to VERSION */
3384 meth = newSVpvn("VERSION",7);
3385 sv_upgrade(meth, SVt_PVIV);
3386 (void)SvIOK_on(meth);
3387 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3388 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3389 append_elem(OP_LIST,
3390 prepend_elem(OP_LIST, pack, list(version)),
3391 newSVOP(OP_METHOD_NAMED, 0, meth)));
3395 /* Fake up an import/unimport */
3396 if (arg && arg->op_type == OP_STUB)
3397 imop = arg; /* no import on explicit () */
3398 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3399 imop = Nullop; /* use 5.0; */
3404 /* Make copy of id so we don't free it twice */
3405 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3407 /* Fake up a method call to import/unimport */
3408 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3409 (void)SvUPGRADE(meth, SVt_PVIV);
3410 (void)SvIOK_on(meth);
3411 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3412 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3413 append_elem(OP_LIST,
3414 prepend_elem(OP_LIST, pack, list(arg)),
3415 newSVOP(OP_METHOD_NAMED, 0, meth)));
3418 if (ckWARN(WARN_MISC) &&
3419 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3420 SvPOK(packsv = ((SVOP*)id)->op_sv))
3422 /* BEGIN will free the ops, so we need to make a copy */
3423 packlen = SvCUR(packsv);
3424 packname = savepvn(SvPVX(packsv), packlen);
3427 /* Fake up the BEGIN {}, which does its thing immediately. */
3429 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3432 append_elem(OP_LINESEQ,
3433 append_elem(OP_LINESEQ,
3434 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3435 newSTATEOP(0, Nullch, veop)),
3436 newSTATEOP(0, Nullch, imop) ));
3439 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3440 Perl_warner(aTHX_ WARN_MISC,
3441 "Package `%s' not found "
3442 "(did you use the incorrect case?)", packname);
3447 PL_hints |= HINT_BLOCK_SCOPE;
3448 PL_copline = NOLINE;
3453 =for apidoc load_module
3455 Loads the module whose name is pointed to by the string part of name.
3456 Note that the actual module name, not its filename, should be given.
3457 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3458 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3459 (or 0 for no flags). ver, if specified, provides version semantics
3460 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3461 arguments can be used to specify arguments to the module's import()
3462 method, similar to C<use Foo::Bar VERSION LIST>.
3467 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3470 va_start(args, ver);
3471 vload_module(flags, name, ver, &args);
3475 #ifdef PERL_IMPLICIT_CONTEXT
3477 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3481 va_start(args, ver);
3482 vload_module(flags, name, ver, &args);
3488 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3490 OP *modname, *veop, *imop;
3492 modname = newSVOP(OP_CONST, 0, name);
3493 modname->op_private |= OPpCONST_BARE;
3495 veop = newSVOP(OP_CONST, 0, ver);
3499 if (flags & PERL_LOADMOD_NOIMPORT) {
3500 imop = sawparens(newNULLLIST());
3502 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3503 imop = va_arg(*args, OP*);
3508 sv = va_arg(*args, SV*);
3510 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3511 sv = va_arg(*args, SV*);
3515 line_t ocopline = PL_copline;
3516 int oexpect = PL_expect;
3518 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3519 veop, modname, imop);
3520 PL_expect = oexpect;
3521 PL_copline = ocopline;
3526 Perl_dofile(pTHX_ OP *term)
3531 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3532 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3533 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3535 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3536 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3537 append_elem(OP_LIST, term,
3538 scalar(newUNOP(OP_RV2CV, 0,
3543 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3549 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3551 return newBINOP(OP_LSLICE, flags,
3552 list(force_list(subscript)),
3553 list(force_list(listval)) );
3557 S_list_assignment(pTHX_ register OP *o)
3562 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3563 o = cUNOPo->op_first;
3565 if (o->op_type == OP_COND_EXPR) {
3566 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3567 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3572 yyerror("Assignment to both a list and a scalar");
3576 if (o->op_type == OP_LIST &&
3577 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3578 o->op_private & OPpLVAL_INTRO)
3581 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3582 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3583 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3586 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3589 if (o->op_type == OP_RV2SV)
3596 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3601 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3602 return newLOGOP(optype, 0,
3603 mod(scalar(left), optype),
3604 newUNOP(OP_SASSIGN, 0, scalar(right)));
3607 return newBINOP(optype, OPf_STACKED,
3608 mod(scalar(left), optype), scalar(right));
3612 if (list_assignment(left)) {
3616 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3617 left = mod(left, OP_AASSIGN);
3625 curop = list(force_list(left));
3626 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3627 o->op_private = 0 | (flags >> 8);
3628 for (curop = ((LISTOP*)curop)->op_first;
3629 curop; curop = curop->op_sibling)
3631 if (curop->op_type == OP_RV2HV &&
3632 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3633 o->op_private |= OPpASSIGN_HASH;
3637 if (!(left->op_private & OPpLVAL_INTRO)) {
3640 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3641 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3642 if (curop->op_type == OP_GV) {
3643 GV *gv = cGVOPx_gv(curop);
3644 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3646 SvCUR(gv) = PL_generation;
3648 else if (curop->op_type == OP_PADSV ||
3649 curop->op_type == OP_PADAV ||
3650 curop->op_type == OP_PADHV ||
3651 curop->op_type == OP_PADANY) {
3652 SV **svp = AvARRAY(PL_comppad_name);
3653 SV *sv = svp[curop->op_targ];
3654 if (SvCUR(sv) == PL_generation)
3656 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3658 else if (curop->op_type == OP_RV2CV)
3660 else if (curop->op_type == OP_RV2SV ||
3661 curop->op_type == OP_RV2AV ||
3662 curop->op_type == OP_RV2HV ||
3663 curop->op_type == OP_RV2GV) {
3664 if (lastop->op_type != OP_GV) /* funny deref? */
3667 else if (curop->op_type == OP_PUSHRE) {
3668 if (((PMOP*)curop)->op_pmreplroot) {
3670 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3672 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3674 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3676 SvCUR(gv) = PL_generation;
3685 o->op_private |= OPpASSIGN_COMMON;
3687 if (right && right->op_type == OP_SPLIT) {
3689 if ((tmpop = ((LISTOP*)right)->op_first) &&
3690 tmpop->op_type == OP_PUSHRE)
3692 PMOP *pm = (PMOP*)tmpop;
3693 if (left->op_type == OP_RV2AV &&
3694 !(left->op_private & OPpLVAL_INTRO) &&
3695 !(o->op_private & OPpASSIGN_COMMON) )
3697 tmpop = ((UNOP*)left)->op_first;
3698 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3700 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3701 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3703 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3704 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3706 pm->op_pmflags |= PMf_ONCE;
3707 tmpop = cUNOPo->op_first; /* to list (nulled) */
3708 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3709 tmpop->op_sibling = Nullop; /* don't free split */
3710 right->op_next = tmpop->op_next; /* fix starting loc */
3711 op_free(o); /* blow off assign */
3712 right->op_flags &= ~OPf_WANT;
3713 /* "I don't know and I don't care." */
3718 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3719 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3721 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3723 sv_setiv(sv, PL_modcount+1);
3731 right = newOP(OP_UNDEF, 0);
3732 if (right->op_type == OP_READLINE) {
3733 right->op_flags |= OPf_STACKED;
3734 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3737 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3738 o = newBINOP(OP_SASSIGN, flags,
3739 scalar(right), mod(scalar(left), OP_SASSIGN) );
3751 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3753 U32 seq = intro_my();
3756 NewOp(1101, cop, 1, COP);
3757 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3758 cop->op_type = OP_DBSTATE;
3759 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3762 cop->op_type = OP_NEXTSTATE;
3763 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3765 cop->op_flags = flags;
3766 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3768 cop->op_private |= NATIVE_HINTS;
3770 PL_compiling.op_private = cop->op_private;
3771 cop->op_next = (OP*)cop;
3774 cop->cop_label = label;
3775 PL_hints |= HINT_BLOCK_SCOPE;
3778 cop->cop_arybase = PL_curcop->cop_arybase;
3779 if (specialWARN(PL_curcop->cop_warnings))
3780 cop->cop_warnings = PL_curcop->cop_warnings ;
3782 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3783 if (specialCopIO(PL_curcop->cop_io))
3784 cop->cop_io = PL_curcop->cop_io;
3786 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3789 if (PL_copline == NOLINE)
3790 CopLINE_set(cop, CopLINE(PL_curcop));
3792 CopLINE_set(cop, PL_copline);
3793 PL_copline = NOLINE;
3796 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3798 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3800 CopSTASH_set(cop, PL_curstash);
3802 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3803 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3804 if (svp && *svp != &PL_sv_undef ) {
3805 (void)SvIOK_on(*svp);
3806 SvIVX(*svp) = PTR2IV(cop);
3810 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3813 /* "Introduce" my variables to visible status. */
3821 if (! PL_min_intro_pending)
3822 return PL_cop_seqmax;
3824 svp = AvARRAY(PL_comppad_name);
3825 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3826 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3827 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3828 SvNVX(sv) = (NV)PL_cop_seqmax;
3831 PL_min_intro_pending = 0;
3832 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3833 return PL_cop_seqmax++;
3837 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3839 return new_logop(type, flags, &first, &other);
3843 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3847 OP *first = *firstp;
3848 OP *other = *otherp;
3850 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3851 return newBINOP(type, flags, scalar(first), scalar(other));
3853 scalarboolean(first);
3854 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3855 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3856 if (type == OP_AND || type == OP_OR) {
3862 first = *firstp = cUNOPo->op_first;
3864 first->op_next = o->op_next;
3865 cUNOPo->op_first = Nullop;
3869 if (first->op_type == OP_CONST) {
3870 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3871 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3872 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3883 else if (first->op_type == OP_WANTARRAY) {
3889 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3890 OP *k1 = ((UNOP*)first)->op_first;
3891 OP *k2 = k1->op_sibling;
3893 switch (first->op_type)
3896 if (k2 && k2->op_type == OP_READLINE
3897 && (k2->op_flags & OPf_STACKED)
3898 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3900 warnop = k2->op_type;
3905 if (k1->op_type == OP_READDIR
3906 || k1->op_type == OP_GLOB
3907 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3908 || k1->op_type == OP_EACH)
3910 warnop = ((k1->op_type == OP_NULL)
3911 ? k1->op_targ : k1->op_type);
3916 line_t oldline = CopLINE(PL_curcop);
3917 CopLINE_set(PL_curcop, PL_copline);
3918 Perl_warner(aTHX_ WARN_MISC,
3919 "Value of %s%s can be \"0\"; test with defined()",
3921 ((warnop == OP_READLINE || warnop == OP_GLOB)
3922 ? " construct" : "() operator"));
3923 CopLINE_set(PL_curcop, oldline);
3930 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3931 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3933 NewOp(1101, logop, 1, LOGOP);
3935 logop->op_type = type;
3936 logop->op_ppaddr = PL_ppaddr[type];
3937 logop->op_first = first;
3938 logop->op_flags = flags | OPf_KIDS;
3939 logop->op_other = LINKLIST(other);
3940 logop->op_private = 1 | (flags >> 8);
3942 /* establish postfix order */
3943 logop->op_next = LINKLIST(first);
3944 first->op_next = (OP*)logop;
3945 first->op_sibling = other;
3947 o = newUNOP(OP_NULL, 0, (OP*)logop);
3954 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3961 return newLOGOP(OP_AND, 0, first, trueop);
3963 return newLOGOP(OP_OR, 0, first, falseop);
3965 scalarboolean(first);
3966 if (first->op_type == OP_CONST) {
3967 if (SvTRUE(((SVOP*)first)->op_sv)) {
3978 else if (first->op_type == OP_WANTARRAY) {
3982 NewOp(1101, logop, 1, LOGOP);
3983 logop->op_type = OP_COND_EXPR;
3984 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3985 logop->op_first = first;
3986 logop->op_flags = flags | OPf_KIDS;
3987 logop->op_private = 1 | (flags >> 8);
3988 logop->op_other = LINKLIST(trueop);
3989 logop->op_next = LINKLIST(falseop);
3992 /* establish postfix order */
3993 start = LINKLIST(first);
3994 first->op_next = (OP*)logop;
3996 first->op_sibling = trueop;
3997 trueop->op_sibling = falseop;
3998 o = newUNOP(OP_NULL, 0, (OP*)logop);
4000 trueop->op_next = falseop->op_next = o;
4007 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4015 NewOp(1101, range, 1, LOGOP);
4017 range->op_type = OP_RANGE;
4018 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4019 range->op_first = left;
4020 range->op_flags = OPf_KIDS;
4021 leftstart = LINKLIST(left);
4022 range->op_other = LINKLIST(right);
4023 range->op_private = 1 | (flags >> 8);
4025 left->op_sibling = right;
4027 range->op_next = (OP*)range;
4028 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4029 flop = newUNOP(OP_FLOP, 0, flip);
4030 o = newUNOP(OP_NULL, 0, flop);
4032 range->op_next = leftstart;
4034 left->op_next = flip;
4035 right->op_next = flop;
4037 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4038 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4039 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4040 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4042 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4043 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4046 if (!flip->op_private || !flop->op_private)
4047 linklist(o); /* blow off optimizer unless constant */
4053 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4057 int once = block && block->op_flags & OPf_SPECIAL &&
4058 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4061 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4062 return block; /* do {} while 0 does once */
4063 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4064 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4065 expr = newUNOP(OP_DEFINED, 0,
4066 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4067 } else if (expr->op_flags & OPf_KIDS) {
4068 OP *k1 = ((UNOP*)expr)->op_first;
4069 OP *k2 = (k1) ? k1->op_sibling : NULL;
4070 switch (expr->op_type) {
4072 if (k2 && k2->op_type == OP_READLINE
4073 && (k2->op_flags & OPf_STACKED)
4074 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4075 expr = newUNOP(OP_DEFINED, 0, expr);
4079 if (k1->op_type == OP_READDIR
4080 || k1->op_type == OP_GLOB
4081 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4082 || k1->op_type == OP_EACH)
4083 expr = newUNOP(OP_DEFINED, 0, expr);
4089 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4090 o = new_logop(OP_AND, 0, &expr, &listop);
4093 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4095 if (once && o != listop)
4096 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4099 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4101 o->op_flags |= flags;
4103 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4108 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4116 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4117 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4118 expr = newUNOP(OP_DEFINED, 0,
4119 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4120 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4121 OP *k1 = ((UNOP*)expr)->op_first;
4122 OP *k2 = (k1) ? k1->op_sibling : NULL;
4123 switch (expr->op_type) {
4125 if (k2 && k2->op_type == OP_READLINE
4126 && (k2->op_flags & OPf_STACKED)
4127 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4128 expr = newUNOP(OP_DEFINED, 0, expr);
4132 if (k1->op_type == OP_READDIR
4133 || k1->op_type == OP_GLOB
4134 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4135 || k1->op_type == OP_EACH)
4136 expr = newUNOP(OP_DEFINED, 0, expr);
4142 block = newOP(OP_NULL, 0);
4144 block = scope(block);
4148 next = LINKLIST(cont);
4151 OP *unstack = newOP(OP_UNSTACK, 0);
4154 cont = append_elem(OP_LINESEQ, cont, unstack);
4155 if ((line_t)whileline != NOLINE) {
4156 PL_copline = whileline;
4157 cont = append_elem(OP_LINESEQ, cont,
4158 newSTATEOP(0, Nullch, Nullop));
4162 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4163 redo = LINKLIST(listop);
4166 PL_copline = whileline;
4168 o = new_logop(OP_AND, 0, &expr, &listop);
4169 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4170 op_free(expr); /* oops, it's a while (0) */
4172 return Nullop; /* listop already freed by new_logop */
4175 ((LISTOP*)listop)->op_last->op_next =
4176 (o == listop ? redo : LINKLIST(o));
4182 NewOp(1101,loop,1,LOOP);
4183 loop->op_type = OP_ENTERLOOP;
4184 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4185 loop->op_private = 0;
4186 loop->op_next = (OP*)loop;
4189 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4191 loop->op_redoop = redo;
4192 loop->op_lastop = o;
4193 o->op_private |= loopflags;
4196 loop->op_nextop = next;
4198 loop->op_nextop = o;
4200 o->op_flags |= flags;
4201 o->op_private |= (flags >> 8);
4206 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4214 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4215 sv->op_type = OP_RV2GV;
4216 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4218 else if (sv->op_type == OP_PADSV) { /* private variable */
4219 padoff = sv->op_targ;
4224 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4225 padoff = sv->op_targ;
4227 iterflags |= OPf_SPECIAL;
4232 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4235 #ifdef USE_5005THREADS
4236 padoff = find_threadsv("_");
4237 iterflags |= OPf_SPECIAL;
4239 sv = newGVOP(OP_GV, 0, PL_defgv);
4242 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4243 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4244 iterflags |= OPf_STACKED;
4246 else if (expr->op_type == OP_NULL &&
4247 (expr->op_flags & OPf_KIDS) &&
4248 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4250 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4251 * set the STACKED flag to indicate that these values are to be
4252 * treated as min/max values by 'pp_iterinit'.
4254 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4255 LOGOP* range = (LOGOP*) flip->op_first;
4256 OP* left = range->op_first;
4257 OP* right = left->op_sibling;
4260 range->op_flags &= ~OPf_KIDS;
4261 range->op_first = Nullop;
4263 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4264 listop->op_first->op_next = range->op_next;
4265 left->op_next = range->op_other;
4266 right->op_next = (OP*)listop;
4267 listop->op_next = listop->op_first;
4270 expr = (OP*)(listop);
4272 iterflags |= OPf_STACKED;
4275 expr = mod(force_list(expr), OP_GREPSTART);
4279 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4280 append_elem(OP_LIST, expr, scalar(sv))));
4281 assert(!loop->op_next);
4282 #ifdef PL_OP_SLAB_ALLOC
4285 NewOp(1234,tmp,1,LOOP);
4286 Copy(loop,tmp,1,LOOP);
4290 Renew(loop, 1, LOOP);
4292 loop->op_targ = padoff;
4293 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4294 PL_copline = forline;
4295 return newSTATEOP(0, label, wop);
4299 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4304 if (type != OP_GOTO || label->op_type == OP_CONST) {
4305 /* "last()" means "last" */
4306 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4307 o = newOP(type, OPf_SPECIAL);
4309 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4310 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4316 if (label->op_type == OP_ENTERSUB)
4317 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4318 o = newUNOP(type, OPf_STACKED, label);
4320 PL_hints |= HINT_BLOCK_SCOPE;
4325 Perl_cv_undef(pTHX_ CV *cv)
4327 #ifdef USE_5005THREADS
4329 MUTEX_DESTROY(CvMUTEXP(cv));
4330 Safefree(CvMUTEXP(cv));
4333 #endif /* USE_5005THREADS */
4336 if (CvFILE(cv) && !CvXSUB(cv)) {
4337 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4338 Safefree(CvFILE(cv));
4343 if (!CvXSUB(cv) && CvROOT(cv)) {
4344 #ifdef USE_5005THREADS
4345 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4346 Perl_croak(aTHX_ "Can't undef active subroutine");
4349 Perl_croak(aTHX_ "Can't undef active subroutine");
4350 #endif /* USE_5005THREADS */
4353 SAVEVPTR(PL_curpad);
4356 op_free(CvROOT(cv));
4357 CvROOT(cv) = Nullop;
4360 SvPOK_off((SV*)cv); /* forget prototype */
4362 /* Since closure prototypes have the same lifetime as the containing
4363 * CV, they don't hold a refcount on the outside CV. This avoids
4364 * the refcount loop between the outer CV (which keeps a refcount to
4365 * the closure prototype in the pad entry for pp_anoncode()) and the
4366 * closure prototype, and the ensuing memory leak. --GSAR */
4367 if (!CvANON(cv) || CvCLONED(cv))
4368 SvREFCNT_dec(CvOUTSIDE(cv));
4369 CvOUTSIDE(cv) = Nullcv;
4371 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4374 if (CvPADLIST(cv)) {
4375 /* may be during global destruction */
4376 if (SvREFCNT(CvPADLIST(cv))) {
4377 I32 i = AvFILLp(CvPADLIST(cv));
4379 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4380 SV* sv = svp ? *svp : Nullsv;
4383 if (sv == (SV*)PL_comppad_name)
4384 PL_comppad_name = Nullav;
4385 else if (sv == (SV*)PL_comppad) {
4386 PL_comppad = Nullav;
4387 PL_curpad = Null(SV**);
4391 SvREFCNT_dec((SV*)CvPADLIST(cv));
4393 CvPADLIST(cv) = Nullav;
4401 #ifdef DEBUG_CLOSURES
4403 S_cv_dump(pTHX_ CV *cv)
4406 CV *outside = CvOUTSIDE(cv);
4407 AV* padlist = CvPADLIST(cv);
4414 PerlIO_printf(Perl_debug_log,
4415 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4417 (CvANON(cv) ? "ANON"
4418 : (cv == PL_main_cv) ? "MAIN"
4419 : CvUNIQUE(cv) ? "UNIQUE"
4420 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4423 : CvANON(outside) ? "ANON"
4424 : (outside == PL_main_cv) ? "MAIN"
4425 : CvUNIQUE(outside) ? "UNIQUE"
4426 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4431 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4432 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4433 pname = AvARRAY(pad_name);
4434 ppad = AvARRAY(pad);
4436 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4437 if (SvPOK(pname[ix]))
4438 PerlIO_printf(Perl_debug_log,
4439 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4440 (int)ix, PTR2UV(ppad[ix]),
4441 SvFAKE(pname[ix]) ? "FAKE " : "",
4443 (IV)I_32(SvNVX(pname[ix])),
4446 #endif /* DEBUGGING */
4448 #endif /* DEBUG_CLOSURES */
4451 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4455 AV* protopadlist = CvPADLIST(proto);
4456 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4457 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4458 SV** pname = AvARRAY(protopad_name);
4459 SV** ppad = AvARRAY(protopad);
4460 I32 fname = AvFILLp(protopad_name);
4461 I32 fpad = AvFILLp(protopad);
4465 assert(!CvUNIQUE(proto));
4469 SAVESPTR(PL_comppad_name);
4470 SAVESPTR(PL_compcv);
4472 cv = PL_compcv = (CV*)NEWSV(1104,0);
4473 sv_upgrade((SV *)cv, SvTYPE(proto));
4474 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4477 #ifdef USE_5005THREADS
4478 New(666, CvMUTEXP(cv), 1, perl_mutex);
4479 MUTEX_INIT(CvMUTEXP(cv));
4481 #endif /* USE_5005THREADS */
4483 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4484 : savepv(CvFILE(proto));
4486 CvFILE(cv) = CvFILE(proto);
4488 CvGV(cv) = CvGV(proto);
4489 CvSTASH(cv) = CvSTASH(proto);
4490 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4491 CvSTART(cv) = CvSTART(proto);
4493 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4496 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4498 PL_comppad_name = newAV();
4499 for (ix = fname; ix >= 0; ix--)
4500 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4502 PL_comppad = newAV();
4504 comppadlist = newAV();
4505 AvREAL_off(comppadlist);
4506 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4507 av_store(comppadlist, 1, (SV*)PL_comppad);
4508 CvPADLIST(cv) = comppadlist;
4509 av_fill(PL_comppad, AvFILLp(protopad));
4510 PL_curpad = AvARRAY(PL_comppad);
4512 av = newAV(); /* will be @_ */
4514 av_store(PL_comppad, 0, (SV*)av);
4515 AvFLAGS(av) = AVf_REIFY;
4517 for (ix = fpad; ix > 0; ix--) {
4518 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4519 if (namesv && namesv != &PL_sv_undef) {
4520 char *name = SvPVX(namesv); /* XXX */
4521 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4522 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4523 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4525 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4527 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4529 else { /* our own lexical */
4532 /* anon code -- we'll come back for it */
4533 sv = SvREFCNT_inc(ppad[ix]);
4535 else if (*name == '@')
4537 else if (*name == '%')
4546 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4547 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4550 SV* sv = NEWSV(0,0);
4556 /* Now that vars are all in place, clone nested closures. */
4558 for (ix = fpad; ix > 0; ix--) {
4559 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4561 && namesv != &PL_sv_undef
4562 && !(SvFLAGS(namesv) & SVf_FAKE)
4563 && *SvPVX(namesv) == '&'
4564 && CvCLONE(ppad[ix]))
4566 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4567 SvREFCNT_dec(ppad[ix]);
4570 PL_curpad[ix] = (SV*)kid;
4574 #ifdef DEBUG_CLOSURES
4575 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4577 PerlIO_printf(Perl_debug_log, " from:\n");
4579 PerlIO_printf(Perl_debug_log, " to:\n");
4586 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4588 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4590 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4597 Perl_cv_clone(pTHX_ CV *proto)
4600 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4601 cv = cv_clone2(proto, CvOUTSIDE(proto));
4602 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4607 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4609 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4610 SV* msg = sv_newmortal();
4614 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4615 sv_setpv(msg, "Prototype mismatch:");
4617 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4619 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4620 sv_catpv(msg, " vs ");
4622 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4624 sv_catpv(msg, "none");
4625 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4629 static void const_sv_xsub(pTHX_ CV* cv);
4632 =for apidoc cv_const_sv
4634 If C<cv> is a constant sub eligible for inlining. returns the constant
4635 value returned by the sub. Otherwise, returns NULL.
4637 Constant subs can be created with C<newCONSTSUB> or as described in
4638 L<perlsub/"Constant Functions">.
4643 Perl_cv_const_sv(pTHX_ CV *cv)
4645 if (!cv || !CvCONST(cv))
4647 return (SV*)CvXSUBANY(cv).any_ptr;
4651 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4658 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4659 o = cLISTOPo->op_first->op_sibling;
4661 for (; o; o = o->op_next) {
4662 OPCODE type = o->op_type;
4664 if (sv && o->op_next == o)
4666 if (o->op_next != o) {
4667 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4669 if (type == OP_DBSTATE)
4672 if (type == OP_LEAVESUB || type == OP_RETURN)
4676 if (type == OP_CONST && cSVOPo->op_sv)
4678 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4679 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4680 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4684 /* We get here only from cv_clone2() while creating a closure.
4685 Copy the const value here instead of in cv_clone2 so that
4686 SvREADONLY_on doesn't lead to problems when leaving
4691 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4703 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4713 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4717 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4719 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4723 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4729 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4734 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4735 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4736 SV *sv = sv_newmortal();
4737 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4738 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4743 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4744 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4754 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4755 maximum a prototype before. */
4756 if (SvTYPE(gv) > SVt_NULL) {
4757 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4758 && ckWARN_d(WARN_PROTOTYPE))
4760 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4762 cv_ckproto((CV*)gv, NULL, ps);
4765 sv_setpv((SV*)gv, ps);
4767 sv_setiv((SV*)gv, -1);
4768 SvREFCNT_dec(PL_compcv);
4769 cv = PL_compcv = NULL;
4770 PL_sub_generation++;
4774 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4776 #ifdef GV_UNIQUE_CHECK
4777 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4778 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4782 if (!block || !ps || *ps || attrs)
4785 const_sv = op_const_sv(block, Nullcv);
4788 bool exists = CvROOT(cv) || CvXSUB(cv);
4790 #ifdef GV_UNIQUE_CHECK
4791 if (exists && GvUNIQUE(gv)) {
4792 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4796 /* if the subroutine doesn't exist and wasn't pre-declared
4797 * with a prototype, assume it will be AUTOLOADed,
4798 * skipping the prototype check
4800 if (exists || SvPOK(cv))
4801 cv_ckproto(cv, gv, ps);
4802 /* already defined (or promised)? */
4803 if (exists || GvASSUMECV(gv)) {
4804 if (!block && !attrs) {
4805 /* just a "sub foo;" when &foo is already defined */
4806 SAVEFREESV(PL_compcv);
4809 /* ahem, death to those who redefine active sort subs */
4810 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4811 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4813 if (ckWARN(WARN_REDEFINE)
4815 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4817 line_t oldline = CopLINE(PL_curcop);
4818 if (PL_copline != NOLINE)
4819 CopLINE_set(PL_curcop, PL_copline);
4820 Perl_warner(aTHX_ WARN_REDEFINE,
4821 CvCONST(cv) ? "Constant subroutine %s redefined"
4822 : "Subroutine %s redefined", name);
4823 CopLINE_set(PL_curcop, oldline);
4831 SvREFCNT_inc(const_sv);
4833 assert(!CvROOT(cv) && !CvCONST(cv));
4834 sv_setpv((SV*)cv, ""); /* prototype is "" */
4835 CvXSUBANY(cv).any_ptr = const_sv;
4836 CvXSUB(cv) = const_sv_xsub;
4841 cv = newCONSTSUB(NULL, name, const_sv);
4844 SvREFCNT_dec(PL_compcv);
4846 PL_sub_generation++;
4853 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4854 * before we clobber PL_compcv.
4858 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4859 stash = GvSTASH(CvGV(cv));
4860 else if (CvSTASH(cv))
4861 stash = CvSTASH(cv);
4863 stash = PL_curstash;
4866 /* possibly about to re-define existing subr -- ignore old cv */
4867 rcv = (SV*)PL_compcv;
4868 if (name && GvSTASH(gv))
4869 stash = GvSTASH(gv);
4871 stash = PL_curstash;
4873 apply_attrs(stash, rcv, attrs, FALSE);
4875 if (cv) { /* must reuse cv if autoloaded */
4877 /* got here with just attrs -- work done, so bug out */
4878 SAVEFREESV(PL_compcv);
4882 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4883 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4884 CvOUTSIDE(PL_compcv) = 0;
4885 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4886 CvPADLIST(PL_compcv) = 0;
4887 /* inner references to PL_compcv must be fixed up ... */
4889 AV *padlist = CvPADLIST(cv);
4890 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4891 AV *comppad = (AV*)AvARRAY(padlist)[1];
4892 SV **namepad = AvARRAY(comppad_name);
4893 SV **curpad = AvARRAY(comppad);
4894 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4895 SV *namesv = namepad[ix];
4896 if (namesv && namesv != &PL_sv_undef
4897 && *SvPVX(namesv) == '&')
4899 CV *innercv = (CV*)curpad[ix];
4900 if (CvOUTSIDE(innercv) == PL_compcv) {
4901 CvOUTSIDE(innercv) = cv;
4902 if (!CvANON(innercv) || CvCLONED(innercv)) {
4903 (void)SvREFCNT_inc(cv);
4904 SvREFCNT_dec(PL_compcv);
4910 /* ... before we throw it away */
4911 SvREFCNT_dec(PL_compcv);
4912 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4913 ++PL_sub_generation;
4920 PL_sub_generation++;
4924 CvFILE_set_from_cop(cv, PL_curcop);
4925 CvSTASH(cv) = PL_curstash;
4926 #ifdef USE_5005THREADS
4928 if (!CvMUTEXP(cv)) {
4929 New(666, CvMUTEXP(cv), 1, perl_mutex);
4930 MUTEX_INIT(CvMUTEXP(cv));
4932 #endif /* USE_5005THREADS */
4935 sv_setpv((SV*)cv, ps);
4937 if (PL_error_count) {
4941 char *s = strrchr(name, ':');
4943 if (strEQ(s, "BEGIN")) {
4945 "BEGIN not safe after errors--compilation aborted";
4946 if (PL_in_eval & EVAL_KEEPERR)
4947 Perl_croak(aTHX_ not_safe);
4949 /* force display of errors found but not reported */
4950 sv_catpv(ERRSV, not_safe);
4951 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4959 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4960 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4963 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4964 mod(scalarseq(block), OP_LEAVESUBLV));
4967 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4969 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4970 OpREFCNT_set(CvROOT(cv), 1);
4971 CvSTART(cv) = LINKLIST(CvROOT(cv));
4972 CvROOT(cv)->op_next = 0;
4973 CALL_PEEP(CvSTART(cv));
4975 /* now that optimizer has done its work, adjust pad values */
4977 SV **namep = AvARRAY(PL_comppad_name);
4978 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4981 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4984 * The only things that a clonable function needs in its
4985 * pad are references to outer lexicals and anonymous subs.
4986 * The rest are created anew during cloning.
4988 if (!((namesv = namep[ix]) != Nullsv &&
4989 namesv != &PL_sv_undef &&
4991 *SvPVX(namesv) == '&')))
4993 SvREFCNT_dec(PL_curpad[ix]);
4994 PL_curpad[ix] = Nullsv;
4997 assert(!CvCONST(cv));
4998 if (ps && !*ps && op_const_sv(block, cv))
5002 AV *av = newAV(); /* Will be @_ */
5004 av_store(PL_comppad, 0, (SV*)av);
5005 AvFLAGS(av) = AVf_REIFY;
5007 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5008 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5010 if (!SvPADMY(PL_curpad[ix]))
5011 SvPADTMP_on(PL_curpad[ix]);
5015 /* If a potential closure prototype, don't keep a refcount on outer CV.
5016 * This is okay as the lifetime of the prototype is tied to the
5017 * lifetime of the outer CV. Avoids memory leak due to reference
5020 SvREFCNT_dec(CvOUTSIDE(cv));
5022 if (name || aname) {
5024 char *tname = (name ? name : aname);
5026 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5027 SV *sv = NEWSV(0,0);
5028 SV *tmpstr = sv_newmortal();
5029 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5033 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5035 (long)PL_subline, (long)CopLINE(PL_curcop));
5036 gv_efullname3(tmpstr, gv, Nullch);
5037 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5038 hv = GvHVn(db_postponed);
5039 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5040 && (pcv = GvCV(db_postponed)))
5046 call_sv((SV*)pcv, G_DISCARD);
5050 if ((s = strrchr(tname,':')))
5055 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5058 if (strEQ(s, "BEGIN")) {
5059 I32 oldscope = PL_scopestack_ix;
5061 SAVECOPFILE(&PL_compiling);
5062 SAVECOPLINE(&PL_compiling);
5065 PL_beginav = newAV();
5066 DEBUG_x( dump_sub(gv) );
5067 av_push(PL_beginav, (SV*)cv);
5068 GvCV(gv) = 0; /* cv has been hijacked */
5069 call_list(oldscope, PL_beginav);
5071 PL_curcop = &PL_compiling;
5072 PL_compiling.op_private = PL_hints;
5075 else if (strEQ(s, "END") && !PL_error_count) {
5078 DEBUG_x( dump_sub(gv) );
5079 av_unshift(PL_endav, 1);
5080 av_store(PL_endav, 0, (SV*)cv);
5081 GvCV(gv) = 0; /* cv has been hijacked */
5083 else if (strEQ(s, "CHECK") && !PL_error_count) {
5085 PL_checkav = newAV();
5086 DEBUG_x( dump_sub(gv) );
5087 if (PL_main_start && ckWARN(WARN_VOID))
5088 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5089 av_unshift(PL_checkav, 1);
5090 av_store(PL_checkav, 0, (SV*)cv);
5091 GvCV(gv) = 0; /* cv has been hijacked */
5093 else if (strEQ(s, "INIT") && !PL_error_count) {
5095 PL_initav = newAV();
5096 DEBUG_x( dump_sub(gv) );
5097 if (PL_main_start && ckWARN(WARN_VOID))
5098 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5099 av_push(PL_initav, (SV*)cv);
5100 GvCV(gv) = 0; /* cv has been hijacked */
5105 PL_copline = NOLINE;
5110 /* XXX unsafe for threads if eval_owner isn't held */
5112 =for apidoc newCONSTSUB
5114 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5115 eligible for inlining at compile-time.
5121 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5127 SAVECOPLINE(PL_curcop);
5128 CopLINE_set(PL_curcop, PL_copline);
5131 PL_hints &= ~HINT_BLOCK_SCOPE;
5134 SAVESPTR(PL_curstash);
5135 SAVECOPSTASH(PL_curcop);
5136 PL_curstash = stash;
5138 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5140 CopSTASH(PL_curcop) = stash;
5144 cv = newXS(name, const_sv_xsub, __FILE__);
5145 CvXSUBANY(cv).any_ptr = sv;
5147 sv_setpv((SV*)cv, ""); /* prototype is "" */
5155 =for apidoc U||newXS
5157 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5163 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5165 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5168 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5170 /* just a cached method */
5174 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5175 /* already defined (or promised) */
5176 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5177 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5178 line_t oldline = CopLINE(PL_curcop);
5179 if (PL_copline != NOLINE)
5180 CopLINE_set(PL_curcop, PL_copline);
5181 Perl_warner(aTHX_ WARN_REDEFINE,
5182 CvCONST(cv) ? "Constant subroutine %s redefined"
5183 : "Subroutine %s redefined"
5185 CopLINE_set(PL_curcop, oldline);
5192 if (cv) /* must reuse cv if autoloaded */
5195 cv = (CV*)NEWSV(1105,0);
5196 sv_upgrade((SV *)cv, SVt_PVCV);
5200 PL_sub_generation++;
5204 #ifdef USE_5005THREADS
5205 New(666, CvMUTEXP(cv), 1, perl_mutex);
5206 MUTEX_INIT(CvMUTEXP(cv));
5208 #endif /* USE_5005THREADS */
5209 (void)gv_fetchfile(filename);
5210 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5211 an external constant string */
5212 CvXSUB(cv) = subaddr;
5215 char *s = strrchr(name,':');
5221 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5224 if (strEQ(s, "BEGIN")) {
5226 PL_beginav = newAV();
5227 av_push(PL_beginav, (SV*)cv);
5228 GvCV(gv) = 0; /* cv has been hijacked */
5230 else if (strEQ(s, "END")) {
5233 av_unshift(PL_endav, 1);
5234 av_store(PL_endav, 0, (SV*)cv);
5235 GvCV(gv) = 0; /* cv has been hijacked */
5237 else if (strEQ(s, "CHECK")) {
5239 PL_checkav = newAV();
5240 if (PL_main_start && ckWARN(WARN_VOID))
5241 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5242 av_unshift(PL_checkav, 1);
5243 av_store(PL_checkav, 0, (SV*)cv);
5244 GvCV(gv) = 0; /* cv has been hijacked */
5246 else if (strEQ(s, "INIT")) {
5248 PL_initav = newAV();
5249 if (PL_main_start && ckWARN(WARN_VOID))
5250 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5251 av_push(PL_initav, (SV*)cv);
5252 GvCV(gv) = 0; /* cv has been hijacked */
5263 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5272 name = SvPVx(cSVOPo->op_sv, n_a);
5275 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5276 #ifdef GV_UNIQUE_CHECK
5278 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5282 if ((cv = GvFORM(gv))) {
5283 if (ckWARN(WARN_REDEFINE)) {
5284 line_t oldline = CopLINE(PL_curcop);
5285 if (PL_copline != NOLINE)
5286 CopLINE_set(PL_curcop, PL_copline);
5287 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5288 CopLINE_set(PL_curcop, oldline);
5295 CvFILE_set_from_cop(cv, PL_curcop);
5297 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5298 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5299 SvPADTMP_on(PL_curpad[ix]);
5302 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5303 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5304 OpREFCNT_set(CvROOT(cv), 1);
5305 CvSTART(cv) = LINKLIST(CvROOT(cv));
5306 CvROOT(cv)->op_next = 0;
5307 CALL_PEEP(CvSTART(cv));
5309 PL_copline = NOLINE;
5314 Perl_newANONLIST(pTHX_ OP *o)
5316 return newUNOP(OP_REFGEN, 0,
5317 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5321 Perl_newANONHASH(pTHX_ OP *o)
5323 return newUNOP(OP_REFGEN, 0,
5324 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5328 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5330 return newANONATTRSUB(floor, proto, Nullop, block);
5334 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5336 return newUNOP(OP_REFGEN, 0,
5337 newSVOP(OP_ANONCODE, 0,
5338 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5342 Perl_oopsAV(pTHX_ OP *o)
5344 switch (o->op_type) {
5346 o->op_type = OP_PADAV;
5347 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5348 return ref(o, OP_RV2AV);
5351 o->op_type = OP_RV2AV;
5352 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5357 if (ckWARN_d(WARN_INTERNAL))
5358 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5365 Perl_oopsHV(pTHX_ OP *o)
5367 switch (o->op_type) {
5370 o->op_type = OP_PADHV;
5371 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5372 return ref(o, OP_RV2HV);
5376 o->op_type = OP_RV2HV;
5377 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5382 if (ckWARN_d(WARN_INTERNAL))
5383 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5390 Perl_newAVREF(pTHX_ OP *o)
5392 if (o->op_type == OP_PADANY) {
5393 o->op_type = OP_PADAV;
5394 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5397 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5398 && ckWARN(WARN_DEPRECATED)) {
5399 Perl_warner(aTHX_ WARN_DEPRECATED,
5400 "Using an array as a reference is deprecated");
5402 return newUNOP(OP_RV2AV, 0, scalar(o));
5406 Perl_newGVREF(pTHX_ I32 type, OP *o)
5408 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5409 return newUNOP(OP_NULL, 0, o);
5410 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5414 Perl_newHVREF(pTHX_ OP *o)
5416 if (o->op_type == OP_PADANY) {
5417 o->op_type = OP_PADHV;
5418 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5421 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5422 && ckWARN(WARN_DEPRECATED)) {
5423 Perl_warner(aTHX_ WARN_DEPRECATED,
5424 "Using a hash as a reference is deprecated");
5426 return newUNOP(OP_RV2HV, 0, scalar(o));
5430 Perl_oopsCV(pTHX_ OP *o)
5432 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5438 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5440 return newUNOP(OP_RV2CV, flags, scalar(o));
5444 Perl_newSVREF(pTHX_ OP *o)
5446 if (o->op_type == OP_PADANY) {
5447 o->op_type = OP_PADSV;
5448 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5451 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5452 o->op_flags |= OPpDONE_SVREF;
5455 return newUNOP(OP_RV2SV, 0, scalar(o));
5458 /* Check routines. */
5461 Perl_ck_anoncode(pTHX_ OP *o)
5466 name = NEWSV(1106,0);
5467 sv_upgrade(name, SVt_PVNV);
5468 sv_setpvn(name, "&", 1);
5471 ix = pad_alloc(o->op_type, SVs_PADMY);
5472 av_store(PL_comppad_name, ix, name);
5473 av_store(PL_comppad, ix, cSVOPo->op_sv);
5474 SvPADMY_on(cSVOPo->op_sv);
5475 cSVOPo->op_sv = Nullsv;
5476 cSVOPo->op_targ = ix;
5481 Perl_ck_bitop(pTHX_ OP *o)
5483 o->op_private = PL_hints;
5488 Perl_ck_concat(pTHX_ OP *o)
5490 if (cUNOPo->op_first->op_type == OP_CONCAT)
5491 o->op_flags |= OPf_STACKED;
5496 Perl_ck_spair(pTHX_ OP *o)
5498 if (o->op_flags & OPf_KIDS) {
5501 OPCODE type = o->op_type;
5502 o = modkids(ck_fun(o), type);
5503 kid = cUNOPo->op_first;
5504 newop = kUNOP->op_first->op_sibling;
5506 (newop->op_sibling ||
5507 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5508 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5509 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5513 op_free(kUNOP->op_first);
5514 kUNOP->op_first = newop;
5516 o->op_ppaddr = PL_ppaddr[++o->op_type];
5521 Perl_ck_delete(pTHX_ OP *o)
5525 if (o->op_flags & OPf_KIDS) {
5526 OP *kid = cUNOPo->op_first;
5527 switch (kid->op_type) {
5529 o->op_flags |= OPf_SPECIAL;
5532 o->op_private |= OPpSLICE;
5535 o->op_flags |= OPf_SPECIAL;
5540 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5549 Perl_ck_die(pTHX_ OP *o)
5552 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5558 Perl_ck_eof(pTHX_ OP *o)
5560 I32 type = o->op_type;
5562 if (o->op_flags & OPf_KIDS) {
5563 if (cLISTOPo->op_first->op_type == OP_STUB) {
5565 o = newUNOP(type, OPf_SPECIAL,
5566 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5574 Perl_ck_eval(pTHX_ OP *o)
5576 PL_hints |= HINT_BLOCK_SCOPE;
5577 if (o->op_flags & OPf_KIDS) {
5578 SVOP *kid = (SVOP*)cUNOPo->op_first;
5581 o->op_flags &= ~OPf_KIDS;
5584 else if (kid->op_type == OP_LINESEQ) {
5587 kid->op_next = o->op_next;
5588 cUNOPo->op_first = 0;
5591 NewOp(1101, enter, 1, LOGOP);
5592 enter->op_type = OP_ENTERTRY;
5593 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5594 enter->op_private = 0;
5596 /* establish postfix order */
5597 enter->op_next = (OP*)enter;
5599 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5600 o->op_type = OP_LEAVETRY;
5601 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5602 enter->op_other = o;
5610 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5612 o->op_targ = (PADOFFSET)PL_hints;
5617 Perl_ck_exit(pTHX_ OP *o)
5620 HV *table = GvHV(PL_hintgv);
5622 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5623 if (svp && *svp && SvTRUE(*svp))
5624 o->op_private |= OPpEXIT_VMSISH;
5626 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5632 Perl_ck_exec(pTHX_ OP *o)
5635 if (o->op_flags & OPf_STACKED) {
5637 kid = cUNOPo->op_first->op_sibling;
5638 if (kid->op_type == OP_RV2GV)
5647 Perl_ck_exists(pTHX_ OP *o)
5650 if (o->op_flags & OPf_KIDS) {
5651 OP *kid = cUNOPo->op_first;
5652 if (kid->op_type == OP_ENTERSUB) {
5653 (void) ref(kid, o->op_type);
5654 if (kid->op_type != OP_RV2CV && !PL_error_count)
5655 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5657 o->op_private |= OPpEXISTS_SUB;
5659 else if (kid->op_type == OP_AELEM)
5660 o->op_flags |= OPf_SPECIAL;
5661 else if (kid->op_type != OP_HELEM)
5662 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5671 Perl_ck_gvconst(pTHX_ register OP *o)
5673 o = fold_constants(o);
5674 if (o->op_type == OP_CONST)
5681 Perl_ck_rvconst(pTHX_ register OP *o)
5683 SVOP *kid = (SVOP*)cUNOPo->op_first;
5685 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5686 if (kid->op_type == OP_CONST) {
5690 SV *kidsv = kid->op_sv;
5693 /* Is it a constant from cv_const_sv()? */
5694 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5695 SV *rsv = SvRV(kidsv);
5696 int svtype = SvTYPE(rsv);
5697 char *badtype = Nullch;
5699 switch (o->op_type) {
5701 if (svtype > SVt_PVMG)
5702 badtype = "a SCALAR";
5705 if (svtype != SVt_PVAV)
5706 badtype = "an ARRAY";
5709 if (svtype != SVt_PVHV) {
5710 if (svtype == SVt_PVAV) { /* pseudohash? */
5711 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5712 if (ksv && SvROK(*ksv)
5713 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5722 if (svtype != SVt_PVCV)
5727 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5730 name = SvPV(kidsv, n_a);
5731 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5732 char *badthing = Nullch;
5733 switch (o->op_type) {
5735 badthing = "a SCALAR";
5738 badthing = "an ARRAY";
5741 badthing = "a HASH";
5746 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5750 * This is a little tricky. We only want to add the symbol if we
5751 * didn't add it in the lexer. Otherwise we get duplicate strict
5752 * warnings. But if we didn't add it in the lexer, we must at
5753 * least pretend like we wanted to add it even if it existed before,
5754 * or we get possible typo warnings. OPpCONST_ENTERED says
5755 * whether the lexer already added THIS instance of this symbol.
5757 iscv = (o->op_type == OP_RV2CV) * 2;
5759 gv = gv_fetchpv(name,
5760 iscv | !(kid->op_private & OPpCONST_ENTERED),
5763 : o->op_type == OP_RV2SV
5765 : o->op_type == OP_RV2AV
5767 : o->op_type == OP_RV2HV
5770 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5772 kid->op_type = OP_GV;
5773 SvREFCNT_dec(kid->op_sv);
5775 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5776 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5777 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5779 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5781 kid->op_sv = SvREFCNT_inc(gv);
5783 kid->op_private = 0;
5784 kid->op_ppaddr = PL_ppaddr[OP_GV];
5791 Perl_ck_ftst(pTHX_ OP *o)
5793 I32 type = o->op_type;
5795 if (o->op_flags & OPf_REF) {
5798 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5799 SVOP *kid = (SVOP*)cUNOPo->op_first;
5801 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5803 OP *newop = newGVOP(type, OPf_REF,
5804 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5811 if (type == OP_FTTTY)
5812 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5815 o = newUNOP(type, 0, newDEFSVOP());
5821 Perl_ck_fun(pTHX_ OP *o)
5827 int type = o->op_type;
5828 register I32 oa = PL_opargs[type] >> OASHIFT;
5830 if (o->op_flags & OPf_STACKED) {
5831 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5834 return no_fh_allowed(o);
5837 if (o->op_flags & OPf_KIDS) {
5839 tokid = &cLISTOPo->op_first;
5840 kid = cLISTOPo->op_first;
5841 if (kid->op_type == OP_PUSHMARK ||
5842 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5844 tokid = &kid->op_sibling;
5845 kid = kid->op_sibling;
5847 if (!kid && PL_opargs[type] & OA_DEFGV)
5848 *tokid = kid = newDEFSVOP();
5852 sibl = kid->op_sibling;
5855 /* list seen where single (scalar) arg expected? */
5856 if (numargs == 1 && !(oa >> 4)
5857 && kid->op_type == OP_LIST && type != OP_SCALAR)
5859 return too_many_arguments(o,PL_op_desc[type]);
5872 if ((type == OP_PUSH || type == OP_UNSHIFT)
5873 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5874 Perl_warner(aTHX_ WARN_SYNTAX,
5875 "Useless use of %s with no values",
5878 if (kid->op_type == OP_CONST &&
5879 (kid->op_private & OPpCONST_BARE))
5881 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5882 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5883 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5884 if (ckWARN(WARN_DEPRECATED))
5885 Perl_warner(aTHX_ WARN_DEPRECATED,
5886 "Array @%s missing the @ in argument %"IVdf" of %s()",
5887 name, (IV)numargs, PL_op_desc[type]);
5890 kid->op_sibling = sibl;
5893 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5894 bad_type(numargs, "array", PL_op_desc[type], kid);
5898 if (kid->op_type == OP_CONST &&
5899 (kid->op_private & OPpCONST_BARE))
5901 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5902 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5903 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5904 if (ckWARN(WARN_DEPRECATED))
5905 Perl_warner(aTHX_ WARN_DEPRECATED,
5906 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5907 name, (IV)numargs, PL_op_desc[type]);
5910 kid->op_sibling = sibl;
5913 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5914 bad_type(numargs, "hash", PL_op_desc[type], kid);
5919 OP *newop = newUNOP(OP_NULL, 0, kid);
5920 kid->op_sibling = 0;
5922 newop->op_next = newop;
5924 kid->op_sibling = sibl;
5929 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5930 if (kid->op_type == OP_CONST &&
5931 (kid->op_private & OPpCONST_BARE))
5933 OP *newop = newGVOP(OP_GV, 0,
5934 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5939 else if (kid->op_type == OP_READLINE) {
5940 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5941 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5944 I32 flags = OPf_SPECIAL;
5948 /* is this op a FH constructor? */
5949 if (is_handle_constructor(o,numargs)) {
5950 char *name = Nullch;
5954 /* Set a flag to tell rv2gv to vivify
5955 * need to "prove" flag does not mean something
5956 * else already - NI-S 1999/05/07
5959 if (kid->op_type == OP_PADSV) {
5960 SV **namep = av_fetch(PL_comppad_name,
5962 if (namep && *namep)
5963 name = SvPV(*namep, len);
5965 else if (kid->op_type == OP_RV2SV
5966 && kUNOP->op_first->op_type == OP_GV)
5968 GV *gv = cGVOPx_gv(kUNOP->op_first);
5970 len = GvNAMELEN(gv);
5972 else if (kid->op_type == OP_AELEM
5973 || kid->op_type == OP_HELEM)
5975 name = "__ANONIO__";
5981 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5982 namesv = PL_curpad[targ];
5983 (void)SvUPGRADE(namesv, SVt_PV);
5985 sv_setpvn(namesv, "$", 1);
5986 sv_catpvn(namesv, name, len);
5989 kid->op_sibling = 0;
5990 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5991 kid->op_targ = targ;
5992 kid->op_private |= priv;
5994 kid->op_sibling = sibl;
6000 mod(scalar(kid), type);
6004 tokid = &kid->op_sibling;
6005 kid = kid->op_sibling;
6007 o->op_private |= numargs;
6009 return too_many_arguments(o,OP_DESC(o));
6012 else if (PL_opargs[type] & OA_DEFGV) {
6014 return newUNOP(type, 0, newDEFSVOP());
6018 while (oa & OA_OPTIONAL)
6020 if (oa && oa != OA_LIST)
6021 return too_few_arguments(o,OP_DESC(o));
6027 Perl_ck_glob(pTHX_ OP *o)
6032 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6033 append_elem(OP_GLOB, o, newDEFSVOP());
6035 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6036 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6038 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6041 #if !defined(PERL_EXTERNAL_GLOB)
6042 /* XXX this can be tightened up and made more failsafe. */
6046 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
6048 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6049 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6050 GvCV(gv) = GvCV(glob_gv);
6051 SvREFCNT_inc((SV*)GvCV(gv));
6052 GvIMPORTED_CV_on(gv);
6055 #endif /* PERL_EXTERNAL_GLOB */
6057 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6058 append_elem(OP_GLOB, o,
6059 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6060 o->op_type = OP_LIST;
6061 o->op_ppaddr = PL_ppaddr[OP_LIST];
6062 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6063 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6064 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6065 append_elem(OP_LIST, o,
6066 scalar(newUNOP(OP_RV2CV, 0,
6067 newGVOP(OP_GV, 0, gv)))));
6068 o = newUNOP(OP_NULL, 0, ck_subr(o));
6069 o->op_targ = OP_GLOB; /* hint at what it used to be */
6072 gv = newGVgen("main");
6074 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6080 Perl_ck_grep(pTHX_ OP *o)
6084 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6086 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6087 NewOp(1101, gwop, 1, LOGOP);
6089 if (o->op_flags & OPf_STACKED) {
6092 kid = cLISTOPo->op_first->op_sibling;
6093 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6096 kid->op_next = (OP*)gwop;
6097 o->op_flags &= ~OPf_STACKED;
6099 kid = cLISTOPo->op_first->op_sibling;
6100 if (type == OP_MAPWHILE)
6107 kid = cLISTOPo->op_first->op_sibling;
6108 if (kid->op_type != OP_NULL)
6109 Perl_croak(aTHX_ "panic: ck_grep");
6110 kid = kUNOP->op_first;
6112 gwop->op_type = type;
6113 gwop->op_ppaddr = PL_ppaddr[type];
6114 gwop->op_first = listkids(o);
6115 gwop->op_flags |= OPf_KIDS;
6116 gwop->op_private = 1;
6117 gwop->op_other = LINKLIST(kid);
6118 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6119 kid->op_next = (OP*)gwop;
6121 kid = cLISTOPo->op_first->op_sibling;
6122 if (!kid || !kid->op_sibling)
6123 return too_few_arguments(o,OP_DESC(o));
6124 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6125 mod(kid, OP_GREPSTART);
6131 Perl_ck_index(pTHX_ OP *o)
6133 if (o->op_flags & OPf_KIDS) {
6134 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6136 kid = kid->op_sibling; /* get past "big" */
6137 if (kid && kid->op_type == OP_CONST)
6138 fbm_compile(((SVOP*)kid)->op_sv, 0);
6144 Perl_ck_lengthconst(pTHX_ OP *o)
6146 /* XXX length optimization goes here */
6151 Perl_ck_lfun(pTHX_ OP *o)
6153 OPCODE type = o->op_type;
6154 return modkids(ck_fun(o), type);
6158 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6160 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6161 switch (cUNOPo->op_first->op_type) {
6163 /* This is needed for
6164 if (defined %stash::)
6165 to work. Do not break Tk.
6167 break; /* Globals via GV can be undef */
6169 case OP_AASSIGN: /* Is this a good idea? */
6170 Perl_warner(aTHX_ WARN_DEPRECATED,
6171 "defined(@array) is deprecated");
6172 Perl_warner(aTHX_ WARN_DEPRECATED,
6173 "\t(Maybe you should just omit the defined()?)\n");
6176 /* This is needed for
6177 if (defined %stash::)
6178 to work. Do not break Tk.
6180 break; /* Globals via GV can be undef */
6182 Perl_warner(aTHX_ WARN_DEPRECATED,
6183 "defined(%%hash) is deprecated");
6184 Perl_warner(aTHX_ WARN_DEPRECATED,
6185 "\t(Maybe you should just omit the defined()?)\n");
6196 Perl_ck_rfun(pTHX_ OP *o)
6198 OPCODE type = o->op_type;
6199 return refkids(ck_fun(o), type);
6203 Perl_ck_listiob(pTHX_ OP *o)
6207 kid = cLISTOPo->op_first;
6210 kid = cLISTOPo->op_first;
6212 if (kid->op_type == OP_PUSHMARK)
6213 kid = kid->op_sibling;
6214 if (kid && o->op_flags & OPf_STACKED)
6215 kid = kid->op_sibling;
6216 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6217 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6218 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6219 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6220 cLISTOPo->op_first->op_sibling = kid;
6221 cLISTOPo->op_last = kid;
6222 kid = kid->op_sibling;
6227 append_elem(o->op_type, o, newDEFSVOP());
6233 Perl_ck_sassign(pTHX_ OP *o)
6235 OP *kid = cLISTOPo->op_first;
6236 /* has a disposable target? */
6237 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6238 && !(kid->op_flags & OPf_STACKED)
6239 /* Cannot steal the second time! */
6240 && !(kid->op_private & OPpTARGET_MY))
6242 OP *kkid = kid->op_sibling;
6244 /* Can just relocate the target. */
6245 if (kkid && kkid->op_type == OP_PADSV
6246 && !(kkid->op_private & OPpLVAL_INTRO))
6248 kid->op_targ = kkid->op_targ;
6250 /* Now we do not need PADSV and SASSIGN. */
6251 kid->op_sibling = o->op_sibling; /* NULL */
6252 cLISTOPo->op_first = NULL;
6255 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6263 Perl_ck_match(pTHX_ OP *o)
6265 o->op_private |= OPpRUNTIME;
6270 Perl_ck_method(pTHX_ OP *o)
6272 OP *kid = cUNOPo->op_first;
6273 if (kid->op_type == OP_CONST) {
6274 SV* sv = kSVOP->op_sv;
6275 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6277 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6278 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6281 kSVOP->op_sv = Nullsv;
6283 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6292 Perl_ck_null(pTHX_ OP *o)
6298 Perl_ck_open(pTHX_ OP *o)
6300 HV *table = GvHV(PL_hintgv);
6304 svp = hv_fetch(table, "open_IN", 7, FALSE);
6306 mode = mode_from_discipline(*svp);
6307 if (mode & O_BINARY)
6308 o->op_private |= OPpOPEN_IN_RAW;
6309 else if (mode & O_TEXT)
6310 o->op_private |= OPpOPEN_IN_CRLF;
6313 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6315 mode = mode_from_discipline(*svp);
6316 if (mode & O_BINARY)
6317 o->op_private |= OPpOPEN_OUT_RAW;
6318 else if (mode & O_TEXT)
6319 o->op_private |= OPpOPEN_OUT_CRLF;
6322 if (o->op_type == OP_BACKTICK)
6328 Perl_ck_repeat(pTHX_ OP *o)
6330 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6331 o->op_private |= OPpREPEAT_DOLIST;
6332 cBINOPo->op_first = force_list(cBINOPo->op_first);
6340 Perl_ck_require(pTHX_ OP *o)
6344 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6345 SVOP *kid = (SVOP*)cUNOPo->op_first;
6347 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6349 for (s = SvPVX(kid->op_sv); *s; s++) {
6350 if (*s == ':' && s[1] == ':') {
6352 Move(s+2, s+1, strlen(s+2)+1, char);
6353 --SvCUR(kid->op_sv);
6356 if (SvREADONLY(kid->op_sv)) {
6357 SvREADONLY_off(kid->op_sv);
6358 sv_catpvn(kid->op_sv, ".pm", 3);
6359 SvREADONLY_on(kid->op_sv);
6362 sv_catpvn(kid->op_sv, ".pm", 3);
6366 /* handle override, if any */
6367 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6368 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6369 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6371 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6372 OP *kid = cUNOPo->op_first;
6373 cUNOPo->op_first = 0;
6375 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6376 append_elem(OP_LIST, kid,
6377 scalar(newUNOP(OP_RV2CV, 0,
6386 Perl_ck_return(pTHX_ OP *o)
6389 if (CvLVALUE(PL_compcv)) {
6390 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6391 mod(kid, OP_LEAVESUBLV);
6398 Perl_ck_retarget(pTHX_ OP *o)
6400 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6407 Perl_ck_select(pTHX_ OP *o)
6410 if (o->op_flags & OPf_KIDS) {
6411 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6412 if (kid && kid->op_sibling) {
6413 o->op_type = OP_SSELECT;
6414 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6416 return fold_constants(o);
6420 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6421 if (kid && kid->op_type == OP_RV2GV)
6422 kid->op_private &= ~HINT_STRICT_REFS;
6427 Perl_ck_shift(pTHX_ OP *o)
6429 I32 type = o->op_type;
6431 if (!(o->op_flags & OPf_KIDS)) {
6435 #ifdef USE_5005THREADS
6436 if (!CvUNIQUE(PL_compcv)) {
6437 argop = newOP(OP_PADAV, OPf_REF);
6438 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6441 argop = newUNOP(OP_RV2AV, 0,
6442 scalar(newGVOP(OP_GV, 0,
6443 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6446 argop = newUNOP(OP_RV2AV, 0,
6447 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6448 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6449 #endif /* USE_5005THREADS */
6450 return newUNOP(type, 0, scalar(argop));
6452 return scalar(modkids(ck_fun(o), type));
6456 Perl_ck_sort(pTHX_ OP *o)
6460 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6462 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6463 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6465 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6467 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6469 if (kid->op_type == OP_SCOPE) {
6473 else if (kid->op_type == OP_LEAVE) {
6474 if (o->op_type == OP_SORT) {
6475 op_null(kid); /* wipe out leave */
6478 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6479 if (k->op_next == kid)
6481 /* don't descend into loops */
6482 else if (k->op_type == OP_ENTERLOOP
6483 || k->op_type == OP_ENTERITER)
6485 k = cLOOPx(k)->op_lastop;
6490 kid->op_next = 0; /* just disconnect the leave */
6491 k = kLISTOP->op_first;
6496 if (o->op_type == OP_SORT) {
6497 /* provide scalar context for comparison function/block */
6503 o->op_flags |= OPf_SPECIAL;
6505 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6508 firstkid = firstkid->op_sibling;
6511 /* provide list context for arguments */
6512 if (o->op_type == OP_SORT)
6519 S_simplify_sort(pTHX_ OP *o)
6521 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6525 if (!(o->op_flags & OPf_STACKED))
6527 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6528 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6529 kid = kUNOP->op_first; /* get past null */
6530 if (kid->op_type != OP_SCOPE)
6532 kid = kLISTOP->op_last; /* get past scope */
6533 switch(kid->op_type) {
6541 k = kid; /* remember this node*/
6542 if (kBINOP->op_first->op_type != OP_RV2SV)
6544 kid = kBINOP->op_first; /* get past cmp */
6545 if (kUNOP->op_first->op_type != OP_GV)
6547 kid = kUNOP->op_first; /* get past rv2sv */
6549 if (GvSTASH(gv) != PL_curstash)
6551 if (strEQ(GvNAME(gv), "a"))
6553 else if (strEQ(GvNAME(gv), "b"))
6557 kid = k; /* back to cmp */
6558 if (kBINOP->op_last->op_type != OP_RV2SV)
6560 kid = kBINOP->op_last; /* down to 2nd arg */
6561 if (kUNOP->op_first->op_type != OP_GV)
6563 kid = kUNOP->op_first; /* get past rv2sv */
6565 if (GvSTASH(gv) != PL_curstash
6567 ? strNE(GvNAME(gv), "a")
6568 : strNE(GvNAME(gv), "b")))
6570 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6572 o->op_private |= OPpSORT_REVERSE;
6573 if (k->op_type == OP_NCMP)
6574 o->op_private |= OPpSORT_NUMERIC;
6575 if (k->op_type == OP_I_NCMP)
6576 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6577 kid = cLISTOPo->op_first->op_sibling;
6578 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6579 op_free(kid); /* then delete it */
6583 Perl_ck_split(pTHX_ OP *o)
6587 if (o->op_flags & OPf_STACKED)
6588 return no_fh_allowed(o);
6590 kid = cLISTOPo->op_first;
6591 if (kid->op_type != OP_NULL)
6592 Perl_croak(aTHX_ "panic: ck_split");
6593 kid = kid->op_sibling;
6594 op_free(cLISTOPo->op_first);
6595 cLISTOPo->op_first = kid;
6597 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6598 cLISTOPo->op_last = kid; /* There was only one element previously */
6601 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6602 OP *sibl = kid->op_sibling;
6603 kid->op_sibling = 0;
6604 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6605 if (cLISTOPo->op_first == cLISTOPo->op_last)
6606 cLISTOPo->op_last = kid;
6607 cLISTOPo->op_first = kid;
6608 kid->op_sibling = sibl;
6611 kid->op_type = OP_PUSHRE;
6612 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6615 if (!kid->op_sibling)
6616 append_elem(OP_SPLIT, o, newDEFSVOP());
6618 kid = kid->op_sibling;
6621 if (!kid->op_sibling)
6622 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6624 kid = kid->op_sibling;
6627 if (kid->op_sibling)
6628 return too_many_arguments(o,OP_DESC(o));
6634 Perl_ck_join(pTHX_ OP *o)
6636 if (ckWARN(WARN_SYNTAX)) {
6637 OP *kid = cLISTOPo->op_first->op_sibling;
6638 if (kid && kid->op_type == OP_MATCH) {
6639 char *pmstr = "STRING";
6640 if (PM_GETRE(kPMOP))
6641 pmstr = PM_GETRE(kPMOP)->precomp;
6642 Perl_warner(aTHX_ WARN_SYNTAX,
6643 "/%s/ should probably be written as \"%s\"",
6651 Perl_ck_subr(pTHX_ OP *o)
6653 OP *prev = ((cUNOPo->op_first->op_sibling)
6654 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6655 OP *o2 = prev->op_sibling;
6662 I32 contextclass = 0;
6666 o->op_private |= OPpENTERSUB_HASTARG;
6667 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6668 if (cvop->op_type == OP_RV2CV) {
6670 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6671 op_null(cvop); /* disable rv2cv */
6672 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6673 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6674 GV *gv = cGVOPx_gv(tmpop);
6677 tmpop->op_private |= OPpEARLY_CV;
6678 else if (SvPOK(cv)) {
6679 namegv = CvANON(cv) ? gv : CvGV(cv);
6680 proto = SvPV((SV*)cv, n_a);
6684 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6685 if (o2->op_type == OP_CONST)
6686 o2->op_private &= ~OPpCONST_STRICT;
6687 else if (o2->op_type == OP_LIST) {
6688 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6689 if (o && o->op_type == OP_CONST)
6690 o->op_private &= ~OPpCONST_STRICT;
6693 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6694 if (PERLDB_SUB && PL_curstash != PL_debstash)
6695 o->op_private |= OPpENTERSUB_DB;
6696 while (o2 != cvop) {
6700 return too_many_arguments(o, gv_ename(namegv));
6718 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6720 arg == 1 ? "block or sub {}" : "sub {}",
6721 gv_ename(namegv), o2);
6724 /* '*' allows any scalar type, including bareword */
6727 if (o2->op_type == OP_RV2GV)
6728 goto wrapref; /* autoconvert GLOB -> GLOBref */
6729 else if (o2->op_type == OP_CONST)
6730 o2->op_private &= ~OPpCONST_STRICT;
6731 else if (o2->op_type == OP_ENTERSUB) {
6732 /* accidental subroutine, revert to bareword */
6733 OP *gvop = ((UNOP*)o2)->op_first;
6734 if (gvop && gvop->op_type == OP_NULL) {
6735 gvop = ((UNOP*)gvop)->op_first;
6737 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6740 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6741 (gvop = ((UNOP*)gvop)->op_first) &&
6742 gvop->op_type == OP_GV)
6744 GV *gv = cGVOPx_gv(gvop);
6745 OP *sibling = o2->op_sibling;
6746 SV *n = newSVpvn("",0);
6748 gv_fullname3(n, gv, "");
6749 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6750 sv_chop(n, SvPVX(n)+6);
6751 o2 = newSVOP(OP_CONST, 0, n);
6752 prev->op_sibling = o2;
6753 o2->op_sibling = sibling;
6769 if (contextclass++ == 0) {
6770 e = strchr(proto, ']');
6771 if (!e || e == proto)
6785 if (o2->op_type == OP_RV2GV)
6788 bad_type(arg, "symbol", gv_ename(namegv), o2);
6791 if (o2->op_type == OP_ENTERSUB)
6794 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6797 if (o2->op_type == OP_RV2SV ||
6798 o2->op_type == OP_PADSV ||
6799 o2->op_type == OP_HELEM ||
6800 o2->op_type == OP_AELEM ||
6801 o2->op_type == OP_THREADSV)
6804 bad_type(arg, "scalar", gv_ename(namegv), o2);
6807 if (o2->op_type == OP_RV2AV ||
6808 o2->op_type == OP_PADAV)
6811 bad_type(arg, "array", gv_ename(namegv), o2);
6814 if (o2->op_type == OP_RV2HV ||
6815 o2->op_type == OP_PADHV)
6818 bad_type(arg, "hash", gv_ename(namegv), o2);
6823 OP* sib = kid->op_sibling;
6824 kid->op_sibling = 0;
6825 o2 = newUNOP(OP_REFGEN, 0, kid);
6826 o2->op_sibling = sib;
6827 prev->op_sibling = o2;
6829 if (contextclass && e) {
6844 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6845 gv_ename(namegv), SvPV((SV*)cv, n_a));
6850 mod(o2, OP_ENTERSUB);
6852 o2 = o2->op_sibling;
6854 if (proto && !optional &&
6855 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6856 return too_few_arguments(o, gv_ename(namegv));
6861 Perl_ck_svconst(pTHX_ OP *o)
6863 SvREADONLY_on(cSVOPo->op_sv);
6868 Perl_ck_trunc(pTHX_ OP *o)
6870 if (o->op_flags & OPf_KIDS) {
6871 SVOP *kid = (SVOP*)cUNOPo->op_first;
6873 if (kid->op_type == OP_NULL)
6874 kid = (SVOP*)kid->op_sibling;
6875 if (kid && kid->op_type == OP_CONST &&
6876 (kid->op_private & OPpCONST_BARE))
6878 o->op_flags |= OPf_SPECIAL;
6879 kid->op_private &= ~OPpCONST_STRICT;
6886 Perl_ck_substr(pTHX_ OP *o)
6889 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6890 OP *kid = cLISTOPo->op_first;
6892 if (kid->op_type == OP_NULL)
6893 kid = kid->op_sibling;
6895 kid->op_flags |= OPf_MOD;
6901 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6904 Perl_peep(pTHX_ register OP *o)
6906 register OP* oldop = 0;
6909 if (!o || o->op_seq)
6913 SAVEVPTR(PL_curcop);
6914 for (; o; o = o->op_next) {
6920 switch (o->op_type) {
6924 PL_curcop = ((COP*)o); /* for warnings */
6925 o->op_seq = PL_op_seqmax++;
6929 if (cSVOPo->op_private & OPpCONST_STRICT)
6930 no_bareword_allowed(o);
6932 /* Relocate sv to the pad for thread safety.
6933 * Despite being a "constant", the SV is written to,
6934 * for reference counts, sv_upgrade() etc. */
6936 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6937 if (SvPADTMP(cSVOPo->op_sv)) {
6938 /* If op_sv is already a PADTMP then it is being used by
6939 * some pad, so make a copy. */
6940 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6941 SvREADONLY_on(PL_curpad[ix]);
6942 SvREFCNT_dec(cSVOPo->op_sv);
6945 SvREFCNT_dec(PL_curpad[ix]);
6946 SvPADTMP_on(cSVOPo->op_sv);
6947 PL_curpad[ix] = cSVOPo->op_sv;
6948 /* XXX I don't know how this isn't readonly already. */
6949 SvREADONLY_on(PL_curpad[ix]);
6951 cSVOPo->op_sv = Nullsv;
6955 o->op_seq = PL_op_seqmax++;
6959 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6960 if (o->op_next->op_private & OPpTARGET_MY) {
6961 if (o->op_flags & OPf_STACKED) /* chained concats */
6962 goto ignore_optimization;
6964 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6965 o->op_targ = o->op_next->op_targ;
6966 o->op_next->op_targ = 0;
6967 o->op_private |= OPpTARGET_MY;
6970 op_null(o->op_next);
6972 ignore_optimization:
6973 o->op_seq = PL_op_seqmax++;
6976 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6977 o->op_seq = PL_op_seqmax++;
6978 break; /* Scalar stub must produce undef. List stub is noop */
6982 if (o->op_targ == OP_NEXTSTATE
6983 || o->op_targ == OP_DBSTATE
6984 || o->op_targ == OP_SETSTATE)
6986 PL_curcop = ((COP*)o);
6988 /* XXX: We avoid setting op_seq here to prevent later calls
6989 to peep() from mistakenly concluding that optimisation
6990 has already occurred. This doesn't fix the real problem,
6991 though (See 20010220.007). AMS 20010719 */
6992 if (oldop && o->op_next) {
6993 oldop->op_next = o->op_next;
7001 if (oldop && o->op_next) {
7002 oldop->op_next = o->op_next;
7005 o->op_seq = PL_op_seqmax++;
7009 if (o->op_next->op_type == OP_RV2SV) {
7010 if (!(o->op_next->op_private & OPpDEREF)) {
7011 op_null(o->op_next);
7012 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7014 o->op_next = o->op_next->op_next;
7015 o->op_type = OP_GVSV;
7016 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7019 else if (o->op_next->op_type == OP_RV2AV) {
7020 OP* pop = o->op_next->op_next;
7022 if (pop->op_type == OP_CONST &&
7023 (PL_op = pop->op_next) &&
7024 pop->op_next->op_type == OP_AELEM &&
7025 !(pop->op_next->op_private &
7026 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7027 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7032 op_null(o->op_next);
7033 op_null(pop->op_next);
7035 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7036 o->op_next = pop->op_next->op_next;
7037 o->op_type = OP_AELEMFAST;
7038 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7039 o->op_private = (U8)i;
7044 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7046 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7047 /* XXX could check prototype here instead of just carping */
7048 SV *sv = sv_newmortal();
7049 gv_efullname3(sv, gv, Nullch);
7050 Perl_warner(aTHX_ WARN_PROTOTYPE,
7051 "%s() called too early to check prototype",
7055 else if (o->op_next->op_type == OP_READLINE
7056 && o->op_next->op_next->op_type == OP_CONCAT
7057 && (o->op_next->op_next->op_flags & OPf_STACKED))
7059 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7060 o->op_type = OP_RCATLINE;
7061 o->op_flags |= OPf_STACKED;
7062 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7063 op_null(o->op_next->op_next);
7064 op_null(o->op_next);
7067 o->op_seq = PL_op_seqmax++;
7078 o->op_seq = PL_op_seqmax++;
7079 while (cLOGOP->op_other->op_type == OP_NULL)
7080 cLOGOP->op_other = cLOGOP->op_other->op_next;
7081 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7086 o->op_seq = PL_op_seqmax++;
7087 while (cLOOP->op_redoop->op_type == OP_NULL)
7088 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7089 peep(cLOOP->op_redoop);
7090 while (cLOOP->op_nextop->op_type == OP_NULL)
7091 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7092 peep(cLOOP->op_nextop);
7093 while (cLOOP->op_lastop->op_type == OP_NULL)
7094 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7095 peep(cLOOP->op_lastop);
7101 o->op_seq = PL_op_seqmax++;
7102 while (cPMOP->op_pmreplstart &&
7103 cPMOP->op_pmreplstart->op_type == OP_NULL)
7104 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7105 peep(cPMOP->op_pmreplstart);
7109 o->op_seq = PL_op_seqmax++;
7110 if (ckWARN(WARN_SYNTAX) && o->op_next
7111 && o->op_next->op_type == OP_NEXTSTATE) {
7112 if (o->op_next->op_sibling &&
7113 o->op_next->op_sibling->op_type != OP_EXIT &&
7114 o->op_next->op_sibling->op_type != OP_WARN &&
7115 o->op_next->op_sibling->op_type != OP_DIE) {
7116 line_t oldline = CopLINE(PL_curcop);
7118 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7119 Perl_warner(aTHX_ WARN_EXEC,
7120 "Statement unlikely to be reached");
7121 Perl_warner(aTHX_ WARN_EXEC,
7122 "\t(Maybe you meant system() when you said exec()?)\n");
7123 CopLINE_set(PL_curcop, oldline);
7132 SV **svp, **indsvp, *sv;
7137 o->op_seq = PL_op_seqmax++;
7139 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7142 /* Make the CONST have a shared SV */
7143 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7144 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7145 key = SvPV(sv, keylen);
7146 lexname = newSVpvn_share(key,
7147 SvUTF8(sv) ? -(I32)keylen : keylen,
7153 if ((o->op_private & (OPpLVAL_INTRO)))
7156 rop = (UNOP*)((BINOP*)o)->op_first;
7157 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7159 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7160 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7162 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7163 if (!fields || !GvHV(*fields))
7165 key = SvPV(*svp, keylen);
7166 indsvp = hv_fetch(GvHV(*fields), key,
7167 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7169 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7170 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7172 ind = SvIV(*indsvp);
7174 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7175 rop->op_type = OP_RV2AV;
7176 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7177 o->op_type = OP_AELEM;
7178 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7180 if (SvREADONLY(*svp))
7182 SvFLAGS(sv) |= (SvFLAGS(*svp)
7183 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7193 SV **svp, **indsvp, *sv;
7197 SVOP *first_key_op, *key_op;
7199 o->op_seq = PL_op_seqmax++;
7200 if ((o->op_private & (OPpLVAL_INTRO))
7201 /* I bet there's always a pushmark... */
7202 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7203 /* hmmm, no optimization if list contains only one key. */
7205 rop = (UNOP*)((LISTOP*)o)->op_last;
7206 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7208 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7209 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7211 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7212 if (!fields || !GvHV(*fields))
7214 /* Again guessing that the pushmark can be jumped over.... */
7215 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7216 ->op_first->op_sibling;
7217 /* Check that the key list contains only constants. */
7218 for (key_op = first_key_op; key_op;
7219 key_op = (SVOP*)key_op->op_sibling)
7220 if (key_op->op_type != OP_CONST)
7224 rop->op_type = OP_RV2AV;
7225 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7226 o->op_type = OP_ASLICE;
7227 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7228 for (key_op = first_key_op; key_op;
7229 key_op = (SVOP*)key_op->op_sibling) {
7230 svp = cSVOPx_svp(key_op);
7231 key = SvPV(*svp, keylen);
7232 indsvp = hv_fetch(GvHV(*fields), key,
7233 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7235 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7236 "in variable %s of type %s",
7237 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7239 ind = SvIV(*indsvp);
7241 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7243 if (SvREADONLY(*svp))
7245 SvFLAGS(sv) |= (SvFLAGS(*svp)
7246 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7254 o->op_seq = PL_op_seqmax++;
7264 char* Perl_custom_op_name(pTHX_ OP* o)
7266 IV index = PTR2IV(o->op_ppaddr);
7270 if (!PL_custom_op_names) /* This probably shouldn't happen */
7271 return PL_op_name[OP_CUSTOM];
7273 keysv = sv_2mortal(newSViv(index));
7275 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7277 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7279 return SvPV_nolen(HeVAL(he));
7282 char* Perl_custom_op_desc(pTHX_ OP* o)
7284 IV index = PTR2IV(o->op_ppaddr);
7288 if (!PL_custom_op_descs)
7289 return PL_op_desc[OP_CUSTOM];
7291 keysv = sv_2mortal(newSViv(index));
7293 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7295 return PL_op_desc[OP_CUSTOM];
7297 return SvPV_nolen(HeVAL(he));
7303 /* Efficient sub that returns a constant scalar value. */
7305 const_sv_xsub(pTHX_ CV* cv)
7310 Perl_croak(aTHX_ "usage: %s::%s()",
7311 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7315 ST(0) = (SV*)XSANY.any_ptr;