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 #ifdef PL_OP_SLAB_ALLOC
28 #define SLAB_SIZE 8192
29 static char *PL_OpPtr = NULL;
30 static int PL_OpSpace = 0;
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);
1032 Perl_scalarvoid(pTHX_ OP *o)
1039 if (o->op_type == OP_NEXTSTATE
1040 || o->op_type == OP_SETSTATE
1041 || o->op_type == OP_DBSTATE
1042 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1043 || o->op_targ == OP_SETSTATE
1044 || o->op_targ == OP_DBSTATE)))
1045 PL_curcop = (COP*)o; /* for warning below */
1047 /* assumes no premature commitment */
1048 want = o->op_flags & OPf_WANT;
1049 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1050 || o->op_type == OP_RETURN)
1055 if ((o->op_private & OPpTARGET_MY)
1056 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1058 return scalar(o); /* As if inside SASSIGN */
1061 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1063 switch (o->op_type) {
1065 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1069 if (o->op_flags & OPf_STACKED)
1073 if (o->op_private == 4)
1115 case OP_GETSOCKNAME:
1116 case OP_GETPEERNAME:
1121 case OP_GETPRIORITY:
1144 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1145 useless = OP_DESC(o);
1152 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1153 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1154 useless = "a variable";
1159 if (cSVOPo->op_private & OPpCONST_STRICT)
1160 no_bareword_allowed(o);
1162 if (ckWARN(WARN_VOID)) {
1163 useless = "a constant";
1164 /* the constants 0 and 1 are permitted as they are
1165 conventionally used as dummies in constructs like
1166 1 while some_condition_with_side_effects; */
1167 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1169 else if (SvPOK(sv)) {
1170 /* perl4's way of mixing documentation and code
1171 (before the invention of POD) was based on a
1172 trick to mix nroff and perl code. The trick was
1173 built upon these three nroff macros being used in
1174 void context. The pink camel has the details in
1175 the script wrapman near page 319. */
1176 if (strnEQ(SvPVX(sv), "di", 2) ||
1177 strnEQ(SvPVX(sv), "ds", 2) ||
1178 strnEQ(SvPVX(sv), "ig", 2))
1183 op_null(o); /* don't execute or even remember it */
1187 o->op_type = OP_PREINC; /* pre-increment is faster */
1188 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1192 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1193 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1199 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1204 if (o->op_flags & OPf_STACKED)
1211 if (!(o->op_flags & OPf_KIDS))
1220 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1227 /* all requires must return a boolean value */
1228 o->op_flags &= ~OPf_WANT;
1233 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1234 if (!kPMOP->op_pmreplroot)
1235 deprecate("implicit split to @_");
1239 if (useless && ckWARN(WARN_VOID))
1240 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1245 Perl_listkids(pTHX_ OP *o)
1248 if (o && o->op_flags & OPf_KIDS) {
1249 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1256 Perl_list(pTHX_ OP *o)
1260 /* assumes no premature commitment */
1261 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1262 || o->op_type == OP_RETURN)
1267 if ((o->op_private & OPpTARGET_MY)
1268 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1270 return o; /* As if inside SASSIGN */
1273 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1275 switch (o->op_type) {
1278 list(cBINOPo->op_first);
1283 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1291 if (!(o->op_flags & OPf_KIDS))
1293 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1294 list(cBINOPo->op_first);
1295 return gen_constant_list(o);
1302 kid = cLISTOPo->op_first;
1304 while ((kid = kid->op_sibling)) {
1305 if (kid->op_sibling)
1310 WITH_THR(PL_curcop = &PL_compiling);
1314 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1315 if (kid->op_sibling)
1320 WITH_THR(PL_curcop = &PL_compiling);
1323 /* all requires must return a boolean value */
1324 o->op_flags &= ~OPf_WANT;
1331 Perl_scalarseq(pTHX_ OP *o)
1336 if (o->op_type == OP_LINESEQ ||
1337 o->op_type == OP_SCOPE ||
1338 o->op_type == OP_LEAVE ||
1339 o->op_type == OP_LEAVETRY)
1341 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1342 if (kid->op_sibling) {
1346 PL_curcop = &PL_compiling;
1348 o->op_flags &= ~OPf_PARENS;
1349 if (PL_hints & HINT_BLOCK_SCOPE)
1350 o->op_flags |= OPf_PARENS;
1353 o = newOP(OP_STUB, 0);
1358 S_modkids(pTHX_ OP *o, I32 type)
1361 if (o && o->op_flags & OPf_KIDS) {
1362 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1369 Perl_mod(pTHX_ OP *o, I32 type)
1374 if (!o || PL_error_count)
1377 if ((o->op_private & OPpTARGET_MY)
1378 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1383 switch (o->op_type) {
1388 if (!(o->op_private & (OPpCONST_ARYBASE)))
1390 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1391 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1395 SAVEI32(PL_compiling.cop_arybase);
1396 PL_compiling.cop_arybase = 0;
1398 else if (type == OP_REFGEN)
1401 Perl_croak(aTHX_ "That use of $[ is unsupported");
1404 if (o->op_flags & OPf_PARENS)
1408 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1409 !(o->op_flags & OPf_STACKED)) {
1410 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1411 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1412 assert(cUNOPo->op_first->op_type == OP_NULL);
1413 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1416 else { /* lvalue subroutine call */
1417 o->op_private |= OPpLVAL_INTRO;
1418 PL_modcount = RETURN_UNLIMITED_NUMBER;
1419 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1420 /* Backward compatibility mode: */
1421 o->op_private |= OPpENTERSUB_INARGS;
1424 else { /* Compile-time error message: */
1425 OP *kid = cUNOPo->op_first;
1429 if (kid->op_type == OP_PUSHMARK)
1431 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1433 "panic: unexpected lvalue entersub "
1434 "args: type/targ %ld:%"UVuf,
1435 (long)kid->op_type, (UV)kid->op_targ);
1436 kid = kLISTOP->op_first;
1438 while (kid->op_sibling)
1439 kid = kid->op_sibling;
1440 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1442 if (kid->op_type == OP_METHOD_NAMED
1443 || kid->op_type == OP_METHOD)
1447 if (kid->op_sibling || kid->op_next != kid) {
1448 yyerror("panic: unexpected optree near method call");
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() */
1673 if (type != OP_LEAVESUBLV)
1674 o->op_flags |= OPf_MOD;
1676 if (type == OP_AASSIGN || type == OP_SASSIGN)
1677 o->op_flags |= OPf_SPECIAL|OPf_REF;
1679 o->op_private |= OPpLVAL_INTRO;
1680 o->op_flags &= ~OPf_SPECIAL;
1681 PL_hints |= HINT_BLOCK_SCOPE;
1683 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1684 && type != OP_LEAVESUBLV)
1685 o->op_flags |= OPf_REF;
1690 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1694 if (o->op_type == OP_RV2GV)
1718 case OP_RIGHT_SHIFT:
1737 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1739 switch (o->op_type) {
1747 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1760 Perl_refkids(pTHX_ OP *o, I32 type)
1763 if (o && o->op_flags & OPf_KIDS) {
1764 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1771 Perl_ref(pTHX_ OP *o, I32 type)
1775 if (!o || PL_error_count)
1778 switch (o->op_type) {
1780 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1781 !(o->op_flags & OPf_STACKED)) {
1782 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1783 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1784 assert(cUNOPo->op_first->op_type == OP_NULL);
1785 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1786 o->op_flags |= OPf_SPECIAL;
1791 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1795 if (type == OP_DEFINED)
1796 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1797 ref(cUNOPo->op_first, o->op_type);
1800 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1801 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1802 : type == OP_RV2HV ? OPpDEREF_HV
1804 o->op_flags |= OPf_MOD;
1809 o->op_flags |= OPf_MOD; /* XXX ??? */
1814 o->op_flags |= OPf_REF;
1817 if (type == OP_DEFINED)
1818 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1819 ref(cUNOPo->op_first, o->op_type);
1824 o->op_flags |= OPf_REF;
1829 if (!(o->op_flags & OPf_KIDS))
1831 ref(cBINOPo->op_first, type);
1835 ref(cBINOPo->op_first, o->op_type);
1836 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1837 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1838 : type == OP_RV2HV ? OPpDEREF_HV
1840 o->op_flags |= OPf_MOD;
1848 if (!(o->op_flags & OPf_KIDS))
1850 ref(cLISTOPo->op_last, type);
1860 S_dup_attrlist(pTHX_ OP *o)
1864 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1865 * where the first kid is OP_PUSHMARK and the remaining ones
1866 * are OP_CONST. We need to push the OP_CONST values.
1868 if (o->op_type == OP_CONST)
1869 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1871 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1872 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1873 if (o->op_type == OP_CONST)
1874 rop = append_elem(OP_LIST, rop,
1875 newSVOP(OP_CONST, o->op_flags,
1876 SvREFCNT_inc(cSVOPo->op_sv)));
1883 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1887 /* fake up C<use attributes $pkg,$rv,@attrs> */
1888 ENTER; /* need to protect against side-effects of 'use' */
1891 stashsv = newSVpv(HvNAME(stash), 0);
1893 stashsv = &PL_sv_no;
1895 #define ATTRSMODULE "attributes"
1897 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1898 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1900 prepend_elem(OP_LIST,
1901 newSVOP(OP_CONST, 0, stashsv),
1902 prepend_elem(OP_LIST,
1903 newSVOP(OP_CONST, 0,
1905 dup_attrlist(attrs))));
1910 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1911 char *attrstr, STRLEN len)
1916 len = strlen(attrstr);
1920 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1922 char *sstr = attrstr;
1923 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1924 attrs = append_elem(OP_LIST, attrs,
1925 newSVOP(OP_CONST, 0,
1926 newSVpvn(sstr, attrstr-sstr)));
1930 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1931 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1932 Nullsv, prepend_elem(OP_LIST,
1933 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1934 prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0,
1941 S_my_kid(pTHX_ OP *o, OP *attrs)
1946 if (!o || PL_error_count)
1950 if (type == OP_LIST) {
1951 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1953 } else if (type == OP_UNDEF) {
1955 } else if (type == OP_RV2SV || /* "our" declaration */
1957 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1959 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1961 PL_in_my_stash = Nullhv;
1962 apply_attrs(GvSTASH(gv),
1963 (type == OP_RV2SV ? GvSV(gv) :
1964 type == OP_RV2AV ? (SV*)GvAV(gv) :
1965 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1968 o->op_private |= OPpOUR_INTRO;
1970 } else if (type != OP_PADSV &&
1973 type != OP_PUSHMARK)
1975 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1977 PL_in_my == KEY_our ? "our" : "my"));
1980 else if (attrs && type != OP_PUSHMARK) {
1986 PL_in_my_stash = Nullhv;
1988 /* check for C<my Dog $spot> when deciding package */
1989 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1990 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1991 stash = SvSTASH(*namesvp);
1993 stash = PL_curstash;
1994 padsv = PAD_SV(o->op_targ);
1995 apply_attrs(stash, padsv, attrs);
1997 o->op_flags |= OPf_MOD;
1998 o->op_private |= OPpLVAL_INTRO;
2003 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2005 if (o->op_flags & OPf_PARENS)
2009 o = my_kid(o, attrs);
2011 PL_in_my_stash = Nullhv;
2016 Perl_my(pTHX_ OP *o)
2018 return my_kid(o, Nullop);
2022 Perl_sawparens(pTHX_ OP *o)
2025 o->op_flags |= OPf_PARENS;
2030 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2034 if (ckWARN(WARN_MISC) &&
2035 (left->op_type == OP_RV2AV ||
2036 left->op_type == OP_RV2HV ||
2037 left->op_type == OP_PADAV ||
2038 left->op_type == OP_PADHV)) {
2039 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2040 right->op_type == OP_TRANS)
2041 ? right->op_type : OP_MATCH];
2042 const char *sample = ((left->op_type == OP_RV2AV ||
2043 left->op_type == OP_PADAV)
2044 ? "@array" : "%hash");
2045 Perl_warner(aTHX_ WARN_MISC,
2046 "Applying %s to %s will act on scalar(%s)",
2047 desc, sample, sample);
2050 if (!(right->op_flags & OPf_STACKED) &&
2051 (right->op_type == OP_MATCH ||
2052 right->op_type == OP_SUBST ||
2053 right->op_type == OP_TRANS)) {
2054 right->op_flags |= OPf_STACKED;
2055 if ((right->op_type != OP_MATCH &&
2056 ! (right->op_type == OP_TRANS &&
2057 right->op_private & OPpTRANS_IDENTICAL)) ||
2058 /* if SV has magic, then match on original SV, not on its copy.
2059 see note in pp_helem() */
2060 (right->op_type == OP_MATCH &&
2061 (left->op_type == OP_AELEM ||
2062 left->op_type == OP_HELEM ||
2063 left->op_type == OP_AELEMFAST)))
2064 left = mod(left, right->op_type);
2065 if (right->op_type == OP_TRANS)
2066 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2068 o = prepend_elem(right->op_type, scalar(left), right);
2070 return newUNOP(OP_NOT, 0, scalar(o));
2074 return bind_match(type, left,
2075 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2079 Perl_invert(pTHX_ OP *o)
2083 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2084 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2088 Perl_scope(pTHX_ OP *o)
2091 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2092 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2093 o->op_type = OP_LEAVE;
2094 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2097 if (o->op_type == OP_LINESEQ) {
2099 o->op_type = OP_SCOPE;
2100 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2101 kid = ((LISTOP*)o)->op_first;
2102 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2106 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2113 Perl_save_hints(pTHX)
2116 SAVESPTR(GvHV(PL_hintgv));
2117 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2118 SAVEFREESV(GvHV(PL_hintgv));
2122 Perl_block_start(pTHX_ int full)
2124 int retval = PL_savestack_ix;
2126 SAVEI32(PL_comppad_name_floor);
2127 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2129 PL_comppad_name_fill = PL_comppad_name_floor;
2130 if (PL_comppad_name_floor < 0)
2131 PL_comppad_name_floor = 0;
2132 SAVEI32(PL_min_intro_pending);
2133 SAVEI32(PL_max_intro_pending);
2134 PL_min_intro_pending = 0;
2135 SAVEI32(PL_comppad_name_fill);
2136 SAVEI32(PL_padix_floor);
2137 PL_padix_floor = PL_padix;
2138 PL_pad_reset_pending = FALSE;
2140 PL_hints &= ~HINT_BLOCK_SCOPE;
2141 SAVESPTR(PL_compiling.cop_warnings);
2142 if (! specialWARN(PL_compiling.cop_warnings)) {
2143 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2144 SAVEFREESV(PL_compiling.cop_warnings) ;
2146 SAVESPTR(PL_compiling.cop_io);
2147 if (! specialCopIO(PL_compiling.cop_io)) {
2148 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2149 SAVEFREESV(PL_compiling.cop_io) ;
2155 Perl_block_end(pTHX_ I32 floor, OP *seq)
2157 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2158 line_t copline = PL_copline;
2159 /* there should be a nextstate in every block */
2160 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2161 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2163 PL_pad_reset_pending = FALSE;
2164 PL_compiling.op_private = PL_hints;
2166 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2167 pad_leavemy(PL_comppad_name_fill);
2175 #ifdef USE_5005THREADS
2176 OP *o = newOP(OP_THREADSV, 0);
2177 o->op_targ = find_threadsv("_");
2180 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2181 #endif /* USE_5005THREADS */
2185 Perl_newPROG(pTHX_ OP *o)
2190 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2191 ((PL_in_eval & EVAL_KEEPERR)
2192 ? OPf_SPECIAL : 0), o);
2193 PL_eval_start = linklist(PL_eval_root);
2194 PL_eval_root->op_private |= OPpREFCOUNTED;
2195 OpREFCNT_set(PL_eval_root, 1);
2196 PL_eval_root->op_next = 0;
2197 CALL_PEEP(PL_eval_start);
2202 PL_main_root = scope(sawparens(scalarvoid(o)));
2203 PL_curcop = &PL_compiling;
2204 PL_main_start = LINKLIST(PL_main_root);
2205 PL_main_root->op_private |= OPpREFCOUNTED;
2206 OpREFCNT_set(PL_main_root, 1);
2207 PL_main_root->op_next = 0;
2208 CALL_PEEP(PL_main_start);
2211 /* Register with debugger */
2213 CV *cv = get_cv("DB::postponed", FALSE);
2217 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2219 call_sv((SV*)cv, G_DISCARD);
2226 Perl_localize(pTHX_ OP *o, I32 lex)
2228 if (o->op_flags & OPf_PARENS)
2231 if (ckWARN(WARN_PARENTHESIS)
2232 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2234 char *s = PL_bufptr;
2236 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2239 if (*s == ';' || *s == '=')
2240 Perl_warner(aTHX_ WARN_PARENTHESIS,
2241 "Parentheses missing around \"%s\" list",
2242 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2248 o = mod(o, OP_NULL); /* a bit kludgey */
2250 PL_in_my_stash = Nullhv;
2255 Perl_jmaybe(pTHX_ OP *o)
2257 if (o->op_type == OP_LIST) {
2259 #ifdef USE_5005THREADS
2260 o2 = newOP(OP_THREADSV, 0);
2261 o2->op_targ = find_threadsv(";");
2263 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2264 #endif /* USE_5005THREADS */
2265 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2271 Perl_fold_constants(pTHX_ register OP *o)
2274 I32 type = o->op_type;
2277 if (PL_opargs[type] & OA_RETSCALAR)
2279 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2280 o->op_targ = pad_alloc(type, SVs_PADTMP);
2282 /* integerize op, unless it happens to be C<-foo>.
2283 * XXX should pp_i_negate() do magic string negation instead? */
2284 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2285 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2286 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2288 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2291 if (!(PL_opargs[type] & OA_FOLDCONST))
2296 /* XXX might want a ck_negate() for this */
2297 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2309 /* XXX what about the numeric ops? */
2310 if (PL_hints & HINT_LOCALE)
2315 goto nope; /* Don't try to run w/ errors */
2317 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2318 if ((curop->op_type != OP_CONST ||
2319 (curop->op_private & OPpCONST_BARE)) &&
2320 curop->op_type != OP_LIST &&
2321 curop->op_type != OP_SCALAR &&
2322 curop->op_type != OP_NULL &&
2323 curop->op_type != OP_PUSHMARK)
2329 curop = LINKLIST(o);
2333 sv = *(PL_stack_sp--);
2334 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2335 pad_swipe(o->op_targ);
2336 else if (SvTEMP(sv)) { /* grab mortal temp? */
2337 (void)SvREFCNT_inc(sv);
2341 if (type == OP_RV2GV)
2342 return newGVOP(OP_GV, 0, (GV*)sv);
2344 /* try to smush double to int, but don't smush -2.0 to -2 */
2345 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2348 #ifdef PERL_PRESERVE_IVUV
2349 /* Only bother to attempt to fold to IV if
2350 most operators will benefit */
2354 return newSVOP(OP_CONST, 0, sv);
2358 if (!(PL_opargs[type] & OA_OTHERINT))
2361 if (!(PL_hints & HINT_INTEGER)) {
2362 if (type == OP_MODULO
2363 || type == OP_DIVIDE
2364 || !(o->op_flags & OPf_KIDS))
2369 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2370 if (curop->op_type == OP_CONST) {
2371 if (SvIOK(((SVOP*)curop)->op_sv))
2375 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2379 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2386 Perl_gen_constant_list(pTHX_ register OP *o)
2389 I32 oldtmps_floor = PL_tmps_floor;
2393 return o; /* Don't attempt to run with errors */
2395 PL_op = curop = LINKLIST(o);
2402 PL_tmps_floor = oldtmps_floor;
2404 o->op_type = OP_RV2AV;
2405 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2406 curop = ((UNOP*)o)->op_first;
2407 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2414 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2416 if (!o || o->op_type != OP_LIST)
2417 o = newLISTOP(OP_LIST, 0, o, Nullop);
2419 o->op_flags &= ~OPf_WANT;
2421 if (!(PL_opargs[type] & OA_MARK))
2422 op_null(cLISTOPo->op_first);
2425 o->op_ppaddr = PL_ppaddr[type];
2426 o->op_flags |= flags;
2428 o = CHECKOP(type, o);
2429 if (o->op_type != type)
2432 return fold_constants(o);
2435 /* List constructors */
2438 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2446 if (first->op_type != type
2447 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2449 return newLISTOP(type, 0, first, last);
2452 if (first->op_flags & OPf_KIDS)
2453 ((LISTOP*)first)->op_last->op_sibling = last;
2455 first->op_flags |= OPf_KIDS;
2456 ((LISTOP*)first)->op_first = last;
2458 ((LISTOP*)first)->op_last = last;
2463 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2471 if (first->op_type != type)
2472 return prepend_elem(type, (OP*)first, (OP*)last);
2474 if (last->op_type != type)
2475 return append_elem(type, (OP*)first, (OP*)last);
2477 first->op_last->op_sibling = last->op_first;
2478 first->op_last = last->op_last;
2479 first->op_flags |= (last->op_flags & OPf_KIDS);
2481 #ifdef PL_OP_SLAB_ALLOC
2489 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2497 if (last->op_type == type) {
2498 if (type == OP_LIST) { /* already a PUSHMARK there */
2499 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2500 ((LISTOP*)last)->op_first->op_sibling = first;
2501 if (!(first->op_flags & OPf_PARENS))
2502 last->op_flags &= ~OPf_PARENS;
2505 if (!(last->op_flags & OPf_KIDS)) {
2506 ((LISTOP*)last)->op_last = first;
2507 last->op_flags |= OPf_KIDS;
2509 first->op_sibling = ((LISTOP*)last)->op_first;
2510 ((LISTOP*)last)->op_first = first;
2512 last->op_flags |= OPf_KIDS;
2516 return newLISTOP(type, 0, first, last);
2522 Perl_newNULLLIST(pTHX)
2524 return newOP(OP_STUB, 0);
2528 Perl_force_list(pTHX_ OP *o)
2530 if (!o || o->op_type != OP_LIST)
2531 o = newLISTOP(OP_LIST, 0, o, Nullop);
2537 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2541 NewOp(1101, listop, 1, LISTOP);
2543 listop->op_type = type;
2544 listop->op_ppaddr = PL_ppaddr[type];
2547 listop->op_flags = flags;
2551 else if (!first && last)
2554 first->op_sibling = last;
2555 listop->op_first = first;
2556 listop->op_last = last;
2557 if (type == OP_LIST) {
2559 pushop = newOP(OP_PUSHMARK, 0);
2560 pushop->op_sibling = first;
2561 listop->op_first = pushop;
2562 listop->op_flags |= OPf_KIDS;
2564 listop->op_last = pushop;
2571 Perl_newOP(pTHX_ I32 type, I32 flags)
2574 NewOp(1101, o, 1, OP);
2576 o->op_ppaddr = PL_ppaddr[type];
2577 o->op_flags = flags;
2580 o->op_private = 0 + (flags >> 8);
2581 if (PL_opargs[type] & OA_RETSCALAR)
2583 if (PL_opargs[type] & OA_TARGET)
2584 o->op_targ = pad_alloc(type, SVs_PADTMP);
2585 return CHECKOP(type, o);
2589 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2594 first = newOP(OP_STUB, 0);
2595 if (PL_opargs[type] & OA_MARK)
2596 first = force_list(first);
2598 NewOp(1101, unop, 1, UNOP);
2599 unop->op_type = type;
2600 unop->op_ppaddr = PL_ppaddr[type];
2601 unop->op_first = first;
2602 unop->op_flags = flags | OPf_KIDS;
2603 unop->op_private = 1 | (flags >> 8);
2604 unop = (UNOP*) CHECKOP(type, unop);
2608 return fold_constants((OP *) unop);
2612 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2615 NewOp(1101, binop, 1, BINOP);
2618 first = newOP(OP_NULL, 0);
2620 binop->op_type = type;
2621 binop->op_ppaddr = PL_ppaddr[type];
2622 binop->op_first = first;
2623 binop->op_flags = flags | OPf_KIDS;
2626 binop->op_private = 1 | (flags >> 8);
2629 binop->op_private = 2 | (flags >> 8);
2630 first->op_sibling = last;
2633 binop = (BINOP*)CHECKOP(type, binop);
2634 if (binop->op_next || binop->op_type != type)
2637 binop->op_last = binop->op_first->op_sibling;
2639 return fold_constants((OP *)binop);
2643 uvcompare(const void *a, const void *b)
2645 if (*((UV *)a) < (*(UV *)b))
2647 if (*((UV *)a) > (*(UV *)b))
2649 if (*((UV *)a+1) < (*(UV *)b+1))
2651 if (*((UV *)a+1) > (*(UV *)b+1))
2657 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2659 SV *tstr = ((SVOP*)expr)->op_sv;
2660 SV *rstr = ((SVOP*)repl)->op_sv;
2663 U8 *t = (U8*)SvPV(tstr, tlen);
2664 U8 *r = (U8*)SvPV(rstr, rlen);
2671 register short *tbl;
2673 PL_hints |= HINT_BLOCK_SCOPE;
2674 complement = o->op_private & OPpTRANS_COMPLEMENT;
2675 del = o->op_private & OPpTRANS_DELETE;
2676 squash = o->op_private & OPpTRANS_SQUASH;
2679 o->op_private |= OPpTRANS_FROM_UTF;
2682 o->op_private |= OPpTRANS_TO_UTF;
2684 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2685 SV* listsv = newSVpvn("# comment\n",10);
2687 U8* tend = t + tlen;
2688 U8* rend = r + rlen;
2702 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2703 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2709 tsave = t = bytes_to_utf8(t, &len);
2712 if (!to_utf && rlen) {
2714 rsave = r = bytes_to_utf8(r, &len);
2718 /* There are several snags with this code on EBCDIC:
2719 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2720 2. scan_const() in toke.c has encoded chars in native encoding which makes
2721 ranges at least in EBCDIC 0..255 range the bottom odd.
2725 U8 tmpbuf[UTF8_MAXLEN+1];
2728 New(1109, cp, 2*tlen, UV);
2730 transv = newSVpvn("",0);
2732 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2734 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2736 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2740 cp[2*i+1] = cp[2*i];
2744 qsort(cp, i, 2*sizeof(UV), uvcompare);
2745 for (j = 0; j < i; j++) {
2747 diff = val - nextmin;
2749 t = uvuni_to_utf8(tmpbuf,nextmin);
2750 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2752 U8 range_mark = UTF_TO_NATIVE(0xff);
2753 t = uvuni_to_utf8(tmpbuf, val - 1);
2754 sv_catpvn(transv, (char *)&range_mark, 1);
2755 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2762 t = uvuni_to_utf8(tmpbuf,nextmin);
2763 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2765 U8 range_mark = UTF_TO_NATIVE(0xff);
2766 sv_catpvn(transv, (char *)&range_mark, 1);
2768 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2769 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2770 t = (U8*)SvPVX(transv);
2771 tlen = SvCUR(transv);
2775 else if (!rlen && !del) {
2776 r = t; rlen = tlen; rend = tend;
2779 if ((!rlen && !del) || t == r ||
2780 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2782 o->op_private |= OPpTRANS_IDENTICAL;
2786 while (t < tend || tfirst <= tlast) {
2787 /* see if we need more "t" chars */
2788 if (tfirst > tlast) {
2789 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2791 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2793 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2800 /* now see if we need more "r" chars */
2801 if (rfirst > rlast) {
2803 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2805 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2807 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2816 rfirst = rlast = 0xffffffff;
2820 /* now see which range will peter our first, if either. */
2821 tdiff = tlast - tfirst;
2822 rdiff = rlast - rfirst;
2829 if (rfirst == 0xffffffff) {
2830 diff = tdiff; /* oops, pretend rdiff is infinite */
2832 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2833 (long)tfirst, (long)tlast);
2835 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2839 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2840 (long)tfirst, (long)(tfirst + diff),
2843 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2844 (long)tfirst, (long)rfirst);
2846 if (rfirst + diff > max)
2847 max = rfirst + diff;
2849 grows = (tfirst < rfirst &&
2850 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2862 else if (max > 0xff)
2867 Safefree(cPVOPo->op_pv);
2868 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2869 SvREFCNT_dec(listsv);
2871 SvREFCNT_dec(transv);
2873 if (!del && havefinal && rlen)
2874 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2875 newSVuv((UV)final), 0);
2878 o->op_private |= OPpTRANS_GROWS;
2890 tbl = (short*)cPVOPo->op_pv;
2892 Zero(tbl, 256, short);
2893 for (i = 0; i < tlen; i++)
2895 for (i = 0, j = 0; i < 256; i++) {
2906 if (i < 128 && r[j] >= 128)
2916 o->op_private |= OPpTRANS_IDENTICAL;
2921 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2922 tbl[0x100] = rlen - j;
2923 for (i=0; i < rlen - j; i++)
2924 tbl[0x101+i] = r[j+i];
2928 if (!rlen && !del) {
2931 o->op_private |= OPpTRANS_IDENTICAL;
2933 for (i = 0; i < 256; i++)
2935 for (i = 0, j = 0; i < tlen; i++,j++) {
2938 if (tbl[t[i]] == -1)
2944 if (tbl[t[i]] == -1) {
2945 if (t[i] < 128 && r[j] >= 128)
2952 o->op_private |= OPpTRANS_GROWS;
2960 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2964 NewOp(1101, pmop, 1, PMOP);
2965 pmop->op_type = type;
2966 pmop->op_ppaddr = PL_ppaddr[type];
2967 pmop->op_flags = flags;
2968 pmop->op_private = 0 | (flags >> 8);
2970 if (PL_hints & HINT_RE_TAINT)
2971 pmop->op_pmpermflags |= PMf_RETAINT;
2972 if (PL_hints & HINT_LOCALE)
2973 pmop->op_pmpermflags |= PMf_LOCALE;
2974 pmop->op_pmflags = pmop->op_pmpermflags;
2979 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2980 repointer = av_pop((AV*)PL_regex_pad[0]);
2981 pmop->op_pmoffset = SvIV(repointer);
2982 SvREPADTMP_off(repointer);
2983 sv_setiv(repointer,0);
2985 repointer = newSViv(0);
2986 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2987 pmop->op_pmoffset = av_len(PL_regex_padav);
2988 PL_regex_pad = AvARRAY(PL_regex_padav);
2993 /* link into pm list */
2994 if (type != OP_TRANS && PL_curstash) {
2995 pmop->op_pmnext = HvPMROOT(PL_curstash);
2996 HvPMROOT(PL_curstash) = pmop;
2997 PmopSTASH_set(pmop,PL_curstash);
3004 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3008 I32 repl_has_vars = 0;
3010 if (o->op_type == OP_TRANS)
3011 return pmtrans(o, expr, repl);
3013 PL_hints |= HINT_BLOCK_SCOPE;
3016 if (expr->op_type == OP_CONST) {
3018 SV *pat = ((SVOP*)expr)->op_sv;
3019 char *p = SvPV(pat, plen);
3020 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3021 sv_setpvn(pat, "\\s+", 3);
3022 p = SvPV(pat, plen);
3023 pm->op_pmflags |= PMf_SKIPWHITE;
3025 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3026 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3027 pm->op_pmflags |= PMf_WHITE;
3031 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3032 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3034 : OP_REGCMAYBE),0,expr);
3036 NewOp(1101, rcop, 1, LOGOP);
3037 rcop->op_type = OP_REGCOMP;
3038 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3039 rcop->op_first = scalar(expr);
3040 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3041 ? (OPf_SPECIAL | OPf_KIDS)
3043 rcop->op_private = 1;
3046 /* establish postfix order */
3047 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3049 rcop->op_next = expr;
3050 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3053 rcop->op_next = LINKLIST(expr);
3054 expr->op_next = (OP*)rcop;
3057 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3062 if (pm->op_pmflags & PMf_EVAL) {
3064 if (CopLINE(PL_curcop) < PL_multi_end)
3065 CopLINE_set(PL_curcop, PL_multi_end);
3067 #ifdef USE_5005THREADS
3068 else if (repl->op_type == OP_THREADSV
3069 && strchr("&`'123456789+",
3070 PL_threadsv_names[repl->op_targ]))
3074 #endif /* USE_5005THREADS */
3075 else if (repl->op_type == OP_CONST)
3079 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3080 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3081 #ifdef USE_5005THREADS
3082 if (curop->op_type == OP_THREADSV) {
3084 if (strchr("&`'123456789+", curop->op_private))
3088 if (curop->op_type == OP_GV) {
3089 GV *gv = cGVOPx_gv(curop);
3091 if (strchr("&`'123456789+", *GvENAME(gv)))
3094 #endif /* USE_5005THREADS */
3095 else if (curop->op_type == OP_RV2CV)
3097 else if (curop->op_type == OP_RV2SV ||
3098 curop->op_type == OP_RV2AV ||
3099 curop->op_type == OP_RV2HV ||
3100 curop->op_type == OP_RV2GV) {
3101 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3104 else if (curop->op_type == OP_PADSV ||
3105 curop->op_type == OP_PADAV ||
3106 curop->op_type == OP_PADHV ||
3107 curop->op_type == OP_PADANY) {
3110 else if (curop->op_type == OP_PUSHRE)
3111 ; /* Okay here, dangerous in newASSIGNOP */
3121 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3122 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3123 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3124 prepend_elem(o->op_type, scalar(repl), o);
3127 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3128 pm->op_pmflags |= PMf_MAYBE_CONST;
3129 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3131 NewOp(1101, rcop, 1, LOGOP);
3132 rcop->op_type = OP_SUBSTCONT;
3133 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3134 rcop->op_first = scalar(repl);
3135 rcop->op_flags |= OPf_KIDS;
3136 rcop->op_private = 1;
3139 /* establish postfix order */
3140 rcop->op_next = LINKLIST(repl);
3141 repl->op_next = (OP*)rcop;
3143 pm->op_pmreplroot = scalar((OP*)rcop);
3144 pm->op_pmreplstart = LINKLIST(rcop);
3153 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3156 NewOp(1101, svop, 1, SVOP);
3157 svop->op_type = type;
3158 svop->op_ppaddr = PL_ppaddr[type];
3160 svop->op_next = (OP*)svop;
3161 svop->op_flags = flags;
3162 if (PL_opargs[type] & OA_RETSCALAR)
3164 if (PL_opargs[type] & OA_TARGET)
3165 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3166 return CHECKOP(type, svop);
3170 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3173 NewOp(1101, padop, 1, PADOP);
3174 padop->op_type = type;
3175 padop->op_ppaddr = PL_ppaddr[type];
3176 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3177 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3178 PL_curpad[padop->op_padix] = sv;
3180 padop->op_next = (OP*)padop;
3181 padop->op_flags = flags;
3182 if (PL_opargs[type] & OA_RETSCALAR)
3184 if (PL_opargs[type] & OA_TARGET)
3185 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3186 return CHECKOP(type, padop);
3190 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3194 return newPADOP(type, flags, SvREFCNT_inc(gv));
3196 return newSVOP(type, flags, SvREFCNT_inc(gv));
3201 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3204 NewOp(1101, pvop, 1, PVOP);
3205 pvop->op_type = type;
3206 pvop->op_ppaddr = PL_ppaddr[type];
3208 pvop->op_next = (OP*)pvop;
3209 pvop->op_flags = flags;
3210 if (PL_opargs[type] & OA_RETSCALAR)
3212 if (PL_opargs[type] & OA_TARGET)
3213 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3214 return CHECKOP(type, pvop);
3218 Perl_package(pTHX_ OP *o)
3222 save_hptr(&PL_curstash);
3223 save_item(PL_curstname);
3228 name = SvPV(sv, len);
3229 PL_curstash = gv_stashpvn(name,len,TRUE);
3230 sv_setpvn(PL_curstname, name, len);
3234 deprecate("\"package\" with no arguments");
3235 sv_setpv(PL_curstname,"<none>");
3236 PL_curstash = Nullhv;
3238 PL_hints |= HINT_BLOCK_SCOPE;
3239 PL_copline = NOLINE;
3244 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3249 char *packname = Nullch;
3253 if (id->op_type != OP_CONST)
3254 Perl_croak(aTHX_ "Module name must be constant");
3258 if (version != Nullop) {
3259 SV *vesv = ((SVOP*)version)->op_sv;
3261 if (arg == Nullop && !SvNIOKp(vesv)) {
3268 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3269 Perl_croak(aTHX_ "Version number must be constant number");
3271 /* Make copy of id so we don't free it twice */
3272 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3274 /* Fake up a method call to VERSION */
3275 meth = newSVpvn("VERSION",7);
3276 sv_upgrade(meth, SVt_PVIV);
3277 (void)SvIOK_on(meth);
3278 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3279 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3280 append_elem(OP_LIST,
3281 prepend_elem(OP_LIST, pack, list(version)),
3282 newSVOP(OP_METHOD_NAMED, 0, meth)));
3286 /* Fake up an import/unimport */
3287 if (arg && arg->op_type == OP_STUB)
3288 imop = arg; /* no import on explicit () */
3289 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3290 imop = Nullop; /* use 5.0; */
3295 /* Make copy of id so we don't free it twice */
3296 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3298 /* Fake up a method call to import/unimport */
3299 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3300 sv_upgrade(meth, SVt_PVIV);
3301 (void)SvIOK_on(meth);
3302 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3303 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3304 append_elem(OP_LIST,
3305 prepend_elem(OP_LIST, pack, list(arg)),
3306 newSVOP(OP_METHOD_NAMED, 0, meth)));
3309 if (ckWARN(WARN_MISC) &&
3310 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3311 SvPOK(packsv = ((SVOP*)id)->op_sv))
3313 /* BEGIN will free the ops, so we need to make a copy */
3314 packlen = SvCUR(packsv);
3315 packname = savepvn(SvPVX(packsv), packlen);
3318 /* Fake up the BEGIN {}, which does its thing immediately. */
3320 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3323 append_elem(OP_LINESEQ,
3324 append_elem(OP_LINESEQ,
3325 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3326 newSTATEOP(0, Nullch, veop)),
3327 newSTATEOP(0, Nullch, imop) ));
3330 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3331 Perl_warner(aTHX_ WARN_MISC,
3332 "Package `%s' not found "
3333 "(did you use the incorrect case?)", packname);
3338 PL_hints |= HINT_BLOCK_SCOPE;
3339 PL_copline = NOLINE;
3344 =for apidoc load_module
3346 Loads the module whose name is pointed to by the string part of name.
3347 Note that the actual module name, not its filename, should be given.
3348 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3349 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3350 (or 0 for no flags). ver, if specified, provides version semantics
3351 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3352 arguments can be used to specify arguments to the module's import()
3353 method, similar to C<use Foo::Bar VERSION LIST>.
3358 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3361 va_start(args, ver);
3362 vload_module(flags, name, ver, &args);
3366 #ifdef PERL_IMPLICIT_CONTEXT
3368 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3372 va_start(args, ver);
3373 vload_module(flags, name, ver, &args);
3379 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3381 OP *modname, *veop, *imop;
3383 modname = newSVOP(OP_CONST, 0, name);
3384 modname->op_private |= OPpCONST_BARE;
3386 veop = newSVOP(OP_CONST, 0, ver);
3390 if (flags & PERL_LOADMOD_NOIMPORT) {
3391 imop = sawparens(newNULLLIST());
3393 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3394 imop = va_arg(*args, OP*);
3399 sv = va_arg(*args, SV*);
3401 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3402 sv = va_arg(*args, SV*);
3406 line_t ocopline = PL_copline;
3407 int oexpect = PL_expect;
3409 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3410 veop, modname, imop);
3411 PL_expect = oexpect;
3412 PL_copline = ocopline;
3417 Perl_dofile(pTHX_ OP *term)
3422 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3423 if (!(gv && GvIMPORTED_CV(gv)))
3424 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3426 if (gv && GvIMPORTED_CV(gv)) {
3427 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3428 append_elem(OP_LIST, term,
3429 scalar(newUNOP(OP_RV2CV, 0,
3434 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3440 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3442 return newBINOP(OP_LSLICE, flags,
3443 list(force_list(subscript)),
3444 list(force_list(listval)) );
3448 S_list_assignment(pTHX_ register OP *o)
3453 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3454 o = cUNOPo->op_first;
3456 if (o->op_type == OP_COND_EXPR) {
3457 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3458 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3463 yyerror("Assignment to both a list and a scalar");
3467 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3468 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3469 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3472 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3475 if (o->op_type == OP_RV2SV)
3482 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3487 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3488 return newLOGOP(optype, 0,
3489 mod(scalar(left), optype),
3490 newUNOP(OP_SASSIGN, 0, scalar(right)));
3493 return newBINOP(optype, OPf_STACKED,
3494 mod(scalar(left), optype), scalar(right));
3498 if (list_assignment(left)) {
3502 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3503 left = mod(left, OP_AASSIGN);
3511 curop = list(force_list(left));
3512 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3513 o->op_private = 0 | (flags >> 8);
3514 for (curop = ((LISTOP*)curop)->op_first;
3515 curop; curop = curop->op_sibling)
3517 if (curop->op_type == OP_RV2HV &&
3518 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3519 o->op_private |= OPpASSIGN_HASH;
3523 if (!(left->op_private & OPpLVAL_INTRO)) {
3526 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3527 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3528 if (curop->op_type == OP_GV) {
3529 GV *gv = cGVOPx_gv(curop);
3530 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3532 SvCUR(gv) = PL_generation;
3534 else if (curop->op_type == OP_PADSV ||
3535 curop->op_type == OP_PADAV ||
3536 curop->op_type == OP_PADHV ||
3537 curop->op_type == OP_PADANY) {
3538 SV **svp = AvARRAY(PL_comppad_name);
3539 SV *sv = svp[curop->op_targ];
3540 if (SvCUR(sv) == PL_generation)
3542 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3544 else if (curop->op_type == OP_RV2CV)
3546 else if (curop->op_type == OP_RV2SV ||
3547 curop->op_type == OP_RV2AV ||
3548 curop->op_type == OP_RV2HV ||
3549 curop->op_type == OP_RV2GV) {
3550 if (lastop->op_type != OP_GV) /* funny deref? */
3553 else if (curop->op_type == OP_PUSHRE) {
3554 if (((PMOP*)curop)->op_pmreplroot) {
3556 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3558 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3560 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3562 SvCUR(gv) = PL_generation;
3571 o->op_private |= OPpASSIGN_COMMON;
3573 if (right && right->op_type == OP_SPLIT) {
3575 if ((tmpop = ((LISTOP*)right)->op_first) &&
3576 tmpop->op_type == OP_PUSHRE)
3578 PMOP *pm = (PMOP*)tmpop;
3579 if (left->op_type == OP_RV2AV &&
3580 !(left->op_private & OPpLVAL_INTRO) &&
3581 !(o->op_private & OPpASSIGN_COMMON) )
3583 tmpop = ((UNOP*)left)->op_first;
3584 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3586 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3587 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3589 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3590 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3592 pm->op_pmflags |= PMf_ONCE;
3593 tmpop = cUNOPo->op_first; /* to list (nulled) */
3594 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3595 tmpop->op_sibling = Nullop; /* don't free split */
3596 right->op_next = tmpop->op_next; /* fix starting loc */
3597 op_free(o); /* blow off assign */
3598 right->op_flags &= ~OPf_WANT;
3599 /* "I don't know and I don't care." */
3604 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3605 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3607 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3609 sv_setiv(sv, PL_modcount+1);
3617 right = newOP(OP_UNDEF, 0);
3618 if (right->op_type == OP_READLINE) {
3619 right->op_flags |= OPf_STACKED;
3620 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3623 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3624 o = newBINOP(OP_SASSIGN, flags,
3625 scalar(right), mod(scalar(left), OP_SASSIGN) );
3637 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3639 U32 seq = intro_my();
3642 NewOp(1101, cop, 1, COP);
3643 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3644 cop->op_type = OP_DBSTATE;
3645 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3648 cop->op_type = OP_NEXTSTATE;
3649 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3651 cop->op_flags = flags;
3652 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3654 cop->op_private |= NATIVE_HINTS;
3656 PL_compiling.op_private = cop->op_private;
3657 cop->op_next = (OP*)cop;
3660 cop->cop_label = label;
3661 PL_hints |= HINT_BLOCK_SCOPE;
3664 cop->cop_arybase = PL_curcop->cop_arybase;
3665 if (specialWARN(PL_curcop->cop_warnings))
3666 cop->cop_warnings = PL_curcop->cop_warnings ;
3668 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3669 if (specialCopIO(PL_curcop->cop_io))
3670 cop->cop_io = PL_curcop->cop_io;
3672 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3675 if (PL_copline == NOLINE)
3676 CopLINE_set(cop, CopLINE(PL_curcop));
3678 CopLINE_set(cop, PL_copline);
3679 PL_copline = NOLINE;
3682 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3684 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3686 CopSTASH_set(cop, PL_curstash);
3688 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3689 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3690 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3691 (void)SvIOK_on(*svp);
3692 SvIVX(*svp) = PTR2IV(cop);
3696 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3699 /* "Introduce" my variables to visible status. */
3707 if (! PL_min_intro_pending)
3708 return PL_cop_seqmax;
3710 svp = AvARRAY(PL_comppad_name);
3711 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3712 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3713 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3714 SvNVX(sv) = (NV)PL_cop_seqmax;
3717 PL_min_intro_pending = 0;
3718 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3719 return PL_cop_seqmax++;
3723 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3725 return new_logop(type, flags, &first, &other);
3729 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3733 OP *first = *firstp;
3734 OP *other = *otherp;
3736 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3737 return newBINOP(type, flags, scalar(first), scalar(other));
3739 scalarboolean(first);
3740 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3741 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3742 if (type == OP_AND || type == OP_OR) {
3748 first = *firstp = cUNOPo->op_first;
3750 first->op_next = o->op_next;
3751 cUNOPo->op_first = Nullop;
3755 if (first->op_type == OP_CONST) {
3756 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3757 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3758 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3769 else if (first->op_type == OP_WANTARRAY) {
3775 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3776 OP *k1 = ((UNOP*)first)->op_first;
3777 OP *k2 = k1->op_sibling;
3779 switch (first->op_type)
3782 if (k2 && k2->op_type == OP_READLINE
3783 && (k2->op_flags & OPf_STACKED)
3784 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3786 warnop = k2->op_type;
3791 if (k1->op_type == OP_READDIR
3792 || k1->op_type == OP_GLOB
3793 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3794 || k1->op_type == OP_EACH)
3796 warnop = ((k1->op_type == OP_NULL)
3797 ? k1->op_targ : k1->op_type);
3802 line_t oldline = CopLINE(PL_curcop);
3803 CopLINE_set(PL_curcop, PL_copline);
3804 Perl_warner(aTHX_ WARN_MISC,
3805 "Value of %s%s can be \"0\"; test with defined()",
3807 ((warnop == OP_READLINE || warnop == OP_GLOB)
3808 ? " construct" : "() operator"));
3809 CopLINE_set(PL_curcop, oldline);
3816 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3817 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3819 NewOp(1101, logop, 1, LOGOP);
3821 logop->op_type = type;
3822 logop->op_ppaddr = PL_ppaddr[type];
3823 logop->op_first = first;
3824 logop->op_flags = flags | OPf_KIDS;
3825 logop->op_other = LINKLIST(other);
3826 logop->op_private = 1 | (flags >> 8);
3828 /* establish postfix order */
3829 logop->op_next = LINKLIST(first);
3830 first->op_next = (OP*)logop;
3831 first->op_sibling = other;
3833 o = newUNOP(OP_NULL, 0, (OP*)logop);
3840 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3847 return newLOGOP(OP_AND, 0, first, trueop);
3849 return newLOGOP(OP_OR, 0, first, falseop);
3851 scalarboolean(first);
3852 if (first->op_type == OP_CONST) {
3853 if (SvTRUE(((SVOP*)first)->op_sv)) {
3864 else if (first->op_type == OP_WANTARRAY) {
3868 NewOp(1101, logop, 1, LOGOP);
3869 logop->op_type = OP_COND_EXPR;
3870 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3871 logop->op_first = first;
3872 logop->op_flags = flags | OPf_KIDS;
3873 logop->op_private = 1 | (flags >> 8);
3874 logop->op_other = LINKLIST(trueop);
3875 logop->op_next = LINKLIST(falseop);
3878 /* establish postfix order */
3879 start = LINKLIST(first);
3880 first->op_next = (OP*)logop;
3882 first->op_sibling = trueop;
3883 trueop->op_sibling = falseop;
3884 o = newUNOP(OP_NULL, 0, (OP*)logop);
3886 trueop->op_next = falseop->op_next = o;
3893 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3901 NewOp(1101, range, 1, LOGOP);
3903 range->op_type = OP_RANGE;
3904 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3905 range->op_first = left;
3906 range->op_flags = OPf_KIDS;
3907 leftstart = LINKLIST(left);
3908 range->op_other = LINKLIST(right);
3909 range->op_private = 1 | (flags >> 8);
3911 left->op_sibling = right;
3913 range->op_next = (OP*)range;
3914 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3915 flop = newUNOP(OP_FLOP, 0, flip);
3916 o = newUNOP(OP_NULL, 0, flop);
3918 range->op_next = leftstart;
3920 left->op_next = flip;
3921 right->op_next = flop;
3923 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3924 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3925 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3926 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3928 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3929 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3932 if (!flip->op_private || !flop->op_private)
3933 linklist(o); /* blow off optimizer unless constant */
3939 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3943 int once = block && block->op_flags & OPf_SPECIAL &&
3944 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3947 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3948 return block; /* do {} while 0 does once */
3949 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3950 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3951 expr = newUNOP(OP_DEFINED, 0,
3952 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3953 } else if (expr->op_flags & OPf_KIDS) {
3954 OP *k1 = ((UNOP*)expr)->op_first;
3955 OP *k2 = (k1) ? k1->op_sibling : NULL;
3956 switch (expr->op_type) {
3958 if (k2 && k2->op_type == OP_READLINE
3959 && (k2->op_flags & OPf_STACKED)
3960 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3961 expr = newUNOP(OP_DEFINED, 0, expr);
3965 if (k1->op_type == OP_READDIR
3966 || k1->op_type == OP_GLOB
3967 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3968 || k1->op_type == OP_EACH)
3969 expr = newUNOP(OP_DEFINED, 0, expr);
3975 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3976 o = new_logop(OP_AND, 0, &expr, &listop);
3979 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3981 if (once && o != listop)
3982 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3985 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3987 o->op_flags |= flags;
3989 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3994 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4002 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4003 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4004 expr = newUNOP(OP_DEFINED, 0,
4005 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4006 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4007 OP *k1 = ((UNOP*)expr)->op_first;
4008 OP *k2 = (k1) ? k1->op_sibling : NULL;
4009 switch (expr->op_type) {
4011 if (k2 && k2->op_type == OP_READLINE
4012 && (k2->op_flags & OPf_STACKED)
4013 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4014 expr = newUNOP(OP_DEFINED, 0, expr);
4018 if (k1->op_type == OP_READDIR
4019 || k1->op_type == OP_GLOB
4020 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4021 || k1->op_type == OP_EACH)
4022 expr = newUNOP(OP_DEFINED, 0, expr);
4028 block = newOP(OP_NULL, 0);
4030 block = scope(block);
4034 next = LINKLIST(cont);
4037 OP *unstack = newOP(OP_UNSTACK, 0);
4040 cont = append_elem(OP_LINESEQ, cont, unstack);
4041 if ((line_t)whileline != NOLINE) {
4042 PL_copline = whileline;
4043 cont = append_elem(OP_LINESEQ, cont,
4044 newSTATEOP(0, Nullch, Nullop));
4048 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4049 redo = LINKLIST(listop);
4052 PL_copline = whileline;
4054 o = new_logop(OP_AND, 0, &expr, &listop);
4055 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4056 op_free(expr); /* oops, it's a while (0) */
4058 return Nullop; /* listop already freed by new_logop */
4061 ((LISTOP*)listop)->op_last->op_next =
4062 (o == listop ? redo : LINKLIST(o));
4068 NewOp(1101,loop,1,LOOP);
4069 loop->op_type = OP_ENTERLOOP;
4070 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4071 loop->op_private = 0;
4072 loop->op_next = (OP*)loop;
4075 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4077 loop->op_redoop = redo;
4078 loop->op_lastop = o;
4079 o->op_private |= loopflags;
4082 loop->op_nextop = next;
4084 loop->op_nextop = o;
4086 o->op_flags |= flags;
4087 o->op_private |= (flags >> 8);
4092 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4100 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4101 sv->op_type = OP_RV2GV;
4102 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4104 else if (sv->op_type == OP_PADSV) { /* private variable */
4105 padoff = sv->op_targ;
4110 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4111 padoff = sv->op_targ;
4113 iterflags |= OPf_SPECIAL;
4118 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4121 #ifdef USE_5005THREADS
4122 padoff = find_threadsv("_");
4123 iterflags |= OPf_SPECIAL;
4125 sv = newGVOP(OP_GV, 0, PL_defgv);
4128 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4129 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4130 iterflags |= OPf_STACKED;
4132 else if (expr->op_type == OP_NULL &&
4133 (expr->op_flags & OPf_KIDS) &&
4134 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4136 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4137 * set the STACKED flag to indicate that these values are to be
4138 * treated as min/max values by 'pp_iterinit'.
4140 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4141 LOGOP* range = (LOGOP*) flip->op_first;
4142 OP* left = range->op_first;
4143 OP* right = left->op_sibling;
4146 range->op_flags &= ~OPf_KIDS;
4147 range->op_first = Nullop;
4149 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4150 listop->op_first->op_next = range->op_next;
4151 left->op_next = range->op_other;
4152 right->op_next = (OP*)listop;
4153 listop->op_next = listop->op_first;
4156 expr = (OP*)(listop);
4158 iterflags |= OPf_STACKED;
4161 expr = mod(force_list(expr), OP_GREPSTART);
4165 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4166 append_elem(OP_LIST, expr, scalar(sv))));
4167 assert(!loop->op_next);
4168 #ifdef PL_OP_SLAB_ALLOC
4171 NewOp(1234,tmp,1,LOOP);
4172 Copy(loop,tmp,1,LOOP);
4176 Renew(loop, 1, LOOP);
4178 loop->op_targ = padoff;
4179 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4180 PL_copline = forline;
4181 return newSTATEOP(0, label, wop);
4185 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4190 if (type != OP_GOTO || label->op_type == OP_CONST) {
4191 /* "last()" means "last" */
4192 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4193 o = newOP(type, OPf_SPECIAL);
4195 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4196 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4202 if (label->op_type == OP_ENTERSUB)
4203 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4204 o = newUNOP(type, OPf_STACKED, label);
4206 PL_hints |= HINT_BLOCK_SCOPE;
4211 Perl_cv_undef(pTHX_ CV *cv)
4213 #ifdef USE_5005THREADS
4215 MUTEX_DESTROY(CvMUTEXP(cv));
4216 Safefree(CvMUTEXP(cv));
4219 #endif /* USE_5005THREADS */
4222 if (CvFILE(cv) && !CvXSUB(cv)) {
4223 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4224 Safefree(CvFILE(cv));
4229 if (!CvXSUB(cv) && CvROOT(cv)) {
4230 #ifdef USE_5005THREADS
4231 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4232 Perl_croak(aTHX_ "Can't undef active subroutine");
4235 Perl_croak(aTHX_ "Can't undef active subroutine");
4236 #endif /* USE_5005THREADS */
4239 SAVEVPTR(PL_curpad);
4242 op_free(CvROOT(cv));
4243 CvROOT(cv) = Nullop;
4246 SvPOK_off((SV*)cv); /* forget prototype */
4248 /* Since closure prototypes have the same lifetime as the containing
4249 * CV, they don't hold a refcount on the outside CV. This avoids
4250 * the refcount loop between the outer CV (which keeps a refcount to
4251 * the closure prototype in the pad entry for pp_anoncode()) and the
4252 * closure prototype, and the ensuing memory leak. This does not
4253 * apply to closures generated within eval"", since eval"" CVs are
4254 * ephemeral. --GSAR */
4255 if (!CvANON(cv) || CvCLONED(cv)
4256 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4257 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4259 SvREFCNT_dec(CvOUTSIDE(cv));
4261 CvOUTSIDE(cv) = Nullcv;
4263 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4266 if (CvPADLIST(cv)) {
4267 /* may be during global destruction */
4268 if (SvREFCNT(CvPADLIST(cv))) {
4269 I32 i = AvFILLp(CvPADLIST(cv));
4271 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4272 SV* sv = svp ? *svp : Nullsv;
4275 if (sv == (SV*)PL_comppad_name)
4276 PL_comppad_name = Nullav;
4277 else if (sv == (SV*)PL_comppad) {
4278 PL_comppad = Nullav;
4279 PL_curpad = Null(SV**);
4283 SvREFCNT_dec((SV*)CvPADLIST(cv));
4285 CvPADLIST(cv) = Nullav;
4293 #ifdef DEBUG_CLOSURES
4295 S_cv_dump(pTHX_ CV *cv)
4298 CV *outside = CvOUTSIDE(cv);
4299 AV* padlist = CvPADLIST(cv);
4306 PerlIO_printf(Perl_debug_log,
4307 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4309 (CvANON(cv) ? "ANON"
4310 : (cv == PL_main_cv) ? "MAIN"
4311 : CvUNIQUE(cv) ? "UNIQUE"
4312 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4315 : CvANON(outside) ? "ANON"
4316 : (outside == PL_main_cv) ? "MAIN"
4317 : CvUNIQUE(outside) ? "UNIQUE"
4318 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4323 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4324 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4325 pname = AvARRAY(pad_name);
4326 ppad = AvARRAY(pad);
4328 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4329 if (SvPOK(pname[ix]))
4330 PerlIO_printf(Perl_debug_log,
4331 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4332 (int)ix, PTR2UV(ppad[ix]),
4333 SvFAKE(pname[ix]) ? "FAKE " : "",
4335 (IV)I_32(SvNVX(pname[ix])),
4338 #endif /* DEBUGGING */
4340 #endif /* DEBUG_CLOSURES */
4343 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4347 AV* protopadlist = CvPADLIST(proto);
4348 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4349 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4350 SV** pname = AvARRAY(protopad_name);
4351 SV** ppad = AvARRAY(protopad);
4352 I32 fname = AvFILLp(protopad_name);
4353 I32 fpad = AvFILLp(protopad);
4357 assert(!CvUNIQUE(proto));
4361 SAVESPTR(PL_comppad_name);
4362 SAVESPTR(PL_compcv);
4364 cv = PL_compcv = (CV*)NEWSV(1104,0);
4365 sv_upgrade((SV *)cv, SvTYPE(proto));
4366 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4369 #ifdef USE_5005THREADS
4370 New(666, CvMUTEXP(cv), 1, perl_mutex);
4371 MUTEX_INIT(CvMUTEXP(cv));
4373 #endif /* USE_5005THREADS */
4375 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4376 : savepv(CvFILE(proto));
4378 CvFILE(cv) = CvFILE(proto);
4380 CvGV(cv) = CvGV(proto);
4381 CvSTASH(cv) = CvSTASH(proto);
4382 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4383 CvSTART(cv) = CvSTART(proto);
4385 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4388 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4390 PL_comppad_name = newAV();
4391 for (ix = fname; ix >= 0; ix--)
4392 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4394 PL_comppad = newAV();
4396 comppadlist = newAV();
4397 AvREAL_off(comppadlist);
4398 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4399 av_store(comppadlist, 1, (SV*)PL_comppad);
4400 CvPADLIST(cv) = comppadlist;
4401 av_fill(PL_comppad, AvFILLp(protopad));
4402 PL_curpad = AvARRAY(PL_comppad);
4404 av = newAV(); /* will be @_ */
4406 av_store(PL_comppad, 0, (SV*)av);
4407 AvFLAGS(av) = AVf_REIFY;
4409 for (ix = fpad; ix > 0; ix--) {
4410 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4411 if (namesv && namesv != &PL_sv_undef) {
4412 char *name = SvPVX(namesv); /* XXX */
4413 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4414 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4415 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4417 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4419 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4421 else { /* our own lexical */
4424 /* anon code -- we'll come back for it */
4425 sv = SvREFCNT_inc(ppad[ix]);
4427 else if (*name == '@')
4429 else if (*name == '%')
4438 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4439 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4442 SV* sv = NEWSV(0,0);
4448 /* Now that vars are all in place, clone nested closures. */
4450 for (ix = fpad; ix > 0; ix--) {
4451 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4453 && namesv != &PL_sv_undef
4454 && !(SvFLAGS(namesv) & SVf_FAKE)
4455 && *SvPVX(namesv) == '&'
4456 && CvCLONE(ppad[ix]))
4458 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4459 SvREFCNT_dec(ppad[ix]);
4462 PL_curpad[ix] = (SV*)kid;
4466 #ifdef DEBUG_CLOSURES
4467 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4469 PerlIO_printf(Perl_debug_log, " from:\n");
4471 PerlIO_printf(Perl_debug_log, " to:\n");
4478 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4480 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4482 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4489 Perl_cv_clone(pTHX_ CV *proto)
4492 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4493 cv = cv_clone2(proto, CvOUTSIDE(proto));
4494 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4499 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4501 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4502 SV* msg = sv_newmortal();
4506 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4507 sv_setpv(msg, "Prototype mismatch:");
4509 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4511 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4512 sv_catpv(msg, " vs ");
4514 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4516 sv_catpv(msg, "none");
4517 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4521 static void const_sv_xsub(pTHX_ CV* cv);
4524 =for apidoc cv_const_sv
4526 If C<cv> is a constant sub eligible for inlining. returns the constant
4527 value returned by the sub. Otherwise, returns NULL.
4529 Constant subs can be created with C<newCONSTSUB> or as described in
4530 L<perlsub/"Constant Functions">.
4535 Perl_cv_const_sv(pTHX_ CV *cv)
4537 if (!cv || !CvCONST(cv))
4539 return (SV*)CvXSUBANY(cv).any_ptr;
4543 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4550 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4551 o = cLISTOPo->op_first->op_sibling;
4553 for (; o; o = o->op_next) {
4554 OPCODE type = o->op_type;
4556 if (sv && o->op_next == o)
4558 if (o->op_next != o) {
4559 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4561 if (type == OP_DBSTATE)
4564 if (type == OP_LEAVESUB || type == OP_RETURN)
4568 if (type == OP_CONST && cSVOPo->op_sv)
4570 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4571 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4572 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4576 /* We get here only from cv_clone2() while creating a closure.
4577 Copy the const value here instead of in cv_clone2 so that
4578 SvREADONLY_on doesn't lead to problems when leaving
4583 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4595 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4605 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4609 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4611 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4615 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4621 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4626 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4627 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4628 SV *sv = sv_newmortal();
4629 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4630 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4635 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4636 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4646 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4647 maximum a prototype before. */
4648 if (SvTYPE(gv) > SVt_NULL) {
4649 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4650 && ckWARN_d(WARN_PROTOTYPE))
4652 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4654 cv_ckproto((CV*)gv, NULL, ps);
4657 sv_setpv((SV*)gv, ps);
4659 sv_setiv((SV*)gv, -1);
4660 SvREFCNT_dec(PL_compcv);
4661 cv = PL_compcv = NULL;
4662 PL_sub_generation++;
4666 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4668 #ifdef GV_UNIQUE_CHECK
4669 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4670 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4674 if (!block || !ps || *ps || attrs)
4677 const_sv = op_const_sv(block, Nullcv);
4680 bool exists = CvROOT(cv) || CvXSUB(cv);
4682 #ifdef GV_UNIQUE_CHECK
4683 if (exists && GvUNIQUE(gv)) {
4684 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4688 /* if the subroutine doesn't exist and wasn't pre-declared
4689 * with a prototype, assume it will be AUTOLOADed,
4690 * skipping the prototype check
4692 if (exists || SvPOK(cv))
4693 cv_ckproto(cv, gv, ps);
4694 /* already defined (or promised)? */
4695 if (exists || GvASSUMECV(gv)) {
4696 if (!block && !attrs) {
4697 /* just a "sub foo;" when &foo is already defined */
4698 SAVEFREESV(PL_compcv);
4701 /* ahem, death to those who redefine active sort subs */
4702 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4703 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4705 if (ckWARN(WARN_REDEFINE)
4707 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4709 line_t oldline = CopLINE(PL_curcop);
4710 if (PL_copline != NOLINE)
4711 CopLINE_set(PL_curcop, PL_copline);
4712 Perl_warner(aTHX_ WARN_REDEFINE,
4713 CvCONST(cv) ? "Constant subroutine %s redefined"
4714 : "Subroutine %s redefined", name);
4715 CopLINE_set(PL_curcop, oldline);
4723 SvREFCNT_inc(const_sv);
4725 assert(!CvROOT(cv) && !CvCONST(cv));
4726 sv_setpv((SV*)cv, ""); /* prototype is "" */
4727 CvXSUBANY(cv).any_ptr = const_sv;
4728 CvXSUB(cv) = const_sv_xsub;
4733 cv = newCONSTSUB(NULL, name, const_sv);
4736 SvREFCNT_dec(PL_compcv);
4738 PL_sub_generation++;
4745 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4746 * before we clobber PL_compcv.
4750 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4751 stash = GvSTASH(CvGV(cv));
4752 else if (CvSTASH(cv))
4753 stash = CvSTASH(cv);
4755 stash = PL_curstash;
4758 /* possibly about to re-define existing subr -- ignore old cv */
4759 rcv = (SV*)PL_compcv;
4760 if (name && GvSTASH(gv))
4761 stash = GvSTASH(gv);
4763 stash = PL_curstash;
4765 apply_attrs(stash, rcv, attrs);
4767 if (cv) { /* must reuse cv if autoloaded */
4769 /* got here with just attrs -- work done, so bug out */
4770 SAVEFREESV(PL_compcv);
4774 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4775 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4776 CvOUTSIDE(PL_compcv) = 0;
4777 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4778 CvPADLIST(PL_compcv) = 0;
4779 /* inner references to PL_compcv must be fixed up ... */
4781 AV *padlist = CvPADLIST(cv);
4782 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4783 AV *comppad = (AV*)AvARRAY(padlist)[1];
4784 SV **namepad = AvARRAY(comppad_name);
4785 SV **curpad = AvARRAY(comppad);
4786 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4787 SV *namesv = namepad[ix];
4788 if (namesv && namesv != &PL_sv_undef
4789 && *SvPVX(namesv) == '&')
4791 CV *innercv = (CV*)curpad[ix];
4792 if (CvOUTSIDE(innercv) == PL_compcv) {
4793 CvOUTSIDE(innercv) = cv;
4794 if (!CvANON(innercv) || CvCLONED(innercv)) {
4795 (void)SvREFCNT_inc(cv);
4796 SvREFCNT_dec(PL_compcv);
4802 /* ... before we throw it away */
4803 SvREFCNT_dec(PL_compcv);
4804 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4805 ++PL_sub_generation;
4812 PL_sub_generation++;
4816 CvFILE_set_from_cop(cv, PL_curcop);
4817 CvSTASH(cv) = PL_curstash;
4818 #ifdef USE_5005THREADS
4820 if (!CvMUTEXP(cv)) {
4821 New(666, CvMUTEXP(cv), 1, perl_mutex);
4822 MUTEX_INIT(CvMUTEXP(cv));
4824 #endif /* USE_5005THREADS */
4827 sv_setpv((SV*)cv, ps);
4829 if (PL_error_count) {
4833 char *s = strrchr(name, ':');
4835 if (strEQ(s, "BEGIN")) {
4837 "BEGIN not safe after errors--compilation aborted";
4838 if (PL_in_eval & EVAL_KEEPERR)
4839 Perl_croak(aTHX_ not_safe);
4841 /* force display of errors found but not reported */
4842 sv_catpv(ERRSV, not_safe);
4843 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4851 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4852 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4855 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4856 mod(scalarseq(block), OP_LEAVESUBLV));
4859 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4861 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4862 OpREFCNT_set(CvROOT(cv), 1);
4863 CvSTART(cv) = LINKLIST(CvROOT(cv));
4864 CvROOT(cv)->op_next = 0;
4865 CALL_PEEP(CvSTART(cv));
4867 /* now that optimizer has done its work, adjust pad values */
4869 SV **namep = AvARRAY(PL_comppad_name);
4870 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4873 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4876 * The only things that a clonable function needs in its
4877 * pad are references to outer lexicals and anonymous subs.
4878 * The rest are created anew during cloning.
4880 if (!((namesv = namep[ix]) != Nullsv &&
4881 namesv != &PL_sv_undef &&
4883 *SvPVX(namesv) == '&')))
4885 SvREFCNT_dec(PL_curpad[ix]);
4886 PL_curpad[ix] = Nullsv;
4889 assert(!CvCONST(cv));
4890 if (ps && !*ps && op_const_sv(block, cv))
4894 AV *av = newAV(); /* Will be @_ */
4896 av_store(PL_comppad, 0, (SV*)av);
4897 AvFLAGS(av) = AVf_REIFY;
4899 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4900 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4902 if (!SvPADMY(PL_curpad[ix]))
4903 SvPADTMP_on(PL_curpad[ix]);
4907 /* If a potential closure prototype, don't keep a refcount on
4908 * outer CV, unless the latter happens to be a passing eval"".
4909 * This is okay as the lifetime of the prototype is tied to the
4910 * lifetime of the outer CV. Avoids memory leak due to reference
4912 if (!name && CvOUTSIDE(cv)
4913 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4914 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4916 SvREFCNT_dec(CvOUTSIDE(cv));
4919 if (name || aname) {
4921 char *tname = (name ? name : aname);
4923 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4924 SV *sv = NEWSV(0,0);
4925 SV *tmpstr = sv_newmortal();
4926 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4930 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4932 (long)PL_subline, (long)CopLINE(PL_curcop));
4933 gv_efullname3(tmpstr, gv, Nullch);
4934 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4935 hv = GvHVn(db_postponed);
4936 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4937 && (pcv = GvCV(db_postponed)))
4943 call_sv((SV*)pcv, G_DISCARD);
4947 if ((s = strrchr(tname,':')))
4952 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4955 if (strEQ(s, "BEGIN")) {
4956 I32 oldscope = PL_scopestack_ix;
4958 SAVECOPFILE(&PL_compiling);
4959 SAVECOPLINE(&PL_compiling);
4962 PL_beginav = newAV();
4963 DEBUG_x( dump_sub(gv) );
4964 av_push(PL_beginav, (SV*)cv);
4965 GvCV(gv) = 0; /* cv has been hijacked */
4966 call_list(oldscope, PL_beginav);
4968 PL_curcop = &PL_compiling;
4969 PL_compiling.op_private = PL_hints;
4972 else if (strEQ(s, "END") && !PL_error_count) {
4975 DEBUG_x( dump_sub(gv) );
4976 av_unshift(PL_endav, 1);
4977 av_store(PL_endav, 0, (SV*)cv);
4978 GvCV(gv) = 0; /* cv has been hijacked */
4980 else if (strEQ(s, "CHECK") && !PL_error_count) {
4982 PL_checkav = newAV();
4983 DEBUG_x( dump_sub(gv) );
4984 if (PL_main_start && ckWARN(WARN_VOID))
4985 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4986 av_unshift(PL_checkav, 1);
4987 av_store(PL_checkav, 0, (SV*)cv);
4988 GvCV(gv) = 0; /* cv has been hijacked */
4990 else if (strEQ(s, "INIT") && !PL_error_count) {
4992 PL_initav = newAV();
4993 DEBUG_x( dump_sub(gv) );
4994 if (PL_main_start && ckWARN(WARN_VOID))
4995 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4996 av_push(PL_initav, (SV*)cv);
4997 GvCV(gv) = 0; /* cv has been hijacked */
5002 PL_copline = NOLINE;
5007 /* XXX unsafe for threads if eval_owner isn't held */
5009 =for apidoc newCONSTSUB
5011 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5012 eligible for inlining at compile-time.
5018 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5024 SAVECOPLINE(PL_curcop);
5025 CopLINE_set(PL_curcop, PL_copline);
5028 PL_hints &= ~HINT_BLOCK_SCOPE;
5031 SAVESPTR(PL_curstash);
5032 SAVECOPSTASH(PL_curcop);
5033 PL_curstash = stash;
5035 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5037 CopSTASH(PL_curcop) = stash;
5041 cv = newXS(name, const_sv_xsub, __FILE__);
5042 CvXSUBANY(cv).any_ptr = sv;
5044 sv_setpv((SV*)cv, ""); /* prototype is "" */
5052 =for apidoc U||newXS
5054 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5060 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5062 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5065 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5067 /* just a cached method */
5071 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5072 /* already defined (or promised) */
5073 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5074 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5075 line_t oldline = CopLINE(PL_curcop);
5076 if (PL_copline != NOLINE)
5077 CopLINE_set(PL_curcop, PL_copline);
5078 Perl_warner(aTHX_ WARN_REDEFINE,
5079 CvCONST(cv) ? "Constant subroutine %s redefined"
5080 : "Subroutine %s redefined"
5082 CopLINE_set(PL_curcop, oldline);
5089 if (cv) /* must reuse cv if autoloaded */
5092 cv = (CV*)NEWSV(1105,0);
5093 sv_upgrade((SV *)cv, SVt_PVCV);
5097 PL_sub_generation++;
5101 #ifdef USE_5005THREADS
5102 New(666, CvMUTEXP(cv), 1, perl_mutex);
5103 MUTEX_INIT(CvMUTEXP(cv));
5105 #endif /* USE_5005THREADS */
5106 (void)gv_fetchfile(filename);
5107 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5108 an external constant string */
5109 CvXSUB(cv) = subaddr;
5112 char *s = strrchr(name,':');
5118 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5121 if (strEQ(s, "BEGIN")) {
5123 PL_beginav = newAV();
5124 av_push(PL_beginav, (SV*)cv);
5125 GvCV(gv) = 0; /* cv has been hijacked */
5127 else if (strEQ(s, "END")) {
5130 av_unshift(PL_endav, 1);
5131 av_store(PL_endav, 0, (SV*)cv);
5132 GvCV(gv) = 0; /* cv has been hijacked */
5134 else if (strEQ(s, "CHECK")) {
5136 PL_checkav = newAV();
5137 if (PL_main_start && ckWARN(WARN_VOID))
5138 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5139 av_unshift(PL_checkav, 1);
5140 av_store(PL_checkav, 0, (SV*)cv);
5141 GvCV(gv) = 0; /* cv has been hijacked */
5143 else if (strEQ(s, "INIT")) {
5145 PL_initav = newAV();
5146 if (PL_main_start && ckWARN(WARN_VOID))
5147 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5148 av_push(PL_initav, (SV*)cv);
5149 GvCV(gv) = 0; /* cv has been hijacked */
5160 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5169 name = SvPVx(cSVOPo->op_sv, n_a);
5172 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5173 #ifdef GV_UNIQUE_CHECK
5175 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5179 if ((cv = GvFORM(gv))) {
5180 if (ckWARN(WARN_REDEFINE)) {
5181 line_t oldline = CopLINE(PL_curcop);
5182 if (PL_copline != NOLINE)
5183 CopLINE_set(PL_curcop, PL_copline);
5184 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5185 CopLINE_set(PL_curcop, oldline);
5192 CvFILE_set_from_cop(cv, PL_curcop);
5194 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5195 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5196 SvPADTMP_on(PL_curpad[ix]);
5199 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5200 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5201 OpREFCNT_set(CvROOT(cv), 1);
5202 CvSTART(cv) = LINKLIST(CvROOT(cv));
5203 CvROOT(cv)->op_next = 0;
5204 CALL_PEEP(CvSTART(cv));
5206 PL_copline = NOLINE;
5211 Perl_newANONLIST(pTHX_ OP *o)
5213 return newUNOP(OP_REFGEN, 0,
5214 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5218 Perl_newANONHASH(pTHX_ OP *o)
5220 return newUNOP(OP_REFGEN, 0,
5221 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5225 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5227 return newANONATTRSUB(floor, proto, Nullop, block);
5231 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5233 return newUNOP(OP_REFGEN, 0,
5234 newSVOP(OP_ANONCODE, 0,
5235 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5239 Perl_oopsAV(pTHX_ OP *o)
5241 switch (o->op_type) {
5243 o->op_type = OP_PADAV;
5244 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5245 return ref(o, OP_RV2AV);
5248 o->op_type = OP_RV2AV;
5249 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5254 if (ckWARN_d(WARN_INTERNAL))
5255 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5262 Perl_oopsHV(pTHX_ OP *o)
5264 switch (o->op_type) {
5267 o->op_type = OP_PADHV;
5268 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5269 return ref(o, OP_RV2HV);
5273 o->op_type = OP_RV2HV;
5274 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5279 if (ckWARN_d(WARN_INTERNAL))
5280 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5287 Perl_newAVREF(pTHX_ OP *o)
5289 if (o->op_type == OP_PADANY) {
5290 o->op_type = OP_PADAV;
5291 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5294 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5295 && ckWARN(WARN_DEPRECATED)) {
5296 Perl_warner(aTHX_ WARN_DEPRECATED,
5297 "Using an array as a reference is deprecated");
5299 return newUNOP(OP_RV2AV, 0, scalar(o));
5303 Perl_newGVREF(pTHX_ I32 type, OP *o)
5305 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5306 return newUNOP(OP_NULL, 0, o);
5307 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5311 Perl_newHVREF(pTHX_ OP *o)
5313 if (o->op_type == OP_PADANY) {
5314 o->op_type = OP_PADHV;
5315 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5318 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5319 && ckWARN(WARN_DEPRECATED)) {
5320 Perl_warner(aTHX_ WARN_DEPRECATED,
5321 "Using a hash as a reference is deprecated");
5323 return newUNOP(OP_RV2HV, 0, scalar(o));
5327 Perl_oopsCV(pTHX_ OP *o)
5329 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5335 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5337 return newUNOP(OP_RV2CV, flags, scalar(o));
5341 Perl_newSVREF(pTHX_ OP *o)
5343 if (o->op_type == OP_PADANY) {
5344 o->op_type = OP_PADSV;
5345 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5348 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5349 o->op_flags |= OPpDONE_SVREF;
5352 return newUNOP(OP_RV2SV, 0, scalar(o));
5355 /* Check routines. */
5358 Perl_ck_anoncode(pTHX_ OP *o)
5363 name = NEWSV(1106,0);
5364 sv_upgrade(name, SVt_PVNV);
5365 sv_setpvn(name, "&", 1);
5368 ix = pad_alloc(o->op_type, SVs_PADMY);
5369 av_store(PL_comppad_name, ix, name);
5370 av_store(PL_comppad, ix, cSVOPo->op_sv);
5371 SvPADMY_on(cSVOPo->op_sv);
5372 cSVOPo->op_sv = Nullsv;
5373 cSVOPo->op_targ = ix;
5378 Perl_ck_bitop(pTHX_ OP *o)
5380 o->op_private = PL_hints;
5385 Perl_ck_concat(pTHX_ OP *o)
5387 if (cUNOPo->op_first->op_type == OP_CONCAT)
5388 o->op_flags |= OPf_STACKED;
5393 Perl_ck_spair(pTHX_ OP *o)
5395 if (o->op_flags & OPf_KIDS) {
5398 OPCODE type = o->op_type;
5399 o = modkids(ck_fun(o), type);
5400 kid = cUNOPo->op_first;
5401 newop = kUNOP->op_first->op_sibling;
5403 (newop->op_sibling ||
5404 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5405 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5406 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5410 op_free(kUNOP->op_first);
5411 kUNOP->op_first = newop;
5413 o->op_ppaddr = PL_ppaddr[++o->op_type];
5418 Perl_ck_delete(pTHX_ OP *o)
5422 if (o->op_flags & OPf_KIDS) {
5423 OP *kid = cUNOPo->op_first;
5424 switch (kid->op_type) {
5426 o->op_flags |= OPf_SPECIAL;
5429 o->op_private |= OPpSLICE;
5432 o->op_flags |= OPf_SPECIAL;
5437 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5446 Perl_ck_eof(pTHX_ OP *o)
5448 I32 type = o->op_type;
5450 if (o->op_flags & OPf_KIDS) {
5451 if (cLISTOPo->op_first->op_type == OP_STUB) {
5453 o = newUNOP(type, OPf_SPECIAL,
5454 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5462 Perl_ck_eval(pTHX_ OP *o)
5464 PL_hints |= HINT_BLOCK_SCOPE;
5465 if (o->op_flags & OPf_KIDS) {
5466 SVOP *kid = (SVOP*)cUNOPo->op_first;
5469 o->op_flags &= ~OPf_KIDS;
5472 else if (kid->op_type == OP_LINESEQ) {
5475 kid->op_next = o->op_next;
5476 cUNOPo->op_first = 0;
5479 NewOp(1101, enter, 1, LOGOP);
5480 enter->op_type = OP_ENTERTRY;
5481 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5482 enter->op_private = 0;
5484 /* establish postfix order */
5485 enter->op_next = (OP*)enter;
5487 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5488 o->op_type = OP_LEAVETRY;
5489 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5490 enter->op_other = o;
5498 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5500 o->op_targ = (PADOFFSET)PL_hints;
5505 Perl_ck_exit(pTHX_ OP *o)
5508 HV *table = GvHV(PL_hintgv);
5510 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5511 if (svp && *svp && SvTRUE(*svp))
5512 o->op_private |= OPpEXIT_VMSISH;
5519 Perl_ck_exec(pTHX_ OP *o)
5522 if (o->op_flags & OPf_STACKED) {
5524 kid = cUNOPo->op_first->op_sibling;
5525 if (kid->op_type == OP_RV2GV)
5534 Perl_ck_exists(pTHX_ OP *o)
5537 if (o->op_flags & OPf_KIDS) {
5538 OP *kid = cUNOPo->op_first;
5539 if (kid->op_type == OP_ENTERSUB) {
5540 (void) ref(kid, o->op_type);
5541 if (kid->op_type != OP_RV2CV && !PL_error_count)
5542 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5544 o->op_private |= OPpEXISTS_SUB;
5546 else if (kid->op_type == OP_AELEM)
5547 o->op_flags |= OPf_SPECIAL;
5548 else if (kid->op_type != OP_HELEM)
5549 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5558 Perl_ck_gvconst(pTHX_ register OP *o)
5560 o = fold_constants(o);
5561 if (o->op_type == OP_CONST)
5568 Perl_ck_rvconst(pTHX_ register OP *o)
5570 SVOP *kid = (SVOP*)cUNOPo->op_first;
5572 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5573 if (kid->op_type == OP_CONST) {
5577 SV *kidsv = kid->op_sv;
5580 /* Is it a constant from cv_const_sv()? */
5581 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5582 SV *rsv = SvRV(kidsv);
5583 int svtype = SvTYPE(rsv);
5584 char *badtype = Nullch;
5586 switch (o->op_type) {
5588 if (svtype > SVt_PVMG)
5589 badtype = "a SCALAR";
5592 if (svtype != SVt_PVAV)
5593 badtype = "an ARRAY";
5596 if (svtype != SVt_PVHV) {
5597 if (svtype == SVt_PVAV) { /* pseudohash? */
5598 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5599 if (ksv && SvROK(*ksv)
5600 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5609 if (svtype != SVt_PVCV)
5614 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5617 name = SvPV(kidsv, n_a);
5618 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5619 char *badthing = Nullch;
5620 switch (o->op_type) {
5622 badthing = "a SCALAR";
5625 badthing = "an ARRAY";
5628 badthing = "a HASH";
5633 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5637 * This is a little tricky. We only want to add the symbol if we
5638 * didn't add it in the lexer. Otherwise we get duplicate strict
5639 * warnings. But if we didn't add it in the lexer, we must at
5640 * least pretend like we wanted to add it even if it existed before,
5641 * or we get possible typo warnings. OPpCONST_ENTERED says
5642 * whether the lexer already added THIS instance of this symbol.
5644 iscv = (o->op_type == OP_RV2CV) * 2;
5646 gv = gv_fetchpv(name,
5647 iscv | !(kid->op_private & OPpCONST_ENTERED),
5650 : o->op_type == OP_RV2SV
5652 : o->op_type == OP_RV2AV
5654 : o->op_type == OP_RV2HV
5657 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5659 kid->op_type = OP_GV;
5660 SvREFCNT_dec(kid->op_sv);
5662 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5663 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5664 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5666 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5668 kid->op_sv = SvREFCNT_inc(gv);
5670 kid->op_private = 0;
5671 kid->op_ppaddr = PL_ppaddr[OP_GV];
5678 Perl_ck_ftst(pTHX_ OP *o)
5680 I32 type = o->op_type;
5682 if (o->op_flags & OPf_REF) {
5685 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5686 SVOP *kid = (SVOP*)cUNOPo->op_first;
5688 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5690 OP *newop = newGVOP(type, OPf_REF,
5691 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5698 if (type == OP_FTTTY)
5699 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5702 o = newUNOP(type, 0, newDEFSVOP());
5708 Perl_ck_fun(pTHX_ OP *o)
5714 int type = o->op_type;
5715 register I32 oa = PL_opargs[type] >> OASHIFT;
5717 if (o->op_flags & OPf_STACKED) {
5718 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5721 return no_fh_allowed(o);
5724 if (o->op_flags & OPf_KIDS) {
5726 tokid = &cLISTOPo->op_first;
5727 kid = cLISTOPo->op_first;
5728 if (kid->op_type == OP_PUSHMARK ||
5729 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5731 tokid = &kid->op_sibling;
5732 kid = kid->op_sibling;
5734 if (!kid && PL_opargs[type] & OA_DEFGV)
5735 *tokid = kid = newDEFSVOP();
5739 sibl = kid->op_sibling;
5742 /* list seen where single (scalar) arg expected? */
5743 if (numargs == 1 && !(oa >> 4)
5744 && kid->op_type == OP_LIST && type != OP_SCALAR)
5746 return too_many_arguments(o,PL_op_desc[type]);
5759 if ((type == OP_PUSH || type == OP_UNSHIFT)
5760 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5761 Perl_warner(aTHX_ WARN_SYNTAX,
5762 "Useless use of %s with no values",
5765 if (kid->op_type == OP_CONST &&
5766 (kid->op_private & OPpCONST_BARE))
5768 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5769 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5770 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5771 if (ckWARN(WARN_DEPRECATED))
5772 Perl_warner(aTHX_ WARN_DEPRECATED,
5773 "Array @%s missing the @ in argument %"IVdf" of %s()",
5774 name, (IV)numargs, PL_op_desc[type]);
5777 kid->op_sibling = sibl;
5780 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5781 bad_type(numargs, "array", PL_op_desc[type], kid);
5785 if (kid->op_type == OP_CONST &&
5786 (kid->op_private & OPpCONST_BARE))
5788 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5789 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5790 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5791 if (ckWARN(WARN_DEPRECATED))
5792 Perl_warner(aTHX_ WARN_DEPRECATED,
5793 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5794 name, (IV)numargs, PL_op_desc[type]);
5797 kid->op_sibling = sibl;
5800 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5801 bad_type(numargs, "hash", PL_op_desc[type], kid);
5806 OP *newop = newUNOP(OP_NULL, 0, kid);
5807 kid->op_sibling = 0;
5809 newop->op_next = newop;
5811 kid->op_sibling = sibl;
5816 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5817 if (kid->op_type == OP_CONST &&
5818 (kid->op_private & OPpCONST_BARE))
5820 OP *newop = newGVOP(OP_GV, 0,
5821 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5826 else if (kid->op_type == OP_READLINE) {
5827 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5828 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5831 I32 flags = OPf_SPECIAL;
5835 /* is this op a FH constructor? */
5836 if (is_handle_constructor(o,numargs)) {
5837 char *name = Nullch;
5841 /* Set a flag to tell rv2gv to vivify
5842 * need to "prove" flag does not mean something
5843 * else already - NI-S 1999/05/07
5846 if (kid->op_type == OP_PADSV) {
5847 SV **namep = av_fetch(PL_comppad_name,
5849 if (namep && *namep)
5850 name = SvPV(*namep, len);
5852 else if (kid->op_type == OP_RV2SV
5853 && kUNOP->op_first->op_type == OP_GV)
5855 GV *gv = cGVOPx_gv(kUNOP->op_first);
5857 len = GvNAMELEN(gv);
5859 else if (kid->op_type == OP_AELEM
5860 || kid->op_type == OP_HELEM)
5862 name = "__ANONIO__";
5868 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5869 namesv = PL_curpad[targ];
5870 (void)SvUPGRADE(namesv, SVt_PV);
5872 sv_setpvn(namesv, "$", 1);
5873 sv_catpvn(namesv, name, len);
5876 kid->op_sibling = 0;
5877 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5878 kid->op_targ = targ;
5879 kid->op_private |= priv;
5881 kid->op_sibling = sibl;
5887 mod(scalar(kid), type);
5891 tokid = &kid->op_sibling;
5892 kid = kid->op_sibling;
5894 o->op_private |= numargs;
5896 return too_many_arguments(o,OP_DESC(o));
5899 else if (PL_opargs[type] & OA_DEFGV) {
5901 return newUNOP(type, 0, newDEFSVOP());
5905 while (oa & OA_OPTIONAL)
5907 if (oa && oa != OA_LIST)
5908 return too_few_arguments(o,OP_DESC(o));
5914 Perl_ck_glob(pTHX_ OP *o)
5919 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5920 append_elem(OP_GLOB, o, newDEFSVOP());
5922 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5923 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5925 #if !defined(PERL_EXTERNAL_GLOB)
5926 /* XXX this can be tightened up and made more failsafe. */
5930 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5932 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5933 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5934 GvCV(gv) = GvCV(glob_gv);
5935 SvREFCNT_inc((SV*)GvCV(gv));
5936 GvIMPORTED_CV_on(gv);
5939 #endif /* PERL_EXTERNAL_GLOB */
5941 if (gv && GvIMPORTED_CV(gv)) {
5942 append_elem(OP_GLOB, o,
5943 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5944 o->op_type = OP_LIST;
5945 o->op_ppaddr = PL_ppaddr[OP_LIST];
5946 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5947 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5948 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5949 append_elem(OP_LIST, o,
5950 scalar(newUNOP(OP_RV2CV, 0,
5951 newGVOP(OP_GV, 0, gv)))));
5952 o = newUNOP(OP_NULL, 0, ck_subr(o));
5953 o->op_targ = OP_GLOB; /* hint at what it used to be */
5956 gv = newGVgen("main");
5958 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5964 Perl_ck_grep(pTHX_ OP *o)
5968 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5970 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5971 NewOp(1101, gwop, 1, LOGOP);
5973 if (o->op_flags & OPf_STACKED) {
5976 kid = cLISTOPo->op_first->op_sibling;
5977 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5980 kid->op_next = (OP*)gwop;
5981 o->op_flags &= ~OPf_STACKED;
5983 kid = cLISTOPo->op_first->op_sibling;
5984 if (type == OP_MAPWHILE)
5991 kid = cLISTOPo->op_first->op_sibling;
5992 if (kid->op_type != OP_NULL)
5993 Perl_croak(aTHX_ "panic: ck_grep");
5994 kid = kUNOP->op_first;
5996 gwop->op_type = type;
5997 gwop->op_ppaddr = PL_ppaddr[type];
5998 gwop->op_first = listkids(o);
5999 gwop->op_flags |= OPf_KIDS;
6000 gwop->op_private = 1;
6001 gwop->op_other = LINKLIST(kid);
6002 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6003 kid->op_next = (OP*)gwop;
6005 kid = cLISTOPo->op_first->op_sibling;
6006 if (!kid || !kid->op_sibling)
6007 return too_few_arguments(o,OP_DESC(o));
6008 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6009 mod(kid, OP_GREPSTART);
6015 Perl_ck_index(pTHX_ OP *o)
6017 if (o->op_flags & OPf_KIDS) {
6018 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6020 kid = kid->op_sibling; /* get past "big" */
6021 if (kid && kid->op_type == OP_CONST)
6022 fbm_compile(((SVOP*)kid)->op_sv, 0);
6028 Perl_ck_lengthconst(pTHX_ OP *o)
6030 /* XXX length optimization goes here */
6035 Perl_ck_lfun(pTHX_ OP *o)
6037 OPCODE type = o->op_type;
6038 return modkids(ck_fun(o), type);
6042 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6044 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6045 switch (cUNOPo->op_first->op_type) {
6047 /* This is needed for
6048 if (defined %stash::)
6049 to work. Do not break Tk.
6051 break; /* Globals via GV can be undef */
6053 case OP_AASSIGN: /* Is this a good idea? */
6054 Perl_warner(aTHX_ WARN_DEPRECATED,
6055 "defined(@array) is deprecated");
6056 Perl_warner(aTHX_ WARN_DEPRECATED,
6057 "\t(Maybe you should just omit the defined()?)\n");
6060 /* This is needed for
6061 if (defined %stash::)
6062 to work. Do not break Tk.
6064 break; /* Globals via GV can be undef */
6066 Perl_warner(aTHX_ WARN_DEPRECATED,
6067 "defined(%%hash) is deprecated");
6068 Perl_warner(aTHX_ WARN_DEPRECATED,
6069 "\t(Maybe you should just omit the defined()?)\n");
6080 Perl_ck_rfun(pTHX_ OP *o)
6082 OPCODE type = o->op_type;
6083 return refkids(ck_fun(o), type);
6087 Perl_ck_listiob(pTHX_ OP *o)
6091 kid = cLISTOPo->op_first;
6094 kid = cLISTOPo->op_first;
6096 if (kid->op_type == OP_PUSHMARK)
6097 kid = kid->op_sibling;
6098 if (kid && o->op_flags & OPf_STACKED)
6099 kid = kid->op_sibling;
6100 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6101 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6102 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6103 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6104 cLISTOPo->op_first->op_sibling = kid;
6105 cLISTOPo->op_last = kid;
6106 kid = kid->op_sibling;
6111 append_elem(o->op_type, o, newDEFSVOP());
6117 Perl_ck_sassign(pTHX_ OP *o)
6119 OP *kid = cLISTOPo->op_first;
6120 /* has a disposable target? */
6121 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6122 && !(kid->op_flags & OPf_STACKED)
6123 /* Cannot steal the second time! */
6124 && !(kid->op_private & OPpTARGET_MY))
6126 OP *kkid = kid->op_sibling;
6128 /* Can just relocate the target. */
6129 if (kkid && kkid->op_type == OP_PADSV
6130 && !(kkid->op_private & OPpLVAL_INTRO))
6132 kid->op_targ = kkid->op_targ;
6134 /* Now we do not need PADSV and SASSIGN. */
6135 kid->op_sibling = o->op_sibling; /* NULL */
6136 cLISTOPo->op_first = NULL;
6139 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6147 Perl_ck_match(pTHX_ OP *o)
6149 o->op_private |= OPpRUNTIME;
6154 Perl_ck_method(pTHX_ OP *o)
6156 OP *kid = cUNOPo->op_first;
6157 if (kid->op_type == OP_CONST) {
6158 SV* sv = kSVOP->op_sv;
6159 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6161 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6162 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6165 kSVOP->op_sv = Nullsv;
6167 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6176 Perl_ck_null(pTHX_ OP *o)
6182 Perl_ck_open(pTHX_ OP *o)
6184 HV *table = GvHV(PL_hintgv);
6188 svp = hv_fetch(table, "open_IN", 7, FALSE);
6190 mode = mode_from_discipline(*svp);
6191 if (mode & O_BINARY)
6192 o->op_private |= OPpOPEN_IN_RAW;
6193 else if (mode & O_TEXT)
6194 o->op_private |= OPpOPEN_IN_CRLF;
6197 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6199 mode = mode_from_discipline(*svp);
6200 if (mode & O_BINARY)
6201 o->op_private |= OPpOPEN_OUT_RAW;
6202 else if (mode & O_TEXT)
6203 o->op_private |= OPpOPEN_OUT_CRLF;
6206 if (o->op_type == OP_BACKTICK)
6212 Perl_ck_repeat(pTHX_ OP *o)
6214 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6215 o->op_private |= OPpREPEAT_DOLIST;
6216 cBINOPo->op_first = force_list(cBINOPo->op_first);
6224 Perl_ck_require(pTHX_ OP *o)
6228 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6229 SVOP *kid = (SVOP*)cUNOPo->op_first;
6231 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6233 for (s = SvPVX(kid->op_sv); *s; s++) {
6234 if (*s == ':' && s[1] == ':') {
6236 Move(s+2, s+1, strlen(s+2)+1, char);
6237 --SvCUR(kid->op_sv);
6240 if (SvREADONLY(kid->op_sv)) {
6241 SvREADONLY_off(kid->op_sv);
6242 sv_catpvn(kid->op_sv, ".pm", 3);
6243 SvREADONLY_on(kid->op_sv);
6246 sv_catpvn(kid->op_sv, ".pm", 3);
6250 /* handle override, if any */
6251 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6252 if (!(gv && GvIMPORTED_CV(gv)))
6253 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6255 if (gv && GvIMPORTED_CV(gv)) {
6256 OP *kid = cUNOPo->op_first;
6257 cUNOPo->op_first = 0;
6259 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6260 append_elem(OP_LIST, kid,
6261 scalar(newUNOP(OP_RV2CV, 0,
6270 Perl_ck_return(pTHX_ OP *o)
6273 if (CvLVALUE(PL_compcv)) {
6274 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6275 mod(kid, OP_LEAVESUBLV);
6282 Perl_ck_retarget(pTHX_ OP *o)
6284 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6291 Perl_ck_select(pTHX_ OP *o)
6294 if (o->op_flags & OPf_KIDS) {
6295 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6296 if (kid && kid->op_sibling) {
6297 o->op_type = OP_SSELECT;
6298 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6300 return fold_constants(o);
6304 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6305 if (kid && kid->op_type == OP_RV2GV)
6306 kid->op_private &= ~HINT_STRICT_REFS;
6311 Perl_ck_shift(pTHX_ OP *o)
6313 I32 type = o->op_type;
6315 if (!(o->op_flags & OPf_KIDS)) {
6319 #ifdef USE_5005THREADS
6320 if (!CvUNIQUE(PL_compcv)) {
6321 argop = newOP(OP_PADAV, OPf_REF);
6322 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6325 argop = newUNOP(OP_RV2AV, 0,
6326 scalar(newGVOP(OP_GV, 0,
6327 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6330 argop = newUNOP(OP_RV2AV, 0,
6331 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6332 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6333 #endif /* USE_5005THREADS */
6334 return newUNOP(type, 0, scalar(argop));
6336 return scalar(modkids(ck_fun(o), type));
6340 Perl_ck_sort(pTHX_ OP *o)
6344 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6346 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6347 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6349 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6351 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6353 if (kid->op_type == OP_SCOPE) {
6357 else if (kid->op_type == OP_LEAVE) {
6358 if (o->op_type == OP_SORT) {
6359 op_null(kid); /* wipe out leave */
6362 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6363 if (k->op_next == kid)
6365 /* don't descend into loops */
6366 else if (k->op_type == OP_ENTERLOOP
6367 || k->op_type == OP_ENTERITER)
6369 k = cLOOPx(k)->op_lastop;
6374 kid->op_next = 0; /* just disconnect the leave */
6375 k = kLISTOP->op_first;
6380 if (o->op_type == OP_SORT) {
6381 /* provide scalar context for comparison function/block */
6387 o->op_flags |= OPf_SPECIAL;
6389 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6392 firstkid = firstkid->op_sibling;
6395 /* provide list context for arguments */
6396 if (o->op_type == OP_SORT)
6403 S_simplify_sort(pTHX_ OP *o)
6405 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6409 if (!(o->op_flags & OPf_STACKED))
6411 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6412 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6413 kid = kUNOP->op_first; /* get past null */
6414 if (kid->op_type != OP_SCOPE)
6416 kid = kLISTOP->op_last; /* get past scope */
6417 switch(kid->op_type) {
6425 k = kid; /* remember this node*/
6426 if (kBINOP->op_first->op_type != OP_RV2SV)
6428 kid = kBINOP->op_first; /* get past cmp */
6429 if (kUNOP->op_first->op_type != OP_GV)
6431 kid = kUNOP->op_first; /* get past rv2sv */
6433 if (GvSTASH(gv) != PL_curstash)
6435 if (strEQ(GvNAME(gv), "a"))
6437 else if (strEQ(GvNAME(gv), "b"))
6441 kid = k; /* back to cmp */
6442 if (kBINOP->op_last->op_type != OP_RV2SV)
6444 kid = kBINOP->op_last; /* down to 2nd arg */
6445 if (kUNOP->op_first->op_type != OP_GV)
6447 kid = kUNOP->op_first; /* get past rv2sv */
6449 if (GvSTASH(gv) != PL_curstash
6451 ? strNE(GvNAME(gv), "a")
6452 : strNE(GvNAME(gv), "b")))
6454 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6456 o->op_private |= OPpSORT_REVERSE;
6457 if (k->op_type == OP_NCMP)
6458 o->op_private |= OPpSORT_NUMERIC;
6459 if (k->op_type == OP_I_NCMP)
6460 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6461 kid = cLISTOPo->op_first->op_sibling;
6462 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6463 op_free(kid); /* then delete it */
6467 Perl_ck_split(pTHX_ OP *o)
6471 if (o->op_flags & OPf_STACKED)
6472 return no_fh_allowed(o);
6474 kid = cLISTOPo->op_first;
6475 if (kid->op_type != OP_NULL)
6476 Perl_croak(aTHX_ "panic: ck_split");
6477 kid = kid->op_sibling;
6478 op_free(cLISTOPo->op_first);
6479 cLISTOPo->op_first = kid;
6481 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6482 cLISTOPo->op_last = kid; /* There was only one element previously */
6485 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6486 OP *sibl = kid->op_sibling;
6487 kid->op_sibling = 0;
6488 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6489 if (cLISTOPo->op_first == cLISTOPo->op_last)
6490 cLISTOPo->op_last = kid;
6491 cLISTOPo->op_first = kid;
6492 kid->op_sibling = sibl;
6495 kid->op_type = OP_PUSHRE;
6496 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6499 if (!kid->op_sibling)
6500 append_elem(OP_SPLIT, o, newDEFSVOP());
6502 kid = kid->op_sibling;
6505 if (!kid->op_sibling)
6506 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6508 kid = kid->op_sibling;
6511 if (kid->op_sibling)
6512 return too_many_arguments(o,OP_DESC(o));
6518 Perl_ck_join(pTHX_ OP *o)
6520 if (ckWARN(WARN_SYNTAX)) {
6521 OP *kid = cLISTOPo->op_first->op_sibling;
6522 if (kid && kid->op_type == OP_MATCH) {
6523 char *pmstr = "STRING";
6524 if (PM_GETRE(kPMOP))
6525 pmstr = PM_GETRE(kPMOP)->precomp;
6526 Perl_warner(aTHX_ WARN_SYNTAX,
6527 "/%s/ should probably be written as \"%s\"",
6535 Perl_ck_subr(pTHX_ OP *o)
6537 OP *prev = ((cUNOPo->op_first->op_sibling)
6538 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6539 OP *o2 = prev->op_sibling;
6546 I32 contextclass = 0;
6550 o->op_private |= OPpENTERSUB_HASTARG;
6551 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6552 if (cvop->op_type == OP_RV2CV) {
6554 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6555 op_null(cvop); /* disable rv2cv */
6556 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6557 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6558 GV *gv = cGVOPx_gv(tmpop);
6561 tmpop->op_private |= OPpEARLY_CV;
6562 else if (SvPOK(cv)) {
6563 namegv = CvANON(cv) ? gv : CvGV(cv);
6564 proto = SvPV((SV*)cv, n_a);
6568 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6569 if (o2->op_type == OP_CONST)
6570 o2->op_private &= ~OPpCONST_STRICT;
6571 else if (o2->op_type == OP_LIST) {
6572 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6573 if (o && o->op_type == OP_CONST)
6574 o->op_private &= ~OPpCONST_STRICT;
6577 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6578 if (PERLDB_SUB && PL_curstash != PL_debstash)
6579 o->op_private |= OPpENTERSUB_DB;
6580 while (o2 != cvop) {
6584 return too_many_arguments(o, gv_ename(namegv));
6602 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6604 arg == 1 ? "block or sub {}" : "sub {}",
6605 gv_ename(namegv), o2);
6608 /* '*' allows any scalar type, including bareword */
6611 if (o2->op_type == OP_RV2GV)
6612 goto wrapref; /* autoconvert GLOB -> GLOBref */
6613 else if (o2->op_type == OP_CONST)
6614 o2->op_private &= ~OPpCONST_STRICT;
6615 else if (o2->op_type == OP_ENTERSUB) {
6616 /* accidental subroutine, revert to bareword */
6617 OP *gvop = ((UNOP*)o2)->op_first;
6618 if (gvop && gvop->op_type == OP_NULL) {
6619 gvop = ((UNOP*)gvop)->op_first;
6621 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6624 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6625 (gvop = ((UNOP*)gvop)->op_first) &&
6626 gvop->op_type == OP_GV)
6628 GV *gv = cGVOPx_gv(gvop);
6629 OP *sibling = o2->op_sibling;
6630 SV *n = newSVpvn("",0);
6632 gv_fullname3(n, gv, "");
6633 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6634 sv_chop(n, SvPVX(n)+6);
6635 o2 = newSVOP(OP_CONST, 0, n);
6636 prev->op_sibling = o2;
6637 o2->op_sibling = sibling;
6653 if (contextclass++ == 0) {
6654 e = strchr(proto, ']');
6655 if (!e || e == proto)
6669 if (o2->op_type == OP_RV2GV)
6672 bad_type(arg, "symbol", gv_ename(namegv), o2);
6675 if (o2->op_type == OP_ENTERSUB)
6678 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6681 if (o2->op_type == OP_RV2SV ||
6682 o2->op_type == OP_PADSV ||
6683 o2->op_type == OP_HELEM ||
6684 o2->op_type == OP_AELEM ||
6685 o2->op_type == OP_THREADSV)
6688 bad_type(arg, "scalar", gv_ename(namegv), o2);
6691 if (o2->op_type == OP_RV2AV ||
6692 o2->op_type == OP_PADAV)
6695 bad_type(arg, "array", gv_ename(namegv), o2);
6698 if (o2->op_type == OP_RV2HV ||
6699 o2->op_type == OP_PADHV)
6702 bad_type(arg, "hash", gv_ename(namegv), o2);
6707 OP* sib = kid->op_sibling;
6708 kid->op_sibling = 0;
6709 o2 = newUNOP(OP_REFGEN, 0, kid);
6710 o2->op_sibling = sib;
6711 prev->op_sibling = o2;
6713 if (contextclass && e) {
6728 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6729 gv_ename(namegv), SvPV((SV*)cv, n_a));
6734 mod(o2, OP_ENTERSUB);
6736 o2 = o2->op_sibling;
6738 if (proto && !optional &&
6739 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6740 return too_few_arguments(o, gv_ename(namegv));
6745 Perl_ck_svconst(pTHX_ OP *o)
6747 SvREADONLY_on(cSVOPo->op_sv);
6752 Perl_ck_trunc(pTHX_ OP *o)
6754 if (o->op_flags & OPf_KIDS) {
6755 SVOP *kid = (SVOP*)cUNOPo->op_first;
6757 if (kid->op_type == OP_NULL)
6758 kid = (SVOP*)kid->op_sibling;
6759 if (kid && kid->op_type == OP_CONST &&
6760 (kid->op_private & OPpCONST_BARE))
6762 o->op_flags |= OPf_SPECIAL;
6763 kid->op_private &= ~OPpCONST_STRICT;
6770 Perl_ck_substr(pTHX_ OP *o)
6773 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6774 OP *kid = cLISTOPo->op_first;
6776 if (kid->op_type == OP_NULL)
6777 kid = kid->op_sibling;
6779 kid->op_flags |= OPf_MOD;
6785 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6788 Perl_peep(pTHX_ register OP *o)
6790 register OP* oldop = 0;
6793 if (!o || o->op_seq)
6797 SAVEVPTR(PL_curcop);
6798 for (; o; o = o->op_next) {
6804 switch (o->op_type) {
6808 PL_curcop = ((COP*)o); /* for warnings */
6809 o->op_seq = PL_op_seqmax++;
6813 if (cSVOPo->op_private & OPpCONST_STRICT)
6814 no_bareword_allowed(o);
6816 /* Relocate sv to the pad for thread safety.
6817 * Despite being a "constant", the SV is written to,
6818 * for reference counts, sv_upgrade() etc. */
6820 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6821 if (SvPADTMP(cSVOPo->op_sv)) {
6822 /* If op_sv is already a PADTMP then it is being used by
6823 * some pad, so make a copy. */
6824 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6825 SvREADONLY_on(PL_curpad[ix]);
6826 SvREFCNT_dec(cSVOPo->op_sv);
6829 SvREFCNT_dec(PL_curpad[ix]);
6830 SvPADTMP_on(cSVOPo->op_sv);
6831 PL_curpad[ix] = cSVOPo->op_sv;
6832 /* XXX I don't know how this isn't readonly already. */
6833 SvREADONLY_on(PL_curpad[ix]);
6835 cSVOPo->op_sv = Nullsv;
6839 o->op_seq = PL_op_seqmax++;
6843 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6844 if (o->op_next->op_private & OPpTARGET_MY) {
6845 if (o->op_flags & OPf_STACKED) /* chained concats */
6846 goto ignore_optimization;
6848 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6849 o->op_targ = o->op_next->op_targ;
6850 o->op_next->op_targ = 0;
6851 o->op_private |= OPpTARGET_MY;
6854 op_null(o->op_next);
6856 ignore_optimization:
6857 o->op_seq = PL_op_seqmax++;
6860 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6861 o->op_seq = PL_op_seqmax++;
6862 break; /* Scalar stub must produce undef. List stub is noop */
6866 if (o->op_targ == OP_NEXTSTATE
6867 || o->op_targ == OP_DBSTATE
6868 || o->op_targ == OP_SETSTATE)
6870 PL_curcop = ((COP*)o);
6872 /* XXX: We avoid setting op_seq here to prevent later calls
6873 to peep() from mistakenly concluding that optimisation
6874 has already occurred. This doesn't fix the real problem,
6875 though (See 20010220.007). AMS 20010719 */
6876 if (oldop && o->op_next) {
6877 oldop->op_next = o->op_next;
6885 if (oldop && o->op_next) {
6886 oldop->op_next = o->op_next;
6889 o->op_seq = PL_op_seqmax++;
6893 if (o->op_next->op_type == OP_RV2SV) {
6894 if (!(o->op_next->op_private & OPpDEREF)) {
6895 op_null(o->op_next);
6896 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6898 o->op_next = o->op_next->op_next;
6899 o->op_type = OP_GVSV;
6900 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6903 else if (o->op_next->op_type == OP_RV2AV) {
6904 OP* pop = o->op_next->op_next;
6906 if (pop->op_type == OP_CONST &&
6907 (PL_op = pop->op_next) &&
6908 pop->op_next->op_type == OP_AELEM &&
6909 !(pop->op_next->op_private &
6910 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6911 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6916 op_null(o->op_next);
6917 op_null(pop->op_next);
6919 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6920 o->op_next = pop->op_next->op_next;
6921 o->op_type = OP_AELEMFAST;
6922 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6923 o->op_private = (U8)i;
6928 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6930 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6931 /* XXX could check prototype here instead of just carping */
6932 SV *sv = sv_newmortal();
6933 gv_efullname3(sv, gv, Nullch);
6934 Perl_warner(aTHX_ WARN_PROTOTYPE,
6935 "%s() called too early to check prototype",
6939 else if (o->op_next->op_type == OP_READLINE
6940 && o->op_next->op_next->op_type == OP_CONCAT
6941 && (o->op_next->op_next->op_flags & OPf_STACKED))
6943 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6944 o->op_type = OP_RCATLINE;
6945 o->op_flags |= OPf_STACKED;
6946 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6947 op_null(o->op_next->op_next);
6948 op_null(o->op_next);
6951 o->op_seq = PL_op_seqmax++;
6962 o->op_seq = PL_op_seqmax++;
6963 while (cLOGOP->op_other->op_type == OP_NULL)
6964 cLOGOP->op_other = cLOGOP->op_other->op_next;
6965 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6970 o->op_seq = PL_op_seqmax++;
6971 while (cLOOP->op_redoop->op_type == OP_NULL)
6972 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6973 peep(cLOOP->op_redoop);
6974 while (cLOOP->op_nextop->op_type == OP_NULL)
6975 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6976 peep(cLOOP->op_nextop);
6977 while (cLOOP->op_lastop->op_type == OP_NULL)
6978 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6979 peep(cLOOP->op_lastop);
6985 o->op_seq = PL_op_seqmax++;
6986 while (cPMOP->op_pmreplstart &&
6987 cPMOP->op_pmreplstart->op_type == OP_NULL)
6988 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6989 peep(cPMOP->op_pmreplstart);
6993 o->op_seq = PL_op_seqmax++;
6994 if (ckWARN(WARN_SYNTAX) && o->op_next
6995 && o->op_next->op_type == OP_NEXTSTATE) {
6996 if (o->op_next->op_sibling &&
6997 o->op_next->op_sibling->op_type != OP_EXIT &&
6998 o->op_next->op_sibling->op_type != OP_WARN &&
6999 o->op_next->op_sibling->op_type != OP_DIE) {
7000 line_t oldline = CopLINE(PL_curcop);
7002 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7003 Perl_warner(aTHX_ WARN_EXEC,
7004 "Statement unlikely to be reached");
7005 Perl_warner(aTHX_ WARN_EXEC,
7006 "\t(Maybe you meant system() when you said exec()?)\n");
7007 CopLINE_set(PL_curcop, oldline);
7016 SV **svp, **indsvp, *sv;
7021 o->op_seq = PL_op_seqmax++;
7023 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7026 /* Make the CONST have a shared SV */
7027 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7028 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7029 key = SvPV(sv, keylen);
7030 lexname = newSVpvn_share(key,
7031 SvUTF8(sv) ? -(I32)keylen : keylen,
7037 if ((o->op_private & (OPpLVAL_INTRO)))
7040 rop = (UNOP*)((BINOP*)o)->op_first;
7041 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7043 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7044 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7046 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7047 if (!fields || !GvHV(*fields))
7049 key = SvPV(*svp, keylen);
7050 indsvp = hv_fetch(GvHV(*fields), key,
7051 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7053 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7054 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7056 ind = SvIV(*indsvp);
7058 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7059 rop->op_type = OP_RV2AV;
7060 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7061 o->op_type = OP_AELEM;
7062 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7064 if (SvREADONLY(*svp))
7066 SvFLAGS(sv) |= (SvFLAGS(*svp)
7067 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7077 SV **svp, **indsvp, *sv;
7081 SVOP *first_key_op, *key_op;
7083 o->op_seq = PL_op_seqmax++;
7084 if ((o->op_private & (OPpLVAL_INTRO))
7085 /* I bet there's always a pushmark... */
7086 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7087 /* hmmm, no optimization if list contains only one key. */
7089 rop = (UNOP*)((LISTOP*)o)->op_last;
7090 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7092 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7093 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7095 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7096 if (!fields || !GvHV(*fields))
7098 /* Again guessing that the pushmark can be jumped over.... */
7099 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7100 ->op_first->op_sibling;
7101 /* Check that the key list contains only constants. */
7102 for (key_op = first_key_op; key_op;
7103 key_op = (SVOP*)key_op->op_sibling)
7104 if (key_op->op_type != OP_CONST)
7108 rop->op_type = OP_RV2AV;
7109 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7110 o->op_type = OP_ASLICE;
7111 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7112 for (key_op = first_key_op; key_op;
7113 key_op = (SVOP*)key_op->op_sibling) {
7114 svp = cSVOPx_svp(key_op);
7115 key = SvPV(*svp, keylen);
7116 indsvp = hv_fetch(GvHV(*fields), key,
7117 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7119 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7120 "in variable %s of type %s",
7121 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7123 ind = SvIV(*indsvp);
7125 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7127 if (SvREADONLY(*svp))
7129 SvFLAGS(sv) |= (SvFLAGS(*svp)
7130 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7138 o->op_seq = PL_op_seqmax++;
7148 char* Perl_custom_op_name(pTHX_ OP* o)
7150 IV index = PTR2IV(o->op_ppaddr);
7154 if (!PL_custom_op_names) /* This probably shouldn't happen */
7155 return PL_op_name[OP_CUSTOM];
7157 keysv = sv_2mortal(newSViv(index));
7159 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7161 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7163 return SvPV_nolen(HeVAL(he));
7166 char* Perl_custom_op_desc(pTHX_ OP* o)
7168 IV index = PTR2IV(o->op_ppaddr);
7172 if (!PL_custom_op_descs)
7173 return PL_op_desc[OP_CUSTOM];
7175 keysv = sv_2mortal(newSViv(index));
7177 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7179 return PL_op_desc[OP_CUSTOM];
7181 return SvPV_nolen(HeVAL(he));
7187 /* Efficient sub that returns a constant scalar value. */
7189 const_sv_xsub(pTHX_ CV* cv)
7194 Perl_croak(aTHX_ "usage: %s::%s()",
7195 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7199 ST(0) = (SV*)XSANY.any_ptr;