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 ((PADOFFSET)cPMOPo->op_pmreplroot) {
818 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
819 pad_swipe((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:%ld",
1435 (long)kid->op_type,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:%ld",
1466 (long)kid->op_type,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:%ld",
1479 (long)kid->op_type,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 OP* retval = scalarseq(seq);
2160 PL_pad_reset_pending = FALSE;
2161 PL_compiling.op_private = PL_hints;
2163 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2164 pad_leavemy(PL_comppad_name_fill);
2172 #ifdef USE_5005THREADS
2173 OP *o = newOP(OP_THREADSV, 0);
2174 o->op_targ = find_threadsv("_");
2177 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2178 #endif /* USE_5005THREADS */
2182 Perl_newPROG(pTHX_ OP *o)
2187 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2188 ((PL_in_eval & EVAL_KEEPERR)
2189 ? OPf_SPECIAL : 0), o);
2190 PL_eval_start = linklist(PL_eval_root);
2191 PL_eval_root->op_private |= OPpREFCOUNTED;
2192 OpREFCNT_set(PL_eval_root, 1);
2193 PL_eval_root->op_next = 0;
2194 CALL_PEEP(PL_eval_start);
2199 PL_main_root = scope(sawparens(scalarvoid(o)));
2200 PL_curcop = &PL_compiling;
2201 PL_main_start = LINKLIST(PL_main_root);
2202 PL_main_root->op_private |= OPpREFCOUNTED;
2203 OpREFCNT_set(PL_main_root, 1);
2204 PL_main_root->op_next = 0;
2205 CALL_PEEP(PL_main_start);
2208 /* Register with debugger */
2210 CV *cv = get_cv("DB::postponed", FALSE);
2214 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2216 call_sv((SV*)cv, G_DISCARD);
2223 Perl_localize(pTHX_ OP *o, I32 lex)
2225 if (o->op_flags & OPf_PARENS)
2228 if (ckWARN(WARN_PARENTHESIS)
2229 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2231 char *s = PL_bufptr;
2233 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2236 if (*s == ';' || *s == '=')
2237 Perl_warner(aTHX_ WARN_PARENTHESIS,
2238 "Parentheses missing around \"%s\" list",
2239 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2245 o = mod(o, OP_NULL); /* a bit kludgey */
2247 PL_in_my_stash = Nullhv;
2252 Perl_jmaybe(pTHX_ OP *o)
2254 if (o->op_type == OP_LIST) {
2256 #ifdef USE_5005THREADS
2257 o2 = newOP(OP_THREADSV, 0);
2258 o2->op_targ = find_threadsv(";");
2260 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2261 #endif /* USE_5005THREADS */
2262 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2268 Perl_fold_constants(pTHX_ register OP *o)
2271 I32 type = o->op_type;
2274 if (PL_opargs[type] & OA_RETSCALAR)
2276 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2277 o->op_targ = pad_alloc(type, SVs_PADTMP);
2279 /* integerize op, unless it happens to be C<-foo>.
2280 * XXX should pp_i_negate() do magic string negation instead? */
2281 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2282 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2283 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2285 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2288 if (!(PL_opargs[type] & OA_FOLDCONST))
2293 /* XXX might want a ck_negate() for this */
2294 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2306 /* XXX what about the numeric ops? */
2307 if (PL_hints & HINT_LOCALE)
2312 goto nope; /* Don't try to run w/ errors */
2314 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2315 if ((curop->op_type != OP_CONST ||
2316 (curop->op_private & OPpCONST_BARE)) &&
2317 curop->op_type != OP_LIST &&
2318 curop->op_type != OP_SCALAR &&
2319 curop->op_type != OP_NULL &&
2320 curop->op_type != OP_PUSHMARK)
2326 curop = LINKLIST(o);
2330 sv = *(PL_stack_sp--);
2331 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2332 pad_swipe(o->op_targ);
2333 else if (SvTEMP(sv)) { /* grab mortal temp? */
2334 (void)SvREFCNT_inc(sv);
2338 if (type == OP_RV2GV)
2339 return newGVOP(OP_GV, 0, (GV*)sv);
2341 /* try to smush double to int, but don't smush -2.0 to -2 */
2342 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2345 #ifdef PERL_PRESERVE_IVUV
2346 /* Only bother to attempt to fold to IV if
2347 most operators will benefit */
2351 return newSVOP(OP_CONST, 0, sv);
2355 if (!(PL_opargs[type] & OA_OTHERINT))
2358 if (!(PL_hints & HINT_INTEGER)) {
2359 if (type == OP_MODULO
2360 || type == OP_DIVIDE
2361 || !(o->op_flags & OPf_KIDS))
2366 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2367 if (curop->op_type == OP_CONST) {
2368 if (SvIOK(((SVOP*)curop)->op_sv))
2372 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2376 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2383 Perl_gen_constant_list(pTHX_ register OP *o)
2386 I32 oldtmps_floor = PL_tmps_floor;
2390 return o; /* Don't attempt to run with errors */
2392 PL_op = curop = LINKLIST(o);
2399 PL_tmps_floor = oldtmps_floor;
2401 o->op_type = OP_RV2AV;
2402 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2403 curop = ((UNOP*)o)->op_first;
2404 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2411 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2413 if (!o || o->op_type != OP_LIST)
2414 o = newLISTOP(OP_LIST, 0, o, Nullop);
2416 o->op_flags &= ~OPf_WANT;
2418 if (!(PL_opargs[type] & OA_MARK))
2419 op_null(cLISTOPo->op_first);
2422 o->op_ppaddr = PL_ppaddr[type];
2423 o->op_flags |= flags;
2425 o = CHECKOP(type, o);
2426 if (o->op_type != type)
2429 return fold_constants(o);
2432 /* List constructors */
2435 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2443 if (first->op_type != type
2444 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2446 return newLISTOP(type, 0, first, last);
2449 if (first->op_flags & OPf_KIDS)
2450 ((LISTOP*)first)->op_last->op_sibling = last;
2452 first->op_flags |= OPf_KIDS;
2453 ((LISTOP*)first)->op_first = last;
2455 ((LISTOP*)first)->op_last = last;
2460 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2468 if (first->op_type != type)
2469 return prepend_elem(type, (OP*)first, (OP*)last);
2471 if (last->op_type != type)
2472 return append_elem(type, (OP*)first, (OP*)last);
2474 first->op_last->op_sibling = last->op_first;
2475 first->op_last = last->op_last;
2476 first->op_flags |= (last->op_flags & OPf_KIDS);
2478 #ifdef PL_OP_SLAB_ALLOC
2486 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2494 if (last->op_type == type) {
2495 if (type == OP_LIST) { /* already a PUSHMARK there */
2496 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2497 ((LISTOP*)last)->op_first->op_sibling = first;
2498 if (!(first->op_flags & OPf_PARENS))
2499 last->op_flags &= ~OPf_PARENS;
2502 if (!(last->op_flags & OPf_KIDS)) {
2503 ((LISTOP*)last)->op_last = first;
2504 last->op_flags |= OPf_KIDS;
2506 first->op_sibling = ((LISTOP*)last)->op_first;
2507 ((LISTOP*)last)->op_first = first;
2509 last->op_flags |= OPf_KIDS;
2513 return newLISTOP(type, 0, first, last);
2519 Perl_newNULLLIST(pTHX)
2521 return newOP(OP_STUB, 0);
2525 Perl_force_list(pTHX_ OP *o)
2527 if (!o || o->op_type != OP_LIST)
2528 o = newLISTOP(OP_LIST, 0, o, Nullop);
2534 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2538 NewOp(1101, listop, 1, LISTOP);
2540 listop->op_type = type;
2541 listop->op_ppaddr = PL_ppaddr[type];
2544 listop->op_flags = flags;
2548 else if (!first && last)
2551 first->op_sibling = last;
2552 listop->op_first = first;
2553 listop->op_last = last;
2554 if (type == OP_LIST) {
2556 pushop = newOP(OP_PUSHMARK, 0);
2557 pushop->op_sibling = first;
2558 listop->op_first = pushop;
2559 listop->op_flags |= OPf_KIDS;
2561 listop->op_last = pushop;
2568 Perl_newOP(pTHX_ I32 type, I32 flags)
2571 NewOp(1101, o, 1, OP);
2573 o->op_ppaddr = PL_ppaddr[type];
2574 o->op_flags = flags;
2577 o->op_private = 0 + (flags >> 8);
2578 if (PL_opargs[type] & OA_RETSCALAR)
2580 if (PL_opargs[type] & OA_TARGET)
2581 o->op_targ = pad_alloc(type, SVs_PADTMP);
2582 return CHECKOP(type, o);
2586 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2591 first = newOP(OP_STUB, 0);
2592 if (PL_opargs[type] & OA_MARK)
2593 first = force_list(first);
2595 NewOp(1101, unop, 1, UNOP);
2596 unop->op_type = type;
2597 unop->op_ppaddr = PL_ppaddr[type];
2598 unop->op_first = first;
2599 unop->op_flags = flags | OPf_KIDS;
2600 unop->op_private = 1 | (flags >> 8);
2601 unop = (UNOP*) CHECKOP(type, unop);
2605 return fold_constants((OP *) unop);
2609 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2612 NewOp(1101, binop, 1, BINOP);
2615 first = newOP(OP_NULL, 0);
2617 binop->op_type = type;
2618 binop->op_ppaddr = PL_ppaddr[type];
2619 binop->op_first = first;
2620 binop->op_flags = flags | OPf_KIDS;
2623 binop->op_private = 1 | (flags >> 8);
2626 binop->op_private = 2 | (flags >> 8);
2627 first->op_sibling = last;
2630 binop = (BINOP*)CHECKOP(type, binop);
2631 if (binop->op_next || binop->op_type != type)
2634 binop->op_last = binop->op_first->op_sibling;
2636 return fold_constants((OP *)binop);
2640 uvcompare(const void *a, const void *b)
2642 if (*((UV *)a) < (*(UV *)b))
2644 if (*((UV *)a) > (*(UV *)b))
2646 if (*((UV *)a+1) < (*(UV *)b+1))
2648 if (*((UV *)a+1) > (*(UV *)b+1))
2654 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2656 SV *tstr = ((SVOP*)expr)->op_sv;
2657 SV *rstr = ((SVOP*)repl)->op_sv;
2660 U8 *t = (U8*)SvPV(tstr, tlen);
2661 U8 *r = (U8*)SvPV(rstr, rlen);
2668 register short *tbl;
2670 PL_hints |= HINT_BLOCK_SCOPE;
2671 complement = o->op_private & OPpTRANS_COMPLEMENT;
2672 del = o->op_private & OPpTRANS_DELETE;
2673 squash = o->op_private & OPpTRANS_SQUASH;
2676 o->op_private |= OPpTRANS_FROM_UTF;
2679 o->op_private |= OPpTRANS_TO_UTF;
2681 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2682 SV* listsv = newSVpvn("# comment\n",10);
2684 U8* tend = t + tlen;
2685 U8* rend = r + rlen;
2699 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2700 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2706 tsave = t = bytes_to_utf8(t, &len);
2709 if (!to_utf && rlen) {
2711 rsave = r = bytes_to_utf8(r, &len);
2715 /* There are several snags with this code on EBCDIC:
2716 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2717 2. scan_const() in toke.c has encoded chars in native encoding which makes
2718 ranges at least in EBCDIC 0..255 range the bottom odd.
2722 U8 tmpbuf[UTF8_MAXLEN+1];
2725 New(1109, cp, 2*tlen, UV);
2727 transv = newSVpvn("",0);
2729 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2731 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2733 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2737 cp[2*i+1] = cp[2*i];
2741 qsort(cp, i, 2*sizeof(UV), uvcompare);
2742 for (j = 0; j < i; j++) {
2744 diff = val - nextmin;
2746 t = uvuni_to_utf8(tmpbuf,nextmin);
2747 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2749 U8 range_mark = UTF_TO_NATIVE(0xff);
2750 t = uvuni_to_utf8(tmpbuf, val - 1);
2751 sv_catpvn(transv, (char *)&range_mark, 1);
2752 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2759 t = uvuni_to_utf8(tmpbuf,nextmin);
2760 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2762 U8 range_mark = UTF_TO_NATIVE(0xff);
2763 sv_catpvn(transv, (char *)&range_mark, 1);
2765 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2766 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2767 t = (U8*)SvPVX(transv);
2768 tlen = SvCUR(transv);
2772 else if (!rlen && !del) {
2773 r = t; rlen = tlen; rend = tend;
2776 if ((!rlen && !del) || t == r ||
2777 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2779 o->op_private |= OPpTRANS_IDENTICAL;
2783 while (t < tend || tfirst <= tlast) {
2784 /* see if we need more "t" chars */
2785 if (tfirst > tlast) {
2786 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2788 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2790 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2797 /* now see if we need more "r" chars */
2798 if (rfirst > rlast) {
2800 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2802 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2804 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2813 rfirst = rlast = 0xffffffff;
2817 /* now see which range will peter our first, if either. */
2818 tdiff = tlast - tfirst;
2819 rdiff = rlast - rfirst;
2826 if (rfirst == 0xffffffff) {
2827 diff = tdiff; /* oops, pretend rdiff is infinite */
2829 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2830 (long)tfirst, (long)tlast);
2832 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2836 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2837 (long)tfirst, (long)(tfirst + diff),
2840 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2841 (long)tfirst, (long)rfirst);
2843 if (rfirst + diff > max)
2844 max = rfirst + diff;
2846 grows = (tfirst < rfirst &&
2847 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2859 else if (max > 0xff)
2864 Safefree(cPVOPo->op_pv);
2865 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2866 SvREFCNT_dec(listsv);
2868 SvREFCNT_dec(transv);
2870 if (!del && havefinal && rlen)
2871 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2872 newSVuv((UV)final), 0);
2875 o->op_private |= OPpTRANS_GROWS;
2887 tbl = (short*)cPVOPo->op_pv;
2889 Zero(tbl, 256, short);
2890 for (i = 0; i < tlen; i++)
2892 for (i = 0, j = 0; i < 256; i++) {
2903 if (i < 128 && r[j] >= 128)
2913 o->op_private |= OPpTRANS_IDENTICAL;
2918 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2919 tbl[0x100] = rlen - j;
2920 for (i=0; i < rlen - j; i++)
2921 tbl[0x101+i] = r[j+i];
2925 if (!rlen && !del) {
2928 o->op_private |= OPpTRANS_IDENTICAL;
2930 for (i = 0; i < 256; i++)
2932 for (i = 0, j = 0; i < tlen; i++,j++) {
2935 if (tbl[t[i]] == -1)
2941 if (tbl[t[i]] == -1) {
2942 if (t[i] < 128 && r[j] >= 128)
2949 o->op_private |= OPpTRANS_GROWS;
2957 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2961 NewOp(1101, pmop, 1, PMOP);
2962 pmop->op_type = type;
2963 pmop->op_ppaddr = PL_ppaddr[type];
2964 pmop->op_flags = flags;
2965 pmop->op_private = 0 | (flags >> 8);
2967 if (PL_hints & HINT_RE_TAINT)
2968 pmop->op_pmpermflags |= PMf_RETAINT;
2969 if (PL_hints & HINT_LOCALE)
2970 pmop->op_pmpermflags |= PMf_LOCALE;
2971 pmop->op_pmflags = pmop->op_pmpermflags;
2976 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2977 repointer = av_pop((AV*)PL_regex_pad[0]);
2978 pmop->op_pmoffset = SvIV(repointer);
2979 SvREPADTMP_off(repointer);
2980 sv_setiv(repointer,0);
2982 repointer = newSViv(0);
2983 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2984 pmop->op_pmoffset = av_len(PL_regex_padav);
2985 PL_regex_pad = AvARRAY(PL_regex_padav);
2990 /* link into pm list */
2991 if (type != OP_TRANS && PL_curstash) {
2992 pmop->op_pmnext = HvPMROOT(PL_curstash);
2993 HvPMROOT(PL_curstash) = pmop;
2994 PmopSTASH_set(pmop,PL_curstash);
3001 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3005 I32 repl_has_vars = 0;
3007 if (o->op_type == OP_TRANS)
3008 return pmtrans(o, expr, repl);
3010 PL_hints |= HINT_BLOCK_SCOPE;
3013 if (expr->op_type == OP_CONST) {
3015 SV *pat = ((SVOP*)expr)->op_sv;
3016 char *p = SvPV(pat, plen);
3017 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3018 sv_setpvn(pat, "\\s+", 3);
3019 p = SvPV(pat, plen);
3020 pm->op_pmflags |= PMf_SKIPWHITE;
3022 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3023 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3024 pm->op_pmflags |= PMf_WHITE;
3028 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3029 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3031 : OP_REGCMAYBE),0,expr);
3033 NewOp(1101, rcop, 1, LOGOP);
3034 rcop->op_type = OP_REGCOMP;
3035 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3036 rcop->op_first = scalar(expr);
3037 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3038 ? (OPf_SPECIAL | OPf_KIDS)
3040 rcop->op_private = 1;
3043 /* establish postfix order */
3044 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3046 rcop->op_next = expr;
3047 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3050 rcop->op_next = LINKLIST(expr);
3051 expr->op_next = (OP*)rcop;
3054 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3059 if (pm->op_pmflags & PMf_EVAL) {
3061 if (CopLINE(PL_curcop) < PL_multi_end)
3062 CopLINE_set(PL_curcop, PL_multi_end);
3064 #ifdef USE_5005THREADS
3065 else if (repl->op_type == OP_THREADSV
3066 && strchr("&`'123456789+",
3067 PL_threadsv_names[repl->op_targ]))
3071 #endif /* USE_5005THREADS */
3072 else if (repl->op_type == OP_CONST)
3076 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3077 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3078 #ifdef USE_5005THREADS
3079 if (curop->op_type == OP_THREADSV) {
3081 if (strchr("&`'123456789+", curop->op_private))
3085 if (curop->op_type == OP_GV) {
3086 GV *gv = cGVOPx_gv(curop);
3088 if (strchr("&`'123456789+", *GvENAME(gv)))
3091 #endif /* USE_5005THREADS */
3092 else if (curop->op_type == OP_RV2CV)
3094 else if (curop->op_type == OP_RV2SV ||
3095 curop->op_type == OP_RV2AV ||
3096 curop->op_type == OP_RV2HV ||
3097 curop->op_type == OP_RV2GV) {
3098 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3101 else if (curop->op_type == OP_PADSV ||
3102 curop->op_type == OP_PADAV ||
3103 curop->op_type == OP_PADHV ||
3104 curop->op_type == OP_PADANY) {
3107 else if (curop->op_type == OP_PUSHRE)
3108 ; /* Okay here, dangerous in newASSIGNOP */
3118 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3119 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3120 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3121 prepend_elem(o->op_type, scalar(repl), o);
3124 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3125 pm->op_pmflags |= PMf_MAYBE_CONST;
3126 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3128 NewOp(1101, rcop, 1, LOGOP);
3129 rcop->op_type = OP_SUBSTCONT;
3130 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3131 rcop->op_first = scalar(repl);
3132 rcop->op_flags |= OPf_KIDS;
3133 rcop->op_private = 1;
3136 /* establish postfix order */
3137 rcop->op_next = LINKLIST(repl);
3138 repl->op_next = (OP*)rcop;
3140 pm->op_pmreplroot = scalar((OP*)rcop);
3141 pm->op_pmreplstart = LINKLIST(rcop);
3150 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3153 NewOp(1101, svop, 1, SVOP);
3154 svop->op_type = type;
3155 svop->op_ppaddr = PL_ppaddr[type];
3157 svop->op_next = (OP*)svop;
3158 svop->op_flags = flags;
3159 if (PL_opargs[type] & OA_RETSCALAR)
3161 if (PL_opargs[type] & OA_TARGET)
3162 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3163 return CHECKOP(type, svop);
3167 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3170 NewOp(1101, padop, 1, PADOP);
3171 padop->op_type = type;
3172 padop->op_ppaddr = PL_ppaddr[type];
3173 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3174 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3175 PL_curpad[padop->op_padix] = sv;
3177 padop->op_next = (OP*)padop;
3178 padop->op_flags = flags;
3179 if (PL_opargs[type] & OA_RETSCALAR)
3181 if (PL_opargs[type] & OA_TARGET)
3182 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3183 return CHECKOP(type, padop);
3187 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3191 return newPADOP(type, flags, SvREFCNT_inc(gv));
3193 return newSVOP(type, flags, SvREFCNT_inc(gv));
3198 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3201 NewOp(1101, pvop, 1, PVOP);
3202 pvop->op_type = type;
3203 pvop->op_ppaddr = PL_ppaddr[type];
3205 pvop->op_next = (OP*)pvop;
3206 pvop->op_flags = flags;
3207 if (PL_opargs[type] & OA_RETSCALAR)
3209 if (PL_opargs[type] & OA_TARGET)
3210 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3211 return CHECKOP(type, pvop);
3215 Perl_package(pTHX_ OP *o)
3219 save_hptr(&PL_curstash);
3220 save_item(PL_curstname);
3225 name = SvPV(sv, len);
3226 PL_curstash = gv_stashpvn(name,len,TRUE);
3227 sv_setpvn(PL_curstname, name, len);
3231 deprecate("\"package\" with no arguments");
3232 sv_setpv(PL_curstname,"<none>");
3233 PL_curstash = Nullhv;
3235 PL_hints |= HINT_BLOCK_SCOPE;
3236 PL_copline = NOLINE;
3241 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3246 char *packname = Nullch;
3250 if (id->op_type != OP_CONST)
3251 Perl_croak(aTHX_ "Module name must be constant");
3255 if (version != Nullop) {
3256 SV *vesv = ((SVOP*)version)->op_sv;
3258 if (arg == Nullop && !SvNIOKp(vesv)) {
3265 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3266 Perl_croak(aTHX_ "Version number must be constant number");
3268 /* Make copy of id so we don't free it twice */
3269 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3271 /* Fake up a method call to VERSION */
3272 meth = newSVpvn("VERSION",7);
3273 sv_upgrade(meth, SVt_PVIV);
3274 (void)SvIOK_on(meth);
3275 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3276 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3277 append_elem(OP_LIST,
3278 prepend_elem(OP_LIST, pack, list(version)),
3279 newSVOP(OP_METHOD_NAMED, 0, meth)));
3283 /* Fake up an import/unimport */
3284 if (arg && arg->op_type == OP_STUB)
3285 imop = arg; /* no import on explicit () */
3286 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3287 imop = Nullop; /* use 5.0; */
3292 /* Make copy of id so we don't free it twice */
3293 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3295 /* Fake up a method call to import/unimport */
3296 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3297 sv_upgrade(meth, SVt_PVIV);
3298 (void)SvIOK_on(meth);
3299 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3300 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3301 append_elem(OP_LIST,
3302 prepend_elem(OP_LIST, pack, list(arg)),
3303 newSVOP(OP_METHOD_NAMED, 0, meth)));
3306 if (ckWARN(WARN_MISC) &&
3307 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3308 SvPOK(packsv = ((SVOP*)id)->op_sv))
3310 /* BEGIN will free the ops, so we need to make a copy */
3311 packlen = SvCUR(packsv);
3312 packname = savepvn(SvPVX(packsv), packlen);
3315 /* Fake up the BEGIN {}, which does its thing immediately. */
3317 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3320 append_elem(OP_LINESEQ,
3321 append_elem(OP_LINESEQ,
3322 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3323 newSTATEOP(0, Nullch, veop)),
3324 newSTATEOP(0, Nullch, imop) ));
3327 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3328 Perl_warner(aTHX_ WARN_MISC,
3329 "Package `%s' not found "
3330 "(did you use the incorrect case?)", packname);
3335 PL_hints |= HINT_BLOCK_SCOPE;
3336 PL_copline = NOLINE;
3341 =for apidoc load_module
3343 Loads the module whose name is pointed to by the string part of name.
3344 Note that the actual module name, not its filename, should be given.
3345 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3346 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3347 (or 0 for no flags). ver, if specified, provides version semantics
3348 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3349 arguments can be used to specify arguments to the module's import()
3350 method, similar to C<use Foo::Bar VERSION LIST>.
3355 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3358 va_start(args, ver);
3359 vload_module(flags, name, ver, &args);
3363 #ifdef PERL_IMPLICIT_CONTEXT
3365 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3369 va_start(args, ver);
3370 vload_module(flags, name, ver, &args);
3376 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3378 OP *modname, *veop, *imop;
3380 modname = newSVOP(OP_CONST, 0, name);
3381 modname->op_private |= OPpCONST_BARE;
3383 veop = newSVOP(OP_CONST, 0, ver);
3387 if (flags & PERL_LOADMOD_NOIMPORT) {
3388 imop = sawparens(newNULLLIST());
3390 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3391 imop = va_arg(*args, OP*);
3396 sv = va_arg(*args, SV*);
3398 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3399 sv = va_arg(*args, SV*);
3403 line_t ocopline = PL_copline;
3404 int oexpect = PL_expect;
3406 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3407 veop, modname, imop);
3408 PL_expect = oexpect;
3409 PL_copline = ocopline;
3414 Perl_dofile(pTHX_ OP *term)
3419 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3420 if (!(gv && GvIMPORTED_CV(gv)))
3421 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3423 if (gv && GvIMPORTED_CV(gv)) {
3424 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3425 append_elem(OP_LIST, term,
3426 scalar(newUNOP(OP_RV2CV, 0,
3431 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3437 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3439 return newBINOP(OP_LSLICE, flags,
3440 list(force_list(subscript)),
3441 list(force_list(listval)) );
3445 S_list_assignment(pTHX_ register OP *o)
3450 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3451 o = cUNOPo->op_first;
3453 if (o->op_type == OP_COND_EXPR) {
3454 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3455 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3460 yyerror("Assignment to both a list and a scalar");
3464 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3465 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3466 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3469 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3472 if (o->op_type == OP_RV2SV)
3479 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3484 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3485 return newLOGOP(optype, 0,
3486 mod(scalar(left), optype),
3487 newUNOP(OP_SASSIGN, 0, scalar(right)));
3490 return newBINOP(optype, OPf_STACKED,
3491 mod(scalar(left), optype), scalar(right));
3495 if (list_assignment(left)) {
3499 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3500 left = mod(left, OP_AASSIGN);
3508 curop = list(force_list(left));
3509 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3510 o->op_private = 0 | (flags >> 8);
3511 for (curop = ((LISTOP*)curop)->op_first;
3512 curop; curop = curop->op_sibling)
3514 if (curop->op_type == OP_RV2HV &&
3515 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3516 o->op_private |= OPpASSIGN_HASH;
3520 if (!(left->op_private & OPpLVAL_INTRO)) {
3523 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3524 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3525 if (curop->op_type == OP_GV) {
3526 GV *gv = cGVOPx_gv(curop);
3527 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3529 SvCUR(gv) = PL_generation;
3531 else if (curop->op_type == OP_PADSV ||
3532 curop->op_type == OP_PADAV ||
3533 curop->op_type == OP_PADHV ||
3534 curop->op_type == OP_PADANY) {
3535 SV **svp = AvARRAY(PL_comppad_name);
3536 SV *sv = svp[curop->op_targ];
3537 if (SvCUR(sv) == PL_generation)
3539 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3541 else if (curop->op_type == OP_RV2CV)
3543 else if (curop->op_type == OP_RV2SV ||
3544 curop->op_type == OP_RV2AV ||
3545 curop->op_type == OP_RV2HV ||
3546 curop->op_type == OP_RV2GV) {
3547 if (lastop->op_type != OP_GV) /* funny deref? */
3550 else if (curop->op_type == OP_PUSHRE) {
3551 if (((PMOP*)curop)->op_pmreplroot) {
3553 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3555 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3557 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3559 SvCUR(gv) = PL_generation;
3568 o->op_private |= OPpASSIGN_COMMON;
3570 if (right && right->op_type == OP_SPLIT) {
3572 if ((tmpop = ((LISTOP*)right)->op_first) &&
3573 tmpop->op_type == OP_PUSHRE)
3575 PMOP *pm = (PMOP*)tmpop;
3576 if (left->op_type == OP_RV2AV &&
3577 !(left->op_private & OPpLVAL_INTRO) &&
3578 !(o->op_private & OPpASSIGN_COMMON) )
3580 tmpop = ((UNOP*)left)->op_first;
3581 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3583 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3584 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3586 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3587 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3589 pm->op_pmflags |= PMf_ONCE;
3590 tmpop = cUNOPo->op_first; /* to list (nulled) */
3591 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3592 tmpop->op_sibling = Nullop; /* don't free split */
3593 right->op_next = tmpop->op_next; /* fix starting loc */
3594 op_free(o); /* blow off assign */
3595 right->op_flags &= ~OPf_WANT;
3596 /* "I don't know and I don't care." */
3601 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3602 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3604 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3606 sv_setiv(sv, PL_modcount+1);
3614 right = newOP(OP_UNDEF, 0);
3615 if (right->op_type == OP_READLINE) {
3616 right->op_flags |= OPf_STACKED;
3617 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3620 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3621 o = newBINOP(OP_SASSIGN, flags,
3622 scalar(right), mod(scalar(left), OP_SASSIGN) );
3634 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3636 U32 seq = intro_my();
3639 NewOp(1101, cop, 1, COP);
3640 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3641 cop->op_type = OP_DBSTATE;
3642 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3645 cop->op_type = OP_NEXTSTATE;
3646 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3648 cop->op_flags = flags;
3649 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3651 cop->op_private |= NATIVE_HINTS;
3653 PL_compiling.op_private = cop->op_private;
3654 cop->op_next = (OP*)cop;
3657 cop->cop_label = label;
3658 PL_hints |= HINT_BLOCK_SCOPE;
3661 cop->cop_arybase = PL_curcop->cop_arybase;
3662 if (specialWARN(PL_curcop->cop_warnings))
3663 cop->cop_warnings = PL_curcop->cop_warnings ;
3665 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3666 if (specialCopIO(PL_curcop->cop_io))
3667 cop->cop_io = PL_curcop->cop_io;
3669 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3672 if (PL_copline == NOLINE)
3673 CopLINE_set(cop, CopLINE(PL_curcop));
3675 CopLINE_set(cop, PL_copline);
3676 PL_copline = NOLINE;
3679 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3681 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3683 CopSTASH_set(cop, PL_curstash);
3685 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3686 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3687 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3688 (void)SvIOK_on(*svp);
3689 SvIVX(*svp) = PTR2IV(cop);
3693 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3696 /* "Introduce" my variables to visible status. */
3704 if (! PL_min_intro_pending)
3705 return PL_cop_seqmax;
3707 svp = AvARRAY(PL_comppad_name);
3708 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3709 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3710 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3711 SvNVX(sv) = (NV)PL_cop_seqmax;
3714 PL_min_intro_pending = 0;
3715 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3716 return PL_cop_seqmax++;
3720 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3722 return new_logop(type, flags, &first, &other);
3726 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3730 OP *first = *firstp;
3731 OP *other = *otherp;
3733 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3734 return newBINOP(type, flags, scalar(first), scalar(other));
3736 scalarboolean(first);
3737 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3738 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3739 if (type == OP_AND || type == OP_OR) {
3745 first = *firstp = cUNOPo->op_first;
3747 first->op_next = o->op_next;
3748 cUNOPo->op_first = Nullop;
3752 if (first->op_type == OP_CONST) {
3753 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3754 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3755 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3766 else if (first->op_type == OP_WANTARRAY) {
3772 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3773 OP *k1 = ((UNOP*)first)->op_first;
3774 OP *k2 = k1->op_sibling;
3776 switch (first->op_type)
3779 if (k2 && k2->op_type == OP_READLINE
3780 && (k2->op_flags & OPf_STACKED)
3781 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3783 warnop = k2->op_type;
3788 if (k1->op_type == OP_READDIR
3789 || k1->op_type == OP_GLOB
3790 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3791 || k1->op_type == OP_EACH)
3793 warnop = ((k1->op_type == OP_NULL)
3794 ? k1->op_targ : k1->op_type);
3799 line_t oldline = CopLINE(PL_curcop);
3800 CopLINE_set(PL_curcop, PL_copline);
3801 Perl_warner(aTHX_ WARN_MISC,
3802 "Value of %s%s can be \"0\"; test with defined()",
3804 ((warnop == OP_READLINE || warnop == OP_GLOB)
3805 ? " construct" : "() operator"));
3806 CopLINE_set(PL_curcop, oldline);
3813 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3814 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3816 NewOp(1101, logop, 1, LOGOP);
3818 logop->op_type = type;
3819 logop->op_ppaddr = PL_ppaddr[type];
3820 logop->op_first = first;
3821 logop->op_flags = flags | OPf_KIDS;
3822 logop->op_other = LINKLIST(other);
3823 logop->op_private = 1 | (flags >> 8);
3825 /* establish postfix order */
3826 logop->op_next = LINKLIST(first);
3827 first->op_next = (OP*)logop;
3828 first->op_sibling = other;
3830 o = newUNOP(OP_NULL, 0, (OP*)logop);
3837 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3844 return newLOGOP(OP_AND, 0, first, trueop);
3846 return newLOGOP(OP_OR, 0, first, falseop);
3848 scalarboolean(first);
3849 if (first->op_type == OP_CONST) {
3850 if (SvTRUE(((SVOP*)first)->op_sv)) {
3861 else if (first->op_type == OP_WANTARRAY) {
3865 NewOp(1101, logop, 1, LOGOP);
3866 logop->op_type = OP_COND_EXPR;
3867 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3868 logop->op_first = first;
3869 logop->op_flags = flags | OPf_KIDS;
3870 logop->op_private = 1 | (flags >> 8);
3871 logop->op_other = LINKLIST(trueop);
3872 logop->op_next = LINKLIST(falseop);
3875 /* establish postfix order */
3876 start = LINKLIST(first);
3877 first->op_next = (OP*)logop;
3879 first->op_sibling = trueop;
3880 trueop->op_sibling = falseop;
3881 o = newUNOP(OP_NULL, 0, (OP*)logop);
3883 trueop->op_next = falseop->op_next = o;
3890 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3898 NewOp(1101, range, 1, LOGOP);
3900 range->op_type = OP_RANGE;
3901 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3902 range->op_first = left;
3903 range->op_flags = OPf_KIDS;
3904 leftstart = LINKLIST(left);
3905 range->op_other = LINKLIST(right);
3906 range->op_private = 1 | (flags >> 8);
3908 left->op_sibling = right;
3910 range->op_next = (OP*)range;
3911 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3912 flop = newUNOP(OP_FLOP, 0, flip);
3913 o = newUNOP(OP_NULL, 0, flop);
3915 range->op_next = leftstart;
3917 left->op_next = flip;
3918 right->op_next = flop;
3920 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3921 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3922 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3923 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3925 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3926 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3929 if (!flip->op_private || !flop->op_private)
3930 linklist(o); /* blow off optimizer unless constant */
3936 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3940 int once = block && block->op_flags & OPf_SPECIAL &&
3941 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3944 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3945 return block; /* do {} while 0 does once */
3946 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3947 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3948 expr = newUNOP(OP_DEFINED, 0,
3949 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3950 } else if (expr->op_flags & OPf_KIDS) {
3951 OP *k1 = ((UNOP*)expr)->op_first;
3952 OP *k2 = (k1) ? k1->op_sibling : NULL;
3953 switch (expr->op_type) {
3955 if (k2 && k2->op_type == OP_READLINE
3956 && (k2->op_flags & OPf_STACKED)
3957 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3958 expr = newUNOP(OP_DEFINED, 0, expr);
3962 if (k1->op_type == OP_READDIR
3963 || k1->op_type == OP_GLOB
3964 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3965 || k1->op_type == OP_EACH)
3966 expr = newUNOP(OP_DEFINED, 0, expr);
3972 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3973 o = new_logop(OP_AND, 0, &expr, &listop);
3976 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3978 if (once && o != listop)
3979 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3982 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3984 o->op_flags |= flags;
3986 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3991 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3999 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4000 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4001 expr = newUNOP(OP_DEFINED, 0,
4002 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4003 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4004 OP *k1 = ((UNOP*)expr)->op_first;
4005 OP *k2 = (k1) ? k1->op_sibling : NULL;
4006 switch (expr->op_type) {
4008 if (k2 && k2->op_type == OP_READLINE
4009 && (k2->op_flags & OPf_STACKED)
4010 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4011 expr = newUNOP(OP_DEFINED, 0, expr);
4015 if (k1->op_type == OP_READDIR
4016 || k1->op_type == OP_GLOB
4017 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4018 || k1->op_type == OP_EACH)
4019 expr = newUNOP(OP_DEFINED, 0, expr);
4025 block = newOP(OP_NULL, 0);
4027 block = scope(block);
4031 next = LINKLIST(cont);
4034 OP *unstack = newOP(OP_UNSTACK, 0);
4037 cont = append_elem(OP_LINESEQ, cont, unstack);
4038 if ((line_t)whileline != NOLINE) {
4039 PL_copline = whileline;
4040 cont = append_elem(OP_LINESEQ, cont,
4041 newSTATEOP(0, Nullch, Nullop));
4045 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4046 redo = LINKLIST(listop);
4049 PL_copline = whileline;
4051 o = new_logop(OP_AND, 0, &expr, &listop);
4052 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4053 op_free(expr); /* oops, it's a while (0) */
4055 return Nullop; /* listop already freed by new_logop */
4058 ((LISTOP*)listop)->op_last->op_next =
4059 (o == listop ? redo : LINKLIST(o));
4065 NewOp(1101,loop,1,LOOP);
4066 loop->op_type = OP_ENTERLOOP;
4067 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4068 loop->op_private = 0;
4069 loop->op_next = (OP*)loop;
4072 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4074 loop->op_redoop = redo;
4075 loop->op_lastop = o;
4076 o->op_private |= loopflags;
4079 loop->op_nextop = next;
4081 loop->op_nextop = o;
4083 o->op_flags |= flags;
4084 o->op_private |= (flags >> 8);
4089 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4097 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4098 sv->op_type = OP_RV2GV;
4099 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4101 else if (sv->op_type == OP_PADSV) { /* private variable */
4102 padoff = sv->op_targ;
4107 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4108 padoff = sv->op_targ;
4110 iterflags |= OPf_SPECIAL;
4115 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4118 #ifdef USE_5005THREADS
4119 padoff = find_threadsv("_");
4120 iterflags |= OPf_SPECIAL;
4122 sv = newGVOP(OP_GV, 0, PL_defgv);
4125 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4126 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4127 iterflags |= OPf_STACKED;
4129 else if (expr->op_type == OP_NULL &&
4130 (expr->op_flags & OPf_KIDS) &&
4131 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4133 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4134 * set the STACKED flag to indicate that these values are to be
4135 * treated as min/max values by 'pp_iterinit'.
4137 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4138 LOGOP* range = (LOGOP*) flip->op_first;
4139 OP* left = range->op_first;
4140 OP* right = left->op_sibling;
4143 range->op_flags &= ~OPf_KIDS;
4144 range->op_first = Nullop;
4146 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4147 listop->op_first->op_next = range->op_next;
4148 left->op_next = range->op_other;
4149 right->op_next = (OP*)listop;
4150 listop->op_next = listop->op_first;
4153 expr = (OP*)(listop);
4155 iterflags |= OPf_STACKED;
4158 expr = mod(force_list(expr), OP_GREPSTART);
4162 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4163 append_elem(OP_LIST, expr, scalar(sv))));
4164 assert(!loop->op_next);
4165 #ifdef PL_OP_SLAB_ALLOC
4168 NewOp(1234,tmp,1,LOOP);
4169 Copy(loop,tmp,1,LOOP);
4173 Renew(loop, 1, LOOP);
4175 loop->op_targ = padoff;
4176 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4177 PL_copline = forline;
4178 return newSTATEOP(0, label, wop);
4182 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4187 if (type != OP_GOTO || label->op_type == OP_CONST) {
4188 /* "last()" means "last" */
4189 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4190 o = newOP(type, OPf_SPECIAL);
4192 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4193 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4199 if (label->op_type == OP_ENTERSUB)
4200 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4201 o = newUNOP(type, OPf_STACKED, label);
4203 PL_hints |= HINT_BLOCK_SCOPE;
4208 Perl_cv_undef(pTHX_ CV *cv)
4210 #ifdef USE_5005THREADS
4212 MUTEX_DESTROY(CvMUTEXP(cv));
4213 Safefree(CvMUTEXP(cv));
4216 #endif /* USE_5005THREADS */
4219 if (CvFILE(cv) && !CvXSUB(cv)) {
4220 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4221 Safefree(CvFILE(cv));
4226 if (!CvXSUB(cv) && CvROOT(cv)) {
4227 #ifdef USE_5005THREADS
4228 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4229 Perl_croak(aTHX_ "Can't undef active subroutine");
4232 Perl_croak(aTHX_ "Can't undef active subroutine");
4233 #endif /* USE_5005THREADS */
4236 SAVEVPTR(PL_curpad);
4239 op_free(CvROOT(cv));
4240 CvROOT(cv) = Nullop;
4243 SvPOK_off((SV*)cv); /* forget prototype */
4245 /* Since closure prototypes have the same lifetime as the containing
4246 * CV, they don't hold a refcount on the outside CV. This avoids
4247 * the refcount loop between the outer CV (which keeps a refcount to
4248 * the closure prototype in the pad entry for pp_anoncode()) and the
4249 * closure prototype, and the ensuing memory leak. This does not
4250 * apply to closures generated within eval"", since eval"" CVs are
4251 * ephemeral. --GSAR */
4252 if (!CvANON(cv) || CvCLONED(cv)
4253 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4254 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4256 SvREFCNT_dec(CvOUTSIDE(cv));
4258 CvOUTSIDE(cv) = Nullcv;
4260 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4263 if (CvPADLIST(cv)) {
4264 /* may be during global destruction */
4265 if (SvREFCNT(CvPADLIST(cv))) {
4266 I32 i = AvFILLp(CvPADLIST(cv));
4268 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4269 SV* sv = svp ? *svp : Nullsv;
4272 if (sv == (SV*)PL_comppad_name)
4273 PL_comppad_name = Nullav;
4274 else if (sv == (SV*)PL_comppad) {
4275 PL_comppad = Nullav;
4276 PL_curpad = Null(SV**);
4280 SvREFCNT_dec((SV*)CvPADLIST(cv));
4282 CvPADLIST(cv) = Nullav;
4290 #ifdef DEBUG_CLOSURES
4292 S_cv_dump(pTHX_ CV *cv)
4295 CV *outside = CvOUTSIDE(cv);
4296 AV* padlist = CvPADLIST(cv);
4303 PerlIO_printf(Perl_debug_log,
4304 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4306 (CvANON(cv) ? "ANON"
4307 : (cv == PL_main_cv) ? "MAIN"
4308 : CvUNIQUE(cv) ? "UNIQUE"
4309 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4312 : CvANON(outside) ? "ANON"
4313 : (outside == PL_main_cv) ? "MAIN"
4314 : CvUNIQUE(outside) ? "UNIQUE"
4315 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4320 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4321 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4322 pname = AvARRAY(pad_name);
4323 ppad = AvARRAY(pad);
4325 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4326 if (SvPOK(pname[ix]))
4327 PerlIO_printf(Perl_debug_log,
4328 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4329 (int)ix, PTR2UV(ppad[ix]),
4330 SvFAKE(pname[ix]) ? "FAKE " : "",
4332 (IV)I_32(SvNVX(pname[ix])),
4335 #endif /* DEBUGGING */
4337 #endif /* DEBUG_CLOSURES */
4340 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4344 AV* protopadlist = CvPADLIST(proto);
4345 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4346 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4347 SV** pname = AvARRAY(protopad_name);
4348 SV** ppad = AvARRAY(protopad);
4349 I32 fname = AvFILLp(protopad_name);
4350 I32 fpad = AvFILLp(protopad);
4354 assert(!CvUNIQUE(proto));
4358 SAVESPTR(PL_comppad_name);
4359 SAVESPTR(PL_compcv);
4361 cv = PL_compcv = (CV*)NEWSV(1104,0);
4362 sv_upgrade((SV *)cv, SvTYPE(proto));
4363 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4366 #ifdef USE_5005THREADS
4367 New(666, CvMUTEXP(cv), 1, perl_mutex);
4368 MUTEX_INIT(CvMUTEXP(cv));
4370 #endif /* USE_5005THREADS */
4372 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4373 : savepv(CvFILE(proto));
4375 CvFILE(cv) = CvFILE(proto);
4377 CvGV(cv) = CvGV(proto);
4378 CvSTASH(cv) = CvSTASH(proto);
4379 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4380 CvSTART(cv) = CvSTART(proto);
4382 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4385 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4387 PL_comppad_name = newAV();
4388 for (ix = fname; ix >= 0; ix--)
4389 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4391 PL_comppad = newAV();
4393 comppadlist = newAV();
4394 AvREAL_off(comppadlist);
4395 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4396 av_store(comppadlist, 1, (SV*)PL_comppad);
4397 CvPADLIST(cv) = comppadlist;
4398 av_fill(PL_comppad, AvFILLp(protopad));
4399 PL_curpad = AvARRAY(PL_comppad);
4401 av = newAV(); /* will be @_ */
4403 av_store(PL_comppad, 0, (SV*)av);
4404 AvFLAGS(av) = AVf_REIFY;
4406 for (ix = fpad; ix > 0; ix--) {
4407 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4408 if (namesv && namesv != &PL_sv_undef) {
4409 char *name = SvPVX(namesv); /* XXX */
4410 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4411 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4412 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4414 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4416 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4418 else { /* our own lexical */
4421 /* anon code -- we'll come back for it */
4422 sv = SvREFCNT_inc(ppad[ix]);
4424 else if (*name == '@')
4426 else if (*name == '%')
4435 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4436 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4439 SV* sv = NEWSV(0,0);
4445 /* Now that vars are all in place, clone nested closures. */
4447 for (ix = fpad; ix > 0; ix--) {
4448 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4450 && namesv != &PL_sv_undef
4451 && !(SvFLAGS(namesv) & SVf_FAKE)
4452 && *SvPVX(namesv) == '&'
4453 && CvCLONE(ppad[ix]))
4455 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4456 SvREFCNT_dec(ppad[ix]);
4459 PL_curpad[ix] = (SV*)kid;
4463 #ifdef DEBUG_CLOSURES
4464 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4466 PerlIO_printf(Perl_debug_log, " from:\n");
4468 PerlIO_printf(Perl_debug_log, " to:\n");
4475 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4477 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4479 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4486 Perl_cv_clone(pTHX_ CV *proto)
4489 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4490 cv = cv_clone2(proto, CvOUTSIDE(proto));
4491 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4496 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4498 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4499 SV* msg = sv_newmortal();
4503 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4504 sv_setpv(msg, "Prototype mismatch:");
4506 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4508 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4509 sv_catpv(msg, " vs ");
4511 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4513 sv_catpv(msg, "none");
4514 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4518 static void const_sv_xsub(pTHXo_ CV* cv);
4521 =for apidoc cv_const_sv
4523 If C<cv> is a constant sub eligible for inlining. returns the constant
4524 value returned by the sub. Otherwise, returns NULL.
4526 Constant subs can be created with C<newCONSTSUB> or as described in
4527 L<perlsub/"Constant Functions">.
4532 Perl_cv_const_sv(pTHX_ CV *cv)
4534 if (!cv || !CvCONST(cv))
4536 return (SV*)CvXSUBANY(cv).any_ptr;
4540 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4547 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4548 o = cLISTOPo->op_first->op_sibling;
4550 for (; o; o = o->op_next) {
4551 OPCODE type = o->op_type;
4553 if (sv && o->op_next == o)
4555 if (o->op_next != o) {
4556 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4558 if (type == OP_DBSTATE)
4561 if (type == OP_LEAVESUB || type == OP_RETURN)
4565 if (type == OP_CONST && cSVOPo->op_sv)
4567 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4568 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4569 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4573 /* We get here only from cv_clone2() while creating a closure.
4574 Copy the const value here instead of in cv_clone2 so that
4575 SvREADONLY_on doesn't lead to problems when leaving
4580 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4592 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4602 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4606 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4608 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4612 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4618 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4623 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4624 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4625 SV *sv = sv_newmortal();
4626 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4627 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4632 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4633 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4643 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4644 maximum a prototype before. */
4645 if (SvTYPE(gv) > SVt_NULL) {
4646 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4647 && ckWARN_d(WARN_PROTOTYPE))
4649 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4651 cv_ckproto((CV*)gv, NULL, ps);
4654 sv_setpv((SV*)gv, ps);
4656 sv_setiv((SV*)gv, -1);
4657 SvREFCNT_dec(PL_compcv);
4658 cv = PL_compcv = NULL;
4659 PL_sub_generation++;
4663 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4665 #ifdef GV_UNIQUE_CHECK
4666 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4667 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4671 if (!block || !ps || *ps || attrs)
4674 const_sv = op_const_sv(block, Nullcv);
4677 bool exists = CvROOT(cv) || CvXSUB(cv);
4679 #ifdef GV_UNIQUE_CHECK
4680 if (exists && GvUNIQUE(gv)) {
4681 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4685 /* if the subroutine doesn't exist and wasn't pre-declared
4686 * with a prototype, assume it will be AUTOLOADed,
4687 * skipping the prototype check
4689 if (exists || SvPOK(cv))
4690 cv_ckproto(cv, gv, ps);
4691 /* already defined (or promised)? */
4692 if (exists || GvASSUMECV(gv)) {
4693 if (!block && !attrs) {
4694 /* just a "sub foo;" when &foo is already defined */
4695 SAVEFREESV(PL_compcv);
4698 /* ahem, death to those who redefine active sort subs */
4699 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4700 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4702 if (ckWARN(WARN_REDEFINE)
4704 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4706 line_t oldline = CopLINE(PL_curcop);
4707 CopLINE_set(PL_curcop, PL_copline);
4708 Perl_warner(aTHX_ WARN_REDEFINE,
4709 CvCONST(cv) ? "Constant subroutine %s redefined"
4710 : "Subroutine %s redefined", name);
4711 CopLINE_set(PL_curcop, oldline);
4719 SvREFCNT_inc(const_sv);
4721 assert(!CvROOT(cv) && !CvCONST(cv));
4722 sv_setpv((SV*)cv, ""); /* prototype is "" */
4723 CvXSUBANY(cv).any_ptr = const_sv;
4724 CvXSUB(cv) = const_sv_xsub;
4729 cv = newCONSTSUB(NULL, name, const_sv);
4732 SvREFCNT_dec(PL_compcv);
4734 PL_sub_generation++;
4741 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4742 * before we clobber PL_compcv.
4746 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4747 stash = GvSTASH(CvGV(cv));
4748 else if (CvSTASH(cv))
4749 stash = CvSTASH(cv);
4751 stash = PL_curstash;
4754 /* possibly about to re-define existing subr -- ignore old cv */
4755 rcv = (SV*)PL_compcv;
4756 if (name && GvSTASH(gv))
4757 stash = GvSTASH(gv);
4759 stash = PL_curstash;
4761 apply_attrs(stash, rcv, attrs);
4763 if (cv) { /* must reuse cv if autoloaded */
4765 /* got here with just attrs -- work done, so bug out */
4766 SAVEFREESV(PL_compcv);
4770 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4771 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4772 CvOUTSIDE(PL_compcv) = 0;
4773 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4774 CvPADLIST(PL_compcv) = 0;
4775 /* inner references to PL_compcv must be fixed up ... */
4777 AV *padlist = CvPADLIST(cv);
4778 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4779 AV *comppad = (AV*)AvARRAY(padlist)[1];
4780 SV **namepad = AvARRAY(comppad_name);
4781 SV **curpad = AvARRAY(comppad);
4782 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4783 SV *namesv = namepad[ix];
4784 if (namesv && namesv != &PL_sv_undef
4785 && *SvPVX(namesv) == '&')
4787 CV *innercv = (CV*)curpad[ix];
4788 if (CvOUTSIDE(innercv) == PL_compcv) {
4789 CvOUTSIDE(innercv) = cv;
4790 if (!CvANON(innercv) || CvCLONED(innercv)) {
4791 (void)SvREFCNT_inc(cv);
4792 SvREFCNT_dec(PL_compcv);
4798 /* ... before we throw it away */
4799 SvREFCNT_dec(PL_compcv);
4800 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4801 ++PL_sub_generation;
4808 PL_sub_generation++;
4812 CvFILE_set_from_cop(cv, PL_curcop);
4813 CvSTASH(cv) = PL_curstash;
4814 #ifdef USE_5005THREADS
4816 if (!CvMUTEXP(cv)) {
4817 New(666, CvMUTEXP(cv), 1, perl_mutex);
4818 MUTEX_INIT(CvMUTEXP(cv));
4820 #endif /* USE_5005THREADS */
4823 sv_setpv((SV*)cv, ps);
4825 if (PL_error_count) {
4829 char *s = strrchr(name, ':');
4831 if (strEQ(s, "BEGIN")) {
4833 "BEGIN not safe after errors--compilation aborted";
4834 if (PL_in_eval & EVAL_KEEPERR)
4835 Perl_croak(aTHX_ not_safe);
4837 /* force display of errors found but not reported */
4838 sv_catpv(ERRSV, not_safe);
4839 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4847 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4848 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4851 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4852 mod(scalarseq(block), OP_LEAVESUBLV));
4855 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4857 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4858 OpREFCNT_set(CvROOT(cv), 1);
4859 CvSTART(cv) = LINKLIST(CvROOT(cv));
4860 CvROOT(cv)->op_next = 0;
4861 CALL_PEEP(CvSTART(cv));
4863 /* now that optimizer has done its work, adjust pad values */
4865 SV **namep = AvARRAY(PL_comppad_name);
4866 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4869 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4872 * The only things that a clonable function needs in its
4873 * pad are references to outer lexicals and anonymous subs.
4874 * The rest are created anew during cloning.
4876 if (!((namesv = namep[ix]) != Nullsv &&
4877 namesv != &PL_sv_undef &&
4879 *SvPVX(namesv) == '&')))
4881 SvREFCNT_dec(PL_curpad[ix]);
4882 PL_curpad[ix] = Nullsv;
4885 assert(!CvCONST(cv));
4886 if (ps && !*ps && op_const_sv(block, cv))
4890 AV *av = newAV(); /* Will be @_ */
4892 av_store(PL_comppad, 0, (SV*)av);
4893 AvFLAGS(av) = AVf_REIFY;
4895 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4896 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4898 if (!SvPADMY(PL_curpad[ix]))
4899 SvPADTMP_on(PL_curpad[ix]);
4903 /* If a potential closure prototype, don't keep a refcount on
4904 * outer CV, unless the latter happens to be a passing eval"".
4905 * This is okay as the lifetime of the prototype is tied to the
4906 * lifetime of the outer CV. Avoids memory leak due to reference
4908 if (!name && CvOUTSIDE(cv)
4909 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4910 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4912 SvREFCNT_dec(CvOUTSIDE(cv));
4915 if (name || aname) {
4917 char *tname = (name ? name : aname);
4919 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4920 SV *sv = NEWSV(0,0);
4921 SV *tmpstr = sv_newmortal();
4922 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4926 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4928 (long)PL_subline, (long)CopLINE(PL_curcop));
4929 gv_efullname3(tmpstr, gv, Nullch);
4930 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4931 hv = GvHVn(db_postponed);
4932 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4933 && (pcv = GvCV(db_postponed)))
4939 call_sv((SV*)pcv, G_DISCARD);
4943 if ((s = strrchr(tname,':')))
4948 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4951 if (strEQ(s, "BEGIN")) {
4952 I32 oldscope = PL_scopestack_ix;
4954 SAVECOPFILE(&PL_compiling);
4955 SAVECOPLINE(&PL_compiling);
4957 sv_setsv(PL_rs, PL_nrs);
4960 PL_beginav = newAV();
4961 DEBUG_x( dump_sub(gv) );
4962 av_push(PL_beginav, (SV*)cv);
4963 GvCV(gv) = 0; /* cv has been hijacked */
4964 call_list(oldscope, PL_beginav);
4966 PL_curcop = &PL_compiling;
4967 PL_compiling.op_private = PL_hints;
4970 else if (strEQ(s, "END") && !PL_error_count) {
4973 DEBUG_x( dump_sub(gv) );
4974 av_unshift(PL_endav, 1);
4975 av_store(PL_endav, 0, (SV*)cv);
4976 GvCV(gv) = 0; /* cv has been hijacked */
4978 else if (strEQ(s, "CHECK") && !PL_error_count) {
4980 PL_checkav = newAV();
4981 DEBUG_x( dump_sub(gv) );
4982 if (PL_main_start && ckWARN(WARN_VOID))
4983 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4984 av_unshift(PL_checkav, 1);
4985 av_store(PL_checkav, 0, (SV*)cv);
4986 GvCV(gv) = 0; /* cv has been hijacked */
4988 else if (strEQ(s, "INIT") && !PL_error_count) {
4990 PL_initav = newAV();
4991 DEBUG_x( dump_sub(gv) );
4992 if (PL_main_start && ckWARN(WARN_VOID))
4993 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4994 av_push(PL_initav, (SV*)cv);
4995 GvCV(gv) = 0; /* cv has been hijacked */
5000 PL_copline = NOLINE;
5005 /* XXX unsafe for threads if eval_owner isn't held */
5007 =for apidoc newCONSTSUB
5009 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5010 eligible for inlining at compile-time.
5016 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5022 SAVECOPLINE(PL_curcop);
5023 CopLINE_set(PL_curcop, PL_copline);
5026 PL_hints &= ~HINT_BLOCK_SCOPE;
5029 SAVESPTR(PL_curstash);
5030 SAVECOPSTASH(PL_curcop);
5031 PL_curstash = stash;
5033 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5035 CopSTASH(PL_curcop) = stash;
5039 cv = newXS(name, const_sv_xsub, __FILE__);
5040 CvXSUBANY(cv).any_ptr = sv;
5042 sv_setpv((SV*)cv, ""); /* prototype is "" */
5050 =for apidoc U||newXS
5052 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5058 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5060 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5063 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5065 /* just a cached method */
5069 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5070 /* already defined (or promised) */
5071 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5072 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5073 line_t oldline = CopLINE(PL_curcop);
5074 if (PL_copline != NOLINE)
5075 CopLINE_set(PL_curcop, PL_copline);
5076 Perl_warner(aTHX_ WARN_REDEFINE,
5077 CvCONST(cv) ? "Constant subroutine %s redefined"
5078 : "Subroutine %s redefined"
5080 CopLINE_set(PL_curcop, oldline);
5087 if (cv) /* must reuse cv if autoloaded */
5090 cv = (CV*)NEWSV(1105,0);
5091 sv_upgrade((SV *)cv, SVt_PVCV);
5095 PL_sub_generation++;
5099 #ifdef USE_5005THREADS
5100 New(666, CvMUTEXP(cv), 1, perl_mutex);
5101 MUTEX_INIT(CvMUTEXP(cv));
5103 #endif /* USE_5005THREADS */
5104 (void)gv_fetchfile(filename);
5105 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5106 an external constant string */
5107 CvXSUB(cv) = subaddr;
5110 char *s = strrchr(name,':');
5116 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5119 if (strEQ(s, "BEGIN")) {
5121 PL_beginav = newAV();
5122 av_push(PL_beginav, (SV*)cv);
5123 GvCV(gv) = 0; /* cv has been hijacked */
5125 else if (strEQ(s, "END")) {
5128 av_unshift(PL_endav, 1);
5129 av_store(PL_endav, 0, (SV*)cv);
5130 GvCV(gv) = 0; /* cv has been hijacked */
5132 else if (strEQ(s, "CHECK")) {
5134 PL_checkav = newAV();
5135 if (PL_main_start && ckWARN(WARN_VOID))
5136 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5137 av_unshift(PL_checkav, 1);
5138 av_store(PL_checkav, 0, (SV*)cv);
5139 GvCV(gv) = 0; /* cv has been hijacked */
5141 else if (strEQ(s, "INIT")) {
5143 PL_initav = newAV();
5144 if (PL_main_start && ckWARN(WARN_VOID))
5145 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5146 av_push(PL_initav, (SV*)cv);
5147 GvCV(gv) = 0; /* cv has been hijacked */
5158 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5167 name = SvPVx(cSVOPo->op_sv, n_a);
5170 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5171 #ifdef GV_UNIQUE_CHECK
5173 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5177 if ((cv = GvFORM(gv))) {
5178 if (ckWARN(WARN_REDEFINE)) {
5179 line_t oldline = CopLINE(PL_curcop);
5181 CopLINE_set(PL_curcop, PL_copline);
5182 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5183 CopLINE_set(PL_curcop, oldline);
5190 CvFILE_set_from_cop(cv, PL_curcop);
5192 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5193 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5194 SvPADTMP_on(PL_curpad[ix]);
5197 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5198 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5199 OpREFCNT_set(CvROOT(cv), 1);
5200 CvSTART(cv) = LINKLIST(CvROOT(cv));
5201 CvROOT(cv)->op_next = 0;
5202 CALL_PEEP(CvSTART(cv));
5204 PL_copline = NOLINE;
5209 Perl_newANONLIST(pTHX_ OP *o)
5211 return newUNOP(OP_REFGEN, 0,
5212 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5216 Perl_newANONHASH(pTHX_ OP *o)
5218 return newUNOP(OP_REFGEN, 0,
5219 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5223 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5225 return newANONATTRSUB(floor, proto, Nullop, block);
5229 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5231 return newUNOP(OP_REFGEN, 0,
5232 newSVOP(OP_ANONCODE, 0,
5233 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5237 Perl_oopsAV(pTHX_ OP *o)
5239 switch (o->op_type) {
5241 o->op_type = OP_PADAV;
5242 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5243 return ref(o, OP_RV2AV);
5246 o->op_type = OP_RV2AV;
5247 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5252 if (ckWARN_d(WARN_INTERNAL))
5253 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5260 Perl_oopsHV(pTHX_ OP *o)
5262 switch (o->op_type) {
5265 o->op_type = OP_PADHV;
5266 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5267 return ref(o, OP_RV2HV);
5271 o->op_type = OP_RV2HV;
5272 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5277 if (ckWARN_d(WARN_INTERNAL))
5278 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5285 Perl_newAVREF(pTHX_ OP *o)
5287 if (o->op_type == OP_PADANY) {
5288 o->op_type = OP_PADAV;
5289 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5292 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5293 && ckWARN(WARN_DEPRECATED)) {
5294 Perl_warner(aTHX_ WARN_DEPRECATED,
5295 "Using an array as a reference is deprecated");
5297 return newUNOP(OP_RV2AV, 0, scalar(o));
5301 Perl_newGVREF(pTHX_ I32 type, OP *o)
5303 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5304 return newUNOP(OP_NULL, 0, o);
5305 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5309 Perl_newHVREF(pTHX_ OP *o)
5311 if (o->op_type == OP_PADANY) {
5312 o->op_type = OP_PADHV;
5313 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5316 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5317 && ckWARN(WARN_DEPRECATED)) {
5318 Perl_warner(aTHX_ WARN_DEPRECATED,
5319 "Using a hash as a reference is deprecated");
5321 return newUNOP(OP_RV2HV, 0, scalar(o));
5325 Perl_oopsCV(pTHX_ OP *o)
5327 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5333 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5335 return newUNOP(OP_RV2CV, flags, scalar(o));
5339 Perl_newSVREF(pTHX_ OP *o)
5341 if (o->op_type == OP_PADANY) {
5342 o->op_type = OP_PADSV;
5343 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5346 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5347 o->op_flags |= OPpDONE_SVREF;
5350 return newUNOP(OP_RV2SV, 0, scalar(o));
5353 /* Check routines. */
5356 Perl_ck_anoncode(pTHX_ OP *o)
5361 name = NEWSV(1106,0);
5362 sv_upgrade(name, SVt_PVNV);
5363 sv_setpvn(name, "&", 1);
5366 ix = pad_alloc(o->op_type, SVs_PADMY);
5367 av_store(PL_comppad_name, ix, name);
5368 av_store(PL_comppad, ix, cSVOPo->op_sv);
5369 SvPADMY_on(cSVOPo->op_sv);
5370 cSVOPo->op_sv = Nullsv;
5371 cSVOPo->op_targ = ix;
5376 Perl_ck_bitop(pTHX_ OP *o)
5378 o->op_private = PL_hints;
5383 Perl_ck_concat(pTHX_ OP *o)
5385 if (cUNOPo->op_first->op_type == OP_CONCAT)
5386 o->op_flags |= OPf_STACKED;
5391 Perl_ck_spair(pTHX_ OP *o)
5393 if (o->op_flags & OPf_KIDS) {
5396 OPCODE type = o->op_type;
5397 o = modkids(ck_fun(o), type);
5398 kid = cUNOPo->op_first;
5399 newop = kUNOP->op_first->op_sibling;
5401 (newop->op_sibling ||
5402 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5403 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5404 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5408 op_free(kUNOP->op_first);
5409 kUNOP->op_first = newop;
5411 o->op_ppaddr = PL_ppaddr[++o->op_type];
5416 Perl_ck_delete(pTHX_ OP *o)
5420 if (o->op_flags & OPf_KIDS) {
5421 OP *kid = cUNOPo->op_first;
5422 switch (kid->op_type) {
5424 o->op_flags |= OPf_SPECIAL;
5427 o->op_private |= OPpSLICE;
5430 o->op_flags |= OPf_SPECIAL;
5435 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5444 Perl_ck_eof(pTHX_ OP *o)
5446 I32 type = o->op_type;
5448 if (o->op_flags & OPf_KIDS) {
5449 if (cLISTOPo->op_first->op_type == OP_STUB) {
5451 o = newUNOP(type, OPf_SPECIAL,
5452 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5460 Perl_ck_eval(pTHX_ OP *o)
5462 PL_hints |= HINT_BLOCK_SCOPE;
5463 if (o->op_flags & OPf_KIDS) {
5464 SVOP *kid = (SVOP*)cUNOPo->op_first;
5467 o->op_flags &= ~OPf_KIDS;
5470 else if (kid->op_type == OP_LINESEQ) {
5473 kid->op_next = o->op_next;
5474 cUNOPo->op_first = 0;
5477 NewOp(1101, enter, 1, LOGOP);
5478 enter->op_type = OP_ENTERTRY;
5479 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5480 enter->op_private = 0;
5482 /* establish postfix order */
5483 enter->op_next = (OP*)enter;
5485 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5486 o->op_type = OP_LEAVETRY;
5487 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5488 enter->op_other = o;
5496 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5498 o->op_targ = (PADOFFSET)PL_hints;
5503 Perl_ck_exit(pTHX_ OP *o)
5506 HV *table = GvHV(PL_hintgv);
5508 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5509 if (svp && *svp && SvTRUE(*svp))
5510 o->op_private |= OPpEXIT_VMSISH;
5517 Perl_ck_exec(pTHX_ OP *o)
5520 if (o->op_flags & OPf_STACKED) {
5522 kid = cUNOPo->op_first->op_sibling;
5523 if (kid->op_type == OP_RV2GV)
5532 Perl_ck_exists(pTHX_ OP *o)
5535 if (o->op_flags & OPf_KIDS) {
5536 OP *kid = cUNOPo->op_first;
5537 if (kid->op_type == OP_ENTERSUB) {
5538 (void) ref(kid, o->op_type);
5539 if (kid->op_type != OP_RV2CV && !PL_error_count)
5540 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5542 o->op_private |= OPpEXISTS_SUB;
5544 else if (kid->op_type == OP_AELEM)
5545 o->op_flags |= OPf_SPECIAL;
5546 else if (kid->op_type != OP_HELEM)
5547 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5556 Perl_ck_gvconst(pTHX_ register OP *o)
5558 o = fold_constants(o);
5559 if (o->op_type == OP_CONST)
5566 Perl_ck_rvconst(pTHX_ register OP *o)
5568 SVOP *kid = (SVOP*)cUNOPo->op_first;
5570 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5571 if (kid->op_type == OP_CONST) {
5575 SV *kidsv = kid->op_sv;
5578 /* Is it a constant from cv_const_sv()? */
5579 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5580 SV *rsv = SvRV(kidsv);
5581 int svtype = SvTYPE(rsv);
5582 char *badtype = Nullch;
5584 switch (o->op_type) {
5586 if (svtype > SVt_PVMG)
5587 badtype = "a SCALAR";
5590 if (svtype != SVt_PVAV)
5591 badtype = "an ARRAY";
5594 if (svtype != SVt_PVHV) {
5595 if (svtype == SVt_PVAV) { /* pseudohash? */
5596 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5597 if (ksv && SvROK(*ksv)
5598 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5607 if (svtype != SVt_PVCV)
5612 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5615 name = SvPV(kidsv, n_a);
5616 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5617 char *badthing = Nullch;
5618 switch (o->op_type) {
5620 badthing = "a SCALAR";
5623 badthing = "an ARRAY";
5626 badthing = "a HASH";
5631 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5635 * This is a little tricky. We only want to add the symbol if we
5636 * didn't add it in the lexer. Otherwise we get duplicate strict
5637 * warnings. But if we didn't add it in the lexer, we must at
5638 * least pretend like we wanted to add it even if it existed before,
5639 * or we get possible typo warnings. OPpCONST_ENTERED says
5640 * whether the lexer already added THIS instance of this symbol.
5642 iscv = (o->op_type == OP_RV2CV) * 2;
5644 gv = gv_fetchpv(name,
5645 iscv | !(kid->op_private & OPpCONST_ENTERED),
5648 : o->op_type == OP_RV2SV
5650 : o->op_type == OP_RV2AV
5652 : o->op_type == OP_RV2HV
5655 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5657 kid->op_type = OP_GV;
5658 SvREFCNT_dec(kid->op_sv);
5660 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5661 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5662 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5664 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5666 kid->op_sv = SvREFCNT_inc(gv);
5668 kid->op_private = 0;
5669 kid->op_ppaddr = PL_ppaddr[OP_GV];
5676 Perl_ck_ftst(pTHX_ OP *o)
5678 I32 type = o->op_type;
5680 if (o->op_flags & OPf_REF) {
5683 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5684 SVOP *kid = (SVOP*)cUNOPo->op_first;
5686 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5688 OP *newop = newGVOP(type, OPf_REF,
5689 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5696 if (type == OP_FTTTY)
5697 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5700 o = newUNOP(type, 0, newDEFSVOP());
5706 Perl_ck_fun(pTHX_ OP *o)
5712 int type = o->op_type;
5713 register I32 oa = PL_opargs[type] >> OASHIFT;
5715 if (o->op_flags & OPf_STACKED) {
5716 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5719 return no_fh_allowed(o);
5722 if (o->op_flags & OPf_KIDS) {
5724 tokid = &cLISTOPo->op_first;
5725 kid = cLISTOPo->op_first;
5726 if (kid->op_type == OP_PUSHMARK ||
5727 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5729 tokid = &kid->op_sibling;
5730 kid = kid->op_sibling;
5732 if (!kid && PL_opargs[type] & OA_DEFGV)
5733 *tokid = kid = newDEFSVOP();
5737 sibl = kid->op_sibling;
5740 /* list seen where single (scalar) arg expected? */
5741 if (numargs == 1 && !(oa >> 4)
5742 && kid->op_type == OP_LIST && type != OP_SCALAR)
5744 return too_many_arguments(o,PL_op_desc[type]);
5757 if ((type == OP_PUSH || type == OP_UNSHIFT)
5758 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5759 Perl_warner(aTHX_ WARN_SYNTAX,
5760 "Useless use of %s with no values",
5763 if (kid->op_type == OP_CONST &&
5764 (kid->op_private & OPpCONST_BARE))
5766 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5767 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5768 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5769 if (ckWARN(WARN_DEPRECATED))
5770 Perl_warner(aTHX_ WARN_DEPRECATED,
5771 "Array @%s missing the @ in argument %"IVdf" of %s()",
5772 name, (IV)numargs, PL_op_desc[type]);
5775 kid->op_sibling = sibl;
5778 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5779 bad_type(numargs, "array", PL_op_desc[type], kid);
5783 if (kid->op_type == OP_CONST &&
5784 (kid->op_private & OPpCONST_BARE))
5786 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5787 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5788 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5789 if (ckWARN(WARN_DEPRECATED))
5790 Perl_warner(aTHX_ WARN_DEPRECATED,
5791 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5792 name, (IV)numargs, PL_op_desc[type]);
5795 kid->op_sibling = sibl;
5798 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5799 bad_type(numargs, "hash", PL_op_desc[type], kid);
5804 OP *newop = newUNOP(OP_NULL, 0, kid);
5805 kid->op_sibling = 0;
5807 newop->op_next = newop;
5809 kid->op_sibling = sibl;
5814 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5815 if (kid->op_type == OP_CONST &&
5816 (kid->op_private & OPpCONST_BARE))
5818 OP *newop = newGVOP(OP_GV, 0,
5819 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5824 else if (kid->op_type == OP_READLINE) {
5825 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5826 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5829 I32 flags = OPf_SPECIAL;
5833 /* is this op a FH constructor? */
5834 if (is_handle_constructor(o,numargs)) {
5835 char *name = Nullch;
5839 /* Set a flag to tell rv2gv to vivify
5840 * need to "prove" flag does not mean something
5841 * else already - NI-S 1999/05/07
5844 if (kid->op_type == OP_PADSV) {
5845 SV **namep = av_fetch(PL_comppad_name,
5847 if (namep && *namep)
5848 name = SvPV(*namep, len);
5850 else if (kid->op_type == OP_RV2SV
5851 && kUNOP->op_first->op_type == OP_GV)
5853 GV *gv = cGVOPx_gv(kUNOP->op_first);
5855 len = GvNAMELEN(gv);
5857 else if (kid->op_type == OP_AELEM
5858 || kid->op_type == OP_HELEM)
5860 name = "__ANONIO__";
5866 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5867 namesv = PL_curpad[targ];
5868 (void)SvUPGRADE(namesv, SVt_PV);
5870 sv_setpvn(namesv, "$", 1);
5871 sv_catpvn(namesv, name, len);
5874 kid->op_sibling = 0;
5875 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5876 kid->op_targ = targ;
5877 kid->op_private |= priv;
5879 kid->op_sibling = sibl;
5885 mod(scalar(kid), type);
5889 tokid = &kid->op_sibling;
5890 kid = kid->op_sibling;
5892 o->op_private |= numargs;
5894 return too_many_arguments(o,OP_DESC(o));
5897 else if (PL_opargs[type] & OA_DEFGV) {
5899 return newUNOP(type, 0, newDEFSVOP());
5903 while (oa & OA_OPTIONAL)
5905 if (oa && oa != OA_LIST)
5906 return too_few_arguments(o,OP_DESC(o));
5912 Perl_ck_glob(pTHX_ OP *o)
5917 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5918 append_elem(OP_GLOB, o, newDEFSVOP());
5920 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5921 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5923 #if !defined(PERL_EXTERNAL_GLOB)
5924 /* XXX this can be tightened up and made more failsafe. */
5928 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5930 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5931 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5932 GvCV(gv) = GvCV(glob_gv);
5933 SvREFCNT_inc((SV*)GvCV(gv));
5934 GvIMPORTED_CV_on(gv);
5937 #endif /* PERL_EXTERNAL_GLOB */
5939 if (gv && GvIMPORTED_CV(gv)) {
5940 append_elem(OP_GLOB, o,
5941 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5942 o->op_type = OP_LIST;
5943 o->op_ppaddr = PL_ppaddr[OP_LIST];
5944 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5945 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5946 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5947 append_elem(OP_LIST, o,
5948 scalar(newUNOP(OP_RV2CV, 0,
5949 newGVOP(OP_GV, 0, gv)))));
5950 o = newUNOP(OP_NULL, 0, ck_subr(o));
5951 o->op_targ = OP_GLOB; /* hint at what it used to be */
5954 gv = newGVgen("main");
5956 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5962 Perl_ck_grep(pTHX_ OP *o)
5966 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5968 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5969 NewOp(1101, gwop, 1, LOGOP);
5971 if (o->op_flags & OPf_STACKED) {
5974 kid = cLISTOPo->op_first->op_sibling;
5975 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5978 kid->op_next = (OP*)gwop;
5979 o->op_flags &= ~OPf_STACKED;
5981 kid = cLISTOPo->op_first->op_sibling;
5982 if (type == OP_MAPWHILE)
5989 kid = cLISTOPo->op_first->op_sibling;
5990 if (kid->op_type != OP_NULL)
5991 Perl_croak(aTHX_ "panic: ck_grep");
5992 kid = kUNOP->op_first;
5994 gwop->op_type = type;
5995 gwop->op_ppaddr = PL_ppaddr[type];
5996 gwop->op_first = listkids(o);
5997 gwop->op_flags |= OPf_KIDS;
5998 gwop->op_private = 1;
5999 gwop->op_other = LINKLIST(kid);
6000 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6001 kid->op_next = (OP*)gwop;
6003 kid = cLISTOPo->op_first->op_sibling;
6004 if (!kid || !kid->op_sibling)
6005 return too_few_arguments(o,OP_DESC(o));
6006 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6007 mod(kid, OP_GREPSTART);
6013 Perl_ck_index(pTHX_ OP *o)
6015 if (o->op_flags & OPf_KIDS) {
6016 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6018 kid = kid->op_sibling; /* get past "big" */
6019 if (kid && kid->op_type == OP_CONST)
6020 fbm_compile(((SVOP*)kid)->op_sv, 0);
6026 Perl_ck_lengthconst(pTHX_ OP *o)
6028 /* XXX length optimization goes here */
6033 Perl_ck_lfun(pTHX_ OP *o)
6035 OPCODE type = o->op_type;
6036 return modkids(ck_fun(o), type);
6040 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6042 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6043 switch (cUNOPo->op_first->op_type) {
6045 /* This is needed for
6046 if (defined %stash::)
6047 to work. Do not break Tk.
6049 break; /* Globals via GV can be undef */
6051 case OP_AASSIGN: /* Is this a good idea? */
6052 Perl_warner(aTHX_ WARN_DEPRECATED,
6053 "defined(@array) is deprecated");
6054 Perl_warner(aTHX_ WARN_DEPRECATED,
6055 "\t(Maybe you should just omit the defined()?)\n");
6058 /* This is needed for
6059 if (defined %stash::)
6060 to work. Do not break Tk.
6062 break; /* Globals via GV can be undef */
6064 Perl_warner(aTHX_ WARN_DEPRECATED,
6065 "defined(%%hash) is deprecated");
6066 Perl_warner(aTHX_ WARN_DEPRECATED,
6067 "\t(Maybe you should just omit the defined()?)\n");
6078 Perl_ck_rfun(pTHX_ OP *o)
6080 OPCODE type = o->op_type;
6081 return refkids(ck_fun(o), type);
6085 Perl_ck_listiob(pTHX_ OP *o)
6089 kid = cLISTOPo->op_first;
6092 kid = cLISTOPo->op_first;
6094 if (kid->op_type == OP_PUSHMARK)
6095 kid = kid->op_sibling;
6096 if (kid && o->op_flags & OPf_STACKED)
6097 kid = kid->op_sibling;
6098 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6099 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6100 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6101 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6102 cLISTOPo->op_first->op_sibling = kid;
6103 cLISTOPo->op_last = kid;
6104 kid = kid->op_sibling;
6109 append_elem(o->op_type, o, newDEFSVOP());
6115 Perl_ck_sassign(pTHX_ OP *o)
6117 OP *kid = cLISTOPo->op_first;
6118 /* has a disposable target? */
6119 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6120 && !(kid->op_flags & OPf_STACKED)
6121 /* Cannot steal the second time! */
6122 && !(kid->op_private & OPpTARGET_MY))
6124 OP *kkid = kid->op_sibling;
6126 /* Can just relocate the target. */
6127 if (kkid && kkid->op_type == OP_PADSV
6128 && !(kkid->op_private & OPpLVAL_INTRO))
6130 kid->op_targ = kkid->op_targ;
6132 /* Now we do not need PADSV and SASSIGN. */
6133 kid->op_sibling = o->op_sibling; /* NULL */
6134 cLISTOPo->op_first = NULL;
6137 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6145 Perl_ck_match(pTHX_ OP *o)
6147 o->op_private |= OPpRUNTIME;
6152 Perl_ck_method(pTHX_ OP *o)
6154 OP *kid = cUNOPo->op_first;
6155 if (kid->op_type == OP_CONST) {
6156 SV* sv = kSVOP->op_sv;
6157 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6159 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6160 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6163 kSVOP->op_sv = Nullsv;
6165 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6174 Perl_ck_null(pTHX_ OP *o)
6180 Perl_ck_open(pTHX_ OP *o)
6182 HV *table = GvHV(PL_hintgv);
6186 svp = hv_fetch(table, "open_IN", 7, FALSE);
6188 mode = mode_from_discipline(*svp);
6189 if (mode & O_BINARY)
6190 o->op_private |= OPpOPEN_IN_RAW;
6191 else if (mode & O_TEXT)
6192 o->op_private |= OPpOPEN_IN_CRLF;
6195 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6197 mode = mode_from_discipline(*svp);
6198 if (mode & O_BINARY)
6199 o->op_private |= OPpOPEN_OUT_RAW;
6200 else if (mode & O_TEXT)
6201 o->op_private |= OPpOPEN_OUT_CRLF;
6204 if (o->op_type == OP_BACKTICK)
6210 Perl_ck_repeat(pTHX_ OP *o)
6212 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6213 o->op_private |= OPpREPEAT_DOLIST;
6214 cBINOPo->op_first = force_list(cBINOPo->op_first);
6222 Perl_ck_require(pTHX_ OP *o)
6226 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6227 SVOP *kid = (SVOP*)cUNOPo->op_first;
6229 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6231 for (s = SvPVX(kid->op_sv); *s; s++) {
6232 if (*s == ':' && s[1] == ':') {
6234 Move(s+2, s+1, strlen(s+2)+1, char);
6235 --SvCUR(kid->op_sv);
6238 if (SvREADONLY(kid->op_sv)) {
6239 SvREADONLY_off(kid->op_sv);
6240 sv_catpvn(kid->op_sv, ".pm", 3);
6241 SvREADONLY_on(kid->op_sv);
6244 sv_catpvn(kid->op_sv, ".pm", 3);
6248 /* handle override, if any */
6249 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6250 if (!(gv && GvIMPORTED_CV(gv)))
6251 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6253 if (gv && GvIMPORTED_CV(gv)) {
6254 OP *kid = cUNOPo->op_first;
6255 cUNOPo->op_first = 0;
6257 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6258 append_elem(OP_LIST, kid,
6259 scalar(newUNOP(OP_RV2CV, 0,
6268 Perl_ck_return(pTHX_ OP *o)
6271 if (CvLVALUE(PL_compcv)) {
6272 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6273 mod(kid, OP_LEAVESUBLV);
6280 Perl_ck_retarget(pTHX_ OP *o)
6282 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6289 Perl_ck_select(pTHX_ OP *o)
6292 if (o->op_flags & OPf_KIDS) {
6293 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6294 if (kid && kid->op_sibling) {
6295 o->op_type = OP_SSELECT;
6296 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6298 return fold_constants(o);
6302 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6303 if (kid && kid->op_type == OP_RV2GV)
6304 kid->op_private &= ~HINT_STRICT_REFS;
6309 Perl_ck_shift(pTHX_ OP *o)
6311 I32 type = o->op_type;
6313 if (!(o->op_flags & OPf_KIDS)) {
6317 #ifdef USE_5005THREADS
6318 if (!CvUNIQUE(PL_compcv)) {
6319 argop = newOP(OP_PADAV, OPf_REF);
6320 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6323 argop = newUNOP(OP_RV2AV, 0,
6324 scalar(newGVOP(OP_GV, 0,
6325 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6328 argop = newUNOP(OP_RV2AV, 0,
6329 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6330 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6331 #endif /* USE_5005THREADS */
6332 return newUNOP(type, 0, scalar(argop));
6334 return scalar(modkids(ck_fun(o), type));
6338 Perl_ck_sort(pTHX_ OP *o)
6342 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6344 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6345 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6347 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6349 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6351 if (kid->op_type == OP_SCOPE) {
6355 else if (kid->op_type == OP_LEAVE) {
6356 if (o->op_type == OP_SORT) {
6357 op_null(kid); /* wipe out leave */
6360 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6361 if (k->op_next == kid)
6363 /* don't descend into loops */
6364 else if (k->op_type == OP_ENTERLOOP
6365 || k->op_type == OP_ENTERITER)
6367 k = cLOOPx(k)->op_lastop;
6372 kid->op_next = 0; /* just disconnect the leave */
6373 k = kLISTOP->op_first;
6378 if (o->op_type == OP_SORT) {
6379 /* provide scalar context for comparison function/block */
6385 o->op_flags |= OPf_SPECIAL;
6387 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6390 firstkid = firstkid->op_sibling;
6393 /* provide list context for arguments */
6394 if (o->op_type == OP_SORT)
6401 S_simplify_sort(pTHX_ OP *o)
6403 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6407 if (!(o->op_flags & OPf_STACKED))
6409 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6410 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6411 kid = kUNOP->op_first; /* get past null */
6412 if (kid->op_type != OP_SCOPE)
6414 kid = kLISTOP->op_last; /* get past scope */
6415 switch(kid->op_type) {
6423 k = kid; /* remember this node*/
6424 if (kBINOP->op_first->op_type != OP_RV2SV)
6426 kid = kBINOP->op_first; /* get past cmp */
6427 if (kUNOP->op_first->op_type != OP_GV)
6429 kid = kUNOP->op_first; /* get past rv2sv */
6431 if (GvSTASH(gv) != PL_curstash)
6433 if (strEQ(GvNAME(gv), "a"))
6435 else if (strEQ(GvNAME(gv), "b"))
6439 kid = k; /* back to cmp */
6440 if (kBINOP->op_last->op_type != OP_RV2SV)
6442 kid = kBINOP->op_last; /* down to 2nd arg */
6443 if (kUNOP->op_first->op_type != OP_GV)
6445 kid = kUNOP->op_first; /* get past rv2sv */
6447 if (GvSTASH(gv) != PL_curstash
6449 ? strNE(GvNAME(gv), "a")
6450 : strNE(GvNAME(gv), "b")))
6452 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6454 o->op_private |= OPpSORT_REVERSE;
6455 if (k->op_type == OP_NCMP)
6456 o->op_private |= OPpSORT_NUMERIC;
6457 if (k->op_type == OP_I_NCMP)
6458 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6459 kid = cLISTOPo->op_first->op_sibling;
6460 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6461 op_free(kid); /* then delete it */
6465 Perl_ck_split(pTHX_ OP *o)
6469 if (o->op_flags & OPf_STACKED)
6470 return no_fh_allowed(o);
6472 kid = cLISTOPo->op_first;
6473 if (kid->op_type != OP_NULL)
6474 Perl_croak(aTHX_ "panic: ck_split");
6475 kid = kid->op_sibling;
6476 op_free(cLISTOPo->op_first);
6477 cLISTOPo->op_first = kid;
6479 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6480 cLISTOPo->op_last = kid; /* There was only one element previously */
6483 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6484 OP *sibl = kid->op_sibling;
6485 kid->op_sibling = 0;
6486 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6487 if (cLISTOPo->op_first == cLISTOPo->op_last)
6488 cLISTOPo->op_last = kid;
6489 cLISTOPo->op_first = kid;
6490 kid->op_sibling = sibl;
6493 kid->op_type = OP_PUSHRE;
6494 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6497 if (!kid->op_sibling)
6498 append_elem(OP_SPLIT, o, newDEFSVOP());
6500 kid = kid->op_sibling;
6503 if (!kid->op_sibling)
6504 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6506 kid = kid->op_sibling;
6509 if (kid->op_sibling)
6510 return too_many_arguments(o,OP_DESC(o));
6516 Perl_ck_join(pTHX_ OP *o)
6518 if (ckWARN(WARN_SYNTAX)) {
6519 OP *kid = cLISTOPo->op_first->op_sibling;
6520 if (kid && kid->op_type == OP_MATCH) {
6521 char *pmstr = "STRING";
6522 if (PM_GETRE(kPMOP))
6523 pmstr = PM_GETRE(kPMOP)->precomp;
6524 Perl_warner(aTHX_ WARN_SYNTAX,
6525 "/%s/ should probably be written as \"%s\"",
6533 Perl_ck_subr(pTHX_ OP *o)
6535 OP *prev = ((cUNOPo->op_first->op_sibling)
6536 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6537 OP *o2 = prev->op_sibling;
6546 o->op_private |= OPpENTERSUB_HASTARG;
6547 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6548 if (cvop->op_type == OP_RV2CV) {
6550 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6551 op_null(cvop); /* disable rv2cv */
6552 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6553 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6554 GV *gv = cGVOPx_gv(tmpop);
6557 tmpop->op_private |= OPpEARLY_CV;
6558 else if (SvPOK(cv)) {
6559 namegv = CvANON(cv) ? gv : CvGV(cv);
6560 proto = SvPV((SV*)cv, n_a);
6564 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6565 if (o2->op_type == OP_CONST)
6566 o2->op_private &= ~OPpCONST_STRICT;
6567 else if (o2->op_type == OP_LIST) {
6568 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6569 if (o && o->op_type == OP_CONST)
6570 o->op_private &= ~OPpCONST_STRICT;
6573 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6574 if (PERLDB_SUB && PL_curstash != PL_debstash)
6575 o->op_private |= OPpENTERSUB_DB;
6576 while (o2 != cvop) {
6580 return too_many_arguments(o, gv_ename(namegv));
6598 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6600 arg == 1 ? "block or sub {}" : "sub {}",
6601 gv_ename(namegv), o2);
6604 /* '*' allows any scalar type, including bareword */
6607 if (o2->op_type == OP_RV2GV)
6608 goto wrapref; /* autoconvert GLOB -> GLOBref */
6609 else if (o2->op_type == OP_CONST)
6610 o2->op_private &= ~OPpCONST_STRICT;
6611 else if (o2->op_type == OP_ENTERSUB) {
6612 /* accidental subroutine, revert to bareword */
6613 OP *gvop = ((UNOP*)o2)->op_first;
6614 if (gvop && gvop->op_type == OP_NULL) {
6615 gvop = ((UNOP*)gvop)->op_first;
6617 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6620 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6621 (gvop = ((UNOP*)gvop)->op_first) &&
6622 gvop->op_type == OP_GV)
6624 GV *gv = cGVOPx_gv(gvop);
6625 OP *sibling = o2->op_sibling;
6626 SV *n = newSVpvn("",0);
6628 gv_fullname3(n, gv, "");
6629 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6630 sv_chop(n, SvPVX(n)+6);
6631 o2 = newSVOP(OP_CONST, 0, n);
6632 prev->op_sibling = o2;
6633 o2->op_sibling = sibling;
6645 if (o2->op_type != OP_RV2GV)
6646 bad_type(arg, "symbol", gv_ename(namegv), o2);
6649 if (o2->op_type != OP_ENTERSUB)
6650 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6653 if (o2->op_type != OP_RV2SV
6654 && o2->op_type != OP_PADSV
6655 && o2->op_type != OP_HELEM
6656 && o2->op_type != OP_AELEM
6657 && o2->op_type != OP_THREADSV)
6659 bad_type(arg, "scalar", gv_ename(namegv), o2);
6663 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6664 bad_type(arg, "array", gv_ename(namegv), o2);
6667 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6668 bad_type(arg, "hash", gv_ename(namegv), o2);
6672 OP* sib = kid->op_sibling;
6673 kid->op_sibling = 0;
6674 o2 = newUNOP(OP_REFGEN, 0, kid);
6675 o2->op_sibling = sib;
6676 prev->op_sibling = o2;
6687 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6688 gv_ename(namegv), SvPV((SV*)cv, n_a));
6693 mod(o2, OP_ENTERSUB);
6695 o2 = o2->op_sibling;
6697 if (proto && !optional &&
6698 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6699 return too_few_arguments(o, gv_ename(namegv));
6704 Perl_ck_svconst(pTHX_ OP *o)
6706 SvREADONLY_on(cSVOPo->op_sv);
6711 Perl_ck_trunc(pTHX_ OP *o)
6713 if (o->op_flags & OPf_KIDS) {
6714 SVOP *kid = (SVOP*)cUNOPo->op_first;
6716 if (kid->op_type == OP_NULL)
6717 kid = (SVOP*)kid->op_sibling;
6718 if (kid && kid->op_type == OP_CONST &&
6719 (kid->op_private & OPpCONST_BARE))
6721 o->op_flags |= OPf_SPECIAL;
6722 kid->op_private &= ~OPpCONST_STRICT;
6729 Perl_ck_substr(pTHX_ OP *o)
6732 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6733 OP *kid = cLISTOPo->op_first;
6735 if (kid->op_type == OP_NULL)
6736 kid = kid->op_sibling;
6738 kid->op_flags |= OPf_MOD;
6744 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6747 Perl_peep(pTHX_ register OP *o)
6749 register OP* oldop = 0;
6752 if (!o || o->op_seq)
6756 SAVEVPTR(PL_curcop);
6757 for (; o; o = o->op_next) {
6763 switch (o->op_type) {
6767 PL_curcop = ((COP*)o); /* for warnings */
6768 o->op_seq = PL_op_seqmax++;
6772 if (cSVOPo->op_private & OPpCONST_STRICT)
6773 no_bareword_allowed(o);
6775 /* Relocate sv to the pad for thread safety.
6776 * Despite being a "constant", the SV is written to,
6777 * for reference counts, sv_upgrade() etc. */
6779 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6780 if (SvPADTMP(cSVOPo->op_sv)) {
6781 /* If op_sv is already a PADTMP then it is being used by
6782 * some pad, so make a copy. */
6783 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6784 SvREADONLY_on(PL_curpad[ix]);
6785 SvREFCNT_dec(cSVOPo->op_sv);
6788 SvREFCNT_dec(PL_curpad[ix]);
6789 SvPADTMP_on(cSVOPo->op_sv);
6790 PL_curpad[ix] = cSVOPo->op_sv;
6791 /* XXX I don't know how this isn't readonly already. */
6792 SvREADONLY_on(PL_curpad[ix]);
6794 cSVOPo->op_sv = Nullsv;
6798 o->op_seq = PL_op_seqmax++;
6802 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6803 if (o->op_next->op_private & OPpTARGET_MY) {
6804 if (o->op_flags & OPf_STACKED) /* chained concats */
6805 goto ignore_optimization;
6807 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6808 o->op_targ = o->op_next->op_targ;
6809 o->op_next->op_targ = 0;
6810 o->op_private |= OPpTARGET_MY;
6813 op_null(o->op_next);
6815 ignore_optimization:
6816 o->op_seq = PL_op_seqmax++;
6819 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6820 o->op_seq = PL_op_seqmax++;
6821 break; /* Scalar stub must produce undef. List stub is noop */
6825 if (o->op_targ == OP_NEXTSTATE
6826 || o->op_targ == OP_DBSTATE
6827 || o->op_targ == OP_SETSTATE)
6829 PL_curcop = ((COP*)o);
6831 /* XXX: We avoid setting op_seq here to prevent later calls
6832 to peep() from mistakenly concluding that optimisation
6833 has already occurred. This doesn't fix the real problem,
6834 though (See 20010220.007). AMS 20010719 */
6835 if (oldop && o->op_next) {
6836 oldop->op_next = o->op_next;
6844 if (oldop && o->op_next) {
6845 oldop->op_next = o->op_next;
6848 o->op_seq = PL_op_seqmax++;
6852 if (o->op_next->op_type == OP_RV2SV) {
6853 if (!(o->op_next->op_private & OPpDEREF)) {
6854 op_null(o->op_next);
6855 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6857 o->op_next = o->op_next->op_next;
6858 o->op_type = OP_GVSV;
6859 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6862 else if (o->op_next->op_type == OP_RV2AV) {
6863 OP* pop = o->op_next->op_next;
6865 if (pop->op_type == OP_CONST &&
6866 (PL_op = pop->op_next) &&
6867 pop->op_next->op_type == OP_AELEM &&
6868 !(pop->op_next->op_private &
6869 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6870 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6875 op_null(o->op_next);
6876 op_null(pop->op_next);
6878 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6879 o->op_next = pop->op_next->op_next;
6880 o->op_type = OP_AELEMFAST;
6881 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6882 o->op_private = (U8)i;
6887 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6889 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6890 /* XXX could check prototype here instead of just carping */
6891 SV *sv = sv_newmortal();
6892 gv_efullname3(sv, gv, Nullch);
6893 Perl_warner(aTHX_ WARN_PROTOTYPE,
6894 "%s() called too early to check prototype",
6898 else if (o->op_next->op_type == OP_READLINE
6899 && o->op_next->op_next->op_type == OP_CONCAT
6900 && (o->op_next->op_next->op_flags & OPf_STACKED))
6902 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010811 */
6903 o->op_next->op_type = OP_RCATLINE;
6904 o->op_next->op_flags |= OPf_STACKED;
6905 op_null(o->op_next->op_next);
6908 o->op_seq = PL_op_seqmax++;
6919 o->op_seq = PL_op_seqmax++;
6920 while (cLOGOP->op_other->op_type == OP_NULL)
6921 cLOGOP->op_other = cLOGOP->op_other->op_next;
6922 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6927 o->op_seq = PL_op_seqmax++;
6928 while (cLOOP->op_redoop->op_type == OP_NULL)
6929 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6930 peep(cLOOP->op_redoop);
6931 while (cLOOP->op_nextop->op_type == OP_NULL)
6932 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6933 peep(cLOOP->op_nextop);
6934 while (cLOOP->op_lastop->op_type == OP_NULL)
6935 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6936 peep(cLOOP->op_lastop);
6942 o->op_seq = PL_op_seqmax++;
6943 while (cPMOP->op_pmreplstart &&
6944 cPMOP->op_pmreplstart->op_type == OP_NULL)
6945 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6946 peep(cPMOP->op_pmreplstart);
6950 o->op_seq = PL_op_seqmax++;
6951 if (ckWARN(WARN_SYNTAX) && o->op_next
6952 && o->op_next->op_type == OP_NEXTSTATE) {
6953 if (o->op_next->op_sibling &&
6954 o->op_next->op_sibling->op_type != OP_EXIT &&
6955 o->op_next->op_sibling->op_type != OP_WARN &&
6956 o->op_next->op_sibling->op_type != OP_DIE) {
6957 line_t oldline = CopLINE(PL_curcop);
6959 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6960 Perl_warner(aTHX_ WARN_EXEC,
6961 "Statement unlikely to be reached");
6962 Perl_warner(aTHX_ WARN_EXEC,
6963 "\t(Maybe you meant system() when you said exec()?)\n");
6964 CopLINE_set(PL_curcop, oldline);
6973 SV **svp, **indsvp, *sv;
6978 o->op_seq = PL_op_seqmax++;
6980 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6983 /* Make the CONST have a shared SV */
6984 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6985 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6986 key = SvPV(sv, keylen);
6987 lexname = newSVpvn_share(key,
6988 SvUTF8(sv) ? -(I32)keylen : keylen,
6994 if ((o->op_private & (OPpLVAL_INTRO)))
6997 rop = (UNOP*)((BINOP*)o)->op_first;
6998 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7000 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7001 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7003 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7004 if (!fields || !GvHV(*fields))
7006 key = SvPV(*svp, keylen);
7007 indsvp = hv_fetch(GvHV(*fields), key,
7008 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7010 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7011 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7013 ind = SvIV(*indsvp);
7015 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7016 rop->op_type = OP_RV2AV;
7017 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7018 o->op_type = OP_AELEM;
7019 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7021 if (SvREADONLY(*svp))
7023 SvFLAGS(sv) |= (SvFLAGS(*svp)
7024 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7034 SV **svp, **indsvp, *sv;
7038 SVOP *first_key_op, *key_op;
7040 o->op_seq = PL_op_seqmax++;
7041 if ((o->op_private & (OPpLVAL_INTRO))
7042 /* I bet there's always a pushmark... */
7043 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7044 /* hmmm, no optimization if list contains only one key. */
7046 rop = (UNOP*)((LISTOP*)o)->op_last;
7047 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7049 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7050 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7052 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7053 if (!fields || !GvHV(*fields))
7055 /* Again guessing that the pushmark can be jumped over.... */
7056 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7057 ->op_first->op_sibling;
7058 /* Check that the key list contains only constants. */
7059 for (key_op = first_key_op; key_op;
7060 key_op = (SVOP*)key_op->op_sibling)
7061 if (key_op->op_type != OP_CONST)
7065 rop->op_type = OP_RV2AV;
7066 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7067 o->op_type = OP_ASLICE;
7068 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7069 for (key_op = first_key_op; key_op;
7070 key_op = (SVOP*)key_op->op_sibling) {
7071 svp = cSVOPx_svp(key_op);
7072 key = SvPV(*svp, keylen);
7073 indsvp = hv_fetch(GvHV(*fields), key,
7074 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7076 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7077 "in variable %s of type %s",
7078 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7080 ind = SvIV(*indsvp);
7082 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7084 if (SvREADONLY(*svp))
7086 SvFLAGS(sv) |= (SvFLAGS(*svp)
7087 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7095 o->op_seq = PL_op_seqmax++;
7103 #ifdef PERL_CUSTOM_OPS
7104 char* custom_op_name(pTHX_ OP* o)
7106 IV index = PTR2IV(o->op_ppaddr);
7110 if (!PL_custom_op_names) /* This probably shouldn't happen */
7111 return PL_op_name[OP_CUSTOM];
7113 keysv = sv_2mortal(newSViv(index));
7115 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7117 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7119 return SvPV_nolen(HeVAL(he));
7122 char* custom_op_desc(pTHX_ OP* o)
7124 IV index = PTR2IV(o->op_ppaddr);
7128 if (!PL_custom_op_descs)
7129 return PL_op_desc[OP_CUSTOM];
7131 keysv = sv_2mortal(newSViv(index));
7133 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7135 return PL_op_desc[OP_CUSTOM];
7137 return SvPV_nolen(HeVAL(he));
7143 /* Efficient sub that returns a constant scalar value. */
7145 const_sv_xsub(pTHXo_ CV* cv)
7150 Perl_croak(aTHX_ "usage: %s::%s()",
7151 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7155 ST(0) = (SV*)XSANY.any_ptr;