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. --GSAR */
4253 if (!CvANON(cv) || CvCLONED(cv))
4254 SvREFCNT_dec(CvOUTSIDE(cv));
4255 CvOUTSIDE(cv) = Nullcv;
4257 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4260 if (CvPADLIST(cv)) {
4261 /* may be during global destruction */
4262 if (SvREFCNT(CvPADLIST(cv))) {
4263 I32 i = AvFILLp(CvPADLIST(cv));
4265 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4266 SV* sv = svp ? *svp : Nullsv;
4269 if (sv == (SV*)PL_comppad_name)
4270 PL_comppad_name = Nullav;
4271 else if (sv == (SV*)PL_comppad) {
4272 PL_comppad = Nullav;
4273 PL_curpad = Null(SV**);
4277 SvREFCNT_dec((SV*)CvPADLIST(cv));
4279 CvPADLIST(cv) = Nullav;
4287 #ifdef DEBUG_CLOSURES
4289 S_cv_dump(pTHX_ CV *cv)
4292 CV *outside = CvOUTSIDE(cv);
4293 AV* padlist = CvPADLIST(cv);
4300 PerlIO_printf(Perl_debug_log,
4301 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4303 (CvANON(cv) ? "ANON"
4304 : (cv == PL_main_cv) ? "MAIN"
4305 : CvUNIQUE(cv) ? "UNIQUE"
4306 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4309 : CvANON(outside) ? "ANON"
4310 : (outside == PL_main_cv) ? "MAIN"
4311 : CvUNIQUE(outside) ? "UNIQUE"
4312 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4317 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4318 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4319 pname = AvARRAY(pad_name);
4320 ppad = AvARRAY(pad);
4322 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4323 if (SvPOK(pname[ix]))
4324 PerlIO_printf(Perl_debug_log,
4325 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4326 (int)ix, PTR2UV(ppad[ix]),
4327 SvFAKE(pname[ix]) ? "FAKE " : "",
4329 (IV)I_32(SvNVX(pname[ix])),
4332 #endif /* DEBUGGING */
4334 #endif /* DEBUG_CLOSURES */
4337 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4341 AV* protopadlist = CvPADLIST(proto);
4342 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4343 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4344 SV** pname = AvARRAY(protopad_name);
4345 SV** ppad = AvARRAY(protopad);
4346 I32 fname = AvFILLp(protopad_name);
4347 I32 fpad = AvFILLp(protopad);
4351 assert(!CvUNIQUE(proto));
4355 SAVESPTR(PL_comppad_name);
4356 SAVESPTR(PL_compcv);
4358 cv = PL_compcv = (CV*)NEWSV(1104,0);
4359 sv_upgrade((SV *)cv, SvTYPE(proto));
4360 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4363 #ifdef USE_5005THREADS
4364 New(666, CvMUTEXP(cv), 1, perl_mutex);
4365 MUTEX_INIT(CvMUTEXP(cv));
4367 #endif /* USE_5005THREADS */
4369 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4370 : savepv(CvFILE(proto));
4372 CvFILE(cv) = CvFILE(proto);
4374 CvGV(cv) = CvGV(proto);
4375 CvSTASH(cv) = CvSTASH(proto);
4376 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4377 CvSTART(cv) = CvSTART(proto);
4379 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4382 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4384 PL_comppad_name = newAV();
4385 for (ix = fname; ix >= 0; ix--)
4386 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4388 PL_comppad = newAV();
4390 comppadlist = newAV();
4391 AvREAL_off(comppadlist);
4392 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4393 av_store(comppadlist, 1, (SV*)PL_comppad);
4394 CvPADLIST(cv) = comppadlist;
4395 av_fill(PL_comppad, AvFILLp(protopad));
4396 PL_curpad = AvARRAY(PL_comppad);
4398 av = newAV(); /* will be @_ */
4400 av_store(PL_comppad, 0, (SV*)av);
4401 AvFLAGS(av) = AVf_REIFY;
4403 for (ix = fpad; ix > 0; ix--) {
4404 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4405 if (namesv && namesv != &PL_sv_undef) {
4406 char *name = SvPVX(namesv); /* XXX */
4407 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4408 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4409 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4411 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4413 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4415 else { /* our own lexical */
4418 /* anon code -- we'll come back for it */
4419 sv = SvREFCNT_inc(ppad[ix]);
4421 else if (*name == '@')
4423 else if (*name == '%')
4432 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4433 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4436 SV* sv = NEWSV(0,0);
4442 /* Now that vars are all in place, clone nested closures. */
4444 for (ix = fpad; ix > 0; ix--) {
4445 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4447 && namesv != &PL_sv_undef
4448 && !(SvFLAGS(namesv) & SVf_FAKE)
4449 && *SvPVX(namesv) == '&'
4450 && CvCLONE(ppad[ix]))
4452 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4453 SvREFCNT_dec(ppad[ix]);
4456 PL_curpad[ix] = (SV*)kid;
4460 #ifdef DEBUG_CLOSURES
4461 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4463 PerlIO_printf(Perl_debug_log, " from:\n");
4465 PerlIO_printf(Perl_debug_log, " to:\n");
4472 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4474 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4476 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4483 Perl_cv_clone(pTHX_ CV *proto)
4486 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4487 cv = cv_clone2(proto, CvOUTSIDE(proto));
4488 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4493 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4495 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4496 SV* msg = sv_newmortal();
4500 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4501 sv_setpv(msg, "Prototype mismatch:");
4503 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4505 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4506 sv_catpv(msg, " vs ");
4508 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4510 sv_catpv(msg, "none");
4511 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4515 static void const_sv_xsub(pTHX_ CV* cv);
4518 =for apidoc cv_const_sv
4520 If C<cv> is a constant sub eligible for inlining. returns the constant
4521 value returned by the sub. Otherwise, returns NULL.
4523 Constant subs can be created with C<newCONSTSUB> or as described in
4524 L<perlsub/"Constant Functions">.
4529 Perl_cv_const_sv(pTHX_ CV *cv)
4531 if (!cv || !CvCONST(cv))
4533 return (SV*)CvXSUBANY(cv).any_ptr;
4537 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4544 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4545 o = cLISTOPo->op_first->op_sibling;
4547 for (; o; o = o->op_next) {
4548 OPCODE type = o->op_type;
4550 if (sv && o->op_next == o)
4552 if (o->op_next != o) {
4553 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4555 if (type == OP_DBSTATE)
4558 if (type == OP_LEAVESUB || type == OP_RETURN)
4562 if (type == OP_CONST && cSVOPo->op_sv)
4564 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4565 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4566 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4570 /* We get here only from cv_clone2() while creating a closure.
4571 Copy the const value here instead of in cv_clone2 so that
4572 SvREADONLY_on doesn't lead to problems when leaving
4577 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4589 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4599 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4603 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4605 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4609 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4615 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4620 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4621 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4622 SV *sv = sv_newmortal();
4623 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4624 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4629 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4630 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4640 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4641 maximum a prototype before. */
4642 if (SvTYPE(gv) > SVt_NULL) {
4643 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4644 && ckWARN_d(WARN_PROTOTYPE))
4646 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4648 cv_ckproto((CV*)gv, NULL, ps);
4651 sv_setpv((SV*)gv, ps);
4653 sv_setiv((SV*)gv, -1);
4654 SvREFCNT_dec(PL_compcv);
4655 cv = PL_compcv = NULL;
4656 PL_sub_generation++;
4660 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4662 #ifdef GV_UNIQUE_CHECK
4663 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4664 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4668 if (!block || !ps || *ps || attrs)
4671 const_sv = op_const_sv(block, Nullcv);
4674 bool exists = CvROOT(cv) || CvXSUB(cv);
4676 #ifdef GV_UNIQUE_CHECK
4677 if (exists && GvUNIQUE(gv)) {
4678 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4682 /* if the subroutine doesn't exist and wasn't pre-declared
4683 * with a prototype, assume it will be AUTOLOADed,
4684 * skipping the prototype check
4686 if (exists || SvPOK(cv))
4687 cv_ckproto(cv, gv, ps);
4688 /* already defined (or promised)? */
4689 if (exists || GvASSUMECV(gv)) {
4690 if (!block && !attrs) {
4691 /* just a "sub foo;" when &foo is already defined */
4692 SAVEFREESV(PL_compcv);
4695 /* ahem, death to those who redefine active sort subs */
4696 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4697 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4699 if (ckWARN(WARN_REDEFINE)
4701 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4703 line_t oldline = CopLINE(PL_curcop);
4704 if (PL_copline != NOLINE)
4705 CopLINE_set(PL_curcop, PL_copline);
4706 Perl_warner(aTHX_ WARN_REDEFINE,
4707 CvCONST(cv) ? "Constant subroutine %s redefined"
4708 : "Subroutine %s redefined", name);
4709 CopLINE_set(PL_curcop, oldline);
4717 SvREFCNT_inc(const_sv);
4719 assert(!CvROOT(cv) && !CvCONST(cv));
4720 sv_setpv((SV*)cv, ""); /* prototype is "" */
4721 CvXSUBANY(cv).any_ptr = const_sv;
4722 CvXSUB(cv) = const_sv_xsub;
4727 cv = newCONSTSUB(NULL, name, const_sv);
4730 SvREFCNT_dec(PL_compcv);
4732 PL_sub_generation++;
4739 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4740 * before we clobber PL_compcv.
4744 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4745 stash = GvSTASH(CvGV(cv));
4746 else if (CvSTASH(cv))
4747 stash = CvSTASH(cv);
4749 stash = PL_curstash;
4752 /* possibly about to re-define existing subr -- ignore old cv */
4753 rcv = (SV*)PL_compcv;
4754 if (name && GvSTASH(gv))
4755 stash = GvSTASH(gv);
4757 stash = PL_curstash;
4759 apply_attrs(stash, rcv, attrs);
4761 if (cv) { /* must reuse cv if autoloaded */
4763 /* got here with just attrs -- work done, so bug out */
4764 SAVEFREESV(PL_compcv);
4768 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4769 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4770 CvOUTSIDE(PL_compcv) = 0;
4771 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4772 CvPADLIST(PL_compcv) = 0;
4773 /* inner references to PL_compcv must be fixed up ... */
4775 AV *padlist = CvPADLIST(cv);
4776 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4777 AV *comppad = (AV*)AvARRAY(padlist)[1];
4778 SV **namepad = AvARRAY(comppad_name);
4779 SV **curpad = AvARRAY(comppad);
4780 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4781 SV *namesv = namepad[ix];
4782 if (namesv && namesv != &PL_sv_undef
4783 && *SvPVX(namesv) == '&')
4785 CV *innercv = (CV*)curpad[ix];
4786 if (CvOUTSIDE(innercv) == PL_compcv) {
4787 CvOUTSIDE(innercv) = cv;
4788 if (!CvANON(innercv) || CvCLONED(innercv)) {
4789 (void)SvREFCNT_inc(cv);
4790 SvREFCNT_dec(PL_compcv);
4796 /* ... before we throw it away */
4797 SvREFCNT_dec(PL_compcv);
4798 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4799 ++PL_sub_generation;
4806 PL_sub_generation++;
4810 CvFILE_set_from_cop(cv, PL_curcop);
4811 CvSTASH(cv) = PL_curstash;
4812 #ifdef USE_5005THREADS
4814 if (!CvMUTEXP(cv)) {
4815 New(666, CvMUTEXP(cv), 1, perl_mutex);
4816 MUTEX_INIT(CvMUTEXP(cv));
4818 #endif /* USE_5005THREADS */
4821 sv_setpv((SV*)cv, ps);
4823 if (PL_error_count) {
4827 char *s = strrchr(name, ':');
4829 if (strEQ(s, "BEGIN")) {
4831 "BEGIN not safe after errors--compilation aborted";
4832 if (PL_in_eval & EVAL_KEEPERR)
4833 Perl_croak(aTHX_ not_safe);
4835 /* force display of errors found but not reported */
4836 sv_catpv(ERRSV, not_safe);
4837 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4845 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4846 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4849 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4850 mod(scalarseq(block), OP_LEAVESUBLV));
4853 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4855 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4856 OpREFCNT_set(CvROOT(cv), 1);
4857 CvSTART(cv) = LINKLIST(CvROOT(cv));
4858 CvROOT(cv)->op_next = 0;
4859 CALL_PEEP(CvSTART(cv));
4861 /* now that optimizer has done its work, adjust pad values */
4863 SV **namep = AvARRAY(PL_comppad_name);
4864 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4867 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4870 * The only things that a clonable function needs in its
4871 * pad are references to outer lexicals and anonymous subs.
4872 * The rest are created anew during cloning.
4874 if (!((namesv = namep[ix]) != Nullsv &&
4875 namesv != &PL_sv_undef &&
4877 *SvPVX(namesv) == '&')))
4879 SvREFCNT_dec(PL_curpad[ix]);
4880 PL_curpad[ix] = Nullsv;
4883 assert(!CvCONST(cv));
4884 if (ps && !*ps && op_const_sv(block, cv))
4888 AV *av = newAV(); /* Will be @_ */
4890 av_store(PL_comppad, 0, (SV*)av);
4891 AvFLAGS(av) = AVf_REIFY;
4893 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4894 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4896 if (!SvPADMY(PL_curpad[ix]))
4897 SvPADTMP_on(PL_curpad[ix]);
4901 /* If a potential closure prototype, don't keep a refcount on outer CV.
4902 * This is okay as the lifetime of the prototype is tied to the
4903 * lifetime of the outer CV. Avoids memory leak due to reference
4906 SvREFCNT_dec(CvOUTSIDE(cv));
4908 if (name || aname) {
4910 char *tname = (name ? name : aname);
4912 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4913 SV *sv = NEWSV(0,0);
4914 SV *tmpstr = sv_newmortal();
4915 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4919 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4921 (long)PL_subline, (long)CopLINE(PL_curcop));
4922 gv_efullname3(tmpstr, gv, Nullch);
4923 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4924 hv = GvHVn(db_postponed);
4925 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4926 && (pcv = GvCV(db_postponed)))
4932 call_sv((SV*)pcv, G_DISCARD);
4936 if ((s = strrchr(tname,':')))
4941 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4944 if (strEQ(s, "BEGIN")) {
4945 I32 oldscope = PL_scopestack_ix;
4947 SAVECOPFILE(&PL_compiling);
4948 SAVECOPLINE(&PL_compiling);
4951 PL_beginav = newAV();
4952 DEBUG_x( dump_sub(gv) );
4953 av_push(PL_beginav, (SV*)cv);
4954 GvCV(gv) = 0; /* cv has been hijacked */
4955 call_list(oldscope, PL_beginav);
4957 PL_curcop = &PL_compiling;
4958 PL_compiling.op_private = PL_hints;
4961 else if (strEQ(s, "END") && !PL_error_count) {
4964 DEBUG_x( dump_sub(gv) );
4965 av_unshift(PL_endav, 1);
4966 av_store(PL_endav, 0, (SV*)cv);
4967 GvCV(gv) = 0; /* cv has been hijacked */
4969 else if (strEQ(s, "CHECK") && !PL_error_count) {
4971 PL_checkav = newAV();
4972 DEBUG_x( dump_sub(gv) );
4973 if (PL_main_start && ckWARN(WARN_VOID))
4974 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4975 av_unshift(PL_checkav, 1);
4976 av_store(PL_checkav, 0, (SV*)cv);
4977 GvCV(gv) = 0; /* cv has been hijacked */
4979 else if (strEQ(s, "INIT") && !PL_error_count) {
4981 PL_initav = newAV();
4982 DEBUG_x( dump_sub(gv) );
4983 if (PL_main_start && ckWARN(WARN_VOID))
4984 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4985 av_push(PL_initav, (SV*)cv);
4986 GvCV(gv) = 0; /* cv has been hijacked */
4991 PL_copline = NOLINE;
4996 /* XXX unsafe for threads if eval_owner isn't held */
4998 =for apidoc newCONSTSUB
5000 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5001 eligible for inlining at compile-time.
5007 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5013 SAVECOPLINE(PL_curcop);
5014 CopLINE_set(PL_curcop, PL_copline);
5017 PL_hints &= ~HINT_BLOCK_SCOPE;
5020 SAVESPTR(PL_curstash);
5021 SAVECOPSTASH(PL_curcop);
5022 PL_curstash = stash;
5024 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5026 CopSTASH(PL_curcop) = stash;
5030 cv = newXS(name, const_sv_xsub, __FILE__);
5031 CvXSUBANY(cv).any_ptr = sv;
5033 sv_setpv((SV*)cv, ""); /* prototype is "" */
5041 =for apidoc U||newXS
5043 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5049 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5051 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5054 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5056 /* just a cached method */
5060 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5061 /* already defined (or promised) */
5062 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5063 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5064 line_t oldline = CopLINE(PL_curcop);
5065 if (PL_copline != NOLINE)
5066 CopLINE_set(PL_curcop, PL_copline);
5067 Perl_warner(aTHX_ WARN_REDEFINE,
5068 CvCONST(cv) ? "Constant subroutine %s redefined"
5069 : "Subroutine %s redefined"
5071 CopLINE_set(PL_curcop, oldline);
5078 if (cv) /* must reuse cv if autoloaded */
5081 cv = (CV*)NEWSV(1105,0);
5082 sv_upgrade((SV *)cv, SVt_PVCV);
5086 PL_sub_generation++;
5090 #ifdef USE_5005THREADS
5091 New(666, CvMUTEXP(cv), 1, perl_mutex);
5092 MUTEX_INIT(CvMUTEXP(cv));
5094 #endif /* USE_5005THREADS */
5095 (void)gv_fetchfile(filename);
5096 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5097 an external constant string */
5098 CvXSUB(cv) = subaddr;
5101 char *s = strrchr(name,':');
5107 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5110 if (strEQ(s, "BEGIN")) {
5112 PL_beginav = newAV();
5113 av_push(PL_beginav, (SV*)cv);
5114 GvCV(gv) = 0; /* cv has been hijacked */
5116 else if (strEQ(s, "END")) {
5119 av_unshift(PL_endav, 1);
5120 av_store(PL_endav, 0, (SV*)cv);
5121 GvCV(gv) = 0; /* cv has been hijacked */
5123 else if (strEQ(s, "CHECK")) {
5125 PL_checkav = newAV();
5126 if (PL_main_start && ckWARN(WARN_VOID))
5127 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5128 av_unshift(PL_checkav, 1);
5129 av_store(PL_checkav, 0, (SV*)cv);
5130 GvCV(gv) = 0; /* cv has been hijacked */
5132 else if (strEQ(s, "INIT")) {
5134 PL_initav = newAV();
5135 if (PL_main_start && ckWARN(WARN_VOID))
5136 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5137 av_push(PL_initav, (SV*)cv);
5138 GvCV(gv) = 0; /* cv has been hijacked */
5149 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5158 name = SvPVx(cSVOPo->op_sv, n_a);
5161 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5162 #ifdef GV_UNIQUE_CHECK
5164 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5168 if ((cv = GvFORM(gv))) {
5169 if (ckWARN(WARN_REDEFINE)) {
5170 line_t oldline = CopLINE(PL_curcop);
5171 if (PL_copline != NOLINE)
5172 CopLINE_set(PL_curcop, PL_copline);
5173 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5174 CopLINE_set(PL_curcop, oldline);
5181 CvFILE_set_from_cop(cv, PL_curcop);
5183 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5184 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5185 SvPADTMP_on(PL_curpad[ix]);
5188 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5189 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5190 OpREFCNT_set(CvROOT(cv), 1);
5191 CvSTART(cv) = LINKLIST(CvROOT(cv));
5192 CvROOT(cv)->op_next = 0;
5193 CALL_PEEP(CvSTART(cv));
5195 PL_copline = NOLINE;
5200 Perl_newANONLIST(pTHX_ OP *o)
5202 return newUNOP(OP_REFGEN, 0,
5203 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5207 Perl_newANONHASH(pTHX_ OP *o)
5209 return newUNOP(OP_REFGEN, 0,
5210 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5214 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5216 return newANONATTRSUB(floor, proto, Nullop, block);
5220 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5222 return newUNOP(OP_REFGEN, 0,
5223 newSVOP(OP_ANONCODE, 0,
5224 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5228 Perl_oopsAV(pTHX_ OP *o)
5230 switch (o->op_type) {
5232 o->op_type = OP_PADAV;
5233 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5234 return ref(o, OP_RV2AV);
5237 o->op_type = OP_RV2AV;
5238 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5243 if (ckWARN_d(WARN_INTERNAL))
5244 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5251 Perl_oopsHV(pTHX_ OP *o)
5253 switch (o->op_type) {
5256 o->op_type = OP_PADHV;
5257 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5258 return ref(o, OP_RV2HV);
5262 o->op_type = OP_RV2HV;
5263 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5268 if (ckWARN_d(WARN_INTERNAL))
5269 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5276 Perl_newAVREF(pTHX_ OP *o)
5278 if (o->op_type == OP_PADANY) {
5279 o->op_type = OP_PADAV;
5280 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5283 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5284 && ckWARN(WARN_DEPRECATED)) {
5285 Perl_warner(aTHX_ WARN_DEPRECATED,
5286 "Using an array as a reference is deprecated");
5288 return newUNOP(OP_RV2AV, 0, scalar(o));
5292 Perl_newGVREF(pTHX_ I32 type, OP *o)
5294 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5295 return newUNOP(OP_NULL, 0, o);
5296 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5300 Perl_newHVREF(pTHX_ OP *o)
5302 if (o->op_type == OP_PADANY) {
5303 o->op_type = OP_PADHV;
5304 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5307 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5308 && ckWARN(WARN_DEPRECATED)) {
5309 Perl_warner(aTHX_ WARN_DEPRECATED,
5310 "Using a hash as a reference is deprecated");
5312 return newUNOP(OP_RV2HV, 0, scalar(o));
5316 Perl_oopsCV(pTHX_ OP *o)
5318 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5324 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5326 return newUNOP(OP_RV2CV, flags, scalar(o));
5330 Perl_newSVREF(pTHX_ OP *o)
5332 if (o->op_type == OP_PADANY) {
5333 o->op_type = OP_PADSV;
5334 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5337 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5338 o->op_flags |= OPpDONE_SVREF;
5341 return newUNOP(OP_RV2SV, 0, scalar(o));
5344 /* Check routines. */
5347 Perl_ck_anoncode(pTHX_ OP *o)
5352 name = NEWSV(1106,0);
5353 sv_upgrade(name, SVt_PVNV);
5354 sv_setpvn(name, "&", 1);
5357 ix = pad_alloc(o->op_type, SVs_PADMY);
5358 av_store(PL_comppad_name, ix, name);
5359 av_store(PL_comppad, ix, cSVOPo->op_sv);
5360 SvPADMY_on(cSVOPo->op_sv);
5361 cSVOPo->op_sv = Nullsv;
5362 cSVOPo->op_targ = ix;
5367 Perl_ck_bitop(pTHX_ OP *o)
5369 o->op_private = PL_hints;
5374 Perl_ck_concat(pTHX_ OP *o)
5376 if (cUNOPo->op_first->op_type == OP_CONCAT)
5377 o->op_flags |= OPf_STACKED;
5382 Perl_ck_spair(pTHX_ OP *o)
5384 if (o->op_flags & OPf_KIDS) {
5387 OPCODE type = o->op_type;
5388 o = modkids(ck_fun(o), type);
5389 kid = cUNOPo->op_first;
5390 newop = kUNOP->op_first->op_sibling;
5392 (newop->op_sibling ||
5393 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5394 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5395 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5399 op_free(kUNOP->op_first);
5400 kUNOP->op_first = newop;
5402 o->op_ppaddr = PL_ppaddr[++o->op_type];
5407 Perl_ck_delete(pTHX_ OP *o)
5411 if (o->op_flags & OPf_KIDS) {
5412 OP *kid = cUNOPo->op_first;
5413 switch (kid->op_type) {
5415 o->op_flags |= OPf_SPECIAL;
5418 o->op_private |= OPpSLICE;
5421 o->op_flags |= OPf_SPECIAL;
5426 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5435 Perl_ck_eof(pTHX_ OP *o)
5437 I32 type = o->op_type;
5439 if (o->op_flags & OPf_KIDS) {
5440 if (cLISTOPo->op_first->op_type == OP_STUB) {
5442 o = newUNOP(type, OPf_SPECIAL,
5443 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5451 Perl_ck_eval(pTHX_ OP *o)
5453 PL_hints |= HINT_BLOCK_SCOPE;
5454 if (o->op_flags & OPf_KIDS) {
5455 SVOP *kid = (SVOP*)cUNOPo->op_first;
5458 o->op_flags &= ~OPf_KIDS;
5461 else if (kid->op_type == OP_LINESEQ) {
5464 kid->op_next = o->op_next;
5465 cUNOPo->op_first = 0;
5468 NewOp(1101, enter, 1, LOGOP);
5469 enter->op_type = OP_ENTERTRY;
5470 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5471 enter->op_private = 0;
5473 /* establish postfix order */
5474 enter->op_next = (OP*)enter;
5476 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5477 o->op_type = OP_LEAVETRY;
5478 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5479 enter->op_other = o;
5487 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5489 o->op_targ = (PADOFFSET)PL_hints;
5494 Perl_ck_exit(pTHX_ OP *o)
5497 HV *table = GvHV(PL_hintgv);
5499 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5500 if (svp && *svp && SvTRUE(*svp))
5501 o->op_private |= OPpEXIT_VMSISH;
5508 Perl_ck_exec(pTHX_ OP *o)
5511 if (o->op_flags & OPf_STACKED) {
5513 kid = cUNOPo->op_first->op_sibling;
5514 if (kid->op_type == OP_RV2GV)
5523 Perl_ck_exists(pTHX_ OP *o)
5526 if (o->op_flags & OPf_KIDS) {
5527 OP *kid = cUNOPo->op_first;
5528 if (kid->op_type == OP_ENTERSUB) {
5529 (void) ref(kid, o->op_type);
5530 if (kid->op_type != OP_RV2CV && !PL_error_count)
5531 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5533 o->op_private |= OPpEXISTS_SUB;
5535 else if (kid->op_type == OP_AELEM)
5536 o->op_flags |= OPf_SPECIAL;
5537 else if (kid->op_type != OP_HELEM)
5538 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5547 Perl_ck_gvconst(pTHX_ register OP *o)
5549 o = fold_constants(o);
5550 if (o->op_type == OP_CONST)
5557 Perl_ck_rvconst(pTHX_ register OP *o)
5559 SVOP *kid = (SVOP*)cUNOPo->op_first;
5561 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5562 if (kid->op_type == OP_CONST) {
5566 SV *kidsv = kid->op_sv;
5569 /* Is it a constant from cv_const_sv()? */
5570 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5571 SV *rsv = SvRV(kidsv);
5572 int svtype = SvTYPE(rsv);
5573 char *badtype = Nullch;
5575 switch (o->op_type) {
5577 if (svtype > SVt_PVMG)
5578 badtype = "a SCALAR";
5581 if (svtype != SVt_PVAV)
5582 badtype = "an ARRAY";
5585 if (svtype != SVt_PVHV) {
5586 if (svtype == SVt_PVAV) { /* pseudohash? */
5587 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5588 if (ksv && SvROK(*ksv)
5589 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5598 if (svtype != SVt_PVCV)
5603 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5606 name = SvPV(kidsv, n_a);
5607 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5608 char *badthing = Nullch;
5609 switch (o->op_type) {
5611 badthing = "a SCALAR";
5614 badthing = "an ARRAY";
5617 badthing = "a HASH";
5622 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5626 * This is a little tricky. We only want to add the symbol if we
5627 * didn't add it in the lexer. Otherwise we get duplicate strict
5628 * warnings. But if we didn't add it in the lexer, we must at
5629 * least pretend like we wanted to add it even if it existed before,
5630 * or we get possible typo warnings. OPpCONST_ENTERED says
5631 * whether the lexer already added THIS instance of this symbol.
5633 iscv = (o->op_type == OP_RV2CV) * 2;
5635 gv = gv_fetchpv(name,
5636 iscv | !(kid->op_private & OPpCONST_ENTERED),
5639 : o->op_type == OP_RV2SV
5641 : o->op_type == OP_RV2AV
5643 : o->op_type == OP_RV2HV
5646 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5648 kid->op_type = OP_GV;
5649 SvREFCNT_dec(kid->op_sv);
5651 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5652 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5653 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5655 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5657 kid->op_sv = SvREFCNT_inc(gv);
5659 kid->op_private = 0;
5660 kid->op_ppaddr = PL_ppaddr[OP_GV];
5667 Perl_ck_ftst(pTHX_ OP *o)
5669 I32 type = o->op_type;
5671 if (o->op_flags & OPf_REF) {
5674 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5675 SVOP *kid = (SVOP*)cUNOPo->op_first;
5677 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5679 OP *newop = newGVOP(type, OPf_REF,
5680 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5687 if (type == OP_FTTTY)
5688 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5691 o = newUNOP(type, 0, newDEFSVOP());
5697 Perl_ck_fun(pTHX_ OP *o)
5703 int type = o->op_type;
5704 register I32 oa = PL_opargs[type] >> OASHIFT;
5706 if (o->op_flags & OPf_STACKED) {
5707 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5710 return no_fh_allowed(o);
5713 if (o->op_flags & OPf_KIDS) {
5715 tokid = &cLISTOPo->op_first;
5716 kid = cLISTOPo->op_first;
5717 if (kid->op_type == OP_PUSHMARK ||
5718 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5720 tokid = &kid->op_sibling;
5721 kid = kid->op_sibling;
5723 if (!kid && PL_opargs[type] & OA_DEFGV)
5724 *tokid = kid = newDEFSVOP();
5728 sibl = kid->op_sibling;
5731 /* list seen where single (scalar) arg expected? */
5732 if (numargs == 1 && !(oa >> 4)
5733 && kid->op_type == OP_LIST && type != OP_SCALAR)
5735 return too_many_arguments(o,PL_op_desc[type]);
5748 if ((type == OP_PUSH || type == OP_UNSHIFT)
5749 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5750 Perl_warner(aTHX_ WARN_SYNTAX,
5751 "Useless use of %s with no values",
5754 if (kid->op_type == OP_CONST &&
5755 (kid->op_private & OPpCONST_BARE))
5757 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5758 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5759 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5760 if (ckWARN(WARN_DEPRECATED))
5761 Perl_warner(aTHX_ WARN_DEPRECATED,
5762 "Array @%s missing the @ in argument %"IVdf" of %s()",
5763 name, (IV)numargs, PL_op_desc[type]);
5766 kid->op_sibling = sibl;
5769 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5770 bad_type(numargs, "array", PL_op_desc[type], kid);
5774 if (kid->op_type == OP_CONST &&
5775 (kid->op_private & OPpCONST_BARE))
5777 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5778 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5779 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5780 if (ckWARN(WARN_DEPRECATED))
5781 Perl_warner(aTHX_ WARN_DEPRECATED,
5782 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5783 name, (IV)numargs, PL_op_desc[type]);
5786 kid->op_sibling = sibl;
5789 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5790 bad_type(numargs, "hash", PL_op_desc[type], kid);
5795 OP *newop = newUNOP(OP_NULL, 0, kid);
5796 kid->op_sibling = 0;
5798 newop->op_next = newop;
5800 kid->op_sibling = sibl;
5805 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5806 if (kid->op_type == OP_CONST &&
5807 (kid->op_private & OPpCONST_BARE))
5809 OP *newop = newGVOP(OP_GV, 0,
5810 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5815 else if (kid->op_type == OP_READLINE) {
5816 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5817 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5820 I32 flags = OPf_SPECIAL;
5824 /* is this op a FH constructor? */
5825 if (is_handle_constructor(o,numargs)) {
5826 char *name = Nullch;
5830 /* Set a flag to tell rv2gv to vivify
5831 * need to "prove" flag does not mean something
5832 * else already - NI-S 1999/05/07
5835 if (kid->op_type == OP_PADSV) {
5836 SV **namep = av_fetch(PL_comppad_name,
5838 if (namep && *namep)
5839 name = SvPV(*namep, len);
5841 else if (kid->op_type == OP_RV2SV
5842 && kUNOP->op_first->op_type == OP_GV)
5844 GV *gv = cGVOPx_gv(kUNOP->op_first);
5846 len = GvNAMELEN(gv);
5848 else if (kid->op_type == OP_AELEM
5849 || kid->op_type == OP_HELEM)
5851 name = "__ANONIO__";
5857 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5858 namesv = PL_curpad[targ];
5859 (void)SvUPGRADE(namesv, SVt_PV);
5861 sv_setpvn(namesv, "$", 1);
5862 sv_catpvn(namesv, name, len);
5865 kid->op_sibling = 0;
5866 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5867 kid->op_targ = targ;
5868 kid->op_private |= priv;
5870 kid->op_sibling = sibl;
5876 mod(scalar(kid), type);
5880 tokid = &kid->op_sibling;
5881 kid = kid->op_sibling;
5883 o->op_private |= numargs;
5885 return too_many_arguments(o,OP_DESC(o));
5888 else if (PL_opargs[type] & OA_DEFGV) {
5890 return newUNOP(type, 0, newDEFSVOP());
5894 while (oa & OA_OPTIONAL)
5896 if (oa && oa != OA_LIST)
5897 return too_few_arguments(o,OP_DESC(o));
5903 Perl_ck_glob(pTHX_ OP *o)
5908 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5909 append_elem(OP_GLOB, o, newDEFSVOP());
5911 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5912 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5914 #if !defined(PERL_EXTERNAL_GLOB)
5915 /* XXX this can be tightened up and made more failsafe. */
5919 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5921 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5922 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5923 GvCV(gv) = GvCV(glob_gv);
5924 SvREFCNT_inc((SV*)GvCV(gv));
5925 GvIMPORTED_CV_on(gv);
5928 #endif /* PERL_EXTERNAL_GLOB */
5930 if (gv && GvIMPORTED_CV(gv)) {
5931 append_elem(OP_GLOB, o,
5932 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5933 o->op_type = OP_LIST;
5934 o->op_ppaddr = PL_ppaddr[OP_LIST];
5935 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5936 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5937 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5938 append_elem(OP_LIST, o,
5939 scalar(newUNOP(OP_RV2CV, 0,
5940 newGVOP(OP_GV, 0, gv)))));
5941 o = newUNOP(OP_NULL, 0, ck_subr(o));
5942 o->op_targ = OP_GLOB; /* hint at what it used to be */
5945 gv = newGVgen("main");
5947 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5953 Perl_ck_grep(pTHX_ OP *o)
5957 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5959 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5960 NewOp(1101, gwop, 1, LOGOP);
5962 if (o->op_flags & OPf_STACKED) {
5965 kid = cLISTOPo->op_first->op_sibling;
5966 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5969 kid->op_next = (OP*)gwop;
5970 o->op_flags &= ~OPf_STACKED;
5972 kid = cLISTOPo->op_first->op_sibling;
5973 if (type == OP_MAPWHILE)
5980 kid = cLISTOPo->op_first->op_sibling;
5981 if (kid->op_type != OP_NULL)
5982 Perl_croak(aTHX_ "panic: ck_grep");
5983 kid = kUNOP->op_first;
5985 gwop->op_type = type;
5986 gwop->op_ppaddr = PL_ppaddr[type];
5987 gwop->op_first = listkids(o);
5988 gwop->op_flags |= OPf_KIDS;
5989 gwop->op_private = 1;
5990 gwop->op_other = LINKLIST(kid);
5991 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5992 kid->op_next = (OP*)gwop;
5994 kid = cLISTOPo->op_first->op_sibling;
5995 if (!kid || !kid->op_sibling)
5996 return too_few_arguments(o,OP_DESC(o));
5997 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5998 mod(kid, OP_GREPSTART);
6004 Perl_ck_index(pTHX_ OP *o)
6006 if (o->op_flags & OPf_KIDS) {
6007 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6009 kid = kid->op_sibling; /* get past "big" */
6010 if (kid && kid->op_type == OP_CONST)
6011 fbm_compile(((SVOP*)kid)->op_sv, 0);
6017 Perl_ck_lengthconst(pTHX_ OP *o)
6019 /* XXX length optimization goes here */
6024 Perl_ck_lfun(pTHX_ OP *o)
6026 OPCODE type = o->op_type;
6027 return modkids(ck_fun(o), type);
6031 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6033 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6034 switch (cUNOPo->op_first->op_type) {
6036 /* This is needed for
6037 if (defined %stash::)
6038 to work. Do not break Tk.
6040 break; /* Globals via GV can be undef */
6042 case OP_AASSIGN: /* Is this a good idea? */
6043 Perl_warner(aTHX_ WARN_DEPRECATED,
6044 "defined(@array) is deprecated");
6045 Perl_warner(aTHX_ WARN_DEPRECATED,
6046 "\t(Maybe you should just omit the defined()?)\n");
6049 /* This is needed for
6050 if (defined %stash::)
6051 to work. Do not break Tk.
6053 break; /* Globals via GV can be undef */
6055 Perl_warner(aTHX_ WARN_DEPRECATED,
6056 "defined(%%hash) is deprecated");
6057 Perl_warner(aTHX_ WARN_DEPRECATED,
6058 "\t(Maybe you should just omit the defined()?)\n");
6069 Perl_ck_rfun(pTHX_ OP *o)
6071 OPCODE type = o->op_type;
6072 return refkids(ck_fun(o), type);
6076 Perl_ck_listiob(pTHX_ OP *o)
6080 kid = cLISTOPo->op_first;
6083 kid = cLISTOPo->op_first;
6085 if (kid->op_type == OP_PUSHMARK)
6086 kid = kid->op_sibling;
6087 if (kid && o->op_flags & OPf_STACKED)
6088 kid = kid->op_sibling;
6089 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6090 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6091 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6092 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6093 cLISTOPo->op_first->op_sibling = kid;
6094 cLISTOPo->op_last = kid;
6095 kid = kid->op_sibling;
6100 append_elem(o->op_type, o, newDEFSVOP());
6106 Perl_ck_sassign(pTHX_ OP *o)
6108 OP *kid = cLISTOPo->op_first;
6109 /* has a disposable target? */
6110 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6111 && !(kid->op_flags & OPf_STACKED)
6112 /* Cannot steal the second time! */
6113 && !(kid->op_private & OPpTARGET_MY))
6115 OP *kkid = kid->op_sibling;
6117 /* Can just relocate the target. */
6118 if (kkid && kkid->op_type == OP_PADSV
6119 && !(kkid->op_private & OPpLVAL_INTRO))
6121 kid->op_targ = kkid->op_targ;
6123 /* Now we do not need PADSV and SASSIGN. */
6124 kid->op_sibling = o->op_sibling; /* NULL */
6125 cLISTOPo->op_first = NULL;
6128 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6136 Perl_ck_match(pTHX_ OP *o)
6138 o->op_private |= OPpRUNTIME;
6143 Perl_ck_method(pTHX_ OP *o)
6145 OP *kid = cUNOPo->op_first;
6146 if (kid->op_type == OP_CONST) {
6147 SV* sv = kSVOP->op_sv;
6148 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6150 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6151 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6154 kSVOP->op_sv = Nullsv;
6156 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6165 Perl_ck_null(pTHX_ OP *o)
6171 Perl_ck_open(pTHX_ OP *o)
6173 HV *table = GvHV(PL_hintgv);
6177 svp = hv_fetch(table, "open_IN", 7, FALSE);
6179 mode = mode_from_discipline(*svp);
6180 if (mode & O_BINARY)
6181 o->op_private |= OPpOPEN_IN_RAW;
6182 else if (mode & O_TEXT)
6183 o->op_private |= OPpOPEN_IN_CRLF;
6186 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6188 mode = mode_from_discipline(*svp);
6189 if (mode & O_BINARY)
6190 o->op_private |= OPpOPEN_OUT_RAW;
6191 else if (mode & O_TEXT)
6192 o->op_private |= OPpOPEN_OUT_CRLF;
6195 if (o->op_type == OP_BACKTICK)
6201 Perl_ck_repeat(pTHX_ OP *o)
6203 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6204 o->op_private |= OPpREPEAT_DOLIST;
6205 cBINOPo->op_first = force_list(cBINOPo->op_first);
6213 Perl_ck_require(pTHX_ OP *o)
6217 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6218 SVOP *kid = (SVOP*)cUNOPo->op_first;
6220 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6222 for (s = SvPVX(kid->op_sv); *s; s++) {
6223 if (*s == ':' && s[1] == ':') {
6225 Move(s+2, s+1, strlen(s+2)+1, char);
6226 --SvCUR(kid->op_sv);
6229 if (SvREADONLY(kid->op_sv)) {
6230 SvREADONLY_off(kid->op_sv);
6231 sv_catpvn(kid->op_sv, ".pm", 3);
6232 SvREADONLY_on(kid->op_sv);
6235 sv_catpvn(kid->op_sv, ".pm", 3);
6239 /* handle override, if any */
6240 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6241 if (!(gv && GvIMPORTED_CV(gv)))
6242 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6244 if (gv && GvIMPORTED_CV(gv)) {
6245 OP *kid = cUNOPo->op_first;
6246 cUNOPo->op_first = 0;
6248 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6249 append_elem(OP_LIST, kid,
6250 scalar(newUNOP(OP_RV2CV, 0,
6259 Perl_ck_return(pTHX_ OP *o)
6262 if (CvLVALUE(PL_compcv)) {
6263 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6264 mod(kid, OP_LEAVESUBLV);
6271 Perl_ck_retarget(pTHX_ OP *o)
6273 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6280 Perl_ck_select(pTHX_ OP *o)
6283 if (o->op_flags & OPf_KIDS) {
6284 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6285 if (kid && kid->op_sibling) {
6286 o->op_type = OP_SSELECT;
6287 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6289 return fold_constants(o);
6293 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6294 if (kid && kid->op_type == OP_RV2GV)
6295 kid->op_private &= ~HINT_STRICT_REFS;
6300 Perl_ck_shift(pTHX_ OP *o)
6302 I32 type = o->op_type;
6304 if (!(o->op_flags & OPf_KIDS)) {
6308 #ifdef USE_5005THREADS
6309 if (!CvUNIQUE(PL_compcv)) {
6310 argop = newOP(OP_PADAV, OPf_REF);
6311 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6314 argop = newUNOP(OP_RV2AV, 0,
6315 scalar(newGVOP(OP_GV, 0,
6316 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6319 argop = newUNOP(OP_RV2AV, 0,
6320 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6321 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6322 #endif /* USE_5005THREADS */
6323 return newUNOP(type, 0, scalar(argop));
6325 return scalar(modkids(ck_fun(o), type));
6329 Perl_ck_sort(pTHX_ OP *o)
6333 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6335 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6336 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6338 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6340 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6342 if (kid->op_type == OP_SCOPE) {
6346 else if (kid->op_type == OP_LEAVE) {
6347 if (o->op_type == OP_SORT) {
6348 op_null(kid); /* wipe out leave */
6351 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6352 if (k->op_next == kid)
6354 /* don't descend into loops */
6355 else if (k->op_type == OP_ENTERLOOP
6356 || k->op_type == OP_ENTERITER)
6358 k = cLOOPx(k)->op_lastop;
6363 kid->op_next = 0; /* just disconnect the leave */
6364 k = kLISTOP->op_first;
6369 if (o->op_type == OP_SORT) {
6370 /* provide scalar context for comparison function/block */
6376 o->op_flags |= OPf_SPECIAL;
6378 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6381 firstkid = firstkid->op_sibling;
6384 /* provide list context for arguments */
6385 if (o->op_type == OP_SORT)
6392 S_simplify_sort(pTHX_ OP *o)
6394 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6398 if (!(o->op_flags & OPf_STACKED))
6400 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6401 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6402 kid = kUNOP->op_first; /* get past null */
6403 if (kid->op_type != OP_SCOPE)
6405 kid = kLISTOP->op_last; /* get past scope */
6406 switch(kid->op_type) {
6414 k = kid; /* remember this node*/
6415 if (kBINOP->op_first->op_type != OP_RV2SV)
6417 kid = kBINOP->op_first; /* get past cmp */
6418 if (kUNOP->op_first->op_type != OP_GV)
6420 kid = kUNOP->op_first; /* get past rv2sv */
6422 if (GvSTASH(gv) != PL_curstash)
6424 if (strEQ(GvNAME(gv), "a"))
6426 else if (strEQ(GvNAME(gv), "b"))
6430 kid = k; /* back to cmp */
6431 if (kBINOP->op_last->op_type != OP_RV2SV)
6433 kid = kBINOP->op_last; /* down to 2nd arg */
6434 if (kUNOP->op_first->op_type != OP_GV)
6436 kid = kUNOP->op_first; /* get past rv2sv */
6438 if (GvSTASH(gv) != PL_curstash
6440 ? strNE(GvNAME(gv), "a")
6441 : strNE(GvNAME(gv), "b")))
6443 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6445 o->op_private |= OPpSORT_REVERSE;
6446 if (k->op_type == OP_NCMP)
6447 o->op_private |= OPpSORT_NUMERIC;
6448 if (k->op_type == OP_I_NCMP)
6449 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6450 kid = cLISTOPo->op_first->op_sibling;
6451 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6452 op_free(kid); /* then delete it */
6456 Perl_ck_split(pTHX_ OP *o)
6460 if (o->op_flags & OPf_STACKED)
6461 return no_fh_allowed(o);
6463 kid = cLISTOPo->op_first;
6464 if (kid->op_type != OP_NULL)
6465 Perl_croak(aTHX_ "panic: ck_split");
6466 kid = kid->op_sibling;
6467 op_free(cLISTOPo->op_first);
6468 cLISTOPo->op_first = kid;
6470 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6471 cLISTOPo->op_last = kid; /* There was only one element previously */
6474 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6475 OP *sibl = kid->op_sibling;
6476 kid->op_sibling = 0;
6477 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6478 if (cLISTOPo->op_first == cLISTOPo->op_last)
6479 cLISTOPo->op_last = kid;
6480 cLISTOPo->op_first = kid;
6481 kid->op_sibling = sibl;
6484 kid->op_type = OP_PUSHRE;
6485 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6488 if (!kid->op_sibling)
6489 append_elem(OP_SPLIT, o, newDEFSVOP());
6491 kid = kid->op_sibling;
6494 if (!kid->op_sibling)
6495 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6497 kid = kid->op_sibling;
6500 if (kid->op_sibling)
6501 return too_many_arguments(o,OP_DESC(o));
6507 Perl_ck_join(pTHX_ OP *o)
6509 if (ckWARN(WARN_SYNTAX)) {
6510 OP *kid = cLISTOPo->op_first->op_sibling;
6511 if (kid && kid->op_type == OP_MATCH) {
6512 char *pmstr = "STRING";
6513 if (PM_GETRE(kPMOP))
6514 pmstr = PM_GETRE(kPMOP)->precomp;
6515 Perl_warner(aTHX_ WARN_SYNTAX,
6516 "/%s/ should probably be written as \"%s\"",
6524 Perl_ck_subr(pTHX_ OP *o)
6526 OP *prev = ((cUNOPo->op_first->op_sibling)
6527 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6528 OP *o2 = prev->op_sibling;
6535 I32 contextclass = 0;
6539 o->op_private |= OPpENTERSUB_HASTARG;
6540 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6541 if (cvop->op_type == OP_RV2CV) {
6543 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6544 op_null(cvop); /* disable rv2cv */
6545 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6546 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6547 GV *gv = cGVOPx_gv(tmpop);
6550 tmpop->op_private |= OPpEARLY_CV;
6551 else if (SvPOK(cv)) {
6552 namegv = CvANON(cv) ? gv : CvGV(cv);
6553 proto = SvPV((SV*)cv, n_a);
6557 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6558 if (o2->op_type == OP_CONST)
6559 o2->op_private &= ~OPpCONST_STRICT;
6560 else if (o2->op_type == OP_LIST) {
6561 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6562 if (o && o->op_type == OP_CONST)
6563 o->op_private &= ~OPpCONST_STRICT;
6566 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6567 if (PERLDB_SUB && PL_curstash != PL_debstash)
6568 o->op_private |= OPpENTERSUB_DB;
6569 while (o2 != cvop) {
6573 return too_many_arguments(o, gv_ename(namegv));
6591 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6593 arg == 1 ? "block or sub {}" : "sub {}",
6594 gv_ename(namegv), o2);
6597 /* '*' allows any scalar type, including bareword */
6600 if (o2->op_type == OP_RV2GV)
6601 goto wrapref; /* autoconvert GLOB -> GLOBref */
6602 else if (o2->op_type == OP_CONST)
6603 o2->op_private &= ~OPpCONST_STRICT;
6604 else if (o2->op_type == OP_ENTERSUB) {
6605 /* accidental subroutine, revert to bareword */
6606 OP *gvop = ((UNOP*)o2)->op_first;
6607 if (gvop && gvop->op_type == OP_NULL) {
6608 gvop = ((UNOP*)gvop)->op_first;
6610 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6613 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6614 (gvop = ((UNOP*)gvop)->op_first) &&
6615 gvop->op_type == OP_GV)
6617 GV *gv = cGVOPx_gv(gvop);
6618 OP *sibling = o2->op_sibling;
6619 SV *n = newSVpvn("",0);
6621 gv_fullname3(n, gv, "");
6622 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6623 sv_chop(n, SvPVX(n)+6);
6624 o2 = newSVOP(OP_CONST, 0, n);
6625 prev->op_sibling = o2;
6626 o2->op_sibling = sibling;
6642 if (contextclass++ == 0) {
6643 e = strchr(proto, ']');
6644 if (!e || e == proto)
6658 if (o2->op_type == OP_RV2GV)
6661 bad_type(arg, "symbol", gv_ename(namegv), o2);
6664 if (o2->op_type == OP_ENTERSUB)
6667 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6670 if (o2->op_type == OP_RV2SV ||
6671 o2->op_type == OP_PADSV ||
6672 o2->op_type == OP_HELEM ||
6673 o2->op_type == OP_AELEM ||
6674 o2->op_type == OP_THREADSV)
6677 bad_type(arg, "scalar", gv_ename(namegv), o2);
6680 if (o2->op_type == OP_RV2AV ||
6681 o2->op_type == OP_PADAV)
6684 bad_type(arg, "array", gv_ename(namegv), o2);
6687 if (o2->op_type == OP_RV2HV ||
6688 o2->op_type == OP_PADHV)
6691 bad_type(arg, "hash", gv_ename(namegv), o2);
6696 OP* sib = kid->op_sibling;
6697 kid->op_sibling = 0;
6698 o2 = newUNOP(OP_REFGEN, 0, kid);
6699 o2->op_sibling = sib;
6700 prev->op_sibling = o2;
6702 if (contextclass && e) {
6717 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6718 gv_ename(namegv), SvPV((SV*)cv, n_a));
6723 mod(o2, OP_ENTERSUB);
6725 o2 = o2->op_sibling;
6727 if (proto && !optional &&
6728 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6729 return too_few_arguments(o, gv_ename(namegv));
6734 Perl_ck_svconst(pTHX_ OP *o)
6736 SvREADONLY_on(cSVOPo->op_sv);
6741 Perl_ck_trunc(pTHX_ OP *o)
6743 if (o->op_flags & OPf_KIDS) {
6744 SVOP *kid = (SVOP*)cUNOPo->op_first;
6746 if (kid->op_type == OP_NULL)
6747 kid = (SVOP*)kid->op_sibling;
6748 if (kid && kid->op_type == OP_CONST &&
6749 (kid->op_private & OPpCONST_BARE))
6751 o->op_flags |= OPf_SPECIAL;
6752 kid->op_private &= ~OPpCONST_STRICT;
6759 Perl_ck_substr(pTHX_ OP *o)
6762 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6763 OP *kid = cLISTOPo->op_first;
6765 if (kid->op_type == OP_NULL)
6766 kid = kid->op_sibling;
6768 kid->op_flags |= OPf_MOD;
6774 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6777 Perl_peep(pTHX_ register OP *o)
6779 register OP* oldop = 0;
6782 if (!o || o->op_seq)
6786 SAVEVPTR(PL_curcop);
6787 for (; o; o = o->op_next) {
6793 switch (o->op_type) {
6797 PL_curcop = ((COP*)o); /* for warnings */
6798 o->op_seq = PL_op_seqmax++;
6802 if (cSVOPo->op_private & OPpCONST_STRICT)
6803 no_bareword_allowed(o);
6805 /* Relocate sv to the pad for thread safety.
6806 * Despite being a "constant", the SV is written to,
6807 * for reference counts, sv_upgrade() etc. */
6809 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6810 if (SvPADTMP(cSVOPo->op_sv)) {
6811 /* If op_sv is already a PADTMP then it is being used by
6812 * some pad, so make a copy. */
6813 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6814 SvREADONLY_on(PL_curpad[ix]);
6815 SvREFCNT_dec(cSVOPo->op_sv);
6818 SvREFCNT_dec(PL_curpad[ix]);
6819 SvPADTMP_on(cSVOPo->op_sv);
6820 PL_curpad[ix] = cSVOPo->op_sv;
6821 /* XXX I don't know how this isn't readonly already. */
6822 SvREADONLY_on(PL_curpad[ix]);
6824 cSVOPo->op_sv = Nullsv;
6828 o->op_seq = PL_op_seqmax++;
6832 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6833 if (o->op_next->op_private & OPpTARGET_MY) {
6834 if (o->op_flags & OPf_STACKED) /* chained concats */
6835 goto ignore_optimization;
6837 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6838 o->op_targ = o->op_next->op_targ;
6839 o->op_next->op_targ = 0;
6840 o->op_private |= OPpTARGET_MY;
6843 op_null(o->op_next);
6845 ignore_optimization:
6846 o->op_seq = PL_op_seqmax++;
6849 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6850 o->op_seq = PL_op_seqmax++;
6851 break; /* Scalar stub must produce undef. List stub is noop */
6855 if (o->op_targ == OP_NEXTSTATE
6856 || o->op_targ == OP_DBSTATE
6857 || o->op_targ == OP_SETSTATE)
6859 PL_curcop = ((COP*)o);
6861 /* XXX: We avoid setting op_seq here to prevent later calls
6862 to peep() from mistakenly concluding that optimisation
6863 has already occurred. This doesn't fix the real problem,
6864 though (See 20010220.007). AMS 20010719 */
6865 if (oldop && o->op_next) {
6866 oldop->op_next = o->op_next;
6874 if (oldop && o->op_next) {
6875 oldop->op_next = o->op_next;
6878 o->op_seq = PL_op_seqmax++;
6882 if (o->op_next->op_type == OP_RV2SV) {
6883 if (!(o->op_next->op_private & OPpDEREF)) {
6884 op_null(o->op_next);
6885 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6887 o->op_next = o->op_next->op_next;
6888 o->op_type = OP_GVSV;
6889 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6892 else if (o->op_next->op_type == OP_RV2AV) {
6893 OP* pop = o->op_next->op_next;
6895 if (pop->op_type == OP_CONST &&
6896 (PL_op = pop->op_next) &&
6897 pop->op_next->op_type == OP_AELEM &&
6898 !(pop->op_next->op_private &
6899 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6900 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6905 op_null(o->op_next);
6906 op_null(pop->op_next);
6908 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6909 o->op_next = pop->op_next->op_next;
6910 o->op_type = OP_AELEMFAST;
6911 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6912 o->op_private = (U8)i;
6917 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6919 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6920 /* XXX could check prototype here instead of just carping */
6921 SV *sv = sv_newmortal();
6922 gv_efullname3(sv, gv, Nullch);
6923 Perl_warner(aTHX_ WARN_PROTOTYPE,
6924 "%s() called too early to check prototype",
6928 else if (o->op_next->op_type == OP_READLINE
6929 && o->op_next->op_next->op_type == OP_CONCAT
6930 && (o->op_next->op_next->op_flags & OPf_STACKED))
6932 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6933 o->op_type = OP_RCATLINE;
6934 o->op_flags |= OPf_STACKED;
6935 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6936 op_null(o->op_next->op_next);
6937 op_null(o->op_next);
6940 o->op_seq = PL_op_seqmax++;
6951 o->op_seq = PL_op_seqmax++;
6952 while (cLOGOP->op_other->op_type == OP_NULL)
6953 cLOGOP->op_other = cLOGOP->op_other->op_next;
6954 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6959 o->op_seq = PL_op_seqmax++;
6960 while (cLOOP->op_redoop->op_type == OP_NULL)
6961 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6962 peep(cLOOP->op_redoop);
6963 while (cLOOP->op_nextop->op_type == OP_NULL)
6964 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6965 peep(cLOOP->op_nextop);
6966 while (cLOOP->op_lastop->op_type == OP_NULL)
6967 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6968 peep(cLOOP->op_lastop);
6974 o->op_seq = PL_op_seqmax++;
6975 while (cPMOP->op_pmreplstart &&
6976 cPMOP->op_pmreplstart->op_type == OP_NULL)
6977 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6978 peep(cPMOP->op_pmreplstart);
6982 o->op_seq = PL_op_seqmax++;
6983 if (ckWARN(WARN_SYNTAX) && o->op_next
6984 && o->op_next->op_type == OP_NEXTSTATE) {
6985 if (o->op_next->op_sibling &&
6986 o->op_next->op_sibling->op_type != OP_EXIT &&
6987 o->op_next->op_sibling->op_type != OP_WARN &&
6988 o->op_next->op_sibling->op_type != OP_DIE) {
6989 line_t oldline = CopLINE(PL_curcop);
6991 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6992 Perl_warner(aTHX_ WARN_EXEC,
6993 "Statement unlikely to be reached");
6994 Perl_warner(aTHX_ WARN_EXEC,
6995 "\t(Maybe you meant system() when you said exec()?)\n");
6996 CopLINE_set(PL_curcop, oldline);
7005 SV **svp, **indsvp, *sv;
7010 o->op_seq = PL_op_seqmax++;
7012 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7015 /* Make the CONST have a shared SV */
7016 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7017 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7018 key = SvPV(sv, keylen);
7019 lexname = newSVpvn_share(key,
7020 SvUTF8(sv) ? -(I32)keylen : keylen,
7026 if ((o->op_private & (OPpLVAL_INTRO)))
7029 rop = (UNOP*)((BINOP*)o)->op_first;
7030 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7032 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7033 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7035 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7036 if (!fields || !GvHV(*fields))
7038 key = SvPV(*svp, keylen);
7039 indsvp = hv_fetch(GvHV(*fields), key,
7040 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7042 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7043 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7045 ind = SvIV(*indsvp);
7047 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7048 rop->op_type = OP_RV2AV;
7049 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7050 o->op_type = OP_AELEM;
7051 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7053 if (SvREADONLY(*svp))
7055 SvFLAGS(sv) |= (SvFLAGS(*svp)
7056 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7066 SV **svp, **indsvp, *sv;
7070 SVOP *first_key_op, *key_op;
7072 o->op_seq = PL_op_seqmax++;
7073 if ((o->op_private & (OPpLVAL_INTRO))
7074 /* I bet there's always a pushmark... */
7075 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7076 /* hmmm, no optimization if list contains only one key. */
7078 rop = (UNOP*)((LISTOP*)o)->op_last;
7079 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7081 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7082 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7084 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7085 if (!fields || !GvHV(*fields))
7087 /* Again guessing that the pushmark can be jumped over.... */
7088 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7089 ->op_first->op_sibling;
7090 /* Check that the key list contains only constants. */
7091 for (key_op = first_key_op; key_op;
7092 key_op = (SVOP*)key_op->op_sibling)
7093 if (key_op->op_type != OP_CONST)
7097 rop->op_type = OP_RV2AV;
7098 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7099 o->op_type = OP_ASLICE;
7100 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7101 for (key_op = first_key_op; key_op;
7102 key_op = (SVOP*)key_op->op_sibling) {
7103 svp = cSVOPx_svp(key_op);
7104 key = SvPV(*svp, keylen);
7105 indsvp = hv_fetch(GvHV(*fields), key,
7106 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7108 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7109 "in variable %s of type %s",
7110 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7112 ind = SvIV(*indsvp);
7114 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7116 if (SvREADONLY(*svp))
7118 SvFLAGS(sv) |= (SvFLAGS(*svp)
7119 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7127 o->op_seq = PL_op_seqmax++;
7137 char* Perl_custom_op_name(pTHX_ OP* o)
7139 IV index = PTR2IV(o->op_ppaddr);
7143 if (!PL_custom_op_names) /* This probably shouldn't happen */
7144 return PL_op_name[OP_CUSTOM];
7146 keysv = sv_2mortal(newSViv(index));
7148 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7150 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7152 return SvPV_nolen(HeVAL(he));
7155 char* Perl_custom_op_desc(pTHX_ OP* o)
7157 IV index = PTR2IV(o->op_ppaddr);
7161 if (!PL_custom_op_descs)
7162 return PL_op_desc[OP_CUSTOM];
7164 keysv = sv_2mortal(newSViv(index));
7166 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7168 return PL_op_desc[OP_CUSTOM];
7170 return SvPV_nolen(HeVAL(he));
7176 /* Efficient sub that returns a constant scalar value. */
7178 const_sv_xsub(pTHX_ CV* cv)
7183 Perl_croak(aTHX_ "usage: %s::%s()",
7184 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7188 ST(0) = (SV*)XSANY.any_ptr;