3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
23 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
25 /* #define PL_OP_SLAB_ALLOC */
27 #if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
28 #define SLAB_SIZE 8192
29 static char *PL_OpPtr = NULL; /* XXX threadead */
30 static int PL_OpSpace = 0; /* XXX threadead */
31 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
32 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
34 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
40 Newz(m,PL_OpPtr,SLAB_SIZE,char);
41 PL_OpSpace = SLAB_SIZE - sz;
42 return PL_OpPtr += PL_OpSpace;
46 #define NewOp(m, var, c, type) Newz(m, var, c, type)
49 * In the following definition, the ", Nullop" is just to make the compiler
50 * think the expression is of the right type: croak actually does a Siglongjmp.
52 #define CHECKOP(type,o) \
53 ((PL_op_mask && PL_op_mask[type]) \
54 ? ( op_free((OP*)o), \
55 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
57 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
59 #define PAD_MAX 999999999
60 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
63 S_gv_ename(pTHX_ GV *gv)
66 SV* tmpsv = sv_newmortal();
67 gv_efullname3(tmpsv, gv, Nullch);
68 return SvPV(tmpsv,n_a);
72 S_no_fh_allowed(pTHX_ OP *o)
74 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
80 S_too_few_arguments(pTHX_ OP *o, char *name)
82 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
87 S_too_many_arguments(pTHX_ OP *o, char *name)
89 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
94 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
96 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
97 (int)n, name, t, OP_DESC(kid)));
101 S_no_bareword_allowed(pTHX_ OP *o)
103 qerror(Perl_mess(aTHX_
104 "Bareword \"%s\" not allowed while \"strict subs\" in use",
105 SvPV_nolen(cSVOPo_sv)));
108 /* "register" allocation */
111 Perl_pad_allocmy(pTHX_ char *name)
116 if (!(PL_in_my == KEY_our ||
118 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
119 (name[1] == '_' && (int)strlen(name) > 2)))
121 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
122 /* 1999-02-27 mjd@plover.com */
124 p = strchr(name, '\0');
125 /* The next block assumes the buffer is at least 205 chars
126 long. At present, it's always at least 256 chars. */
128 strcpy(name+200, "...");
134 /* Move everything else down one character */
135 for (; p-name > 2; p--)
137 name[2] = toCTRL(name[1]);
140 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
142 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
143 SV **svp = AvARRAY(PL_comppad_name);
144 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
145 PADOFFSET top = AvFILLp(PL_comppad_name);
146 for (off = top; off > PL_comppad_name_floor; off--) {
148 && sv != &PL_sv_undef
149 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
150 && (PL_in_my != KEY_our
151 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
152 && strEQ(name, SvPVX(sv)))
154 Perl_warner(aTHX_ WARN_MISC,
155 "\"%s\" variable %s masks earlier declaration in same %s",
156 (PL_in_my == KEY_our ? "our" : "my"),
158 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
163 if (PL_in_my == KEY_our) {
166 && sv != &PL_sv_undef
167 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
168 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
169 && strEQ(name, SvPVX(sv)))
171 Perl_warner(aTHX_ WARN_MISC,
172 "\"our\" variable %s redeclared", name);
173 Perl_warner(aTHX_ WARN_MISC,
174 "\t(Did you mean \"local\" instead of \"our\"?)\n");
177 } while ( off-- > 0 );
180 off = pad_alloc(OP_PADSV, SVs_PADMY);
182 sv_upgrade(sv, SVt_PVNV);
184 if (PL_in_my_stash) {
186 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
187 name, PL_in_my == KEY_our ? "our" : "my"));
188 SvFLAGS(sv) |= SVpad_TYPED;
189 (void)SvUPGRADE(sv, SVt_PVMG);
190 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
192 if (PL_in_my == KEY_our) {
193 (void)SvUPGRADE(sv, SVt_PVGV);
194 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
195 SvFLAGS(sv) |= SVpad_OUR;
197 av_store(PL_comppad_name, off, sv);
198 SvNVX(sv) = (NV)PAD_MAX;
199 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
200 if (!PL_min_intro_pending)
201 PL_min_intro_pending = off;
202 PL_max_intro_pending = off;
204 av_store(PL_comppad, off, (SV*)newAV());
205 else if (*name == '%')
206 av_store(PL_comppad, off, (SV*)newHV());
207 SvPADMY_on(PL_curpad[off]);
212 S_pad_addlex(pTHX_ SV *proto_namesv)
214 SV *namesv = NEWSV(1103,0);
215 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
216 sv_upgrade(namesv, SVt_PVNV);
217 sv_setpv(namesv, SvPVX(proto_namesv));
218 av_store(PL_comppad_name, newoff, namesv);
219 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
220 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
221 SvFAKE_on(namesv); /* A ref, not a real var */
222 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
223 SvFLAGS(namesv) |= SVpad_OUR;
224 (void)SvUPGRADE(namesv, SVt_PVGV);
225 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
227 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
228 SvFLAGS(namesv) |= SVpad_TYPED;
229 (void)SvUPGRADE(namesv, SVt_PVMG);
230 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
235 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
238 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
239 I32 cx_ix, I32 saweval, U32 flags)
245 register PERL_CONTEXT *cx;
247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
252 if (!svp || *svp == &PL_sv_undef)
255 svp = AvARRAY(curname);
256 for (off = AvFILLp(curname); off > 0; off--) {
257 if ((sv = svp[off]) &&
258 sv != &PL_sv_undef &&
260 seq > I_32(SvNVX(sv)) &&
261 strEQ(SvPVX(sv), name))
272 return 0; /* don't clone from inactive stack frame */
276 oldpad = (AV*)AvARRAY(curlist)[depth];
277 oldsv = *av_fetch(oldpad, off, TRUE);
278 if (!newoff) { /* Not a mere clone operation. */
279 newoff = pad_addlex(sv);
280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
281 /* "It's closures all the way down." */
282 CvCLONE_on(PL_compcv);
284 if (CvANON(PL_compcv))
285 oldsv = Nullsv; /* no need to keep ref */
290 bcv && bcv != cv && !CvCLONE(bcv);
291 bcv = CvOUTSIDE(bcv))
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
314 Perl_warner(aTHX_ WARN_CLOSURE,
315 "Variable \"%s\" may be unavailable",
323 else if (!CvUNIQUE(PL_compcv)) {
324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
327 Perl_warner(aTHX_ WARN_CLOSURE,
328 "Variable \"%s\" will not stay shared", name);
332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
338 if (flags & FINDLEX_NOSEARCH)
341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
346 for (i = cx_ix; i >= 0; i--) {
348 switch (CxTYPE(cx)) {
350 if (i == 0 && saweval) {
351 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
355 switch (cx->blk_eval.old_op_type) {
357 if (CxREALEVAL(cx)) {
360 seq = cxstack[i].blk_oldcop->cop_seq;
361 startcv = cxstack[i].blk_eval.cv;
362 if (startcv && CvOUTSIDE(startcv)) {
363 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
365 if (off) /* continue looking if not found here */
372 /* require/do must have their own scope */
381 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
382 saweval = i; /* so we know where we were called from */
383 seq = cxstack[i].blk_oldcop->cop_seq;
386 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
394 Perl_pad_findmy(pTHX_ char *name)
399 SV **svp = AvARRAY(PL_comppad_name);
400 U32 seq = PL_cop_seqmax;
404 #ifdef USE_5005THREADS
406 * Special case to get lexical (and hence per-thread) @_.
407 * XXX I need to find out how to tell at parse-time whether use
408 * of @_ should refer to a lexical (from a sub) or defgv (global
409 * scope and maybe weird sub-ish things like formats). See
410 * startsub in perly.y. It's possible that @_ could be lexical
411 * (at least from subs) even in non-threaded perl.
413 if (strEQ(name, "@_"))
414 return 0; /* success. (NOT_IN_PAD indicates failure) */
415 #endif /* USE_5005THREADS */
417 /* The one we're looking for is probably just before comppad_name_fill. */
418 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
419 if ((sv = svp[off]) &&
420 sv != &PL_sv_undef &&
423 seq > I_32(SvNVX(sv)))) &&
424 strEQ(SvPVX(sv), name))
426 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
427 return (PADOFFSET)off;
428 pendoff = off; /* this pending def. will override import */
432 outside = CvOUTSIDE(PL_compcv);
434 /* Check if if we're compiling an eval'', and adjust seq to be the
435 * eval's seq number. This depends on eval'' having a non-null
436 * CvOUTSIDE() while it is being compiled. The eval'' itself is
437 * identified by CvEVAL being true and CvGV being null. */
438 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
439 cx = &cxstack[cxstack_ix];
441 seq = cx->blk_oldcop->cop_seq;
444 /* See if it's in a nested scope */
445 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
447 /* If there is a pending local definition, this new alias must die */
449 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
450 return off; /* pad_findlex returns 0 for failure...*/
452 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
456 Perl_pad_leavemy(pTHX_ I32 fill)
459 SV **svp = AvARRAY(PL_comppad_name);
461 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
462 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
463 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
464 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
467 /* "Deintroduce" my variables that are leaving with this scope. */
468 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
469 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
470 SvIVX(sv) = PL_cop_seqmax;
475 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
480 if (AvARRAY(PL_comppad) != PL_curpad)
481 Perl_croak(aTHX_ "panic: pad_alloc");
482 if (PL_pad_reset_pending)
484 if (tmptype & SVs_PADMY) {
486 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
487 } while (SvPADBUSY(sv)); /* need a fresh one */
488 retval = AvFILLp(PL_comppad);
491 SV **names = AvARRAY(PL_comppad_name);
492 SSize_t names_fill = AvFILLp(PL_comppad_name);
495 * "foreach" index vars temporarily become aliases to non-"my"
496 * values. Thus we must skip, not just pad values that are
497 * marked as current pad values, but also those with names.
499 if (++PL_padix <= names_fill &&
500 (sv = names[PL_padix]) && sv != &PL_sv_undef)
502 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
503 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
504 !IS_PADGV(sv) && !IS_PADCONST(sv))
509 SvFLAGS(sv) |= tmptype;
510 PL_curpad = AvARRAY(PL_comppad);
511 #ifdef USE_5005THREADS
512 DEBUG_X(PerlIO_printf(Perl_debug_log,
513 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
514 PTR2UV(thr), PTR2UV(PL_curpad),
515 (long) retval, PL_op_name[optype]));
517 DEBUG_X(PerlIO_printf(Perl_debug_log,
518 "Pad 0x%"UVxf" alloc %ld for %s\n",
520 (long) retval, PL_op_name[optype]));
521 #endif /* USE_5005THREADS */
522 return (PADOFFSET)retval;
526 Perl_pad_sv(pTHX_ PADOFFSET po)
528 #ifdef USE_5005THREADS
529 DEBUG_X(PerlIO_printf(Perl_debug_log,
530 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
531 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
534 Perl_croak(aTHX_ "panic: pad_sv po");
535 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
536 PTR2UV(PL_curpad), (IV)po));
537 #endif /* USE_5005THREADS */
538 return PL_curpad[po]; /* eventually we'll turn this into a macro */
542 Perl_pad_free(pTHX_ PADOFFSET po)
546 if (AvARRAY(PL_comppad) != PL_curpad)
547 Perl_croak(aTHX_ "panic: pad_free curpad");
549 Perl_croak(aTHX_ "panic: pad_free po");
550 #ifdef USE_5005THREADS
551 DEBUG_X(PerlIO_printf(Perl_debug_log,
552 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
553 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
555 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
556 PTR2UV(PL_curpad), (IV)po));
557 #endif /* USE_5005THREADS */
558 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
559 SvPADTMP_off(PL_curpad[po]);
561 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
564 if ((I32)po < PL_padix)
569 Perl_pad_swipe(pTHX_ PADOFFSET po)
571 if (AvARRAY(PL_comppad) != PL_curpad)
572 Perl_croak(aTHX_ "panic: pad_swipe curpad");
574 Perl_croak(aTHX_ "panic: pad_swipe po");
575 #ifdef USE_5005THREADS
576 DEBUG_X(PerlIO_printf(Perl_debug_log,
577 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
580 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
581 PTR2UV(PL_curpad), (IV)po));
582 #endif /* USE_5005THREADS */
583 SvPADTMP_off(PL_curpad[po]);
584 PL_curpad[po] = NEWSV(1107,0);
585 SvPADTMP_on(PL_curpad[po]);
586 if ((I32)po < PL_padix)
590 /* XXX pad_reset() is currently disabled because it results in serious bugs.
591 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
592 * on the stack by OPs that use them, there are several ways to get an alias
593 * to a shared TARG. Such an alias will change randomly and unpredictably.
594 * We avoid doing this until we can think of a Better Way.
599 #ifdef USE_BROKEN_PAD_RESET
602 if (AvARRAY(PL_comppad) != PL_curpad)
603 Perl_croak(aTHX_ "panic: pad_reset curpad");
604 #ifdef USE_5005THREADS
605 DEBUG_X(PerlIO_printf(Perl_debug_log,
606 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
607 PTR2UV(thr), PTR2UV(PL_curpad)));
609 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
611 #endif /* USE_5005THREADS */
612 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
613 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
614 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
615 SvPADTMP_off(PL_curpad[po]);
617 PL_padix = PL_padix_floor;
620 PL_pad_reset_pending = FALSE;
623 #ifdef USE_5005THREADS
624 /* find_threadsv is not reentrant */
626 Perl_find_threadsv(pTHX_ const char *name)
631 /* We currently only handle names of a single character */
632 p = strchr(PL_threadsv_names, *name);
635 key = p - PL_threadsv_names;
636 MUTEX_LOCK(&thr->mutex);
637 svp = av_fetch(thr->threadsv, key, FALSE);
639 MUTEX_UNLOCK(&thr->mutex);
641 SV *sv = NEWSV(0, 0);
642 av_store(thr->threadsv, key, sv);
643 thr->threadsvp = AvARRAY(thr->threadsv);
644 MUTEX_UNLOCK(&thr->mutex);
646 * Some magic variables used to be automagically initialised
647 * in gv_fetchpv. Those which are now per-thread magicals get
648 * initialised here instead.
654 sv_setpv(sv, "\034");
655 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
660 PL_sawampersand = TRUE;
674 /* XXX %! tied to Errno.pm needs to be added here.
675 * See gv_fetchpv(). */
679 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
681 DEBUG_S(PerlIO_printf(Perl_error_log,
682 "find_threadsv: new SV %p for $%s%c\n",
683 sv, (*name < 32) ? "^" : "",
684 (*name < 32) ? toCTRL(*name) : *name));
688 #endif /* USE_5005THREADS */
693 Perl_op_free(pTHX_ OP *o)
695 register OP *kid, *nextkid;
698 if (!o || o->op_seq == (U16)-1)
701 if (o->op_private & OPpREFCOUNTED) {
702 switch (o->op_type) {
710 if (OpREFCNT_dec(o)) {
721 if (o->op_flags & OPf_KIDS) {
722 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
723 nextkid = kid->op_sibling; /* Get before next freeing kid */
731 /* COP* is not cleared by op_clear() so that we may track line
732 * numbers etc even after null() */
733 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
738 #ifdef PL_OP_SLAB_ALLOC
739 if ((char *) o == PL_OpPtr)
748 Perl_op_clear(pTHX_ OP *o)
751 switch (o->op_type) {
752 case OP_NULL: /* Was holding old type, if any. */
753 case OP_ENTEREVAL: /* Was holding hints. */
754 #ifdef USE_5005THREADS
755 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
759 #ifdef USE_5005THREADS
761 if (!(o->op_flags & OPf_SPECIAL))
764 #endif /* USE_5005THREADS */
766 if (!(o->op_flags & OPf_REF)
767 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
774 if (cPADOPo->op_padix > 0) {
777 pad_swipe(cPADOPo->op_padix);
778 /* No GvIN_PAD_off(gv) here, because other references may still
779 * exist on the pad */
782 cPADOPo->op_padix = 0;
785 SvREFCNT_dec(cSVOPo->op_sv);
786 cSVOPo->op_sv = Nullsv;
789 case OP_METHOD_NAMED:
791 SvREFCNT_dec(cSVOPo->op_sv);
792 cSVOPo->op_sv = Nullsv;
798 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
802 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
803 SvREFCNT_dec(cSVOPo->op_sv);
804 cSVOPo->op_sv = Nullsv;
807 Safefree(cPVOPo->op_pv);
808 cPVOPo->op_pv = Nullch;
812 op_free(cPMOPo->op_pmreplroot);
816 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
818 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
819 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
820 /* No GvIN_PAD_off(gv) here, because other references may still
821 * exist on the pad */
826 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
833 HV *pmstash = PmopSTASH(cPMOPo);
834 if (pmstash && SvREFCNT(pmstash)) {
835 PMOP *pmop = HvPMROOT(pmstash);
836 PMOP *lastpmop = NULL;
838 if (cPMOPo == pmop) {
840 lastpmop->op_pmnext = pmop->op_pmnext;
842 HvPMROOT(pmstash) = pmop->op_pmnext;
846 pmop = pmop->op_pmnext;
850 Safefree(PmopSTASHPV(cPMOPo));
852 /* NOTE: PMOP.op_pmstash is not refcounted */
855 cPMOPo->op_pmreplroot = Nullop;
856 /* we use the "SAFE" version of the PM_ macros here
857 * since sv_clean_all might release some PMOPs
858 * after PL_regex_padav has been cleared
859 * and the clearing of PL_regex_padav needs to
860 * happen before sv_clean_all
862 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
863 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
865 if(PL_regex_pad) { /* We could be in destruction */
866 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
867 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
868 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
875 if (o->op_targ > 0) {
876 pad_free(o->op_targ);
882 S_cop_free(pTHX_ COP* cop)
884 Safefree(cop->cop_label);
886 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
887 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
889 /* NOTE: COP.cop_stash is not refcounted */
890 SvREFCNT_dec(CopFILEGV(cop));
892 if (! specialWARN(cop->cop_warnings))
893 SvREFCNT_dec(cop->cop_warnings);
894 if (! specialCopIO(cop->cop_io))
895 SvREFCNT_dec(cop->cop_io);
899 Perl_op_null(pTHX_ OP *o)
901 if (o->op_type == OP_NULL)
904 o->op_targ = o->op_type;
905 o->op_type = OP_NULL;
906 o->op_ppaddr = PL_ppaddr[OP_NULL];
909 /* Contextualizers */
911 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
914 Perl_linklist(pTHX_ OP *o)
921 /* establish postfix order */
922 if (cUNOPo->op_first) {
923 o->op_next = LINKLIST(cUNOPo->op_first);
924 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
926 kid->op_next = LINKLIST(kid->op_sibling);
938 Perl_scalarkids(pTHX_ OP *o)
941 if (o && o->op_flags & OPf_KIDS) {
942 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
949 S_scalarboolean(pTHX_ OP *o)
951 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
952 if (ckWARN(WARN_SYNTAX)) {
953 line_t oldline = CopLINE(PL_curcop);
955 if (PL_copline != NOLINE)
956 CopLINE_set(PL_curcop, PL_copline);
957 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
958 CopLINE_set(PL_curcop, oldline);
965 Perl_scalar(pTHX_ OP *o)
969 /* assumes no premature commitment */
970 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
971 || o->op_type == OP_RETURN)
976 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
978 switch (o->op_type) {
980 scalar(cBINOPo->op_first);
985 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
989 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
990 if (!kPMOP->op_pmreplroot)
991 deprecate("implicit split to @_");
999 if (o->op_flags & OPf_KIDS) {
1000 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1006 kid = cLISTOPo->op_first;
1008 while ((kid = kid->op_sibling)) {
1009 if (kid->op_sibling)
1014 WITH_THR(PL_curcop = &PL_compiling);
1019 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1020 if (kid->op_sibling)
1025 WITH_THR(PL_curcop = &PL_compiling);
1028 if (ckWARN(WARN_VOID))
1029 Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
1035 Perl_scalarvoid(pTHX_ OP *o)
1042 if (o->op_type == OP_NEXTSTATE
1043 || o->op_type == OP_SETSTATE
1044 || o->op_type == OP_DBSTATE
1045 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1046 || o->op_targ == OP_SETSTATE
1047 || o->op_targ == OP_DBSTATE)))
1048 PL_curcop = (COP*)o; /* for warning below */
1050 /* assumes no premature commitment */
1051 want = o->op_flags & OPf_WANT;
1052 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1053 || o->op_type == OP_RETURN)
1058 if ((o->op_private & OPpTARGET_MY)
1059 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1061 return scalar(o); /* As if inside SASSIGN */
1064 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1066 switch (o->op_type) {
1068 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1072 if (o->op_flags & OPf_STACKED)
1076 if (o->op_private == 4)
1118 case OP_GETSOCKNAME:
1119 case OP_GETPEERNAME:
1124 case OP_GETPRIORITY:
1147 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1148 useless = OP_DESC(o);
1155 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1156 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1157 useless = "a variable";
1162 if (cSVOPo->op_private & OPpCONST_STRICT)
1163 no_bareword_allowed(o);
1165 if (ckWARN(WARN_VOID)) {
1166 useless = "a constant";
1167 /* the constants 0 and 1 are permitted as they are
1168 conventionally used as dummies in constructs like
1169 1 while some_condition_with_side_effects; */
1170 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1172 else if (SvPOK(sv)) {
1173 /* perl4's way of mixing documentation and code
1174 (before the invention of POD) was based on a
1175 trick to mix nroff and perl code. The trick was
1176 built upon these three nroff macros being used in
1177 void context. The pink camel has the details in
1178 the script wrapman near page 319. */
1179 if (strnEQ(SvPVX(sv), "di", 2) ||
1180 strnEQ(SvPVX(sv), "ds", 2) ||
1181 strnEQ(SvPVX(sv), "ig", 2))
1186 op_null(o); /* don't execute or even remember it */
1190 o->op_type = OP_PREINC; /* pre-increment is faster */
1191 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1195 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1196 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1202 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1207 if (o->op_flags & OPf_STACKED)
1214 if (!(o->op_flags & OPf_KIDS))
1223 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1230 /* all requires must return a boolean value */
1231 o->op_flags &= ~OPf_WANT;
1236 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1237 if (!kPMOP->op_pmreplroot)
1238 deprecate("implicit split to @_");
1242 if (useless && ckWARN(WARN_VOID))
1243 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1248 Perl_listkids(pTHX_ OP *o)
1251 if (o && o->op_flags & OPf_KIDS) {
1252 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1259 Perl_list(pTHX_ OP *o)
1263 /* assumes no premature commitment */
1264 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1265 || o->op_type == OP_RETURN)
1270 if ((o->op_private & OPpTARGET_MY)
1271 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1273 return o; /* As if inside SASSIGN */
1276 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1278 switch (o->op_type) {
1281 list(cBINOPo->op_first);
1286 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1294 if (!(o->op_flags & OPf_KIDS))
1296 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1297 list(cBINOPo->op_first);
1298 return gen_constant_list(o);
1305 kid = cLISTOPo->op_first;
1307 while ((kid = kid->op_sibling)) {
1308 if (kid->op_sibling)
1313 WITH_THR(PL_curcop = &PL_compiling);
1317 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1318 if (kid->op_sibling)
1323 WITH_THR(PL_curcop = &PL_compiling);
1326 /* all requires must return a boolean value */
1327 o->op_flags &= ~OPf_WANT;
1334 Perl_scalarseq(pTHX_ OP *o)
1339 if (o->op_type == OP_LINESEQ ||
1340 o->op_type == OP_SCOPE ||
1341 o->op_type == OP_LEAVE ||
1342 o->op_type == OP_LEAVETRY)
1344 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1345 if (kid->op_sibling) {
1349 PL_curcop = &PL_compiling;
1351 o->op_flags &= ~OPf_PARENS;
1352 if (PL_hints & HINT_BLOCK_SCOPE)
1353 o->op_flags |= OPf_PARENS;
1356 o = newOP(OP_STUB, 0);
1361 S_modkids(pTHX_ OP *o, I32 type)
1364 if (o && o->op_flags & OPf_KIDS) {
1365 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1372 Perl_mod(pTHX_ OP *o, I32 type)
1377 if (!o || PL_error_count)
1380 if ((o->op_private & OPpTARGET_MY)
1381 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1386 switch (o->op_type) {
1391 if (!(o->op_private & (OPpCONST_ARYBASE)))
1393 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1394 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1398 SAVEI32(PL_compiling.cop_arybase);
1399 PL_compiling.cop_arybase = 0;
1401 else if (type == OP_REFGEN)
1404 Perl_croak(aTHX_ "That use of $[ is unsupported");
1407 if (o->op_flags & OPf_PARENS)
1411 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1412 !(o->op_flags & OPf_STACKED)) {
1413 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1414 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1415 assert(cUNOPo->op_first->op_type == OP_NULL);
1416 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1419 else { /* lvalue subroutine call */
1420 o->op_private |= OPpLVAL_INTRO;
1421 PL_modcount = RETURN_UNLIMITED_NUMBER;
1422 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1423 /* Backward compatibility mode: */
1424 o->op_private |= OPpENTERSUB_INARGS;
1427 else { /* Compile-time error message: */
1428 OP *kid = cUNOPo->op_first;
1432 if (kid->op_type == OP_PUSHMARK)
1434 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1436 "panic: unexpected lvalue entersub "
1437 "args: type/targ %ld:%"UVuf,
1438 (long)kid->op_type, (UV)kid->op_targ);
1439 kid = kLISTOP->op_first;
1441 while (kid->op_sibling)
1442 kid = kid->op_sibling;
1443 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1445 if (kid->op_type == OP_METHOD_NAMED
1446 || kid->op_type == OP_METHOD)
1450 NewOp(1101, newop, 1, UNOP);
1451 newop->op_type = OP_RV2CV;
1452 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1453 newop->op_first = Nullop;
1454 newop->op_next = (OP*)newop;
1455 kid->op_sibling = (OP*)newop;
1456 newop->op_private |= OPpLVAL_INTRO;
1460 if (kid->op_type != OP_RV2CV)
1462 "panic: unexpected lvalue entersub "
1463 "entry via type/targ %ld:%"UVuf,
1464 (long)kid->op_type, (UV)kid->op_targ);
1465 kid->op_private |= OPpLVAL_INTRO;
1466 break; /* Postpone until runtime */
1470 kid = kUNOP->op_first;
1471 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL)
1475 "Unexpected constant lvalue entersub "
1476 "entry via type/targ %ld:%"UVuf,
1477 (long)kid->op_type, (UV)kid->op_targ);
1478 if (kid->op_type != OP_GV) {
1479 /* Restore RV2CV to check lvalueness */
1481 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1482 okid->op_next = kid->op_next;
1483 kid->op_next = okid;
1486 okid->op_next = Nullop;
1487 okid->op_type = OP_RV2CV;
1489 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1490 okid->op_private |= OPpLVAL_INTRO;
1494 cv = GvCV(kGVOP_gv);
1504 /* grep, foreach, subcalls, refgen */
1505 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1507 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1508 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1510 : (o->op_type == OP_ENTERSUB
1511 ? "non-lvalue subroutine call"
1513 type ? PL_op_desc[type] : "local"));
1527 case OP_RIGHT_SHIFT:
1536 if (!(o->op_flags & OPf_STACKED))
1542 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1548 if (!type && cUNOPo->op_first->op_type != OP_GV)
1549 Perl_croak(aTHX_ "Can't localize through a reference");
1550 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1551 PL_modcount = RETURN_UNLIMITED_NUMBER;
1552 return o; /* Treat \(@foo) like ordinary list. */
1556 if (scalar_mod_type(o, type))
1558 ref(cUNOPo->op_first, o->op_type);
1562 if (type == OP_LEAVESUBLV)
1563 o->op_private |= OPpMAYBE_LVSUB;
1569 PL_modcount = RETURN_UNLIMITED_NUMBER;
1572 if (!type && cUNOPo->op_first->op_type != OP_GV)
1573 Perl_croak(aTHX_ "Can't localize through a reference");
1574 ref(cUNOPo->op_first, o->op_type);
1578 PL_hints |= HINT_BLOCK_SCOPE;
1588 PL_modcount = RETURN_UNLIMITED_NUMBER;
1589 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1590 return o; /* Treat \(@foo) like ordinary list. */
1591 if (scalar_mod_type(o, type))
1593 if (type == OP_LEAVESUBLV)
1594 o->op_private |= OPpMAYBE_LVSUB;
1599 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1600 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1603 #ifdef USE_5005THREADS
1605 PL_modcount++; /* XXX ??? */
1607 #endif /* USE_5005THREADS */
1613 if (type != OP_SASSIGN)
1617 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1622 if (type == OP_LEAVESUBLV)
1623 o->op_private |= OPpMAYBE_LVSUB;
1625 pad_free(o->op_targ);
1626 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1627 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1628 if (o->op_flags & OPf_KIDS)
1629 mod(cBINOPo->op_first->op_sibling, type);
1634 ref(cBINOPo->op_first, o->op_type);
1635 if (type == OP_ENTERSUB &&
1636 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1637 o->op_private |= OPpLVAL_DEFER;
1638 if (type == OP_LEAVESUBLV)
1639 o->op_private |= OPpMAYBE_LVSUB;
1647 if (o->op_flags & OPf_KIDS)
1648 mod(cLISTOPo->op_last, type);
1652 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1654 else if (!(o->op_flags & OPf_KIDS))
1656 if (o->op_targ != OP_LIST) {
1657 mod(cBINOPo->op_first, type);
1662 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1667 if (type != OP_LEAVESUBLV)
1669 break; /* mod()ing was handled by ck_return() */
1672 /* [20011101.069] File test operators interpret OPf_REF to mean that
1673 their argument is a filehandle; thus \stat(".") should not set
1675 if (type == OP_REFGEN &&
1676 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1679 if (type != OP_LEAVESUBLV)
1680 o->op_flags |= OPf_MOD;
1682 if (type == OP_AASSIGN || type == OP_SASSIGN)
1683 o->op_flags |= OPf_SPECIAL|OPf_REF;
1685 o->op_private |= OPpLVAL_INTRO;
1686 o->op_flags &= ~OPf_SPECIAL;
1687 PL_hints |= HINT_BLOCK_SCOPE;
1689 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1690 && type != OP_LEAVESUBLV)
1691 o->op_flags |= OPf_REF;
1696 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1700 if (o->op_type == OP_RV2GV)
1724 case OP_RIGHT_SHIFT:
1743 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1745 switch (o->op_type) {
1753 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1766 Perl_refkids(pTHX_ OP *o, I32 type)
1769 if (o && o->op_flags & OPf_KIDS) {
1770 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1777 Perl_ref(pTHX_ OP *o, I32 type)
1781 if (!o || PL_error_count)
1784 switch (o->op_type) {
1786 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1787 !(o->op_flags & OPf_STACKED)) {
1788 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1789 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1790 assert(cUNOPo->op_first->op_type == OP_NULL);
1791 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1792 o->op_flags |= OPf_SPECIAL;
1797 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1801 if (type == OP_DEFINED)
1802 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1803 ref(cUNOPo->op_first, o->op_type);
1806 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1807 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1808 : type == OP_RV2HV ? OPpDEREF_HV
1810 o->op_flags |= OPf_MOD;
1815 o->op_flags |= OPf_MOD; /* XXX ??? */
1820 o->op_flags |= OPf_REF;
1823 if (type == OP_DEFINED)
1824 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1825 ref(cUNOPo->op_first, o->op_type);
1830 o->op_flags |= OPf_REF;
1835 if (!(o->op_flags & OPf_KIDS))
1837 ref(cBINOPo->op_first, type);
1841 ref(cBINOPo->op_first, o->op_type);
1842 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1843 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1844 : type == OP_RV2HV ? OPpDEREF_HV
1846 o->op_flags |= OPf_MOD;
1854 if (!(o->op_flags & OPf_KIDS))
1856 ref(cLISTOPo->op_last, type);
1866 S_dup_attrlist(pTHX_ OP *o)
1870 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1871 * where the first kid is OP_PUSHMARK and the remaining ones
1872 * are OP_CONST. We need to push the OP_CONST values.
1874 if (o->op_type == OP_CONST)
1875 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1877 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1878 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1879 if (o->op_type == OP_CONST)
1880 rop = append_elem(OP_LIST, rop,
1881 newSVOP(OP_CONST, o->op_flags,
1882 SvREFCNT_inc(cSVOPo->op_sv)));
1889 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1893 /* fake up C<use attributes $pkg,$rv,@attrs> */
1894 ENTER; /* need to protect against side-effects of 'use' */
1897 stashsv = newSVpv(HvNAME(stash), 0);
1899 stashsv = &PL_sv_no;
1901 #define ATTRSMODULE "attributes"
1903 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1904 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1906 prepend_elem(OP_LIST,
1907 newSVOP(OP_CONST, 0, stashsv),
1908 prepend_elem(OP_LIST,
1909 newSVOP(OP_CONST, 0,
1911 dup_attrlist(attrs))));
1916 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1917 char *attrstr, STRLEN len)
1922 len = strlen(attrstr);
1926 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1928 char *sstr = attrstr;
1929 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1930 attrs = append_elem(OP_LIST, attrs,
1931 newSVOP(OP_CONST, 0,
1932 newSVpvn(sstr, attrstr-sstr)));
1936 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1937 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1938 Nullsv, prepend_elem(OP_LIST,
1939 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1940 prepend_elem(OP_LIST,
1941 newSVOP(OP_CONST, 0,
1947 S_my_kid(pTHX_ OP *o, OP *attrs)
1952 if (!o || PL_error_count)
1956 if (type == OP_LIST) {
1957 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1959 } else if (type == OP_UNDEF) {
1961 } else if (type == OP_RV2SV || /* "our" declaration */
1963 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1965 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1967 PL_in_my_stash = Nullhv;
1968 apply_attrs(GvSTASH(gv),
1969 (type == OP_RV2SV ? GvSV(gv) :
1970 type == OP_RV2AV ? (SV*)GvAV(gv) :
1971 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1974 o->op_private |= OPpOUR_INTRO;
1976 } else if (type != OP_PADSV &&
1979 type != OP_PUSHMARK)
1981 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1983 PL_in_my == KEY_our ? "our" : "my"));
1986 else if (attrs && type != OP_PUSHMARK) {
1992 PL_in_my_stash = Nullhv;
1994 /* check for C<my Dog $spot> when deciding package */
1995 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1996 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
1997 stash = SvSTASH(*namesvp);
1999 stash = PL_curstash;
2000 padsv = PAD_SV(o->op_targ);
2001 apply_attrs(stash, padsv, attrs);
2003 o->op_flags |= OPf_MOD;
2004 o->op_private |= OPpLVAL_INTRO;
2009 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2011 if (o->op_flags & OPf_PARENS)
2015 o = my_kid(o, attrs);
2017 PL_in_my_stash = Nullhv;
2022 Perl_my(pTHX_ OP *o)
2024 return my_kid(o, Nullop);
2028 Perl_sawparens(pTHX_ OP *o)
2031 o->op_flags |= OPf_PARENS;
2036 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2040 if (ckWARN(WARN_MISC) &&
2041 (left->op_type == OP_RV2AV ||
2042 left->op_type == OP_RV2HV ||
2043 left->op_type == OP_PADAV ||
2044 left->op_type == OP_PADHV)) {
2045 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2046 right->op_type == OP_TRANS)
2047 ? right->op_type : OP_MATCH];
2048 const char *sample = ((left->op_type == OP_RV2AV ||
2049 left->op_type == OP_PADAV)
2050 ? "@array" : "%hash");
2051 Perl_warner(aTHX_ WARN_MISC,
2052 "Applying %s to %s will act on scalar(%s)",
2053 desc, sample, sample);
2056 if (right->op_type == OP_CONST &&
2057 cSVOPx(right)->op_private & OPpCONST_BARE &&
2058 cSVOPx(right)->op_private & OPpCONST_STRICT)
2060 no_bareword_allowed(right);
2063 if (!(right->op_flags & OPf_STACKED) &&
2064 (right->op_type == OP_MATCH ||
2065 right->op_type == OP_SUBST ||
2066 right->op_type == OP_TRANS)) {
2067 right->op_flags |= OPf_STACKED;
2068 if ((right->op_type != OP_MATCH &&
2069 ! (right->op_type == OP_TRANS &&
2070 right->op_private & OPpTRANS_IDENTICAL)) ||
2071 /* if SV has magic, then match on original SV, not on its copy.
2072 see note in pp_helem() */
2073 (right->op_type == OP_MATCH &&
2074 (left->op_type == OP_AELEM ||
2075 left->op_type == OP_HELEM ||
2076 left->op_type == OP_AELEMFAST)))
2077 left = mod(left, right->op_type);
2078 if (right->op_type == OP_TRANS)
2079 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2081 o = prepend_elem(right->op_type, scalar(left), right);
2083 return newUNOP(OP_NOT, 0, scalar(o));
2087 return bind_match(type, left,
2088 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2092 Perl_invert(pTHX_ OP *o)
2096 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2097 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2101 Perl_scope(pTHX_ OP *o)
2104 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2105 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2106 o->op_type = OP_LEAVE;
2107 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2110 if (o->op_type == OP_LINESEQ) {
2112 o->op_type = OP_SCOPE;
2113 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2114 kid = ((LISTOP*)o)->op_first;
2115 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2119 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2126 Perl_save_hints(pTHX)
2129 SAVESPTR(GvHV(PL_hintgv));
2130 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2131 SAVEFREESV(GvHV(PL_hintgv));
2135 Perl_block_start(pTHX_ int full)
2137 int retval = PL_savestack_ix;
2139 SAVEI32(PL_comppad_name_floor);
2140 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2142 PL_comppad_name_fill = PL_comppad_name_floor;
2143 if (PL_comppad_name_floor < 0)
2144 PL_comppad_name_floor = 0;
2145 SAVEI32(PL_min_intro_pending);
2146 SAVEI32(PL_max_intro_pending);
2147 PL_min_intro_pending = 0;
2148 SAVEI32(PL_comppad_name_fill);
2149 SAVEI32(PL_padix_floor);
2150 PL_padix_floor = PL_padix;
2151 PL_pad_reset_pending = FALSE;
2153 PL_hints &= ~HINT_BLOCK_SCOPE;
2154 SAVESPTR(PL_compiling.cop_warnings);
2155 if (! specialWARN(PL_compiling.cop_warnings)) {
2156 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2157 SAVEFREESV(PL_compiling.cop_warnings) ;
2159 SAVESPTR(PL_compiling.cop_io);
2160 if (! specialCopIO(PL_compiling.cop_io)) {
2161 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2162 SAVEFREESV(PL_compiling.cop_io) ;
2168 Perl_block_end(pTHX_ I32 floor, OP *seq)
2170 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2171 line_t copline = PL_copline;
2172 /* there should be a nextstate in every block */
2173 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2174 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2176 PL_pad_reset_pending = FALSE;
2177 PL_compiling.op_private = PL_hints;
2179 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2180 pad_leavemy(PL_comppad_name_fill);
2188 #ifdef USE_5005THREADS
2189 OP *o = newOP(OP_THREADSV, 0);
2190 o->op_targ = find_threadsv("_");
2193 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2194 #endif /* USE_5005THREADS */
2198 Perl_newPROG(pTHX_ OP *o)
2203 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2204 ((PL_in_eval & EVAL_KEEPERR)
2205 ? OPf_SPECIAL : 0), o);
2206 PL_eval_start = linklist(PL_eval_root);
2207 PL_eval_root->op_private |= OPpREFCOUNTED;
2208 OpREFCNT_set(PL_eval_root, 1);
2209 PL_eval_root->op_next = 0;
2210 CALL_PEEP(PL_eval_start);
2215 PL_main_root = scope(sawparens(scalarvoid(o)));
2216 PL_curcop = &PL_compiling;
2217 PL_main_start = LINKLIST(PL_main_root);
2218 PL_main_root->op_private |= OPpREFCOUNTED;
2219 OpREFCNT_set(PL_main_root, 1);
2220 PL_main_root->op_next = 0;
2221 CALL_PEEP(PL_main_start);
2224 /* Register with debugger */
2226 CV *cv = get_cv("DB::postponed", FALSE);
2230 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2232 call_sv((SV*)cv, G_DISCARD);
2239 Perl_localize(pTHX_ OP *o, I32 lex)
2241 if (o->op_flags & OPf_PARENS)
2244 if (ckWARN(WARN_PARENTHESIS)
2245 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2247 char *s = PL_bufptr;
2249 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2252 if (*s == ';' || *s == '=')
2253 Perl_warner(aTHX_ WARN_PARENTHESIS,
2254 "Parentheses missing around \"%s\" list",
2255 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2261 o = mod(o, OP_NULL); /* a bit kludgey */
2263 PL_in_my_stash = Nullhv;
2268 Perl_jmaybe(pTHX_ OP *o)
2270 if (o->op_type == OP_LIST) {
2272 #ifdef USE_5005THREADS
2273 o2 = newOP(OP_THREADSV, 0);
2274 o2->op_targ = find_threadsv(";");
2276 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2277 #endif /* USE_5005THREADS */
2278 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2284 Perl_fold_constants(pTHX_ register OP *o)
2287 I32 type = o->op_type;
2290 if (PL_opargs[type] & OA_RETSCALAR)
2292 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2293 o->op_targ = pad_alloc(type, SVs_PADTMP);
2295 /* integerize op, unless it happens to be C<-foo>.
2296 * XXX should pp_i_negate() do magic string negation instead? */
2297 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2298 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2299 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2301 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2304 if (!(PL_opargs[type] & OA_FOLDCONST))
2309 /* XXX might want a ck_negate() for this */
2310 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2322 /* XXX what about the numeric ops? */
2323 if (PL_hints & HINT_LOCALE)
2328 goto nope; /* Don't try to run w/ errors */
2330 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2331 if ((curop->op_type != OP_CONST ||
2332 (curop->op_private & OPpCONST_BARE)) &&
2333 curop->op_type != OP_LIST &&
2334 curop->op_type != OP_SCALAR &&
2335 curop->op_type != OP_NULL &&
2336 curop->op_type != OP_PUSHMARK)
2342 curop = LINKLIST(o);
2346 sv = *(PL_stack_sp--);
2347 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2348 pad_swipe(o->op_targ);
2349 else if (SvTEMP(sv)) { /* grab mortal temp? */
2350 (void)SvREFCNT_inc(sv);
2354 if (type == OP_RV2GV)
2355 return newGVOP(OP_GV, 0, (GV*)sv);
2357 /* try to smush double to int, but don't smush -2.0 to -2 */
2358 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2361 #ifdef PERL_PRESERVE_IVUV
2362 /* Only bother to attempt to fold to IV if
2363 most operators will benefit */
2367 return newSVOP(OP_CONST, 0, sv);
2371 if (!(PL_opargs[type] & OA_OTHERINT))
2374 if (!(PL_hints & HINT_INTEGER)) {
2375 if (type == OP_MODULO
2376 || type == OP_DIVIDE
2377 || !(o->op_flags & OPf_KIDS))
2382 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2383 if (curop->op_type == OP_CONST) {
2384 if (SvIOK(((SVOP*)curop)->op_sv))
2388 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2392 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2399 Perl_gen_constant_list(pTHX_ register OP *o)
2402 I32 oldtmps_floor = PL_tmps_floor;
2406 return o; /* Don't attempt to run with errors */
2408 PL_op = curop = LINKLIST(o);
2415 PL_tmps_floor = oldtmps_floor;
2417 o->op_type = OP_RV2AV;
2418 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2419 curop = ((UNOP*)o)->op_first;
2420 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2427 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2429 if (!o || o->op_type != OP_LIST)
2430 o = newLISTOP(OP_LIST, 0, o, Nullop);
2432 o->op_flags &= ~OPf_WANT;
2434 if (!(PL_opargs[type] & OA_MARK))
2435 op_null(cLISTOPo->op_first);
2438 o->op_ppaddr = PL_ppaddr[type];
2439 o->op_flags |= flags;
2441 o = CHECKOP(type, o);
2442 if (o->op_type != type)
2445 return fold_constants(o);
2448 /* List constructors */
2451 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2459 if (first->op_type != type
2460 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2462 return newLISTOP(type, 0, first, last);
2465 if (first->op_flags & OPf_KIDS)
2466 ((LISTOP*)first)->op_last->op_sibling = last;
2468 first->op_flags |= OPf_KIDS;
2469 ((LISTOP*)first)->op_first = last;
2471 ((LISTOP*)first)->op_last = last;
2476 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2484 if (first->op_type != type)
2485 return prepend_elem(type, (OP*)first, (OP*)last);
2487 if (last->op_type != type)
2488 return append_elem(type, (OP*)first, (OP*)last);
2490 first->op_last->op_sibling = last->op_first;
2491 first->op_last = last->op_last;
2492 first->op_flags |= (last->op_flags & OPf_KIDS);
2494 #ifdef PL_OP_SLAB_ALLOC
2502 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2510 if (last->op_type == type) {
2511 if (type == OP_LIST) { /* already a PUSHMARK there */
2512 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2513 ((LISTOP*)last)->op_first->op_sibling = first;
2514 if (!(first->op_flags & OPf_PARENS))
2515 last->op_flags &= ~OPf_PARENS;
2518 if (!(last->op_flags & OPf_KIDS)) {
2519 ((LISTOP*)last)->op_last = first;
2520 last->op_flags |= OPf_KIDS;
2522 first->op_sibling = ((LISTOP*)last)->op_first;
2523 ((LISTOP*)last)->op_first = first;
2525 last->op_flags |= OPf_KIDS;
2529 return newLISTOP(type, 0, first, last);
2535 Perl_newNULLLIST(pTHX)
2537 return newOP(OP_STUB, 0);
2541 Perl_force_list(pTHX_ OP *o)
2543 if (!o || o->op_type != OP_LIST)
2544 o = newLISTOP(OP_LIST, 0, o, Nullop);
2550 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2554 NewOp(1101, listop, 1, LISTOP);
2556 listop->op_type = type;
2557 listop->op_ppaddr = PL_ppaddr[type];
2560 listop->op_flags = flags;
2564 else if (!first && last)
2567 first->op_sibling = last;
2568 listop->op_first = first;
2569 listop->op_last = last;
2570 if (type == OP_LIST) {
2572 pushop = newOP(OP_PUSHMARK, 0);
2573 pushop->op_sibling = first;
2574 listop->op_first = pushop;
2575 listop->op_flags |= OPf_KIDS;
2577 listop->op_last = pushop;
2584 Perl_newOP(pTHX_ I32 type, I32 flags)
2587 NewOp(1101, o, 1, OP);
2589 o->op_ppaddr = PL_ppaddr[type];
2590 o->op_flags = flags;
2593 o->op_private = 0 + (flags >> 8);
2594 if (PL_opargs[type] & OA_RETSCALAR)
2596 if (PL_opargs[type] & OA_TARGET)
2597 o->op_targ = pad_alloc(type, SVs_PADTMP);
2598 return CHECKOP(type, o);
2602 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2607 first = newOP(OP_STUB, 0);
2608 if (PL_opargs[type] & OA_MARK)
2609 first = force_list(first);
2611 NewOp(1101, unop, 1, UNOP);
2612 unop->op_type = type;
2613 unop->op_ppaddr = PL_ppaddr[type];
2614 unop->op_first = first;
2615 unop->op_flags = flags | OPf_KIDS;
2616 unop->op_private = 1 | (flags >> 8);
2617 unop = (UNOP*) CHECKOP(type, unop);
2621 return fold_constants((OP *) unop);
2625 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2628 NewOp(1101, binop, 1, BINOP);
2631 first = newOP(OP_NULL, 0);
2633 binop->op_type = type;
2634 binop->op_ppaddr = PL_ppaddr[type];
2635 binop->op_first = first;
2636 binop->op_flags = flags | OPf_KIDS;
2639 binop->op_private = 1 | (flags >> 8);
2642 binop->op_private = 2 | (flags >> 8);
2643 first->op_sibling = last;
2646 binop = (BINOP*)CHECKOP(type, binop);
2647 if (binop->op_next || binop->op_type != type)
2650 binop->op_last = binop->op_first->op_sibling;
2652 return fold_constants((OP *)binop);
2656 uvcompare(const void *a, const void *b)
2658 if (*((UV *)a) < (*(UV *)b))
2660 if (*((UV *)a) > (*(UV *)b))
2662 if (*((UV *)a+1) < (*(UV *)b+1))
2664 if (*((UV *)a+1) > (*(UV *)b+1))
2670 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2672 SV *tstr = ((SVOP*)expr)->op_sv;
2673 SV *rstr = ((SVOP*)repl)->op_sv;
2676 U8 *t = (U8*)SvPV(tstr, tlen);
2677 U8 *r = (U8*)SvPV(rstr, rlen);
2684 register short *tbl;
2686 PL_hints |= HINT_BLOCK_SCOPE;
2687 complement = o->op_private & OPpTRANS_COMPLEMENT;
2688 del = o->op_private & OPpTRANS_DELETE;
2689 squash = o->op_private & OPpTRANS_SQUASH;
2692 o->op_private |= OPpTRANS_FROM_UTF;
2695 o->op_private |= OPpTRANS_TO_UTF;
2697 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2698 SV* listsv = newSVpvn("# comment\n",10);
2700 U8* tend = t + tlen;
2701 U8* rend = r + rlen;
2715 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2716 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2722 tsave = t = bytes_to_utf8(t, &len);
2725 if (!to_utf && rlen) {
2727 rsave = r = bytes_to_utf8(r, &len);
2731 /* There are several snags with this code on EBCDIC:
2732 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2733 2. scan_const() in toke.c has encoded chars in native encoding which makes
2734 ranges at least in EBCDIC 0..255 range the bottom odd.
2738 U8 tmpbuf[UTF8_MAXLEN+1];
2741 New(1109, cp, 2*tlen, UV);
2743 transv = newSVpvn("",0);
2745 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2747 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2749 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2753 cp[2*i+1] = cp[2*i];
2757 qsort(cp, i, 2*sizeof(UV), uvcompare);
2758 for (j = 0; j < i; j++) {
2760 diff = val - nextmin;
2762 t = uvuni_to_utf8(tmpbuf,nextmin);
2763 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2765 U8 range_mark = UTF_TO_NATIVE(0xff);
2766 t = uvuni_to_utf8(tmpbuf, val - 1);
2767 sv_catpvn(transv, (char *)&range_mark, 1);
2768 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2775 t = uvuni_to_utf8(tmpbuf,nextmin);
2776 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2778 U8 range_mark = UTF_TO_NATIVE(0xff);
2779 sv_catpvn(transv, (char *)&range_mark, 1);
2781 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2782 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2783 t = (U8*)SvPVX(transv);
2784 tlen = SvCUR(transv);
2788 else if (!rlen && !del) {
2789 r = t; rlen = tlen; rend = tend;
2792 if ((!rlen && !del) || t == r ||
2793 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2795 o->op_private |= OPpTRANS_IDENTICAL;
2799 while (t < tend || tfirst <= tlast) {
2800 /* see if we need more "t" chars */
2801 if (tfirst > tlast) {
2802 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2804 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2806 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2813 /* now see if we need more "r" chars */
2814 if (rfirst > rlast) {
2816 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2818 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2820 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2829 rfirst = rlast = 0xffffffff;
2833 /* now see which range will peter our first, if either. */
2834 tdiff = tlast - tfirst;
2835 rdiff = rlast - rfirst;
2842 if (rfirst == 0xffffffff) {
2843 diff = tdiff; /* oops, pretend rdiff is infinite */
2845 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2846 (long)tfirst, (long)tlast);
2848 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2852 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2853 (long)tfirst, (long)(tfirst + diff),
2856 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2857 (long)tfirst, (long)rfirst);
2859 if (rfirst + diff > max)
2860 max = rfirst + diff;
2862 grows = (tfirst < rfirst &&
2863 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2875 else if (max > 0xff)
2880 Safefree(cPVOPo->op_pv);
2881 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2882 SvREFCNT_dec(listsv);
2884 SvREFCNT_dec(transv);
2886 if (!del && havefinal && rlen)
2887 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2888 newSVuv((UV)final), 0);
2891 o->op_private |= OPpTRANS_GROWS;
2903 tbl = (short*)cPVOPo->op_pv;
2905 Zero(tbl, 256, short);
2906 for (i = 0; i < tlen; i++)
2908 for (i = 0, j = 0; i < 256; i++) {
2919 if (i < 128 && r[j] >= 128)
2929 o->op_private |= OPpTRANS_IDENTICAL;
2934 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2935 tbl[0x100] = rlen - j;
2936 for (i=0; i < rlen - j; i++)
2937 tbl[0x101+i] = r[j+i];
2941 if (!rlen && !del) {
2944 o->op_private |= OPpTRANS_IDENTICAL;
2946 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2947 o->op_private |= OPpTRANS_IDENTICAL;
2949 for (i = 0; i < 256; i++)
2951 for (i = 0, j = 0; i < tlen; i++,j++) {
2954 if (tbl[t[i]] == -1)
2960 if (tbl[t[i]] == -1) {
2961 if (t[i] < 128 && r[j] >= 128)
2968 o->op_private |= OPpTRANS_GROWS;
2976 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2980 NewOp(1101, pmop, 1, PMOP);
2981 pmop->op_type = type;
2982 pmop->op_ppaddr = PL_ppaddr[type];
2983 pmop->op_flags = flags;
2984 pmop->op_private = 0 | (flags >> 8);
2986 if (PL_hints & HINT_RE_TAINT)
2987 pmop->op_pmpermflags |= PMf_RETAINT;
2988 if (PL_hints & HINT_LOCALE)
2989 pmop->op_pmpermflags |= PMf_LOCALE;
2990 pmop->op_pmflags = pmop->op_pmpermflags;
2995 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2996 repointer = av_pop((AV*)PL_regex_pad[0]);
2997 pmop->op_pmoffset = SvIV(repointer);
2998 SvREPADTMP_off(repointer);
2999 sv_setiv(repointer,0);
3001 repointer = newSViv(0);
3002 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3003 pmop->op_pmoffset = av_len(PL_regex_padav);
3004 PL_regex_pad = AvARRAY(PL_regex_padav);
3009 /* link into pm list */
3010 if (type != OP_TRANS && PL_curstash) {
3011 pmop->op_pmnext = HvPMROOT(PL_curstash);
3012 HvPMROOT(PL_curstash) = pmop;
3013 PmopSTASH_set(pmop,PL_curstash);
3020 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3024 I32 repl_has_vars = 0;
3026 if (o->op_type == OP_TRANS)
3027 return pmtrans(o, expr, repl);
3029 PL_hints |= HINT_BLOCK_SCOPE;
3032 if (expr->op_type == OP_CONST) {
3034 SV *pat = ((SVOP*)expr)->op_sv;
3035 char *p = SvPV(pat, plen);
3036 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3037 sv_setpvn(pat, "\\s+", 3);
3038 p = SvPV(pat, plen);
3039 pm->op_pmflags |= PMf_SKIPWHITE;
3041 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3042 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3043 pm->op_pmflags |= PMf_WHITE;
3047 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3048 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3050 : OP_REGCMAYBE),0,expr);
3052 NewOp(1101, rcop, 1, LOGOP);
3053 rcop->op_type = OP_REGCOMP;
3054 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3055 rcop->op_first = scalar(expr);
3056 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3057 ? (OPf_SPECIAL | OPf_KIDS)
3059 rcop->op_private = 1;
3062 /* establish postfix order */
3063 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3065 rcop->op_next = expr;
3066 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3069 rcop->op_next = LINKLIST(expr);
3070 expr->op_next = (OP*)rcop;
3073 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3078 if (pm->op_pmflags & PMf_EVAL) {
3080 if (CopLINE(PL_curcop) < PL_multi_end)
3081 CopLINE_set(PL_curcop, PL_multi_end);
3083 #ifdef USE_5005THREADS
3084 else if (repl->op_type == OP_THREADSV
3085 && strchr("&`'123456789+",
3086 PL_threadsv_names[repl->op_targ]))
3090 #endif /* USE_5005THREADS */
3091 else if (repl->op_type == OP_CONST)
3095 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3096 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3097 #ifdef USE_5005THREADS
3098 if (curop->op_type == OP_THREADSV) {
3100 if (strchr("&`'123456789+", curop->op_private))
3104 if (curop->op_type == OP_GV) {
3105 GV *gv = cGVOPx_gv(curop);
3107 if (strchr("&`'123456789+", *GvENAME(gv)))
3110 #endif /* USE_5005THREADS */
3111 else if (curop->op_type == OP_RV2CV)
3113 else if (curop->op_type == OP_RV2SV ||
3114 curop->op_type == OP_RV2AV ||
3115 curop->op_type == OP_RV2HV ||
3116 curop->op_type == OP_RV2GV) {
3117 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3120 else if (curop->op_type == OP_PADSV ||
3121 curop->op_type == OP_PADAV ||
3122 curop->op_type == OP_PADHV ||
3123 curop->op_type == OP_PADANY) {
3126 else if (curop->op_type == OP_PUSHRE)
3127 ; /* Okay here, dangerous in newASSIGNOP */
3137 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3138 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3139 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3140 prepend_elem(o->op_type, scalar(repl), o);
3143 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3144 pm->op_pmflags |= PMf_MAYBE_CONST;
3145 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3147 NewOp(1101, rcop, 1, LOGOP);
3148 rcop->op_type = OP_SUBSTCONT;
3149 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3150 rcop->op_first = scalar(repl);
3151 rcop->op_flags |= OPf_KIDS;
3152 rcop->op_private = 1;
3155 /* establish postfix order */
3156 rcop->op_next = LINKLIST(repl);
3157 repl->op_next = (OP*)rcop;
3159 pm->op_pmreplroot = scalar((OP*)rcop);
3160 pm->op_pmreplstart = LINKLIST(rcop);
3169 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3172 NewOp(1101, svop, 1, SVOP);
3173 svop->op_type = type;
3174 svop->op_ppaddr = PL_ppaddr[type];
3176 svop->op_next = (OP*)svop;
3177 svop->op_flags = flags;
3178 if (PL_opargs[type] & OA_RETSCALAR)
3180 if (PL_opargs[type] & OA_TARGET)
3181 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3182 return CHECKOP(type, svop);
3186 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3189 NewOp(1101, padop, 1, PADOP);
3190 padop->op_type = type;
3191 padop->op_ppaddr = PL_ppaddr[type];
3192 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3193 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3194 PL_curpad[padop->op_padix] = sv;
3196 padop->op_next = (OP*)padop;
3197 padop->op_flags = flags;
3198 if (PL_opargs[type] & OA_RETSCALAR)
3200 if (PL_opargs[type] & OA_TARGET)
3201 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3202 return CHECKOP(type, padop);
3206 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3210 return newPADOP(type, flags, SvREFCNT_inc(gv));
3212 return newSVOP(type, flags, SvREFCNT_inc(gv));
3217 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3220 NewOp(1101, pvop, 1, PVOP);
3221 pvop->op_type = type;
3222 pvop->op_ppaddr = PL_ppaddr[type];
3224 pvop->op_next = (OP*)pvop;
3225 pvop->op_flags = flags;
3226 if (PL_opargs[type] & OA_RETSCALAR)
3228 if (PL_opargs[type] & OA_TARGET)
3229 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3230 return CHECKOP(type, pvop);
3234 Perl_package(pTHX_ OP *o)
3238 save_hptr(&PL_curstash);
3239 save_item(PL_curstname);
3244 name = SvPV(sv, len);
3245 PL_curstash = gv_stashpvn(name,len,TRUE);
3246 sv_setpvn(PL_curstname, name, len);
3250 deprecate("\"package\" with no arguments");
3251 sv_setpv(PL_curstname,"<none>");
3252 PL_curstash = Nullhv;
3254 PL_hints |= HINT_BLOCK_SCOPE;
3255 PL_copline = NOLINE;
3260 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3265 char *packname = Nullch;
3269 if (id->op_type != OP_CONST)
3270 Perl_croak(aTHX_ "Module name must be constant");
3274 if (version != Nullop) {
3275 SV *vesv = ((SVOP*)version)->op_sv;
3277 if (arg == Nullop && !SvNIOKp(vesv)) {
3284 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3285 Perl_croak(aTHX_ "Version number must be constant number");
3287 /* Make copy of id so we don't free it twice */
3288 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3290 /* Fake up a method call to VERSION */
3291 meth = newSVpvn("VERSION",7);
3292 sv_upgrade(meth, SVt_PVIV);
3293 (void)SvIOK_on(meth);
3294 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3295 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3296 append_elem(OP_LIST,
3297 prepend_elem(OP_LIST, pack, list(version)),
3298 newSVOP(OP_METHOD_NAMED, 0, meth)));
3302 /* Fake up an import/unimport */
3303 if (arg && arg->op_type == OP_STUB)
3304 imop = arg; /* no import on explicit () */
3305 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3306 imop = Nullop; /* use 5.0; */
3311 /* Make copy of id so we don't free it twice */
3312 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3314 /* Fake up a method call to import/unimport */
3315 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3316 (void)SvUPGRADE(meth, SVt_PVIV);
3317 (void)SvIOK_on(meth);
3318 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3319 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3320 append_elem(OP_LIST,
3321 prepend_elem(OP_LIST, pack, list(arg)),
3322 newSVOP(OP_METHOD_NAMED, 0, meth)));
3325 if (ckWARN(WARN_MISC) &&
3326 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3327 SvPOK(packsv = ((SVOP*)id)->op_sv))
3329 /* BEGIN will free the ops, so we need to make a copy */
3330 packlen = SvCUR(packsv);
3331 packname = savepvn(SvPVX(packsv), packlen);
3334 /* Fake up the BEGIN {}, which does its thing immediately. */
3336 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3339 append_elem(OP_LINESEQ,
3340 append_elem(OP_LINESEQ,
3341 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3342 newSTATEOP(0, Nullch, veop)),
3343 newSTATEOP(0, Nullch, imop) ));
3346 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3347 Perl_warner(aTHX_ WARN_MISC,
3348 "Package `%s' not found "
3349 "(did you use the incorrect case?)", packname);
3354 PL_hints |= HINT_BLOCK_SCOPE;
3355 PL_copline = NOLINE;
3360 =for apidoc load_module
3362 Loads the module whose name is pointed to by the string part of name.
3363 Note that the actual module name, not its filename, should be given.
3364 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3365 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3366 (or 0 for no flags). ver, if specified, provides version semantics
3367 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3368 arguments can be used to specify arguments to the module's import()
3369 method, similar to C<use Foo::Bar VERSION LIST>.
3374 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3377 va_start(args, ver);
3378 vload_module(flags, name, ver, &args);
3382 #ifdef PERL_IMPLICIT_CONTEXT
3384 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3388 va_start(args, ver);
3389 vload_module(flags, name, ver, &args);
3395 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3397 OP *modname, *veop, *imop;
3399 modname = newSVOP(OP_CONST, 0, name);
3400 modname->op_private |= OPpCONST_BARE;
3402 veop = newSVOP(OP_CONST, 0, ver);
3406 if (flags & PERL_LOADMOD_NOIMPORT) {
3407 imop = sawparens(newNULLLIST());
3409 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3410 imop = va_arg(*args, OP*);
3415 sv = va_arg(*args, SV*);
3417 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3418 sv = va_arg(*args, SV*);
3422 line_t ocopline = PL_copline;
3423 int oexpect = PL_expect;
3425 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3426 veop, modname, imop);
3427 PL_expect = oexpect;
3428 PL_copline = ocopline;
3433 Perl_dofile(pTHX_ OP *term)
3438 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3439 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3440 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3442 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3443 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3444 append_elem(OP_LIST, term,
3445 scalar(newUNOP(OP_RV2CV, 0,
3450 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3456 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3458 return newBINOP(OP_LSLICE, flags,
3459 list(force_list(subscript)),
3460 list(force_list(listval)) );
3464 S_list_assignment(pTHX_ register OP *o)
3469 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3470 o = cUNOPo->op_first;
3472 if (o->op_type == OP_COND_EXPR) {
3473 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3474 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3479 yyerror("Assignment to both a list and a scalar");
3483 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3484 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3485 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3488 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3491 if (o->op_type == OP_RV2SV)
3498 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3503 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3504 return newLOGOP(optype, 0,
3505 mod(scalar(left), optype),
3506 newUNOP(OP_SASSIGN, 0, scalar(right)));
3509 return newBINOP(optype, OPf_STACKED,
3510 mod(scalar(left), optype), scalar(right));
3514 if (list_assignment(left)) {
3518 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3519 left = mod(left, OP_AASSIGN);
3527 curop = list(force_list(left));
3528 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3529 o->op_private = 0 | (flags >> 8);
3530 for (curop = ((LISTOP*)curop)->op_first;
3531 curop; curop = curop->op_sibling)
3533 if (curop->op_type == OP_RV2HV &&
3534 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3535 o->op_private |= OPpASSIGN_HASH;
3539 if (!(left->op_private & OPpLVAL_INTRO)) {
3542 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3543 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3544 if (curop->op_type == OP_GV) {
3545 GV *gv = cGVOPx_gv(curop);
3546 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3548 SvCUR(gv) = PL_generation;
3550 else if (curop->op_type == OP_PADSV ||
3551 curop->op_type == OP_PADAV ||
3552 curop->op_type == OP_PADHV ||
3553 curop->op_type == OP_PADANY) {
3554 SV **svp = AvARRAY(PL_comppad_name);
3555 SV *sv = svp[curop->op_targ];
3556 if (SvCUR(sv) == PL_generation)
3558 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3560 else if (curop->op_type == OP_RV2CV)
3562 else if (curop->op_type == OP_RV2SV ||
3563 curop->op_type == OP_RV2AV ||
3564 curop->op_type == OP_RV2HV ||
3565 curop->op_type == OP_RV2GV) {
3566 if (lastop->op_type != OP_GV) /* funny deref? */
3569 else if (curop->op_type == OP_PUSHRE) {
3570 if (((PMOP*)curop)->op_pmreplroot) {
3572 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3574 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3576 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3578 SvCUR(gv) = PL_generation;
3587 o->op_private |= OPpASSIGN_COMMON;
3589 if (right && right->op_type == OP_SPLIT) {
3591 if ((tmpop = ((LISTOP*)right)->op_first) &&
3592 tmpop->op_type == OP_PUSHRE)
3594 PMOP *pm = (PMOP*)tmpop;
3595 if (left->op_type == OP_RV2AV &&
3596 !(left->op_private & OPpLVAL_INTRO) &&
3597 !(o->op_private & OPpASSIGN_COMMON) )
3599 tmpop = ((UNOP*)left)->op_first;
3600 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3602 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3603 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3605 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3606 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3608 pm->op_pmflags |= PMf_ONCE;
3609 tmpop = cUNOPo->op_first; /* to list (nulled) */
3610 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3611 tmpop->op_sibling = Nullop; /* don't free split */
3612 right->op_next = tmpop->op_next; /* fix starting loc */
3613 op_free(o); /* blow off assign */
3614 right->op_flags &= ~OPf_WANT;
3615 /* "I don't know and I don't care." */
3620 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3621 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3623 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3625 sv_setiv(sv, PL_modcount+1);
3633 right = newOP(OP_UNDEF, 0);
3634 if (right->op_type == OP_READLINE) {
3635 right->op_flags |= OPf_STACKED;
3636 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3639 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3640 o = newBINOP(OP_SASSIGN, flags,
3641 scalar(right), mod(scalar(left), OP_SASSIGN) );
3653 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3655 U32 seq = intro_my();
3658 NewOp(1101, cop, 1, COP);
3659 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3660 cop->op_type = OP_DBSTATE;
3661 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3664 cop->op_type = OP_NEXTSTATE;
3665 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3667 cop->op_flags = flags;
3668 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3670 cop->op_private |= NATIVE_HINTS;
3672 PL_compiling.op_private = cop->op_private;
3673 cop->op_next = (OP*)cop;
3676 cop->cop_label = label;
3677 PL_hints |= HINT_BLOCK_SCOPE;
3680 cop->cop_arybase = PL_curcop->cop_arybase;
3681 if (specialWARN(PL_curcop->cop_warnings))
3682 cop->cop_warnings = PL_curcop->cop_warnings ;
3684 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3685 if (specialCopIO(PL_curcop->cop_io))
3686 cop->cop_io = PL_curcop->cop_io;
3688 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3691 if (PL_copline == NOLINE)
3692 CopLINE_set(cop, CopLINE(PL_curcop));
3694 CopLINE_set(cop, PL_copline);
3695 PL_copline = NOLINE;
3698 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3700 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3702 CopSTASH_set(cop, PL_curstash);
3704 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3705 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3706 if (svp && *svp != &PL_sv_undef ) {
3707 (void)SvIOK_on(*svp);
3708 SvIVX(*svp) = PTR2IV(cop);
3712 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3715 /* "Introduce" my variables to visible status. */
3723 if (! PL_min_intro_pending)
3724 return PL_cop_seqmax;
3726 svp = AvARRAY(PL_comppad_name);
3727 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3728 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3729 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3730 SvNVX(sv) = (NV)PL_cop_seqmax;
3733 PL_min_intro_pending = 0;
3734 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3735 return PL_cop_seqmax++;
3739 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3741 return new_logop(type, flags, &first, &other);
3745 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3749 OP *first = *firstp;
3750 OP *other = *otherp;
3752 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3753 return newBINOP(type, flags, scalar(first), scalar(other));
3755 scalarboolean(first);
3756 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3757 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3758 if (type == OP_AND || type == OP_OR) {
3764 first = *firstp = cUNOPo->op_first;
3766 first->op_next = o->op_next;
3767 cUNOPo->op_first = Nullop;
3771 if (first->op_type == OP_CONST) {
3772 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3773 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3774 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3785 else if (first->op_type == OP_WANTARRAY) {
3791 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3792 OP *k1 = ((UNOP*)first)->op_first;
3793 OP *k2 = k1->op_sibling;
3795 switch (first->op_type)
3798 if (k2 && k2->op_type == OP_READLINE
3799 && (k2->op_flags & OPf_STACKED)
3800 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3802 warnop = k2->op_type;
3807 if (k1->op_type == OP_READDIR
3808 || k1->op_type == OP_GLOB
3809 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3810 || k1->op_type == OP_EACH)
3812 warnop = ((k1->op_type == OP_NULL)
3813 ? k1->op_targ : k1->op_type);
3818 line_t oldline = CopLINE(PL_curcop);
3819 CopLINE_set(PL_curcop, PL_copline);
3820 Perl_warner(aTHX_ WARN_MISC,
3821 "Value of %s%s can be \"0\"; test with defined()",
3823 ((warnop == OP_READLINE || warnop == OP_GLOB)
3824 ? " construct" : "() operator"));
3825 CopLINE_set(PL_curcop, oldline);
3832 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3833 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3835 NewOp(1101, logop, 1, LOGOP);
3837 logop->op_type = type;
3838 logop->op_ppaddr = PL_ppaddr[type];
3839 logop->op_first = first;
3840 logop->op_flags = flags | OPf_KIDS;
3841 logop->op_other = LINKLIST(other);
3842 logop->op_private = 1 | (flags >> 8);
3844 /* establish postfix order */
3845 logop->op_next = LINKLIST(first);
3846 first->op_next = (OP*)logop;
3847 first->op_sibling = other;
3849 o = newUNOP(OP_NULL, 0, (OP*)logop);
3856 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3863 return newLOGOP(OP_AND, 0, first, trueop);
3865 return newLOGOP(OP_OR, 0, first, falseop);
3867 scalarboolean(first);
3868 if (first->op_type == OP_CONST) {
3869 if (SvTRUE(((SVOP*)first)->op_sv)) {
3880 else if (first->op_type == OP_WANTARRAY) {
3884 NewOp(1101, logop, 1, LOGOP);
3885 logop->op_type = OP_COND_EXPR;
3886 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3887 logop->op_first = first;
3888 logop->op_flags = flags | OPf_KIDS;
3889 logop->op_private = 1 | (flags >> 8);
3890 logop->op_other = LINKLIST(trueop);
3891 logop->op_next = LINKLIST(falseop);
3894 /* establish postfix order */
3895 start = LINKLIST(first);
3896 first->op_next = (OP*)logop;
3898 first->op_sibling = trueop;
3899 trueop->op_sibling = falseop;
3900 o = newUNOP(OP_NULL, 0, (OP*)logop);
3902 trueop->op_next = falseop->op_next = o;
3909 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3917 NewOp(1101, range, 1, LOGOP);
3919 range->op_type = OP_RANGE;
3920 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3921 range->op_first = left;
3922 range->op_flags = OPf_KIDS;
3923 leftstart = LINKLIST(left);
3924 range->op_other = LINKLIST(right);
3925 range->op_private = 1 | (flags >> 8);
3927 left->op_sibling = right;
3929 range->op_next = (OP*)range;
3930 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3931 flop = newUNOP(OP_FLOP, 0, flip);
3932 o = newUNOP(OP_NULL, 0, flop);
3934 range->op_next = leftstart;
3936 left->op_next = flip;
3937 right->op_next = flop;
3939 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3940 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3941 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3942 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3944 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3945 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3948 if (!flip->op_private || !flop->op_private)
3949 linklist(o); /* blow off optimizer unless constant */
3955 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3959 int once = block && block->op_flags & OPf_SPECIAL &&
3960 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3963 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3964 return block; /* do {} while 0 does once */
3965 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3966 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3967 expr = newUNOP(OP_DEFINED, 0,
3968 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3969 } else if (expr->op_flags & OPf_KIDS) {
3970 OP *k1 = ((UNOP*)expr)->op_first;
3971 OP *k2 = (k1) ? k1->op_sibling : NULL;
3972 switch (expr->op_type) {
3974 if (k2 && k2->op_type == OP_READLINE
3975 && (k2->op_flags & OPf_STACKED)
3976 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3977 expr = newUNOP(OP_DEFINED, 0, expr);
3981 if (k1->op_type == OP_READDIR
3982 || k1->op_type == OP_GLOB
3983 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3984 || k1->op_type == OP_EACH)
3985 expr = newUNOP(OP_DEFINED, 0, expr);
3991 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3992 o = new_logop(OP_AND, 0, &expr, &listop);
3995 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3997 if (once && o != listop)
3998 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4001 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4003 o->op_flags |= flags;
4005 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4010 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4018 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4019 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4020 expr = newUNOP(OP_DEFINED, 0,
4021 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4022 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4023 OP *k1 = ((UNOP*)expr)->op_first;
4024 OP *k2 = (k1) ? k1->op_sibling : NULL;
4025 switch (expr->op_type) {
4027 if (k2 && k2->op_type == OP_READLINE
4028 && (k2->op_flags & OPf_STACKED)
4029 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4030 expr = newUNOP(OP_DEFINED, 0, expr);
4034 if (k1->op_type == OP_READDIR
4035 || k1->op_type == OP_GLOB
4036 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4037 || k1->op_type == OP_EACH)
4038 expr = newUNOP(OP_DEFINED, 0, expr);
4044 block = newOP(OP_NULL, 0);
4046 block = scope(block);
4050 next = LINKLIST(cont);
4053 OP *unstack = newOP(OP_UNSTACK, 0);
4056 cont = append_elem(OP_LINESEQ, cont, unstack);
4057 if ((line_t)whileline != NOLINE) {
4058 PL_copline = whileline;
4059 cont = append_elem(OP_LINESEQ, cont,
4060 newSTATEOP(0, Nullch, Nullop));
4064 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4065 redo = LINKLIST(listop);
4068 PL_copline = whileline;
4070 o = new_logop(OP_AND, 0, &expr, &listop);
4071 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4072 op_free(expr); /* oops, it's a while (0) */
4074 return Nullop; /* listop already freed by new_logop */
4077 ((LISTOP*)listop)->op_last->op_next =
4078 (o == listop ? redo : LINKLIST(o));
4084 NewOp(1101,loop,1,LOOP);
4085 loop->op_type = OP_ENTERLOOP;
4086 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4087 loop->op_private = 0;
4088 loop->op_next = (OP*)loop;
4091 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4093 loop->op_redoop = redo;
4094 loop->op_lastop = o;
4095 o->op_private |= loopflags;
4098 loop->op_nextop = next;
4100 loop->op_nextop = o;
4102 o->op_flags |= flags;
4103 o->op_private |= (flags >> 8);
4108 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4116 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4117 sv->op_type = OP_RV2GV;
4118 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4120 else if (sv->op_type == OP_PADSV) { /* private variable */
4121 padoff = sv->op_targ;
4126 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4127 padoff = sv->op_targ;
4129 iterflags |= OPf_SPECIAL;
4134 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4137 #ifdef USE_5005THREADS
4138 padoff = find_threadsv("_");
4139 iterflags |= OPf_SPECIAL;
4141 sv = newGVOP(OP_GV, 0, PL_defgv);
4144 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4145 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4146 iterflags |= OPf_STACKED;
4148 else if (expr->op_type == OP_NULL &&
4149 (expr->op_flags & OPf_KIDS) &&
4150 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4152 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4153 * set the STACKED flag to indicate that these values are to be
4154 * treated as min/max values by 'pp_iterinit'.
4156 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4157 LOGOP* range = (LOGOP*) flip->op_first;
4158 OP* left = range->op_first;
4159 OP* right = left->op_sibling;
4162 range->op_flags &= ~OPf_KIDS;
4163 range->op_first = Nullop;
4165 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4166 listop->op_first->op_next = range->op_next;
4167 left->op_next = range->op_other;
4168 right->op_next = (OP*)listop;
4169 listop->op_next = listop->op_first;
4172 expr = (OP*)(listop);
4174 iterflags |= OPf_STACKED;
4177 expr = mod(force_list(expr), OP_GREPSTART);
4181 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4182 append_elem(OP_LIST, expr, scalar(sv))));
4183 assert(!loop->op_next);
4184 #ifdef PL_OP_SLAB_ALLOC
4187 NewOp(1234,tmp,1,LOOP);
4188 Copy(loop,tmp,1,LOOP);
4192 Renew(loop, 1, LOOP);
4194 loop->op_targ = padoff;
4195 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4196 PL_copline = forline;
4197 return newSTATEOP(0, label, wop);
4201 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4206 if (type != OP_GOTO || label->op_type == OP_CONST) {
4207 /* "last()" means "last" */
4208 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4209 o = newOP(type, OPf_SPECIAL);
4211 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4212 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4218 if (label->op_type == OP_ENTERSUB)
4219 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4220 o = newUNOP(type, OPf_STACKED, label);
4222 PL_hints |= HINT_BLOCK_SCOPE;
4227 Perl_cv_undef(pTHX_ CV *cv)
4229 #ifdef USE_5005THREADS
4231 MUTEX_DESTROY(CvMUTEXP(cv));
4232 Safefree(CvMUTEXP(cv));
4235 #endif /* USE_5005THREADS */
4238 if (CvFILE(cv) && !CvXSUB(cv)) {
4239 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4240 Safefree(CvFILE(cv));
4245 if (!CvXSUB(cv) && CvROOT(cv)) {
4246 #ifdef USE_5005THREADS
4247 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4248 Perl_croak(aTHX_ "Can't undef active subroutine");
4251 Perl_croak(aTHX_ "Can't undef active subroutine");
4252 #endif /* USE_5005THREADS */
4255 SAVEVPTR(PL_curpad);
4258 op_free(CvROOT(cv));
4259 CvROOT(cv) = Nullop;
4262 SvPOK_off((SV*)cv); /* forget prototype */
4264 /* Since closure prototypes have the same lifetime as the containing
4265 * CV, they don't hold a refcount on the outside CV. This avoids
4266 * the refcount loop between the outer CV (which keeps a refcount to
4267 * the closure prototype in the pad entry for pp_anoncode()) and the
4268 * closure prototype, and the ensuing memory leak. --GSAR */
4269 if (!CvANON(cv) || CvCLONED(cv))
4270 SvREFCNT_dec(CvOUTSIDE(cv));
4271 CvOUTSIDE(cv) = Nullcv;
4273 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4276 if (CvPADLIST(cv)) {
4277 /* may be during global destruction */
4278 if (SvREFCNT(CvPADLIST(cv))) {
4279 I32 i = AvFILLp(CvPADLIST(cv));
4281 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4282 SV* sv = svp ? *svp : Nullsv;
4285 if (sv == (SV*)PL_comppad_name)
4286 PL_comppad_name = Nullav;
4287 else if (sv == (SV*)PL_comppad) {
4288 PL_comppad = Nullav;
4289 PL_curpad = Null(SV**);
4293 SvREFCNT_dec((SV*)CvPADLIST(cv));
4295 CvPADLIST(cv) = Nullav;
4303 #ifdef DEBUG_CLOSURES
4305 S_cv_dump(pTHX_ CV *cv)
4308 CV *outside = CvOUTSIDE(cv);
4309 AV* padlist = CvPADLIST(cv);
4316 PerlIO_printf(Perl_debug_log,
4317 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4319 (CvANON(cv) ? "ANON"
4320 : (cv == PL_main_cv) ? "MAIN"
4321 : CvUNIQUE(cv) ? "UNIQUE"
4322 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4325 : CvANON(outside) ? "ANON"
4326 : (outside == PL_main_cv) ? "MAIN"
4327 : CvUNIQUE(outside) ? "UNIQUE"
4328 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4333 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4334 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4335 pname = AvARRAY(pad_name);
4336 ppad = AvARRAY(pad);
4338 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4339 if (SvPOK(pname[ix]))
4340 PerlIO_printf(Perl_debug_log,
4341 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4342 (int)ix, PTR2UV(ppad[ix]),
4343 SvFAKE(pname[ix]) ? "FAKE " : "",
4345 (IV)I_32(SvNVX(pname[ix])),
4348 #endif /* DEBUGGING */
4350 #endif /* DEBUG_CLOSURES */
4353 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4357 AV* protopadlist = CvPADLIST(proto);
4358 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4359 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4360 SV** pname = AvARRAY(protopad_name);
4361 SV** ppad = AvARRAY(protopad);
4362 I32 fname = AvFILLp(protopad_name);
4363 I32 fpad = AvFILLp(protopad);
4367 assert(!CvUNIQUE(proto));
4371 SAVESPTR(PL_comppad_name);
4372 SAVESPTR(PL_compcv);
4374 cv = PL_compcv = (CV*)NEWSV(1104,0);
4375 sv_upgrade((SV *)cv, SvTYPE(proto));
4376 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4379 #ifdef USE_5005THREADS
4380 New(666, CvMUTEXP(cv), 1, perl_mutex);
4381 MUTEX_INIT(CvMUTEXP(cv));
4383 #endif /* USE_5005THREADS */
4385 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4386 : savepv(CvFILE(proto));
4388 CvFILE(cv) = CvFILE(proto);
4390 CvGV(cv) = CvGV(proto);
4391 CvSTASH(cv) = CvSTASH(proto);
4392 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4393 CvSTART(cv) = CvSTART(proto);
4395 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4398 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4400 PL_comppad_name = newAV();
4401 for (ix = fname; ix >= 0; ix--)
4402 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4404 PL_comppad = newAV();
4406 comppadlist = newAV();
4407 AvREAL_off(comppadlist);
4408 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4409 av_store(comppadlist, 1, (SV*)PL_comppad);
4410 CvPADLIST(cv) = comppadlist;
4411 av_fill(PL_comppad, AvFILLp(protopad));
4412 PL_curpad = AvARRAY(PL_comppad);
4414 av = newAV(); /* will be @_ */
4416 av_store(PL_comppad, 0, (SV*)av);
4417 AvFLAGS(av) = AVf_REIFY;
4419 for (ix = fpad; ix > 0; ix--) {
4420 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4421 if (namesv && namesv != &PL_sv_undef) {
4422 char *name = SvPVX(namesv); /* XXX */
4423 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4424 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4425 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4427 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4429 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4431 else { /* our own lexical */
4434 /* anon code -- we'll come back for it */
4435 sv = SvREFCNT_inc(ppad[ix]);
4437 else if (*name == '@')
4439 else if (*name == '%')
4448 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4449 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4452 SV* sv = NEWSV(0,0);
4458 /* Now that vars are all in place, clone nested closures. */
4460 for (ix = fpad; ix > 0; ix--) {
4461 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4463 && namesv != &PL_sv_undef
4464 && !(SvFLAGS(namesv) & SVf_FAKE)
4465 && *SvPVX(namesv) == '&'
4466 && CvCLONE(ppad[ix]))
4468 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4469 SvREFCNT_dec(ppad[ix]);
4472 PL_curpad[ix] = (SV*)kid;
4476 #ifdef DEBUG_CLOSURES
4477 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4479 PerlIO_printf(Perl_debug_log, " from:\n");
4481 PerlIO_printf(Perl_debug_log, " to:\n");
4488 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4490 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4492 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4499 Perl_cv_clone(pTHX_ CV *proto)
4502 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4503 cv = cv_clone2(proto, CvOUTSIDE(proto));
4504 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4509 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4511 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4512 SV* msg = sv_newmortal();
4516 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4517 sv_setpv(msg, "Prototype mismatch:");
4519 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4521 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4522 sv_catpv(msg, " vs ");
4524 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4526 sv_catpv(msg, "none");
4527 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4531 static void const_sv_xsub(pTHX_ CV* cv);
4534 =for apidoc cv_const_sv
4536 If C<cv> is a constant sub eligible for inlining. returns the constant
4537 value returned by the sub. Otherwise, returns NULL.
4539 Constant subs can be created with C<newCONSTSUB> or as described in
4540 L<perlsub/"Constant Functions">.
4545 Perl_cv_const_sv(pTHX_ CV *cv)
4547 if (!cv || !CvCONST(cv))
4549 return (SV*)CvXSUBANY(cv).any_ptr;
4553 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4560 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4561 o = cLISTOPo->op_first->op_sibling;
4563 for (; o; o = o->op_next) {
4564 OPCODE type = o->op_type;
4566 if (sv && o->op_next == o)
4568 if (o->op_next != o) {
4569 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4571 if (type == OP_DBSTATE)
4574 if (type == OP_LEAVESUB || type == OP_RETURN)
4578 if (type == OP_CONST && cSVOPo->op_sv)
4580 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4581 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4582 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4586 /* We get here only from cv_clone2() while creating a closure.
4587 Copy the const value here instead of in cv_clone2 so that
4588 SvREADONLY_on doesn't lead to problems when leaving
4593 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4605 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4615 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4619 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4621 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4625 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4631 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4636 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4637 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4638 SV *sv = sv_newmortal();
4639 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4640 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4645 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4646 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4656 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4657 maximum a prototype before. */
4658 if (SvTYPE(gv) > SVt_NULL) {
4659 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4660 && ckWARN_d(WARN_PROTOTYPE))
4662 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4664 cv_ckproto((CV*)gv, NULL, ps);
4667 sv_setpv((SV*)gv, ps);
4669 sv_setiv((SV*)gv, -1);
4670 SvREFCNT_dec(PL_compcv);
4671 cv = PL_compcv = NULL;
4672 PL_sub_generation++;
4676 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4678 #ifdef GV_UNIQUE_CHECK
4679 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4680 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4684 if (!block || !ps || *ps || attrs)
4687 const_sv = op_const_sv(block, Nullcv);
4690 bool exists = CvROOT(cv) || CvXSUB(cv);
4692 #ifdef GV_UNIQUE_CHECK
4693 if (exists && GvUNIQUE(gv)) {
4694 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4698 /* if the subroutine doesn't exist and wasn't pre-declared
4699 * with a prototype, assume it will be AUTOLOADed,
4700 * skipping the prototype check
4702 if (exists || SvPOK(cv))
4703 cv_ckproto(cv, gv, ps);
4704 /* already defined (or promised)? */
4705 if (exists || GvASSUMECV(gv)) {
4706 if (!block && !attrs) {
4707 /* just a "sub foo;" when &foo is already defined */
4708 SAVEFREESV(PL_compcv);
4711 /* ahem, death to those who redefine active sort subs */
4712 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4713 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4715 if (ckWARN(WARN_REDEFINE)
4717 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4719 line_t oldline = CopLINE(PL_curcop);
4720 if (PL_copline != NOLINE)
4721 CopLINE_set(PL_curcop, PL_copline);
4722 Perl_warner(aTHX_ WARN_REDEFINE,
4723 CvCONST(cv) ? "Constant subroutine %s redefined"
4724 : "Subroutine %s redefined", name);
4725 CopLINE_set(PL_curcop, oldline);
4733 SvREFCNT_inc(const_sv);
4735 assert(!CvROOT(cv) && !CvCONST(cv));
4736 sv_setpv((SV*)cv, ""); /* prototype is "" */
4737 CvXSUBANY(cv).any_ptr = const_sv;
4738 CvXSUB(cv) = const_sv_xsub;
4743 cv = newCONSTSUB(NULL, name, const_sv);
4746 SvREFCNT_dec(PL_compcv);
4748 PL_sub_generation++;
4755 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4756 * before we clobber PL_compcv.
4760 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4761 stash = GvSTASH(CvGV(cv));
4762 else if (CvSTASH(cv))
4763 stash = CvSTASH(cv);
4765 stash = PL_curstash;
4768 /* possibly about to re-define existing subr -- ignore old cv */
4769 rcv = (SV*)PL_compcv;
4770 if (name && GvSTASH(gv))
4771 stash = GvSTASH(gv);
4773 stash = PL_curstash;
4775 apply_attrs(stash, rcv, attrs);
4777 if (cv) { /* must reuse cv if autoloaded */
4779 /* got here with just attrs -- work done, so bug out */
4780 SAVEFREESV(PL_compcv);
4784 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4785 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4786 CvOUTSIDE(PL_compcv) = 0;
4787 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4788 CvPADLIST(PL_compcv) = 0;
4789 /* inner references to PL_compcv must be fixed up ... */
4791 AV *padlist = CvPADLIST(cv);
4792 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4793 AV *comppad = (AV*)AvARRAY(padlist)[1];
4794 SV **namepad = AvARRAY(comppad_name);
4795 SV **curpad = AvARRAY(comppad);
4796 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4797 SV *namesv = namepad[ix];
4798 if (namesv && namesv != &PL_sv_undef
4799 && *SvPVX(namesv) == '&')
4801 CV *innercv = (CV*)curpad[ix];
4802 if (CvOUTSIDE(innercv) == PL_compcv) {
4803 CvOUTSIDE(innercv) = cv;
4804 if (!CvANON(innercv) || CvCLONED(innercv)) {
4805 (void)SvREFCNT_inc(cv);
4806 SvREFCNT_dec(PL_compcv);
4812 /* ... before we throw it away */
4813 SvREFCNT_dec(PL_compcv);
4814 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4815 ++PL_sub_generation;
4822 PL_sub_generation++;
4826 CvFILE_set_from_cop(cv, PL_curcop);
4827 CvSTASH(cv) = PL_curstash;
4828 #ifdef USE_5005THREADS
4830 if (!CvMUTEXP(cv)) {
4831 New(666, CvMUTEXP(cv), 1, perl_mutex);
4832 MUTEX_INIT(CvMUTEXP(cv));
4834 #endif /* USE_5005THREADS */
4837 sv_setpv((SV*)cv, ps);
4839 if (PL_error_count) {
4843 char *s = strrchr(name, ':');
4845 if (strEQ(s, "BEGIN")) {
4847 "BEGIN not safe after errors--compilation aborted";
4848 if (PL_in_eval & EVAL_KEEPERR)
4849 Perl_croak(aTHX_ not_safe);
4851 /* force display of errors found but not reported */
4852 sv_catpv(ERRSV, not_safe);
4853 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4861 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4862 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4865 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4866 mod(scalarseq(block), OP_LEAVESUBLV));
4869 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4871 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4872 OpREFCNT_set(CvROOT(cv), 1);
4873 CvSTART(cv) = LINKLIST(CvROOT(cv));
4874 CvROOT(cv)->op_next = 0;
4875 CALL_PEEP(CvSTART(cv));
4877 /* now that optimizer has done its work, adjust pad values */
4879 SV **namep = AvARRAY(PL_comppad_name);
4880 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4883 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4886 * The only things that a clonable function needs in its
4887 * pad are references to outer lexicals and anonymous subs.
4888 * The rest are created anew during cloning.
4890 if (!((namesv = namep[ix]) != Nullsv &&
4891 namesv != &PL_sv_undef &&
4893 *SvPVX(namesv) == '&')))
4895 SvREFCNT_dec(PL_curpad[ix]);
4896 PL_curpad[ix] = Nullsv;
4899 assert(!CvCONST(cv));
4900 if (ps && !*ps && op_const_sv(block, cv))
4904 AV *av = newAV(); /* Will be @_ */
4906 av_store(PL_comppad, 0, (SV*)av);
4907 AvFLAGS(av) = AVf_REIFY;
4909 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4910 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4912 if (!SvPADMY(PL_curpad[ix]))
4913 SvPADTMP_on(PL_curpad[ix]);
4917 /* If a potential closure prototype, don't keep a refcount on outer CV.
4918 * This is okay as the lifetime of the prototype is tied to the
4919 * lifetime of the outer CV. Avoids memory leak due to reference
4922 SvREFCNT_dec(CvOUTSIDE(cv));
4924 if (name || aname) {
4926 char *tname = (name ? name : aname);
4928 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4929 SV *sv = NEWSV(0,0);
4930 SV *tmpstr = sv_newmortal();
4931 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4935 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4937 (long)PL_subline, (long)CopLINE(PL_curcop));
4938 gv_efullname3(tmpstr, gv, Nullch);
4939 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4940 hv = GvHVn(db_postponed);
4941 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4942 && (pcv = GvCV(db_postponed)))
4948 call_sv((SV*)pcv, G_DISCARD);
4952 if ((s = strrchr(tname,':')))
4957 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4960 if (strEQ(s, "BEGIN")) {
4961 I32 oldscope = PL_scopestack_ix;
4963 SAVECOPFILE(&PL_compiling);
4964 SAVECOPLINE(&PL_compiling);
4967 PL_beginav = newAV();
4968 DEBUG_x( dump_sub(gv) );
4969 av_push(PL_beginav, (SV*)cv);
4970 GvCV(gv) = 0; /* cv has been hijacked */
4971 call_list(oldscope, PL_beginav);
4973 PL_curcop = &PL_compiling;
4974 PL_compiling.op_private = PL_hints;
4977 else if (strEQ(s, "END") && !PL_error_count) {
4980 DEBUG_x( dump_sub(gv) );
4981 av_unshift(PL_endav, 1);
4982 av_store(PL_endav, 0, (SV*)cv);
4983 GvCV(gv) = 0; /* cv has been hijacked */
4985 else if (strEQ(s, "CHECK") && !PL_error_count) {
4987 PL_checkav = newAV();
4988 DEBUG_x( dump_sub(gv) );
4989 if (PL_main_start && ckWARN(WARN_VOID))
4990 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4991 av_unshift(PL_checkav, 1);
4992 av_store(PL_checkav, 0, (SV*)cv);
4993 GvCV(gv) = 0; /* cv has been hijacked */
4995 else if (strEQ(s, "INIT") && !PL_error_count) {
4997 PL_initav = newAV();
4998 DEBUG_x( dump_sub(gv) );
4999 if (PL_main_start && ckWARN(WARN_VOID))
5000 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5001 av_push(PL_initav, (SV*)cv);
5002 GvCV(gv) = 0; /* cv has been hijacked */
5007 PL_copline = NOLINE;
5012 /* XXX unsafe for threads if eval_owner isn't held */
5014 =for apidoc newCONSTSUB
5016 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5017 eligible for inlining at compile-time.
5023 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5029 SAVECOPLINE(PL_curcop);
5030 CopLINE_set(PL_curcop, PL_copline);
5033 PL_hints &= ~HINT_BLOCK_SCOPE;
5036 SAVESPTR(PL_curstash);
5037 SAVECOPSTASH(PL_curcop);
5038 PL_curstash = stash;
5040 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5042 CopSTASH(PL_curcop) = stash;
5046 cv = newXS(name, const_sv_xsub, __FILE__);
5047 CvXSUBANY(cv).any_ptr = sv;
5049 sv_setpv((SV*)cv, ""); /* prototype is "" */
5057 =for apidoc U||newXS
5059 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5065 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5067 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5070 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5072 /* just a cached method */
5076 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5077 /* already defined (or promised) */
5078 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5079 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5080 line_t oldline = CopLINE(PL_curcop);
5081 if (PL_copline != NOLINE)
5082 CopLINE_set(PL_curcop, PL_copline);
5083 Perl_warner(aTHX_ WARN_REDEFINE,
5084 CvCONST(cv) ? "Constant subroutine %s redefined"
5085 : "Subroutine %s redefined"
5087 CopLINE_set(PL_curcop, oldline);
5094 if (cv) /* must reuse cv if autoloaded */
5097 cv = (CV*)NEWSV(1105,0);
5098 sv_upgrade((SV *)cv, SVt_PVCV);
5102 PL_sub_generation++;
5106 #ifdef USE_5005THREADS
5107 New(666, CvMUTEXP(cv), 1, perl_mutex);
5108 MUTEX_INIT(CvMUTEXP(cv));
5110 #endif /* USE_5005THREADS */
5111 (void)gv_fetchfile(filename);
5112 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5113 an external constant string */
5114 CvXSUB(cv) = subaddr;
5117 char *s = strrchr(name,':');
5123 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5126 if (strEQ(s, "BEGIN")) {
5128 PL_beginav = newAV();
5129 av_push(PL_beginav, (SV*)cv);
5130 GvCV(gv) = 0; /* cv has been hijacked */
5132 else if (strEQ(s, "END")) {
5135 av_unshift(PL_endav, 1);
5136 av_store(PL_endav, 0, (SV*)cv);
5137 GvCV(gv) = 0; /* cv has been hijacked */
5139 else if (strEQ(s, "CHECK")) {
5141 PL_checkav = newAV();
5142 if (PL_main_start && ckWARN(WARN_VOID))
5143 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5144 av_unshift(PL_checkav, 1);
5145 av_store(PL_checkav, 0, (SV*)cv);
5146 GvCV(gv) = 0; /* cv has been hijacked */
5148 else if (strEQ(s, "INIT")) {
5150 PL_initav = newAV();
5151 if (PL_main_start && ckWARN(WARN_VOID))
5152 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5153 av_push(PL_initav, (SV*)cv);
5154 GvCV(gv) = 0; /* cv has been hijacked */
5165 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5174 name = SvPVx(cSVOPo->op_sv, n_a);
5177 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5178 #ifdef GV_UNIQUE_CHECK
5180 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5184 if ((cv = GvFORM(gv))) {
5185 if (ckWARN(WARN_REDEFINE)) {
5186 line_t oldline = CopLINE(PL_curcop);
5187 if (PL_copline != NOLINE)
5188 CopLINE_set(PL_curcop, PL_copline);
5189 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5190 CopLINE_set(PL_curcop, oldline);
5197 CvFILE_set_from_cop(cv, PL_curcop);
5199 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5200 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5201 SvPADTMP_on(PL_curpad[ix]);
5204 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5205 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5206 OpREFCNT_set(CvROOT(cv), 1);
5207 CvSTART(cv) = LINKLIST(CvROOT(cv));
5208 CvROOT(cv)->op_next = 0;
5209 CALL_PEEP(CvSTART(cv));
5211 PL_copline = NOLINE;
5216 Perl_newANONLIST(pTHX_ OP *o)
5218 return newUNOP(OP_REFGEN, 0,
5219 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5223 Perl_newANONHASH(pTHX_ OP *o)
5225 return newUNOP(OP_REFGEN, 0,
5226 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5230 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5232 return newANONATTRSUB(floor, proto, Nullop, block);
5236 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5238 return newUNOP(OP_REFGEN, 0,
5239 newSVOP(OP_ANONCODE, 0,
5240 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5244 Perl_oopsAV(pTHX_ OP *o)
5246 switch (o->op_type) {
5248 o->op_type = OP_PADAV;
5249 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5250 return ref(o, OP_RV2AV);
5253 o->op_type = OP_RV2AV;
5254 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5259 if (ckWARN_d(WARN_INTERNAL))
5260 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5267 Perl_oopsHV(pTHX_ OP *o)
5269 switch (o->op_type) {
5272 o->op_type = OP_PADHV;
5273 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5274 return ref(o, OP_RV2HV);
5278 o->op_type = OP_RV2HV;
5279 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5284 if (ckWARN_d(WARN_INTERNAL))
5285 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5292 Perl_newAVREF(pTHX_ OP *o)
5294 if (o->op_type == OP_PADANY) {
5295 o->op_type = OP_PADAV;
5296 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5299 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5300 && ckWARN(WARN_DEPRECATED)) {
5301 Perl_warner(aTHX_ WARN_DEPRECATED,
5302 "Using an array as a reference is deprecated");
5304 return newUNOP(OP_RV2AV, 0, scalar(o));
5308 Perl_newGVREF(pTHX_ I32 type, OP *o)
5310 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5311 return newUNOP(OP_NULL, 0, o);
5312 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5316 Perl_newHVREF(pTHX_ OP *o)
5318 if (o->op_type == OP_PADANY) {
5319 o->op_type = OP_PADHV;
5320 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5323 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5324 && ckWARN(WARN_DEPRECATED)) {
5325 Perl_warner(aTHX_ WARN_DEPRECATED,
5326 "Using a hash as a reference is deprecated");
5328 return newUNOP(OP_RV2HV, 0, scalar(o));
5332 Perl_oopsCV(pTHX_ OP *o)
5334 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5340 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5342 return newUNOP(OP_RV2CV, flags, scalar(o));
5346 Perl_newSVREF(pTHX_ OP *o)
5348 if (o->op_type == OP_PADANY) {
5349 o->op_type = OP_PADSV;
5350 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5353 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5354 o->op_flags |= OPpDONE_SVREF;
5357 return newUNOP(OP_RV2SV, 0, scalar(o));
5360 /* Check routines. */
5363 Perl_ck_anoncode(pTHX_ OP *o)
5368 name = NEWSV(1106,0);
5369 sv_upgrade(name, SVt_PVNV);
5370 sv_setpvn(name, "&", 1);
5373 ix = pad_alloc(o->op_type, SVs_PADMY);
5374 av_store(PL_comppad_name, ix, name);
5375 av_store(PL_comppad, ix, cSVOPo->op_sv);
5376 SvPADMY_on(cSVOPo->op_sv);
5377 cSVOPo->op_sv = Nullsv;
5378 cSVOPo->op_targ = ix;
5383 Perl_ck_bitop(pTHX_ OP *o)
5385 o->op_private = PL_hints;
5390 Perl_ck_concat(pTHX_ OP *o)
5392 if (cUNOPo->op_first->op_type == OP_CONCAT)
5393 o->op_flags |= OPf_STACKED;
5398 Perl_ck_spair(pTHX_ OP *o)
5400 if (o->op_flags & OPf_KIDS) {
5403 OPCODE type = o->op_type;
5404 o = modkids(ck_fun(o), type);
5405 kid = cUNOPo->op_first;
5406 newop = kUNOP->op_first->op_sibling;
5408 (newop->op_sibling ||
5409 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5410 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5411 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5415 op_free(kUNOP->op_first);
5416 kUNOP->op_first = newop;
5418 o->op_ppaddr = PL_ppaddr[++o->op_type];
5423 Perl_ck_delete(pTHX_ OP *o)
5427 if (o->op_flags & OPf_KIDS) {
5428 OP *kid = cUNOPo->op_first;
5429 switch (kid->op_type) {
5431 o->op_flags |= OPf_SPECIAL;
5434 o->op_private |= OPpSLICE;
5437 o->op_flags |= OPf_SPECIAL;
5442 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5451 Perl_ck_die(pTHX_ OP *o)
5454 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5460 Perl_ck_eof(pTHX_ OP *o)
5462 I32 type = o->op_type;
5464 if (o->op_flags & OPf_KIDS) {
5465 if (cLISTOPo->op_first->op_type == OP_STUB) {
5467 o = newUNOP(type, OPf_SPECIAL,
5468 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5476 Perl_ck_eval(pTHX_ OP *o)
5478 PL_hints |= HINT_BLOCK_SCOPE;
5479 if (o->op_flags & OPf_KIDS) {
5480 SVOP *kid = (SVOP*)cUNOPo->op_first;
5483 o->op_flags &= ~OPf_KIDS;
5486 else if (kid->op_type == OP_LINESEQ) {
5489 kid->op_next = o->op_next;
5490 cUNOPo->op_first = 0;
5493 NewOp(1101, enter, 1, LOGOP);
5494 enter->op_type = OP_ENTERTRY;
5495 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5496 enter->op_private = 0;
5498 /* establish postfix order */
5499 enter->op_next = (OP*)enter;
5501 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5502 o->op_type = OP_LEAVETRY;
5503 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5504 enter->op_other = o;
5512 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5514 o->op_targ = (PADOFFSET)PL_hints;
5519 Perl_ck_exit(pTHX_ OP *o)
5522 HV *table = GvHV(PL_hintgv);
5524 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5525 if (svp && *svp && SvTRUE(*svp))
5526 o->op_private |= OPpEXIT_VMSISH;
5528 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5534 Perl_ck_exec(pTHX_ OP *o)
5537 if (o->op_flags & OPf_STACKED) {
5539 kid = cUNOPo->op_first->op_sibling;
5540 if (kid->op_type == OP_RV2GV)
5549 Perl_ck_exists(pTHX_ OP *o)
5552 if (o->op_flags & OPf_KIDS) {
5553 OP *kid = cUNOPo->op_first;
5554 if (kid->op_type == OP_ENTERSUB) {
5555 (void) ref(kid, o->op_type);
5556 if (kid->op_type != OP_RV2CV && !PL_error_count)
5557 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5559 o->op_private |= OPpEXISTS_SUB;
5561 else if (kid->op_type == OP_AELEM)
5562 o->op_flags |= OPf_SPECIAL;
5563 else if (kid->op_type != OP_HELEM)
5564 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5573 Perl_ck_gvconst(pTHX_ register OP *o)
5575 o = fold_constants(o);
5576 if (o->op_type == OP_CONST)
5583 Perl_ck_rvconst(pTHX_ register OP *o)
5585 SVOP *kid = (SVOP*)cUNOPo->op_first;
5587 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5588 if (kid->op_type == OP_CONST) {
5592 SV *kidsv = kid->op_sv;
5595 /* Is it a constant from cv_const_sv()? */
5596 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5597 SV *rsv = SvRV(kidsv);
5598 int svtype = SvTYPE(rsv);
5599 char *badtype = Nullch;
5601 switch (o->op_type) {
5603 if (svtype > SVt_PVMG)
5604 badtype = "a SCALAR";
5607 if (svtype != SVt_PVAV)
5608 badtype = "an ARRAY";
5611 if (svtype != SVt_PVHV) {
5612 if (svtype == SVt_PVAV) { /* pseudohash? */
5613 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5614 if (ksv && SvROK(*ksv)
5615 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5624 if (svtype != SVt_PVCV)
5629 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5632 name = SvPV(kidsv, n_a);
5633 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5634 char *badthing = Nullch;
5635 switch (o->op_type) {
5637 badthing = "a SCALAR";
5640 badthing = "an ARRAY";
5643 badthing = "a HASH";
5648 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5652 * This is a little tricky. We only want to add the symbol if we
5653 * didn't add it in the lexer. Otherwise we get duplicate strict
5654 * warnings. But if we didn't add it in the lexer, we must at
5655 * least pretend like we wanted to add it even if it existed before,
5656 * or we get possible typo warnings. OPpCONST_ENTERED says
5657 * whether the lexer already added THIS instance of this symbol.
5659 iscv = (o->op_type == OP_RV2CV) * 2;
5661 gv = gv_fetchpv(name,
5662 iscv | !(kid->op_private & OPpCONST_ENTERED),
5665 : o->op_type == OP_RV2SV
5667 : o->op_type == OP_RV2AV
5669 : o->op_type == OP_RV2HV
5672 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5674 kid->op_type = OP_GV;
5675 SvREFCNT_dec(kid->op_sv);
5677 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5678 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5679 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5681 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5683 kid->op_sv = SvREFCNT_inc(gv);
5685 kid->op_private = 0;
5686 kid->op_ppaddr = PL_ppaddr[OP_GV];
5693 Perl_ck_ftst(pTHX_ OP *o)
5695 I32 type = o->op_type;
5697 if (o->op_flags & OPf_REF) {
5700 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5701 SVOP *kid = (SVOP*)cUNOPo->op_first;
5703 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5705 OP *newop = newGVOP(type, OPf_REF,
5706 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5713 if (type == OP_FTTTY)
5714 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5717 o = newUNOP(type, 0, newDEFSVOP());
5723 Perl_ck_fun(pTHX_ OP *o)
5729 int type = o->op_type;
5730 register I32 oa = PL_opargs[type] >> OASHIFT;
5732 if (o->op_flags & OPf_STACKED) {
5733 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5736 return no_fh_allowed(o);
5739 if (o->op_flags & OPf_KIDS) {
5741 tokid = &cLISTOPo->op_first;
5742 kid = cLISTOPo->op_first;
5743 if (kid->op_type == OP_PUSHMARK ||
5744 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5746 tokid = &kid->op_sibling;
5747 kid = kid->op_sibling;
5749 if (!kid && PL_opargs[type] & OA_DEFGV)
5750 *tokid = kid = newDEFSVOP();
5754 sibl = kid->op_sibling;
5757 /* list seen where single (scalar) arg expected? */
5758 if (numargs == 1 && !(oa >> 4)
5759 && kid->op_type == OP_LIST && type != OP_SCALAR)
5761 return too_many_arguments(o,PL_op_desc[type]);
5774 if ((type == OP_PUSH || type == OP_UNSHIFT)
5775 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5776 Perl_warner(aTHX_ WARN_SYNTAX,
5777 "Useless use of %s with no values",
5780 if (kid->op_type == OP_CONST &&
5781 (kid->op_private & OPpCONST_BARE))
5783 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5784 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5785 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5786 if (ckWARN(WARN_DEPRECATED))
5787 Perl_warner(aTHX_ WARN_DEPRECATED,
5788 "Array @%s missing the @ in argument %"IVdf" of %s()",
5789 name, (IV)numargs, PL_op_desc[type]);
5792 kid->op_sibling = sibl;
5795 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5796 bad_type(numargs, "array", PL_op_desc[type], kid);
5800 if (kid->op_type == OP_CONST &&
5801 (kid->op_private & OPpCONST_BARE))
5803 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5804 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5805 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5806 if (ckWARN(WARN_DEPRECATED))
5807 Perl_warner(aTHX_ WARN_DEPRECATED,
5808 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5809 name, (IV)numargs, PL_op_desc[type]);
5812 kid->op_sibling = sibl;
5815 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5816 bad_type(numargs, "hash", PL_op_desc[type], kid);
5821 OP *newop = newUNOP(OP_NULL, 0, kid);
5822 kid->op_sibling = 0;
5824 newop->op_next = newop;
5826 kid->op_sibling = sibl;
5831 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5832 if (kid->op_type == OP_CONST &&
5833 (kid->op_private & OPpCONST_BARE))
5835 OP *newop = newGVOP(OP_GV, 0,
5836 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5841 else if (kid->op_type == OP_READLINE) {
5842 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5843 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5846 I32 flags = OPf_SPECIAL;
5850 /* is this op a FH constructor? */
5851 if (is_handle_constructor(o,numargs)) {
5852 char *name = Nullch;
5856 /* Set a flag to tell rv2gv to vivify
5857 * need to "prove" flag does not mean something
5858 * else already - NI-S 1999/05/07
5861 if (kid->op_type == OP_PADSV) {
5862 SV **namep = av_fetch(PL_comppad_name,
5864 if (namep && *namep)
5865 name = SvPV(*namep, len);
5867 else if (kid->op_type == OP_RV2SV
5868 && kUNOP->op_first->op_type == OP_GV)
5870 GV *gv = cGVOPx_gv(kUNOP->op_first);
5872 len = GvNAMELEN(gv);
5874 else if (kid->op_type == OP_AELEM
5875 || kid->op_type == OP_HELEM)
5877 name = "__ANONIO__";
5883 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5884 namesv = PL_curpad[targ];
5885 (void)SvUPGRADE(namesv, SVt_PV);
5887 sv_setpvn(namesv, "$", 1);
5888 sv_catpvn(namesv, name, len);
5891 kid->op_sibling = 0;
5892 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5893 kid->op_targ = targ;
5894 kid->op_private |= priv;
5896 kid->op_sibling = sibl;
5902 mod(scalar(kid), type);
5906 tokid = &kid->op_sibling;
5907 kid = kid->op_sibling;
5909 o->op_private |= numargs;
5911 return too_many_arguments(o,OP_DESC(o));
5914 else if (PL_opargs[type] & OA_DEFGV) {
5916 return newUNOP(type, 0, newDEFSVOP());
5920 while (oa & OA_OPTIONAL)
5922 if (oa && oa != OA_LIST)
5923 return too_few_arguments(o,OP_DESC(o));
5929 Perl_ck_glob(pTHX_ OP *o)
5934 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5935 append_elem(OP_GLOB, o, newDEFSVOP());
5937 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5938 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5940 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5943 #if !defined(PERL_EXTERNAL_GLOB)
5944 /* XXX this can be tightened up and made more failsafe. */
5948 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5950 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5951 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5952 GvCV(gv) = GvCV(glob_gv);
5953 SvREFCNT_inc((SV*)GvCV(gv));
5954 GvIMPORTED_CV_on(gv);
5957 #endif /* PERL_EXTERNAL_GLOB */
5959 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5960 append_elem(OP_GLOB, o,
5961 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5962 o->op_type = OP_LIST;
5963 o->op_ppaddr = PL_ppaddr[OP_LIST];
5964 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5965 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5966 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5967 append_elem(OP_LIST, o,
5968 scalar(newUNOP(OP_RV2CV, 0,
5969 newGVOP(OP_GV, 0, gv)))));
5970 o = newUNOP(OP_NULL, 0, ck_subr(o));
5971 o->op_targ = OP_GLOB; /* hint at what it used to be */
5974 gv = newGVgen("main");
5976 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5982 Perl_ck_grep(pTHX_ OP *o)
5986 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5988 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5989 NewOp(1101, gwop, 1, LOGOP);
5991 if (o->op_flags & OPf_STACKED) {
5994 kid = cLISTOPo->op_first->op_sibling;
5995 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5998 kid->op_next = (OP*)gwop;
5999 o->op_flags &= ~OPf_STACKED;
6001 kid = cLISTOPo->op_first->op_sibling;
6002 if (type == OP_MAPWHILE)
6009 kid = cLISTOPo->op_first->op_sibling;
6010 if (kid->op_type != OP_NULL)
6011 Perl_croak(aTHX_ "panic: ck_grep");
6012 kid = kUNOP->op_first;
6014 gwop->op_type = type;
6015 gwop->op_ppaddr = PL_ppaddr[type];
6016 gwop->op_first = listkids(o);
6017 gwop->op_flags |= OPf_KIDS;
6018 gwop->op_private = 1;
6019 gwop->op_other = LINKLIST(kid);
6020 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6021 kid->op_next = (OP*)gwop;
6023 kid = cLISTOPo->op_first->op_sibling;
6024 if (!kid || !kid->op_sibling)
6025 return too_few_arguments(o,OP_DESC(o));
6026 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6027 mod(kid, OP_GREPSTART);
6033 Perl_ck_index(pTHX_ OP *o)
6035 if (o->op_flags & OPf_KIDS) {
6036 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6038 kid = kid->op_sibling; /* get past "big" */
6039 if (kid && kid->op_type == OP_CONST)
6040 fbm_compile(((SVOP*)kid)->op_sv, 0);
6046 Perl_ck_lengthconst(pTHX_ OP *o)
6048 /* XXX length optimization goes here */
6053 Perl_ck_lfun(pTHX_ OP *o)
6055 OPCODE type = o->op_type;
6056 return modkids(ck_fun(o), type);
6060 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6062 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6063 switch (cUNOPo->op_first->op_type) {
6065 /* This is needed for
6066 if (defined %stash::)
6067 to work. Do not break Tk.
6069 break; /* Globals via GV can be undef */
6071 case OP_AASSIGN: /* Is this a good idea? */
6072 Perl_warner(aTHX_ WARN_DEPRECATED,
6073 "defined(@array) is deprecated");
6074 Perl_warner(aTHX_ WARN_DEPRECATED,
6075 "\t(Maybe you should just omit the defined()?)\n");
6078 /* This is needed for
6079 if (defined %stash::)
6080 to work. Do not break Tk.
6082 break; /* Globals via GV can be undef */
6084 Perl_warner(aTHX_ WARN_DEPRECATED,
6085 "defined(%%hash) is deprecated");
6086 Perl_warner(aTHX_ WARN_DEPRECATED,
6087 "\t(Maybe you should just omit the defined()?)\n");
6098 Perl_ck_rfun(pTHX_ OP *o)
6100 OPCODE type = o->op_type;
6101 return refkids(ck_fun(o), type);
6105 Perl_ck_listiob(pTHX_ OP *o)
6109 kid = cLISTOPo->op_first;
6112 kid = cLISTOPo->op_first;
6114 if (kid->op_type == OP_PUSHMARK)
6115 kid = kid->op_sibling;
6116 if (kid && o->op_flags & OPf_STACKED)
6117 kid = kid->op_sibling;
6118 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6119 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6120 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6121 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6122 cLISTOPo->op_first->op_sibling = kid;
6123 cLISTOPo->op_last = kid;
6124 kid = kid->op_sibling;
6129 append_elem(o->op_type, o, newDEFSVOP());
6135 Perl_ck_sassign(pTHX_ OP *o)
6137 OP *kid = cLISTOPo->op_first;
6138 /* has a disposable target? */
6139 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6140 && !(kid->op_flags & OPf_STACKED)
6141 /* Cannot steal the second time! */
6142 && !(kid->op_private & OPpTARGET_MY))
6144 OP *kkid = kid->op_sibling;
6146 /* Can just relocate the target. */
6147 if (kkid && kkid->op_type == OP_PADSV
6148 && !(kkid->op_private & OPpLVAL_INTRO))
6150 kid->op_targ = kkid->op_targ;
6152 /* Now we do not need PADSV and SASSIGN. */
6153 kid->op_sibling = o->op_sibling; /* NULL */
6154 cLISTOPo->op_first = NULL;
6157 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6165 Perl_ck_match(pTHX_ OP *o)
6167 o->op_private |= OPpRUNTIME;
6172 Perl_ck_method(pTHX_ OP *o)
6174 OP *kid = cUNOPo->op_first;
6175 if (kid->op_type == OP_CONST) {
6176 SV* sv = kSVOP->op_sv;
6177 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6179 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6180 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6183 kSVOP->op_sv = Nullsv;
6185 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6194 Perl_ck_null(pTHX_ OP *o)
6200 Perl_ck_open(pTHX_ OP *o)
6202 HV *table = GvHV(PL_hintgv);
6206 svp = hv_fetch(table, "open_IN", 7, FALSE);
6208 mode = mode_from_discipline(*svp);
6209 if (mode & O_BINARY)
6210 o->op_private |= OPpOPEN_IN_RAW;
6211 else if (mode & O_TEXT)
6212 o->op_private |= OPpOPEN_IN_CRLF;
6215 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6217 mode = mode_from_discipline(*svp);
6218 if (mode & O_BINARY)
6219 o->op_private |= OPpOPEN_OUT_RAW;
6220 else if (mode & O_TEXT)
6221 o->op_private |= OPpOPEN_OUT_CRLF;
6224 if (o->op_type == OP_BACKTICK)
6230 Perl_ck_repeat(pTHX_ OP *o)
6232 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6233 o->op_private |= OPpREPEAT_DOLIST;
6234 cBINOPo->op_first = force_list(cBINOPo->op_first);
6242 Perl_ck_require(pTHX_ OP *o)
6246 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6247 SVOP *kid = (SVOP*)cUNOPo->op_first;
6249 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6251 for (s = SvPVX(kid->op_sv); *s; s++) {
6252 if (*s == ':' && s[1] == ':') {
6254 Move(s+2, s+1, strlen(s+2)+1, char);
6255 --SvCUR(kid->op_sv);
6258 if (SvREADONLY(kid->op_sv)) {
6259 SvREADONLY_off(kid->op_sv);
6260 sv_catpvn(kid->op_sv, ".pm", 3);
6261 SvREADONLY_on(kid->op_sv);
6264 sv_catpvn(kid->op_sv, ".pm", 3);
6268 /* handle override, if any */
6269 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6270 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6271 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6273 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6274 OP *kid = cUNOPo->op_first;
6275 cUNOPo->op_first = 0;
6277 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6278 append_elem(OP_LIST, kid,
6279 scalar(newUNOP(OP_RV2CV, 0,
6288 Perl_ck_return(pTHX_ OP *o)
6291 if (CvLVALUE(PL_compcv)) {
6292 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6293 mod(kid, OP_LEAVESUBLV);
6300 Perl_ck_retarget(pTHX_ OP *o)
6302 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6309 Perl_ck_select(pTHX_ OP *o)
6312 if (o->op_flags & OPf_KIDS) {
6313 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6314 if (kid && kid->op_sibling) {
6315 o->op_type = OP_SSELECT;
6316 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6318 return fold_constants(o);
6322 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6323 if (kid && kid->op_type == OP_RV2GV)
6324 kid->op_private &= ~HINT_STRICT_REFS;
6329 Perl_ck_shift(pTHX_ OP *o)
6331 I32 type = o->op_type;
6333 if (!(o->op_flags & OPf_KIDS)) {
6337 #ifdef USE_5005THREADS
6338 if (!CvUNIQUE(PL_compcv)) {
6339 argop = newOP(OP_PADAV, OPf_REF);
6340 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6343 argop = newUNOP(OP_RV2AV, 0,
6344 scalar(newGVOP(OP_GV, 0,
6345 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6348 argop = newUNOP(OP_RV2AV, 0,
6349 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6350 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6351 #endif /* USE_5005THREADS */
6352 return newUNOP(type, 0, scalar(argop));
6354 return scalar(modkids(ck_fun(o), type));
6358 Perl_ck_sort(pTHX_ OP *o)
6362 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6364 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6365 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6367 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6369 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6371 if (kid->op_type == OP_SCOPE) {
6375 else if (kid->op_type == OP_LEAVE) {
6376 if (o->op_type == OP_SORT) {
6377 op_null(kid); /* wipe out leave */
6380 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6381 if (k->op_next == kid)
6383 /* don't descend into loops */
6384 else if (k->op_type == OP_ENTERLOOP
6385 || k->op_type == OP_ENTERITER)
6387 k = cLOOPx(k)->op_lastop;
6392 kid->op_next = 0; /* just disconnect the leave */
6393 k = kLISTOP->op_first;
6398 if (o->op_type == OP_SORT) {
6399 /* provide scalar context for comparison function/block */
6405 o->op_flags |= OPf_SPECIAL;
6407 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6410 firstkid = firstkid->op_sibling;
6413 /* provide list context for arguments */
6414 if (o->op_type == OP_SORT)
6421 S_simplify_sort(pTHX_ OP *o)
6423 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6427 if (!(o->op_flags & OPf_STACKED))
6429 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6430 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6431 kid = kUNOP->op_first; /* get past null */
6432 if (kid->op_type != OP_SCOPE)
6434 kid = kLISTOP->op_last; /* get past scope */
6435 switch(kid->op_type) {
6443 k = kid; /* remember this node*/
6444 if (kBINOP->op_first->op_type != OP_RV2SV)
6446 kid = kBINOP->op_first; /* get past cmp */
6447 if (kUNOP->op_first->op_type != OP_GV)
6449 kid = kUNOP->op_first; /* get past rv2sv */
6451 if (GvSTASH(gv) != PL_curstash)
6453 if (strEQ(GvNAME(gv), "a"))
6455 else if (strEQ(GvNAME(gv), "b"))
6459 kid = k; /* back to cmp */
6460 if (kBINOP->op_last->op_type != OP_RV2SV)
6462 kid = kBINOP->op_last; /* down to 2nd arg */
6463 if (kUNOP->op_first->op_type != OP_GV)
6465 kid = kUNOP->op_first; /* get past rv2sv */
6467 if (GvSTASH(gv) != PL_curstash
6469 ? strNE(GvNAME(gv), "a")
6470 : strNE(GvNAME(gv), "b")))
6472 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6474 o->op_private |= OPpSORT_REVERSE;
6475 if (k->op_type == OP_NCMP)
6476 o->op_private |= OPpSORT_NUMERIC;
6477 if (k->op_type == OP_I_NCMP)
6478 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6479 kid = cLISTOPo->op_first->op_sibling;
6480 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6481 op_free(kid); /* then delete it */
6485 Perl_ck_split(pTHX_ OP *o)
6489 if (o->op_flags & OPf_STACKED)
6490 return no_fh_allowed(o);
6492 kid = cLISTOPo->op_first;
6493 if (kid->op_type != OP_NULL)
6494 Perl_croak(aTHX_ "panic: ck_split");
6495 kid = kid->op_sibling;
6496 op_free(cLISTOPo->op_first);
6497 cLISTOPo->op_first = kid;
6499 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6500 cLISTOPo->op_last = kid; /* There was only one element previously */
6503 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6504 OP *sibl = kid->op_sibling;
6505 kid->op_sibling = 0;
6506 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6507 if (cLISTOPo->op_first == cLISTOPo->op_last)
6508 cLISTOPo->op_last = kid;
6509 cLISTOPo->op_first = kid;
6510 kid->op_sibling = sibl;
6513 kid->op_type = OP_PUSHRE;
6514 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6517 if (!kid->op_sibling)
6518 append_elem(OP_SPLIT, o, newDEFSVOP());
6520 kid = kid->op_sibling;
6523 if (!kid->op_sibling)
6524 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6526 kid = kid->op_sibling;
6529 if (kid->op_sibling)
6530 return too_many_arguments(o,OP_DESC(o));
6536 Perl_ck_join(pTHX_ OP *o)
6538 if (ckWARN(WARN_SYNTAX)) {
6539 OP *kid = cLISTOPo->op_first->op_sibling;
6540 if (kid && kid->op_type == OP_MATCH) {
6541 char *pmstr = "STRING";
6542 if (PM_GETRE(kPMOP))
6543 pmstr = PM_GETRE(kPMOP)->precomp;
6544 Perl_warner(aTHX_ WARN_SYNTAX,
6545 "/%s/ should probably be written as \"%s\"",
6553 Perl_ck_subr(pTHX_ OP *o)
6555 OP *prev = ((cUNOPo->op_first->op_sibling)
6556 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6557 OP *o2 = prev->op_sibling;
6564 I32 contextclass = 0;
6568 o->op_private |= OPpENTERSUB_HASTARG;
6569 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6570 if (cvop->op_type == OP_RV2CV) {
6572 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6573 op_null(cvop); /* disable rv2cv */
6574 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6575 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6576 GV *gv = cGVOPx_gv(tmpop);
6579 tmpop->op_private |= OPpEARLY_CV;
6580 else if (SvPOK(cv)) {
6581 namegv = CvANON(cv) ? gv : CvGV(cv);
6582 proto = SvPV((SV*)cv, n_a);
6586 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6587 if (o2->op_type == OP_CONST)
6588 o2->op_private &= ~OPpCONST_STRICT;
6589 else if (o2->op_type == OP_LIST) {
6590 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6591 if (o && o->op_type == OP_CONST)
6592 o->op_private &= ~OPpCONST_STRICT;
6595 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6596 if (PERLDB_SUB && PL_curstash != PL_debstash)
6597 o->op_private |= OPpENTERSUB_DB;
6598 while (o2 != cvop) {
6602 return too_many_arguments(o, gv_ename(namegv));
6620 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6622 arg == 1 ? "block or sub {}" : "sub {}",
6623 gv_ename(namegv), o2);
6626 /* '*' allows any scalar type, including bareword */
6629 if (o2->op_type == OP_RV2GV)
6630 goto wrapref; /* autoconvert GLOB -> GLOBref */
6631 else if (o2->op_type == OP_CONST)
6632 o2->op_private &= ~OPpCONST_STRICT;
6633 else if (o2->op_type == OP_ENTERSUB) {
6634 /* accidental subroutine, revert to bareword */
6635 OP *gvop = ((UNOP*)o2)->op_first;
6636 if (gvop && gvop->op_type == OP_NULL) {
6637 gvop = ((UNOP*)gvop)->op_first;
6639 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6642 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6643 (gvop = ((UNOP*)gvop)->op_first) &&
6644 gvop->op_type == OP_GV)
6646 GV *gv = cGVOPx_gv(gvop);
6647 OP *sibling = o2->op_sibling;
6648 SV *n = newSVpvn("",0);
6650 gv_fullname3(n, gv, "");
6651 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6652 sv_chop(n, SvPVX(n)+6);
6653 o2 = newSVOP(OP_CONST, 0, n);
6654 prev->op_sibling = o2;
6655 o2->op_sibling = sibling;
6671 if (contextclass++ == 0) {
6672 e = strchr(proto, ']');
6673 if (!e || e == proto)
6687 if (o2->op_type == OP_RV2GV)
6690 bad_type(arg, "symbol", gv_ename(namegv), o2);
6693 if (o2->op_type == OP_ENTERSUB)
6696 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6699 if (o2->op_type == OP_RV2SV ||
6700 o2->op_type == OP_PADSV ||
6701 o2->op_type == OP_HELEM ||
6702 o2->op_type == OP_AELEM ||
6703 o2->op_type == OP_THREADSV)
6706 bad_type(arg, "scalar", gv_ename(namegv), o2);
6709 if (o2->op_type == OP_RV2AV ||
6710 o2->op_type == OP_PADAV)
6713 bad_type(arg, "array", gv_ename(namegv), o2);
6716 if (o2->op_type == OP_RV2HV ||
6717 o2->op_type == OP_PADHV)
6720 bad_type(arg, "hash", gv_ename(namegv), o2);
6725 OP* sib = kid->op_sibling;
6726 kid->op_sibling = 0;
6727 o2 = newUNOP(OP_REFGEN, 0, kid);
6728 o2->op_sibling = sib;
6729 prev->op_sibling = o2;
6731 if (contextclass && e) {
6746 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6747 gv_ename(namegv), SvPV((SV*)cv, n_a));
6752 mod(o2, OP_ENTERSUB);
6754 o2 = o2->op_sibling;
6756 if (proto && !optional &&
6757 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6758 return too_few_arguments(o, gv_ename(namegv));
6763 Perl_ck_svconst(pTHX_ OP *o)
6765 SvREADONLY_on(cSVOPo->op_sv);
6770 Perl_ck_trunc(pTHX_ OP *o)
6772 if (o->op_flags & OPf_KIDS) {
6773 SVOP *kid = (SVOP*)cUNOPo->op_first;
6775 if (kid->op_type == OP_NULL)
6776 kid = (SVOP*)kid->op_sibling;
6777 if (kid && kid->op_type == OP_CONST &&
6778 (kid->op_private & OPpCONST_BARE))
6780 o->op_flags |= OPf_SPECIAL;
6781 kid->op_private &= ~OPpCONST_STRICT;
6788 Perl_ck_substr(pTHX_ OP *o)
6791 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6792 OP *kid = cLISTOPo->op_first;
6794 if (kid->op_type == OP_NULL)
6795 kid = kid->op_sibling;
6797 kid->op_flags |= OPf_MOD;
6803 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6806 Perl_peep(pTHX_ register OP *o)
6808 register OP* oldop = 0;
6811 if (!o || o->op_seq)
6815 SAVEVPTR(PL_curcop);
6816 for (; o; o = o->op_next) {
6822 switch (o->op_type) {
6826 PL_curcop = ((COP*)o); /* for warnings */
6827 o->op_seq = PL_op_seqmax++;
6831 if (cSVOPo->op_private & OPpCONST_STRICT)
6832 no_bareword_allowed(o);
6834 /* Relocate sv to the pad for thread safety.
6835 * Despite being a "constant", the SV is written to,
6836 * for reference counts, sv_upgrade() etc. */
6838 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6839 if (SvPADTMP(cSVOPo->op_sv)) {
6840 /* If op_sv is already a PADTMP then it is being used by
6841 * some pad, so make a copy. */
6842 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6843 SvREADONLY_on(PL_curpad[ix]);
6844 SvREFCNT_dec(cSVOPo->op_sv);
6847 SvREFCNT_dec(PL_curpad[ix]);
6848 SvPADTMP_on(cSVOPo->op_sv);
6849 PL_curpad[ix] = cSVOPo->op_sv;
6850 /* XXX I don't know how this isn't readonly already. */
6851 SvREADONLY_on(PL_curpad[ix]);
6853 cSVOPo->op_sv = Nullsv;
6857 o->op_seq = PL_op_seqmax++;
6861 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6862 if (o->op_next->op_private & OPpTARGET_MY) {
6863 if (o->op_flags & OPf_STACKED) /* chained concats */
6864 goto ignore_optimization;
6866 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6867 o->op_targ = o->op_next->op_targ;
6868 o->op_next->op_targ = 0;
6869 o->op_private |= OPpTARGET_MY;
6872 op_null(o->op_next);
6874 ignore_optimization:
6875 o->op_seq = PL_op_seqmax++;
6878 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6879 o->op_seq = PL_op_seqmax++;
6880 break; /* Scalar stub must produce undef. List stub is noop */
6884 if (o->op_targ == OP_NEXTSTATE
6885 || o->op_targ == OP_DBSTATE
6886 || o->op_targ == OP_SETSTATE)
6888 PL_curcop = ((COP*)o);
6890 /* XXX: We avoid setting op_seq here to prevent later calls
6891 to peep() from mistakenly concluding that optimisation
6892 has already occurred. This doesn't fix the real problem,
6893 though (See 20010220.007). AMS 20010719 */
6894 if (oldop && o->op_next) {
6895 oldop->op_next = o->op_next;
6903 if (oldop && o->op_next) {
6904 oldop->op_next = o->op_next;
6907 o->op_seq = PL_op_seqmax++;
6911 if (o->op_next->op_type == OP_RV2SV) {
6912 if (!(o->op_next->op_private & OPpDEREF)) {
6913 op_null(o->op_next);
6914 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6916 o->op_next = o->op_next->op_next;
6917 o->op_type = OP_GVSV;
6918 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6921 else if (o->op_next->op_type == OP_RV2AV) {
6922 OP* pop = o->op_next->op_next;
6924 if (pop->op_type == OP_CONST &&
6925 (PL_op = pop->op_next) &&
6926 pop->op_next->op_type == OP_AELEM &&
6927 !(pop->op_next->op_private &
6928 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6929 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6934 op_null(o->op_next);
6935 op_null(pop->op_next);
6937 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6938 o->op_next = pop->op_next->op_next;
6939 o->op_type = OP_AELEMFAST;
6940 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6941 o->op_private = (U8)i;
6946 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6948 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6949 /* XXX could check prototype here instead of just carping */
6950 SV *sv = sv_newmortal();
6951 gv_efullname3(sv, gv, Nullch);
6952 Perl_warner(aTHX_ WARN_PROTOTYPE,
6953 "%s() called too early to check prototype",
6957 else if (o->op_next->op_type == OP_READLINE
6958 && o->op_next->op_next->op_type == OP_CONCAT
6959 && (o->op_next->op_next->op_flags & OPf_STACKED))
6961 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6962 o->op_type = OP_RCATLINE;
6963 o->op_flags |= OPf_STACKED;
6964 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6965 op_null(o->op_next->op_next);
6966 op_null(o->op_next);
6969 o->op_seq = PL_op_seqmax++;
6980 o->op_seq = PL_op_seqmax++;
6981 while (cLOGOP->op_other->op_type == OP_NULL)
6982 cLOGOP->op_other = cLOGOP->op_other->op_next;
6983 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6988 o->op_seq = PL_op_seqmax++;
6989 while (cLOOP->op_redoop->op_type == OP_NULL)
6990 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6991 peep(cLOOP->op_redoop);
6992 while (cLOOP->op_nextop->op_type == OP_NULL)
6993 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6994 peep(cLOOP->op_nextop);
6995 while (cLOOP->op_lastop->op_type == OP_NULL)
6996 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6997 peep(cLOOP->op_lastop);
7003 o->op_seq = PL_op_seqmax++;
7004 while (cPMOP->op_pmreplstart &&
7005 cPMOP->op_pmreplstart->op_type == OP_NULL)
7006 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7007 peep(cPMOP->op_pmreplstart);
7011 o->op_seq = PL_op_seqmax++;
7012 if (ckWARN(WARN_SYNTAX) && o->op_next
7013 && o->op_next->op_type == OP_NEXTSTATE) {
7014 if (o->op_next->op_sibling &&
7015 o->op_next->op_sibling->op_type != OP_EXIT &&
7016 o->op_next->op_sibling->op_type != OP_WARN &&
7017 o->op_next->op_sibling->op_type != OP_DIE) {
7018 line_t oldline = CopLINE(PL_curcop);
7020 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7021 Perl_warner(aTHX_ WARN_EXEC,
7022 "Statement unlikely to be reached");
7023 Perl_warner(aTHX_ WARN_EXEC,
7024 "\t(Maybe you meant system() when you said exec()?)\n");
7025 CopLINE_set(PL_curcop, oldline);
7034 SV **svp, **indsvp, *sv;
7039 o->op_seq = PL_op_seqmax++;
7041 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7044 /* Make the CONST have a shared SV */
7045 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7046 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7047 key = SvPV(sv, keylen);
7048 lexname = newSVpvn_share(key,
7049 SvUTF8(sv) ? -(I32)keylen : keylen,
7055 if ((o->op_private & (OPpLVAL_INTRO)))
7058 rop = (UNOP*)((BINOP*)o)->op_first;
7059 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7061 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7062 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7064 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7065 if (!fields || !GvHV(*fields))
7067 key = SvPV(*svp, keylen);
7068 indsvp = hv_fetch(GvHV(*fields), key,
7069 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7071 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7072 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7074 ind = SvIV(*indsvp);
7076 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7077 rop->op_type = OP_RV2AV;
7078 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7079 o->op_type = OP_AELEM;
7080 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7082 if (SvREADONLY(*svp))
7084 SvFLAGS(sv) |= (SvFLAGS(*svp)
7085 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7095 SV **svp, **indsvp, *sv;
7099 SVOP *first_key_op, *key_op;
7101 o->op_seq = PL_op_seqmax++;
7102 if ((o->op_private & (OPpLVAL_INTRO))
7103 /* I bet there's always a pushmark... */
7104 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7105 /* hmmm, no optimization if list contains only one key. */
7107 rop = (UNOP*)((LISTOP*)o)->op_last;
7108 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7110 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7111 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7113 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7114 if (!fields || !GvHV(*fields))
7116 /* Again guessing that the pushmark can be jumped over.... */
7117 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7118 ->op_first->op_sibling;
7119 /* Check that the key list contains only constants. */
7120 for (key_op = first_key_op; key_op;
7121 key_op = (SVOP*)key_op->op_sibling)
7122 if (key_op->op_type != OP_CONST)
7126 rop->op_type = OP_RV2AV;
7127 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7128 o->op_type = OP_ASLICE;
7129 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7130 for (key_op = first_key_op; key_op;
7131 key_op = (SVOP*)key_op->op_sibling) {
7132 svp = cSVOPx_svp(key_op);
7133 key = SvPV(*svp, keylen);
7134 indsvp = hv_fetch(GvHV(*fields), key,
7135 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7137 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7138 "in variable %s of type %s",
7139 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7141 ind = SvIV(*indsvp);
7143 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7145 if (SvREADONLY(*svp))
7147 SvFLAGS(sv) |= (SvFLAGS(*svp)
7148 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7156 o->op_seq = PL_op_seqmax++;
7166 char* Perl_custom_op_name(pTHX_ OP* o)
7168 IV index = PTR2IV(o->op_ppaddr);
7172 if (!PL_custom_op_names) /* This probably shouldn't happen */
7173 return PL_op_name[OP_CUSTOM];
7175 keysv = sv_2mortal(newSViv(index));
7177 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7179 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7181 return SvPV_nolen(HeVAL(he));
7184 char* Perl_custom_op_desc(pTHX_ OP* o)
7186 IV index = PTR2IV(o->op_ppaddr);
7190 if (!PL_custom_op_descs)
7191 return PL_op_desc[OP_CUSTOM];
7193 keysv = sv_2mortal(newSViv(index));
7195 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7197 return PL_op_desc[OP_CUSTOM];
7199 return SvPV_nolen(HeVAL(he));
7205 /* Efficient sub that returns a constant scalar value. */
7207 const_sv_xsub(pTHX_ CV* cv)
7212 Perl_croak(aTHX_ "usage: %s::%s()",
7213 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7217 ST(0) = (SV*)XSANY.any_ptr;