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_flags & OPf_STACKED) &&
2057 (right->op_type == OP_MATCH ||
2058 right->op_type == OP_SUBST ||
2059 right->op_type == OP_TRANS)) {
2060 right->op_flags |= OPf_STACKED;
2061 if ((right->op_type != OP_MATCH &&
2062 ! (right->op_type == OP_TRANS &&
2063 right->op_private & OPpTRANS_IDENTICAL)) ||
2064 /* if SV has magic, then match on original SV, not on its copy.
2065 see note in pp_helem() */
2066 (right->op_type == OP_MATCH &&
2067 (left->op_type == OP_AELEM ||
2068 left->op_type == OP_HELEM ||
2069 left->op_type == OP_AELEMFAST)))
2070 left = mod(left, right->op_type);
2071 if (right->op_type == OP_TRANS)
2072 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2074 o = prepend_elem(right->op_type, scalar(left), right);
2076 return newUNOP(OP_NOT, 0, scalar(o));
2080 return bind_match(type, left,
2081 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2085 Perl_invert(pTHX_ OP *o)
2089 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2090 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2094 Perl_scope(pTHX_ OP *o)
2097 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2098 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2099 o->op_type = OP_LEAVE;
2100 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2103 if (o->op_type == OP_LINESEQ) {
2105 o->op_type = OP_SCOPE;
2106 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2107 kid = ((LISTOP*)o)->op_first;
2108 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2112 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2119 Perl_save_hints(pTHX)
2122 SAVESPTR(GvHV(PL_hintgv));
2123 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2124 SAVEFREESV(GvHV(PL_hintgv));
2128 Perl_block_start(pTHX_ int full)
2130 int retval = PL_savestack_ix;
2132 SAVEI32(PL_comppad_name_floor);
2133 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2135 PL_comppad_name_fill = PL_comppad_name_floor;
2136 if (PL_comppad_name_floor < 0)
2137 PL_comppad_name_floor = 0;
2138 SAVEI32(PL_min_intro_pending);
2139 SAVEI32(PL_max_intro_pending);
2140 PL_min_intro_pending = 0;
2141 SAVEI32(PL_comppad_name_fill);
2142 SAVEI32(PL_padix_floor);
2143 PL_padix_floor = PL_padix;
2144 PL_pad_reset_pending = FALSE;
2146 PL_hints &= ~HINT_BLOCK_SCOPE;
2147 SAVESPTR(PL_compiling.cop_warnings);
2148 if (! specialWARN(PL_compiling.cop_warnings)) {
2149 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2150 SAVEFREESV(PL_compiling.cop_warnings) ;
2152 SAVESPTR(PL_compiling.cop_io);
2153 if (! specialCopIO(PL_compiling.cop_io)) {
2154 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2155 SAVEFREESV(PL_compiling.cop_io) ;
2161 Perl_block_end(pTHX_ I32 floor, OP *seq)
2163 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2164 line_t copline = PL_copline;
2165 /* there should be a nextstate in every block */
2166 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2167 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2169 PL_pad_reset_pending = FALSE;
2170 PL_compiling.op_private = PL_hints;
2172 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2173 pad_leavemy(PL_comppad_name_fill);
2181 #ifdef USE_5005THREADS
2182 OP *o = newOP(OP_THREADSV, 0);
2183 o->op_targ = find_threadsv("_");
2186 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2187 #endif /* USE_5005THREADS */
2191 Perl_newPROG(pTHX_ OP *o)
2196 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2197 ((PL_in_eval & EVAL_KEEPERR)
2198 ? OPf_SPECIAL : 0), o);
2199 PL_eval_start = linklist(PL_eval_root);
2200 PL_eval_root->op_private |= OPpREFCOUNTED;
2201 OpREFCNT_set(PL_eval_root, 1);
2202 PL_eval_root->op_next = 0;
2203 CALL_PEEP(PL_eval_start);
2208 PL_main_root = scope(sawparens(scalarvoid(o)));
2209 PL_curcop = &PL_compiling;
2210 PL_main_start = LINKLIST(PL_main_root);
2211 PL_main_root->op_private |= OPpREFCOUNTED;
2212 OpREFCNT_set(PL_main_root, 1);
2213 PL_main_root->op_next = 0;
2214 CALL_PEEP(PL_main_start);
2217 /* Register with debugger */
2219 CV *cv = get_cv("DB::postponed", FALSE);
2223 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2225 call_sv((SV*)cv, G_DISCARD);
2232 Perl_localize(pTHX_ OP *o, I32 lex)
2234 if (o->op_flags & OPf_PARENS)
2237 if (ckWARN(WARN_PARENTHESIS)
2238 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2240 char *s = PL_bufptr;
2242 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2245 if (*s == ';' || *s == '=')
2246 Perl_warner(aTHX_ WARN_PARENTHESIS,
2247 "Parentheses missing around \"%s\" list",
2248 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2254 o = mod(o, OP_NULL); /* a bit kludgey */
2256 PL_in_my_stash = Nullhv;
2261 Perl_jmaybe(pTHX_ OP *o)
2263 if (o->op_type == OP_LIST) {
2265 #ifdef USE_5005THREADS
2266 o2 = newOP(OP_THREADSV, 0);
2267 o2->op_targ = find_threadsv(";");
2269 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2270 #endif /* USE_5005THREADS */
2271 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2277 Perl_fold_constants(pTHX_ register OP *o)
2280 I32 type = o->op_type;
2283 if (PL_opargs[type] & OA_RETSCALAR)
2285 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2286 o->op_targ = pad_alloc(type, SVs_PADTMP);
2288 /* integerize op, unless it happens to be C<-foo>.
2289 * XXX should pp_i_negate() do magic string negation instead? */
2290 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2291 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2292 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2294 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2297 if (!(PL_opargs[type] & OA_FOLDCONST))
2302 /* XXX might want a ck_negate() for this */
2303 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2315 /* XXX what about the numeric ops? */
2316 if (PL_hints & HINT_LOCALE)
2321 goto nope; /* Don't try to run w/ errors */
2323 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2324 if ((curop->op_type != OP_CONST ||
2325 (curop->op_private & OPpCONST_BARE)) &&
2326 curop->op_type != OP_LIST &&
2327 curop->op_type != OP_SCALAR &&
2328 curop->op_type != OP_NULL &&
2329 curop->op_type != OP_PUSHMARK)
2335 curop = LINKLIST(o);
2339 sv = *(PL_stack_sp--);
2340 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2341 pad_swipe(o->op_targ);
2342 else if (SvTEMP(sv)) { /* grab mortal temp? */
2343 (void)SvREFCNT_inc(sv);
2347 if (type == OP_RV2GV)
2348 return newGVOP(OP_GV, 0, (GV*)sv);
2350 /* try to smush double to int, but don't smush -2.0 to -2 */
2351 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2354 #ifdef PERL_PRESERVE_IVUV
2355 /* Only bother to attempt to fold to IV if
2356 most operators will benefit */
2360 return newSVOP(OP_CONST, 0, sv);
2364 if (!(PL_opargs[type] & OA_OTHERINT))
2367 if (!(PL_hints & HINT_INTEGER)) {
2368 if (type == OP_MODULO
2369 || type == OP_DIVIDE
2370 || !(o->op_flags & OPf_KIDS))
2375 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2376 if (curop->op_type == OP_CONST) {
2377 if (SvIOK(((SVOP*)curop)->op_sv))
2381 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2385 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2392 Perl_gen_constant_list(pTHX_ register OP *o)
2395 I32 oldtmps_floor = PL_tmps_floor;
2399 return o; /* Don't attempt to run with errors */
2401 PL_op = curop = LINKLIST(o);
2408 PL_tmps_floor = oldtmps_floor;
2410 o->op_type = OP_RV2AV;
2411 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2412 curop = ((UNOP*)o)->op_first;
2413 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2420 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2422 if (!o || o->op_type != OP_LIST)
2423 o = newLISTOP(OP_LIST, 0, o, Nullop);
2425 o->op_flags &= ~OPf_WANT;
2427 if (!(PL_opargs[type] & OA_MARK))
2428 op_null(cLISTOPo->op_first);
2431 o->op_ppaddr = PL_ppaddr[type];
2432 o->op_flags |= flags;
2434 o = CHECKOP(type, o);
2435 if (o->op_type != type)
2438 return fold_constants(o);
2441 /* List constructors */
2444 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2452 if (first->op_type != type
2453 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2455 return newLISTOP(type, 0, first, last);
2458 if (first->op_flags & OPf_KIDS)
2459 ((LISTOP*)first)->op_last->op_sibling = last;
2461 first->op_flags |= OPf_KIDS;
2462 ((LISTOP*)first)->op_first = last;
2464 ((LISTOP*)first)->op_last = last;
2469 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2477 if (first->op_type != type)
2478 return prepend_elem(type, (OP*)first, (OP*)last);
2480 if (last->op_type != type)
2481 return append_elem(type, (OP*)first, (OP*)last);
2483 first->op_last->op_sibling = last->op_first;
2484 first->op_last = last->op_last;
2485 first->op_flags |= (last->op_flags & OPf_KIDS);
2487 #ifdef PL_OP_SLAB_ALLOC
2495 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2503 if (last->op_type == type) {
2504 if (type == OP_LIST) { /* already a PUSHMARK there */
2505 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2506 ((LISTOP*)last)->op_first->op_sibling = first;
2507 if (!(first->op_flags & OPf_PARENS))
2508 last->op_flags &= ~OPf_PARENS;
2511 if (!(last->op_flags & OPf_KIDS)) {
2512 ((LISTOP*)last)->op_last = first;
2513 last->op_flags |= OPf_KIDS;
2515 first->op_sibling = ((LISTOP*)last)->op_first;
2516 ((LISTOP*)last)->op_first = first;
2518 last->op_flags |= OPf_KIDS;
2522 return newLISTOP(type, 0, first, last);
2528 Perl_newNULLLIST(pTHX)
2530 return newOP(OP_STUB, 0);
2534 Perl_force_list(pTHX_ OP *o)
2536 if (!o || o->op_type != OP_LIST)
2537 o = newLISTOP(OP_LIST, 0, o, Nullop);
2543 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2547 NewOp(1101, listop, 1, LISTOP);
2549 listop->op_type = type;
2550 listop->op_ppaddr = PL_ppaddr[type];
2553 listop->op_flags = flags;
2557 else if (!first && last)
2560 first->op_sibling = last;
2561 listop->op_first = first;
2562 listop->op_last = last;
2563 if (type == OP_LIST) {
2565 pushop = newOP(OP_PUSHMARK, 0);
2566 pushop->op_sibling = first;
2567 listop->op_first = pushop;
2568 listop->op_flags |= OPf_KIDS;
2570 listop->op_last = pushop;
2577 Perl_newOP(pTHX_ I32 type, I32 flags)
2580 NewOp(1101, o, 1, OP);
2582 o->op_ppaddr = PL_ppaddr[type];
2583 o->op_flags = flags;
2586 o->op_private = 0 + (flags >> 8);
2587 if (PL_opargs[type] & OA_RETSCALAR)
2589 if (PL_opargs[type] & OA_TARGET)
2590 o->op_targ = pad_alloc(type, SVs_PADTMP);
2591 return CHECKOP(type, o);
2595 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2600 first = newOP(OP_STUB, 0);
2601 if (PL_opargs[type] & OA_MARK)
2602 first = force_list(first);
2604 NewOp(1101, unop, 1, UNOP);
2605 unop->op_type = type;
2606 unop->op_ppaddr = PL_ppaddr[type];
2607 unop->op_first = first;
2608 unop->op_flags = flags | OPf_KIDS;
2609 unop->op_private = 1 | (flags >> 8);
2610 unop = (UNOP*) CHECKOP(type, unop);
2614 return fold_constants((OP *) unop);
2618 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2621 NewOp(1101, binop, 1, BINOP);
2624 first = newOP(OP_NULL, 0);
2626 binop->op_type = type;
2627 binop->op_ppaddr = PL_ppaddr[type];
2628 binop->op_first = first;
2629 binop->op_flags = flags | OPf_KIDS;
2632 binop->op_private = 1 | (flags >> 8);
2635 binop->op_private = 2 | (flags >> 8);
2636 first->op_sibling = last;
2639 binop = (BINOP*)CHECKOP(type, binop);
2640 if (binop->op_next || binop->op_type != type)
2643 binop->op_last = binop->op_first->op_sibling;
2645 return fold_constants((OP *)binop);
2649 uvcompare(const void *a, const void *b)
2651 if (*((UV *)a) < (*(UV *)b))
2653 if (*((UV *)a) > (*(UV *)b))
2655 if (*((UV *)a+1) < (*(UV *)b+1))
2657 if (*((UV *)a+1) > (*(UV *)b+1))
2663 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2665 SV *tstr = ((SVOP*)expr)->op_sv;
2666 SV *rstr = ((SVOP*)repl)->op_sv;
2669 U8 *t = (U8*)SvPV(tstr, tlen);
2670 U8 *r = (U8*)SvPV(rstr, rlen);
2677 register short *tbl;
2679 PL_hints |= HINT_BLOCK_SCOPE;
2680 complement = o->op_private & OPpTRANS_COMPLEMENT;
2681 del = o->op_private & OPpTRANS_DELETE;
2682 squash = o->op_private & OPpTRANS_SQUASH;
2685 o->op_private |= OPpTRANS_FROM_UTF;
2688 o->op_private |= OPpTRANS_TO_UTF;
2690 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2691 SV* listsv = newSVpvn("# comment\n",10);
2693 U8* tend = t + tlen;
2694 U8* rend = r + rlen;
2708 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2709 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2715 tsave = t = bytes_to_utf8(t, &len);
2718 if (!to_utf && rlen) {
2720 rsave = r = bytes_to_utf8(r, &len);
2724 /* There are several snags with this code on EBCDIC:
2725 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2726 2. scan_const() in toke.c has encoded chars in native encoding which makes
2727 ranges at least in EBCDIC 0..255 range the bottom odd.
2731 U8 tmpbuf[UTF8_MAXLEN+1];
2734 New(1109, cp, 2*tlen, UV);
2736 transv = newSVpvn("",0);
2738 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2740 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2742 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2746 cp[2*i+1] = cp[2*i];
2750 qsort(cp, i, 2*sizeof(UV), uvcompare);
2751 for (j = 0; j < i; j++) {
2753 diff = val - nextmin;
2755 t = uvuni_to_utf8(tmpbuf,nextmin);
2756 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2758 U8 range_mark = UTF_TO_NATIVE(0xff);
2759 t = uvuni_to_utf8(tmpbuf, val - 1);
2760 sv_catpvn(transv, (char *)&range_mark, 1);
2761 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2768 t = uvuni_to_utf8(tmpbuf,nextmin);
2769 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2771 U8 range_mark = UTF_TO_NATIVE(0xff);
2772 sv_catpvn(transv, (char *)&range_mark, 1);
2774 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2775 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2776 t = (U8*)SvPVX(transv);
2777 tlen = SvCUR(transv);
2781 else if (!rlen && !del) {
2782 r = t; rlen = tlen; rend = tend;
2785 if ((!rlen && !del) || t == r ||
2786 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2788 o->op_private |= OPpTRANS_IDENTICAL;
2792 while (t < tend || tfirst <= tlast) {
2793 /* see if we need more "t" chars */
2794 if (tfirst > tlast) {
2795 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2797 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2799 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2806 /* now see if we need more "r" chars */
2807 if (rfirst > rlast) {
2809 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2811 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2813 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2822 rfirst = rlast = 0xffffffff;
2826 /* now see which range will peter our first, if either. */
2827 tdiff = tlast - tfirst;
2828 rdiff = rlast - rfirst;
2835 if (rfirst == 0xffffffff) {
2836 diff = tdiff; /* oops, pretend rdiff is infinite */
2838 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2839 (long)tfirst, (long)tlast);
2841 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2845 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2846 (long)tfirst, (long)(tfirst + diff),
2849 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2850 (long)tfirst, (long)rfirst);
2852 if (rfirst + diff > max)
2853 max = rfirst + diff;
2855 grows = (tfirst < rfirst &&
2856 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2868 else if (max > 0xff)
2873 Safefree(cPVOPo->op_pv);
2874 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2875 SvREFCNT_dec(listsv);
2877 SvREFCNT_dec(transv);
2879 if (!del && havefinal && rlen)
2880 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2881 newSVuv((UV)final), 0);
2884 o->op_private |= OPpTRANS_GROWS;
2896 tbl = (short*)cPVOPo->op_pv;
2898 Zero(tbl, 256, short);
2899 for (i = 0; i < tlen; i++)
2901 for (i = 0, j = 0; i < 256; i++) {
2912 if (i < 128 && r[j] >= 128)
2922 o->op_private |= OPpTRANS_IDENTICAL;
2927 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2928 tbl[0x100] = rlen - j;
2929 for (i=0; i < rlen - j; i++)
2930 tbl[0x101+i] = r[j+i];
2934 if (!rlen && !del) {
2937 o->op_private |= OPpTRANS_IDENTICAL;
2939 for (i = 0; i < 256; i++)
2941 for (i = 0, j = 0; i < tlen; i++,j++) {
2944 if (tbl[t[i]] == -1)
2950 if (tbl[t[i]] == -1) {
2951 if (t[i] < 128 && r[j] >= 128)
2958 o->op_private |= OPpTRANS_GROWS;
2966 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2970 NewOp(1101, pmop, 1, PMOP);
2971 pmop->op_type = type;
2972 pmop->op_ppaddr = PL_ppaddr[type];
2973 pmop->op_flags = flags;
2974 pmop->op_private = 0 | (flags >> 8);
2976 if (PL_hints & HINT_RE_TAINT)
2977 pmop->op_pmpermflags |= PMf_RETAINT;
2978 if (PL_hints & HINT_LOCALE)
2979 pmop->op_pmpermflags |= PMf_LOCALE;
2980 pmop->op_pmflags = pmop->op_pmpermflags;
2985 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2986 repointer = av_pop((AV*)PL_regex_pad[0]);
2987 pmop->op_pmoffset = SvIV(repointer);
2988 SvREPADTMP_off(repointer);
2989 sv_setiv(repointer,0);
2991 repointer = newSViv(0);
2992 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2993 pmop->op_pmoffset = av_len(PL_regex_padav);
2994 PL_regex_pad = AvARRAY(PL_regex_padav);
2999 /* link into pm list */
3000 if (type != OP_TRANS && PL_curstash) {
3001 pmop->op_pmnext = HvPMROOT(PL_curstash);
3002 HvPMROOT(PL_curstash) = pmop;
3003 PmopSTASH_set(pmop,PL_curstash);
3010 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3014 I32 repl_has_vars = 0;
3016 if (o->op_type == OP_TRANS)
3017 return pmtrans(o, expr, repl);
3019 PL_hints |= HINT_BLOCK_SCOPE;
3022 if (expr->op_type == OP_CONST) {
3024 SV *pat = ((SVOP*)expr)->op_sv;
3025 char *p = SvPV(pat, plen);
3026 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3027 sv_setpvn(pat, "\\s+", 3);
3028 p = SvPV(pat, plen);
3029 pm->op_pmflags |= PMf_SKIPWHITE;
3031 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3032 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3033 pm->op_pmflags |= PMf_WHITE;
3037 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3038 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3040 : OP_REGCMAYBE),0,expr);
3042 NewOp(1101, rcop, 1, LOGOP);
3043 rcop->op_type = OP_REGCOMP;
3044 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3045 rcop->op_first = scalar(expr);
3046 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3047 ? (OPf_SPECIAL | OPf_KIDS)
3049 rcop->op_private = 1;
3052 /* establish postfix order */
3053 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3055 rcop->op_next = expr;
3056 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3059 rcop->op_next = LINKLIST(expr);
3060 expr->op_next = (OP*)rcop;
3063 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3068 if (pm->op_pmflags & PMf_EVAL) {
3070 if (CopLINE(PL_curcop) < PL_multi_end)
3071 CopLINE_set(PL_curcop, PL_multi_end);
3073 #ifdef USE_5005THREADS
3074 else if (repl->op_type == OP_THREADSV
3075 && strchr("&`'123456789+",
3076 PL_threadsv_names[repl->op_targ]))
3080 #endif /* USE_5005THREADS */
3081 else if (repl->op_type == OP_CONST)
3085 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3086 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3087 #ifdef USE_5005THREADS
3088 if (curop->op_type == OP_THREADSV) {
3090 if (strchr("&`'123456789+", curop->op_private))
3094 if (curop->op_type == OP_GV) {
3095 GV *gv = cGVOPx_gv(curop);
3097 if (strchr("&`'123456789+", *GvENAME(gv)))
3100 #endif /* USE_5005THREADS */
3101 else if (curop->op_type == OP_RV2CV)
3103 else if (curop->op_type == OP_RV2SV ||
3104 curop->op_type == OP_RV2AV ||
3105 curop->op_type == OP_RV2HV ||
3106 curop->op_type == OP_RV2GV) {
3107 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3110 else if (curop->op_type == OP_PADSV ||
3111 curop->op_type == OP_PADAV ||
3112 curop->op_type == OP_PADHV ||
3113 curop->op_type == OP_PADANY) {
3116 else if (curop->op_type == OP_PUSHRE)
3117 ; /* Okay here, dangerous in newASSIGNOP */
3127 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3128 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3129 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3130 prepend_elem(o->op_type, scalar(repl), o);
3133 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3134 pm->op_pmflags |= PMf_MAYBE_CONST;
3135 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3137 NewOp(1101, rcop, 1, LOGOP);
3138 rcop->op_type = OP_SUBSTCONT;
3139 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3140 rcop->op_first = scalar(repl);
3141 rcop->op_flags |= OPf_KIDS;
3142 rcop->op_private = 1;
3145 /* establish postfix order */
3146 rcop->op_next = LINKLIST(repl);
3147 repl->op_next = (OP*)rcop;
3149 pm->op_pmreplroot = scalar((OP*)rcop);
3150 pm->op_pmreplstart = LINKLIST(rcop);
3159 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3162 NewOp(1101, svop, 1, SVOP);
3163 svop->op_type = type;
3164 svop->op_ppaddr = PL_ppaddr[type];
3166 svop->op_next = (OP*)svop;
3167 svop->op_flags = flags;
3168 if (PL_opargs[type] & OA_RETSCALAR)
3170 if (PL_opargs[type] & OA_TARGET)
3171 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3172 return CHECKOP(type, svop);
3176 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3179 NewOp(1101, padop, 1, PADOP);
3180 padop->op_type = type;
3181 padop->op_ppaddr = PL_ppaddr[type];
3182 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3183 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3184 PL_curpad[padop->op_padix] = sv;
3186 padop->op_next = (OP*)padop;
3187 padop->op_flags = flags;
3188 if (PL_opargs[type] & OA_RETSCALAR)
3190 if (PL_opargs[type] & OA_TARGET)
3191 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3192 return CHECKOP(type, padop);
3196 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3200 return newPADOP(type, flags, SvREFCNT_inc(gv));
3202 return newSVOP(type, flags, SvREFCNT_inc(gv));
3207 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3210 NewOp(1101, pvop, 1, PVOP);
3211 pvop->op_type = type;
3212 pvop->op_ppaddr = PL_ppaddr[type];
3214 pvop->op_next = (OP*)pvop;
3215 pvop->op_flags = flags;
3216 if (PL_opargs[type] & OA_RETSCALAR)
3218 if (PL_opargs[type] & OA_TARGET)
3219 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3220 return CHECKOP(type, pvop);
3224 Perl_package(pTHX_ OP *o)
3228 save_hptr(&PL_curstash);
3229 save_item(PL_curstname);
3234 name = SvPV(sv, len);
3235 PL_curstash = gv_stashpvn(name,len,TRUE);
3236 sv_setpvn(PL_curstname, name, len);
3240 deprecate("\"package\" with no arguments");
3241 sv_setpv(PL_curstname,"<none>");
3242 PL_curstash = Nullhv;
3244 PL_hints |= HINT_BLOCK_SCOPE;
3245 PL_copline = NOLINE;
3250 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3255 char *packname = Nullch;
3259 if (id->op_type != OP_CONST)
3260 Perl_croak(aTHX_ "Module name must be constant");
3264 if (version != Nullop) {
3265 SV *vesv = ((SVOP*)version)->op_sv;
3267 if (arg == Nullop && !SvNIOKp(vesv)) {
3274 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3275 Perl_croak(aTHX_ "Version number must be constant number");
3277 /* Make copy of id so we don't free it twice */
3278 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3280 /* Fake up a method call to VERSION */
3281 meth = newSVpvn("VERSION",7);
3282 sv_upgrade(meth, SVt_PVIV);
3283 (void)SvIOK_on(meth);
3284 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3285 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3286 append_elem(OP_LIST,
3287 prepend_elem(OP_LIST, pack, list(version)),
3288 newSVOP(OP_METHOD_NAMED, 0, meth)));
3292 /* Fake up an import/unimport */
3293 if (arg && arg->op_type == OP_STUB)
3294 imop = arg; /* no import on explicit () */
3295 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3296 imop = Nullop; /* use 5.0; */
3301 /* Make copy of id so we don't free it twice */
3302 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3304 /* Fake up a method call to import/unimport */
3305 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3306 (void)SvUPGRADE(meth, SVt_PVIV);
3307 (void)SvIOK_on(meth);
3308 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3309 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3310 append_elem(OP_LIST,
3311 prepend_elem(OP_LIST, pack, list(arg)),
3312 newSVOP(OP_METHOD_NAMED, 0, meth)));
3315 if (ckWARN(WARN_MISC) &&
3316 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3317 SvPOK(packsv = ((SVOP*)id)->op_sv))
3319 /* BEGIN will free the ops, so we need to make a copy */
3320 packlen = SvCUR(packsv);
3321 packname = savepvn(SvPVX(packsv), packlen);
3324 /* Fake up the BEGIN {}, which does its thing immediately. */
3326 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3329 append_elem(OP_LINESEQ,
3330 append_elem(OP_LINESEQ,
3331 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3332 newSTATEOP(0, Nullch, veop)),
3333 newSTATEOP(0, Nullch, imop) ));
3336 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3337 Perl_warner(aTHX_ WARN_MISC,
3338 "Package `%s' not found "
3339 "(did you use the incorrect case?)", packname);
3344 PL_hints |= HINT_BLOCK_SCOPE;
3345 PL_copline = NOLINE;
3350 =for apidoc load_module
3352 Loads the module whose name is pointed to by the string part of name.
3353 Note that the actual module name, not its filename, should be given.
3354 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3355 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3356 (or 0 for no flags). ver, if specified, provides version semantics
3357 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3358 arguments can be used to specify arguments to the module's import()
3359 method, similar to C<use Foo::Bar VERSION LIST>.
3364 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3367 va_start(args, ver);
3368 vload_module(flags, name, ver, &args);
3372 #ifdef PERL_IMPLICIT_CONTEXT
3374 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3378 va_start(args, ver);
3379 vload_module(flags, name, ver, &args);
3385 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3387 OP *modname, *veop, *imop;
3389 modname = newSVOP(OP_CONST, 0, name);
3390 modname->op_private |= OPpCONST_BARE;
3392 veop = newSVOP(OP_CONST, 0, ver);
3396 if (flags & PERL_LOADMOD_NOIMPORT) {
3397 imop = sawparens(newNULLLIST());
3399 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3400 imop = va_arg(*args, OP*);
3405 sv = va_arg(*args, SV*);
3407 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3408 sv = va_arg(*args, SV*);
3412 line_t ocopline = PL_copline;
3413 int oexpect = PL_expect;
3415 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3416 veop, modname, imop);
3417 PL_expect = oexpect;
3418 PL_copline = ocopline;
3423 Perl_dofile(pTHX_ OP *term)
3428 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3429 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3430 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3432 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3433 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3434 append_elem(OP_LIST, term,
3435 scalar(newUNOP(OP_RV2CV, 0,
3440 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3446 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3448 return newBINOP(OP_LSLICE, flags,
3449 list(force_list(subscript)),
3450 list(force_list(listval)) );
3454 S_list_assignment(pTHX_ register OP *o)
3459 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3460 o = cUNOPo->op_first;
3462 if (o->op_type == OP_COND_EXPR) {
3463 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3464 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3469 yyerror("Assignment to both a list and a scalar");
3473 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3474 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3475 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3478 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3481 if (o->op_type == OP_RV2SV)
3488 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3493 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3494 return newLOGOP(optype, 0,
3495 mod(scalar(left), optype),
3496 newUNOP(OP_SASSIGN, 0, scalar(right)));
3499 return newBINOP(optype, OPf_STACKED,
3500 mod(scalar(left), optype), scalar(right));
3504 if (list_assignment(left)) {
3508 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3509 left = mod(left, OP_AASSIGN);
3517 curop = list(force_list(left));
3518 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3519 o->op_private = 0 | (flags >> 8);
3520 for (curop = ((LISTOP*)curop)->op_first;
3521 curop; curop = curop->op_sibling)
3523 if (curop->op_type == OP_RV2HV &&
3524 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3525 o->op_private |= OPpASSIGN_HASH;
3529 if (!(left->op_private & OPpLVAL_INTRO)) {
3532 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3533 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3534 if (curop->op_type == OP_GV) {
3535 GV *gv = cGVOPx_gv(curop);
3536 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3538 SvCUR(gv) = PL_generation;
3540 else if (curop->op_type == OP_PADSV ||
3541 curop->op_type == OP_PADAV ||
3542 curop->op_type == OP_PADHV ||
3543 curop->op_type == OP_PADANY) {
3544 SV **svp = AvARRAY(PL_comppad_name);
3545 SV *sv = svp[curop->op_targ];
3546 if (SvCUR(sv) == PL_generation)
3548 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3550 else if (curop->op_type == OP_RV2CV)
3552 else if (curop->op_type == OP_RV2SV ||
3553 curop->op_type == OP_RV2AV ||
3554 curop->op_type == OP_RV2HV ||
3555 curop->op_type == OP_RV2GV) {
3556 if (lastop->op_type != OP_GV) /* funny deref? */
3559 else if (curop->op_type == OP_PUSHRE) {
3560 if (((PMOP*)curop)->op_pmreplroot) {
3562 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3564 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3566 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3568 SvCUR(gv) = PL_generation;
3577 o->op_private |= OPpASSIGN_COMMON;
3579 if (right && right->op_type == OP_SPLIT) {
3581 if ((tmpop = ((LISTOP*)right)->op_first) &&
3582 tmpop->op_type == OP_PUSHRE)
3584 PMOP *pm = (PMOP*)tmpop;
3585 if (left->op_type == OP_RV2AV &&
3586 !(left->op_private & OPpLVAL_INTRO) &&
3587 !(o->op_private & OPpASSIGN_COMMON) )
3589 tmpop = ((UNOP*)left)->op_first;
3590 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3592 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3593 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3595 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3596 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3598 pm->op_pmflags |= PMf_ONCE;
3599 tmpop = cUNOPo->op_first; /* to list (nulled) */
3600 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3601 tmpop->op_sibling = Nullop; /* don't free split */
3602 right->op_next = tmpop->op_next; /* fix starting loc */
3603 op_free(o); /* blow off assign */
3604 right->op_flags &= ~OPf_WANT;
3605 /* "I don't know and I don't care." */
3610 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3611 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3613 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3615 sv_setiv(sv, PL_modcount+1);
3623 right = newOP(OP_UNDEF, 0);
3624 if (right->op_type == OP_READLINE) {
3625 right->op_flags |= OPf_STACKED;
3626 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3629 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3630 o = newBINOP(OP_SASSIGN, flags,
3631 scalar(right), mod(scalar(left), OP_SASSIGN) );
3643 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3645 U32 seq = intro_my();
3648 NewOp(1101, cop, 1, COP);
3649 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3650 cop->op_type = OP_DBSTATE;
3651 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3654 cop->op_type = OP_NEXTSTATE;
3655 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3657 cop->op_flags = flags;
3658 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3660 cop->op_private |= NATIVE_HINTS;
3662 PL_compiling.op_private = cop->op_private;
3663 cop->op_next = (OP*)cop;
3666 cop->cop_label = label;
3667 PL_hints |= HINT_BLOCK_SCOPE;
3670 cop->cop_arybase = PL_curcop->cop_arybase;
3671 if (specialWARN(PL_curcop->cop_warnings))
3672 cop->cop_warnings = PL_curcop->cop_warnings ;
3674 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3675 if (specialCopIO(PL_curcop->cop_io))
3676 cop->cop_io = PL_curcop->cop_io;
3678 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3681 if (PL_copline == NOLINE)
3682 CopLINE_set(cop, CopLINE(PL_curcop));
3684 CopLINE_set(cop, PL_copline);
3685 PL_copline = NOLINE;
3688 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3690 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3692 CopSTASH_set(cop, PL_curstash);
3694 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3695 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3696 if (svp && *svp != &PL_sv_undef ) {
3697 (void)SvIOK_on(*svp);
3698 SvIVX(*svp) = PTR2IV(cop);
3702 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3705 /* "Introduce" my variables to visible status. */
3713 if (! PL_min_intro_pending)
3714 return PL_cop_seqmax;
3716 svp = AvARRAY(PL_comppad_name);
3717 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3718 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3719 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3720 SvNVX(sv) = (NV)PL_cop_seqmax;
3723 PL_min_intro_pending = 0;
3724 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3725 return PL_cop_seqmax++;
3729 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3731 return new_logop(type, flags, &first, &other);
3735 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3739 OP *first = *firstp;
3740 OP *other = *otherp;
3742 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3743 return newBINOP(type, flags, scalar(first), scalar(other));
3745 scalarboolean(first);
3746 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3747 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3748 if (type == OP_AND || type == OP_OR) {
3754 first = *firstp = cUNOPo->op_first;
3756 first->op_next = o->op_next;
3757 cUNOPo->op_first = Nullop;
3761 if (first->op_type == OP_CONST) {
3762 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3763 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3764 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3775 else if (first->op_type == OP_WANTARRAY) {
3781 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3782 OP *k1 = ((UNOP*)first)->op_first;
3783 OP *k2 = k1->op_sibling;
3785 switch (first->op_type)
3788 if (k2 && k2->op_type == OP_READLINE
3789 && (k2->op_flags & OPf_STACKED)
3790 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3792 warnop = k2->op_type;
3797 if (k1->op_type == OP_READDIR
3798 || k1->op_type == OP_GLOB
3799 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3800 || k1->op_type == OP_EACH)
3802 warnop = ((k1->op_type == OP_NULL)
3803 ? k1->op_targ : k1->op_type);
3808 line_t oldline = CopLINE(PL_curcop);
3809 CopLINE_set(PL_curcop, PL_copline);
3810 Perl_warner(aTHX_ WARN_MISC,
3811 "Value of %s%s can be \"0\"; test with defined()",
3813 ((warnop == OP_READLINE || warnop == OP_GLOB)
3814 ? " construct" : "() operator"));
3815 CopLINE_set(PL_curcop, oldline);
3822 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3823 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3825 NewOp(1101, logop, 1, LOGOP);
3827 logop->op_type = type;
3828 logop->op_ppaddr = PL_ppaddr[type];
3829 logop->op_first = first;
3830 logop->op_flags = flags | OPf_KIDS;
3831 logop->op_other = LINKLIST(other);
3832 logop->op_private = 1 | (flags >> 8);
3834 /* establish postfix order */
3835 logop->op_next = LINKLIST(first);
3836 first->op_next = (OP*)logop;
3837 first->op_sibling = other;
3839 o = newUNOP(OP_NULL, 0, (OP*)logop);
3846 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3853 return newLOGOP(OP_AND, 0, first, trueop);
3855 return newLOGOP(OP_OR, 0, first, falseop);
3857 scalarboolean(first);
3858 if (first->op_type == OP_CONST) {
3859 if (SvTRUE(((SVOP*)first)->op_sv)) {
3870 else if (first->op_type == OP_WANTARRAY) {
3874 NewOp(1101, logop, 1, LOGOP);
3875 logop->op_type = OP_COND_EXPR;
3876 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3877 logop->op_first = first;
3878 logop->op_flags = flags | OPf_KIDS;
3879 logop->op_private = 1 | (flags >> 8);
3880 logop->op_other = LINKLIST(trueop);
3881 logop->op_next = LINKLIST(falseop);
3884 /* establish postfix order */
3885 start = LINKLIST(first);
3886 first->op_next = (OP*)logop;
3888 first->op_sibling = trueop;
3889 trueop->op_sibling = falseop;
3890 o = newUNOP(OP_NULL, 0, (OP*)logop);
3892 trueop->op_next = falseop->op_next = o;
3899 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3907 NewOp(1101, range, 1, LOGOP);
3909 range->op_type = OP_RANGE;
3910 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3911 range->op_first = left;
3912 range->op_flags = OPf_KIDS;
3913 leftstart = LINKLIST(left);
3914 range->op_other = LINKLIST(right);
3915 range->op_private = 1 | (flags >> 8);
3917 left->op_sibling = right;
3919 range->op_next = (OP*)range;
3920 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3921 flop = newUNOP(OP_FLOP, 0, flip);
3922 o = newUNOP(OP_NULL, 0, flop);
3924 range->op_next = leftstart;
3926 left->op_next = flip;
3927 right->op_next = flop;
3929 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3930 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3931 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3932 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3934 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3935 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3938 if (!flip->op_private || !flop->op_private)
3939 linklist(o); /* blow off optimizer unless constant */
3945 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3949 int once = block && block->op_flags & OPf_SPECIAL &&
3950 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3953 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3954 return block; /* do {} while 0 does once */
3955 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3956 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3957 expr = newUNOP(OP_DEFINED, 0,
3958 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3959 } else if (expr->op_flags & OPf_KIDS) {
3960 OP *k1 = ((UNOP*)expr)->op_first;
3961 OP *k2 = (k1) ? k1->op_sibling : NULL;
3962 switch (expr->op_type) {
3964 if (k2 && k2->op_type == OP_READLINE
3965 && (k2->op_flags & OPf_STACKED)
3966 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3967 expr = newUNOP(OP_DEFINED, 0, expr);
3971 if (k1->op_type == OP_READDIR
3972 || k1->op_type == OP_GLOB
3973 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3974 || k1->op_type == OP_EACH)
3975 expr = newUNOP(OP_DEFINED, 0, expr);
3981 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3982 o = new_logop(OP_AND, 0, &expr, &listop);
3985 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3987 if (once && o != listop)
3988 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3991 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3993 o->op_flags |= flags;
3995 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4000 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4008 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4009 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4010 expr = newUNOP(OP_DEFINED, 0,
4011 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4012 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4013 OP *k1 = ((UNOP*)expr)->op_first;
4014 OP *k2 = (k1) ? k1->op_sibling : NULL;
4015 switch (expr->op_type) {
4017 if (k2 && k2->op_type == OP_READLINE
4018 && (k2->op_flags & OPf_STACKED)
4019 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4020 expr = newUNOP(OP_DEFINED, 0, expr);
4024 if (k1->op_type == OP_READDIR
4025 || k1->op_type == OP_GLOB
4026 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4027 || k1->op_type == OP_EACH)
4028 expr = newUNOP(OP_DEFINED, 0, expr);
4034 block = newOP(OP_NULL, 0);
4036 block = scope(block);
4040 next = LINKLIST(cont);
4043 OP *unstack = newOP(OP_UNSTACK, 0);
4046 cont = append_elem(OP_LINESEQ, cont, unstack);
4047 if ((line_t)whileline != NOLINE) {
4048 PL_copline = whileline;
4049 cont = append_elem(OP_LINESEQ, cont,
4050 newSTATEOP(0, Nullch, Nullop));
4054 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4055 redo = LINKLIST(listop);
4058 PL_copline = whileline;
4060 o = new_logop(OP_AND, 0, &expr, &listop);
4061 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4062 op_free(expr); /* oops, it's a while (0) */
4064 return Nullop; /* listop already freed by new_logop */
4067 ((LISTOP*)listop)->op_last->op_next =
4068 (o == listop ? redo : LINKLIST(o));
4074 NewOp(1101,loop,1,LOOP);
4075 loop->op_type = OP_ENTERLOOP;
4076 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4077 loop->op_private = 0;
4078 loop->op_next = (OP*)loop;
4081 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4083 loop->op_redoop = redo;
4084 loop->op_lastop = o;
4085 o->op_private |= loopflags;
4088 loop->op_nextop = next;
4090 loop->op_nextop = o;
4092 o->op_flags |= flags;
4093 o->op_private |= (flags >> 8);
4098 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4106 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4107 sv->op_type = OP_RV2GV;
4108 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4110 else if (sv->op_type == OP_PADSV) { /* private variable */
4111 padoff = sv->op_targ;
4116 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4117 padoff = sv->op_targ;
4119 iterflags |= OPf_SPECIAL;
4124 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4127 #ifdef USE_5005THREADS
4128 padoff = find_threadsv("_");
4129 iterflags |= OPf_SPECIAL;
4131 sv = newGVOP(OP_GV, 0, PL_defgv);
4134 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4135 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4136 iterflags |= OPf_STACKED;
4138 else if (expr->op_type == OP_NULL &&
4139 (expr->op_flags & OPf_KIDS) &&
4140 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4142 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4143 * set the STACKED flag to indicate that these values are to be
4144 * treated as min/max values by 'pp_iterinit'.
4146 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4147 LOGOP* range = (LOGOP*) flip->op_first;
4148 OP* left = range->op_first;
4149 OP* right = left->op_sibling;
4152 range->op_flags &= ~OPf_KIDS;
4153 range->op_first = Nullop;
4155 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4156 listop->op_first->op_next = range->op_next;
4157 left->op_next = range->op_other;
4158 right->op_next = (OP*)listop;
4159 listop->op_next = listop->op_first;
4162 expr = (OP*)(listop);
4164 iterflags |= OPf_STACKED;
4167 expr = mod(force_list(expr), OP_GREPSTART);
4171 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4172 append_elem(OP_LIST, expr, scalar(sv))));
4173 assert(!loop->op_next);
4174 #ifdef PL_OP_SLAB_ALLOC
4177 NewOp(1234,tmp,1,LOOP);
4178 Copy(loop,tmp,1,LOOP);
4182 Renew(loop, 1, LOOP);
4184 loop->op_targ = padoff;
4185 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4186 PL_copline = forline;
4187 return newSTATEOP(0, label, wop);
4191 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4196 if (type != OP_GOTO || label->op_type == OP_CONST) {
4197 /* "last()" means "last" */
4198 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4199 o = newOP(type, OPf_SPECIAL);
4201 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4202 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4208 if (label->op_type == OP_ENTERSUB)
4209 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4210 o = newUNOP(type, OPf_STACKED, label);
4212 PL_hints |= HINT_BLOCK_SCOPE;
4217 Perl_cv_undef(pTHX_ CV *cv)
4220 CV *freecv = Nullcv;
4222 #ifdef USE_5005THREADS
4224 MUTEX_DESTROY(CvMUTEXP(cv));
4225 Safefree(CvMUTEXP(cv));
4228 #endif /* USE_5005THREADS */
4231 if (CvFILE(cv) && !CvXSUB(cv)) {
4232 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4233 Safefree(CvFILE(cv));
4238 if (!CvXSUB(cv) && CvROOT(cv)) {
4239 #ifdef USE_5005THREADS
4240 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4241 Perl_croak(aTHX_ "Can't undef active subroutine");
4244 Perl_croak(aTHX_ "Can't undef active subroutine");
4245 #endif /* USE_5005THREADS */
4248 SAVEVPTR(PL_curpad);
4251 op_free(CvROOT(cv));
4252 CvROOT(cv) = Nullop;
4255 SvPOK_off((SV*)cv); /* forget prototype */
4257 outsidecv = CvOUTSIDE(cv);
4258 /* Since closure prototypes have the same lifetime as the containing
4259 * CV, they don't hold a refcount on the outside CV. This avoids
4260 * the refcount loop between the outer CV (which keeps a refcount to
4261 * the closure prototype in the pad entry for pp_anoncode()) and the
4262 * closure prototype, and the ensuing memory leak. --GSAR */
4263 if (!CvANON(cv) || CvCLONED(cv))
4265 CvOUTSIDE(cv) = Nullcv;
4267 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4270 if (CvPADLIST(cv)) {
4271 /* may be during global destruction */
4272 if (SvREFCNT(CvPADLIST(cv))) {
4273 /* inner references to cv must be fixed up */
4274 AV *padlist = CvPADLIST(cv);
4275 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4276 AV *comppad = (AV*)AvARRAY(padlist)[1];
4277 SV **namepad = AvARRAY(comppad_name);
4278 SV **curpad = AvARRAY(comppad);
4280 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4281 SV *namesv = namepad[ix];
4282 if (namesv && namesv != &PL_sv_undef
4283 && *SvPVX(namesv) == '&')
4285 CV *innercv = (CV*)curpad[ix];
4286 if (SvTYPE(innercv) == SVt_PVCV
4287 && CvOUTSIDE(innercv) == cv)
4289 CvOUTSIDE(innercv) = outsidecv;
4290 if (!CvANON(innercv) || CvCLONED(innercv)) {
4291 (void)SvREFCNT_inc(outsidecv);
4299 SvREFCNT_dec(freecv);
4300 ix = AvFILLp(padlist);
4302 SV* sv = AvARRAY(padlist)[ix--];
4305 if (sv == (SV*)PL_comppad_name)
4306 PL_comppad_name = Nullav;
4307 else if (sv == (SV*)PL_comppad) {
4308 PL_comppad = Nullav;
4309 PL_curpad = Null(SV**);
4313 SvREFCNT_dec((SV*)CvPADLIST(cv));
4315 CvPADLIST(cv) = Nullav;
4318 SvREFCNT_dec(freecv);
4325 #ifdef DEBUG_CLOSURES
4327 S_cv_dump(pTHX_ CV *cv)
4330 CV *outside = CvOUTSIDE(cv);
4331 AV* padlist = CvPADLIST(cv);
4338 PerlIO_printf(Perl_debug_log,
4339 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4341 (CvANON(cv) ? "ANON"
4342 : (cv == PL_main_cv) ? "MAIN"
4343 : CvUNIQUE(cv) ? "UNIQUE"
4344 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4347 : CvANON(outside) ? "ANON"
4348 : (outside == PL_main_cv) ? "MAIN"
4349 : CvUNIQUE(outside) ? "UNIQUE"
4350 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4355 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4356 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4357 pname = AvARRAY(pad_name);
4358 ppad = AvARRAY(pad);
4360 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4361 if (SvPOK(pname[ix]))
4362 PerlIO_printf(Perl_debug_log,
4363 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4364 (int)ix, PTR2UV(ppad[ix]),
4365 SvFAKE(pname[ix]) ? "FAKE " : "",
4367 (IV)I_32(SvNVX(pname[ix])),
4370 #endif /* DEBUGGING */
4372 #endif /* DEBUG_CLOSURES */
4375 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4379 AV* protopadlist = CvPADLIST(proto);
4380 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4381 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4382 SV** pname = AvARRAY(protopad_name);
4383 SV** ppad = AvARRAY(protopad);
4384 I32 fname = AvFILLp(protopad_name);
4385 I32 fpad = AvFILLp(protopad);
4389 assert(!CvUNIQUE(proto));
4393 SAVESPTR(PL_comppad_name);
4394 SAVESPTR(PL_compcv);
4396 cv = PL_compcv = (CV*)NEWSV(1104,0);
4397 sv_upgrade((SV *)cv, SvTYPE(proto));
4398 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4401 #ifdef USE_5005THREADS
4402 New(666, CvMUTEXP(cv), 1, perl_mutex);
4403 MUTEX_INIT(CvMUTEXP(cv));
4405 #endif /* USE_5005THREADS */
4407 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4408 : savepv(CvFILE(proto));
4410 CvFILE(cv) = CvFILE(proto);
4412 CvGV(cv) = CvGV(proto);
4413 CvSTASH(cv) = CvSTASH(proto);
4414 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4415 CvSTART(cv) = CvSTART(proto);
4417 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4420 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4422 PL_comppad_name = newAV();
4423 for (ix = fname; ix >= 0; ix--)
4424 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4426 PL_comppad = newAV();
4428 comppadlist = newAV();
4429 AvREAL_off(comppadlist);
4430 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4431 av_store(comppadlist, 1, (SV*)PL_comppad);
4432 CvPADLIST(cv) = comppadlist;
4433 av_fill(PL_comppad, AvFILLp(protopad));
4434 PL_curpad = AvARRAY(PL_comppad);
4436 av = newAV(); /* will be @_ */
4438 av_store(PL_comppad, 0, (SV*)av);
4439 AvFLAGS(av) = AVf_REIFY;
4441 for (ix = fpad; ix > 0; ix--) {
4442 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4443 if (namesv && namesv != &PL_sv_undef) {
4444 char *name = SvPVX(namesv); /* XXX */
4445 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4446 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4447 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4449 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4451 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4453 else { /* our own lexical */
4456 /* anon code -- we'll come back for it */
4457 sv = SvREFCNT_inc(ppad[ix]);
4459 else if (*name == '@')
4461 else if (*name == '%')
4470 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4471 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4474 SV* sv = NEWSV(0,0);
4480 /* Now that vars are all in place, clone nested closures. */
4482 for (ix = fpad; ix > 0; ix--) {
4483 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4485 && namesv != &PL_sv_undef
4486 && !(SvFLAGS(namesv) & SVf_FAKE)
4487 && *SvPVX(namesv) == '&'
4488 && CvCLONE(ppad[ix]))
4490 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4491 SvREFCNT_dec(ppad[ix]);
4494 PL_curpad[ix] = (SV*)kid;
4498 #ifdef DEBUG_CLOSURES
4499 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4501 PerlIO_printf(Perl_debug_log, " from:\n");
4503 PerlIO_printf(Perl_debug_log, " to:\n");
4510 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4512 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4514 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4521 Perl_cv_clone(pTHX_ CV *proto)
4524 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4525 cv = cv_clone2(proto, CvOUTSIDE(proto));
4526 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4531 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4533 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4534 SV* msg = sv_newmortal();
4538 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4539 sv_setpv(msg, "Prototype mismatch:");
4541 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4543 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4544 sv_catpv(msg, " vs ");
4546 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4548 sv_catpv(msg, "none");
4549 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4553 static void const_sv_xsub(pTHX_ CV* cv);
4556 =for apidoc cv_const_sv
4558 If C<cv> is a constant sub eligible for inlining. returns the constant
4559 value returned by the sub. Otherwise, returns NULL.
4561 Constant subs can be created with C<newCONSTSUB> or as described in
4562 L<perlsub/"Constant Functions">.
4567 Perl_cv_const_sv(pTHX_ CV *cv)
4569 if (!cv || !CvCONST(cv))
4571 return (SV*)CvXSUBANY(cv).any_ptr;
4575 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4582 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4583 o = cLISTOPo->op_first->op_sibling;
4585 for (; o; o = o->op_next) {
4586 OPCODE type = o->op_type;
4588 if (sv && o->op_next == o)
4590 if (o->op_next != o) {
4591 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4593 if (type == OP_DBSTATE)
4596 if (type == OP_LEAVESUB || type == OP_RETURN)
4600 if (type == OP_CONST && cSVOPo->op_sv)
4602 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4603 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4604 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4608 /* We get here only from cv_clone2() while creating a closure.
4609 Copy the const value here instead of in cv_clone2 so that
4610 SvREADONLY_on doesn't lead to problems when leaving
4615 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4627 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4637 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4641 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4643 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4647 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4653 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4658 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4659 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4660 SV *sv = sv_newmortal();
4661 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4662 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4667 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4668 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4678 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4679 maximum a prototype before. */
4680 if (SvTYPE(gv) > SVt_NULL) {
4681 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4682 && ckWARN_d(WARN_PROTOTYPE))
4684 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4686 cv_ckproto((CV*)gv, NULL, ps);
4689 sv_setpv((SV*)gv, ps);
4691 sv_setiv((SV*)gv, -1);
4692 SvREFCNT_dec(PL_compcv);
4693 cv = PL_compcv = NULL;
4694 PL_sub_generation++;
4698 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4700 #ifdef GV_UNIQUE_CHECK
4701 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4702 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4706 if (!block || !ps || *ps || attrs)
4709 const_sv = op_const_sv(block, Nullcv);
4712 bool exists = CvROOT(cv) || CvXSUB(cv);
4714 #ifdef GV_UNIQUE_CHECK
4715 if (exists && GvUNIQUE(gv)) {
4716 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4720 /* if the subroutine doesn't exist and wasn't pre-declared
4721 * with a prototype, assume it will be AUTOLOADed,
4722 * skipping the prototype check
4724 if (exists || SvPOK(cv))
4725 cv_ckproto(cv, gv, ps);
4726 /* already defined (or promised)? */
4727 if (exists || GvASSUMECV(gv)) {
4728 if (!block && !attrs) {
4729 /* just a "sub foo;" when &foo is already defined */
4730 SAVEFREESV(PL_compcv);
4733 /* ahem, death to those who redefine active sort subs */
4734 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4735 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4737 if (ckWARN(WARN_REDEFINE)
4739 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4741 line_t oldline = CopLINE(PL_curcop);
4742 if (PL_copline != NOLINE)
4743 CopLINE_set(PL_curcop, PL_copline);
4744 Perl_warner(aTHX_ WARN_REDEFINE,
4745 CvCONST(cv) ? "Constant subroutine %s redefined"
4746 : "Subroutine %s redefined", name);
4747 CopLINE_set(PL_curcop, oldline);
4755 SvREFCNT_inc(const_sv);
4757 assert(!CvROOT(cv) && !CvCONST(cv));
4758 sv_setpv((SV*)cv, ""); /* prototype is "" */
4759 CvXSUBANY(cv).any_ptr = const_sv;
4760 CvXSUB(cv) = const_sv_xsub;
4765 cv = newCONSTSUB(NULL, name, const_sv);
4768 SvREFCNT_dec(PL_compcv);
4770 PL_sub_generation++;
4777 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4778 * before we clobber PL_compcv.
4782 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4783 stash = GvSTASH(CvGV(cv));
4784 else if (CvSTASH(cv))
4785 stash = CvSTASH(cv);
4787 stash = PL_curstash;
4790 /* possibly about to re-define existing subr -- ignore old cv */
4791 rcv = (SV*)PL_compcv;
4792 if (name && GvSTASH(gv))
4793 stash = GvSTASH(gv);
4795 stash = PL_curstash;
4797 apply_attrs(stash, rcv, attrs);
4799 if (cv) { /* must reuse cv if autoloaded */
4801 /* got here with just attrs -- work done, so bug out */
4802 SAVEFREESV(PL_compcv);
4806 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4807 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4808 CvOUTSIDE(PL_compcv) = 0;
4809 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4810 CvPADLIST(PL_compcv) = 0;
4811 /* inner references to PL_compcv must be fixed up ... */
4813 AV *padlist = CvPADLIST(cv);
4814 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4815 AV *comppad = (AV*)AvARRAY(padlist)[1];
4816 SV **namepad = AvARRAY(comppad_name);
4817 SV **curpad = AvARRAY(comppad);
4818 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4819 SV *namesv = namepad[ix];
4820 if (namesv && namesv != &PL_sv_undef
4821 && *SvPVX(namesv) == '&')
4823 CV *innercv = (CV*)curpad[ix];
4824 if (CvOUTSIDE(innercv) == PL_compcv) {
4825 CvOUTSIDE(innercv) = cv;
4826 if (!CvANON(innercv) || CvCLONED(innercv)) {
4827 (void)SvREFCNT_inc(cv);
4828 SvREFCNT_dec(PL_compcv);
4834 /* ... before we throw it away */
4835 SvREFCNT_dec(PL_compcv);
4836 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4837 ++PL_sub_generation;
4844 PL_sub_generation++;
4848 CvFILE_set_from_cop(cv, PL_curcop);
4849 CvSTASH(cv) = PL_curstash;
4850 #ifdef USE_5005THREADS
4852 if (!CvMUTEXP(cv)) {
4853 New(666, CvMUTEXP(cv), 1, perl_mutex);
4854 MUTEX_INIT(CvMUTEXP(cv));
4856 #endif /* USE_5005THREADS */
4859 sv_setpv((SV*)cv, ps);
4861 if (PL_error_count) {
4865 char *s = strrchr(name, ':');
4867 if (strEQ(s, "BEGIN")) {
4869 "BEGIN not safe after errors--compilation aborted";
4870 if (PL_in_eval & EVAL_KEEPERR)
4871 Perl_croak(aTHX_ not_safe);
4873 /* force display of errors found but not reported */
4874 sv_catpv(ERRSV, not_safe);
4875 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4883 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4884 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4887 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4888 mod(scalarseq(block), OP_LEAVESUBLV));
4891 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4893 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4894 OpREFCNT_set(CvROOT(cv), 1);
4895 CvSTART(cv) = LINKLIST(CvROOT(cv));
4896 CvROOT(cv)->op_next = 0;
4897 CALL_PEEP(CvSTART(cv));
4899 /* now that optimizer has done its work, adjust pad values */
4901 SV **namep = AvARRAY(PL_comppad_name);
4902 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4905 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4908 * The only things that a clonable function needs in its
4909 * pad are references to outer lexicals and anonymous subs.
4910 * The rest are created anew during cloning.
4912 if (!((namesv = namep[ix]) != Nullsv &&
4913 namesv != &PL_sv_undef &&
4915 *SvPVX(namesv) == '&')))
4917 SvREFCNT_dec(PL_curpad[ix]);
4918 PL_curpad[ix] = Nullsv;
4921 assert(!CvCONST(cv));
4922 if (ps && !*ps && op_const_sv(block, cv))
4926 AV *av = newAV(); /* Will be @_ */
4928 av_store(PL_comppad, 0, (SV*)av);
4929 AvFLAGS(av) = AVf_REIFY;
4931 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4932 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4934 if (!SvPADMY(PL_curpad[ix]))
4935 SvPADTMP_on(PL_curpad[ix]);
4939 /* If a potential closure prototype, don't keep a refcount on outer CV.
4940 * This is okay as the lifetime of the prototype is tied to the
4941 * lifetime of the outer CV. Avoids memory leak due to reference
4944 SvREFCNT_dec(CvOUTSIDE(cv));
4946 if (name || aname) {
4948 char *tname = (name ? name : aname);
4950 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4951 SV *sv = NEWSV(0,0);
4952 SV *tmpstr = sv_newmortal();
4953 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4957 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4959 (long)PL_subline, (long)CopLINE(PL_curcop));
4960 gv_efullname3(tmpstr, gv, Nullch);
4961 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4962 hv = GvHVn(db_postponed);
4963 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4964 && (pcv = GvCV(db_postponed)))
4970 call_sv((SV*)pcv, G_DISCARD);
4974 if ((s = strrchr(tname,':')))
4979 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4982 if (strEQ(s, "BEGIN")) {
4983 I32 oldscope = PL_scopestack_ix;
4985 SAVECOPFILE(&PL_compiling);
4986 SAVECOPLINE(&PL_compiling);
4989 PL_beginav = newAV();
4990 DEBUG_x( dump_sub(gv) );
4991 av_push(PL_beginav, (SV*)cv);
4992 GvCV(gv) = 0; /* cv has been hijacked */
4993 call_list(oldscope, PL_beginav);
4995 PL_curcop = &PL_compiling;
4996 PL_compiling.op_private = PL_hints;
4999 else if (strEQ(s, "END") && !PL_error_count) {
5002 DEBUG_x( dump_sub(gv) );
5003 av_unshift(PL_endav, 1);
5004 av_store(PL_endav, 0, (SV*)cv);
5005 GvCV(gv) = 0; /* cv has been hijacked */
5007 else if (strEQ(s, "CHECK") && !PL_error_count) {
5009 PL_checkav = newAV();
5010 DEBUG_x( dump_sub(gv) );
5011 if (PL_main_start && ckWARN(WARN_VOID))
5012 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5013 av_unshift(PL_checkav, 1);
5014 av_store(PL_checkav, 0, (SV*)cv);
5015 GvCV(gv) = 0; /* cv has been hijacked */
5017 else if (strEQ(s, "INIT") && !PL_error_count) {
5019 PL_initav = newAV();
5020 DEBUG_x( dump_sub(gv) );
5021 if (PL_main_start && ckWARN(WARN_VOID))
5022 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5023 av_push(PL_initav, (SV*)cv);
5024 GvCV(gv) = 0; /* cv has been hijacked */
5029 PL_copline = NOLINE;
5034 /* XXX unsafe for threads if eval_owner isn't held */
5036 =for apidoc newCONSTSUB
5038 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5039 eligible for inlining at compile-time.
5045 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5051 SAVECOPLINE(PL_curcop);
5052 CopLINE_set(PL_curcop, PL_copline);
5055 PL_hints &= ~HINT_BLOCK_SCOPE;
5058 SAVESPTR(PL_curstash);
5059 SAVECOPSTASH(PL_curcop);
5060 PL_curstash = stash;
5062 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5064 CopSTASH(PL_curcop) = stash;
5068 cv = newXS(name, const_sv_xsub, __FILE__);
5069 CvXSUBANY(cv).any_ptr = sv;
5071 sv_setpv((SV*)cv, ""); /* prototype is "" */
5079 =for apidoc U||newXS
5081 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5087 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5089 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5092 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5094 /* just a cached method */
5098 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5099 /* already defined (or promised) */
5100 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5101 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5102 line_t oldline = CopLINE(PL_curcop);
5103 if (PL_copline != NOLINE)
5104 CopLINE_set(PL_curcop, PL_copline);
5105 Perl_warner(aTHX_ WARN_REDEFINE,
5106 CvCONST(cv) ? "Constant subroutine %s redefined"
5107 : "Subroutine %s redefined"
5109 CopLINE_set(PL_curcop, oldline);
5116 if (cv) /* must reuse cv if autoloaded */
5119 cv = (CV*)NEWSV(1105,0);
5120 sv_upgrade((SV *)cv, SVt_PVCV);
5124 PL_sub_generation++;
5128 #ifdef USE_5005THREADS
5129 New(666, CvMUTEXP(cv), 1, perl_mutex);
5130 MUTEX_INIT(CvMUTEXP(cv));
5132 #endif /* USE_5005THREADS */
5133 (void)gv_fetchfile(filename);
5134 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5135 an external constant string */
5136 CvXSUB(cv) = subaddr;
5139 char *s = strrchr(name,':');
5145 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5148 if (strEQ(s, "BEGIN")) {
5150 PL_beginav = newAV();
5151 av_push(PL_beginav, (SV*)cv);
5152 GvCV(gv) = 0; /* cv has been hijacked */
5154 else if (strEQ(s, "END")) {
5157 av_unshift(PL_endav, 1);
5158 av_store(PL_endav, 0, (SV*)cv);
5159 GvCV(gv) = 0; /* cv has been hijacked */
5161 else if (strEQ(s, "CHECK")) {
5163 PL_checkav = newAV();
5164 if (PL_main_start && ckWARN(WARN_VOID))
5165 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5166 av_unshift(PL_checkav, 1);
5167 av_store(PL_checkav, 0, (SV*)cv);
5168 GvCV(gv) = 0; /* cv has been hijacked */
5170 else if (strEQ(s, "INIT")) {
5172 PL_initav = newAV();
5173 if (PL_main_start && ckWARN(WARN_VOID))
5174 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5175 av_push(PL_initav, (SV*)cv);
5176 GvCV(gv) = 0; /* cv has been hijacked */
5187 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5196 name = SvPVx(cSVOPo->op_sv, n_a);
5199 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5200 #ifdef GV_UNIQUE_CHECK
5202 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5206 if ((cv = GvFORM(gv))) {
5207 if (ckWARN(WARN_REDEFINE)) {
5208 line_t oldline = CopLINE(PL_curcop);
5209 if (PL_copline != NOLINE)
5210 CopLINE_set(PL_curcop, PL_copline);
5211 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5212 CopLINE_set(PL_curcop, oldline);
5219 CvFILE_set_from_cop(cv, PL_curcop);
5221 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5222 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5223 SvPADTMP_on(PL_curpad[ix]);
5226 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5227 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5228 OpREFCNT_set(CvROOT(cv), 1);
5229 CvSTART(cv) = LINKLIST(CvROOT(cv));
5230 CvROOT(cv)->op_next = 0;
5231 CALL_PEEP(CvSTART(cv));
5233 PL_copline = NOLINE;
5238 Perl_newANONLIST(pTHX_ OP *o)
5240 return newUNOP(OP_REFGEN, 0,
5241 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5245 Perl_newANONHASH(pTHX_ OP *o)
5247 return newUNOP(OP_REFGEN, 0,
5248 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5252 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5254 return newANONATTRSUB(floor, proto, Nullop, block);
5258 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5260 return newUNOP(OP_REFGEN, 0,
5261 newSVOP(OP_ANONCODE, 0,
5262 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5266 Perl_oopsAV(pTHX_ OP *o)
5268 switch (o->op_type) {
5270 o->op_type = OP_PADAV;
5271 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5272 return ref(o, OP_RV2AV);
5275 o->op_type = OP_RV2AV;
5276 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5281 if (ckWARN_d(WARN_INTERNAL))
5282 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5289 Perl_oopsHV(pTHX_ OP *o)
5291 switch (o->op_type) {
5294 o->op_type = OP_PADHV;
5295 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5296 return ref(o, OP_RV2HV);
5300 o->op_type = OP_RV2HV;
5301 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5306 if (ckWARN_d(WARN_INTERNAL))
5307 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5314 Perl_newAVREF(pTHX_ OP *o)
5316 if (o->op_type == OP_PADANY) {
5317 o->op_type = OP_PADAV;
5318 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5321 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5322 && ckWARN(WARN_DEPRECATED)) {
5323 Perl_warner(aTHX_ WARN_DEPRECATED,
5324 "Using an array as a reference is deprecated");
5326 return newUNOP(OP_RV2AV, 0, scalar(o));
5330 Perl_newGVREF(pTHX_ I32 type, OP *o)
5332 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5333 return newUNOP(OP_NULL, 0, o);
5334 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5338 Perl_newHVREF(pTHX_ OP *o)
5340 if (o->op_type == OP_PADANY) {
5341 o->op_type = OP_PADHV;
5342 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5345 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5346 && ckWARN(WARN_DEPRECATED)) {
5347 Perl_warner(aTHX_ WARN_DEPRECATED,
5348 "Using a hash as a reference is deprecated");
5350 return newUNOP(OP_RV2HV, 0, scalar(o));
5354 Perl_oopsCV(pTHX_ OP *o)
5356 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5362 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5364 return newUNOP(OP_RV2CV, flags, scalar(o));
5368 Perl_newSVREF(pTHX_ OP *o)
5370 if (o->op_type == OP_PADANY) {
5371 o->op_type = OP_PADSV;
5372 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5375 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5376 o->op_flags |= OPpDONE_SVREF;
5379 return newUNOP(OP_RV2SV, 0, scalar(o));
5382 /* Check routines. */
5385 Perl_ck_anoncode(pTHX_ OP *o)
5390 name = NEWSV(1106,0);
5391 sv_upgrade(name, SVt_PVNV);
5392 sv_setpvn(name, "&", 1);
5395 ix = pad_alloc(o->op_type, SVs_PADMY);
5396 av_store(PL_comppad_name, ix, name);
5397 av_store(PL_comppad, ix, cSVOPo->op_sv);
5398 SvPADMY_on(cSVOPo->op_sv);
5399 cSVOPo->op_sv = Nullsv;
5400 cSVOPo->op_targ = ix;
5405 Perl_ck_bitop(pTHX_ OP *o)
5407 o->op_private = PL_hints;
5412 Perl_ck_concat(pTHX_ OP *o)
5414 if (cUNOPo->op_first->op_type == OP_CONCAT)
5415 o->op_flags |= OPf_STACKED;
5420 Perl_ck_spair(pTHX_ OP *o)
5422 if (o->op_flags & OPf_KIDS) {
5425 OPCODE type = o->op_type;
5426 o = modkids(ck_fun(o), type);
5427 kid = cUNOPo->op_first;
5428 newop = kUNOP->op_first->op_sibling;
5430 (newop->op_sibling ||
5431 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5432 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5433 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5437 op_free(kUNOP->op_first);
5438 kUNOP->op_first = newop;
5440 o->op_ppaddr = PL_ppaddr[++o->op_type];
5445 Perl_ck_delete(pTHX_ OP *o)
5449 if (o->op_flags & OPf_KIDS) {
5450 OP *kid = cUNOPo->op_first;
5451 switch (kid->op_type) {
5453 o->op_flags |= OPf_SPECIAL;
5456 o->op_private |= OPpSLICE;
5459 o->op_flags |= OPf_SPECIAL;
5464 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5473 Perl_ck_die(pTHX_ OP *o)
5476 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5482 Perl_ck_eof(pTHX_ OP *o)
5484 I32 type = o->op_type;
5486 if (o->op_flags & OPf_KIDS) {
5487 if (cLISTOPo->op_first->op_type == OP_STUB) {
5489 o = newUNOP(type, OPf_SPECIAL,
5490 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5498 Perl_ck_eval(pTHX_ OP *o)
5500 PL_hints |= HINT_BLOCK_SCOPE;
5501 if (o->op_flags & OPf_KIDS) {
5502 SVOP *kid = (SVOP*)cUNOPo->op_first;
5505 o->op_flags &= ~OPf_KIDS;
5508 else if (kid->op_type == OP_LINESEQ) {
5511 kid->op_next = o->op_next;
5512 cUNOPo->op_first = 0;
5515 NewOp(1101, enter, 1, LOGOP);
5516 enter->op_type = OP_ENTERTRY;
5517 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5518 enter->op_private = 0;
5520 /* establish postfix order */
5521 enter->op_next = (OP*)enter;
5523 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5524 o->op_type = OP_LEAVETRY;
5525 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5526 enter->op_other = o;
5534 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5536 o->op_targ = (PADOFFSET)PL_hints;
5541 Perl_ck_exit(pTHX_ OP *o)
5544 HV *table = GvHV(PL_hintgv);
5546 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5547 if (svp && *svp && SvTRUE(*svp))
5548 o->op_private |= OPpEXIT_VMSISH;
5550 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5556 Perl_ck_exec(pTHX_ OP *o)
5559 if (o->op_flags & OPf_STACKED) {
5561 kid = cUNOPo->op_first->op_sibling;
5562 if (kid->op_type == OP_RV2GV)
5571 Perl_ck_exists(pTHX_ OP *o)
5574 if (o->op_flags & OPf_KIDS) {
5575 OP *kid = cUNOPo->op_first;
5576 if (kid->op_type == OP_ENTERSUB) {
5577 (void) ref(kid, o->op_type);
5578 if (kid->op_type != OP_RV2CV && !PL_error_count)
5579 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5581 o->op_private |= OPpEXISTS_SUB;
5583 else if (kid->op_type == OP_AELEM)
5584 o->op_flags |= OPf_SPECIAL;
5585 else if (kid->op_type != OP_HELEM)
5586 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5595 Perl_ck_gvconst(pTHX_ register OP *o)
5597 o = fold_constants(o);
5598 if (o->op_type == OP_CONST)
5605 Perl_ck_rvconst(pTHX_ register OP *o)
5607 SVOP *kid = (SVOP*)cUNOPo->op_first;
5609 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5610 if (kid->op_type == OP_CONST) {
5614 SV *kidsv = kid->op_sv;
5617 /* Is it a constant from cv_const_sv()? */
5618 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5619 SV *rsv = SvRV(kidsv);
5620 int svtype = SvTYPE(rsv);
5621 char *badtype = Nullch;
5623 switch (o->op_type) {
5625 if (svtype > SVt_PVMG)
5626 badtype = "a SCALAR";
5629 if (svtype != SVt_PVAV)
5630 badtype = "an ARRAY";
5633 if (svtype != SVt_PVHV) {
5634 if (svtype == SVt_PVAV) { /* pseudohash? */
5635 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5636 if (ksv && SvROK(*ksv)
5637 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5646 if (svtype != SVt_PVCV)
5651 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5654 name = SvPV(kidsv, n_a);
5655 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5656 char *badthing = Nullch;
5657 switch (o->op_type) {
5659 badthing = "a SCALAR";
5662 badthing = "an ARRAY";
5665 badthing = "a HASH";
5670 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5674 * This is a little tricky. We only want to add the symbol if we
5675 * didn't add it in the lexer. Otherwise we get duplicate strict
5676 * warnings. But if we didn't add it in the lexer, we must at
5677 * least pretend like we wanted to add it even if it existed before,
5678 * or we get possible typo warnings. OPpCONST_ENTERED says
5679 * whether the lexer already added THIS instance of this symbol.
5681 iscv = (o->op_type == OP_RV2CV) * 2;
5683 gv = gv_fetchpv(name,
5684 iscv | !(kid->op_private & OPpCONST_ENTERED),
5687 : o->op_type == OP_RV2SV
5689 : o->op_type == OP_RV2AV
5691 : o->op_type == OP_RV2HV
5694 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5696 kid->op_type = OP_GV;
5697 SvREFCNT_dec(kid->op_sv);
5699 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5700 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5701 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5703 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5705 kid->op_sv = SvREFCNT_inc(gv);
5707 kid->op_private = 0;
5708 kid->op_ppaddr = PL_ppaddr[OP_GV];
5715 Perl_ck_ftst(pTHX_ OP *o)
5717 I32 type = o->op_type;
5719 if (o->op_flags & OPf_REF) {
5722 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5723 SVOP *kid = (SVOP*)cUNOPo->op_first;
5725 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5727 OP *newop = newGVOP(type, OPf_REF,
5728 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5735 if (type == OP_FTTTY)
5736 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5739 o = newUNOP(type, 0, newDEFSVOP());
5745 Perl_ck_fun(pTHX_ OP *o)
5751 int type = o->op_type;
5752 register I32 oa = PL_opargs[type] >> OASHIFT;
5754 if (o->op_flags & OPf_STACKED) {
5755 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5758 return no_fh_allowed(o);
5761 if (o->op_flags & OPf_KIDS) {
5763 tokid = &cLISTOPo->op_first;
5764 kid = cLISTOPo->op_first;
5765 if (kid->op_type == OP_PUSHMARK ||
5766 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5768 tokid = &kid->op_sibling;
5769 kid = kid->op_sibling;
5771 if (!kid && PL_opargs[type] & OA_DEFGV)
5772 *tokid = kid = newDEFSVOP();
5776 sibl = kid->op_sibling;
5779 /* list seen where single (scalar) arg expected? */
5780 if (numargs == 1 && !(oa >> 4)
5781 && kid->op_type == OP_LIST && type != OP_SCALAR)
5783 return too_many_arguments(o,PL_op_desc[type]);
5796 if ((type == OP_PUSH || type == OP_UNSHIFT)
5797 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5798 Perl_warner(aTHX_ WARN_SYNTAX,
5799 "Useless use of %s with no values",
5802 if (kid->op_type == OP_CONST &&
5803 (kid->op_private & OPpCONST_BARE))
5805 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5806 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5807 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5808 if (ckWARN(WARN_DEPRECATED))
5809 Perl_warner(aTHX_ WARN_DEPRECATED,
5810 "Array @%s missing the @ in argument %"IVdf" of %s()",
5811 name, (IV)numargs, PL_op_desc[type]);
5814 kid->op_sibling = sibl;
5817 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5818 bad_type(numargs, "array", PL_op_desc[type], kid);
5822 if (kid->op_type == OP_CONST &&
5823 (kid->op_private & OPpCONST_BARE))
5825 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5826 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5827 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5828 if (ckWARN(WARN_DEPRECATED))
5829 Perl_warner(aTHX_ WARN_DEPRECATED,
5830 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5831 name, (IV)numargs, PL_op_desc[type]);
5834 kid->op_sibling = sibl;
5837 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5838 bad_type(numargs, "hash", PL_op_desc[type], kid);
5843 OP *newop = newUNOP(OP_NULL, 0, kid);
5844 kid->op_sibling = 0;
5846 newop->op_next = newop;
5848 kid->op_sibling = sibl;
5853 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5854 if (kid->op_type == OP_CONST &&
5855 (kid->op_private & OPpCONST_BARE))
5857 OP *newop = newGVOP(OP_GV, 0,
5858 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5863 else if (kid->op_type == OP_READLINE) {
5864 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5865 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5868 I32 flags = OPf_SPECIAL;
5872 /* is this op a FH constructor? */
5873 if (is_handle_constructor(o,numargs)) {
5874 char *name = Nullch;
5878 /* Set a flag to tell rv2gv to vivify
5879 * need to "prove" flag does not mean something
5880 * else already - NI-S 1999/05/07
5883 if (kid->op_type == OP_PADSV) {
5884 SV **namep = av_fetch(PL_comppad_name,
5886 if (namep && *namep)
5887 name = SvPV(*namep, len);
5889 else if (kid->op_type == OP_RV2SV
5890 && kUNOP->op_first->op_type == OP_GV)
5892 GV *gv = cGVOPx_gv(kUNOP->op_first);
5894 len = GvNAMELEN(gv);
5896 else if (kid->op_type == OP_AELEM
5897 || kid->op_type == OP_HELEM)
5899 name = "__ANONIO__";
5905 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5906 namesv = PL_curpad[targ];
5907 (void)SvUPGRADE(namesv, SVt_PV);
5909 sv_setpvn(namesv, "$", 1);
5910 sv_catpvn(namesv, name, len);
5913 kid->op_sibling = 0;
5914 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5915 kid->op_targ = targ;
5916 kid->op_private |= priv;
5918 kid->op_sibling = sibl;
5924 mod(scalar(kid), type);
5928 tokid = &kid->op_sibling;
5929 kid = kid->op_sibling;
5931 o->op_private |= numargs;
5933 return too_many_arguments(o,OP_DESC(o));
5936 else if (PL_opargs[type] & OA_DEFGV) {
5938 return newUNOP(type, 0, newDEFSVOP());
5942 while (oa & OA_OPTIONAL)
5944 if (oa && oa != OA_LIST)
5945 return too_few_arguments(o,OP_DESC(o));
5951 Perl_ck_glob(pTHX_ OP *o)
5956 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5957 append_elem(OP_GLOB, o, newDEFSVOP());
5959 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5960 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5962 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5965 #if !defined(PERL_EXTERNAL_GLOB)
5966 /* XXX this can be tightened up and made more failsafe. */
5970 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5972 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5973 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5974 GvCV(gv) = GvCV(glob_gv);
5975 SvREFCNT_inc((SV*)GvCV(gv));
5976 GvIMPORTED_CV_on(gv);
5979 #endif /* PERL_EXTERNAL_GLOB */
5981 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5982 append_elem(OP_GLOB, o,
5983 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5984 o->op_type = OP_LIST;
5985 o->op_ppaddr = PL_ppaddr[OP_LIST];
5986 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5987 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5988 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5989 append_elem(OP_LIST, o,
5990 scalar(newUNOP(OP_RV2CV, 0,
5991 newGVOP(OP_GV, 0, gv)))));
5992 o = newUNOP(OP_NULL, 0, ck_subr(o));
5993 o->op_targ = OP_GLOB; /* hint at what it used to be */
5996 gv = newGVgen("main");
5998 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6004 Perl_ck_grep(pTHX_ OP *o)
6008 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6010 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6011 NewOp(1101, gwop, 1, LOGOP);
6013 if (o->op_flags & OPf_STACKED) {
6016 kid = cLISTOPo->op_first->op_sibling;
6017 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6020 kid->op_next = (OP*)gwop;
6021 o->op_flags &= ~OPf_STACKED;
6023 kid = cLISTOPo->op_first->op_sibling;
6024 if (type == OP_MAPWHILE)
6031 kid = cLISTOPo->op_first->op_sibling;
6032 if (kid->op_type != OP_NULL)
6033 Perl_croak(aTHX_ "panic: ck_grep");
6034 kid = kUNOP->op_first;
6036 gwop->op_type = type;
6037 gwop->op_ppaddr = PL_ppaddr[type];
6038 gwop->op_first = listkids(o);
6039 gwop->op_flags |= OPf_KIDS;
6040 gwop->op_private = 1;
6041 gwop->op_other = LINKLIST(kid);
6042 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6043 kid->op_next = (OP*)gwop;
6045 kid = cLISTOPo->op_first->op_sibling;
6046 if (!kid || !kid->op_sibling)
6047 return too_few_arguments(o,OP_DESC(o));
6048 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6049 mod(kid, OP_GREPSTART);
6055 Perl_ck_index(pTHX_ OP *o)
6057 if (o->op_flags & OPf_KIDS) {
6058 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6060 kid = kid->op_sibling; /* get past "big" */
6061 if (kid && kid->op_type == OP_CONST)
6062 fbm_compile(((SVOP*)kid)->op_sv, 0);
6068 Perl_ck_lengthconst(pTHX_ OP *o)
6070 /* XXX length optimization goes here */
6075 Perl_ck_lfun(pTHX_ OP *o)
6077 OPCODE type = o->op_type;
6078 return modkids(ck_fun(o), type);
6082 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6084 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6085 switch (cUNOPo->op_first->op_type) {
6087 /* This is needed for
6088 if (defined %stash::)
6089 to work. Do not break Tk.
6091 break; /* Globals via GV can be undef */
6093 case OP_AASSIGN: /* Is this a good idea? */
6094 Perl_warner(aTHX_ WARN_DEPRECATED,
6095 "defined(@array) is deprecated");
6096 Perl_warner(aTHX_ WARN_DEPRECATED,
6097 "\t(Maybe you should just omit the defined()?)\n");
6100 /* This is needed for
6101 if (defined %stash::)
6102 to work. Do not break Tk.
6104 break; /* Globals via GV can be undef */
6106 Perl_warner(aTHX_ WARN_DEPRECATED,
6107 "defined(%%hash) is deprecated");
6108 Perl_warner(aTHX_ WARN_DEPRECATED,
6109 "\t(Maybe you should just omit the defined()?)\n");
6120 Perl_ck_rfun(pTHX_ OP *o)
6122 OPCODE type = o->op_type;
6123 return refkids(ck_fun(o), type);
6127 Perl_ck_listiob(pTHX_ OP *o)
6131 kid = cLISTOPo->op_first;
6134 kid = cLISTOPo->op_first;
6136 if (kid->op_type == OP_PUSHMARK)
6137 kid = kid->op_sibling;
6138 if (kid && o->op_flags & OPf_STACKED)
6139 kid = kid->op_sibling;
6140 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6141 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6142 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6143 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6144 cLISTOPo->op_first->op_sibling = kid;
6145 cLISTOPo->op_last = kid;
6146 kid = kid->op_sibling;
6151 append_elem(o->op_type, o, newDEFSVOP());
6157 Perl_ck_sassign(pTHX_ OP *o)
6159 OP *kid = cLISTOPo->op_first;
6160 /* has a disposable target? */
6161 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6162 && !(kid->op_flags & OPf_STACKED)
6163 /* Cannot steal the second time! */
6164 && !(kid->op_private & OPpTARGET_MY))
6166 OP *kkid = kid->op_sibling;
6168 /* Can just relocate the target. */
6169 if (kkid && kkid->op_type == OP_PADSV
6170 && !(kkid->op_private & OPpLVAL_INTRO))
6172 kid->op_targ = kkid->op_targ;
6174 /* Now we do not need PADSV and SASSIGN. */
6175 kid->op_sibling = o->op_sibling; /* NULL */
6176 cLISTOPo->op_first = NULL;
6179 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6187 Perl_ck_match(pTHX_ OP *o)
6189 o->op_private |= OPpRUNTIME;
6194 Perl_ck_method(pTHX_ OP *o)
6196 OP *kid = cUNOPo->op_first;
6197 if (kid->op_type == OP_CONST) {
6198 SV* sv = kSVOP->op_sv;
6199 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6201 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6202 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6205 kSVOP->op_sv = Nullsv;
6207 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6216 Perl_ck_null(pTHX_ OP *o)
6222 Perl_ck_open(pTHX_ OP *o)
6224 HV *table = GvHV(PL_hintgv);
6228 svp = hv_fetch(table, "open_IN", 7, FALSE);
6230 mode = mode_from_discipline(*svp);
6231 if (mode & O_BINARY)
6232 o->op_private |= OPpOPEN_IN_RAW;
6233 else if (mode & O_TEXT)
6234 o->op_private |= OPpOPEN_IN_CRLF;
6237 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6239 mode = mode_from_discipline(*svp);
6240 if (mode & O_BINARY)
6241 o->op_private |= OPpOPEN_OUT_RAW;
6242 else if (mode & O_TEXT)
6243 o->op_private |= OPpOPEN_OUT_CRLF;
6246 if (o->op_type == OP_BACKTICK)
6252 Perl_ck_repeat(pTHX_ OP *o)
6254 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6255 o->op_private |= OPpREPEAT_DOLIST;
6256 cBINOPo->op_first = force_list(cBINOPo->op_first);
6264 Perl_ck_require(pTHX_ OP *o)
6268 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6269 SVOP *kid = (SVOP*)cUNOPo->op_first;
6271 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6273 for (s = SvPVX(kid->op_sv); *s; s++) {
6274 if (*s == ':' && s[1] == ':') {
6276 Move(s+2, s+1, strlen(s+2)+1, char);
6277 --SvCUR(kid->op_sv);
6280 if (SvREADONLY(kid->op_sv)) {
6281 SvREADONLY_off(kid->op_sv);
6282 sv_catpvn(kid->op_sv, ".pm", 3);
6283 SvREADONLY_on(kid->op_sv);
6286 sv_catpvn(kid->op_sv, ".pm", 3);
6290 /* handle override, if any */
6291 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6292 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6293 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6295 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6296 OP *kid = cUNOPo->op_first;
6297 cUNOPo->op_first = 0;
6299 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6300 append_elem(OP_LIST, kid,
6301 scalar(newUNOP(OP_RV2CV, 0,
6310 Perl_ck_return(pTHX_ OP *o)
6313 if (CvLVALUE(PL_compcv)) {
6314 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6315 mod(kid, OP_LEAVESUBLV);
6322 Perl_ck_retarget(pTHX_ OP *o)
6324 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6331 Perl_ck_select(pTHX_ OP *o)
6334 if (o->op_flags & OPf_KIDS) {
6335 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6336 if (kid && kid->op_sibling) {
6337 o->op_type = OP_SSELECT;
6338 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6340 return fold_constants(o);
6344 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6345 if (kid && kid->op_type == OP_RV2GV)
6346 kid->op_private &= ~HINT_STRICT_REFS;
6351 Perl_ck_shift(pTHX_ OP *o)
6353 I32 type = o->op_type;
6355 if (!(o->op_flags & OPf_KIDS)) {
6359 #ifdef USE_5005THREADS
6360 if (!CvUNIQUE(PL_compcv)) {
6361 argop = newOP(OP_PADAV, OPf_REF);
6362 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6365 argop = newUNOP(OP_RV2AV, 0,
6366 scalar(newGVOP(OP_GV, 0,
6367 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6370 argop = newUNOP(OP_RV2AV, 0,
6371 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6372 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6373 #endif /* USE_5005THREADS */
6374 return newUNOP(type, 0, scalar(argop));
6376 return scalar(modkids(ck_fun(o), type));
6380 Perl_ck_sort(pTHX_ OP *o)
6384 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6386 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6387 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6389 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6391 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6393 if (kid->op_type == OP_SCOPE) {
6397 else if (kid->op_type == OP_LEAVE) {
6398 if (o->op_type == OP_SORT) {
6399 op_null(kid); /* wipe out leave */
6402 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6403 if (k->op_next == kid)
6405 /* don't descend into loops */
6406 else if (k->op_type == OP_ENTERLOOP
6407 || k->op_type == OP_ENTERITER)
6409 k = cLOOPx(k)->op_lastop;
6414 kid->op_next = 0; /* just disconnect the leave */
6415 k = kLISTOP->op_first;
6420 if (o->op_type == OP_SORT) {
6421 /* provide scalar context for comparison function/block */
6427 o->op_flags |= OPf_SPECIAL;
6429 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6432 firstkid = firstkid->op_sibling;
6435 /* provide list context for arguments */
6436 if (o->op_type == OP_SORT)
6443 S_simplify_sort(pTHX_ OP *o)
6445 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6449 if (!(o->op_flags & OPf_STACKED))
6451 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6452 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6453 kid = kUNOP->op_first; /* get past null */
6454 if (kid->op_type != OP_SCOPE)
6456 kid = kLISTOP->op_last; /* get past scope */
6457 switch(kid->op_type) {
6465 k = kid; /* remember this node*/
6466 if (kBINOP->op_first->op_type != OP_RV2SV)
6468 kid = kBINOP->op_first; /* get past cmp */
6469 if (kUNOP->op_first->op_type != OP_GV)
6471 kid = kUNOP->op_first; /* get past rv2sv */
6473 if (GvSTASH(gv) != PL_curstash)
6475 if (strEQ(GvNAME(gv), "a"))
6477 else if (strEQ(GvNAME(gv), "b"))
6481 kid = k; /* back to cmp */
6482 if (kBINOP->op_last->op_type != OP_RV2SV)
6484 kid = kBINOP->op_last; /* down to 2nd arg */
6485 if (kUNOP->op_first->op_type != OP_GV)
6487 kid = kUNOP->op_first; /* get past rv2sv */
6489 if (GvSTASH(gv) != PL_curstash
6491 ? strNE(GvNAME(gv), "a")
6492 : strNE(GvNAME(gv), "b")))
6494 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6496 o->op_private |= OPpSORT_REVERSE;
6497 if (k->op_type == OP_NCMP)
6498 o->op_private |= OPpSORT_NUMERIC;
6499 if (k->op_type == OP_I_NCMP)
6500 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6501 kid = cLISTOPo->op_first->op_sibling;
6502 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6503 op_free(kid); /* then delete it */
6507 Perl_ck_split(pTHX_ OP *o)
6511 if (o->op_flags & OPf_STACKED)
6512 return no_fh_allowed(o);
6514 kid = cLISTOPo->op_first;
6515 if (kid->op_type != OP_NULL)
6516 Perl_croak(aTHX_ "panic: ck_split");
6517 kid = kid->op_sibling;
6518 op_free(cLISTOPo->op_first);
6519 cLISTOPo->op_first = kid;
6521 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6522 cLISTOPo->op_last = kid; /* There was only one element previously */
6525 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6526 OP *sibl = kid->op_sibling;
6527 kid->op_sibling = 0;
6528 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6529 if (cLISTOPo->op_first == cLISTOPo->op_last)
6530 cLISTOPo->op_last = kid;
6531 cLISTOPo->op_first = kid;
6532 kid->op_sibling = sibl;
6535 kid->op_type = OP_PUSHRE;
6536 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6539 if (!kid->op_sibling)
6540 append_elem(OP_SPLIT, o, newDEFSVOP());
6542 kid = kid->op_sibling;
6545 if (!kid->op_sibling)
6546 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6548 kid = kid->op_sibling;
6551 if (kid->op_sibling)
6552 return too_many_arguments(o,OP_DESC(o));
6558 Perl_ck_join(pTHX_ OP *o)
6560 if (ckWARN(WARN_SYNTAX)) {
6561 OP *kid = cLISTOPo->op_first->op_sibling;
6562 if (kid && kid->op_type == OP_MATCH) {
6563 char *pmstr = "STRING";
6564 if (PM_GETRE(kPMOP))
6565 pmstr = PM_GETRE(kPMOP)->precomp;
6566 Perl_warner(aTHX_ WARN_SYNTAX,
6567 "/%s/ should probably be written as \"%s\"",
6575 Perl_ck_subr(pTHX_ OP *o)
6577 OP *prev = ((cUNOPo->op_first->op_sibling)
6578 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6579 OP *o2 = prev->op_sibling;
6586 I32 contextclass = 0;
6590 o->op_private |= OPpENTERSUB_HASTARG;
6591 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6592 if (cvop->op_type == OP_RV2CV) {
6594 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6595 op_null(cvop); /* disable rv2cv */
6596 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6597 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6598 GV *gv = cGVOPx_gv(tmpop);
6601 tmpop->op_private |= OPpEARLY_CV;
6602 else if (SvPOK(cv)) {
6603 namegv = CvANON(cv) ? gv : CvGV(cv);
6604 proto = SvPV((SV*)cv, n_a);
6608 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6609 if (o2->op_type == OP_CONST)
6610 o2->op_private &= ~OPpCONST_STRICT;
6611 else if (o2->op_type == OP_LIST) {
6612 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6613 if (o && o->op_type == OP_CONST)
6614 o->op_private &= ~OPpCONST_STRICT;
6617 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6618 if (PERLDB_SUB && PL_curstash != PL_debstash)
6619 o->op_private |= OPpENTERSUB_DB;
6620 while (o2 != cvop) {
6624 return too_many_arguments(o, gv_ename(namegv));
6642 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6644 arg == 1 ? "block or sub {}" : "sub {}",
6645 gv_ename(namegv), o2);
6648 /* '*' allows any scalar type, including bareword */
6651 if (o2->op_type == OP_RV2GV)
6652 goto wrapref; /* autoconvert GLOB -> GLOBref */
6653 else if (o2->op_type == OP_CONST)
6654 o2->op_private &= ~OPpCONST_STRICT;
6655 else if (o2->op_type == OP_ENTERSUB) {
6656 /* accidental subroutine, revert to bareword */
6657 OP *gvop = ((UNOP*)o2)->op_first;
6658 if (gvop && gvop->op_type == OP_NULL) {
6659 gvop = ((UNOP*)gvop)->op_first;
6661 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6664 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6665 (gvop = ((UNOP*)gvop)->op_first) &&
6666 gvop->op_type == OP_GV)
6668 GV *gv = cGVOPx_gv(gvop);
6669 OP *sibling = o2->op_sibling;
6670 SV *n = newSVpvn("",0);
6672 gv_fullname3(n, gv, "");
6673 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6674 sv_chop(n, SvPVX(n)+6);
6675 o2 = newSVOP(OP_CONST, 0, n);
6676 prev->op_sibling = o2;
6677 o2->op_sibling = sibling;
6693 if (contextclass++ == 0) {
6694 e = strchr(proto, ']');
6695 if (!e || e == proto)
6709 if (o2->op_type == OP_RV2GV)
6712 bad_type(arg, "symbol", gv_ename(namegv), o2);
6715 if (o2->op_type == OP_ENTERSUB)
6718 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6721 if (o2->op_type == OP_RV2SV ||
6722 o2->op_type == OP_PADSV ||
6723 o2->op_type == OP_HELEM ||
6724 o2->op_type == OP_AELEM ||
6725 o2->op_type == OP_THREADSV)
6728 bad_type(arg, "scalar", gv_ename(namegv), o2);
6731 if (o2->op_type == OP_RV2AV ||
6732 o2->op_type == OP_PADAV)
6735 bad_type(arg, "array", gv_ename(namegv), o2);
6738 if (o2->op_type == OP_RV2HV ||
6739 o2->op_type == OP_PADHV)
6742 bad_type(arg, "hash", gv_ename(namegv), o2);
6747 OP* sib = kid->op_sibling;
6748 kid->op_sibling = 0;
6749 o2 = newUNOP(OP_REFGEN, 0, kid);
6750 o2->op_sibling = sib;
6751 prev->op_sibling = o2;
6753 if (contextclass && e) {
6768 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6769 gv_ename(namegv), SvPV((SV*)cv, n_a));
6774 mod(o2, OP_ENTERSUB);
6776 o2 = o2->op_sibling;
6778 if (proto && !optional &&
6779 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6780 return too_few_arguments(o, gv_ename(namegv));
6785 Perl_ck_svconst(pTHX_ OP *o)
6787 SvREADONLY_on(cSVOPo->op_sv);
6792 Perl_ck_trunc(pTHX_ OP *o)
6794 if (o->op_flags & OPf_KIDS) {
6795 SVOP *kid = (SVOP*)cUNOPo->op_first;
6797 if (kid->op_type == OP_NULL)
6798 kid = (SVOP*)kid->op_sibling;
6799 if (kid && kid->op_type == OP_CONST &&
6800 (kid->op_private & OPpCONST_BARE))
6802 o->op_flags |= OPf_SPECIAL;
6803 kid->op_private &= ~OPpCONST_STRICT;
6810 Perl_ck_substr(pTHX_ OP *o)
6813 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6814 OP *kid = cLISTOPo->op_first;
6816 if (kid->op_type == OP_NULL)
6817 kid = kid->op_sibling;
6819 kid->op_flags |= OPf_MOD;
6825 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6828 Perl_peep(pTHX_ register OP *o)
6830 register OP* oldop = 0;
6833 if (!o || o->op_seq)
6837 SAVEVPTR(PL_curcop);
6838 for (; o; o = o->op_next) {
6844 switch (o->op_type) {
6848 PL_curcop = ((COP*)o); /* for warnings */
6849 o->op_seq = PL_op_seqmax++;
6853 if (cSVOPo->op_private & OPpCONST_STRICT)
6854 no_bareword_allowed(o);
6856 /* Relocate sv to the pad for thread safety.
6857 * Despite being a "constant", the SV is written to,
6858 * for reference counts, sv_upgrade() etc. */
6860 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6861 if (SvPADTMP(cSVOPo->op_sv)) {
6862 /* If op_sv is already a PADTMP then it is being used by
6863 * some pad, so make a copy. */
6864 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6865 SvREADONLY_on(PL_curpad[ix]);
6866 SvREFCNT_dec(cSVOPo->op_sv);
6869 SvREFCNT_dec(PL_curpad[ix]);
6870 SvPADTMP_on(cSVOPo->op_sv);
6871 PL_curpad[ix] = cSVOPo->op_sv;
6872 /* XXX I don't know how this isn't readonly already. */
6873 SvREADONLY_on(PL_curpad[ix]);
6875 cSVOPo->op_sv = Nullsv;
6879 o->op_seq = PL_op_seqmax++;
6883 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6884 if (o->op_next->op_private & OPpTARGET_MY) {
6885 if (o->op_flags & OPf_STACKED) /* chained concats */
6886 goto ignore_optimization;
6888 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6889 o->op_targ = o->op_next->op_targ;
6890 o->op_next->op_targ = 0;
6891 o->op_private |= OPpTARGET_MY;
6894 op_null(o->op_next);
6896 ignore_optimization:
6897 o->op_seq = PL_op_seqmax++;
6900 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6901 o->op_seq = PL_op_seqmax++;
6902 break; /* Scalar stub must produce undef. List stub is noop */
6906 if (o->op_targ == OP_NEXTSTATE
6907 || o->op_targ == OP_DBSTATE
6908 || o->op_targ == OP_SETSTATE)
6910 PL_curcop = ((COP*)o);
6912 /* XXX: We avoid setting op_seq here to prevent later calls
6913 to peep() from mistakenly concluding that optimisation
6914 has already occurred. This doesn't fix the real problem,
6915 though (See 20010220.007). AMS 20010719 */
6916 if (oldop && o->op_next) {
6917 oldop->op_next = o->op_next;
6925 if (oldop && o->op_next) {
6926 oldop->op_next = o->op_next;
6929 o->op_seq = PL_op_seqmax++;
6933 if (o->op_next->op_type == OP_RV2SV) {
6934 if (!(o->op_next->op_private & OPpDEREF)) {
6935 op_null(o->op_next);
6936 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6938 o->op_next = o->op_next->op_next;
6939 o->op_type = OP_GVSV;
6940 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6943 else if (o->op_next->op_type == OP_RV2AV) {
6944 OP* pop = o->op_next->op_next;
6946 if (pop->op_type == OP_CONST &&
6947 (PL_op = pop->op_next) &&
6948 pop->op_next->op_type == OP_AELEM &&
6949 !(pop->op_next->op_private &
6950 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6951 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6956 op_null(o->op_next);
6957 op_null(pop->op_next);
6959 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6960 o->op_next = pop->op_next->op_next;
6961 o->op_type = OP_AELEMFAST;
6962 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6963 o->op_private = (U8)i;
6968 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6970 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6971 /* XXX could check prototype here instead of just carping */
6972 SV *sv = sv_newmortal();
6973 gv_efullname3(sv, gv, Nullch);
6974 Perl_warner(aTHX_ WARN_PROTOTYPE,
6975 "%s() called too early to check prototype",
6979 else if (o->op_next->op_type == OP_READLINE
6980 && o->op_next->op_next->op_type == OP_CONCAT
6981 && (o->op_next->op_next->op_flags & OPf_STACKED))
6983 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6984 o->op_type = OP_RCATLINE;
6985 o->op_flags |= OPf_STACKED;
6986 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6987 op_null(o->op_next->op_next);
6988 op_null(o->op_next);
6991 o->op_seq = PL_op_seqmax++;
7002 o->op_seq = PL_op_seqmax++;
7003 while (cLOGOP->op_other->op_type == OP_NULL)
7004 cLOGOP->op_other = cLOGOP->op_other->op_next;
7005 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7010 o->op_seq = PL_op_seqmax++;
7011 while (cLOOP->op_redoop->op_type == OP_NULL)
7012 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7013 peep(cLOOP->op_redoop);
7014 while (cLOOP->op_nextop->op_type == OP_NULL)
7015 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7016 peep(cLOOP->op_nextop);
7017 while (cLOOP->op_lastop->op_type == OP_NULL)
7018 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7019 peep(cLOOP->op_lastop);
7025 o->op_seq = PL_op_seqmax++;
7026 while (cPMOP->op_pmreplstart &&
7027 cPMOP->op_pmreplstart->op_type == OP_NULL)
7028 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7029 peep(cPMOP->op_pmreplstart);
7033 o->op_seq = PL_op_seqmax++;
7034 if (ckWARN(WARN_SYNTAX) && o->op_next
7035 && o->op_next->op_type == OP_NEXTSTATE) {
7036 if (o->op_next->op_sibling &&
7037 o->op_next->op_sibling->op_type != OP_EXIT &&
7038 o->op_next->op_sibling->op_type != OP_WARN &&
7039 o->op_next->op_sibling->op_type != OP_DIE) {
7040 line_t oldline = CopLINE(PL_curcop);
7042 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7043 Perl_warner(aTHX_ WARN_EXEC,
7044 "Statement unlikely to be reached");
7045 Perl_warner(aTHX_ WARN_EXEC,
7046 "\t(Maybe you meant system() when you said exec()?)\n");
7047 CopLINE_set(PL_curcop, oldline);
7056 SV **svp, **indsvp, *sv;
7061 o->op_seq = PL_op_seqmax++;
7063 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7066 /* Make the CONST have a shared SV */
7067 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7068 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7069 key = SvPV(sv, keylen);
7070 lexname = newSVpvn_share(key,
7071 SvUTF8(sv) ? -(I32)keylen : keylen,
7077 if ((o->op_private & (OPpLVAL_INTRO)))
7080 rop = (UNOP*)((BINOP*)o)->op_first;
7081 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7083 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7084 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7086 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7087 if (!fields || !GvHV(*fields))
7089 key = SvPV(*svp, keylen);
7090 indsvp = hv_fetch(GvHV(*fields), key,
7091 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7093 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7094 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7096 ind = SvIV(*indsvp);
7098 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7099 rop->op_type = OP_RV2AV;
7100 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7101 o->op_type = OP_AELEM;
7102 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7104 if (SvREADONLY(*svp))
7106 SvFLAGS(sv) |= (SvFLAGS(*svp)
7107 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7117 SV **svp, **indsvp, *sv;
7121 SVOP *first_key_op, *key_op;
7123 o->op_seq = PL_op_seqmax++;
7124 if ((o->op_private & (OPpLVAL_INTRO))
7125 /* I bet there's always a pushmark... */
7126 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7127 /* hmmm, no optimization if list contains only one key. */
7129 rop = (UNOP*)((LISTOP*)o)->op_last;
7130 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7132 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7133 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7135 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7136 if (!fields || !GvHV(*fields))
7138 /* Again guessing that the pushmark can be jumped over.... */
7139 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7140 ->op_first->op_sibling;
7141 /* Check that the key list contains only constants. */
7142 for (key_op = first_key_op; key_op;
7143 key_op = (SVOP*)key_op->op_sibling)
7144 if (key_op->op_type != OP_CONST)
7148 rop->op_type = OP_RV2AV;
7149 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7150 o->op_type = OP_ASLICE;
7151 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7152 for (key_op = first_key_op; key_op;
7153 key_op = (SVOP*)key_op->op_sibling) {
7154 svp = cSVOPx_svp(key_op);
7155 key = SvPV(*svp, keylen);
7156 indsvp = hv_fetch(GvHV(*fields), key,
7157 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7159 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7160 "in variable %s of type %s",
7161 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7163 ind = SvIV(*indsvp);
7165 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7167 if (SvREADONLY(*svp))
7169 SvFLAGS(sv) |= (SvFLAGS(*svp)
7170 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7178 o->op_seq = PL_op_seqmax++;
7188 char* Perl_custom_op_name(pTHX_ OP* o)
7190 IV index = PTR2IV(o->op_ppaddr);
7194 if (!PL_custom_op_names) /* This probably shouldn't happen */
7195 return PL_op_name[OP_CUSTOM];
7197 keysv = sv_2mortal(newSViv(index));
7199 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7201 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7203 return SvPV_nolen(HeVAL(he));
7206 char* Perl_custom_op_desc(pTHX_ OP* o)
7208 IV index = PTR2IV(o->op_ppaddr);
7212 if (!PL_custom_op_descs)
7213 return PL_op_desc[OP_CUSTOM];
7215 keysv = sv_2mortal(newSViv(index));
7217 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7219 return PL_op_desc[OP_CUSTOM];
7221 return SvPV_nolen(HeVAL(he));
7227 /* Efficient sub that returns a constant scalar value. */
7229 const_sv_xsub(pTHX_ CV* cv)
7234 Perl_croak(aTHX_ "usage: %s::%s()",
7235 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7239 ST(0) = (SV*)XSANY.any_ptr;