3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
25 /* #define PL_OP_SLAB_ALLOC */
27 #ifdef PL_OP_SLAB_ALLOC
28 #define SLAB_SIZE 8192
29 static char *PL_OpPtr = NULL;
30 static int PL_OpSpace = 0;
31 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
32 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
34 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
40 Newz(m,PL_OpPtr,SLAB_SIZE,char);
41 PL_OpSpace = SLAB_SIZE - sz;
42 return PL_OpPtr += PL_OpSpace;
46 #define NewOp(m, var, c, type) Newz(m, var, c, type)
49 * In the following definition, the ", Nullop" is just to make the compiler
50 * think the expression is of the right type: croak actually does a Siglongjmp.
52 #define CHECKOP(type,o) \
53 ((PL_op_mask && PL_op_mask[type]) \
54 ? ( op_free((OP*)o), \
55 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
57 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
59 #define PAD_MAX 999999999
60 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
63 S_gv_ename(pTHX_ GV *gv)
66 SV* tmpsv = sv_newmortal();
67 gv_efullname3(tmpsv, gv, Nullch);
68 return SvPV(tmpsv,n_a);
72 S_no_fh_allowed(pTHX_ OP *o)
74 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
80 S_too_few_arguments(pTHX_ OP *o, char *name)
82 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
87 S_too_many_arguments(pTHX_ OP *o, char *name)
89 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
94 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
96 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
97 (int)n, name, t, OP_DESC(kid)));
101 S_no_bareword_allowed(pTHX_ OP *o)
103 qerror(Perl_mess(aTHX_
104 "Bareword \"%s\" not allowed while \"strict subs\" in use",
105 SvPV_nolen(cSVOPo_sv)));
108 /* "register" allocation */
111 Perl_pad_allocmy(pTHX_ char *name)
116 if (!(PL_in_my == KEY_our ||
118 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
119 (name[1] == '_' && (int)strlen(name) > 2)))
121 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
122 /* 1999-02-27 mjd@plover.com */
124 p = strchr(name, '\0');
125 /* The next block assumes the buffer is at least 205 chars
126 long. At present, it's always at least 256 chars. */
128 strcpy(name+200, "...");
134 /* Move everything else down one character */
135 for (; p-name > 2; p--)
137 name[2] = toCTRL(name[1]);
140 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
142 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
143 SV **svp = AvARRAY(PL_comppad_name);
144 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
145 PADOFFSET top = AvFILLp(PL_comppad_name);
146 for (off = top; off > PL_comppad_name_floor; off--) {
148 && sv != &PL_sv_undef
149 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
150 && (PL_in_my != KEY_our
151 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
152 && strEQ(name, SvPVX(sv)))
154 Perl_warner(aTHX_ WARN_MISC,
155 "\"%s\" variable %s masks earlier declaration in same %s",
156 (PL_in_my == KEY_our ? "our" : "my"),
158 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
163 if (PL_in_my == KEY_our) {
166 && sv != &PL_sv_undef
167 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
168 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
169 && strEQ(name, SvPVX(sv)))
171 Perl_warner(aTHX_ WARN_MISC,
172 "\"our\" variable %s redeclared", name);
173 Perl_warner(aTHX_ WARN_MISC,
174 "\t(Did you mean \"local\" instead of \"our\"?)\n");
177 } while ( off-- > 0 );
180 off = pad_alloc(OP_PADSV, SVs_PADMY);
182 sv_upgrade(sv, SVt_PVNV);
184 if (PL_in_my_stash) {
186 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
187 name, PL_in_my == KEY_our ? "our" : "my"));
188 SvFLAGS(sv) |= SVpad_TYPED;
189 (void)SvUPGRADE(sv, SVt_PVMG);
190 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
192 if (PL_in_my == KEY_our) {
193 (void)SvUPGRADE(sv, SVt_PVGV);
194 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
195 SvFLAGS(sv) |= SVpad_OUR;
197 av_store(PL_comppad_name, off, sv);
198 SvNVX(sv) = (NV)PAD_MAX;
199 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
200 if (!PL_min_intro_pending)
201 PL_min_intro_pending = off;
202 PL_max_intro_pending = off;
204 av_store(PL_comppad, off, (SV*)newAV());
205 else if (*name == '%')
206 av_store(PL_comppad, off, (SV*)newHV());
207 SvPADMY_on(PL_curpad[off]);
212 S_pad_addlex(pTHX_ SV *proto_namesv)
214 SV *namesv = NEWSV(1103,0);
215 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
216 sv_upgrade(namesv, SVt_PVNV);
217 sv_setpv(namesv, SvPVX(proto_namesv));
218 av_store(PL_comppad_name, newoff, namesv);
219 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
220 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
221 SvFAKE_on(namesv); /* A ref, not a real var */
222 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
223 SvFLAGS(namesv) |= SVpad_OUR;
224 (void)SvUPGRADE(namesv, SVt_PVGV);
225 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
227 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
228 SvFLAGS(namesv) |= SVpad_TYPED;
229 (void)SvUPGRADE(namesv, SVt_PVMG);
230 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
235 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
238 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
239 I32 cx_ix, I32 saweval, U32 flags)
245 register PERL_CONTEXT *cx;
247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
252 if (!svp || *svp == &PL_sv_undef)
255 svp = AvARRAY(curname);
256 for (off = AvFILLp(curname); off > 0; off--) {
257 if ((sv = svp[off]) &&
258 sv != &PL_sv_undef &&
260 seq > I_32(SvNVX(sv)) &&
261 strEQ(SvPVX(sv), name))
272 return 0; /* don't clone from inactive stack frame */
276 oldpad = (AV*)AvARRAY(curlist)[depth];
277 oldsv = *av_fetch(oldpad, off, TRUE);
278 if (!newoff) { /* Not a mere clone operation. */
279 newoff = pad_addlex(sv);
280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
281 /* "It's closures all the way down." */
282 CvCLONE_on(PL_compcv);
284 if (CvANON(PL_compcv))
285 oldsv = Nullsv; /* no need to keep ref */
290 bcv && bcv != cv && !CvCLONE(bcv);
291 bcv = CvOUTSIDE(bcv))
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
314 Perl_warner(aTHX_ WARN_CLOSURE,
315 "Variable \"%s\" may be unavailable",
323 else if (!CvUNIQUE(PL_compcv)) {
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
327 Perl_warner(aTHX_ WARN_CLOSURE,
328 "Variable \"%s\" will not stay shared", name);
332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
338 if (flags & FINDLEX_NOSEARCH)
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
346 for (i = cx_ix; i >= 0; i--) {
348 switch (CxTYPE(cx)) {
350 if (i == 0 && saweval) {
351 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
355 switch (cx->blk_eval.old_op_type) {
357 if (CxREALEVAL(cx)) {
360 seq = cxstack[i].blk_oldcop->cop_seq;
361 startcv = cxstack[i].blk_eval.cv;
362 if (startcv && CvOUTSIDE(startcv)) {
363 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
365 if (off) /* continue looking if not found here */
372 /* require/do must have their own scope */
381 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
382 saweval = i; /* so we know where we were called from */
383 seq = cxstack[i].blk_oldcop->cop_seq;
386 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
394 Perl_pad_findmy(pTHX_ char *name)
399 SV **svp = AvARRAY(PL_comppad_name);
400 U32 seq = PL_cop_seqmax;
404 #ifdef USE_5005THREADS
406 * Special case to get lexical (and hence per-thread) @_.
407 * XXX I need to find out how to tell at parse-time whether use
408 * of @_ should refer to a lexical (from a sub) or defgv (global
409 * scope and maybe weird sub-ish things like formats). See
410 * startsub in perly.y. It's possible that @_ could be lexical
411 * (at least from subs) even in non-threaded perl.
413 if (strEQ(name, "@_"))
414 return 0; /* success. (NOT_IN_PAD indicates failure) */
415 #endif /* USE_5005THREADS */
417 /* The one we're looking for is probably just before comppad_name_fill. */
418 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
419 if ((sv = svp[off]) &&
420 sv != &PL_sv_undef &&
423 seq > I_32(SvNVX(sv)))) &&
424 strEQ(SvPVX(sv), name))
426 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
427 return (PADOFFSET)off;
428 pendoff = off; /* this pending def. will override import */
432 outside = CvOUTSIDE(PL_compcv);
434 /* Check if if we're compiling an eval'', and adjust seq to be the
435 * eval's seq number. This depends on eval'' having a non-null
436 * CvOUTSIDE() while it is being compiled. The eval'' itself is
437 * identified by CvEVAL being true and CvGV being null. */
438 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
439 cx = &cxstack[cxstack_ix];
441 seq = cx->blk_oldcop->cop_seq;
444 /* See if it's in a nested scope */
445 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
447 /* If there is a pending local definition, this new alias must die */
449 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
450 return off; /* pad_findlex returns 0 for failure...*/
452 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
456 Perl_pad_leavemy(pTHX_ I32 fill)
459 SV **svp = AvARRAY(PL_comppad_name);
461 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
462 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
463 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
464 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
467 /* "Deintroduce" my variables that are leaving with this scope. */
468 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
469 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
470 SvIVX(sv) = PL_cop_seqmax;
475 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
480 if (AvARRAY(PL_comppad) != PL_curpad)
481 Perl_croak(aTHX_ "panic: pad_alloc");
482 if (PL_pad_reset_pending)
484 if (tmptype & SVs_PADMY) {
486 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
487 } while (SvPADBUSY(sv)); /* need a fresh one */
488 retval = AvFILLp(PL_comppad);
491 SV **names = AvARRAY(PL_comppad_name);
492 SSize_t names_fill = AvFILLp(PL_comppad_name);
495 * "foreach" index vars temporarily become aliases to non-"my"
496 * values. Thus we must skip, not just pad values that are
497 * marked as current pad values, but also those with names.
499 if (++PL_padix <= names_fill &&
500 (sv = names[PL_padix]) && sv != &PL_sv_undef)
502 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
503 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
504 !IS_PADGV(sv) && !IS_PADCONST(sv))
509 SvFLAGS(sv) |= tmptype;
510 PL_curpad = AvARRAY(PL_comppad);
511 #ifdef USE_5005THREADS
512 DEBUG_X(PerlIO_printf(Perl_debug_log,
513 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
514 PTR2UV(thr), PTR2UV(PL_curpad),
515 (long) retval, PL_op_name[optype]));
517 DEBUG_X(PerlIO_printf(Perl_debug_log,
518 "Pad 0x%"UVxf" alloc %ld for %s\n",
520 (long) retval, PL_op_name[optype]));
521 #endif /* USE_5005THREADS */
522 return (PADOFFSET)retval;
526 Perl_pad_sv(pTHX_ PADOFFSET po)
528 #ifdef USE_5005THREADS
529 DEBUG_X(PerlIO_printf(Perl_debug_log,
530 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
531 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
534 Perl_croak(aTHX_ "panic: pad_sv po");
535 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
536 PTR2UV(PL_curpad), (IV)po));
537 #endif /* USE_5005THREADS */
538 return PL_curpad[po]; /* eventually we'll turn this into a macro */
542 Perl_pad_free(pTHX_ PADOFFSET po)
546 if (AvARRAY(PL_comppad) != PL_curpad)
547 Perl_croak(aTHX_ "panic: pad_free curpad");
549 Perl_croak(aTHX_ "panic: pad_free po");
550 #ifdef USE_5005THREADS
551 DEBUG_X(PerlIO_printf(Perl_debug_log,
552 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
553 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
555 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
556 PTR2UV(PL_curpad), (IV)po));
557 #endif /* USE_5005THREADS */
558 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
559 SvPADTMP_off(PL_curpad[po]);
561 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
564 if ((I32)po < PL_padix)
569 Perl_pad_swipe(pTHX_ PADOFFSET po)
571 if (AvARRAY(PL_comppad) != PL_curpad)
572 Perl_croak(aTHX_ "panic: pad_swipe curpad");
574 Perl_croak(aTHX_ "panic: pad_swipe po");
575 #ifdef USE_5005THREADS
576 DEBUG_X(PerlIO_printf(Perl_debug_log,
577 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
580 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
581 PTR2UV(PL_curpad), (IV)po));
582 #endif /* USE_5005THREADS */
583 SvPADTMP_off(PL_curpad[po]);
584 PL_curpad[po] = NEWSV(1107,0);
585 SvPADTMP_on(PL_curpad[po]);
586 if ((I32)po < PL_padix)
590 /* XXX pad_reset() is currently disabled because it results in serious bugs.
591 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
592 * on the stack by OPs that use them, there are several ways to get an alias
593 * to a shared TARG. Such an alias will change randomly and unpredictably.
594 * We avoid doing this until we can think of a Better Way.
599 #ifdef USE_BROKEN_PAD_RESET
602 if (AvARRAY(PL_comppad) != PL_curpad)
603 Perl_croak(aTHX_ "panic: pad_reset curpad");
604 #ifdef USE_5005THREADS
605 DEBUG_X(PerlIO_printf(Perl_debug_log,
606 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
607 PTR2UV(thr), PTR2UV(PL_curpad)));
609 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
611 #endif /* USE_5005THREADS */
612 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
613 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
614 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
615 SvPADTMP_off(PL_curpad[po]);
617 PL_padix = PL_padix_floor;
620 PL_pad_reset_pending = FALSE;
623 #ifdef USE_5005THREADS
624 /* find_threadsv is not reentrant */
626 Perl_find_threadsv(pTHX_ const char *name)
631 /* We currently only handle names of a single character */
632 p = strchr(PL_threadsv_names, *name);
635 key = p - PL_threadsv_names;
636 MUTEX_LOCK(&thr->mutex);
637 svp = av_fetch(thr->threadsv, key, FALSE);
639 MUTEX_UNLOCK(&thr->mutex);
641 SV *sv = NEWSV(0, 0);
642 av_store(thr->threadsv, key, sv);
643 thr->threadsvp = AvARRAY(thr->threadsv);
644 MUTEX_UNLOCK(&thr->mutex);
646 * Some magic variables used to be automagically initialised
647 * in gv_fetchpv. Those which are now per-thread magicals get
648 * initialised here instead.
654 sv_setpv(sv, "\034");
655 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
660 PL_sawampersand = TRUE;
674 /* XXX %! tied to Errno.pm needs to be added here.
675 * See gv_fetchpv(). */
679 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
681 DEBUG_S(PerlIO_printf(Perl_error_log,
682 "find_threadsv: new SV %p for $%s%c\n",
683 sv, (*name < 32) ? "^" : "",
684 (*name < 32) ? toCTRL(*name) : *name));
688 #endif /* USE_5005THREADS */
693 Perl_op_free(pTHX_ OP *o)
695 register OP *kid, *nextkid;
698 if (!o || o->op_seq == (U16)-1)
701 if (o->op_private & OPpREFCOUNTED) {
702 switch (o->op_type) {
710 if (OpREFCNT_dec(o)) {
721 if (o->op_flags & OPf_KIDS) {
722 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
723 nextkid = kid->op_sibling; /* Get before next freeing kid */
731 /* COP* is not cleared by op_clear() so that we may track line
732 * numbers etc even after null() */
733 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
738 #ifdef PL_OP_SLAB_ALLOC
739 if ((char *) o == PL_OpPtr)
748 Perl_op_clear(pTHX_ OP *o)
751 switch (o->op_type) {
752 case OP_NULL: /* Was holding old type, if any. */
753 case OP_ENTEREVAL: /* Was holding hints. */
754 #ifdef USE_5005THREADS
755 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
759 #ifdef USE_5005THREADS
761 if (!(o->op_flags & OPf_SPECIAL))
764 #endif /* USE_5005THREADS */
766 if (!(o->op_flags & OPf_REF)
767 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
774 if (cPADOPo->op_padix > 0) {
777 pad_swipe(cPADOPo->op_padix);
778 /* No GvIN_PAD_off(gv) here, because other references may still
779 * exist on the pad */
782 cPADOPo->op_padix = 0;
785 SvREFCNT_dec(cSVOPo->op_sv);
786 cSVOPo->op_sv = Nullsv;
789 case OP_METHOD_NAMED:
791 SvREFCNT_dec(cSVOPo->op_sv);
792 cSVOPo->op_sv = Nullsv;
798 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
802 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
803 SvREFCNT_dec(cSVOPo->op_sv);
804 cSVOPo->op_sv = Nullsv;
807 Safefree(cPVOPo->op_pv);
808 cPVOPo->op_pv = Nullch;
812 op_free(cPMOPo->op_pmreplroot);
816 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
818 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
819 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
820 /* No GvIN_PAD_off(gv) here, because other references may still
821 * exist on the pad */
826 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
833 HV *pmstash = PmopSTASH(cPMOPo);
834 if (pmstash && SvREFCNT(pmstash)) {
835 PMOP *pmop = HvPMROOT(pmstash);
836 PMOP *lastpmop = NULL;
838 if (cPMOPo == pmop) {
840 lastpmop->op_pmnext = pmop->op_pmnext;
842 HvPMROOT(pmstash) = pmop->op_pmnext;
846 pmop = pmop->op_pmnext;
850 Safefree(PmopSTASHPV(cPMOPo));
852 /* NOTE: PMOP.op_pmstash is not refcounted */
855 cPMOPo->op_pmreplroot = Nullop;
856 /* we use the "SAFE" version of the PM_ macros here
857 * since sv_clean_all might release some PMOPs
858 * after PL_regex_padav has been cleared
859 * and the clearing of PL_regex_padav needs to
860 * happen before sv_clean_all
862 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
863 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
865 if(PL_regex_pad) { /* We could be in destruction */
866 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
867 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
868 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
875 if (o->op_targ > 0) {
876 pad_free(o->op_targ);
882 S_cop_free(pTHX_ COP* cop)
884 Safefree(cop->cop_label);
886 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
887 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
889 /* NOTE: COP.cop_stash is not refcounted */
890 SvREFCNT_dec(CopFILEGV(cop));
892 if (! specialWARN(cop->cop_warnings))
893 SvREFCNT_dec(cop->cop_warnings);
894 if (! specialCopIO(cop->cop_io))
895 SvREFCNT_dec(cop->cop_io);
899 Perl_op_null(pTHX_ OP *o)
901 if (o->op_type == OP_NULL)
904 o->op_targ = o->op_type;
905 o->op_type = OP_NULL;
906 o->op_ppaddr = PL_ppaddr[OP_NULL];
909 /* Contextualizers */
911 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
914 Perl_linklist(pTHX_ OP *o)
921 /* establish postfix order */
922 if (cUNOPo->op_first) {
923 o->op_next = LINKLIST(cUNOPo->op_first);
924 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
926 kid->op_next = LINKLIST(kid->op_sibling);
938 Perl_scalarkids(pTHX_ OP *o)
941 if (o && o->op_flags & OPf_KIDS) {
942 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
949 S_scalarboolean(pTHX_ OP *o)
951 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
952 if (ckWARN(WARN_SYNTAX)) {
953 line_t oldline = CopLINE(PL_curcop);
955 if (PL_copline != NOLINE)
956 CopLINE_set(PL_curcop, PL_copline);
957 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
958 CopLINE_set(PL_curcop, oldline);
965 Perl_scalar(pTHX_ OP *o)
969 /* assumes no premature commitment */
970 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
971 || o->op_type == OP_RETURN)
976 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
978 switch (o->op_type) {
980 scalar(cBINOPo->op_first);
985 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
989 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
990 if (!kPMOP->op_pmreplroot)
991 deprecate("implicit split to @_");
999 if (o->op_flags & OPf_KIDS) {
1000 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1006 kid = cLISTOPo->op_first;
1008 while ((kid = kid->op_sibling)) {
1009 if (kid->op_sibling)
1014 WITH_THR(PL_curcop = &PL_compiling);
1019 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1020 if (kid->op_sibling)
1025 WITH_THR(PL_curcop = &PL_compiling);
1032 Perl_scalarvoid(pTHX_ OP *o)
1039 if (o->op_type == OP_NEXTSTATE
1040 || o->op_type == OP_SETSTATE
1041 || o->op_type == OP_DBSTATE
1042 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1043 || o->op_targ == OP_SETSTATE
1044 || o->op_targ == OP_DBSTATE)))
1045 PL_curcop = (COP*)o; /* for warning below */
1047 /* assumes no premature commitment */
1048 want = o->op_flags & OPf_WANT;
1049 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1050 || o->op_type == OP_RETURN)
1055 if ((o->op_private & OPpTARGET_MY)
1056 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1058 return scalar(o); /* As if inside SASSIGN */
1061 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1063 switch (o->op_type) {
1065 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1069 if (o->op_flags & OPf_STACKED)
1073 if (o->op_private == 4)
1115 case OP_GETSOCKNAME:
1116 case OP_GETPEERNAME:
1121 case OP_GETPRIORITY:
1144 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1145 useless = OP_DESC(o);
1152 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1153 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1154 useless = "a variable";
1159 if (cSVOPo->op_private & OPpCONST_STRICT)
1160 no_bareword_allowed(o);
1162 if (ckWARN(WARN_VOID)) {
1163 useless = "a constant";
1164 /* the constants 0 and 1 are permitted as they are
1165 conventionally used as dummies in constructs like
1166 1 while some_condition_with_side_effects; */
1167 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1169 else if (SvPOK(sv)) {
1170 /* perl4's way of mixing documentation and code
1171 (before the invention of POD) was based on a
1172 trick to mix nroff and perl code. The trick was
1173 built upon these three nroff macros being used in
1174 void context. The pink camel has the details in
1175 the script wrapman near page 319. */
1176 if (strnEQ(SvPVX(sv), "di", 2) ||
1177 strnEQ(SvPVX(sv), "ds", 2) ||
1178 strnEQ(SvPVX(sv), "ig", 2))
1183 op_null(o); /* don't execute or even remember it */
1187 o->op_type = OP_PREINC; /* pre-increment is faster */
1188 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1192 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1193 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1199 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1204 if (o->op_flags & OPf_STACKED)
1211 if (!(o->op_flags & OPf_KIDS))
1220 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1227 /* all requires must return a boolean value */
1228 o->op_flags &= ~OPf_WANT;
1233 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1234 if (!kPMOP->op_pmreplroot)
1235 deprecate("implicit split to @_");
1239 if (useless && ckWARN(WARN_VOID))
1240 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1245 Perl_listkids(pTHX_ OP *o)
1248 if (o && o->op_flags & OPf_KIDS) {
1249 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1256 Perl_list(pTHX_ OP *o)
1260 /* assumes no premature commitment */
1261 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1262 || o->op_type == OP_RETURN)
1267 if ((o->op_private & OPpTARGET_MY)
1268 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1270 return o; /* As if inside SASSIGN */
1273 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1275 switch (o->op_type) {
1278 list(cBINOPo->op_first);
1283 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1291 if (!(o->op_flags & OPf_KIDS))
1293 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1294 list(cBINOPo->op_first);
1295 return gen_constant_list(o);
1302 kid = cLISTOPo->op_first;
1304 while ((kid = kid->op_sibling)) {
1305 if (kid->op_sibling)
1310 WITH_THR(PL_curcop = &PL_compiling);
1314 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1315 if (kid->op_sibling)
1320 WITH_THR(PL_curcop = &PL_compiling);
1323 /* all requires must return a boolean value */
1324 o->op_flags &= ~OPf_WANT;
1331 Perl_scalarseq(pTHX_ OP *o)
1336 if (o->op_type == OP_LINESEQ ||
1337 o->op_type == OP_SCOPE ||
1338 o->op_type == OP_LEAVE ||
1339 o->op_type == OP_LEAVETRY)
1341 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1342 if (kid->op_sibling) {
1346 PL_curcop = &PL_compiling;
1348 o->op_flags &= ~OPf_PARENS;
1349 if (PL_hints & HINT_BLOCK_SCOPE)
1350 o->op_flags |= OPf_PARENS;
1353 o = newOP(OP_STUB, 0);
1358 S_modkids(pTHX_ OP *o, I32 type)
1361 if (o && o->op_flags & OPf_KIDS) {
1362 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1369 Perl_mod(pTHX_ OP *o, I32 type)
1374 if (!o || PL_error_count)
1377 if ((o->op_private & OPpTARGET_MY)
1378 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1383 switch (o->op_type) {
1388 if (!(o->op_private & (OPpCONST_ARYBASE)))
1390 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1391 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1395 SAVEI32(PL_compiling.cop_arybase);
1396 PL_compiling.cop_arybase = 0;
1398 else if (type == OP_REFGEN)
1401 Perl_croak(aTHX_ "That use of $[ is unsupported");
1404 if (o->op_flags & OPf_PARENS)
1408 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1409 !(o->op_flags & OPf_STACKED)) {
1410 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1411 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1412 assert(cUNOPo->op_first->op_type == OP_NULL);
1413 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1416 else { /* lvalue subroutine call */
1417 o->op_private |= OPpLVAL_INTRO;
1418 PL_modcount = RETURN_UNLIMITED_NUMBER;
1419 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1420 /* Backward compatibility mode: */
1421 o->op_private |= OPpENTERSUB_INARGS;
1424 else { /* Compile-time error message: */
1425 OP *kid = cUNOPo->op_first;
1429 if (kid->op_type == OP_PUSHMARK)
1431 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1433 "panic: unexpected lvalue entersub "
1434 "args: type/targ %ld:%"UVuf,
1435 (long)kid->op_type, (UV)kid->op_targ);
1436 kid = kLISTOP->op_first;
1438 while (kid->op_sibling)
1439 kid = kid->op_sibling;
1440 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1442 if (kid->op_type == OP_METHOD_NAMED
1443 || kid->op_type == OP_METHOD)
1447 if (kid->op_sibling || kid->op_next != kid) {
1448 yyerror("panic: unexpected optree near method call");
1452 NewOp(1101, newop, 1, UNOP);
1453 newop->op_type = OP_RV2CV;
1454 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1455 newop->op_first = Nullop;
1456 newop->op_next = (OP*)newop;
1457 kid->op_sibling = (OP*)newop;
1458 newop->op_private |= OPpLVAL_INTRO;
1462 if (kid->op_type != OP_RV2CV)
1464 "panic: unexpected lvalue entersub "
1465 "entry via type/targ %ld:%"UVuf,
1466 (long)kid->op_type, (UV)kid->op_targ);
1467 kid->op_private |= OPpLVAL_INTRO;
1468 break; /* Postpone until runtime */
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1474 kid = kUNOP->op_first;
1475 if (kid->op_type == OP_NULL)
1477 "Unexpected constant lvalue entersub "
1478 "entry via type/targ %ld:%"UVuf,
1479 (long)kid->op_type, (UV)kid->op_targ);
1480 if (kid->op_type != OP_GV) {
1481 /* Restore RV2CV to check lvalueness */
1483 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1484 okid->op_next = kid->op_next;
1485 kid->op_next = okid;
1488 okid->op_next = Nullop;
1489 okid->op_type = OP_RV2CV;
1491 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1492 okid->op_private |= OPpLVAL_INTRO;
1496 cv = GvCV(kGVOP_gv);
1506 /* grep, foreach, subcalls, refgen */
1507 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1509 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1510 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1512 : (o->op_type == OP_ENTERSUB
1513 ? "non-lvalue subroutine call"
1515 type ? PL_op_desc[type] : "local"));
1529 case OP_RIGHT_SHIFT:
1538 if (!(o->op_flags & OPf_STACKED))
1544 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1550 if (!type && cUNOPo->op_first->op_type != OP_GV)
1551 Perl_croak(aTHX_ "Can't localize through a reference");
1552 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1553 PL_modcount = RETURN_UNLIMITED_NUMBER;
1554 return o; /* Treat \(@foo) like ordinary list. */
1558 if (scalar_mod_type(o, type))
1560 ref(cUNOPo->op_first, o->op_type);
1564 if (type == OP_LEAVESUBLV)
1565 o->op_private |= OPpMAYBE_LVSUB;
1571 PL_modcount = RETURN_UNLIMITED_NUMBER;
1574 if (!type && cUNOPo->op_first->op_type != OP_GV)
1575 Perl_croak(aTHX_ "Can't localize through a reference");
1576 ref(cUNOPo->op_first, o->op_type);
1580 PL_hints |= HINT_BLOCK_SCOPE;
1590 PL_modcount = RETURN_UNLIMITED_NUMBER;
1591 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1592 return o; /* Treat \(@foo) like ordinary list. */
1593 if (scalar_mod_type(o, type))
1595 if (type == OP_LEAVESUBLV)
1596 o->op_private |= OPpMAYBE_LVSUB;
1601 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1602 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1605 #ifdef USE_5005THREADS
1607 PL_modcount++; /* XXX ??? */
1609 #endif /* USE_5005THREADS */
1615 if (type != OP_SASSIGN)
1619 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1624 if (type == OP_LEAVESUBLV)
1625 o->op_private |= OPpMAYBE_LVSUB;
1627 pad_free(o->op_targ);
1628 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1629 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1630 if (o->op_flags & OPf_KIDS)
1631 mod(cBINOPo->op_first->op_sibling, type);
1636 ref(cBINOPo->op_first, o->op_type);
1637 if (type == OP_ENTERSUB &&
1638 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1639 o->op_private |= OPpLVAL_DEFER;
1640 if (type == OP_LEAVESUBLV)
1641 o->op_private |= OPpMAYBE_LVSUB;
1649 if (o->op_flags & OPf_KIDS)
1650 mod(cLISTOPo->op_last, type);
1654 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1656 else if (!(o->op_flags & OPf_KIDS))
1658 if (o->op_targ != OP_LIST) {
1659 mod(cBINOPo->op_first, type);
1664 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1669 if (type != OP_LEAVESUBLV)
1671 break; /* mod()ing was handled by ck_return() */
1673 if (type != OP_LEAVESUBLV)
1674 o->op_flags |= OPf_MOD;
1676 if (type == OP_AASSIGN || type == OP_SASSIGN)
1677 o->op_flags |= OPf_SPECIAL|OPf_REF;
1679 o->op_private |= OPpLVAL_INTRO;
1680 o->op_flags &= ~OPf_SPECIAL;
1681 PL_hints |= HINT_BLOCK_SCOPE;
1683 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1684 && type != OP_LEAVESUBLV)
1685 o->op_flags |= OPf_REF;
1690 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1694 if (o->op_type == OP_RV2GV)
1718 case OP_RIGHT_SHIFT:
1737 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1739 switch (o->op_type) {
1747 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1760 Perl_refkids(pTHX_ OP *o, I32 type)
1763 if (o && o->op_flags & OPf_KIDS) {
1764 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1771 Perl_ref(pTHX_ OP *o, I32 type)
1775 if (!o || PL_error_count)
1778 switch (o->op_type) {
1780 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1781 !(o->op_flags & OPf_STACKED)) {
1782 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1783 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1784 assert(cUNOPo->op_first->op_type == OP_NULL);
1785 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1786 o->op_flags |= OPf_SPECIAL;
1791 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1795 if (type == OP_DEFINED)
1796 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1797 ref(cUNOPo->op_first, o->op_type);
1800 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1801 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1802 : type == OP_RV2HV ? OPpDEREF_HV
1804 o->op_flags |= OPf_MOD;
1809 o->op_flags |= OPf_MOD; /* XXX ??? */
1814 o->op_flags |= OPf_REF;
1817 if (type == OP_DEFINED)
1818 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1819 ref(cUNOPo->op_first, o->op_type);
1824 o->op_flags |= OPf_REF;
1829 if (!(o->op_flags & OPf_KIDS))
1831 ref(cBINOPo->op_first, type);
1835 ref(cBINOPo->op_first, o->op_type);
1836 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1837 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1838 : type == OP_RV2HV ? OPpDEREF_HV
1840 o->op_flags |= OPf_MOD;
1848 if (!(o->op_flags & OPf_KIDS))
1850 ref(cLISTOPo->op_last, type);
1860 S_dup_attrlist(pTHX_ OP *o)
1864 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1865 * where the first kid is OP_PUSHMARK and the remaining ones
1866 * are OP_CONST. We need to push the OP_CONST values.
1868 if (o->op_type == OP_CONST)
1869 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1871 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1872 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1873 if (o->op_type == OP_CONST)
1874 rop = append_elem(OP_LIST, rop,
1875 newSVOP(OP_CONST, o->op_flags,
1876 SvREFCNT_inc(cSVOPo->op_sv)));
1883 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1887 /* fake up C<use attributes $pkg,$rv,@attrs> */
1888 ENTER; /* need to protect against side-effects of 'use' */
1891 stashsv = newSVpv(HvNAME(stash), 0);
1893 stashsv = &PL_sv_no;
1895 #define ATTRSMODULE "attributes"
1897 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1898 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1900 prepend_elem(OP_LIST,
1901 newSVOP(OP_CONST, 0, stashsv),
1902 prepend_elem(OP_LIST,
1903 newSVOP(OP_CONST, 0,
1905 dup_attrlist(attrs))));
1910 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1911 char *attrstr, STRLEN len)
1916 len = strlen(attrstr);
1920 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1922 char *sstr = attrstr;
1923 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1924 attrs = append_elem(OP_LIST, attrs,
1925 newSVOP(OP_CONST, 0,
1926 newSVpvn(sstr, attrstr-sstr)));
1930 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1931 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1932 Nullsv, prepend_elem(OP_LIST,
1933 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1934 prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0,
1941 S_my_kid(pTHX_ OP *o, OP *attrs)
1946 if (!o || PL_error_count)
1950 if (type == OP_LIST) {
1951 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1953 } else if (type == OP_UNDEF) {
1955 } else if (type == OP_RV2SV || /* "our" declaration */
1957 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1959 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1961 PL_in_my_stash = Nullhv;
1962 apply_attrs(GvSTASH(gv),
1963 (type == OP_RV2SV ? GvSV(gv) :
1964 type == OP_RV2AV ? (SV*)GvAV(gv) :
1965 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1968 o->op_private |= OPpOUR_INTRO;
1970 } else if (type != OP_PADSV &&
1973 type != OP_PUSHMARK)
1975 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1977 PL_in_my == KEY_our ? "our" : "my"));
1980 else if (attrs && type != OP_PUSHMARK) {
1986 PL_in_my_stash = Nullhv;
1988 /* check for C<my Dog $spot> when deciding package */
1989 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1990 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1991 stash = SvSTASH(*namesvp);
1993 stash = PL_curstash;
1994 padsv = PAD_SV(o->op_targ);
1995 apply_attrs(stash, padsv, attrs);
1997 o->op_flags |= OPf_MOD;
1998 o->op_private |= OPpLVAL_INTRO;
2003 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2005 if (o->op_flags & OPf_PARENS)
2009 o = my_kid(o, attrs);
2011 PL_in_my_stash = Nullhv;
2016 Perl_my(pTHX_ OP *o)
2018 return my_kid(o, Nullop);
2022 Perl_sawparens(pTHX_ OP *o)
2025 o->op_flags |= OPf_PARENS;
2030 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2034 if (ckWARN(WARN_MISC) &&
2035 (left->op_type == OP_RV2AV ||
2036 left->op_type == OP_RV2HV ||
2037 left->op_type == OP_PADAV ||
2038 left->op_type == OP_PADHV)) {
2039 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2040 right->op_type == OP_TRANS)
2041 ? right->op_type : OP_MATCH];
2042 const char *sample = ((left->op_type == OP_RV2AV ||
2043 left->op_type == OP_PADAV)
2044 ? "@array" : "%hash");
2045 Perl_warner(aTHX_ WARN_MISC,
2046 "Applying %s to %s will act on scalar(%s)",
2047 desc, sample, sample);
2050 if (!(right->op_flags & OPf_STACKED) &&
2051 (right->op_type == OP_MATCH ||
2052 right->op_type == OP_SUBST ||
2053 right->op_type == OP_TRANS)) {
2054 right->op_flags |= OPf_STACKED;
2055 if ((right->op_type != OP_MATCH &&
2056 ! (right->op_type == OP_TRANS &&
2057 right->op_private & OPpTRANS_IDENTICAL)) ||
2058 /* if SV has magic, then match on original SV, not on its copy.
2059 see note in pp_helem() */
2060 (right->op_type == OP_MATCH &&
2061 (left->op_type == OP_AELEM ||
2062 left->op_type == OP_HELEM ||
2063 left->op_type == OP_AELEMFAST)))
2064 left = mod(left, right->op_type);
2065 if (right->op_type == OP_TRANS)
2066 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2068 o = prepend_elem(right->op_type, scalar(left), right);
2070 return newUNOP(OP_NOT, 0, scalar(o));
2074 return bind_match(type, left,
2075 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2079 Perl_invert(pTHX_ OP *o)
2083 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2084 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2088 Perl_scope(pTHX_ OP *o)
2091 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2092 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2093 o->op_type = OP_LEAVE;
2094 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2097 if (o->op_type == OP_LINESEQ) {
2099 o->op_type = OP_SCOPE;
2100 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2101 kid = ((LISTOP*)o)->op_first;
2102 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2106 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2113 Perl_save_hints(pTHX)
2116 SAVESPTR(GvHV(PL_hintgv));
2117 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2118 SAVEFREESV(GvHV(PL_hintgv));
2122 Perl_block_start(pTHX_ int full)
2124 int retval = PL_savestack_ix;
2126 SAVEI32(PL_comppad_name_floor);
2127 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2129 PL_comppad_name_fill = PL_comppad_name_floor;
2130 if (PL_comppad_name_floor < 0)
2131 PL_comppad_name_floor = 0;
2132 SAVEI32(PL_min_intro_pending);
2133 SAVEI32(PL_max_intro_pending);
2134 PL_min_intro_pending = 0;
2135 SAVEI32(PL_comppad_name_fill);
2136 SAVEI32(PL_padix_floor);
2137 PL_padix_floor = PL_padix;
2138 PL_pad_reset_pending = FALSE;
2140 PL_hints &= ~HINT_BLOCK_SCOPE;
2141 SAVESPTR(PL_compiling.cop_warnings);
2142 if (! specialWARN(PL_compiling.cop_warnings)) {
2143 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2144 SAVEFREESV(PL_compiling.cop_warnings) ;
2146 SAVESPTR(PL_compiling.cop_io);
2147 if (! specialCopIO(PL_compiling.cop_io)) {
2148 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2149 SAVEFREESV(PL_compiling.cop_io) ;
2155 Perl_block_end(pTHX_ I32 floor, OP *seq)
2157 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2158 line_t copline = PL_copline;
2159 /* there should be a nextstate in every block */
2160 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2161 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2163 PL_pad_reset_pending = FALSE;
2164 PL_compiling.op_private = PL_hints;
2166 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2167 pad_leavemy(PL_comppad_name_fill);
2175 #ifdef USE_5005THREADS
2176 OP *o = newOP(OP_THREADSV, 0);
2177 o->op_targ = find_threadsv("_");
2180 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2181 #endif /* USE_5005THREADS */
2185 Perl_newPROG(pTHX_ OP *o)
2190 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2191 ((PL_in_eval & EVAL_KEEPERR)
2192 ? OPf_SPECIAL : 0), o);
2193 PL_eval_start = linklist(PL_eval_root);
2194 PL_eval_root->op_private |= OPpREFCOUNTED;
2195 OpREFCNT_set(PL_eval_root, 1);
2196 PL_eval_root->op_next = 0;
2197 CALL_PEEP(PL_eval_start);
2202 PL_main_root = scope(sawparens(scalarvoid(o)));
2203 PL_curcop = &PL_compiling;
2204 PL_main_start = LINKLIST(PL_main_root);
2205 PL_main_root->op_private |= OPpREFCOUNTED;
2206 OpREFCNT_set(PL_main_root, 1);
2207 PL_main_root->op_next = 0;
2208 CALL_PEEP(PL_main_start);
2211 /* Register with debugger */
2213 CV *cv = get_cv("DB::postponed", FALSE);
2217 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2219 call_sv((SV*)cv, G_DISCARD);
2226 Perl_localize(pTHX_ OP *o, I32 lex)
2228 if (o->op_flags & OPf_PARENS)
2231 if (ckWARN(WARN_PARENTHESIS)
2232 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2234 char *s = PL_bufptr;
2236 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2239 if (*s == ';' || *s == '=')
2240 Perl_warner(aTHX_ WARN_PARENTHESIS,
2241 "Parentheses missing around \"%s\" list",
2242 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2248 o = mod(o, OP_NULL); /* a bit kludgey */
2250 PL_in_my_stash = Nullhv;
2255 Perl_jmaybe(pTHX_ OP *o)
2257 if (o->op_type == OP_LIST) {
2259 #ifdef USE_5005THREADS
2260 o2 = newOP(OP_THREADSV, 0);
2261 o2->op_targ = find_threadsv(";");
2263 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2264 #endif /* USE_5005THREADS */
2265 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2271 Perl_fold_constants(pTHX_ register OP *o)
2274 I32 type = o->op_type;
2277 if (PL_opargs[type] & OA_RETSCALAR)
2279 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2280 o->op_targ = pad_alloc(type, SVs_PADTMP);
2282 /* integerize op, unless it happens to be C<-foo>.
2283 * XXX should pp_i_negate() do magic string negation instead? */
2284 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2285 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2286 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2288 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2291 if (!(PL_opargs[type] & OA_FOLDCONST))
2296 /* XXX might want a ck_negate() for this */
2297 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2309 /* XXX what about the numeric ops? */
2310 if (PL_hints & HINT_LOCALE)
2315 goto nope; /* Don't try to run w/ errors */
2317 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2318 if ((curop->op_type != OP_CONST ||
2319 (curop->op_private & OPpCONST_BARE)) &&
2320 curop->op_type != OP_LIST &&
2321 curop->op_type != OP_SCALAR &&
2322 curop->op_type != OP_NULL &&
2323 curop->op_type != OP_PUSHMARK)
2329 curop = LINKLIST(o);
2333 sv = *(PL_stack_sp--);
2334 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2335 pad_swipe(o->op_targ);
2336 else if (SvTEMP(sv)) { /* grab mortal temp? */
2337 (void)SvREFCNT_inc(sv);
2341 if (type == OP_RV2GV)
2342 return newGVOP(OP_GV, 0, (GV*)sv);
2344 /* try to smush double to int, but don't smush -2.0 to -2 */
2345 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2348 #ifdef PERL_PRESERVE_IVUV
2349 /* Only bother to attempt to fold to IV if
2350 most operators will benefit */
2354 return newSVOP(OP_CONST, 0, sv);
2358 if (!(PL_opargs[type] & OA_OTHERINT))
2361 if (!(PL_hints & HINT_INTEGER)) {
2362 if (type == OP_MODULO
2363 || type == OP_DIVIDE
2364 || !(o->op_flags & OPf_KIDS))
2369 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2370 if (curop->op_type == OP_CONST) {
2371 if (SvIOK(((SVOP*)curop)->op_sv))
2375 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2379 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2386 Perl_gen_constant_list(pTHX_ register OP *o)
2389 I32 oldtmps_floor = PL_tmps_floor;
2393 return o; /* Don't attempt to run with errors */
2395 PL_op = curop = LINKLIST(o);
2402 PL_tmps_floor = oldtmps_floor;
2404 o->op_type = OP_RV2AV;
2405 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2406 curop = ((UNOP*)o)->op_first;
2407 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2414 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2416 if (!o || o->op_type != OP_LIST)
2417 o = newLISTOP(OP_LIST, 0, o, Nullop);
2419 o->op_flags &= ~OPf_WANT;
2421 if (!(PL_opargs[type] & OA_MARK))
2422 op_null(cLISTOPo->op_first);
2425 o->op_ppaddr = PL_ppaddr[type];
2426 o->op_flags |= flags;
2428 o = CHECKOP(type, o);
2429 if (o->op_type != type)
2432 return fold_constants(o);
2435 /* List constructors */
2438 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2446 if (first->op_type != type
2447 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2449 return newLISTOP(type, 0, first, last);
2452 if (first->op_flags & OPf_KIDS)
2453 ((LISTOP*)first)->op_last->op_sibling = last;
2455 first->op_flags |= OPf_KIDS;
2456 ((LISTOP*)first)->op_first = last;
2458 ((LISTOP*)first)->op_last = last;
2463 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2471 if (first->op_type != type)
2472 return prepend_elem(type, (OP*)first, (OP*)last);
2474 if (last->op_type != type)
2475 return append_elem(type, (OP*)first, (OP*)last);
2477 first->op_last->op_sibling = last->op_first;
2478 first->op_last = last->op_last;
2479 first->op_flags |= (last->op_flags & OPf_KIDS);
2481 #ifdef PL_OP_SLAB_ALLOC
2489 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2497 if (last->op_type == type) {
2498 if (type == OP_LIST) { /* already a PUSHMARK there */
2499 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2500 ((LISTOP*)last)->op_first->op_sibling = first;
2501 if (!(first->op_flags & OPf_PARENS))
2502 last->op_flags &= ~OPf_PARENS;
2505 if (!(last->op_flags & OPf_KIDS)) {
2506 ((LISTOP*)last)->op_last = first;
2507 last->op_flags |= OPf_KIDS;
2509 first->op_sibling = ((LISTOP*)last)->op_first;
2510 ((LISTOP*)last)->op_first = first;
2512 last->op_flags |= OPf_KIDS;
2516 return newLISTOP(type, 0, first, last);
2522 Perl_newNULLLIST(pTHX)
2524 return newOP(OP_STUB, 0);
2528 Perl_force_list(pTHX_ OP *o)
2530 if (!o || o->op_type != OP_LIST)
2531 o = newLISTOP(OP_LIST, 0, o, Nullop);
2537 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2541 NewOp(1101, listop, 1, LISTOP);
2543 listop->op_type = type;
2544 listop->op_ppaddr = PL_ppaddr[type];
2547 listop->op_flags = flags;
2551 else if (!first && last)
2554 first->op_sibling = last;
2555 listop->op_first = first;
2556 listop->op_last = last;
2557 if (type == OP_LIST) {
2559 pushop = newOP(OP_PUSHMARK, 0);
2560 pushop->op_sibling = first;
2561 listop->op_first = pushop;
2562 listop->op_flags |= OPf_KIDS;
2564 listop->op_last = pushop;
2571 Perl_newOP(pTHX_ I32 type, I32 flags)
2574 NewOp(1101, o, 1, OP);
2576 o->op_ppaddr = PL_ppaddr[type];
2577 o->op_flags = flags;
2580 o->op_private = 0 + (flags >> 8);
2581 if (PL_opargs[type] & OA_RETSCALAR)
2583 if (PL_opargs[type] & OA_TARGET)
2584 o->op_targ = pad_alloc(type, SVs_PADTMP);
2585 return CHECKOP(type, o);
2589 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2594 first = newOP(OP_STUB, 0);
2595 if (PL_opargs[type] & OA_MARK)
2596 first = force_list(first);
2598 NewOp(1101, unop, 1, UNOP);
2599 unop->op_type = type;
2600 unop->op_ppaddr = PL_ppaddr[type];
2601 unop->op_first = first;
2602 unop->op_flags = flags | OPf_KIDS;
2603 unop->op_private = 1 | (flags >> 8);
2604 unop = (UNOP*) CHECKOP(type, unop);
2608 return fold_constants((OP *) unop);
2612 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2615 NewOp(1101, binop, 1, BINOP);
2618 first = newOP(OP_NULL, 0);
2620 binop->op_type = type;
2621 binop->op_ppaddr = PL_ppaddr[type];
2622 binop->op_first = first;
2623 binop->op_flags = flags | OPf_KIDS;
2626 binop->op_private = 1 | (flags >> 8);
2629 binop->op_private = 2 | (flags >> 8);
2630 first->op_sibling = last;
2633 binop = (BINOP*)CHECKOP(type, binop);
2634 if (binop->op_next || binop->op_type != type)
2637 binop->op_last = binop->op_first->op_sibling;
2639 return fold_constants((OP *)binop);
2643 uvcompare(const void *a, const void *b)
2645 if (*((UV *)a) < (*(UV *)b))
2647 if (*((UV *)a) > (*(UV *)b))
2649 if (*((UV *)a+1) < (*(UV *)b+1))
2651 if (*((UV *)a+1) > (*(UV *)b+1))
2657 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2659 SV *tstr = ((SVOP*)expr)->op_sv;
2660 SV *rstr = ((SVOP*)repl)->op_sv;
2663 U8 *t = (U8*)SvPV(tstr, tlen);
2664 U8 *r = (U8*)SvPV(rstr, rlen);
2671 register short *tbl;
2673 PL_hints |= HINT_BLOCK_SCOPE;
2674 complement = o->op_private & OPpTRANS_COMPLEMENT;
2675 del = o->op_private & OPpTRANS_DELETE;
2676 squash = o->op_private & OPpTRANS_SQUASH;
2679 o->op_private |= OPpTRANS_FROM_UTF;
2682 o->op_private |= OPpTRANS_TO_UTF;
2684 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2685 SV* listsv = newSVpvn("# comment\n",10);
2687 U8* tend = t + tlen;
2688 U8* rend = r + rlen;
2702 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2703 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2709 tsave = t = bytes_to_utf8(t, &len);
2712 if (!to_utf && rlen) {
2714 rsave = r = bytes_to_utf8(r, &len);
2718 /* There are several snags with this code on EBCDIC:
2719 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2720 2. scan_const() in toke.c has encoded chars in native encoding which makes
2721 ranges at least in EBCDIC 0..255 range the bottom odd.
2725 U8 tmpbuf[UTF8_MAXLEN+1];
2728 New(1109, cp, 2*tlen, UV);
2730 transv = newSVpvn("",0);
2732 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2734 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2736 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2740 cp[2*i+1] = cp[2*i];
2744 qsort(cp, i, 2*sizeof(UV), uvcompare);
2745 for (j = 0; j < i; j++) {
2747 diff = val - nextmin;
2749 t = uvuni_to_utf8(tmpbuf,nextmin);
2750 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2752 U8 range_mark = UTF_TO_NATIVE(0xff);
2753 t = uvuni_to_utf8(tmpbuf, val - 1);
2754 sv_catpvn(transv, (char *)&range_mark, 1);
2755 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2762 t = uvuni_to_utf8(tmpbuf,nextmin);
2763 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2765 U8 range_mark = UTF_TO_NATIVE(0xff);
2766 sv_catpvn(transv, (char *)&range_mark, 1);
2768 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2769 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2770 t = (U8*)SvPVX(transv);
2771 tlen = SvCUR(transv);
2775 else if (!rlen && !del) {
2776 r = t; rlen = tlen; rend = tend;
2779 if ((!rlen && !del) || t == r ||
2780 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2782 o->op_private |= OPpTRANS_IDENTICAL;
2786 while (t < tend || tfirst <= tlast) {
2787 /* see if we need more "t" chars */
2788 if (tfirst > tlast) {
2789 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2791 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2793 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2800 /* now see if we need more "r" chars */
2801 if (rfirst > rlast) {
2803 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2805 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2807 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2816 rfirst = rlast = 0xffffffff;
2820 /* now see which range will peter our first, if either. */
2821 tdiff = tlast - tfirst;
2822 rdiff = rlast - rfirst;
2829 if (rfirst == 0xffffffff) {
2830 diff = tdiff; /* oops, pretend rdiff is infinite */
2832 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2833 (long)tfirst, (long)tlast);
2835 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2839 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2840 (long)tfirst, (long)(tfirst + diff),
2843 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2844 (long)tfirst, (long)rfirst);
2846 if (rfirst + diff > max)
2847 max = rfirst + diff;
2849 grows = (tfirst < rfirst &&
2850 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2862 else if (max > 0xff)
2867 Safefree(cPVOPo->op_pv);
2868 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2869 SvREFCNT_dec(listsv);
2871 SvREFCNT_dec(transv);
2873 if (!del && havefinal && rlen)
2874 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2875 newSVuv((UV)final), 0);
2878 o->op_private |= OPpTRANS_GROWS;
2890 tbl = (short*)cPVOPo->op_pv;
2892 Zero(tbl, 256, short);
2893 for (i = 0; i < tlen; i++)
2895 for (i = 0, j = 0; i < 256; i++) {
2906 if (i < 128 && r[j] >= 128)
2916 o->op_private |= OPpTRANS_IDENTICAL;
2921 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2922 tbl[0x100] = rlen - j;
2923 for (i=0; i < rlen - j; i++)
2924 tbl[0x101+i] = r[j+i];
2928 if (!rlen && !del) {
2931 o->op_private |= OPpTRANS_IDENTICAL;
2933 for (i = 0; i < 256; i++)
2935 for (i = 0, j = 0; i < tlen; i++,j++) {
2938 if (tbl[t[i]] == -1)
2944 if (tbl[t[i]] == -1) {
2945 if (t[i] < 128 && r[j] >= 128)
2952 o->op_private |= OPpTRANS_GROWS;
2960 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2964 NewOp(1101, pmop, 1, PMOP);
2965 pmop->op_type = type;
2966 pmop->op_ppaddr = PL_ppaddr[type];
2967 pmop->op_flags = flags;
2968 pmop->op_private = 0 | (flags >> 8);
2970 if (PL_hints & HINT_RE_TAINT)
2971 pmop->op_pmpermflags |= PMf_RETAINT;
2972 if (PL_hints & HINT_LOCALE)
2973 pmop->op_pmpermflags |= PMf_LOCALE;
2974 pmop->op_pmflags = pmop->op_pmpermflags;
2979 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2980 repointer = av_pop((AV*)PL_regex_pad[0]);
2981 pmop->op_pmoffset = SvIV(repointer);
2982 SvREPADTMP_off(repointer);
2983 sv_setiv(repointer,0);
2985 repointer = newSViv(0);
2986 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2987 pmop->op_pmoffset = av_len(PL_regex_padav);
2988 PL_regex_pad = AvARRAY(PL_regex_padav);
2993 /* link into pm list */
2994 if (type != OP_TRANS && PL_curstash) {
2995 pmop->op_pmnext = HvPMROOT(PL_curstash);
2996 HvPMROOT(PL_curstash) = pmop;
2997 PmopSTASH_set(pmop,PL_curstash);
3004 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3008 I32 repl_has_vars = 0;
3010 if (o->op_type == OP_TRANS)
3011 return pmtrans(o, expr, repl);
3013 PL_hints |= HINT_BLOCK_SCOPE;
3016 if (expr->op_type == OP_CONST) {
3018 SV *pat = ((SVOP*)expr)->op_sv;
3019 char *p = SvPV(pat, plen);
3020 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3021 sv_setpvn(pat, "\\s+", 3);
3022 p = SvPV(pat, plen);
3023 pm->op_pmflags |= PMf_SKIPWHITE;
3025 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3026 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3027 pm->op_pmflags |= PMf_WHITE;
3031 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3032 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3034 : OP_REGCMAYBE),0,expr);
3036 NewOp(1101, rcop, 1, LOGOP);
3037 rcop->op_type = OP_REGCOMP;
3038 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3039 rcop->op_first = scalar(expr);
3040 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3041 ? (OPf_SPECIAL | OPf_KIDS)
3043 rcop->op_private = 1;
3046 /* establish postfix order */
3047 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3049 rcop->op_next = expr;
3050 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3053 rcop->op_next = LINKLIST(expr);
3054 expr->op_next = (OP*)rcop;
3057 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3062 if (pm->op_pmflags & PMf_EVAL) {
3064 if (CopLINE(PL_curcop) < PL_multi_end)
3065 CopLINE_set(PL_curcop, PL_multi_end);
3067 #ifdef USE_5005THREADS
3068 else if (repl->op_type == OP_THREADSV
3069 && strchr("&`'123456789+",
3070 PL_threadsv_names[repl->op_targ]))
3074 #endif /* USE_5005THREADS */
3075 else if (repl->op_type == OP_CONST)
3079 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3080 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3081 #ifdef USE_5005THREADS
3082 if (curop->op_type == OP_THREADSV) {
3084 if (strchr("&`'123456789+", curop->op_private))
3088 if (curop->op_type == OP_GV) {
3089 GV *gv = cGVOPx_gv(curop);
3091 if (strchr("&`'123456789+", *GvENAME(gv)))
3094 #endif /* USE_5005THREADS */
3095 else if (curop->op_type == OP_RV2CV)
3097 else if (curop->op_type == OP_RV2SV ||
3098 curop->op_type == OP_RV2AV ||
3099 curop->op_type == OP_RV2HV ||
3100 curop->op_type == OP_RV2GV) {
3101 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3104 else if (curop->op_type == OP_PADSV ||
3105 curop->op_type == OP_PADAV ||
3106 curop->op_type == OP_PADHV ||
3107 curop->op_type == OP_PADANY) {
3110 else if (curop->op_type == OP_PUSHRE)
3111 ; /* Okay here, dangerous in newASSIGNOP */
3121 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3122 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3123 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3124 prepend_elem(o->op_type, scalar(repl), o);
3127 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3128 pm->op_pmflags |= PMf_MAYBE_CONST;
3129 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3131 NewOp(1101, rcop, 1, LOGOP);
3132 rcop->op_type = OP_SUBSTCONT;
3133 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3134 rcop->op_first = scalar(repl);
3135 rcop->op_flags |= OPf_KIDS;
3136 rcop->op_private = 1;
3139 /* establish postfix order */
3140 rcop->op_next = LINKLIST(repl);
3141 repl->op_next = (OP*)rcop;
3143 pm->op_pmreplroot = scalar((OP*)rcop);
3144 pm->op_pmreplstart = LINKLIST(rcop);
3153 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3156 NewOp(1101, svop, 1, SVOP);
3157 svop->op_type = type;
3158 svop->op_ppaddr = PL_ppaddr[type];
3160 svop->op_next = (OP*)svop;
3161 svop->op_flags = flags;
3162 if (PL_opargs[type] & OA_RETSCALAR)
3164 if (PL_opargs[type] & OA_TARGET)
3165 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3166 return CHECKOP(type, svop);
3170 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3173 NewOp(1101, padop, 1, PADOP);
3174 padop->op_type = type;
3175 padop->op_ppaddr = PL_ppaddr[type];
3176 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3177 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3178 PL_curpad[padop->op_padix] = sv;
3180 padop->op_next = (OP*)padop;
3181 padop->op_flags = flags;
3182 if (PL_opargs[type] & OA_RETSCALAR)
3184 if (PL_opargs[type] & OA_TARGET)
3185 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3186 return CHECKOP(type, padop);
3190 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3194 return newPADOP(type, flags, SvREFCNT_inc(gv));
3196 return newSVOP(type, flags, SvREFCNT_inc(gv));
3201 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3204 NewOp(1101, pvop, 1, PVOP);
3205 pvop->op_type = type;
3206 pvop->op_ppaddr = PL_ppaddr[type];
3208 pvop->op_next = (OP*)pvop;
3209 pvop->op_flags = flags;
3210 if (PL_opargs[type] & OA_RETSCALAR)
3212 if (PL_opargs[type] & OA_TARGET)
3213 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3214 return CHECKOP(type, pvop);
3218 Perl_package(pTHX_ OP *o)
3222 save_hptr(&PL_curstash);
3223 save_item(PL_curstname);
3228 name = SvPV(sv, len);
3229 PL_curstash = gv_stashpvn(name,len,TRUE);
3230 sv_setpvn(PL_curstname, name, len);
3234 deprecate("\"package\" with no arguments");
3235 sv_setpv(PL_curstname,"<none>");
3236 PL_curstash = Nullhv;
3238 PL_hints |= HINT_BLOCK_SCOPE;
3239 PL_copline = NOLINE;
3244 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3249 char *packname = Nullch;
3253 if (id->op_type != OP_CONST)
3254 Perl_croak(aTHX_ "Module name must be constant");
3258 if (version != Nullop) {
3259 SV *vesv = ((SVOP*)version)->op_sv;
3261 if (arg == Nullop && !SvNIOKp(vesv)) {
3268 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3269 Perl_croak(aTHX_ "Version number must be constant number");
3271 /* Make copy of id so we don't free it twice */
3272 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3274 /* Fake up a method call to VERSION */
3275 meth = newSVpvn("VERSION",7);
3276 sv_upgrade(meth, SVt_PVIV);
3277 (void)SvIOK_on(meth);
3278 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3279 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3280 append_elem(OP_LIST,
3281 prepend_elem(OP_LIST, pack, list(version)),
3282 newSVOP(OP_METHOD_NAMED, 0, meth)));
3286 /* Fake up an import/unimport */
3287 if (arg && arg->op_type == OP_STUB)
3288 imop = arg; /* no import on explicit () */
3289 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3290 imop = Nullop; /* use 5.0; */
3295 /* Make copy of id so we don't free it twice */
3296 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3298 /* Fake up a method call to import/unimport */
3299 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3300 sv_upgrade(meth, SVt_PVIV);
3301 (void)SvIOK_on(meth);
3302 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3303 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3304 append_elem(OP_LIST,
3305 prepend_elem(OP_LIST, pack, list(arg)),
3306 newSVOP(OP_METHOD_NAMED, 0, meth)));
3309 if (ckWARN(WARN_MISC) &&
3310 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3311 SvPOK(packsv = ((SVOP*)id)->op_sv))
3313 /* BEGIN will free the ops, so we need to make a copy */
3314 packlen = SvCUR(packsv);
3315 packname = savepvn(SvPVX(packsv), packlen);
3318 /* Fake up the BEGIN {}, which does its thing immediately. */
3320 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3323 append_elem(OP_LINESEQ,
3324 append_elem(OP_LINESEQ,
3325 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3326 newSTATEOP(0, Nullch, veop)),
3327 newSTATEOP(0, Nullch, imop) ));
3330 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3331 Perl_warner(aTHX_ WARN_MISC,
3332 "Package `%s' not found "
3333 "(did you use the incorrect case?)", packname);
3338 PL_hints |= HINT_BLOCK_SCOPE;
3339 PL_copline = NOLINE;
3344 =for apidoc load_module
3346 Loads the module whose name is pointed to by the string part of name.
3347 Note that the actual module name, not its filename, should be given.
3348 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3349 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3350 (or 0 for no flags). ver, if specified, provides version semantics
3351 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3352 arguments can be used to specify arguments to the module's import()
3353 method, similar to C<use Foo::Bar VERSION LIST>.
3358 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3361 va_start(args, ver);
3362 vload_module(flags, name, ver, &args);
3366 #ifdef PERL_IMPLICIT_CONTEXT
3368 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3372 va_start(args, ver);
3373 vload_module(flags, name, ver, &args);
3379 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3381 OP *modname, *veop, *imop;
3383 modname = newSVOP(OP_CONST, 0, name);
3384 modname->op_private |= OPpCONST_BARE;
3386 veop = newSVOP(OP_CONST, 0, ver);
3390 if (flags & PERL_LOADMOD_NOIMPORT) {
3391 imop = sawparens(newNULLLIST());
3393 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3394 imop = va_arg(*args, OP*);
3399 sv = va_arg(*args, SV*);
3401 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3402 sv = va_arg(*args, SV*);
3406 line_t ocopline = PL_copline;
3407 int oexpect = PL_expect;
3409 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3410 veop, modname, imop);
3411 PL_expect = oexpect;
3412 PL_copline = ocopline;
3417 Perl_dofile(pTHX_ OP *term)
3422 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3423 if (!(gv && GvIMPORTED_CV(gv)))
3424 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3426 if (gv && GvIMPORTED_CV(gv)) {
3427 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3428 append_elem(OP_LIST, term,
3429 scalar(newUNOP(OP_RV2CV, 0,
3434 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3440 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3442 return newBINOP(OP_LSLICE, flags,
3443 list(force_list(subscript)),
3444 list(force_list(listval)) );
3448 S_list_assignment(pTHX_ register OP *o)
3453 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3454 o = cUNOPo->op_first;
3456 if (o->op_type == OP_COND_EXPR) {
3457 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3458 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3463 yyerror("Assignment to both a list and a scalar");
3467 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3468 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3469 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3472 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3475 if (o->op_type == OP_RV2SV)
3482 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3487 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3488 return newLOGOP(optype, 0,
3489 mod(scalar(left), optype),
3490 newUNOP(OP_SASSIGN, 0, scalar(right)));
3493 return newBINOP(optype, OPf_STACKED,
3494 mod(scalar(left), optype), scalar(right));
3498 if (list_assignment(left)) {
3502 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3503 left = mod(left, OP_AASSIGN);
3511 curop = list(force_list(left));
3512 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3513 o->op_private = 0 | (flags >> 8);
3514 for (curop = ((LISTOP*)curop)->op_first;
3515 curop; curop = curop->op_sibling)
3517 if (curop->op_type == OP_RV2HV &&
3518 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3519 o->op_private |= OPpASSIGN_HASH;
3523 if (!(left->op_private & OPpLVAL_INTRO)) {
3526 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3527 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3528 if (curop->op_type == OP_GV) {
3529 GV *gv = cGVOPx_gv(curop);
3530 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3532 SvCUR(gv) = PL_generation;
3534 else if (curop->op_type == OP_PADSV ||
3535 curop->op_type == OP_PADAV ||
3536 curop->op_type == OP_PADHV ||
3537 curop->op_type == OP_PADANY) {
3538 SV **svp = AvARRAY(PL_comppad_name);
3539 SV *sv = svp[curop->op_targ];
3540 if (SvCUR(sv) == PL_generation)
3542 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3544 else if (curop->op_type == OP_RV2CV)
3546 else if (curop->op_type == OP_RV2SV ||
3547 curop->op_type == OP_RV2AV ||
3548 curop->op_type == OP_RV2HV ||
3549 curop->op_type == OP_RV2GV) {
3550 if (lastop->op_type != OP_GV) /* funny deref? */
3553 else if (curop->op_type == OP_PUSHRE) {
3554 if (((PMOP*)curop)->op_pmreplroot) {
3556 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3558 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3560 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3562 SvCUR(gv) = PL_generation;
3571 o->op_private |= OPpASSIGN_COMMON;
3573 if (right && right->op_type == OP_SPLIT) {
3575 if ((tmpop = ((LISTOP*)right)->op_first) &&
3576 tmpop->op_type == OP_PUSHRE)
3578 PMOP *pm = (PMOP*)tmpop;
3579 if (left->op_type == OP_RV2AV &&
3580 !(left->op_private & OPpLVAL_INTRO) &&
3581 !(o->op_private & OPpASSIGN_COMMON) )
3583 tmpop = ((UNOP*)left)->op_first;
3584 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3586 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3587 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3589 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3590 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3592 pm->op_pmflags |= PMf_ONCE;
3593 tmpop = cUNOPo->op_first; /* to list (nulled) */
3594 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3595 tmpop->op_sibling = Nullop; /* don't free split */
3596 right->op_next = tmpop->op_next; /* fix starting loc */
3597 op_free(o); /* blow off assign */
3598 right->op_flags &= ~OPf_WANT;
3599 /* "I don't know and I don't care." */
3604 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3605 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3607 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3609 sv_setiv(sv, PL_modcount+1);
3617 right = newOP(OP_UNDEF, 0);
3618 if (right->op_type == OP_READLINE) {
3619 right->op_flags |= OPf_STACKED;
3620 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3623 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3624 o = newBINOP(OP_SASSIGN, flags,
3625 scalar(right), mod(scalar(left), OP_SASSIGN) );
3637 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3639 U32 seq = intro_my();
3642 NewOp(1101, cop, 1, COP);
3643 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3644 cop->op_type = OP_DBSTATE;
3645 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3648 cop->op_type = OP_NEXTSTATE;
3649 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3651 cop->op_flags = flags;
3652 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3654 cop->op_private |= NATIVE_HINTS;
3656 PL_compiling.op_private = cop->op_private;
3657 cop->op_next = (OP*)cop;
3660 cop->cop_label = label;
3661 PL_hints |= HINT_BLOCK_SCOPE;
3664 cop->cop_arybase = PL_curcop->cop_arybase;
3665 if (specialWARN(PL_curcop->cop_warnings))
3666 cop->cop_warnings = PL_curcop->cop_warnings ;
3668 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3669 if (specialCopIO(PL_curcop->cop_io))
3670 cop->cop_io = PL_curcop->cop_io;
3672 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3675 if (PL_copline == NOLINE)
3676 CopLINE_set(cop, CopLINE(PL_curcop));
3678 CopLINE_set(cop, PL_copline);
3679 PL_copline = NOLINE;
3682 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3684 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3686 CopSTASH_set(cop, PL_curstash);
3688 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3689 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3690 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3691 (void)SvIOK_on(*svp);
3692 SvIVX(*svp) = PTR2IV(cop);
3696 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3699 /* "Introduce" my variables to visible status. */
3707 if (! PL_min_intro_pending)
3708 return PL_cop_seqmax;
3710 svp = AvARRAY(PL_comppad_name);
3711 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3712 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3713 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3714 SvNVX(sv) = (NV)PL_cop_seqmax;
3717 PL_min_intro_pending = 0;
3718 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3719 return PL_cop_seqmax++;
3723 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3725 return new_logop(type, flags, &first, &other);
3729 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3733 OP *first = *firstp;
3734 OP *other = *otherp;
3736 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3737 return newBINOP(type, flags, scalar(first), scalar(other));
3739 scalarboolean(first);
3740 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3741 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3742 if (type == OP_AND || type == OP_OR) {
3748 first = *firstp = cUNOPo->op_first;
3750 first->op_next = o->op_next;
3751 cUNOPo->op_first = Nullop;
3755 if (first->op_type == OP_CONST) {
3756 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3757 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3758 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3769 else if (first->op_type == OP_WANTARRAY) {
3775 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3776 OP *k1 = ((UNOP*)first)->op_first;
3777 OP *k2 = k1->op_sibling;
3779 switch (first->op_type)
3782 if (k2 && k2->op_type == OP_READLINE
3783 && (k2->op_flags & OPf_STACKED)
3784 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3786 warnop = k2->op_type;
3791 if (k1->op_type == OP_READDIR
3792 || k1->op_type == OP_GLOB
3793 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3794 || k1->op_type == OP_EACH)
3796 warnop = ((k1->op_type == OP_NULL)
3797 ? k1->op_targ : k1->op_type);
3802 line_t oldline = CopLINE(PL_curcop);
3803 CopLINE_set(PL_curcop, PL_copline);
3804 Perl_warner(aTHX_ WARN_MISC,
3805 "Value of %s%s can be \"0\"; test with defined()",
3807 ((warnop == OP_READLINE || warnop == OP_GLOB)
3808 ? " construct" : "() operator"));
3809 CopLINE_set(PL_curcop, oldline);
3816 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3817 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3819 NewOp(1101, logop, 1, LOGOP);
3821 logop->op_type = type;
3822 logop->op_ppaddr = PL_ppaddr[type];
3823 logop->op_first = first;
3824 logop->op_flags = flags | OPf_KIDS;
3825 logop->op_other = LINKLIST(other);
3826 logop->op_private = 1 | (flags >> 8);
3828 /* establish postfix order */
3829 logop->op_next = LINKLIST(first);
3830 first->op_next = (OP*)logop;
3831 first->op_sibling = other;
3833 o = newUNOP(OP_NULL, 0, (OP*)logop);
3840 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3847 return newLOGOP(OP_AND, 0, first, trueop);
3849 return newLOGOP(OP_OR, 0, first, falseop);
3851 scalarboolean(first);
3852 if (first->op_type == OP_CONST) {
3853 if (SvTRUE(((SVOP*)first)->op_sv)) {
3864 else if (first->op_type == OP_WANTARRAY) {
3868 NewOp(1101, logop, 1, LOGOP);
3869 logop->op_type = OP_COND_EXPR;
3870 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3871 logop->op_first = first;
3872 logop->op_flags = flags | OPf_KIDS;
3873 logop->op_private = 1 | (flags >> 8);
3874 logop->op_other = LINKLIST(trueop);
3875 logop->op_next = LINKLIST(falseop);
3878 /* establish postfix order */
3879 start = LINKLIST(first);
3880 first->op_next = (OP*)logop;
3882 first->op_sibling = trueop;
3883 trueop->op_sibling = falseop;
3884 o = newUNOP(OP_NULL, 0, (OP*)logop);
3886 trueop->op_next = falseop->op_next = o;
3893 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3901 NewOp(1101, range, 1, LOGOP);
3903 range->op_type = OP_RANGE;
3904 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3905 range->op_first = left;
3906 range->op_flags = OPf_KIDS;
3907 leftstart = LINKLIST(left);
3908 range->op_other = LINKLIST(right);
3909 range->op_private = 1 | (flags >> 8);
3911 left->op_sibling = right;
3913 range->op_next = (OP*)range;
3914 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3915 flop = newUNOP(OP_FLOP, 0, flip);
3916 o = newUNOP(OP_NULL, 0, flop);
3918 range->op_next = leftstart;
3920 left->op_next = flip;
3921 right->op_next = flop;
3923 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3924 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3925 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3926 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3928 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3929 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3932 if (!flip->op_private || !flop->op_private)
3933 linklist(o); /* blow off optimizer unless constant */
3939 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3943 int once = block && block->op_flags & OPf_SPECIAL &&
3944 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3947 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3948 return block; /* do {} while 0 does once */
3949 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3950 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3951 expr = newUNOP(OP_DEFINED, 0,
3952 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3953 } else if (expr->op_flags & OPf_KIDS) {
3954 OP *k1 = ((UNOP*)expr)->op_first;
3955 OP *k2 = (k1) ? k1->op_sibling : NULL;
3956 switch (expr->op_type) {
3958 if (k2 && k2->op_type == OP_READLINE
3959 && (k2->op_flags & OPf_STACKED)
3960 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3961 expr = newUNOP(OP_DEFINED, 0, expr);
3965 if (k1->op_type == OP_READDIR
3966 || k1->op_type == OP_GLOB
3967 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3968 || k1->op_type == OP_EACH)
3969 expr = newUNOP(OP_DEFINED, 0, expr);
3975 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3976 o = new_logop(OP_AND, 0, &expr, &listop);
3979 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3981 if (once && o != listop)
3982 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3985 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3987 o->op_flags |= flags;
3989 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3994 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4002 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4003 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4004 expr = newUNOP(OP_DEFINED, 0,
4005 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4006 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4007 OP *k1 = ((UNOP*)expr)->op_first;
4008 OP *k2 = (k1) ? k1->op_sibling : NULL;
4009 switch (expr->op_type) {
4011 if (k2 && k2->op_type == OP_READLINE
4012 && (k2->op_flags & OPf_STACKED)
4013 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4014 expr = newUNOP(OP_DEFINED, 0, expr);
4018 if (k1->op_type == OP_READDIR
4019 || k1->op_type == OP_GLOB
4020 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4021 || k1->op_type == OP_EACH)
4022 expr = newUNOP(OP_DEFINED, 0, expr);
4028 block = newOP(OP_NULL, 0);
4030 block = scope(block);
4034 next = LINKLIST(cont);
4037 OP *unstack = newOP(OP_UNSTACK, 0);
4040 cont = append_elem(OP_LINESEQ, cont, unstack);
4041 if ((line_t)whileline != NOLINE) {
4042 PL_copline = whileline;
4043 cont = append_elem(OP_LINESEQ, cont,
4044 newSTATEOP(0, Nullch, Nullop));
4048 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4049 redo = LINKLIST(listop);
4052 PL_copline = whileline;
4054 o = new_logop(OP_AND, 0, &expr, &listop);
4055 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4056 op_free(expr); /* oops, it's a while (0) */
4058 return Nullop; /* listop already freed by new_logop */
4061 ((LISTOP*)listop)->op_last->op_next =
4062 (o == listop ? redo : LINKLIST(o));
4068 NewOp(1101,loop,1,LOOP);
4069 loop->op_type = OP_ENTERLOOP;
4070 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4071 loop->op_private = 0;
4072 loop->op_next = (OP*)loop;
4075 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4077 loop->op_redoop = redo;
4078 loop->op_lastop = o;
4079 o->op_private |= loopflags;
4082 loop->op_nextop = next;
4084 loop->op_nextop = o;
4086 o->op_flags |= flags;
4087 o->op_private |= (flags >> 8);
4092 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4100 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4101 sv->op_type = OP_RV2GV;
4102 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4104 else if (sv->op_type == OP_PADSV) { /* private variable */
4105 padoff = sv->op_targ;
4110 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4111 padoff = sv->op_targ;
4113 iterflags |= OPf_SPECIAL;
4118 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4121 #ifdef USE_5005THREADS
4122 padoff = find_threadsv("_");
4123 iterflags |= OPf_SPECIAL;
4125 sv = newGVOP(OP_GV, 0, PL_defgv);
4128 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4129 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4130 iterflags |= OPf_STACKED;
4132 else if (expr->op_type == OP_NULL &&
4133 (expr->op_flags & OPf_KIDS) &&
4134 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4136 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4137 * set the STACKED flag to indicate that these values are to be
4138 * treated as min/max values by 'pp_iterinit'.
4140 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4141 LOGOP* range = (LOGOP*) flip->op_first;
4142 OP* left = range->op_first;
4143 OP* right = left->op_sibling;
4146 range->op_flags &= ~OPf_KIDS;
4147 range->op_first = Nullop;
4149 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4150 listop->op_first->op_next = range->op_next;
4151 left->op_next = range->op_other;
4152 right->op_next = (OP*)listop;
4153 listop->op_next = listop->op_first;
4156 expr = (OP*)(listop);
4158 iterflags |= OPf_STACKED;
4161 expr = mod(force_list(expr), OP_GREPSTART);
4165 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4166 append_elem(OP_LIST, expr, scalar(sv))));
4167 assert(!loop->op_next);
4168 #ifdef PL_OP_SLAB_ALLOC
4171 NewOp(1234,tmp,1,LOOP);
4172 Copy(loop,tmp,1,LOOP);
4176 Renew(loop, 1, LOOP);
4178 loop->op_targ = padoff;
4179 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4180 PL_copline = forline;
4181 return newSTATEOP(0, label, wop);
4185 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4190 if (type != OP_GOTO || label->op_type == OP_CONST) {
4191 /* "last()" means "last" */
4192 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4193 o = newOP(type, OPf_SPECIAL);
4195 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4196 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4202 if (label->op_type == OP_ENTERSUB)
4203 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4204 o = newUNOP(type, OPf_STACKED, label);
4206 PL_hints |= HINT_BLOCK_SCOPE;
4211 Perl_cv_undef(pTHX_ CV *cv)
4213 #ifdef USE_5005THREADS
4215 MUTEX_DESTROY(CvMUTEXP(cv));
4216 Safefree(CvMUTEXP(cv));
4219 #endif /* USE_5005THREADS */
4222 if (CvFILE(cv) && !CvXSUB(cv)) {
4223 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4224 Safefree(CvFILE(cv));
4229 if (!CvXSUB(cv) && CvROOT(cv)) {
4230 #ifdef USE_5005THREADS
4231 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4232 Perl_croak(aTHX_ "Can't undef active subroutine");
4235 Perl_croak(aTHX_ "Can't undef active subroutine");
4236 #endif /* USE_5005THREADS */
4239 SAVEVPTR(PL_curpad);
4242 op_free(CvROOT(cv));
4243 CvROOT(cv) = Nullop;
4246 SvPOK_off((SV*)cv); /* forget prototype */
4248 /* Since closure prototypes have the same lifetime as the containing
4249 * CV, they don't hold a refcount on the outside CV. This avoids
4250 * the refcount loop between the outer CV (which keeps a refcount to
4251 * the closure prototype in the pad entry for pp_anoncode()) and the
4252 * closure prototype, and the ensuing memory leak. --GSAR */
4253 if (!CvANON(cv) || CvCLONED(cv))
4254 SvREFCNT_dec(CvOUTSIDE(cv));
4255 CvOUTSIDE(cv) = Nullcv;
4257 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4260 if (CvPADLIST(cv)) {
4261 /* may be during global destruction */
4262 if (SvREFCNT(CvPADLIST(cv))) {
4263 I32 i = AvFILLp(CvPADLIST(cv));
4265 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4266 SV* sv = svp ? *svp : Nullsv;
4269 if (sv == (SV*)PL_comppad_name)
4270 PL_comppad_name = Nullav;
4271 else if (sv == (SV*)PL_comppad) {
4272 PL_comppad = Nullav;
4273 PL_curpad = Null(SV**);
4277 SvREFCNT_dec((SV*)CvPADLIST(cv));
4279 CvPADLIST(cv) = Nullav;
4287 #ifdef DEBUG_CLOSURES
4289 S_cv_dump(pTHX_ CV *cv)
4292 CV *outside = CvOUTSIDE(cv);
4293 AV* padlist = CvPADLIST(cv);
4300 PerlIO_printf(Perl_debug_log,
4301 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4303 (CvANON(cv) ? "ANON"
4304 : (cv == PL_main_cv) ? "MAIN"
4305 : CvUNIQUE(cv) ? "UNIQUE"
4306 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4309 : CvANON(outside) ? "ANON"
4310 : (outside == PL_main_cv) ? "MAIN"
4311 : CvUNIQUE(outside) ? "UNIQUE"
4312 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4317 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4318 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4319 pname = AvARRAY(pad_name);
4320 ppad = AvARRAY(pad);
4322 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4323 if (SvPOK(pname[ix]))
4324 PerlIO_printf(Perl_debug_log,
4325 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4326 (int)ix, PTR2UV(ppad[ix]),
4327 SvFAKE(pname[ix]) ? "FAKE " : "",
4329 (IV)I_32(SvNVX(pname[ix])),
4332 #endif /* DEBUGGING */
4334 #endif /* DEBUG_CLOSURES */
4337 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4341 AV* protopadlist = CvPADLIST(proto);
4342 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4343 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4344 SV** pname = AvARRAY(protopad_name);
4345 SV** ppad = AvARRAY(protopad);
4346 I32 fname = AvFILLp(protopad_name);
4347 I32 fpad = AvFILLp(protopad);
4351 assert(!CvUNIQUE(proto));
4355 SAVESPTR(PL_comppad_name);
4356 SAVESPTR(PL_compcv);
4358 cv = PL_compcv = (CV*)NEWSV(1104,0);
4359 sv_upgrade((SV *)cv, SvTYPE(proto));
4360 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4363 #ifdef USE_5005THREADS
4364 New(666, CvMUTEXP(cv), 1, perl_mutex);
4365 MUTEX_INIT(CvMUTEXP(cv));
4367 #endif /* USE_5005THREADS */
4369 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4370 : savepv(CvFILE(proto));
4372 CvFILE(cv) = CvFILE(proto);
4374 CvGV(cv) = CvGV(proto);
4375 CvSTASH(cv) = CvSTASH(proto);
4376 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4377 CvSTART(cv) = CvSTART(proto);
4379 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4382 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4384 PL_comppad_name = newAV();
4385 for (ix = fname; ix >= 0; ix--)
4386 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4388 PL_comppad = newAV();
4390 comppadlist = newAV();
4391 AvREAL_off(comppadlist);
4392 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4393 av_store(comppadlist, 1, (SV*)PL_comppad);
4394 CvPADLIST(cv) = comppadlist;
4395 av_fill(PL_comppad, AvFILLp(protopad));
4396 PL_curpad = AvARRAY(PL_comppad);
4398 av = newAV(); /* will be @_ */
4400 av_store(PL_comppad, 0, (SV*)av);
4401 AvFLAGS(av) = AVf_REIFY;
4403 for (ix = fpad; ix > 0; ix--) {
4404 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4405 if (namesv && namesv != &PL_sv_undef) {
4406 char *name = SvPVX(namesv); /* XXX */
4407 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4408 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4409 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4411 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4413 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4415 else { /* our own lexical */
4418 /* anon code -- we'll come back for it */
4419 sv = SvREFCNT_inc(ppad[ix]);
4421 else if (*name == '@')
4423 else if (*name == '%')
4432 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4433 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4436 SV* sv = NEWSV(0,0);
4442 /* Now that vars are all in place, clone nested closures. */
4444 for (ix = fpad; ix > 0; ix--) {
4445 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4447 && namesv != &PL_sv_undef
4448 && !(SvFLAGS(namesv) & SVf_FAKE)
4449 && *SvPVX(namesv) == '&'
4450 && CvCLONE(ppad[ix]))
4452 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4453 SvREFCNT_dec(ppad[ix]);
4456 PL_curpad[ix] = (SV*)kid;
4460 #ifdef DEBUG_CLOSURES
4461 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4463 PerlIO_printf(Perl_debug_log, " from:\n");
4465 PerlIO_printf(Perl_debug_log, " to:\n");
4472 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4474 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4476 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4483 Perl_cv_clone(pTHX_ CV *proto)
4486 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4487 cv = cv_clone2(proto, CvOUTSIDE(proto));
4488 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4493 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4495 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4496 SV* msg = sv_newmortal();
4500 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4501 sv_setpv(msg, "Prototype mismatch:");
4503 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4505 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4506 sv_catpv(msg, " vs ");
4508 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4510 sv_catpv(msg, "none");
4511 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4515 static void const_sv_xsub(pTHX_ CV* cv);
4518 =for apidoc cv_const_sv
4520 If C<cv> is a constant sub eligible for inlining. returns the constant
4521 value returned by the sub. Otherwise, returns NULL.
4523 Constant subs can be created with C<newCONSTSUB> or as described in
4524 L<perlsub/"Constant Functions">.
4529 Perl_cv_const_sv(pTHX_ CV *cv)
4531 if (!cv || !CvCONST(cv))
4533 return (SV*)CvXSUBANY(cv).any_ptr;
4537 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4544 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4545 o = cLISTOPo->op_first->op_sibling;
4547 for (; o; o = o->op_next) {
4548 OPCODE type = o->op_type;
4550 if (sv && o->op_next == o)
4552 if (o->op_next != o) {
4553 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4555 if (type == OP_DBSTATE)
4558 if (type == OP_LEAVESUB || type == OP_RETURN)
4562 if (type == OP_CONST && cSVOPo->op_sv)
4564 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4565 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4566 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4570 /* We get here only from cv_clone2() while creating a closure.
4571 Copy the const value here instead of in cv_clone2 so that
4572 SvREADONLY_on doesn't lead to problems when leaving
4577 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4589 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4599 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4603 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4605 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4609 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4615 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4620 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4621 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4622 SV *sv = sv_newmortal();
4623 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4624 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4629 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4630 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4640 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4641 maximum a prototype before. */
4642 if (SvTYPE(gv) > SVt_NULL) {
4643 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4644 && ckWARN_d(WARN_PROTOTYPE))
4646 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4648 cv_ckproto((CV*)gv, NULL, ps);
4651 sv_setpv((SV*)gv, ps);
4653 sv_setiv((SV*)gv, -1);
4654 SvREFCNT_dec(PL_compcv);
4655 cv = PL_compcv = NULL;
4656 PL_sub_generation++;
4660 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4662 #ifdef GV_UNIQUE_CHECK
4663 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4664 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4668 if (!block || !ps || *ps || attrs)
4671 const_sv = op_const_sv(block, Nullcv);
4674 bool exists = CvROOT(cv) || CvXSUB(cv);
4676 #ifdef GV_UNIQUE_CHECK
4677 if (exists && GvUNIQUE(gv)) {
4678 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4682 /* if the subroutine doesn't exist and wasn't pre-declared
4683 * with a prototype, assume it will be AUTOLOADed,
4684 * skipping the prototype check
4686 if (exists || SvPOK(cv))
4687 cv_ckproto(cv, gv, ps);
4688 /* already defined (or promised)? */
4689 if (exists || GvASSUMECV(gv)) {
4690 if (!block && !attrs) {
4691 /* just a "sub foo;" when &foo is already defined */
4692 SAVEFREESV(PL_compcv);
4695 /* ahem, death to those who redefine active sort subs */
4696 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4697 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4699 if (ckWARN(WARN_REDEFINE)
4701 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4703 line_t oldline = CopLINE(PL_curcop);
4704 if (PL_copline != NOLINE)
4705 CopLINE_set(PL_curcop, PL_copline);
4706 Perl_warner(aTHX_ WARN_REDEFINE,
4707 CvCONST(cv) ? "Constant subroutine %s redefined"
4708 : "Subroutine %s redefined", name);
4709 CopLINE_set(PL_curcop, oldline);
4717 SvREFCNT_inc(const_sv);
4719 assert(!CvROOT(cv) && !CvCONST(cv));
4720 sv_setpv((SV*)cv, ""); /* prototype is "" */
4721 CvXSUBANY(cv).any_ptr = const_sv;
4722 CvXSUB(cv) = const_sv_xsub;
4727 cv = newCONSTSUB(NULL, name, const_sv);
4730 SvREFCNT_dec(PL_compcv);
4732 PL_sub_generation++;
4739 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4740 * before we clobber PL_compcv.
4744 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4745 stash = GvSTASH(CvGV(cv));
4746 else if (CvSTASH(cv))
4747 stash = CvSTASH(cv);
4749 stash = PL_curstash;
4752 /* possibly about to re-define existing subr -- ignore old cv */
4753 rcv = (SV*)PL_compcv;
4754 if (name && GvSTASH(gv))
4755 stash = GvSTASH(gv);
4757 stash = PL_curstash;
4759 apply_attrs(stash, rcv, attrs);
4761 if (cv) { /* must reuse cv if autoloaded */
4763 /* got here with just attrs -- work done, so bug out */
4764 SAVEFREESV(PL_compcv);
4768 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4769 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4770 CvOUTSIDE(PL_compcv) = 0;
4771 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4772 CvPADLIST(PL_compcv) = 0;
4773 /* inner references to PL_compcv must be fixed up ... */
4775 AV *padlist = CvPADLIST(cv);
4776 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4777 AV *comppad = (AV*)AvARRAY(padlist)[1];
4778 SV **namepad = AvARRAY(comppad_name);
4779 SV **curpad = AvARRAY(comppad);
4780 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4781 SV *namesv = namepad[ix];
4782 if (namesv && namesv != &PL_sv_undef
4783 && *SvPVX(namesv) == '&')
4785 CV *innercv = (CV*)curpad[ix];
4786 if (CvOUTSIDE(innercv) == PL_compcv) {
4787 CvOUTSIDE(innercv) = cv;
4788 if (!CvANON(innercv) || CvCLONED(innercv)) {
4789 (void)SvREFCNT_inc(cv);
4790 SvREFCNT_dec(PL_compcv);
4796 /* ... before we throw it away */
4797 SvREFCNT_dec(PL_compcv);
4798 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4799 ++PL_sub_generation;
4806 PL_sub_generation++;
4810 CvFILE_set_from_cop(cv, PL_curcop);
4811 CvSTASH(cv) = PL_curstash;
4812 #ifdef USE_5005THREADS
4814 if (!CvMUTEXP(cv)) {
4815 New(666, CvMUTEXP(cv), 1, perl_mutex);
4816 MUTEX_INIT(CvMUTEXP(cv));
4818 #endif /* USE_5005THREADS */
4821 sv_setpv((SV*)cv, ps);
4823 if (PL_error_count) {
4827 char *s = strrchr(name, ':');
4829 if (strEQ(s, "BEGIN")) {
4831 "BEGIN not safe after errors--compilation aborted";
4832 if (PL_in_eval & EVAL_KEEPERR)
4833 Perl_croak(aTHX_ not_safe);
4835 /* force display of errors found but not reported */
4836 sv_catpv(ERRSV, not_safe);
4837 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4845 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4846 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4849 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4850 mod(scalarseq(block), OP_LEAVESUBLV));
4853 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4855 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4856 OpREFCNT_set(CvROOT(cv), 1);
4857 CvSTART(cv) = LINKLIST(CvROOT(cv));
4858 CvROOT(cv)->op_next = 0;
4859 CALL_PEEP(CvSTART(cv));
4861 /* now that optimizer has done its work, adjust pad values */
4863 SV **namep = AvARRAY(PL_comppad_name);
4864 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4867 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4870 * The only things that a clonable function needs in its
4871 * pad are references to outer lexicals and anonymous subs.
4872 * The rest are created anew during cloning.
4874 if (!((namesv = namep[ix]) != Nullsv &&
4875 namesv != &PL_sv_undef &&
4877 *SvPVX(namesv) == '&')))
4879 SvREFCNT_dec(PL_curpad[ix]);
4880 PL_curpad[ix] = Nullsv;
4883 assert(!CvCONST(cv));
4884 if (ps && !*ps && op_const_sv(block, cv))
4888 AV *av = newAV(); /* Will be @_ */
4890 av_store(PL_comppad, 0, (SV*)av);
4891 AvFLAGS(av) = AVf_REIFY;
4893 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4894 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4896 if (!SvPADMY(PL_curpad[ix]))
4897 SvPADTMP_on(PL_curpad[ix]);
4901 /* If a potential closure prototype, don't keep a refcount on outer CV.
4902 * This is okay as the lifetime of the prototype is tied to the
4903 * lifetime of the outer CV. Avoids memory leak due to reference
4906 SvREFCNT_dec(CvOUTSIDE(cv));
4908 if (name || aname) {
4910 char *tname = (name ? name : aname);
4912 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4913 SV *sv = NEWSV(0,0);
4914 SV *tmpstr = sv_newmortal();
4915 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4919 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4921 (long)PL_subline, (long)CopLINE(PL_curcop));
4922 gv_efullname3(tmpstr, gv, Nullch);
4923 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4924 hv = GvHVn(db_postponed);
4925 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4926 && (pcv = GvCV(db_postponed)))
4932 call_sv((SV*)pcv, G_DISCARD);
4936 if ((s = strrchr(tname,':')))
4941 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4944 if (strEQ(s, "BEGIN")) {
4945 I32 oldscope = PL_scopestack_ix;
4947 SAVECOPFILE(&PL_compiling);
4948 SAVECOPLINE(&PL_compiling);
4951 PL_beginav = newAV();
4952 DEBUG_x( dump_sub(gv) );
4953 av_push(PL_beginav, (SV*)cv);
4954 GvCV(gv) = 0; /* cv has been hijacked */
4955 call_list(oldscope, PL_beginav);
4957 PL_curcop = &PL_compiling;
4958 PL_compiling.op_private = PL_hints;
4961 else if (strEQ(s, "END") && !PL_error_count) {
4964 DEBUG_x( dump_sub(gv) );
4965 av_unshift(PL_endav, 1);
4966 av_store(PL_endav, 0, (SV*)cv);
4967 GvCV(gv) = 0; /* cv has been hijacked */
4969 else if (strEQ(s, "CHECK") && !PL_error_count) {
4971 PL_checkav = newAV();
4972 DEBUG_x( dump_sub(gv) );
4973 if (PL_main_start && ckWARN(WARN_VOID))
4974 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4975 av_unshift(PL_checkav, 1);
4976 av_store(PL_checkav, 0, (SV*)cv);
4977 GvCV(gv) = 0; /* cv has been hijacked */
4979 else if (strEQ(s, "INIT") && !PL_error_count) {
4981 PL_initav = newAV();
4982 DEBUG_x( dump_sub(gv) );
4983 if (PL_main_start && ckWARN(WARN_VOID))
4984 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4985 av_push(PL_initav, (SV*)cv);
4986 GvCV(gv) = 0; /* cv has been hijacked */
4991 PL_copline = NOLINE;
4996 /* XXX unsafe for threads if eval_owner isn't held */
4998 =for apidoc newCONSTSUB
5000 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5001 eligible for inlining at compile-time.
5007 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5013 SAVECOPLINE(PL_curcop);
5014 CopLINE_set(PL_curcop, PL_copline);
5017 PL_hints &= ~HINT_BLOCK_SCOPE;
5020 SAVESPTR(PL_curstash);
5021 SAVECOPSTASH(PL_curcop);
5022 PL_curstash = stash;
5024 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5026 CopSTASH(PL_curcop) = stash;
5030 cv = newXS(name, const_sv_xsub, __FILE__);
5031 CvXSUBANY(cv).any_ptr = sv;
5033 sv_setpv((SV*)cv, ""); /* prototype is "" */
5041 =for apidoc U||newXS
5043 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5049 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5051 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5054 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5056 /* just a cached method */
5060 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5061 /* already defined (or promised) */
5062 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5063 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5064 line_t oldline = CopLINE(PL_curcop);
5065 if (PL_copline != NOLINE)
5066 CopLINE_set(PL_curcop, PL_copline);
5067 Perl_warner(aTHX_ WARN_REDEFINE,
5068 CvCONST(cv) ? "Constant subroutine %s redefined"
5069 : "Subroutine %s redefined"
5071 CopLINE_set(PL_curcop, oldline);
5078 if (cv) /* must reuse cv if autoloaded */
5081 cv = (CV*)NEWSV(1105,0);
5082 sv_upgrade((SV *)cv, SVt_PVCV);
5086 PL_sub_generation++;
5090 #ifdef USE_5005THREADS
5091 New(666, CvMUTEXP(cv), 1, perl_mutex);
5092 MUTEX_INIT(CvMUTEXP(cv));
5094 #endif /* USE_5005THREADS */
5095 (void)gv_fetchfile(filename);
5096 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5097 an external constant string */
5098 CvXSUB(cv) = subaddr;
5101 char *s = strrchr(name,':');
5107 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5110 if (strEQ(s, "BEGIN")) {
5112 PL_beginav = newAV();
5113 av_push(PL_beginav, (SV*)cv);
5114 GvCV(gv) = 0; /* cv has been hijacked */
5116 else if (strEQ(s, "END")) {
5119 av_unshift(PL_endav, 1);
5120 av_store(PL_endav, 0, (SV*)cv);
5121 GvCV(gv) = 0; /* cv has been hijacked */
5123 else if (strEQ(s, "CHECK")) {
5125 PL_checkav = newAV();
5126 if (PL_main_start && ckWARN(WARN_VOID))
5127 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5128 av_unshift(PL_checkav, 1);
5129 av_store(PL_checkav, 0, (SV*)cv);
5130 GvCV(gv) = 0; /* cv has been hijacked */
5132 else if (strEQ(s, "INIT")) {
5134 PL_initav = newAV();
5135 if (PL_main_start && ckWARN(WARN_VOID))
5136 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5137 av_push(PL_initav, (SV*)cv);
5138 GvCV(gv) = 0; /* cv has been hijacked */
5149 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5158 name = SvPVx(cSVOPo->op_sv, n_a);
5161 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5162 #ifdef GV_UNIQUE_CHECK
5164 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5168 if ((cv = GvFORM(gv))) {
5169 if (ckWARN(WARN_REDEFINE)) {
5170 line_t oldline = CopLINE(PL_curcop);
5171 if (PL_copline != NOLINE)
5172 CopLINE_set(PL_curcop, PL_copline);
5173 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5174 CopLINE_set(PL_curcop, oldline);
5181 CvFILE_set_from_cop(cv, PL_curcop);
5183 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5184 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5185 SvPADTMP_on(PL_curpad[ix]);
5188 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5189 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5190 OpREFCNT_set(CvROOT(cv), 1);
5191 CvSTART(cv) = LINKLIST(CvROOT(cv));
5192 CvROOT(cv)->op_next = 0;
5193 CALL_PEEP(CvSTART(cv));
5195 PL_copline = NOLINE;
5200 Perl_newANONLIST(pTHX_ OP *o)
5202 return newUNOP(OP_REFGEN, 0,
5203 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5207 Perl_newANONHASH(pTHX_ OP *o)
5209 return newUNOP(OP_REFGEN, 0,
5210 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5214 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5216 return newANONATTRSUB(floor, proto, Nullop, block);
5220 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5222 return newUNOP(OP_REFGEN, 0,
5223 newSVOP(OP_ANONCODE, 0,
5224 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5228 Perl_oopsAV(pTHX_ OP *o)
5230 switch (o->op_type) {
5232 o->op_type = OP_PADAV;
5233 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5234 return ref(o, OP_RV2AV);
5237 o->op_type = OP_RV2AV;
5238 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5243 if (ckWARN_d(WARN_INTERNAL))
5244 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5251 Perl_oopsHV(pTHX_ OP *o)
5253 switch (o->op_type) {
5256 o->op_type = OP_PADHV;
5257 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5258 return ref(o, OP_RV2HV);
5262 o->op_type = OP_RV2HV;
5263 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5268 if (ckWARN_d(WARN_INTERNAL))
5269 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5276 Perl_newAVREF(pTHX_ OP *o)
5278 if (o->op_type == OP_PADANY) {
5279 o->op_type = OP_PADAV;
5280 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5283 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5284 && ckWARN(WARN_DEPRECATED)) {
5285 Perl_warner(aTHX_ WARN_DEPRECATED,
5286 "Using an array as a reference is deprecated");
5288 return newUNOP(OP_RV2AV, 0, scalar(o));
5292 Perl_newGVREF(pTHX_ I32 type, OP *o)
5294 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5295 return newUNOP(OP_NULL, 0, o);
5296 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5300 Perl_newHVREF(pTHX_ OP *o)
5302 if (o->op_type == OP_PADANY) {
5303 o->op_type = OP_PADHV;
5304 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5307 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5308 && ckWARN(WARN_DEPRECATED)) {
5309 Perl_warner(aTHX_ WARN_DEPRECATED,
5310 "Using a hash as a reference is deprecated");
5312 return newUNOP(OP_RV2HV, 0, scalar(o));
5316 Perl_oopsCV(pTHX_ OP *o)
5318 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5324 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5326 return newUNOP(OP_RV2CV, flags, scalar(o));
5330 Perl_newSVREF(pTHX_ OP *o)
5332 if (o->op_type == OP_PADANY) {
5333 o->op_type = OP_PADSV;
5334 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5337 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5338 o->op_flags |= OPpDONE_SVREF;
5341 return newUNOP(OP_RV2SV, 0, scalar(o));
5344 /* Check routines. */
5347 Perl_ck_anoncode(pTHX_ OP *o)
5352 name = NEWSV(1106,0);
5353 sv_upgrade(name, SVt_PVNV);
5354 sv_setpvn(name, "&", 1);
5357 ix = pad_alloc(o->op_type, SVs_PADMY);
5358 av_store(PL_comppad_name, ix, name);
5359 av_store(PL_comppad, ix, cSVOPo->op_sv);
5360 SvPADMY_on(cSVOPo->op_sv);
5361 cSVOPo->op_sv = Nullsv;
5362 cSVOPo->op_targ = ix;
5367 Perl_ck_bitop(pTHX_ OP *o)
5369 o->op_private = PL_hints;
5374 Perl_ck_concat(pTHX_ OP *o)
5376 if (cUNOPo->op_first->op_type == OP_CONCAT)
5377 o->op_flags |= OPf_STACKED;
5382 Perl_ck_spair(pTHX_ OP *o)
5384 if (o->op_flags & OPf_KIDS) {
5387 OPCODE type = o->op_type;
5388 o = modkids(ck_fun(o), type);
5389 kid = cUNOPo->op_first;
5390 newop = kUNOP->op_first->op_sibling;
5392 (newop->op_sibling ||
5393 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5394 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5395 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5399 op_free(kUNOP->op_first);
5400 kUNOP->op_first = newop;
5402 o->op_ppaddr = PL_ppaddr[++o->op_type];
5407 Perl_ck_delete(pTHX_ OP *o)
5411 if (o->op_flags & OPf_KIDS) {
5412 OP *kid = cUNOPo->op_first;
5413 switch (kid->op_type) {
5415 o->op_flags |= OPf_SPECIAL;
5418 o->op_private |= OPpSLICE;
5421 o->op_flags |= OPf_SPECIAL;
5426 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5435 Perl_ck_die(pTHX_ OP *o)
5438 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
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;
5512 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5518 Perl_ck_exec(pTHX_ OP *o)
5521 if (o->op_flags & OPf_STACKED) {
5523 kid = cUNOPo->op_first->op_sibling;
5524 if (kid->op_type == OP_RV2GV)
5533 Perl_ck_exists(pTHX_ OP *o)
5536 if (o->op_flags & OPf_KIDS) {
5537 OP *kid = cUNOPo->op_first;
5538 if (kid->op_type == OP_ENTERSUB) {
5539 (void) ref(kid, o->op_type);
5540 if (kid->op_type != OP_RV2CV && !PL_error_count)
5541 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5543 o->op_private |= OPpEXISTS_SUB;
5545 else if (kid->op_type == OP_AELEM)
5546 o->op_flags |= OPf_SPECIAL;
5547 else if (kid->op_type != OP_HELEM)
5548 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5557 Perl_ck_gvconst(pTHX_ register OP *o)
5559 o = fold_constants(o);
5560 if (o->op_type == OP_CONST)
5567 Perl_ck_rvconst(pTHX_ register OP *o)
5569 SVOP *kid = (SVOP*)cUNOPo->op_first;
5571 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5572 if (kid->op_type == OP_CONST) {
5576 SV *kidsv = kid->op_sv;
5579 /* Is it a constant from cv_const_sv()? */
5580 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5581 SV *rsv = SvRV(kidsv);
5582 int svtype = SvTYPE(rsv);
5583 char *badtype = Nullch;
5585 switch (o->op_type) {
5587 if (svtype > SVt_PVMG)
5588 badtype = "a SCALAR";
5591 if (svtype != SVt_PVAV)
5592 badtype = "an ARRAY";
5595 if (svtype != SVt_PVHV) {
5596 if (svtype == SVt_PVAV) { /* pseudohash? */
5597 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5598 if (ksv && SvROK(*ksv)
5599 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5608 if (svtype != SVt_PVCV)
5613 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5616 name = SvPV(kidsv, n_a);
5617 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5618 char *badthing = Nullch;
5619 switch (o->op_type) {
5621 badthing = "a SCALAR";
5624 badthing = "an ARRAY";
5627 badthing = "a HASH";
5632 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5636 * This is a little tricky. We only want to add the symbol if we
5637 * didn't add it in the lexer. Otherwise we get duplicate strict
5638 * warnings. But if we didn't add it in the lexer, we must at
5639 * least pretend like we wanted to add it even if it existed before,
5640 * or we get possible typo warnings. OPpCONST_ENTERED says
5641 * whether the lexer already added THIS instance of this symbol.
5643 iscv = (o->op_type == OP_RV2CV) * 2;
5645 gv = gv_fetchpv(name,
5646 iscv | !(kid->op_private & OPpCONST_ENTERED),
5649 : o->op_type == OP_RV2SV
5651 : o->op_type == OP_RV2AV
5653 : o->op_type == OP_RV2HV
5656 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5658 kid->op_type = OP_GV;
5659 SvREFCNT_dec(kid->op_sv);
5661 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5662 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5663 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5665 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5667 kid->op_sv = SvREFCNT_inc(gv);
5669 kid->op_private = 0;
5670 kid->op_ppaddr = PL_ppaddr[OP_GV];
5677 Perl_ck_ftst(pTHX_ OP *o)
5679 I32 type = o->op_type;
5681 if (o->op_flags & OPf_REF) {
5684 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5685 SVOP *kid = (SVOP*)cUNOPo->op_first;
5687 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5689 OP *newop = newGVOP(type, OPf_REF,
5690 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5697 if (type == OP_FTTTY)
5698 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5701 o = newUNOP(type, 0, newDEFSVOP());
5707 Perl_ck_fun(pTHX_ OP *o)
5713 int type = o->op_type;
5714 register I32 oa = PL_opargs[type] >> OASHIFT;
5716 if (o->op_flags & OPf_STACKED) {
5717 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5720 return no_fh_allowed(o);
5723 if (o->op_flags & OPf_KIDS) {
5725 tokid = &cLISTOPo->op_first;
5726 kid = cLISTOPo->op_first;
5727 if (kid->op_type == OP_PUSHMARK ||
5728 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5730 tokid = &kid->op_sibling;
5731 kid = kid->op_sibling;
5733 if (!kid && PL_opargs[type] & OA_DEFGV)
5734 *tokid = kid = newDEFSVOP();
5738 sibl = kid->op_sibling;
5741 /* list seen where single (scalar) arg expected? */
5742 if (numargs == 1 && !(oa >> 4)
5743 && kid->op_type == OP_LIST && type != OP_SCALAR)
5745 return too_many_arguments(o,PL_op_desc[type]);
5758 if ((type == OP_PUSH || type == OP_UNSHIFT)
5759 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5760 Perl_warner(aTHX_ WARN_SYNTAX,
5761 "Useless use of %s with no values",
5764 if (kid->op_type == OP_CONST &&
5765 (kid->op_private & OPpCONST_BARE))
5767 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5768 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5769 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5770 if (ckWARN(WARN_DEPRECATED))
5771 Perl_warner(aTHX_ WARN_DEPRECATED,
5772 "Array @%s missing the @ in argument %"IVdf" of %s()",
5773 name, (IV)numargs, PL_op_desc[type]);
5776 kid->op_sibling = sibl;
5779 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5780 bad_type(numargs, "array", PL_op_desc[type], kid);
5784 if (kid->op_type == OP_CONST &&
5785 (kid->op_private & OPpCONST_BARE))
5787 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5788 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5789 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5790 if (ckWARN(WARN_DEPRECATED))
5791 Perl_warner(aTHX_ WARN_DEPRECATED,
5792 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5793 name, (IV)numargs, PL_op_desc[type]);
5796 kid->op_sibling = sibl;
5799 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5800 bad_type(numargs, "hash", PL_op_desc[type], kid);
5805 OP *newop = newUNOP(OP_NULL, 0, kid);
5806 kid->op_sibling = 0;
5808 newop->op_next = newop;
5810 kid->op_sibling = sibl;
5815 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5816 if (kid->op_type == OP_CONST &&
5817 (kid->op_private & OPpCONST_BARE))
5819 OP *newop = newGVOP(OP_GV, 0,
5820 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5825 else if (kid->op_type == OP_READLINE) {
5826 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5827 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5830 I32 flags = OPf_SPECIAL;
5834 /* is this op a FH constructor? */
5835 if (is_handle_constructor(o,numargs)) {
5836 char *name = Nullch;
5840 /* Set a flag to tell rv2gv to vivify
5841 * need to "prove" flag does not mean something
5842 * else already - NI-S 1999/05/07
5845 if (kid->op_type == OP_PADSV) {
5846 SV **namep = av_fetch(PL_comppad_name,
5848 if (namep && *namep)
5849 name = SvPV(*namep, len);
5851 else if (kid->op_type == OP_RV2SV
5852 && kUNOP->op_first->op_type == OP_GV)
5854 GV *gv = cGVOPx_gv(kUNOP->op_first);
5856 len = GvNAMELEN(gv);
5858 else if (kid->op_type == OP_AELEM
5859 || kid->op_type == OP_HELEM)
5861 name = "__ANONIO__";
5867 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5868 namesv = PL_curpad[targ];
5869 (void)SvUPGRADE(namesv, SVt_PV);
5871 sv_setpvn(namesv, "$", 1);
5872 sv_catpvn(namesv, name, len);
5875 kid->op_sibling = 0;
5876 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5877 kid->op_targ = targ;
5878 kid->op_private |= priv;
5880 kid->op_sibling = sibl;
5886 mod(scalar(kid), type);
5890 tokid = &kid->op_sibling;
5891 kid = kid->op_sibling;
5893 o->op_private |= numargs;
5895 return too_many_arguments(o,OP_DESC(o));
5898 else if (PL_opargs[type] & OA_DEFGV) {
5900 return newUNOP(type, 0, newDEFSVOP());
5904 while (oa & OA_OPTIONAL)
5906 if (oa && oa != OA_LIST)
5907 return too_few_arguments(o,OP_DESC(o));
5913 Perl_ck_glob(pTHX_ OP *o)
5918 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5919 append_elem(OP_GLOB, o, newDEFSVOP());
5921 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5922 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5924 #if !defined(PERL_EXTERNAL_GLOB)
5925 /* XXX this can be tightened up and made more failsafe. */
5929 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5931 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5932 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5933 GvCV(gv) = GvCV(glob_gv);
5934 SvREFCNT_inc((SV*)GvCV(gv));
5935 GvIMPORTED_CV_on(gv);
5938 #endif /* PERL_EXTERNAL_GLOB */
5940 if (gv && GvIMPORTED_CV(gv)) {
5941 append_elem(OP_GLOB, o,
5942 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5943 o->op_type = OP_LIST;
5944 o->op_ppaddr = PL_ppaddr[OP_LIST];
5945 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5946 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5947 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5948 append_elem(OP_LIST, o,
5949 scalar(newUNOP(OP_RV2CV, 0,
5950 newGVOP(OP_GV, 0, gv)))));
5951 o = newUNOP(OP_NULL, 0, ck_subr(o));
5952 o->op_targ = OP_GLOB; /* hint at what it used to be */
5955 gv = newGVgen("main");
5957 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5963 Perl_ck_grep(pTHX_ OP *o)
5967 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5969 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5970 NewOp(1101, gwop, 1, LOGOP);
5972 if (o->op_flags & OPf_STACKED) {
5975 kid = cLISTOPo->op_first->op_sibling;
5976 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5979 kid->op_next = (OP*)gwop;
5980 o->op_flags &= ~OPf_STACKED;
5982 kid = cLISTOPo->op_first->op_sibling;
5983 if (type == OP_MAPWHILE)
5990 kid = cLISTOPo->op_first->op_sibling;
5991 if (kid->op_type != OP_NULL)
5992 Perl_croak(aTHX_ "panic: ck_grep");
5993 kid = kUNOP->op_first;
5995 gwop->op_type = type;
5996 gwop->op_ppaddr = PL_ppaddr[type];
5997 gwop->op_first = listkids(o);
5998 gwop->op_flags |= OPf_KIDS;
5999 gwop->op_private = 1;
6000 gwop->op_other = LINKLIST(kid);
6001 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6002 kid->op_next = (OP*)gwop;
6004 kid = cLISTOPo->op_first->op_sibling;
6005 if (!kid || !kid->op_sibling)
6006 return too_few_arguments(o,OP_DESC(o));
6007 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6008 mod(kid, OP_GREPSTART);
6014 Perl_ck_index(pTHX_ OP *o)
6016 if (o->op_flags & OPf_KIDS) {
6017 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6019 kid = kid->op_sibling; /* get past "big" */
6020 if (kid && kid->op_type == OP_CONST)
6021 fbm_compile(((SVOP*)kid)->op_sv, 0);
6027 Perl_ck_lengthconst(pTHX_ OP *o)
6029 /* XXX length optimization goes here */
6034 Perl_ck_lfun(pTHX_ OP *o)
6036 OPCODE type = o->op_type;
6037 return modkids(ck_fun(o), type);
6041 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6043 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6044 switch (cUNOPo->op_first->op_type) {
6046 /* This is needed for
6047 if (defined %stash::)
6048 to work. Do not break Tk.
6050 break; /* Globals via GV can be undef */
6052 case OP_AASSIGN: /* Is this a good idea? */
6053 Perl_warner(aTHX_ WARN_DEPRECATED,
6054 "defined(@array) is deprecated");
6055 Perl_warner(aTHX_ WARN_DEPRECATED,
6056 "\t(Maybe you should just omit the defined()?)\n");
6059 /* This is needed for
6060 if (defined %stash::)
6061 to work. Do not break Tk.
6063 break; /* Globals via GV can be undef */
6065 Perl_warner(aTHX_ WARN_DEPRECATED,
6066 "defined(%%hash) is deprecated");
6067 Perl_warner(aTHX_ WARN_DEPRECATED,
6068 "\t(Maybe you should just omit the defined()?)\n");
6079 Perl_ck_rfun(pTHX_ OP *o)
6081 OPCODE type = o->op_type;
6082 return refkids(ck_fun(o), type);
6086 Perl_ck_listiob(pTHX_ OP *o)
6090 kid = cLISTOPo->op_first;
6093 kid = cLISTOPo->op_first;
6095 if (kid->op_type == OP_PUSHMARK)
6096 kid = kid->op_sibling;
6097 if (kid && o->op_flags & OPf_STACKED)
6098 kid = kid->op_sibling;
6099 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6100 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6101 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6102 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6103 cLISTOPo->op_first->op_sibling = kid;
6104 cLISTOPo->op_last = kid;
6105 kid = kid->op_sibling;
6110 append_elem(o->op_type, o, newDEFSVOP());
6116 Perl_ck_sassign(pTHX_ OP *o)
6118 OP *kid = cLISTOPo->op_first;
6119 /* has a disposable target? */
6120 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6121 && !(kid->op_flags & OPf_STACKED)
6122 /* Cannot steal the second time! */
6123 && !(kid->op_private & OPpTARGET_MY))
6125 OP *kkid = kid->op_sibling;
6127 /* Can just relocate the target. */
6128 if (kkid && kkid->op_type == OP_PADSV
6129 && !(kkid->op_private & OPpLVAL_INTRO))
6131 kid->op_targ = kkid->op_targ;
6133 /* Now we do not need PADSV and SASSIGN. */
6134 kid->op_sibling = o->op_sibling; /* NULL */
6135 cLISTOPo->op_first = NULL;
6138 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6146 Perl_ck_match(pTHX_ OP *o)
6148 o->op_private |= OPpRUNTIME;
6153 Perl_ck_method(pTHX_ OP *o)
6155 OP *kid = cUNOPo->op_first;
6156 if (kid->op_type == OP_CONST) {
6157 SV* sv = kSVOP->op_sv;
6158 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6160 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6161 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6164 kSVOP->op_sv = Nullsv;
6166 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6175 Perl_ck_null(pTHX_ OP *o)
6181 Perl_ck_open(pTHX_ OP *o)
6183 HV *table = GvHV(PL_hintgv);
6187 svp = hv_fetch(table, "open_IN", 7, FALSE);
6189 mode = mode_from_discipline(*svp);
6190 if (mode & O_BINARY)
6191 o->op_private |= OPpOPEN_IN_RAW;
6192 else if (mode & O_TEXT)
6193 o->op_private |= OPpOPEN_IN_CRLF;
6196 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6198 mode = mode_from_discipline(*svp);
6199 if (mode & O_BINARY)
6200 o->op_private |= OPpOPEN_OUT_RAW;
6201 else if (mode & O_TEXT)
6202 o->op_private |= OPpOPEN_OUT_CRLF;
6205 if (o->op_type == OP_BACKTICK)
6211 Perl_ck_repeat(pTHX_ OP *o)
6213 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6214 o->op_private |= OPpREPEAT_DOLIST;
6215 cBINOPo->op_first = force_list(cBINOPo->op_first);
6223 Perl_ck_require(pTHX_ OP *o)
6227 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6228 SVOP *kid = (SVOP*)cUNOPo->op_first;
6230 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6232 for (s = SvPVX(kid->op_sv); *s; s++) {
6233 if (*s == ':' && s[1] == ':') {
6235 Move(s+2, s+1, strlen(s+2)+1, char);
6236 --SvCUR(kid->op_sv);
6239 if (SvREADONLY(kid->op_sv)) {
6240 SvREADONLY_off(kid->op_sv);
6241 sv_catpvn(kid->op_sv, ".pm", 3);
6242 SvREADONLY_on(kid->op_sv);
6245 sv_catpvn(kid->op_sv, ".pm", 3);
6249 /* handle override, if any */
6250 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6251 if (!(gv && GvIMPORTED_CV(gv)))
6252 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6254 if (gv && GvIMPORTED_CV(gv)) {
6255 OP *kid = cUNOPo->op_first;
6256 cUNOPo->op_first = 0;
6258 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6259 append_elem(OP_LIST, kid,
6260 scalar(newUNOP(OP_RV2CV, 0,
6269 Perl_ck_return(pTHX_ OP *o)
6272 if (CvLVALUE(PL_compcv)) {
6273 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6274 mod(kid, OP_LEAVESUBLV);
6281 Perl_ck_retarget(pTHX_ OP *o)
6283 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6290 Perl_ck_select(pTHX_ OP *o)
6293 if (o->op_flags & OPf_KIDS) {
6294 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6295 if (kid && kid->op_sibling) {
6296 o->op_type = OP_SSELECT;
6297 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6299 return fold_constants(o);
6303 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6304 if (kid && kid->op_type == OP_RV2GV)
6305 kid->op_private &= ~HINT_STRICT_REFS;
6310 Perl_ck_shift(pTHX_ OP *o)
6312 I32 type = o->op_type;
6314 if (!(o->op_flags & OPf_KIDS)) {
6318 #ifdef USE_5005THREADS
6319 if (!CvUNIQUE(PL_compcv)) {
6320 argop = newOP(OP_PADAV, OPf_REF);
6321 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6324 argop = newUNOP(OP_RV2AV, 0,
6325 scalar(newGVOP(OP_GV, 0,
6326 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6329 argop = newUNOP(OP_RV2AV, 0,
6330 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6331 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6332 #endif /* USE_5005THREADS */
6333 return newUNOP(type, 0, scalar(argop));
6335 return scalar(modkids(ck_fun(o), type));
6339 Perl_ck_sort(pTHX_ OP *o)
6343 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6345 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6346 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6348 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6350 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6352 if (kid->op_type == OP_SCOPE) {
6356 else if (kid->op_type == OP_LEAVE) {
6357 if (o->op_type == OP_SORT) {
6358 op_null(kid); /* wipe out leave */
6361 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6362 if (k->op_next == kid)
6364 /* don't descend into loops */
6365 else if (k->op_type == OP_ENTERLOOP
6366 || k->op_type == OP_ENTERITER)
6368 k = cLOOPx(k)->op_lastop;
6373 kid->op_next = 0; /* just disconnect the leave */
6374 k = kLISTOP->op_first;
6379 if (o->op_type == OP_SORT) {
6380 /* provide scalar context for comparison function/block */
6386 o->op_flags |= OPf_SPECIAL;
6388 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6391 firstkid = firstkid->op_sibling;
6394 /* provide list context for arguments */
6395 if (o->op_type == OP_SORT)
6402 S_simplify_sort(pTHX_ OP *o)
6404 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6408 if (!(o->op_flags & OPf_STACKED))
6410 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6411 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6412 kid = kUNOP->op_first; /* get past null */
6413 if (kid->op_type != OP_SCOPE)
6415 kid = kLISTOP->op_last; /* get past scope */
6416 switch(kid->op_type) {
6424 k = kid; /* remember this node*/
6425 if (kBINOP->op_first->op_type != OP_RV2SV)
6427 kid = kBINOP->op_first; /* get past cmp */
6428 if (kUNOP->op_first->op_type != OP_GV)
6430 kid = kUNOP->op_first; /* get past rv2sv */
6432 if (GvSTASH(gv) != PL_curstash)
6434 if (strEQ(GvNAME(gv), "a"))
6436 else if (strEQ(GvNAME(gv), "b"))
6440 kid = k; /* back to cmp */
6441 if (kBINOP->op_last->op_type != OP_RV2SV)
6443 kid = kBINOP->op_last; /* down to 2nd arg */
6444 if (kUNOP->op_first->op_type != OP_GV)
6446 kid = kUNOP->op_first; /* get past rv2sv */
6448 if (GvSTASH(gv) != PL_curstash
6450 ? strNE(GvNAME(gv), "a")
6451 : strNE(GvNAME(gv), "b")))
6453 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6455 o->op_private |= OPpSORT_REVERSE;
6456 if (k->op_type == OP_NCMP)
6457 o->op_private |= OPpSORT_NUMERIC;
6458 if (k->op_type == OP_I_NCMP)
6459 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6460 kid = cLISTOPo->op_first->op_sibling;
6461 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6462 op_free(kid); /* then delete it */
6466 Perl_ck_split(pTHX_ OP *o)
6470 if (o->op_flags & OPf_STACKED)
6471 return no_fh_allowed(o);
6473 kid = cLISTOPo->op_first;
6474 if (kid->op_type != OP_NULL)
6475 Perl_croak(aTHX_ "panic: ck_split");
6476 kid = kid->op_sibling;
6477 op_free(cLISTOPo->op_first);
6478 cLISTOPo->op_first = kid;
6480 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6481 cLISTOPo->op_last = kid; /* There was only one element previously */
6484 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6485 OP *sibl = kid->op_sibling;
6486 kid->op_sibling = 0;
6487 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6488 if (cLISTOPo->op_first == cLISTOPo->op_last)
6489 cLISTOPo->op_last = kid;
6490 cLISTOPo->op_first = kid;
6491 kid->op_sibling = sibl;
6494 kid->op_type = OP_PUSHRE;
6495 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6498 if (!kid->op_sibling)
6499 append_elem(OP_SPLIT, o, newDEFSVOP());
6501 kid = kid->op_sibling;
6504 if (!kid->op_sibling)
6505 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6507 kid = kid->op_sibling;
6510 if (kid->op_sibling)
6511 return too_many_arguments(o,OP_DESC(o));
6517 Perl_ck_join(pTHX_ OP *o)
6519 if (ckWARN(WARN_SYNTAX)) {
6520 OP *kid = cLISTOPo->op_first->op_sibling;
6521 if (kid && kid->op_type == OP_MATCH) {
6522 char *pmstr = "STRING";
6523 if (PM_GETRE(kPMOP))
6524 pmstr = PM_GETRE(kPMOP)->precomp;
6525 Perl_warner(aTHX_ WARN_SYNTAX,
6526 "/%s/ should probably be written as \"%s\"",
6534 Perl_ck_subr(pTHX_ OP *o)
6536 OP *prev = ((cUNOPo->op_first->op_sibling)
6537 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6538 OP *o2 = prev->op_sibling;
6545 I32 contextclass = 0;
6549 o->op_private |= OPpENTERSUB_HASTARG;
6550 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6551 if (cvop->op_type == OP_RV2CV) {
6553 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6554 op_null(cvop); /* disable rv2cv */
6555 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6556 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6557 GV *gv = cGVOPx_gv(tmpop);
6560 tmpop->op_private |= OPpEARLY_CV;
6561 else if (SvPOK(cv)) {
6562 namegv = CvANON(cv) ? gv : CvGV(cv);
6563 proto = SvPV((SV*)cv, n_a);
6567 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6568 if (o2->op_type == OP_CONST)
6569 o2->op_private &= ~OPpCONST_STRICT;
6570 else if (o2->op_type == OP_LIST) {
6571 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6572 if (o && o->op_type == OP_CONST)
6573 o->op_private &= ~OPpCONST_STRICT;
6576 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6577 if (PERLDB_SUB && PL_curstash != PL_debstash)
6578 o->op_private |= OPpENTERSUB_DB;
6579 while (o2 != cvop) {
6583 return too_many_arguments(o, gv_ename(namegv));
6601 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6603 arg == 1 ? "block or sub {}" : "sub {}",
6604 gv_ename(namegv), o2);
6607 /* '*' allows any scalar type, including bareword */
6610 if (o2->op_type == OP_RV2GV)
6611 goto wrapref; /* autoconvert GLOB -> GLOBref */
6612 else if (o2->op_type == OP_CONST)
6613 o2->op_private &= ~OPpCONST_STRICT;
6614 else if (o2->op_type == OP_ENTERSUB) {
6615 /* accidental subroutine, revert to bareword */
6616 OP *gvop = ((UNOP*)o2)->op_first;
6617 if (gvop && gvop->op_type == OP_NULL) {
6618 gvop = ((UNOP*)gvop)->op_first;
6620 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6623 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6624 (gvop = ((UNOP*)gvop)->op_first) &&
6625 gvop->op_type == OP_GV)
6627 GV *gv = cGVOPx_gv(gvop);
6628 OP *sibling = o2->op_sibling;
6629 SV *n = newSVpvn("",0);
6631 gv_fullname3(n, gv, "");
6632 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6633 sv_chop(n, SvPVX(n)+6);
6634 o2 = newSVOP(OP_CONST, 0, n);
6635 prev->op_sibling = o2;
6636 o2->op_sibling = sibling;
6652 if (contextclass++ == 0) {
6653 e = strchr(proto, ']');
6654 if (!e || e == proto)
6668 if (o2->op_type == OP_RV2GV)
6671 bad_type(arg, "symbol", gv_ename(namegv), o2);
6674 if (o2->op_type == OP_ENTERSUB)
6677 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6680 if (o2->op_type == OP_RV2SV ||
6681 o2->op_type == OP_PADSV ||
6682 o2->op_type == OP_HELEM ||
6683 o2->op_type == OP_AELEM ||
6684 o2->op_type == OP_THREADSV)
6687 bad_type(arg, "scalar", gv_ename(namegv), o2);
6690 if (o2->op_type == OP_RV2AV ||
6691 o2->op_type == OP_PADAV)
6694 bad_type(arg, "array", gv_ename(namegv), o2);
6697 if (o2->op_type == OP_RV2HV ||
6698 o2->op_type == OP_PADHV)
6701 bad_type(arg, "hash", gv_ename(namegv), o2);
6706 OP* sib = kid->op_sibling;
6707 kid->op_sibling = 0;
6708 o2 = newUNOP(OP_REFGEN, 0, kid);
6709 o2->op_sibling = sib;
6710 prev->op_sibling = o2;
6712 if (contextclass && e) {
6727 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6728 gv_ename(namegv), SvPV((SV*)cv, n_a));
6733 mod(o2, OP_ENTERSUB);
6735 o2 = o2->op_sibling;
6737 if (proto && !optional &&
6738 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6739 return too_few_arguments(o, gv_ename(namegv));
6744 Perl_ck_svconst(pTHX_ OP *o)
6746 SvREADONLY_on(cSVOPo->op_sv);
6751 Perl_ck_trunc(pTHX_ OP *o)
6753 if (o->op_flags & OPf_KIDS) {
6754 SVOP *kid = (SVOP*)cUNOPo->op_first;
6756 if (kid->op_type == OP_NULL)
6757 kid = (SVOP*)kid->op_sibling;
6758 if (kid && kid->op_type == OP_CONST &&
6759 (kid->op_private & OPpCONST_BARE))
6761 o->op_flags |= OPf_SPECIAL;
6762 kid->op_private &= ~OPpCONST_STRICT;
6769 Perl_ck_substr(pTHX_ OP *o)
6772 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6773 OP *kid = cLISTOPo->op_first;
6775 if (kid->op_type == OP_NULL)
6776 kid = kid->op_sibling;
6778 kid->op_flags |= OPf_MOD;
6784 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6787 Perl_peep(pTHX_ register OP *o)
6789 register OP* oldop = 0;
6792 if (!o || o->op_seq)
6796 SAVEVPTR(PL_curcop);
6797 for (; o; o = o->op_next) {
6803 switch (o->op_type) {
6807 PL_curcop = ((COP*)o); /* for warnings */
6808 o->op_seq = PL_op_seqmax++;
6812 if (cSVOPo->op_private & OPpCONST_STRICT)
6813 no_bareword_allowed(o);
6815 /* Relocate sv to the pad for thread safety.
6816 * Despite being a "constant", the SV is written to,
6817 * for reference counts, sv_upgrade() etc. */
6819 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6820 if (SvPADTMP(cSVOPo->op_sv)) {
6821 /* If op_sv is already a PADTMP then it is being used by
6822 * some pad, so make a copy. */
6823 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6824 SvREADONLY_on(PL_curpad[ix]);
6825 SvREFCNT_dec(cSVOPo->op_sv);
6828 SvREFCNT_dec(PL_curpad[ix]);
6829 SvPADTMP_on(cSVOPo->op_sv);
6830 PL_curpad[ix] = cSVOPo->op_sv;
6831 /* XXX I don't know how this isn't readonly already. */
6832 SvREADONLY_on(PL_curpad[ix]);
6834 cSVOPo->op_sv = Nullsv;
6838 o->op_seq = PL_op_seqmax++;
6842 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6843 if (o->op_next->op_private & OPpTARGET_MY) {
6844 if (o->op_flags & OPf_STACKED) /* chained concats */
6845 goto ignore_optimization;
6847 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6848 o->op_targ = o->op_next->op_targ;
6849 o->op_next->op_targ = 0;
6850 o->op_private |= OPpTARGET_MY;
6853 op_null(o->op_next);
6855 ignore_optimization:
6856 o->op_seq = PL_op_seqmax++;
6859 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6860 o->op_seq = PL_op_seqmax++;
6861 break; /* Scalar stub must produce undef. List stub is noop */
6865 if (o->op_targ == OP_NEXTSTATE
6866 || o->op_targ == OP_DBSTATE
6867 || o->op_targ == OP_SETSTATE)
6869 PL_curcop = ((COP*)o);
6871 /* XXX: We avoid setting op_seq here to prevent later calls
6872 to peep() from mistakenly concluding that optimisation
6873 has already occurred. This doesn't fix the real problem,
6874 though (See 20010220.007). AMS 20010719 */
6875 if (oldop && o->op_next) {
6876 oldop->op_next = o->op_next;
6884 if (oldop && o->op_next) {
6885 oldop->op_next = o->op_next;
6888 o->op_seq = PL_op_seqmax++;
6892 if (o->op_next->op_type == OP_RV2SV) {
6893 if (!(o->op_next->op_private & OPpDEREF)) {
6894 op_null(o->op_next);
6895 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6897 o->op_next = o->op_next->op_next;
6898 o->op_type = OP_GVSV;
6899 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6902 else if (o->op_next->op_type == OP_RV2AV) {
6903 OP* pop = o->op_next->op_next;
6905 if (pop->op_type == OP_CONST &&
6906 (PL_op = pop->op_next) &&
6907 pop->op_next->op_type == OP_AELEM &&
6908 !(pop->op_next->op_private &
6909 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6910 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6915 op_null(o->op_next);
6916 op_null(pop->op_next);
6918 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6919 o->op_next = pop->op_next->op_next;
6920 o->op_type = OP_AELEMFAST;
6921 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6922 o->op_private = (U8)i;
6927 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6929 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6930 /* XXX could check prototype here instead of just carping */
6931 SV *sv = sv_newmortal();
6932 gv_efullname3(sv, gv, Nullch);
6933 Perl_warner(aTHX_ WARN_PROTOTYPE,
6934 "%s() called too early to check prototype",
6938 else if (o->op_next->op_type == OP_READLINE
6939 && o->op_next->op_next->op_type == OP_CONCAT
6940 && (o->op_next->op_next->op_flags & OPf_STACKED))
6942 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6943 o->op_type = OP_RCATLINE;
6944 o->op_flags |= OPf_STACKED;
6945 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6946 op_null(o->op_next->op_next);
6947 op_null(o->op_next);
6950 o->op_seq = PL_op_seqmax++;
6961 o->op_seq = PL_op_seqmax++;
6962 while (cLOGOP->op_other->op_type == OP_NULL)
6963 cLOGOP->op_other = cLOGOP->op_other->op_next;
6964 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6969 o->op_seq = PL_op_seqmax++;
6970 while (cLOOP->op_redoop->op_type == OP_NULL)
6971 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6972 peep(cLOOP->op_redoop);
6973 while (cLOOP->op_nextop->op_type == OP_NULL)
6974 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6975 peep(cLOOP->op_nextop);
6976 while (cLOOP->op_lastop->op_type == OP_NULL)
6977 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6978 peep(cLOOP->op_lastop);
6984 o->op_seq = PL_op_seqmax++;
6985 while (cPMOP->op_pmreplstart &&
6986 cPMOP->op_pmreplstart->op_type == OP_NULL)
6987 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6988 peep(cPMOP->op_pmreplstart);
6992 o->op_seq = PL_op_seqmax++;
6993 if (ckWARN(WARN_SYNTAX) && o->op_next
6994 && o->op_next->op_type == OP_NEXTSTATE) {
6995 if (o->op_next->op_sibling &&
6996 o->op_next->op_sibling->op_type != OP_EXIT &&
6997 o->op_next->op_sibling->op_type != OP_WARN &&
6998 o->op_next->op_sibling->op_type != OP_DIE) {
6999 line_t oldline = CopLINE(PL_curcop);
7001 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7002 Perl_warner(aTHX_ WARN_EXEC,
7003 "Statement unlikely to be reached");
7004 Perl_warner(aTHX_ WARN_EXEC,
7005 "\t(Maybe you meant system() when you said exec()?)\n");
7006 CopLINE_set(PL_curcop, oldline);
7015 SV **svp, **indsvp, *sv;
7020 o->op_seq = PL_op_seqmax++;
7022 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7025 /* Make the CONST have a shared SV */
7026 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7027 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7028 key = SvPV(sv, keylen);
7029 lexname = newSVpvn_share(key,
7030 SvUTF8(sv) ? -(I32)keylen : keylen,
7036 if ((o->op_private & (OPpLVAL_INTRO)))
7039 rop = (UNOP*)((BINOP*)o)->op_first;
7040 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7042 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7043 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7045 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7046 if (!fields || !GvHV(*fields))
7048 key = SvPV(*svp, keylen);
7049 indsvp = hv_fetch(GvHV(*fields), key,
7050 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7052 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7053 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7055 ind = SvIV(*indsvp);
7057 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7058 rop->op_type = OP_RV2AV;
7059 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7060 o->op_type = OP_AELEM;
7061 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7063 if (SvREADONLY(*svp))
7065 SvFLAGS(sv) |= (SvFLAGS(*svp)
7066 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7076 SV **svp, **indsvp, *sv;
7080 SVOP *first_key_op, *key_op;
7082 o->op_seq = PL_op_seqmax++;
7083 if ((o->op_private & (OPpLVAL_INTRO))
7084 /* I bet there's always a pushmark... */
7085 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7086 /* hmmm, no optimization if list contains only one key. */
7088 rop = (UNOP*)((LISTOP*)o)->op_last;
7089 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7091 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7092 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7094 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7095 if (!fields || !GvHV(*fields))
7097 /* Again guessing that the pushmark can be jumped over.... */
7098 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7099 ->op_first->op_sibling;
7100 /* Check that the key list contains only constants. */
7101 for (key_op = first_key_op; key_op;
7102 key_op = (SVOP*)key_op->op_sibling)
7103 if (key_op->op_type != OP_CONST)
7107 rop->op_type = OP_RV2AV;
7108 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7109 o->op_type = OP_ASLICE;
7110 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7111 for (key_op = first_key_op; key_op;
7112 key_op = (SVOP*)key_op->op_sibling) {
7113 svp = cSVOPx_svp(key_op);
7114 key = SvPV(*svp, keylen);
7115 indsvp = hv_fetch(GvHV(*fields), key,
7116 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7118 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7119 "in variable %s of type %s",
7120 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7122 ind = SvIV(*indsvp);
7124 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7126 if (SvREADONLY(*svp))
7128 SvFLAGS(sv) |= (SvFLAGS(*svp)
7129 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7137 o->op_seq = PL_op_seqmax++;
7147 char* Perl_custom_op_name(pTHX_ OP* o)
7149 IV index = PTR2IV(o->op_ppaddr);
7153 if (!PL_custom_op_names) /* This probably shouldn't happen */
7154 return PL_op_name[OP_CUSTOM];
7156 keysv = sv_2mortal(newSViv(index));
7158 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7160 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7162 return SvPV_nolen(HeVAL(he));
7165 char* Perl_custom_op_desc(pTHX_ OP* o)
7167 IV index = PTR2IV(o->op_ppaddr);
7171 if (!PL_custom_op_descs)
7172 return PL_op_desc[OP_CUSTOM];
7174 keysv = sv_2mortal(newSViv(index));
7176 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7178 return PL_op_desc[OP_CUSTOM];
7180 return SvPV_nolen(HeVAL(he));
7186 /* Efficient sub that returns a constant scalar value. */
7188 const_sv_xsub(pTHX_ CV* cv)
7193 Perl_croak(aTHX_ "usage: %s::%s()",
7194 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7198 ST(0) = (SV*)XSANY.any_ptr;