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
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 /* #define PL_OP_SLAB_ALLOC */
28 #if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
29 #define SLAB_SIZE 8192
30 static char *PL_OpPtr = NULL; /* XXX threadead */
31 static int PL_OpSpace = 0; /* XXX threadead */
32 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
33 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
35 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
39 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 Newz(m,PL_OpPtr,SLAB_SIZE,char);
42 PL_OpSpace = SLAB_SIZE - sz;
43 return PL_OpPtr += PL_OpSpace;
47 #define NewOp(m, var, c, type) Newz(m, var, c, type)
50 * In the following definition, the ", Nullop" is just to make the compiler
51 * think the expression is of the right type: croak actually does a Siglongjmp.
53 #define CHECKOP(type,o) \
54 ((PL_op_mask && PL_op_mask[type]) \
55 ? ( op_free((OP*)o), \
56 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
58 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
60 #define PAD_MAX 999999999
61 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
64 S_gv_ename(pTHX_ GV *gv)
67 SV* tmpsv = sv_newmortal();
68 gv_efullname3(tmpsv, gv, Nullch);
69 return SvPV(tmpsv,n_a);
73 S_no_fh_allowed(pTHX_ OP *o)
75 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
81 S_too_few_arguments(pTHX_ OP *o, char *name)
83 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
88 S_too_many_arguments(pTHX_ OP *o, char *name)
90 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
95 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
97 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
98 (int)n, name, t, OP_DESC(kid)));
102 S_no_bareword_allowed(pTHX_ OP *o)
104 qerror(Perl_mess(aTHX_
105 "Bareword \"%s\" not allowed while \"strict subs\" in use",
106 SvPV_nolen(cSVOPo_sv)));
109 /* "register" allocation */
112 Perl_pad_allocmy(pTHX_ char *name)
117 if (!(PL_in_my == KEY_our ||
119 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
120 (name[1] == '_' && (int)strlen(name) > 2)))
122 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
123 /* 1999-02-27 mjd@plover.com */
125 p = strchr(name, '\0');
126 /* The next block assumes the buffer is at least 205 chars
127 long. At present, it's always at least 256 chars. */
129 strcpy(name+200, "...");
135 /* Move everything else down one character */
136 for (; p-name > 2; p--)
138 name[2] = toCTRL(name[1]);
141 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
143 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
144 SV **svp = AvARRAY(PL_comppad_name);
145 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
146 PADOFFSET top = AvFILLp(PL_comppad_name);
147 for (off = top; off > PL_comppad_name_floor; off--) {
149 && sv != &PL_sv_undef
150 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
151 && (PL_in_my != KEY_our
152 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
153 && strEQ(name, SvPVX(sv)))
155 Perl_warner(aTHX_ WARN_MISC,
156 "\"%s\" variable %s masks earlier declaration in same %s",
157 (PL_in_my == KEY_our ? "our" : "my"),
159 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
164 if (PL_in_my == KEY_our) {
167 && sv != &PL_sv_undef
168 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
169 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
170 && strEQ(name, SvPVX(sv)))
172 Perl_warner(aTHX_ WARN_MISC,
173 "\"our\" variable %s redeclared", name);
174 Perl_warner(aTHX_ WARN_MISC,
175 "\t(Did you mean \"local\" instead of \"our\"?)\n");
178 } while ( off-- > 0 );
181 off = pad_alloc(OP_PADSV, SVs_PADMY);
183 sv_upgrade(sv, SVt_PVNV);
185 if (PL_in_my_stash) {
187 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
188 name, PL_in_my == KEY_our ? "our" : "my"));
189 SvFLAGS(sv) |= SVpad_TYPED;
190 (void)SvUPGRADE(sv, SVt_PVMG);
191 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
193 if (PL_in_my == KEY_our) {
194 (void)SvUPGRADE(sv, SVt_PVGV);
195 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
196 SvFLAGS(sv) |= SVpad_OUR;
198 av_store(PL_comppad_name, off, sv);
199 SvNVX(sv) = (NV)PAD_MAX;
200 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
201 if (!PL_min_intro_pending)
202 PL_min_intro_pending = off;
203 PL_max_intro_pending = off;
205 av_store(PL_comppad, off, (SV*)newAV());
206 else if (*name == '%')
207 av_store(PL_comppad, off, (SV*)newHV());
208 SvPADMY_on(PL_curpad[off]);
213 S_pad_addlex(pTHX_ SV *proto_namesv)
215 SV *namesv = NEWSV(1103,0);
216 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
217 sv_upgrade(namesv, SVt_PVNV);
218 sv_setpv(namesv, SvPVX(proto_namesv));
219 av_store(PL_comppad_name, newoff, namesv);
220 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
221 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
222 SvFAKE_on(namesv); /* A ref, not a real var */
223 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
224 SvFLAGS(namesv) |= SVpad_OUR;
225 (void)SvUPGRADE(namesv, SVt_PVGV);
226 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
228 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
229 SvFLAGS(namesv) |= SVpad_TYPED;
230 (void)SvUPGRADE(namesv, SVt_PVMG);
231 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
236 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
239 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
240 I32 cx_ix, I32 saweval, U32 flags)
246 register PERL_CONTEXT *cx;
248 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
249 AV *curlist = CvPADLIST(cv);
250 SV **svp = av_fetch(curlist, 0, FALSE);
253 if (!svp || *svp == &PL_sv_undef)
256 svp = AvARRAY(curname);
257 for (off = AvFILLp(curname); off > 0; off--) {
258 if ((sv = svp[off]) &&
259 sv != &PL_sv_undef &&
261 seq > I_32(SvNVX(sv)) &&
262 strEQ(SvPVX(sv), name))
273 return 0; /* don't clone from inactive stack frame */
277 oldpad = (AV*)AvARRAY(curlist)[depth];
278 oldsv = *av_fetch(oldpad, off, TRUE);
279 if (!newoff) { /* Not a mere clone operation. */
280 newoff = pad_addlex(sv);
281 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
282 /* "It's closures all the way down." */
283 CvCLONE_on(PL_compcv);
285 if (CvANON(PL_compcv))
286 oldsv = Nullsv; /* no need to keep ref */
291 bcv && bcv != cv && !CvCLONE(bcv);
292 bcv = CvOUTSIDE(bcv))
295 /* install the missing pad entry in intervening
296 * nested subs and mark them cloneable.
297 * XXX fix pad_foo() to not use globals */
298 AV *ocomppad_name = PL_comppad_name;
299 AV *ocomppad = PL_comppad;
300 SV **ocurpad = PL_curpad;
301 AV *padlist = CvPADLIST(bcv);
302 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
303 PL_comppad = (AV*)AvARRAY(padlist)[1];
304 PL_curpad = AvARRAY(PL_comppad);
306 PL_comppad_name = ocomppad_name;
307 PL_comppad = ocomppad;
312 if (ckWARN(WARN_CLOSURE)
313 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
315 Perl_warner(aTHX_ WARN_CLOSURE,
316 "Variable \"%s\" may be unavailable",
324 else if (!CvUNIQUE(PL_compcv)) {
325 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
326 && !(SvFLAGS(sv) & SVpad_OUR))
328 Perl_warner(aTHX_ WARN_CLOSURE,
329 "Variable \"%s\" will not stay shared", name);
333 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
339 if (flags & FINDLEX_NOSEARCH)
342 /* Nothing in current lexical context--try eval's context, if any.
343 * This is necessary to let the perldb get at lexically scoped variables.
344 * XXX This will also probably interact badly with eval tree caching.
347 for (i = cx_ix; i >= 0; i--) {
349 switch (CxTYPE(cx)) {
351 if (i == 0 && saweval) {
352 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
356 switch (cx->blk_eval.old_op_type) {
358 if (CxREALEVAL(cx)) {
361 seq = cxstack[i].blk_oldcop->cop_seq;
362 startcv = cxstack[i].blk_eval.cv;
363 if (startcv && CvOUTSIDE(startcv)) {
364 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
366 if (off) /* continue looking if not found here */
373 /* require/do must have their own scope */
382 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
383 saweval = i; /* so we know where we were called from */
384 seq = cxstack[i].blk_oldcop->cop_seq;
387 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
395 Perl_pad_findmy(pTHX_ char *name)
400 SV **svp = AvARRAY(PL_comppad_name);
401 U32 seq = PL_cop_seqmax;
405 #ifdef USE_5005THREADS
407 * Special case to get lexical (and hence per-thread) @_.
408 * XXX I need to find out how to tell at parse-time whether use
409 * of @_ should refer to a lexical (from a sub) or defgv (global
410 * scope and maybe weird sub-ish things like formats). See
411 * startsub in perly.y. It's possible that @_ could be lexical
412 * (at least from subs) even in non-threaded perl.
414 if (strEQ(name, "@_"))
415 return 0; /* success. (NOT_IN_PAD indicates failure) */
416 #endif /* USE_5005THREADS */
418 /* The one we're looking for is probably just before comppad_name_fill. */
419 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
420 if ((sv = svp[off]) &&
421 sv != &PL_sv_undef &&
424 seq > I_32(SvNVX(sv)))) &&
425 strEQ(SvPVX(sv), name))
427 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
428 return (PADOFFSET)off;
429 pendoff = off; /* this pending def. will override import */
433 outside = CvOUTSIDE(PL_compcv);
435 /* Check if if we're compiling an eval'', and adjust seq to be the
436 * eval's seq number. This depends on eval'' having a non-null
437 * CvOUTSIDE() while it is being compiled. The eval'' itself is
438 * identified by CvEVAL being true and CvGV being null. */
439 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
440 cx = &cxstack[cxstack_ix];
442 seq = cx->blk_oldcop->cop_seq;
445 /* See if it's in a nested scope */
446 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
448 /* If there is a pending local definition, this new alias must die */
450 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
451 return off; /* pad_findlex returns 0 for failure...*/
453 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
457 Perl_pad_leavemy(pTHX_ I32 fill)
460 SV **svp = AvARRAY(PL_comppad_name);
462 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
463 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
464 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
465 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
468 /* "Deintroduce" my variables that are leaving with this scope. */
469 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
470 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
471 SvIVX(sv) = PL_cop_seqmax;
476 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
481 if (AvARRAY(PL_comppad) != PL_curpad)
482 Perl_croak(aTHX_ "panic: pad_alloc");
483 if (PL_pad_reset_pending)
485 if (tmptype & SVs_PADMY) {
487 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
488 } while (SvPADBUSY(sv)); /* need a fresh one */
489 retval = AvFILLp(PL_comppad);
492 SV **names = AvARRAY(PL_comppad_name);
493 SSize_t names_fill = AvFILLp(PL_comppad_name);
496 * "foreach" index vars temporarily become aliases to non-"my"
497 * values. Thus we must skip, not just pad values that are
498 * marked as current pad values, but also those with names.
500 if (++PL_padix <= names_fill &&
501 (sv = names[PL_padix]) && sv != &PL_sv_undef)
503 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
504 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
505 !IS_PADGV(sv) && !IS_PADCONST(sv))
510 SvFLAGS(sv) |= tmptype;
511 PL_curpad = AvARRAY(PL_comppad);
512 #ifdef USE_5005THREADS
513 DEBUG_X(PerlIO_printf(Perl_debug_log,
514 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
515 PTR2UV(thr), PTR2UV(PL_curpad),
516 (long) retval, PL_op_name[optype]));
518 DEBUG_X(PerlIO_printf(Perl_debug_log,
519 "Pad 0x%"UVxf" alloc %ld for %s\n",
521 (long) retval, PL_op_name[optype]));
522 #endif /* USE_5005THREADS */
523 return (PADOFFSET)retval;
527 Perl_pad_sv(pTHX_ PADOFFSET po)
529 #ifdef USE_5005THREADS
530 DEBUG_X(PerlIO_printf(Perl_debug_log,
531 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
532 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
535 Perl_croak(aTHX_ "panic: pad_sv po");
536 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
537 PTR2UV(PL_curpad), (IV)po));
538 #endif /* USE_5005THREADS */
539 return PL_curpad[po]; /* eventually we'll turn this into a macro */
543 Perl_pad_free(pTHX_ PADOFFSET po)
547 if (AvARRAY(PL_comppad) != PL_curpad)
548 Perl_croak(aTHX_ "panic: pad_free curpad");
550 Perl_croak(aTHX_ "panic: pad_free po");
551 #ifdef USE_5005THREADS
552 DEBUG_X(PerlIO_printf(Perl_debug_log,
553 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
554 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
556 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
557 PTR2UV(PL_curpad), (IV)po));
558 #endif /* USE_5005THREADS */
559 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
560 SvPADTMP_off(PL_curpad[po]);
562 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
565 if ((I32)po < PL_padix)
570 Perl_pad_swipe(pTHX_ PADOFFSET po)
572 if (AvARRAY(PL_comppad) != PL_curpad)
573 Perl_croak(aTHX_ "panic: pad_swipe curpad");
575 Perl_croak(aTHX_ "panic: pad_swipe po");
576 #ifdef USE_5005THREADS
577 DEBUG_X(PerlIO_printf(Perl_debug_log,
578 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
579 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
581 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
582 PTR2UV(PL_curpad), (IV)po));
583 #endif /* USE_5005THREADS */
584 SvPADTMP_off(PL_curpad[po]);
585 PL_curpad[po] = NEWSV(1107,0);
586 SvPADTMP_on(PL_curpad[po]);
587 if ((I32)po < PL_padix)
591 /* XXX pad_reset() is currently disabled because it results in serious bugs.
592 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
593 * on the stack by OPs that use them, there are several ways to get an alias
594 * to a shared TARG. Such an alias will change randomly and unpredictably.
595 * We avoid doing this until we can think of a Better Way.
600 #ifdef USE_BROKEN_PAD_RESET
603 if (AvARRAY(PL_comppad) != PL_curpad)
604 Perl_croak(aTHX_ "panic: pad_reset curpad");
605 #ifdef USE_5005THREADS
606 DEBUG_X(PerlIO_printf(Perl_debug_log,
607 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
608 PTR2UV(thr), PTR2UV(PL_curpad)));
610 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
612 #endif /* USE_5005THREADS */
613 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
614 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
615 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
616 SvPADTMP_off(PL_curpad[po]);
618 PL_padix = PL_padix_floor;
621 PL_pad_reset_pending = FALSE;
624 #ifdef USE_5005THREADS
625 /* find_threadsv is not reentrant */
627 Perl_find_threadsv(pTHX_ const char *name)
632 /* We currently only handle names of a single character */
633 p = strchr(PL_threadsv_names, *name);
636 key = p - PL_threadsv_names;
637 MUTEX_LOCK(&thr->mutex);
638 svp = av_fetch(thr->threadsv, key, FALSE);
640 MUTEX_UNLOCK(&thr->mutex);
642 SV *sv = NEWSV(0, 0);
643 av_store(thr->threadsv, key, sv);
644 thr->threadsvp = AvARRAY(thr->threadsv);
645 MUTEX_UNLOCK(&thr->mutex);
647 * Some magic variables used to be automagically initialised
648 * in gv_fetchpv. Those which are now per-thread magicals get
649 * initialised here instead.
655 sv_setpv(sv, "\034");
656 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
661 PL_sawampersand = TRUE;
675 /* XXX %! tied to Errno.pm needs to be added here.
676 * See gv_fetchpv(). */
680 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
682 DEBUG_S(PerlIO_printf(Perl_error_log,
683 "find_threadsv: new SV %p for $%s%c\n",
684 sv, (*name < 32) ? "^" : "",
685 (*name < 32) ? toCTRL(*name) : *name));
689 #endif /* USE_5005THREADS */
694 Perl_op_free(pTHX_ OP *o)
696 register OP *kid, *nextkid;
699 if (!o || o->op_seq == (U16)-1)
702 if (o->op_private & OPpREFCOUNTED) {
703 switch (o->op_type) {
711 if (OpREFCNT_dec(o)) {
722 if (o->op_flags & OPf_KIDS) {
723 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
724 nextkid = kid->op_sibling; /* Get before next freeing kid */
732 /* COP* is not cleared by op_clear() so that we may track line
733 * numbers etc even after null() */
734 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
739 #ifdef PL_OP_SLAB_ALLOC
740 if ((char *) o == PL_OpPtr)
749 Perl_op_clear(pTHX_ OP *o)
752 switch (o->op_type) {
753 case OP_NULL: /* Was holding old type, if any. */
754 case OP_ENTEREVAL: /* Was holding hints. */
755 #ifdef USE_5005THREADS
756 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
760 #ifdef USE_5005THREADS
762 if (!(o->op_flags & OPf_SPECIAL))
765 #endif /* USE_5005THREADS */
767 if (!(o->op_flags & OPf_REF)
768 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
775 if (cPADOPo->op_padix > 0) {
778 pad_swipe(cPADOPo->op_padix);
779 /* No GvIN_PAD_off(gv) here, because other references may still
780 * exist on the pad */
783 cPADOPo->op_padix = 0;
786 SvREFCNT_dec(cSVOPo->op_sv);
787 cSVOPo->op_sv = Nullsv;
790 case OP_METHOD_NAMED:
792 SvREFCNT_dec(cSVOPo->op_sv);
793 cSVOPo->op_sv = Nullsv;
799 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
803 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
804 SvREFCNT_dec(cSVOPo->op_sv);
805 cSVOPo->op_sv = Nullsv;
808 Safefree(cPVOPo->op_pv);
809 cPVOPo->op_pv = Nullch;
813 op_free(cPMOPo->op_pmreplroot);
817 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
819 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
820 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
821 /* No GvIN_PAD_off(gv) here, because other references may still
822 * exist on the pad */
827 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
834 HV *pmstash = PmopSTASH(cPMOPo);
835 if (pmstash && SvREFCNT(pmstash)) {
836 PMOP *pmop = HvPMROOT(pmstash);
837 PMOP *lastpmop = NULL;
839 if (cPMOPo == pmop) {
841 lastpmop->op_pmnext = pmop->op_pmnext;
843 HvPMROOT(pmstash) = pmop->op_pmnext;
847 pmop = pmop->op_pmnext;
851 Safefree(PmopSTASHPV(cPMOPo));
853 /* NOTE: PMOP.op_pmstash is not refcounted */
856 cPMOPo->op_pmreplroot = Nullop;
857 /* we use the "SAFE" version of the PM_ macros here
858 * since sv_clean_all might release some PMOPs
859 * after PL_regex_padav has been cleared
860 * and the clearing of PL_regex_padav needs to
861 * happen before sv_clean_all
863 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
864 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
866 if(PL_regex_pad) { /* We could be in destruction */
867 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
868 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
869 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
876 if (o->op_targ > 0) {
877 pad_free(o->op_targ);
883 S_cop_free(pTHX_ COP* cop)
885 Safefree(cop->cop_label);
887 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
888 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
890 /* NOTE: COP.cop_stash is not refcounted */
891 SvREFCNT_dec(CopFILEGV(cop));
893 if (! specialWARN(cop->cop_warnings))
894 SvREFCNT_dec(cop->cop_warnings);
895 if (! specialCopIO(cop->cop_io))
896 SvREFCNT_dec(cop->cop_io);
900 Perl_op_null(pTHX_ OP *o)
902 if (o->op_type == OP_NULL)
905 o->op_targ = o->op_type;
906 o->op_type = OP_NULL;
907 o->op_ppaddr = PL_ppaddr[OP_NULL];
910 /* Contextualizers */
912 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
915 Perl_linklist(pTHX_ OP *o)
922 /* establish postfix order */
923 if (cUNOPo->op_first) {
924 o->op_next = LINKLIST(cUNOPo->op_first);
925 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
927 kid->op_next = LINKLIST(kid->op_sibling);
939 Perl_scalarkids(pTHX_ OP *o)
942 if (o && o->op_flags & OPf_KIDS) {
943 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
950 S_scalarboolean(pTHX_ OP *o)
952 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
953 if (ckWARN(WARN_SYNTAX)) {
954 line_t oldline = CopLINE(PL_curcop);
956 if (PL_copline != NOLINE)
957 CopLINE_set(PL_curcop, PL_copline);
958 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
959 CopLINE_set(PL_curcop, oldline);
966 Perl_scalar(pTHX_ OP *o)
970 /* assumes no premature commitment */
971 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
972 || o->op_type == OP_RETURN)
977 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
979 switch (o->op_type) {
981 scalar(cBINOPo->op_first);
986 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
990 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
991 if (!kPMOP->op_pmreplroot)
992 deprecate("implicit split to @_");
1000 if (o->op_flags & OPf_KIDS) {
1001 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1007 kid = cLISTOPo->op_first;
1009 while ((kid = kid->op_sibling)) {
1010 if (kid->op_sibling)
1015 WITH_THR(PL_curcop = &PL_compiling);
1020 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1021 if (kid->op_sibling)
1026 WITH_THR(PL_curcop = &PL_compiling);
1029 if (ckWARN(WARN_VOID))
1030 Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
1036 Perl_scalarvoid(pTHX_ OP *o)
1043 if (o->op_type == OP_NEXTSTATE
1044 || o->op_type == OP_SETSTATE
1045 || o->op_type == OP_DBSTATE
1046 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1047 || o->op_targ == OP_SETSTATE
1048 || o->op_targ == OP_DBSTATE)))
1049 PL_curcop = (COP*)o; /* for warning below */
1051 /* assumes no premature commitment */
1052 want = o->op_flags & OPf_WANT;
1053 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1054 || o->op_type == OP_RETURN)
1059 if ((o->op_private & OPpTARGET_MY)
1060 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1062 return scalar(o); /* As if inside SASSIGN */
1065 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1067 switch (o->op_type) {
1069 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1073 if (o->op_flags & OPf_STACKED)
1077 if (o->op_private == 4)
1119 case OP_GETSOCKNAME:
1120 case OP_GETPEERNAME:
1125 case OP_GETPRIORITY:
1148 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1149 useless = OP_DESC(o);
1156 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1157 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1158 useless = "a variable";
1163 if (cSVOPo->op_private & OPpCONST_STRICT)
1164 no_bareword_allowed(o);
1166 if (ckWARN(WARN_VOID)) {
1167 useless = "a constant";
1168 /* the constants 0 and 1 are permitted as they are
1169 conventionally used as dummies in constructs like
1170 1 while some_condition_with_side_effects; */
1171 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1173 else if (SvPOK(sv)) {
1174 /* perl4's way of mixing documentation and code
1175 (before the invention of POD) was based on a
1176 trick to mix nroff and perl code. The trick was
1177 built upon these three nroff macros being used in
1178 void context. The pink camel has the details in
1179 the script wrapman near page 319. */
1180 if (strnEQ(SvPVX(sv), "di", 2) ||
1181 strnEQ(SvPVX(sv), "ds", 2) ||
1182 strnEQ(SvPVX(sv), "ig", 2))
1187 op_null(o); /* don't execute or even remember it */
1191 o->op_type = OP_PREINC; /* pre-increment is faster */
1192 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1196 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1197 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1203 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1208 if (o->op_flags & OPf_STACKED)
1215 if (!(o->op_flags & OPf_KIDS))
1224 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1231 /* all requires must return a boolean value */
1232 o->op_flags &= ~OPf_WANT;
1237 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1238 if (!kPMOP->op_pmreplroot)
1239 deprecate("implicit split to @_");
1243 if (useless && ckWARN(WARN_VOID))
1244 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1249 Perl_listkids(pTHX_ OP *o)
1252 if (o && o->op_flags & OPf_KIDS) {
1253 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1260 Perl_list(pTHX_ OP *o)
1264 /* assumes no premature commitment */
1265 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1266 || o->op_type == OP_RETURN)
1271 if ((o->op_private & OPpTARGET_MY)
1272 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1274 return o; /* As if inside SASSIGN */
1277 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1279 switch (o->op_type) {
1282 list(cBINOPo->op_first);
1287 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1295 if (!(o->op_flags & OPf_KIDS))
1297 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1298 list(cBINOPo->op_first);
1299 return gen_constant_list(o);
1306 kid = cLISTOPo->op_first;
1308 while ((kid = kid->op_sibling)) {
1309 if (kid->op_sibling)
1314 WITH_THR(PL_curcop = &PL_compiling);
1318 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1319 if (kid->op_sibling)
1324 WITH_THR(PL_curcop = &PL_compiling);
1327 /* all requires must return a boolean value */
1328 o->op_flags &= ~OPf_WANT;
1335 Perl_scalarseq(pTHX_ OP *o)
1340 if (o->op_type == OP_LINESEQ ||
1341 o->op_type == OP_SCOPE ||
1342 o->op_type == OP_LEAVE ||
1343 o->op_type == OP_LEAVETRY)
1345 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1346 if (kid->op_sibling) {
1350 PL_curcop = &PL_compiling;
1352 o->op_flags &= ~OPf_PARENS;
1353 if (PL_hints & HINT_BLOCK_SCOPE)
1354 o->op_flags |= OPf_PARENS;
1357 o = newOP(OP_STUB, 0);
1362 S_modkids(pTHX_ OP *o, I32 type)
1365 if (o && o->op_flags & OPf_KIDS) {
1366 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1373 Perl_mod(pTHX_ OP *o, I32 type)
1378 if (!o || PL_error_count)
1381 if ((o->op_private & OPpTARGET_MY)
1382 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1387 switch (o->op_type) {
1392 if (!(o->op_private & (OPpCONST_ARYBASE)))
1394 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1395 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1399 SAVEI32(PL_compiling.cop_arybase);
1400 PL_compiling.cop_arybase = 0;
1402 else if (type == OP_REFGEN)
1405 Perl_croak(aTHX_ "That use of $[ is unsupported");
1408 if (o->op_flags & OPf_PARENS)
1412 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1413 !(o->op_flags & OPf_STACKED)) {
1414 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1415 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1416 assert(cUNOPo->op_first->op_type == OP_NULL);
1417 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1420 else if (o->op_private & OPpENTERSUB_NOMOD)
1422 else { /* lvalue subroutine call */
1423 o->op_private |= OPpLVAL_INTRO;
1424 PL_modcount = RETURN_UNLIMITED_NUMBER;
1425 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1426 /* Backward compatibility mode: */
1427 o->op_private |= OPpENTERSUB_INARGS;
1430 else { /* Compile-time error message: */
1431 OP *kid = cUNOPo->op_first;
1435 if (kid->op_type == OP_PUSHMARK)
1437 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1439 "panic: unexpected lvalue entersub "
1440 "args: type/targ %ld:%"UVuf,
1441 (long)kid->op_type, (UV)kid->op_targ);
1442 kid = kLISTOP->op_first;
1444 while (kid->op_sibling)
1445 kid = kid->op_sibling;
1446 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1448 if (kid->op_type == OP_METHOD_NAMED
1449 || kid->op_type == OP_METHOD)
1453 NewOp(1101, newop, 1, UNOP);
1454 newop->op_type = OP_RV2CV;
1455 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456 newop->op_first = Nullop;
1457 newop->op_next = (OP*)newop;
1458 kid->op_sibling = (OP*)newop;
1459 newop->op_private |= OPpLVAL_INTRO;
1463 if (kid->op_type != OP_RV2CV)
1465 "panic: unexpected lvalue entersub "
1466 "entry via type/targ %ld:%"UVuf,
1467 (long)kid->op_type, (UV)kid->op_targ);
1468 kid->op_private |= OPpLVAL_INTRO;
1469 break; /* Postpone until runtime */
1473 kid = kUNOP->op_first;
1474 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1475 kid = kUNOP->op_first;
1476 if (kid->op_type == OP_NULL)
1478 "Unexpected constant lvalue entersub "
1479 "entry via type/targ %ld:%"UVuf,
1480 (long)kid->op_type, (UV)kid->op_targ);
1481 if (kid->op_type != OP_GV) {
1482 /* Restore RV2CV to check lvalueness */
1484 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1485 okid->op_next = kid->op_next;
1486 kid->op_next = okid;
1489 okid->op_next = Nullop;
1490 okid->op_type = OP_RV2CV;
1492 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1493 okid->op_private |= OPpLVAL_INTRO;
1497 cv = GvCV(kGVOP_gv);
1507 /* grep, foreach, subcalls, refgen */
1508 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1510 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1511 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1513 : (o->op_type == OP_ENTERSUB
1514 ? "non-lvalue subroutine call"
1516 type ? PL_op_desc[type] : "local"));
1530 case OP_RIGHT_SHIFT:
1539 if (!(o->op_flags & OPf_STACKED))
1545 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1551 if (!type && cUNOPo->op_first->op_type != OP_GV)
1552 Perl_croak(aTHX_ "Can't localize through a reference");
1553 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1554 PL_modcount = RETURN_UNLIMITED_NUMBER;
1555 return o; /* Treat \(@foo) like ordinary list. */
1559 if (scalar_mod_type(o, type))
1561 ref(cUNOPo->op_first, o->op_type);
1565 if (type == OP_LEAVESUBLV)
1566 o->op_private |= OPpMAYBE_LVSUB;
1572 PL_modcount = RETURN_UNLIMITED_NUMBER;
1575 if (!type && cUNOPo->op_first->op_type != OP_GV)
1576 Perl_croak(aTHX_ "Can't localize through a reference");
1577 ref(cUNOPo->op_first, o->op_type);
1581 PL_hints |= HINT_BLOCK_SCOPE;
1591 PL_modcount = RETURN_UNLIMITED_NUMBER;
1592 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1593 return o; /* Treat \(@foo) like ordinary list. */
1594 if (scalar_mod_type(o, type))
1596 if (type == OP_LEAVESUBLV)
1597 o->op_private |= OPpMAYBE_LVSUB;
1602 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1603 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1606 #ifdef USE_5005THREADS
1608 PL_modcount++; /* XXX ??? */
1610 #endif /* USE_5005THREADS */
1616 if (type != OP_SASSIGN)
1620 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1625 if (type == OP_LEAVESUBLV)
1626 o->op_private |= OPpMAYBE_LVSUB;
1628 pad_free(o->op_targ);
1629 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1630 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1631 if (o->op_flags & OPf_KIDS)
1632 mod(cBINOPo->op_first->op_sibling, type);
1637 ref(cBINOPo->op_first, o->op_type);
1638 if (type == OP_ENTERSUB &&
1639 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1640 o->op_private |= OPpLVAL_DEFER;
1641 if (type == OP_LEAVESUBLV)
1642 o->op_private |= OPpMAYBE_LVSUB;
1650 if (o->op_flags & OPf_KIDS)
1651 mod(cLISTOPo->op_last, type);
1655 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1657 else if (!(o->op_flags & OPf_KIDS))
1659 if (o->op_targ != OP_LIST) {
1660 mod(cBINOPo->op_first, type);
1665 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1670 if (type != OP_LEAVESUBLV)
1672 break; /* mod()ing was handled by ck_return() */
1675 /* [20011101.069] File test operators interpret OPf_REF to mean that
1676 their argument is a filehandle; thus \stat(".") should not set
1678 if (type == OP_REFGEN &&
1679 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1682 if (type != OP_LEAVESUBLV)
1683 o->op_flags |= OPf_MOD;
1685 if (type == OP_AASSIGN || type == OP_SASSIGN)
1686 o->op_flags |= OPf_SPECIAL|OPf_REF;
1688 o->op_private |= OPpLVAL_INTRO;
1689 o->op_flags &= ~OPf_SPECIAL;
1690 PL_hints |= HINT_BLOCK_SCOPE;
1692 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1693 && type != OP_LEAVESUBLV)
1694 o->op_flags |= OPf_REF;
1699 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1703 if (o->op_type == OP_RV2GV)
1727 case OP_RIGHT_SHIFT:
1746 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1748 switch (o->op_type) {
1756 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1769 Perl_refkids(pTHX_ OP *o, I32 type)
1772 if (o && o->op_flags & OPf_KIDS) {
1773 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1780 Perl_ref(pTHX_ OP *o, I32 type)
1784 if (!o || PL_error_count)
1787 switch (o->op_type) {
1789 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1790 !(o->op_flags & OPf_STACKED)) {
1791 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1792 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1793 assert(cUNOPo->op_first->op_type == OP_NULL);
1794 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1795 o->op_flags |= OPf_SPECIAL;
1800 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1804 if (type == OP_DEFINED)
1805 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1806 ref(cUNOPo->op_first, o->op_type);
1809 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1810 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1811 : type == OP_RV2HV ? OPpDEREF_HV
1813 o->op_flags |= OPf_MOD;
1818 o->op_flags |= OPf_MOD; /* XXX ??? */
1823 o->op_flags |= OPf_REF;
1826 if (type == OP_DEFINED)
1827 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1828 ref(cUNOPo->op_first, o->op_type);
1833 o->op_flags |= OPf_REF;
1838 if (!(o->op_flags & OPf_KIDS))
1840 ref(cBINOPo->op_first, type);
1844 ref(cBINOPo->op_first, o->op_type);
1845 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1846 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1847 : type == OP_RV2HV ? OPpDEREF_HV
1849 o->op_flags |= OPf_MOD;
1857 if (!(o->op_flags & OPf_KIDS))
1859 ref(cLISTOPo->op_last, type);
1869 S_dup_attrlist(pTHX_ OP *o)
1873 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1874 * where the first kid is OP_PUSHMARK and the remaining ones
1875 * are OP_CONST. We need to push the OP_CONST values.
1877 if (o->op_type == OP_CONST)
1878 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1880 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1881 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1882 if (o->op_type == OP_CONST)
1883 rop = append_elem(OP_LIST, rop,
1884 newSVOP(OP_CONST, o->op_flags,
1885 SvREFCNT_inc(cSVOPo->op_sv)));
1892 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1896 /* fake up C<use attributes $pkg,$rv,@attrs> */
1897 ENTER; /* need to protect against side-effects of 'use' */
1900 stashsv = newSVpv(HvNAME(stash), 0);
1902 stashsv = &PL_sv_no;
1904 #define ATTRSMODULE "attributes"
1905 #define ATTRSMODULE_PM "attributes.pm"
1909 /* Don't force the C<use> if we don't need it. */
1910 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1911 sizeof(ATTRSMODULE_PM)-1, 0);
1912 if (svp && *svp != &PL_sv_undef)
1913 ; /* already in %INC */
1915 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1916 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1920 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1921 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1923 prepend_elem(OP_LIST,
1924 newSVOP(OP_CONST, 0, stashsv),
1925 prepend_elem(OP_LIST,
1926 newSVOP(OP_CONST, 0,
1928 dup_attrlist(attrs))));
1934 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1936 OP *pack, *imop, *arg;
1942 assert(target->op_type == OP_PADSV ||
1943 target->op_type == OP_PADHV ||
1944 target->op_type == OP_PADAV);
1946 /* Ensure that attributes.pm is loaded. */
1947 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1949 /* Need package name for method call. */
1950 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1952 /* Build up the real arg-list. */
1954 stashsv = newSVpv(HvNAME(stash), 0);
1956 stashsv = &PL_sv_no;
1957 arg = newOP(OP_PADSV, 0);
1958 arg->op_targ = target->op_targ;
1959 arg = prepend_elem(OP_LIST,
1960 newSVOP(OP_CONST, 0, stashsv),
1961 prepend_elem(OP_LIST,
1962 newUNOP(OP_REFGEN, 0,
1963 mod(arg, OP_REFGEN)),
1964 dup_attrlist(attrs)));
1966 /* Fake up a method call to import */
1967 meth = newSVpvn("import", 6);
1968 (void)SvUPGRADE(meth, SVt_PVIV);
1969 (void)SvIOK_on(meth);
1970 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1971 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1972 append_elem(OP_LIST,
1973 prepend_elem(OP_LIST, pack, list(arg)),
1974 newSVOP(OP_METHOD_NAMED, 0, meth)));
1975 imop->op_private |= OPpENTERSUB_NOMOD;
1977 /* Combine the ops. */
1978 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1982 =notfor apidoc apply_attrs_string
1984 Attempts to apply a list of attributes specified by the C<attrstr> and
1985 C<len> arguments to the subroutine identified by the C<cv> argument which
1986 is expected to be associated with the package identified by the C<stashpv>
1987 argument (see L<attributes>). It gets this wrong, though, in that it
1988 does not correctly identify the boundaries of the individual attribute
1989 specifications within C<attrstr>. This is not really intended for the
1990 public API, but has to be listed here for systems such as AIX which
1991 need an explicit export list for symbols. (It's called from XS code
1992 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1993 to respect attribute syntax properly would be welcome.
1999 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2000 char *attrstr, STRLEN len)
2005 len = strlen(attrstr);
2009 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2011 char *sstr = attrstr;
2012 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2013 attrs = append_elem(OP_LIST, attrs,
2014 newSVOP(OP_CONST, 0,
2015 newSVpvn(sstr, attrstr-sstr)));
2019 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2020 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2021 Nullsv, prepend_elem(OP_LIST,
2022 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2023 prepend_elem(OP_LIST,
2024 newSVOP(OP_CONST, 0,
2030 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2035 if (!o || PL_error_count)
2039 if (type == OP_LIST) {
2040 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2041 my_kid(kid, attrs, imopsp);
2042 } else if (type == OP_UNDEF) {
2044 } else if (type == OP_RV2SV || /* "our" declaration */
2046 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2047 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2048 yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
2051 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2053 PL_in_my_stash = Nullhv;
2054 apply_attrs(GvSTASH(gv),
2055 (type == OP_RV2SV ? GvSV(gv) :
2056 type == OP_RV2AV ? (SV*)GvAV(gv) :
2057 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2060 o->op_private |= OPpOUR_INTRO;
2063 else if (type != OP_PADSV &&
2066 type != OP_PUSHMARK)
2068 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2070 PL_in_my == KEY_our ? "our" : "my"));
2073 else if (attrs && type != OP_PUSHMARK) {
2078 PL_in_my_stash = Nullhv;
2080 /* check for C<my Dog $spot> when deciding package */
2081 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2082 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
2083 stash = SvSTASH(*namesvp);
2085 stash = PL_curstash;
2086 apply_attrs_my(stash, o, attrs, imopsp);
2088 o->op_flags |= OPf_MOD;
2089 o->op_private |= OPpLVAL_INTRO;
2094 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2097 int maybe_scalar = 0;
2099 if (o->op_flags & OPf_PARENS)
2105 o = my_kid(o, attrs, &rops);
2107 if (maybe_scalar && o->op_type == OP_PADSV) {
2108 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2109 o->op_private |= OPpLVAL_INTRO;
2112 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2115 PL_in_my_stash = Nullhv;
2120 Perl_my(pTHX_ OP *o)
2122 return my_attrs(o, Nullop);
2126 Perl_sawparens(pTHX_ OP *o)
2129 o->op_flags |= OPf_PARENS;
2134 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2138 if (ckWARN(WARN_MISC) &&
2139 (left->op_type == OP_RV2AV ||
2140 left->op_type == OP_RV2HV ||
2141 left->op_type == OP_PADAV ||
2142 left->op_type == OP_PADHV)) {
2143 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2144 right->op_type == OP_TRANS)
2145 ? right->op_type : OP_MATCH];
2146 const char *sample = ((left->op_type == OP_RV2AV ||
2147 left->op_type == OP_PADAV)
2148 ? "@array" : "%hash");
2149 Perl_warner(aTHX_ WARN_MISC,
2150 "Applying %s to %s will act on scalar(%s)",
2151 desc, sample, sample);
2154 if (right->op_type == OP_CONST &&
2155 cSVOPx(right)->op_private & OPpCONST_BARE &&
2156 cSVOPx(right)->op_private & OPpCONST_STRICT)
2158 no_bareword_allowed(right);
2161 if (!(right->op_flags & OPf_STACKED) &&
2162 (right->op_type == OP_MATCH ||
2163 right->op_type == OP_SUBST ||
2164 right->op_type == OP_TRANS)) {
2165 right->op_flags |= OPf_STACKED;
2166 if (right->op_type != OP_MATCH &&
2167 ! (right->op_type == OP_TRANS &&
2168 right->op_private & OPpTRANS_IDENTICAL))
2169 left = mod(left, right->op_type);
2170 if (right->op_type == OP_TRANS)
2171 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2173 o = prepend_elem(right->op_type, scalar(left), right);
2175 return newUNOP(OP_NOT, 0, scalar(o));
2179 return bind_match(type, left,
2180 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2184 Perl_invert(pTHX_ OP *o)
2188 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
2189 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2193 Perl_scope(pTHX_ OP *o)
2196 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2197 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2198 o->op_type = OP_LEAVE;
2199 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2202 if (o->op_type == OP_LINESEQ) {
2204 o->op_type = OP_SCOPE;
2205 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2206 kid = ((LISTOP*)o)->op_first;
2207 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2211 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2218 Perl_save_hints(pTHX)
2221 SAVESPTR(GvHV(PL_hintgv));
2222 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2223 SAVEFREESV(GvHV(PL_hintgv));
2227 Perl_block_start(pTHX_ int full)
2229 int retval = PL_savestack_ix;
2231 SAVEI32(PL_comppad_name_floor);
2232 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2234 PL_comppad_name_fill = PL_comppad_name_floor;
2235 if (PL_comppad_name_floor < 0)
2236 PL_comppad_name_floor = 0;
2237 SAVEI32(PL_min_intro_pending);
2238 SAVEI32(PL_max_intro_pending);
2239 PL_min_intro_pending = 0;
2240 SAVEI32(PL_comppad_name_fill);
2241 SAVEI32(PL_padix_floor);
2242 PL_padix_floor = PL_padix;
2243 PL_pad_reset_pending = FALSE;
2245 PL_hints &= ~HINT_BLOCK_SCOPE;
2246 SAVESPTR(PL_compiling.cop_warnings);
2247 if (! specialWARN(PL_compiling.cop_warnings)) {
2248 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2249 SAVEFREESV(PL_compiling.cop_warnings) ;
2251 SAVESPTR(PL_compiling.cop_io);
2252 if (! specialCopIO(PL_compiling.cop_io)) {
2253 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2254 SAVEFREESV(PL_compiling.cop_io) ;
2260 Perl_block_end(pTHX_ I32 floor, OP *seq)
2262 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2263 line_t copline = PL_copline;
2264 /* there should be a nextstate in every block */
2265 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2266 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
2268 PL_pad_reset_pending = FALSE;
2269 PL_compiling.op_private = PL_hints;
2271 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2272 pad_leavemy(PL_comppad_name_fill);
2280 #ifdef USE_5005THREADS
2281 OP *o = newOP(OP_THREADSV, 0);
2282 o->op_targ = find_threadsv("_");
2285 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2286 #endif /* USE_5005THREADS */
2290 Perl_newPROG(pTHX_ OP *o)
2295 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2296 ((PL_in_eval & EVAL_KEEPERR)
2297 ? OPf_SPECIAL : 0), o);
2298 PL_eval_start = linklist(PL_eval_root);
2299 PL_eval_root->op_private |= OPpREFCOUNTED;
2300 OpREFCNT_set(PL_eval_root, 1);
2301 PL_eval_root->op_next = 0;
2302 CALL_PEEP(PL_eval_start);
2307 PL_main_root = scope(sawparens(scalarvoid(o)));
2308 PL_curcop = &PL_compiling;
2309 PL_main_start = LINKLIST(PL_main_root);
2310 PL_main_root->op_private |= OPpREFCOUNTED;
2311 OpREFCNT_set(PL_main_root, 1);
2312 PL_main_root->op_next = 0;
2313 CALL_PEEP(PL_main_start);
2316 /* Register with debugger */
2318 CV *cv = get_cv("DB::postponed", FALSE);
2322 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2324 call_sv((SV*)cv, G_DISCARD);
2331 Perl_localize(pTHX_ OP *o, I32 lex)
2333 if (o->op_flags & OPf_PARENS)
2336 if (ckWARN(WARN_PARENTHESIS)
2337 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2339 char *s = PL_bufptr;
2341 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2344 if (*s == ';' || *s == '=')
2345 Perl_warner(aTHX_ WARN_PARENTHESIS,
2346 "Parentheses missing around \"%s\" list",
2347 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2353 o = mod(o, OP_NULL); /* a bit kludgey */
2355 PL_in_my_stash = Nullhv;
2360 Perl_jmaybe(pTHX_ OP *o)
2362 if (o->op_type == OP_LIST) {
2364 #ifdef USE_5005THREADS
2365 o2 = newOP(OP_THREADSV, 0);
2366 o2->op_targ = find_threadsv(";");
2368 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2369 #endif /* USE_5005THREADS */
2370 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2376 Perl_fold_constants(pTHX_ register OP *o)
2379 I32 type = o->op_type;
2382 if (PL_opargs[type] & OA_RETSCALAR)
2384 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2385 o->op_targ = pad_alloc(type, SVs_PADTMP);
2387 /* integerize op, unless it happens to be C<-foo>.
2388 * XXX should pp_i_negate() do magic string negation instead? */
2389 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2390 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2391 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2393 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2396 if (!(PL_opargs[type] & OA_FOLDCONST))
2401 /* XXX might want a ck_negate() for this */
2402 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2414 /* XXX what about the numeric ops? */
2415 if (PL_hints & HINT_LOCALE)
2420 goto nope; /* Don't try to run w/ errors */
2422 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2423 if ((curop->op_type != OP_CONST ||
2424 (curop->op_private & OPpCONST_BARE)) &&
2425 curop->op_type != OP_LIST &&
2426 curop->op_type != OP_SCALAR &&
2427 curop->op_type != OP_NULL &&
2428 curop->op_type != OP_PUSHMARK)
2434 curop = LINKLIST(o);
2438 sv = *(PL_stack_sp--);
2439 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2440 pad_swipe(o->op_targ);
2441 else if (SvTEMP(sv)) { /* grab mortal temp? */
2442 (void)SvREFCNT_inc(sv);
2446 if (type == OP_RV2GV)
2447 return newGVOP(OP_GV, 0, (GV*)sv);
2449 /* try to smush double to int, but don't smush -2.0 to -2 */
2450 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2453 #ifdef PERL_PRESERVE_IVUV
2454 /* Only bother to attempt to fold to IV if
2455 most operators will benefit */
2459 return newSVOP(OP_CONST, 0, sv);
2463 if (!(PL_opargs[type] & OA_OTHERINT))
2466 if (!(PL_hints & HINT_INTEGER)) {
2467 if (type == OP_MODULO
2468 || type == OP_DIVIDE
2469 || !(o->op_flags & OPf_KIDS))
2474 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2475 if (curop->op_type == OP_CONST) {
2476 if (SvIOK(((SVOP*)curop)->op_sv))
2480 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2484 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2491 Perl_gen_constant_list(pTHX_ register OP *o)
2494 I32 oldtmps_floor = PL_tmps_floor;
2498 return o; /* Don't attempt to run with errors */
2500 PL_op = curop = LINKLIST(o);
2507 PL_tmps_floor = oldtmps_floor;
2509 o->op_type = OP_RV2AV;
2510 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2511 curop = ((UNOP*)o)->op_first;
2512 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2519 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2521 if (!o || o->op_type != OP_LIST)
2522 o = newLISTOP(OP_LIST, 0, o, Nullop);
2524 o->op_flags &= ~OPf_WANT;
2526 if (!(PL_opargs[type] & OA_MARK))
2527 op_null(cLISTOPo->op_first);
2530 o->op_ppaddr = PL_ppaddr[type];
2531 o->op_flags |= flags;
2533 o = CHECKOP(type, o);
2534 if (o->op_type != type)
2537 return fold_constants(o);
2540 /* List constructors */
2543 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2551 if (first->op_type != type
2552 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2554 return newLISTOP(type, 0, first, last);
2557 if (first->op_flags & OPf_KIDS)
2558 ((LISTOP*)first)->op_last->op_sibling = last;
2560 first->op_flags |= OPf_KIDS;
2561 ((LISTOP*)first)->op_first = last;
2563 ((LISTOP*)first)->op_last = last;
2568 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2576 if (first->op_type != type)
2577 return prepend_elem(type, (OP*)first, (OP*)last);
2579 if (last->op_type != type)
2580 return append_elem(type, (OP*)first, (OP*)last);
2582 first->op_last->op_sibling = last->op_first;
2583 first->op_last = last->op_last;
2584 first->op_flags |= (last->op_flags & OPf_KIDS);
2586 #ifdef PL_OP_SLAB_ALLOC
2594 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2602 if (last->op_type == type) {
2603 if (type == OP_LIST) { /* already a PUSHMARK there */
2604 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2605 ((LISTOP*)last)->op_first->op_sibling = first;
2606 if (!(first->op_flags & OPf_PARENS))
2607 last->op_flags &= ~OPf_PARENS;
2610 if (!(last->op_flags & OPf_KIDS)) {
2611 ((LISTOP*)last)->op_last = first;
2612 last->op_flags |= OPf_KIDS;
2614 first->op_sibling = ((LISTOP*)last)->op_first;
2615 ((LISTOP*)last)->op_first = first;
2617 last->op_flags |= OPf_KIDS;
2621 return newLISTOP(type, 0, first, last);
2627 Perl_newNULLLIST(pTHX)
2629 return newOP(OP_STUB, 0);
2633 Perl_force_list(pTHX_ OP *o)
2635 if (!o || o->op_type != OP_LIST)
2636 o = newLISTOP(OP_LIST, 0, o, Nullop);
2642 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2646 NewOp(1101, listop, 1, LISTOP);
2648 listop->op_type = type;
2649 listop->op_ppaddr = PL_ppaddr[type];
2652 listop->op_flags = flags;
2656 else if (!first && last)
2659 first->op_sibling = last;
2660 listop->op_first = first;
2661 listop->op_last = last;
2662 if (type == OP_LIST) {
2664 pushop = newOP(OP_PUSHMARK, 0);
2665 pushop->op_sibling = first;
2666 listop->op_first = pushop;
2667 listop->op_flags |= OPf_KIDS;
2669 listop->op_last = pushop;
2676 Perl_newOP(pTHX_ I32 type, I32 flags)
2679 NewOp(1101, o, 1, OP);
2681 o->op_ppaddr = PL_ppaddr[type];
2682 o->op_flags = flags;
2685 o->op_private = 0 + (flags >> 8);
2686 if (PL_opargs[type] & OA_RETSCALAR)
2688 if (PL_opargs[type] & OA_TARGET)
2689 o->op_targ = pad_alloc(type, SVs_PADTMP);
2690 return CHECKOP(type, o);
2694 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2699 first = newOP(OP_STUB, 0);
2700 if (PL_opargs[type] & OA_MARK)
2701 first = force_list(first);
2703 NewOp(1101, unop, 1, UNOP);
2704 unop->op_type = type;
2705 unop->op_ppaddr = PL_ppaddr[type];
2706 unop->op_first = first;
2707 unop->op_flags = flags | OPf_KIDS;
2708 unop->op_private = 1 | (flags >> 8);
2709 unop = (UNOP*) CHECKOP(type, unop);
2713 return fold_constants((OP *) unop);
2717 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2720 NewOp(1101, binop, 1, BINOP);
2723 first = newOP(OP_NULL, 0);
2725 binop->op_type = type;
2726 binop->op_ppaddr = PL_ppaddr[type];
2727 binop->op_first = first;
2728 binop->op_flags = flags | OPf_KIDS;
2731 binop->op_private = 1 | (flags >> 8);
2734 binop->op_private = 2 | (flags >> 8);
2735 first->op_sibling = last;
2738 binop = (BINOP*)CHECKOP(type, binop);
2739 if (binop->op_next || binop->op_type != type)
2742 binop->op_last = binop->op_first->op_sibling;
2744 return fold_constants((OP *)binop);
2748 uvcompare(const void *a, const void *b)
2750 if (*((UV *)a) < (*(UV *)b))
2752 if (*((UV *)a) > (*(UV *)b))
2754 if (*((UV *)a+1) < (*(UV *)b+1))
2756 if (*((UV *)a+1) > (*(UV *)b+1))
2762 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2764 SV *tstr = ((SVOP*)expr)->op_sv;
2765 SV *rstr = ((SVOP*)repl)->op_sv;
2768 U8 *t = (U8*)SvPV(tstr, tlen);
2769 U8 *r = (U8*)SvPV(rstr, rlen);
2776 register short *tbl;
2778 PL_hints |= HINT_BLOCK_SCOPE;
2779 complement = o->op_private & OPpTRANS_COMPLEMENT;
2780 del = o->op_private & OPpTRANS_DELETE;
2781 squash = o->op_private & OPpTRANS_SQUASH;
2784 o->op_private |= OPpTRANS_FROM_UTF;
2787 o->op_private |= OPpTRANS_TO_UTF;
2789 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2790 SV* listsv = newSVpvn("# comment\n",10);
2792 U8* tend = t + tlen;
2793 U8* rend = r + rlen;
2807 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2808 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2814 tsave = t = bytes_to_utf8(t, &len);
2817 if (!to_utf && rlen) {
2819 rsave = r = bytes_to_utf8(r, &len);
2823 /* There are several snags with this code on EBCDIC:
2824 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2825 2. scan_const() in toke.c has encoded chars in native encoding which makes
2826 ranges at least in EBCDIC 0..255 range the bottom odd.
2830 U8 tmpbuf[UTF8_MAXLEN+1];
2833 New(1109, cp, 2*tlen, UV);
2835 transv = newSVpvn("",0);
2837 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2839 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2841 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2845 cp[2*i+1] = cp[2*i];
2849 qsort(cp, i, 2*sizeof(UV), uvcompare);
2850 for (j = 0; j < i; j++) {
2852 diff = val - nextmin;
2854 t = uvuni_to_utf8(tmpbuf,nextmin);
2855 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2857 U8 range_mark = UTF_TO_NATIVE(0xff);
2858 t = uvuni_to_utf8(tmpbuf, val - 1);
2859 sv_catpvn(transv, (char *)&range_mark, 1);
2860 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2867 t = uvuni_to_utf8(tmpbuf,nextmin);
2868 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2870 U8 range_mark = UTF_TO_NATIVE(0xff);
2871 sv_catpvn(transv, (char *)&range_mark, 1);
2873 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2874 UNICODE_ALLOW_SUPER);
2875 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2876 t = (U8*)SvPVX(transv);
2877 tlen = SvCUR(transv);
2881 else if (!rlen && !del) {
2882 r = t; rlen = tlen; rend = tend;
2885 if ((!rlen && !del) || t == r ||
2886 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2888 o->op_private |= OPpTRANS_IDENTICAL;
2892 while (t < tend || tfirst <= tlast) {
2893 /* see if we need more "t" chars */
2894 if (tfirst > tlast) {
2895 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2897 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2899 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2906 /* now see if we need more "r" chars */
2907 if (rfirst > rlast) {
2909 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2911 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2913 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2922 rfirst = rlast = 0xffffffff;
2926 /* now see which range will peter our first, if either. */
2927 tdiff = tlast - tfirst;
2928 rdiff = rlast - rfirst;
2935 if (rfirst == 0xffffffff) {
2936 diff = tdiff; /* oops, pretend rdiff is infinite */
2938 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2939 (long)tfirst, (long)tlast);
2941 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2945 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2946 (long)tfirst, (long)(tfirst + diff),
2949 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2950 (long)tfirst, (long)rfirst);
2952 if (rfirst + diff > max)
2953 max = rfirst + diff;
2955 grows = (tfirst < rfirst &&
2956 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2968 else if (max > 0xff)
2973 Safefree(cPVOPo->op_pv);
2974 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2975 SvREFCNT_dec(listsv);
2977 SvREFCNT_dec(transv);
2979 if (!del && havefinal && rlen)
2980 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2981 newSVuv((UV)final), 0);
2984 o->op_private |= OPpTRANS_GROWS;
2996 tbl = (short*)cPVOPo->op_pv;
2998 Zero(tbl, 256, short);
2999 for (i = 0; i < tlen; i++)
3001 for (i = 0, j = 0; i < 256; i++) {
3012 if (i < 128 && r[j] >= 128)
3022 o->op_private |= OPpTRANS_IDENTICAL;
3027 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3028 tbl[0x100] = rlen - j;
3029 for (i=0; i < rlen - j; i++)
3030 tbl[0x101+i] = r[j+i];
3034 if (!rlen && !del) {
3037 o->op_private |= OPpTRANS_IDENTICAL;
3039 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3040 o->op_private |= OPpTRANS_IDENTICAL;
3042 for (i = 0; i < 256; i++)
3044 for (i = 0, j = 0; i < tlen; i++,j++) {
3047 if (tbl[t[i]] == -1)
3053 if (tbl[t[i]] == -1) {
3054 if (t[i] < 128 && r[j] >= 128)
3061 o->op_private |= OPpTRANS_GROWS;
3069 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3073 NewOp(1101, pmop, 1, PMOP);
3074 pmop->op_type = type;
3075 pmop->op_ppaddr = PL_ppaddr[type];
3076 pmop->op_flags = flags;
3077 pmop->op_private = 0 | (flags >> 8);
3079 if (PL_hints & HINT_RE_TAINT)
3080 pmop->op_pmpermflags |= PMf_RETAINT;
3081 if (PL_hints & HINT_LOCALE)
3082 pmop->op_pmpermflags |= PMf_LOCALE;
3083 pmop->op_pmflags = pmop->op_pmpermflags;
3088 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3089 repointer = av_pop((AV*)PL_regex_pad[0]);
3090 pmop->op_pmoffset = SvIV(repointer);
3091 SvREPADTMP_off(repointer);
3092 sv_setiv(repointer,0);
3094 repointer = newSViv(0);
3095 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3096 pmop->op_pmoffset = av_len(PL_regex_padav);
3097 PL_regex_pad = AvARRAY(PL_regex_padav);
3102 /* link into pm list */
3103 if (type != OP_TRANS && PL_curstash) {
3104 pmop->op_pmnext = HvPMROOT(PL_curstash);
3105 HvPMROOT(PL_curstash) = pmop;
3106 PmopSTASH_set(pmop,PL_curstash);
3113 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3117 I32 repl_has_vars = 0;
3119 if (o->op_type == OP_TRANS)
3120 return pmtrans(o, expr, repl);
3122 PL_hints |= HINT_BLOCK_SCOPE;
3125 if (expr->op_type == OP_CONST) {
3127 SV *pat = ((SVOP*)expr)->op_sv;
3128 char *p = SvPV(pat, plen);
3129 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3130 sv_setpvn(pat, "\\s+", 3);
3131 p = SvPV(pat, plen);
3132 pm->op_pmflags |= PMf_SKIPWHITE;
3135 pm->op_pmdynflags |= PMdf_UTF8;
3136 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3137 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3138 pm->op_pmflags |= PMf_WHITE;
3142 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3143 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3145 : OP_REGCMAYBE),0,expr);
3147 NewOp(1101, rcop, 1, LOGOP);
3148 rcop->op_type = OP_REGCOMP;
3149 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3150 rcop->op_first = scalar(expr);
3151 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3152 ? (OPf_SPECIAL | OPf_KIDS)
3154 rcop->op_private = 1;
3157 /* establish postfix order */
3158 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3160 rcop->op_next = expr;
3161 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3164 rcop->op_next = LINKLIST(expr);
3165 expr->op_next = (OP*)rcop;
3168 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3173 if (pm->op_pmflags & PMf_EVAL) {
3175 if (CopLINE(PL_curcop) < PL_multi_end)
3176 CopLINE_set(PL_curcop, PL_multi_end);
3178 #ifdef USE_5005THREADS
3179 else if (repl->op_type == OP_THREADSV
3180 && strchr("&`'123456789+",
3181 PL_threadsv_names[repl->op_targ]))
3185 #endif /* USE_5005THREADS */
3186 else if (repl->op_type == OP_CONST)
3190 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3191 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3192 #ifdef USE_5005THREADS
3193 if (curop->op_type == OP_THREADSV) {
3195 if (strchr("&`'123456789+", curop->op_private))
3199 if (curop->op_type == OP_GV) {
3200 GV *gv = cGVOPx_gv(curop);
3202 if (strchr("&`'123456789+", *GvENAME(gv)))
3205 #endif /* USE_5005THREADS */
3206 else if (curop->op_type == OP_RV2CV)
3208 else if (curop->op_type == OP_RV2SV ||
3209 curop->op_type == OP_RV2AV ||
3210 curop->op_type == OP_RV2HV ||
3211 curop->op_type == OP_RV2GV) {
3212 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3215 else if (curop->op_type == OP_PADSV ||
3216 curop->op_type == OP_PADAV ||
3217 curop->op_type == OP_PADHV ||
3218 curop->op_type == OP_PADANY) {
3221 else if (curop->op_type == OP_PUSHRE)
3222 ; /* Okay here, dangerous in newASSIGNOP */
3232 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3233 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3234 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3235 prepend_elem(o->op_type, scalar(repl), o);
3238 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3239 pm->op_pmflags |= PMf_MAYBE_CONST;
3240 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3242 NewOp(1101, rcop, 1, LOGOP);
3243 rcop->op_type = OP_SUBSTCONT;
3244 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3245 rcop->op_first = scalar(repl);
3246 rcop->op_flags |= OPf_KIDS;
3247 rcop->op_private = 1;
3250 /* establish postfix order */
3251 rcop->op_next = LINKLIST(repl);
3252 repl->op_next = (OP*)rcop;
3254 pm->op_pmreplroot = scalar((OP*)rcop);
3255 pm->op_pmreplstart = LINKLIST(rcop);
3264 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3267 NewOp(1101, svop, 1, SVOP);
3268 svop->op_type = type;
3269 svop->op_ppaddr = PL_ppaddr[type];
3271 svop->op_next = (OP*)svop;
3272 svop->op_flags = flags;
3273 if (PL_opargs[type] & OA_RETSCALAR)
3275 if (PL_opargs[type] & OA_TARGET)
3276 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3277 return CHECKOP(type, svop);
3281 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3284 NewOp(1101, padop, 1, PADOP);
3285 padop->op_type = type;
3286 padop->op_ppaddr = PL_ppaddr[type];
3287 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3288 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3289 PL_curpad[padop->op_padix] = sv;
3291 padop->op_next = (OP*)padop;
3292 padop->op_flags = flags;
3293 if (PL_opargs[type] & OA_RETSCALAR)
3295 if (PL_opargs[type] & OA_TARGET)
3296 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3297 return CHECKOP(type, padop);
3301 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3305 return newPADOP(type, flags, SvREFCNT_inc(gv));
3307 return newSVOP(type, flags, SvREFCNT_inc(gv));
3312 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3315 NewOp(1101, pvop, 1, PVOP);
3316 pvop->op_type = type;
3317 pvop->op_ppaddr = PL_ppaddr[type];
3319 pvop->op_next = (OP*)pvop;
3320 pvop->op_flags = flags;
3321 if (PL_opargs[type] & OA_RETSCALAR)
3323 if (PL_opargs[type] & OA_TARGET)
3324 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3325 return CHECKOP(type, pvop);
3329 Perl_package(pTHX_ OP *o)
3333 save_hptr(&PL_curstash);
3334 save_item(PL_curstname);
3339 name = SvPV(sv, len);
3340 PL_curstash = gv_stashpvn(name,len,TRUE);
3341 sv_setpvn(PL_curstname, name, len);
3345 deprecate("\"package\" with no arguments");
3346 sv_setpv(PL_curstname,"<none>");
3347 PL_curstash = Nullhv;
3349 PL_hints |= HINT_BLOCK_SCOPE;
3350 PL_copline = NOLINE;
3355 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3360 char *packname = Nullch;
3364 if (id->op_type != OP_CONST)
3365 Perl_croak(aTHX_ "Module name must be constant");
3369 if (version != Nullop) {
3370 SV *vesv = ((SVOP*)version)->op_sv;
3372 if (arg == Nullop && !SvNIOKp(vesv)) {
3379 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3380 Perl_croak(aTHX_ "Version number must be constant number");
3382 /* Make copy of id so we don't free it twice */
3383 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3385 /* Fake up a method call to VERSION */
3386 meth = newSVpvn("VERSION",7);
3387 sv_upgrade(meth, SVt_PVIV);
3388 (void)SvIOK_on(meth);
3389 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3390 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3391 append_elem(OP_LIST,
3392 prepend_elem(OP_LIST, pack, list(version)),
3393 newSVOP(OP_METHOD_NAMED, 0, meth)));
3397 /* Fake up an import/unimport */
3398 if (arg && arg->op_type == OP_STUB)
3399 imop = arg; /* no import on explicit () */
3400 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3401 imop = Nullop; /* use 5.0; */
3406 /* Make copy of id so we don't free it twice */
3407 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3409 /* Fake up a method call to import/unimport */
3410 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3411 (void)SvUPGRADE(meth, SVt_PVIV);
3412 (void)SvIOK_on(meth);
3413 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3414 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3415 append_elem(OP_LIST,
3416 prepend_elem(OP_LIST, pack, list(arg)),
3417 newSVOP(OP_METHOD_NAMED, 0, meth)));
3420 if (ckWARN(WARN_MISC) &&
3421 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3422 SvPOK(packsv = ((SVOP*)id)->op_sv))
3424 /* BEGIN will free the ops, so we need to make a copy */
3425 packlen = SvCUR(packsv);
3426 packname = savepvn(SvPVX(packsv), packlen);
3429 /* Fake up the BEGIN {}, which does its thing immediately. */
3431 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3434 append_elem(OP_LINESEQ,
3435 append_elem(OP_LINESEQ,
3436 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3437 newSTATEOP(0, Nullch, veop)),
3438 newSTATEOP(0, Nullch, imop) ));
3441 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3442 Perl_warner(aTHX_ WARN_MISC,
3443 "Package `%s' not found "
3444 "(did you use the incorrect case?)", packname);
3449 PL_hints |= HINT_BLOCK_SCOPE;
3450 PL_copline = NOLINE;
3455 =head1 Embedding Functions
3457 =for apidoc load_module
3459 Loads the module whose name is pointed to by the string part of name.
3460 Note that the actual module name, not its filename, should be given.
3461 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3462 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3463 (or 0 for no flags). ver, if specified, provides version semantics
3464 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3465 arguments can be used to specify arguments to the module's import()
3466 method, similar to C<use Foo::Bar VERSION LIST>.
3471 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3474 va_start(args, ver);
3475 vload_module(flags, name, ver, &args);
3479 #ifdef PERL_IMPLICIT_CONTEXT
3481 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3485 va_start(args, ver);
3486 vload_module(flags, name, ver, &args);
3492 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3494 OP *modname, *veop, *imop;
3496 modname = newSVOP(OP_CONST, 0, name);
3497 modname->op_private |= OPpCONST_BARE;
3499 veop = newSVOP(OP_CONST, 0, ver);
3503 if (flags & PERL_LOADMOD_NOIMPORT) {
3504 imop = sawparens(newNULLLIST());
3506 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3507 imop = va_arg(*args, OP*);
3512 sv = va_arg(*args, SV*);
3514 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3515 sv = va_arg(*args, SV*);
3519 line_t ocopline = PL_copline;
3520 int oexpect = PL_expect;
3522 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3523 veop, modname, imop);
3524 PL_expect = oexpect;
3525 PL_copline = ocopline;
3530 Perl_dofile(pTHX_ OP *term)
3535 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3536 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3537 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3539 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3540 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3541 append_elem(OP_LIST, term,
3542 scalar(newUNOP(OP_RV2CV, 0,
3547 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3553 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3555 return newBINOP(OP_LSLICE, flags,
3556 list(force_list(subscript)),
3557 list(force_list(listval)) );
3561 S_list_assignment(pTHX_ register OP *o)
3566 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3567 o = cUNOPo->op_first;
3569 if (o->op_type == OP_COND_EXPR) {
3570 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3571 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3576 yyerror("Assignment to both a list and a scalar");
3580 if (o->op_type == OP_LIST &&
3581 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3582 o->op_private & OPpLVAL_INTRO)
3585 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3586 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3587 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3590 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3593 if (o->op_type == OP_RV2SV)
3600 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3605 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3606 return newLOGOP(optype, 0,
3607 mod(scalar(left), optype),
3608 newUNOP(OP_SASSIGN, 0, scalar(right)));
3611 return newBINOP(optype, OPf_STACKED,
3612 mod(scalar(left), optype), scalar(right));
3616 if (list_assignment(left)) {
3620 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3621 left = mod(left, OP_AASSIGN);
3629 curop = list(force_list(left));
3630 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3631 o->op_private = 0 | (flags >> 8);
3632 for (curop = ((LISTOP*)curop)->op_first;
3633 curop; curop = curop->op_sibling)
3635 if (curop->op_type == OP_RV2HV &&
3636 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3637 o->op_private |= OPpASSIGN_HASH;
3641 if (!(left->op_private & OPpLVAL_INTRO)) {
3644 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3645 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3646 if (curop->op_type == OP_GV) {
3647 GV *gv = cGVOPx_gv(curop);
3648 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3650 SvCUR(gv) = PL_generation;
3652 else if (curop->op_type == OP_PADSV ||
3653 curop->op_type == OP_PADAV ||
3654 curop->op_type == OP_PADHV ||
3655 curop->op_type == OP_PADANY) {
3656 SV **svp = AvARRAY(PL_comppad_name);
3657 SV *sv = svp[curop->op_targ];
3658 if (SvCUR(sv) == PL_generation)
3660 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3662 else if (curop->op_type == OP_RV2CV)
3664 else if (curop->op_type == OP_RV2SV ||
3665 curop->op_type == OP_RV2AV ||
3666 curop->op_type == OP_RV2HV ||
3667 curop->op_type == OP_RV2GV) {
3668 if (lastop->op_type != OP_GV) /* funny deref? */
3671 else if (curop->op_type == OP_PUSHRE) {
3672 if (((PMOP*)curop)->op_pmreplroot) {
3674 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3676 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3678 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3680 SvCUR(gv) = PL_generation;
3689 o->op_private |= OPpASSIGN_COMMON;
3691 if (right && right->op_type == OP_SPLIT) {
3693 if ((tmpop = ((LISTOP*)right)->op_first) &&
3694 tmpop->op_type == OP_PUSHRE)
3696 PMOP *pm = (PMOP*)tmpop;
3697 if (left->op_type == OP_RV2AV &&
3698 !(left->op_private & OPpLVAL_INTRO) &&
3699 !(o->op_private & OPpASSIGN_COMMON) )
3701 tmpop = ((UNOP*)left)->op_first;
3702 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3704 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3705 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3707 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3708 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3710 pm->op_pmflags |= PMf_ONCE;
3711 tmpop = cUNOPo->op_first; /* to list (nulled) */
3712 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3713 tmpop->op_sibling = Nullop; /* don't free split */
3714 right->op_next = tmpop->op_next; /* fix starting loc */
3715 op_free(o); /* blow off assign */
3716 right->op_flags &= ~OPf_WANT;
3717 /* "I don't know and I don't care." */
3722 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3723 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3725 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3727 sv_setiv(sv, PL_modcount+1);
3735 right = newOP(OP_UNDEF, 0);
3736 if (right->op_type == OP_READLINE) {
3737 right->op_flags |= OPf_STACKED;
3738 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3741 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3742 o = newBINOP(OP_SASSIGN, flags,
3743 scalar(right), mod(scalar(left), OP_SASSIGN) );
3755 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3757 U32 seq = intro_my();
3760 NewOp(1101, cop, 1, COP);
3761 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3762 cop->op_type = OP_DBSTATE;
3763 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3766 cop->op_type = OP_NEXTSTATE;
3767 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3769 cop->op_flags = flags;
3770 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3772 cop->op_private |= NATIVE_HINTS;
3774 PL_compiling.op_private = cop->op_private;
3775 cop->op_next = (OP*)cop;
3778 cop->cop_label = label;
3779 PL_hints |= HINT_BLOCK_SCOPE;
3782 cop->cop_arybase = PL_curcop->cop_arybase;
3783 if (specialWARN(PL_curcop->cop_warnings))
3784 cop->cop_warnings = PL_curcop->cop_warnings ;
3786 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3787 if (specialCopIO(PL_curcop->cop_io))
3788 cop->cop_io = PL_curcop->cop_io;
3790 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3793 if (PL_copline == NOLINE)
3794 CopLINE_set(cop, CopLINE(PL_curcop));
3796 CopLINE_set(cop, PL_copline);
3797 PL_copline = NOLINE;
3800 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3802 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3804 CopSTASH_set(cop, PL_curstash);
3806 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3807 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3808 if (svp && *svp != &PL_sv_undef ) {
3809 (void)SvIOK_on(*svp);
3810 SvIVX(*svp) = PTR2IV(cop);
3814 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3817 /* "Introduce" my variables to visible status. */
3825 if (! PL_min_intro_pending)
3826 return PL_cop_seqmax;
3828 svp = AvARRAY(PL_comppad_name);
3829 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3830 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3831 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3832 SvNVX(sv) = (NV)PL_cop_seqmax;
3835 PL_min_intro_pending = 0;
3836 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3837 return PL_cop_seqmax++;
3841 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3843 return new_logop(type, flags, &first, &other);
3847 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3851 OP *first = *firstp;
3852 OP *other = *otherp;
3854 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3855 return newBINOP(type, flags, scalar(first), scalar(other));
3857 scalarboolean(first);
3858 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3859 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3860 if (type == OP_AND || type == OP_OR) {
3866 first = *firstp = cUNOPo->op_first;
3868 first->op_next = o->op_next;
3869 cUNOPo->op_first = Nullop;
3873 if (first->op_type == OP_CONST) {
3874 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3875 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3876 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3887 else if (first->op_type == OP_WANTARRAY) {
3893 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3894 OP *k1 = ((UNOP*)first)->op_first;
3895 OP *k2 = k1->op_sibling;
3897 switch (first->op_type)
3900 if (k2 && k2->op_type == OP_READLINE
3901 && (k2->op_flags & OPf_STACKED)
3902 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3904 warnop = k2->op_type;
3909 if (k1->op_type == OP_READDIR
3910 || k1->op_type == OP_GLOB
3911 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3912 || k1->op_type == OP_EACH)
3914 warnop = ((k1->op_type == OP_NULL)
3915 ? k1->op_targ : k1->op_type);
3920 line_t oldline = CopLINE(PL_curcop);
3921 CopLINE_set(PL_curcop, PL_copline);
3922 Perl_warner(aTHX_ WARN_MISC,
3923 "Value of %s%s can be \"0\"; test with defined()",
3925 ((warnop == OP_READLINE || warnop == OP_GLOB)
3926 ? " construct" : "() operator"));
3927 CopLINE_set(PL_curcop, oldline);
3934 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3935 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3937 NewOp(1101, logop, 1, LOGOP);
3939 logop->op_type = type;
3940 logop->op_ppaddr = PL_ppaddr[type];
3941 logop->op_first = first;
3942 logop->op_flags = flags | OPf_KIDS;
3943 logop->op_other = LINKLIST(other);
3944 logop->op_private = 1 | (flags >> 8);
3946 /* establish postfix order */
3947 logop->op_next = LINKLIST(first);
3948 first->op_next = (OP*)logop;
3949 first->op_sibling = other;
3951 o = newUNOP(OP_NULL, 0, (OP*)logop);
3958 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3965 return newLOGOP(OP_AND, 0, first, trueop);
3967 return newLOGOP(OP_OR, 0, first, falseop);
3969 scalarboolean(first);
3970 if (first->op_type == OP_CONST) {
3971 if (SvTRUE(((SVOP*)first)->op_sv)) {
3982 else if (first->op_type == OP_WANTARRAY) {
3986 NewOp(1101, logop, 1, LOGOP);
3987 logop->op_type = OP_COND_EXPR;
3988 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3989 logop->op_first = first;
3990 logop->op_flags = flags | OPf_KIDS;
3991 logop->op_private = 1 | (flags >> 8);
3992 logop->op_other = LINKLIST(trueop);
3993 logop->op_next = LINKLIST(falseop);
3996 /* establish postfix order */
3997 start = LINKLIST(first);
3998 first->op_next = (OP*)logop;
4000 first->op_sibling = trueop;
4001 trueop->op_sibling = falseop;
4002 o = newUNOP(OP_NULL, 0, (OP*)logop);
4004 trueop->op_next = falseop->op_next = o;
4011 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4019 NewOp(1101, range, 1, LOGOP);
4021 range->op_type = OP_RANGE;
4022 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4023 range->op_first = left;
4024 range->op_flags = OPf_KIDS;
4025 leftstart = LINKLIST(left);
4026 range->op_other = LINKLIST(right);
4027 range->op_private = 1 | (flags >> 8);
4029 left->op_sibling = right;
4031 range->op_next = (OP*)range;
4032 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4033 flop = newUNOP(OP_FLOP, 0, flip);
4034 o = newUNOP(OP_NULL, 0, flop);
4036 range->op_next = leftstart;
4038 left->op_next = flip;
4039 right->op_next = flop;
4041 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4042 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4043 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4044 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4046 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4047 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4050 if (!flip->op_private || !flop->op_private)
4051 linklist(o); /* blow off optimizer unless constant */
4057 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4061 int once = block && block->op_flags & OPf_SPECIAL &&
4062 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4065 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4066 return block; /* do {} while 0 does once */
4067 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4068 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4069 expr = newUNOP(OP_DEFINED, 0,
4070 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4071 } else if (expr->op_flags & OPf_KIDS) {
4072 OP *k1 = ((UNOP*)expr)->op_first;
4073 OP *k2 = (k1) ? k1->op_sibling : NULL;
4074 switch (expr->op_type) {
4076 if (k2 && k2->op_type == OP_READLINE
4077 && (k2->op_flags & OPf_STACKED)
4078 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4079 expr = newUNOP(OP_DEFINED, 0, expr);
4083 if (k1->op_type == OP_READDIR
4084 || k1->op_type == OP_GLOB
4085 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4086 || k1->op_type == OP_EACH)
4087 expr = newUNOP(OP_DEFINED, 0, expr);
4093 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4094 o = new_logop(OP_AND, 0, &expr, &listop);
4097 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4099 if (once && o != listop)
4100 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4103 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4105 o->op_flags |= flags;
4107 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4112 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4120 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4121 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4122 expr = newUNOP(OP_DEFINED, 0,
4123 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4124 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4125 OP *k1 = ((UNOP*)expr)->op_first;
4126 OP *k2 = (k1) ? k1->op_sibling : NULL;
4127 switch (expr->op_type) {
4129 if (k2 && k2->op_type == OP_READLINE
4130 && (k2->op_flags & OPf_STACKED)
4131 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4132 expr = newUNOP(OP_DEFINED, 0, expr);
4136 if (k1->op_type == OP_READDIR
4137 || k1->op_type == OP_GLOB
4138 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4139 || k1->op_type == OP_EACH)
4140 expr = newUNOP(OP_DEFINED, 0, expr);
4146 block = newOP(OP_NULL, 0);
4148 block = scope(block);
4152 next = LINKLIST(cont);
4155 OP *unstack = newOP(OP_UNSTACK, 0);
4158 cont = append_elem(OP_LINESEQ, cont, unstack);
4159 if ((line_t)whileline != NOLINE) {
4160 PL_copline = whileline;
4161 cont = append_elem(OP_LINESEQ, cont,
4162 newSTATEOP(0, Nullch, Nullop));
4166 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4167 redo = LINKLIST(listop);
4170 PL_copline = whileline;
4172 o = new_logop(OP_AND, 0, &expr, &listop);
4173 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4174 op_free(expr); /* oops, it's a while (0) */
4176 return Nullop; /* listop already freed by new_logop */
4179 ((LISTOP*)listop)->op_last->op_next =
4180 (o == listop ? redo : LINKLIST(o));
4186 NewOp(1101,loop,1,LOOP);
4187 loop->op_type = OP_ENTERLOOP;
4188 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4189 loop->op_private = 0;
4190 loop->op_next = (OP*)loop;
4193 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4195 loop->op_redoop = redo;
4196 loop->op_lastop = o;
4197 o->op_private |= loopflags;
4200 loop->op_nextop = next;
4202 loop->op_nextop = o;
4204 o->op_flags |= flags;
4205 o->op_private |= (flags >> 8);
4210 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4218 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4219 sv->op_type = OP_RV2GV;
4220 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4222 else if (sv->op_type == OP_PADSV) { /* private variable */
4223 padoff = sv->op_targ;
4228 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4229 padoff = sv->op_targ;
4231 iterflags |= OPf_SPECIAL;
4236 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4239 #ifdef USE_5005THREADS
4240 padoff = find_threadsv("_");
4241 iterflags |= OPf_SPECIAL;
4243 sv = newGVOP(OP_GV, 0, PL_defgv);
4246 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4247 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4248 iterflags |= OPf_STACKED;
4250 else if (expr->op_type == OP_NULL &&
4251 (expr->op_flags & OPf_KIDS) &&
4252 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4254 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4255 * set the STACKED flag to indicate that these values are to be
4256 * treated as min/max values by 'pp_iterinit'.
4258 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4259 LOGOP* range = (LOGOP*) flip->op_first;
4260 OP* left = range->op_first;
4261 OP* right = left->op_sibling;
4264 range->op_flags &= ~OPf_KIDS;
4265 range->op_first = Nullop;
4267 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4268 listop->op_first->op_next = range->op_next;
4269 left->op_next = range->op_other;
4270 right->op_next = (OP*)listop;
4271 listop->op_next = listop->op_first;
4274 expr = (OP*)(listop);
4276 iterflags |= OPf_STACKED;
4279 expr = mod(force_list(expr), OP_GREPSTART);
4283 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4284 append_elem(OP_LIST, expr, scalar(sv))));
4285 assert(!loop->op_next);
4286 #ifdef PL_OP_SLAB_ALLOC
4289 NewOp(1234,tmp,1,LOOP);
4290 Copy(loop,tmp,1,LOOP);
4294 Renew(loop, 1, LOOP);
4296 loop->op_targ = padoff;
4297 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4298 PL_copline = forline;
4299 return newSTATEOP(0, label, wop);
4303 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4308 if (type != OP_GOTO || label->op_type == OP_CONST) {
4309 /* "last()" means "last" */
4310 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4311 o = newOP(type, OPf_SPECIAL);
4313 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4314 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4320 if (label->op_type == OP_ENTERSUB)
4321 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4322 o = newUNOP(type, OPf_STACKED, label);
4324 PL_hints |= HINT_BLOCK_SCOPE;
4329 Perl_cv_undef(pTHX_ CV *cv)
4331 #ifdef USE_5005THREADS
4333 MUTEX_DESTROY(CvMUTEXP(cv));
4334 Safefree(CvMUTEXP(cv));
4337 #endif /* USE_5005THREADS */
4340 if (CvFILE(cv) && !CvXSUB(cv)) {
4341 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4342 Safefree(CvFILE(cv));
4347 if (!CvXSUB(cv) && CvROOT(cv)) {
4348 #ifdef USE_5005THREADS
4349 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4350 Perl_croak(aTHX_ "Can't undef active subroutine");
4353 Perl_croak(aTHX_ "Can't undef active subroutine");
4354 #endif /* USE_5005THREADS */
4357 SAVEVPTR(PL_curpad);
4360 op_free(CvROOT(cv));
4361 CvROOT(cv) = Nullop;
4364 SvPOK_off((SV*)cv); /* forget prototype */
4366 /* Since closure prototypes have the same lifetime as the containing
4367 * CV, they don't hold a refcount on the outside CV. This avoids
4368 * the refcount loop between the outer CV (which keeps a refcount to
4369 * the closure prototype in the pad entry for pp_anoncode()) and the
4370 * closure prototype, and the ensuing memory leak. --GSAR */
4371 if (!CvANON(cv) || CvCLONED(cv))
4372 SvREFCNT_dec(CvOUTSIDE(cv));
4373 CvOUTSIDE(cv) = Nullcv;
4375 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4378 if (CvPADLIST(cv)) {
4379 /* may be during global destruction */
4380 if (SvREFCNT(CvPADLIST(cv))) {
4381 I32 i = AvFILLp(CvPADLIST(cv));
4383 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4384 SV* sv = svp ? *svp : Nullsv;
4387 if (sv == (SV*)PL_comppad_name)
4388 PL_comppad_name = Nullav;
4389 else if (sv == (SV*)PL_comppad) {
4390 PL_comppad = Nullav;
4391 PL_curpad = Null(SV**);
4395 SvREFCNT_dec((SV*)CvPADLIST(cv));
4397 CvPADLIST(cv) = Nullav;
4405 #ifdef DEBUG_CLOSURES
4407 S_cv_dump(pTHX_ CV *cv)
4410 CV *outside = CvOUTSIDE(cv);
4411 AV* padlist = CvPADLIST(cv);
4418 PerlIO_printf(Perl_debug_log,
4419 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4421 (CvANON(cv) ? "ANON"
4422 : (cv == PL_main_cv) ? "MAIN"
4423 : CvUNIQUE(cv) ? "UNIQUE"
4424 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4427 : CvANON(outside) ? "ANON"
4428 : (outside == PL_main_cv) ? "MAIN"
4429 : CvUNIQUE(outside) ? "UNIQUE"
4430 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4435 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4436 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4437 pname = AvARRAY(pad_name);
4438 ppad = AvARRAY(pad);
4440 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4441 if (SvPOK(pname[ix]))
4442 PerlIO_printf(Perl_debug_log,
4443 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4444 (int)ix, PTR2UV(ppad[ix]),
4445 SvFAKE(pname[ix]) ? "FAKE " : "",
4447 (IV)I_32(SvNVX(pname[ix])),
4450 #endif /* DEBUGGING */
4452 #endif /* DEBUG_CLOSURES */
4455 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4459 AV* protopadlist = CvPADLIST(proto);
4460 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4461 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4462 SV** pname = AvARRAY(protopad_name);
4463 SV** ppad = AvARRAY(protopad);
4464 I32 fname = AvFILLp(protopad_name);
4465 I32 fpad = AvFILLp(protopad);
4469 assert(!CvUNIQUE(proto));
4473 SAVESPTR(PL_comppad_name);
4474 SAVESPTR(PL_compcv);
4476 cv = PL_compcv = (CV*)NEWSV(1104,0);
4477 sv_upgrade((SV *)cv, SvTYPE(proto));
4478 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4481 #ifdef USE_5005THREADS
4482 New(666, CvMUTEXP(cv), 1, perl_mutex);
4483 MUTEX_INIT(CvMUTEXP(cv));
4485 #endif /* USE_5005THREADS */
4487 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4488 : savepv(CvFILE(proto));
4490 CvFILE(cv) = CvFILE(proto);
4492 CvGV(cv) = CvGV(proto);
4493 CvSTASH(cv) = CvSTASH(proto);
4494 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4495 CvSTART(cv) = CvSTART(proto);
4497 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4500 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4502 PL_comppad_name = newAV();
4503 for (ix = fname; ix >= 0; ix--)
4504 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4506 PL_comppad = newAV();
4508 comppadlist = newAV();
4509 AvREAL_off(comppadlist);
4510 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4511 av_store(comppadlist, 1, (SV*)PL_comppad);
4512 CvPADLIST(cv) = comppadlist;
4513 av_fill(PL_comppad, AvFILLp(protopad));
4514 PL_curpad = AvARRAY(PL_comppad);
4516 av = newAV(); /* will be @_ */
4518 av_store(PL_comppad, 0, (SV*)av);
4519 AvFLAGS(av) = AVf_REIFY;
4521 for (ix = fpad; ix > 0; ix--) {
4522 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4523 if (namesv && namesv != &PL_sv_undef) {
4524 char *name = SvPVX(namesv); /* XXX */
4525 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4526 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4527 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4529 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4531 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4533 else { /* our own lexical */
4536 /* anon code -- we'll come back for it */
4537 sv = SvREFCNT_inc(ppad[ix]);
4539 else if (*name == '@')
4541 else if (*name == '%')
4550 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4551 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4554 SV* sv = NEWSV(0,0);
4560 /* Now that vars are all in place, clone nested closures. */
4562 for (ix = fpad; ix > 0; ix--) {
4563 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4565 && namesv != &PL_sv_undef
4566 && !(SvFLAGS(namesv) & SVf_FAKE)
4567 && *SvPVX(namesv) == '&'
4568 && CvCLONE(ppad[ix]))
4570 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4571 SvREFCNT_dec(ppad[ix]);
4574 PL_curpad[ix] = (SV*)kid;
4578 #ifdef DEBUG_CLOSURES
4579 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4581 PerlIO_printf(Perl_debug_log, " from:\n");
4583 PerlIO_printf(Perl_debug_log, " to:\n");
4590 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4592 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4594 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4601 Perl_cv_clone(pTHX_ CV *proto)
4604 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4605 cv = cv_clone2(proto, CvOUTSIDE(proto));
4606 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4611 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4613 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4614 SV* msg = sv_newmortal();
4618 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4619 sv_setpv(msg, "Prototype mismatch:");
4621 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4623 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4624 sv_catpv(msg, " vs ");
4626 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4628 sv_catpv(msg, "none");
4629 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4633 static void const_sv_xsub(pTHX_ CV* cv);
4637 =head1 Optree Manipulation Functions
4639 =for apidoc cv_const_sv
4641 If C<cv> is a constant sub eligible for inlining. returns the constant
4642 value returned by the sub. Otherwise, returns NULL.
4644 Constant subs can be created with C<newCONSTSUB> or as described in
4645 L<perlsub/"Constant Functions">.
4650 Perl_cv_const_sv(pTHX_ CV *cv)
4652 if (!cv || !CvCONST(cv))
4654 return (SV*)CvXSUBANY(cv).any_ptr;
4658 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4665 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4666 o = cLISTOPo->op_first->op_sibling;
4668 for (; o; o = o->op_next) {
4669 OPCODE type = o->op_type;
4671 if (sv && o->op_next == o)
4673 if (o->op_next != o) {
4674 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4676 if (type == OP_DBSTATE)
4679 if (type == OP_LEAVESUB || type == OP_RETURN)
4683 if (type == OP_CONST && cSVOPo->op_sv)
4685 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4686 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4687 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4691 /* We get here only from cv_clone2() while creating a closure.
4692 Copy the const value here instead of in cv_clone2 so that
4693 SvREADONLY_on doesn't lead to problems when leaving
4698 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4710 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4720 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4724 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4726 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4730 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4736 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4741 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4742 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4743 SV *sv = sv_newmortal();
4744 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4745 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4750 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4751 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4761 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4762 maximum a prototype before. */
4763 if (SvTYPE(gv) > SVt_NULL) {
4764 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4765 && ckWARN_d(WARN_PROTOTYPE))
4767 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4769 cv_ckproto((CV*)gv, NULL, ps);
4772 sv_setpv((SV*)gv, ps);
4774 sv_setiv((SV*)gv, -1);
4775 SvREFCNT_dec(PL_compcv);
4776 cv = PL_compcv = NULL;
4777 PL_sub_generation++;
4781 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4783 #ifdef GV_UNIQUE_CHECK
4784 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4785 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4789 if (!block || !ps || *ps || attrs)
4792 const_sv = op_const_sv(block, Nullcv);
4795 bool exists = CvROOT(cv) || CvXSUB(cv);
4797 #ifdef GV_UNIQUE_CHECK
4798 if (exists && GvUNIQUE(gv)) {
4799 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4803 /* if the subroutine doesn't exist and wasn't pre-declared
4804 * with a prototype, assume it will be AUTOLOADed,
4805 * skipping the prototype check
4807 if (exists || SvPOK(cv))
4808 cv_ckproto(cv, gv, ps);
4809 /* already defined (or promised)? */
4810 if (exists || GvASSUMECV(gv)) {
4811 if (!block && !attrs) {
4812 /* just a "sub foo;" when &foo is already defined */
4813 SAVEFREESV(PL_compcv);
4816 /* ahem, death to those who redefine active sort subs */
4817 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4818 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4820 if (ckWARN(WARN_REDEFINE)
4822 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4824 line_t oldline = CopLINE(PL_curcop);
4825 if (PL_copline != NOLINE)
4826 CopLINE_set(PL_curcop, PL_copline);
4827 Perl_warner(aTHX_ WARN_REDEFINE,
4828 CvCONST(cv) ? "Constant subroutine %s redefined"
4829 : "Subroutine %s redefined", name);
4830 CopLINE_set(PL_curcop, oldline);
4838 SvREFCNT_inc(const_sv);
4840 assert(!CvROOT(cv) && !CvCONST(cv));
4841 sv_setpv((SV*)cv, ""); /* prototype is "" */
4842 CvXSUBANY(cv).any_ptr = const_sv;
4843 CvXSUB(cv) = const_sv_xsub;
4848 cv = newCONSTSUB(NULL, name, const_sv);
4851 SvREFCNT_dec(PL_compcv);
4853 PL_sub_generation++;
4860 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4861 * before we clobber PL_compcv.
4865 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4866 stash = GvSTASH(CvGV(cv));
4867 else if (CvSTASH(cv))
4868 stash = CvSTASH(cv);
4870 stash = PL_curstash;
4873 /* possibly about to re-define existing subr -- ignore old cv */
4874 rcv = (SV*)PL_compcv;
4875 if (name && GvSTASH(gv))
4876 stash = GvSTASH(gv);
4878 stash = PL_curstash;
4880 apply_attrs(stash, rcv, attrs, FALSE);
4882 if (cv) { /* must reuse cv if autoloaded */
4884 /* got here with just attrs -- work done, so bug out */
4885 SAVEFREESV(PL_compcv);
4889 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4890 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4891 CvOUTSIDE(PL_compcv) = 0;
4892 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4893 CvPADLIST(PL_compcv) = 0;
4894 /* inner references to PL_compcv must be fixed up ... */
4896 AV *padlist = CvPADLIST(cv);
4897 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4898 AV *comppad = (AV*)AvARRAY(padlist)[1];
4899 SV **namepad = AvARRAY(comppad_name);
4900 SV **curpad = AvARRAY(comppad);
4901 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4902 SV *namesv = namepad[ix];
4903 if (namesv && namesv != &PL_sv_undef
4904 && *SvPVX(namesv) == '&')
4906 CV *innercv = (CV*)curpad[ix];
4907 if (CvOUTSIDE(innercv) == PL_compcv) {
4908 CvOUTSIDE(innercv) = cv;
4909 if (!CvANON(innercv) || CvCLONED(innercv)) {
4910 (void)SvREFCNT_inc(cv);
4911 SvREFCNT_dec(PL_compcv);
4917 /* ... before we throw it away */
4918 SvREFCNT_dec(PL_compcv);
4919 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4920 ++PL_sub_generation;
4927 PL_sub_generation++;
4931 CvFILE_set_from_cop(cv, PL_curcop);
4932 CvSTASH(cv) = PL_curstash;
4933 #ifdef USE_5005THREADS
4935 if (!CvMUTEXP(cv)) {
4936 New(666, CvMUTEXP(cv), 1, perl_mutex);
4937 MUTEX_INIT(CvMUTEXP(cv));
4939 #endif /* USE_5005THREADS */
4942 sv_setpv((SV*)cv, ps);
4944 if (PL_error_count) {
4948 char *s = strrchr(name, ':');
4950 if (strEQ(s, "BEGIN")) {
4952 "BEGIN not safe after errors--compilation aborted";
4953 if (PL_in_eval & EVAL_KEEPERR)
4954 Perl_croak(aTHX_ not_safe);
4956 /* force display of errors found but not reported */
4957 sv_catpv(ERRSV, not_safe);
4958 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4966 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4967 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4970 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4971 mod(scalarseq(block), OP_LEAVESUBLV));
4974 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4976 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4977 OpREFCNT_set(CvROOT(cv), 1);
4978 CvSTART(cv) = LINKLIST(CvROOT(cv));
4979 CvROOT(cv)->op_next = 0;
4980 CALL_PEEP(CvSTART(cv));
4982 /* now that optimizer has done its work, adjust pad values */
4984 SV **namep = AvARRAY(PL_comppad_name);
4985 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4988 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4991 * The only things that a clonable function needs in its
4992 * pad are references to outer lexicals and anonymous subs.
4993 * The rest are created anew during cloning.
4995 if (!((namesv = namep[ix]) != Nullsv &&
4996 namesv != &PL_sv_undef &&
4998 *SvPVX(namesv) == '&')))
5000 SvREFCNT_dec(PL_curpad[ix]);
5001 PL_curpad[ix] = Nullsv;
5004 assert(!CvCONST(cv));
5005 if (ps && !*ps && op_const_sv(block, cv))
5009 AV *av = newAV(); /* Will be @_ */
5011 av_store(PL_comppad, 0, (SV*)av);
5012 AvFLAGS(av) = AVf_REIFY;
5014 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5015 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5017 if (!SvPADMY(PL_curpad[ix]))
5018 SvPADTMP_on(PL_curpad[ix]);
5022 /* If a potential closure prototype, don't keep a refcount on outer CV.
5023 * This is okay as the lifetime of the prototype is tied to the
5024 * lifetime of the outer CV. Avoids memory leak due to reference
5027 SvREFCNT_dec(CvOUTSIDE(cv));
5029 if (name || aname) {
5031 char *tname = (name ? name : aname);
5033 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5034 SV *sv = NEWSV(0,0);
5035 SV *tmpstr = sv_newmortal();
5036 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5040 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5042 (long)PL_subline, (long)CopLINE(PL_curcop));
5043 gv_efullname3(tmpstr, gv, Nullch);
5044 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5045 hv = GvHVn(db_postponed);
5046 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5047 && (pcv = GvCV(db_postponed)))
5053 call_sv((SV*)pcv, G_DISCARD);
5057 if ((s = strrchr(tname,':')))
5062 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5065 if (strEQ(s, "BEGIN")) {
5066 I32 oldscope = PL_scopestack_ix;
5068 SAVECOPFILE(&PL_compiling);
5069 SAVECOPLINE(&PL_compiling);
5072 PL_beginav = newAV();
5073 DEBUG_x( dump_sub(gv) );
5074 av_push(PL_beginav, (SV*)cv);
5075 GvCV(gv) = 0; /* cv has been hijacked */
5076 call_list(oldscope, PL_beginav);
5078 PL_curcop = &PL_compiling;
5079 PL_compiling.op_private = PL_hints;
5082 else if (strEQ(s, "END") && !PL_error_count) {
5085 DEBUG_x( dump_sub(gv) );
5086 av_unshift(PL_endav, 1);
5087 av_store(PL_endav, 0, (SV*)cv);
5088 GvCV(gv) = 0; /* cv has been hijacked */
5090 else if (strEQ(s, "CHECK") && !PL_error_count) {
5092 PL_checkav = newAV();
5093 DEBUG_x( dump_sub(gv) );
5094 if (PL_main_start && ckWARN(WARN_VOID))
5095 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5096 av_unshift(PL_checkav, 1);
5097 av_store(PL_checkav, 0, (SV*)cv);
5098 GvCV(gv) = 0; /* cv has been hijacked */
5100 else if (strEQ(s, "INIT") && !PL_error_count) {
5102 PL_initav = newAV();
5103 DEBUG_x( dump_sub(gv) );
5104 if (PL_main_start && ckWARN(WARN_VOID))
5105 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5106 av_push(PL_initav, (SV*)cv);
5107 GvCV(gv) = 0; /* cv has been hijacked */
5112 PL_copline = NOLINE;
5117 /* XXX unsafe for threads if eval_owner isn't held */
5119 =for apidoc newCONSTSUB
5121 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5122 eligible for inlining at compile-time.
5128 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5134 SAVECOPLINE(PL_curcop);
5135 CopLINE_set(PL_curcop, PL_copline);
5138 PL_hints &= ~HINT_BLOCK_SCOPE;
5141 SAVESPTR(PL_curstash);
5142 SAVECOPSTASH(PL_curcop);
5143 PL_curstash = stash;
5145 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5147 CopSTASH(PL_curcop) = stash;
5151 cv = newXS(name, const_sv_xsub, __FILE__);
5152 CvXSUBANY(cv).any_ptr = sv;
5154 sv_setpv((SV*)cv, ""); /* prototype is "" */
5162 =for apidoc U||newXS
5164 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5170 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5172 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5175 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5177 /* just a cached method */
5181 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5182 /* already defined (or promised) */
5183 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5184 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5185 line_t oldline = CopLINE(PL_curcop);
5186 if (PL_copline != NOLINE)
5187 CopLINE_set(PL_curcop, PL_copline);
5188 Perl_warner(aTHX_ WARN_REDEFINE,
5189 CvCONST(cv) ? "Constant subroutine %s redefined"
5190 : "Subroutine %s redefined"
5192 CopLINE_set(PL_curcop, oldline);
5199 if (cv) /* must reuse cv if autoloaded */
5202 cv = (CV*)NEWSV(1105,0);
5203 sv_upgrade((SV *)cv, SVt_PVCV);
5207 PL_sub_generation++;
5211 #ifdef USE_5005THREADS
5212 New(666, CvMUTEXP(cv), 1, perl_mutex);
5213 MUTEX_INIT(CvMUTEXP(cv));
5215 #endif /* USE_5005THREADS */
5216 (void)gv_fetchfile(filename);
5217 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5218 an external constant string */
5219 CvXSUB(cv) = subaddr;
5222 char *s = strrchr(name,':');
5228 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5231 if (strEQ(s, "BEGIN")) {
5233 PL_beginav = newAV();
5234 av_push(PL_beginav, (SV*)cv);
5235 GvCV(gv) = 0; /* cv has been hijacked */
5237 else if (strEQ(s, "END")) {
5240 av_unshift(PL_endav, 1);
5241 av_store(PL_endav, 0, (SV*)cv);
5242 GvCV(gv) = 0; /* cv has been hijacked */
5244 else if (strEQ(s, "CHECK")) {
5246 PL_checkav = newAV();
5247 if (PL_main_start && ckWARN(WARN_VOID))
5248 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5249 av_unshift(PL_checkav, 1);
5250 av_store(PL_checkav, 0, (SV*)cv);
5251 GvCV(gv) = 0; /* cv has been hijacked */
5253 else if (strEQ(s, "INIT")) {
5255 PL_initav = newAV();
5256 if (PL_main_start && ckWARN(WARN_VOID))
5257 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5258 av_push(PL_initav, (SV*)cv);
5259 GvCV(gv) = 0; /* cv has been hijacked */
5270 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5279 name = SvPVx(cSVOPo->op_sv, n_a);
5282 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5283 #ifdef GV_UNIQUE_CHECK
5285 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5289 if ((cv = GvFORM(gv))) {
5290 if (ckWARN(WARN_REDEFINE)) {
5291 line_t oldline = CopLINE(PL_curcop);
5292 if (PL_copline != NOLINE)
5293 CopLINE_set(PL_curcop, PL_copline);
5294 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5295 CopLINE_set(PL_curcop, oldline);
5302 CvFILE_set_from_cop(cv, PL_curcop);
5304 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5305 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5306 SvPADTMP_on(PL_curpad[ix]);
5309 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5310 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5311 OpREFCNT_set(CvROOT(cv), 1);
5312 CvSTART(cv) = LINKLIST(CvROOT(cv));
5313 CvROOT(cv)->op_next = 0;
5314 CALL_PEEP(CvSTART(cv));
5316 PL_copline = NOLINE;
5321 Perl_newANONLIST(pTHX_ OP *o)
5323 return newUNOP(OP_REFGEN, 0,
5324 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5328 Perl_newANONHASH(pTHX_ OP *o)
5330 return newUNOP(OP_REFGEN, 0,
5331 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5335 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5337 return newANONATTRSUB(floor, proto, Nullop, block);
5341 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5343 return newUNOP(OP_REFGEN, 0,
5344 newSVOP(OP_ANONCODE, 0,
5345 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5349 Perl_oopsAV(pTHX_ OP *o)
5351 switch (o->op_type) {
5353 o->op_type = OP_PADAV;
5354 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5355 return ref(o, OP_RV2AV);
5358 o->op_type = OP_RV2AV;
5359 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5364 if (ckWARN_d(WARN_INTERNAL))
5365 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5372 Perl_oopsHV(pTHX_ OP *o)
5374 switch (o->op_type) {
5377 o->op_type = OP_PADHV;
5378 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5379 return ref(o, OP_RV2HV);
5383 o->op_type = OP_RV2HV;
5384 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5389 if (ckWARN_d(WARN_INTERNAL))
5390 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5397 Perl_newAVREF(pTHX_ OP *o)
5399 if (o->op_type == OP_PADANY) {
5400 o->op_type = OP_PADAV;
5401 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5404 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5405 && ckWARN(WARN_DEPRECATED)) {
5406 Perl_warner(aTHX_ WARN_DEPRECATED,
5407 "Using an array as a reference is deprecated");
5409 return newUNOP(OP_RV2AV, 0, scalar(o));
5413 Perl_newGVREF(pTHX_ I32 type, OP *o)
5415 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5416 return newUNOP(OP_NULL, 0, o);
5417 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5421 Perl_newHVREF(pTHX_ OP *o)
5423 if (o->op_type == OP_PADANY) {
5424 o->op_type = OP_PADHV;
5425 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5428 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5429 && ckWARN(WARN_DEPRECATED)) {
5430 Perl_warner(aTHX_ WARN_DEPRECATED,
5431 "Using a hash as a reference is deprecated");
5433 return newUNOP(OP_RV2HV, 0, scalar(o));
5437 Perl_oopsCV(pTHX_ OP *o)
5439 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5445 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5447 return newUNOP(OP_RV2CV, flags, scalar(o));
5451 Perl_newSVREF(pTHX_ OP *o)
5453 if (o->op_type == OP_PADANY) {
5454 o->op_type = OP_PADSV;
5455 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5458 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5459 o->op_flags |= OPpDONE_SVREF;
5462 return newUNOP(OP_RV2SV, 0, scalar(o));
5465 /* Check routines. */
5468 Perl_ck_anoncode(pTHX_ OP *o)
5473 name = NEWSV(1106,0);
5474 sv_upgrade(name, SVt_PVNV);
5475 sv_setpvn(name, "&", 1);
5478 ix = pad_alloc(o->op_type, SVs_PADMY);
5479 av_store(PL_comppad_name, ix, name);
5480 av_store(PL_comppad, ix, cSVOPo->op_sv);
5481 SvPADMY_on(cSVOPo->op_sv);
5482 cSVOPo->op_sv = Nullsv;
5483 cSVOPo->op_targ = ix;
5488 Perl_ck_bitop(pTHX_ OP *o)
5490 o->op_private = PL_hints;
5495 Perl_ck_concat(pTHX_ OP *o)
5497 if (cUNOPo->op_first->op_type == OP_CONCAT)
5498 o->op_flags |= OPf_STACKED;
5503 Perl_ck_spair(pTHX_ OP *o)
5505 if (o->op_flags & OPf_KIDS) {
5508 OPCODE type = o->op_type;
5509 o = modkids(ck_fun(o), type);
5510 kid = cUNOPo->op_first;
5511 newop = kUNOP->op_first->op_sibling;
5513 (newop->op_sibling ||
5514 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5515 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5516 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5520 op_free(kUNOP->op_first);
5521 kUNOP->op_first = newop;
5523 o->op_ppaddr = PL_ppaddr[++o->op_type];
5528 Perl_ck_delete(pTHX_ OP *o)
5532 if (o->op_flags & OPf_KIDS) {
5533 OP *kid = cUNOPo->op_first;
5534 switch (kid->op_type) {
5536 o->op_flags |= OPf_SPECIAL;
5539 o->op_private |= OPpSLICE;
5542 o->op_flags |= OPf_SPECIAL;
5547 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5556 Perl_ck_die(pTHX_ OP *o)
5559 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5565 Perl_ck_eof(pTHX_ OP *o)
5567 I32 type = o->op_type;
5569 if (o->op_flags & OPf_KIDS) {
5570 if (cLISTOPo->op_first->op_type == OP_STUB) {
5572 o = newUNOP(type, OPf_SPECIAL,
5573 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5581 Perl_ck_eval(pTHX_ OP *o)
5583 PL_hints |= HINT_BLOCK_SCOPE;
5584 if (o->op_flags & OPf_KIDS) {
5585 SVOP *kid = (SVOP*)cUNOPo->op_first;
5588 o->op_flags &= ~OPf_KIDS;
5591 else if (kid->op_type == OP_LINESEQ) {
5594 kid->op_next = o->op_next;
5595 cUNOPo->op_first = 0;
5598 NewOp(1101, enter, 1, LOGOP);
5599 enter->op_type = OP_ENTERTRY;
5600 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5601 enter->op_private = 0;
5603 /* establish postfix order */
5604 enter->op_next = (OP*)enter;
5606 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5607 o->op_type = OP_LEAVETRY;
5608 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5609 enter->op_other = o;
5617 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5619 o->op_targ = (PADOFFSET)PL_hints;
5624 Perl_ck_exit(pTHX_ OP *o)
5627 HV *table = GvHV(PL_hintgv);
5629 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5630 if (svp && *svp && SvTRUE(*svp))
5631 o->op_private |= OPpEXIT_VMSISH;
5633 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5639 Perl_ck_exec(pTHX_ OP *o)
5642 if (o->op_flags & OPf_STACKED) {
5644 kid = cUNOPo->op_first->op_sibling;
5645 if (kid->op_type == OP_RV2GV)
5654 Perl_ck_exists(pTHX_ OP *o)
5657 if (o->op_flags & OPf_KIDS) {
5658 OP *kid = cUNOPo->op_first;
5659 if (kid->op_type == OP_ENTERSUB) {
5660 (void) ref(kid, o->op_type);
5661 if (kid->op_type != OP_RV2CV && !PL_error_count)
5662 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5664 o->op_private |= OPpEXISTS_SUB;
5666 else if (kid->op_type == OP_AELEM)
5667 o->op_flags |= OPf_SPECIAL;
5668 else if (kid->op_type != OP_HELEM)
5669 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5678 Perl_ck_gvconst(pTHX_ register OP *o)
5680 o = fold_constants(o);
5681 if (o->op_type == OP_CONST)
5688 Perl_ck_rvconst(pTHX_ register OP *o)
5690 SVOP *kid = (SVOP*)cUNOPo->op_first;
5692 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5693 if (kid->op_type == OP_CONST) {
5697 SV *kidsv = kid->op_sv;
5700 /* Is it a constant from cv_const_sv()? */
5701 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5702 SV *rsv = SvRV(kidsv);
5703 int svtype = SvTYPE(rsv);
5704 char *badtype = Nullch;
5706 switch (o->op_type) {
5708 if (svtype > SVt_PVMG)
5709 badtype = "a SCALAR";
5712 if (svtype != SVt_PVAV)
5713 badtype = "an ARRAY";
5716 if (svtype != SVt_PVHV) {
5717 if (svtype == SVt_PVAV) { /* pseudohash? */
5718 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5719 if (ksv && SvROK(*ksv)
5720 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5729 if (svtype != SVt_PVCV)
5734 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5737 name = SvPV(kidsv, n_a);
5738 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5739 char *badthing = Nullch;
5740 switch (o->op_type) {
5742 badthing = "a SCALAR";
5745 badthing = "an ARRAY";
5748 badthing = "a HASH";
5753 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5757 * This is a little tricky. We only want to add the symbol if we
5758 * didn't add it in the lexer. Otherwise we get duplicate strict
5759 * warnings. But if we didn't add it in the lexer, we must at
5760 * least pretend like we wanted to add it even if it existed before,
5761 * or we get possible typo warnings. OPpCONST_ENTERED says
5762 * whether the lexer already added THIS instance of this symbol.
5764 iscv = (o->op_type == OP_RV2CV) * 2;
5766 gv = gv_fetchpv(name,
5767 iscv | !(kid->op_private & OPpCONST_ENTERED),
5770 : o->op_type == OP_RV2SV
5772 : o->op_type == OP_RV2AV
5774 : o->op_type == OP_RV2HV
5777 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5779 kid->op_type = OP_GV;
5780 SvREFCNT_dec(kid->op_sv);
5782 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5783 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5784 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5786 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5788 kid->op_sv = SvREFCNT_inc(gv);
5790 kid->op_private = 0;
5791 kid->op_ppaddr = PL_ppaddr[OP_GV];
5798 Perl_ck_ftst(pTHX_ OP *o)
5800 I32 type = o->op_type;
5802 if (o->op_flags & OPf_REF) {
5805 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5806 SVOP *kid = (SVOP*)cUNOPo->op_first;
5808 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5810 OP *newop = newGVOP(type, OPf_REF,
5811 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5818 if (type == OP_FTTTY)
5819 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5822 o = newUNOP(type, 0, newDEFSVOP());
5828 Perl_ck_fun(pTHX_ OP *o)
5834 int type = o->op_type;
5835 register I32 oa = PL_opargs[type] >> OASHIFT;
5837 if (o->op_flags & OPf_STACKED) {
5838 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5841 return no_fh_allowed(o);
5844 if (o->op_flags & OPf_KIDS) {
5846 tokid = &cLISTOPo->op_first;
5847 kid = cLISTOPo->op_first;
5848 if (kid->op_type == OP_PUSHMARK ||
5849 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5851 tokid = &kid->op_sibling;
5852 kid = kid->op_sibling;
5854 if (!kid && PL_opargs[type] & OA_DEFGV)
5855 *tokid = kid = newDEFSVOP();
5859 sibl = kid->op_sibling;
5862 /* list seen where single (scalar) arg expected? */
5863 if (numargs == 1 && !(oa >> 4)
5864 && kid->op_type == OP_LIST && type != OP_SCALAR)
5866 return too_many_arguments(o,PL_op_desc[type]);
5879 if ((type == OP_PUSH || type == OP_UNSHIFT)
5880 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5881 Perl_warner(aTHX_ WARN_SYNTAX,
5882 "Useless use of %s with no values",
5885 if (kid->op_type == OP_CONST &&
5886 (kid->op_private & OPpCONST_BARE))
5888 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5889 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5890 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5891 if (ckWARN(WARN_DEPRECATED))
5892 Perl_warner(aTHX_ WARN_DEPRECATED,
5893 "Array @%s missing the @ in argument %"IVdf" of %s()",
5894 name, (IV)numargs, PL_op_desc[type]);
5897 kid->op_sibling = sibl;
5900 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5901 bad_type(numargs, "array", PL_op_desc[type], kid);
5905 if (kid->op_type == OP_CONST &&
5906 (kid->op_private & OPpCONST_BARE))
5908 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5909 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5910 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5911 if (ckWARN(WARN_DEPRECATED))
5912 Perl_warner(aTHX_ WARN_DEPRECATED,
5913 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5914 name, (IV)numargs, PL_op_desc[type]);
5917 kid->op_sibling = sibl;
5920 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5921 bad_type(numargs, "hash", PL_op_desc[type], kid);
5926 OP *newop = newUNOP(OP_NULL, 0, kid);
5927 kid->op_sibling = 0;
5929 newop->op_next = newop;
5931 kid->op_sibling = sibl;
5936 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5937 if (kid->op_type == OP_CONST &&
5938 (kid->op_private & OPpCONST_BARE))
5940 OP *newop = newGVOP(OP_GV, 0,
5941 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5943 if (kid == cLISTOPo->op_last)
5944 cLISTOPo->op_last = newop;
5948 else if (kid->op_type == OP_READLINE) {
5949 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5950 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5953 I32 flags = OPf_SPECIAL;
5957 /* is this op a FH constructor? */
5958 if (is_handle_constructor(o,numargs)) {
5959 char *name = Nullch;
5963 /* Set a flag to tell rv2gv to vivify
5964 * need to "prove" flag does not mean something
5965 * else already - NI-S 1999/05/07
5968 if (kid->op_type == OP_PADSV) {
5969 SV **namep = av_fetch(PL_comppad_name,
5971 if (namep && *namep)
5972 name = SvPV(*namep, len);
5974 else if (kid->op_type == OP_RV2SV
5975 && kUNOP->op_first->op_type == OP_GV)
5977 GV *gv = cGVOPx_gv(kUNOP->op_first);
5979 len = GvNAMELEN(gv);
5981 else if (kid->op_type == OP_AELEM
5982 || kid->op_type == OP_HELEM)
5984 name = "__ANONIO__";
5990 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5991 namesv = PL_curpad[targ];
5992 (void)SvUPGRADE(namesv, SVt_PV);
5994 sv_setpvn(namesv, "$", 1);
5995 sv_catpvn(namesv, name, len);
5998 kid->op_sibling = 0;
5999 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6000 kid->op_targ = targ;
6001 kid->op_private |= priv;
6003 kid->op_sibling = sibl;
6009 mod(scalar(kid), type);
6013 tokid = &kid->op_sibling;
6014 kid = kid->op_sibling;
6016 o->op_private |= numargs;
6018 return too_many_arguments(o,OP_DESC(o));
6021 else if (PL_opargs[type] & OA_DEFGV) {
6023 return newUNOP(type, 0, newDEFSVOP());
6027 while (oa & OA_OPTIONAL)
6029 if (oa && oa != OA_LIST)
6030 return too_few_arguments(o,OP_DESC(o));
6036 Perl_ck_glob(pTHX_ OP *o)
6041 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6042 append_elem(OP_GLOB, o, newDEFSVOP());
6044 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6045 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6047 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6050 #if !defined(PERL_EXTERNAL_GLOB)
6051 /* XXX this can be tightened up and made more failsafe. */
6055 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
6057 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6058 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6059 GvCV(gv) = GvCV(glob_gv);
6060 SvREFCNT_inc((SV*)GvCV(gv));
6061 GvIMPORTED_CV_on(gv);
6064 #endif /* PERL_EXTERNAL_GLOB */
6066 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6067 append_elem(OP_GLOB, o,
6068 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6069 o->op_type = OP_LIST;
6070 o->op_ppaddr = PL_ppaddr[OP_LIST];
6071 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6072 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6073 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6074 append_elem(OP_LIST, o,
6075 scalar(newUNOP(OP_RV2CV, 0,
6076 newGVOP(OP_GV, 0, gv)))));
6077 o = newUNOP(OP_NULL, 0, ck_subr(o));
6078 o->op_targ = OP_GLOB; /* hint at what it used to be */
6081 gv = newGVgen("main");
6083 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6089 Perl_ck_grep(pTHX_ OP *o)
6093 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6095 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6096 NewOp(1101, gwop, 1, LOGOP);
6098 if (o->op_flags & OPf_STACKED) {
6101 kid = cLISTOPo->op_first->op_sibling;
6102 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6105 kid->op_next = (OP*)gwop;
6106 o->op_flags &= ~OPf_STACKED;
6108 kid = cLISTOPo->op_first->op_sibling;
6109 if (type == OP_MAPWHILE)
6116 kid = cLISTOPo->op_first->op_sibling;
6117 if (kid->op_type != OP_NULL)
6118 Perl_croak(aTHX_ "panic: ck_grep");
6119 kid = kUNOP->op_first;
6121 gwop->op_type = type;
6122 gwop->op_ppaddr = PL_ppaddr[type];
6123 gwop->op_first = listkids(o);
6124 gwop->op_flags |= OPf_KIDS;
6125 gwop->op_private = 1;
6126 gwop->op_other = LINKLIST(kid);
6127 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6128 kid->op_next = (OP*)gwop;
6130 kid = cLISTOPo->op_first->op_sibling;
6131 if (!kid || !kid->op_sibling)
6132 return too_few_arguments(o,OP_DESC(o));
6133 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6134 mod(kid, OP_GREPSTART);
6140 Perl_ck_index(pTHX_ OP *o)
6142 if (o->op_flags & OPf_KIDS) {
6143 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6145 kid = kid->op_sibling; /* get past "big" */
6146 if (kid && kid->op_type == OP_CONST)
6147 fbm_compile(((SVOP*)kid)->op_sv, 0);
6153 Perl_ck_lengthconst(pTHX_ OP *o)
6155 /* XXX length optimization goes here */
6160 Perl_ck_lfun(pTHX_ OP *o)
6162 OPCODE type = o->op_type;
6163 return modkids(ck_fun(o), type);
6167 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6169 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6170 switch (cUNOPo->op_first->op_type) {
6172 /* This is needed for
6173 if (defined %stash::)
6174 to work. Do not break Tk.
6176 break; /* Globals via GV can be undef */
6178 case OP_AASSIGN: /* Is this a good idea? */
6179 Perl_warner(aTHX_ WARN_DEPRECATED,
6180 "defined(@array) is deprecated");
6181 Perl_warner(aTHX_ WARN_DEPRECATED,
6182 "\t(Maybe you should just omit the defined()?)\n");
6185 /* This is needed for
6186 if (defined %stash::)
6187 to work. Do not break Tk.
6189 break; /* Globals via GV can be undef */
6191 Perl_warner(aTHX_ WARN_DEPRECATED,
6192 "defined(%%hash) is deprecated");
6193 Perl_warner(aTHX_ WARN_DEPRECATED,
6194 "\t(Maybe you should just omit the defined()?)\n");
6205 Perl_ck_rfun(pTHX_ OP *o)
6207 OPCODE type = o->op_type;
6208 return refkids(ck_fun(o), type);
6212 Perl_ck_listiob(pTHX_ OP *o)
6216 kid = cLISTOPo->op_first;
6219 kid = cLISTOPo->op_first;
6221 if (kid->op_type == OP_PUSHMARK)
6222 kid = kid->op_sibling;
6223 if (kid && o->op_flags & OPf_STACKED)
6224 kid = kid->op_sibling;
6225 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6226 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6227 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6228 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6229 cLISTOPo->op_first->op_sibling = kid;
6230 cLISTOPo->op_last = kid;
6231 kid = kid->op_sibling;
6236 append_elem(o->op_type, o, newDEFSVOP());
6242 Perl_ck_sassign(pTHX_ OP *o)
6244 OP *kid = cLISTOPo->op_first;
6245 /* has a disposable target? */
6246 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6247 && !(kid->op_flags & OPf_STACKED)
6248 /* Cannot steal the second time! */
6249 && !(kid->op_private & OPpTARGET_MY))
6251 OP *kkid = kid->op_sibling;
6253 /* Can just relocate the target. */
6254 if (kkid && kkid->op_type == OP_PADSV
6255 && !(kkid->op_private & OPpLVAL_INTRO))
6257 kid->op_targ = kkid->op_targ;
6259 /* Now we do not need PADSV and SASSIGN. */
6260 kid->op_sibling = o->op_sibling; /* NULL */
6261 cLISTOPo->op_first = NULL;
6264 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6272 Perl_ck_match(pTHX_ OP *o)
6274 o->op_private |= OPpRUNTIME;
6279 Perl_ck_method(pTHX_ OP *o)
6281 OP *kid = cUNOPo->op_first;
6282 if (kid->op_type == OP_CONST) {
6283 SV* sv = kSVOP->op_sv;
6284 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6286 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6287 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6290 kSVOP->op_sv = Nullsv;
6292 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6301 Perl_ck_null(pTHX_ OP *o)
6307 Perl_ck_open(pTHX_ OP *o)
6309 HV *table = GvHV(PL_hintgv);
6313 svp = hv_fetch(table, "open_IN", 7, FALSE);
6315 mode = mode_from_discipline(*svp);
6316 if (mode & O_BINARY)
6317 o->op_private |= OPpOPEN_IN_RAW;
6318 else if (mode & O_TEXT)
6319 o->op_private |= OPpOPEN_IN_CRLF;
6322 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6324 mode = mode_from_discipline(*svp);
6325 if (mode & O_BINARY)
6326 o->op_private |= OPpOPEN_OUT_RAW;
6327 else if (mode & O_TEXT)
6328 o->op_private |= OPpOPEN_OUT_CRLF;
6331 if (o->op_type == OP_BACKTICK)
6337 Perl_ck_repeat(pTHX_ OP *o)
6339 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6340 o->op_private |= OPpREPEAT_DOLIST;
6341 cBINOPo->op_first = force_list(cBINOPo->op_first);
6349 Perl_ck_require(pTHX_ OP *o)
6353 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6354 SVOP *kid = (SVOP*)cUNOPo->op_first;
6356 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6358 for (s = SvPVX(kid->op_sv); *s; s++) {
6359 if (*s == ':' && s[1] == ':') {
6361 Move(s+2, s+1, strlen(s+2)+1, char);
6362 --SvCUR(kid->op_sv);
6365 if (SvREADONLY(kid->op_sv)) {
6366 SvREADONLY_off(kid->op_sv);
6367 sv_catpvn(kid->op_sv, ".pm", 3);
6368 SvREADONLY_on(kid->op_sv);
6371 sv_catpvn(kid->op_sv, ".pm", 3);
6375 /* handle override, if any */
6376 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6377 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6378 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6380 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6381 OP *kid = cUNOPo->op_first;
6382 cUNOPo->op_first = 0;
6384 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6385 append_elem(OP_LIST, kid,
6386 scalar(newUNOP(OP_RV2CV, 0,
6395 Perl_ck_return(pTHX_ OP *o)
6398 if (CvLVALUE(PL_compcv)) {
6399 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6400 mod(kid, OP_LEAVESUBLV);
6407 Perl_ck_retarget(pTHX_ OP *o)
6409 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6416 Perl_ck_select(pTHX_ OP *o)
6419 if (o->op_flags & OPf_KIDS) {
6420 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6421 if (kid && kid->op_sibling) {
6422 o->op_type = OP_SSELECT;
6423 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6425 return fold_constants(o);
6429 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6430 if (kid && kid->op_type == OP_RV2GV)
6431 kid->op_private &= ~HINT_STRICT_REFS;
6436 Perl_ck_shift(pTHX_ OP *o)
6438 I32 type = o->op_type;
6440 if (!(o->op_flags & OPf_KIDS)) {
6444 #ifdef USE_5005THREADS
6445 if (!CvUNIQUE(PL_compcv)) {
6446 argop = newOP(OP_PADAV, OPf_REF);
6447 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6450 argop = newUNOP(OP_RV2AV, 0,
6451 scalar(newGVOP(OP_GV, 0,
6452 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6455 argop = newUNOP(OP_RV2AV, 0,
6456 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6457 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6458 #endif /* USE_5005THREADS */
6459 return newUNOP(type, 0, scalar(argop));
6461 return scalar(modkids(ck_fun(o), type));
6465 Perl_ck_sort(pTHX_ OP *o)
6469 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6471 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6472 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6474 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6476 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6478 if (kid->op_type == OP_SCOPE) {
6482 else if (kid->op_type == OP_LEAVE) {
6483 if (o->op_type == OP_SORT) {
6484 op_null(kid); /* wipe out leave */
6487 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6488 if (k->op_next == kid)
6490 /* don't descend into loops */
6491 else if (k->op_type == OP_ENTERLOOP
6492 || k->op_type == OP_ENTERITER)
6494 k = cLOOPx(k)->op_lastop;
6499 kid->op_next = 0; /* just disconnect the leave */
6500 k = kLISTOP->op_first;
6505 if (o->op_type == OP_SORT) {
6506 /* provide scalar context for comparison function/block */
6512 o->op_flags |= OPf_SPECIAL;
6514 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6517 firstkid = firstkid->op_sibling;
6520 /* provide list context for arguments */
6521 if (o->op_type == OP_SORT)
6528 S_simplify_sort(pTHX_ OP *o)
6530 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6534 if (!(o->op_flags & OPf_STACKED))
6536 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6537 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6538 kid = kUNOP->op_first; /* get past null */
6539 if (kid->op_type != OP_SCOPE)
6541 kid = kLISTOP->op_last; /* get past scope */
6542 switch(kid->op_type) {
6550 k = kid; /* remember this node*/
6551 if (kBINOP->op_first->op_type != OP_RV2SV)
6553 kid = kBINOP->op_first; /* get past cmp */
6554 if (kUNOP->op_first->op_type != OP_GV)
6556 kid = kUNOP->op_first; /* get past rv2sv */
6558 if (GvSTASH(gv) != PL_curstash)
6560 if (strEQ(GvNAME(gv), "a"))
6562 else if (strEQ(GvNAME(gv), "b"))
6566 kid = k; /* back to cmp */
6567 if (kBINOP->op_last->op_type != OP_RV2SV)
6569 kid = kBINOP->op_last; /* down to 2nd arg */
6570 if (kUNOP->op_first->op_type != OP_GV)
6572 kid = kUNOP->op_first; /* get past rv2sv */
6574 if (GvSTASH(gv) != PL_curstash
6576 ? strNE(GvNAME(gv), "a")
6577 : strNE(GvNAME(gv), "b")))
6579 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6581 o->op_private |= OPpSORT_REVERSE;
6582 if (k->op_type == OP_NCMP)
6583 o->op_private |= OPpSORT_NUMERIC;
6584 if (k->op_type == OP_I_NCMP)
6585 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6586 kid = cLISTOPo->op_first->op_sibling;
6587 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6588 op_free(kid); /* then delete it */
6592 Perl_ck_split(pTHX_ OP *o)
6596 if (o->op_flags & OPf_STACKED)
6597 return no_fh_allowed(o);
6599 kid = cLISTOPo->op_first;
6600 if (kid->op_type != OP_NULL)
6601 Perl_croak(aTHX_ "panic: ck_split");
6602 kid = kid->op_sibling;
6603 op_free(cLISTOPo->op_first);
6604 cLISTOPo->op_first = kid;
6606 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6607 cLISTOPo->op_last = kid; /* There was only one element previously */
6610 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6611 OP *sibl = kid->op_sibling;
6612 kid->op_sibling = 0;
6613 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6614 if (cLISTOPo->op_first == cLISTOPo->op_last)
6615 cLISTOPo->op_last = kid;
6616 cLISTOPo->op_first = kid;
6617 kid->op_sibling = sibl;
6620 kid->op_type = OP_PUSHRE;
6621 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6624 if (!kid->op_sibling)
6625 append_elem(OP_SPLIT, o, newDEFSVOP());
6627 kid = kid->op_sibling;
6630 if (!kid->op_sibling)
6631 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6633 kid = kid->op_sibling;
6636 if (kid->op_sibling)
6637 return too_many_arguments(o,OP_DESC(o));
6643 Perl_ck_join(pTHX_ OP *o)
6645 if (ckWARN(WARN_SYNTAX)) {
6646 OP *kid = cLISTOPo->op_first->op_sibling;
6647 if (kid && kid->op_type == OP_MATCH) {
6648 char *pmstr = "STRING";
6649 if (PM_GETRE(kPMOP))
6650 pmstr = PM_GETRE(kPMOP)->precomp;
6651 Perl_warner(aTHX_ WARN_SYNTAX,
6652 "/%s/ should probably be written as \"%s\"",
6660 Perl_ck_subr(pTHX_ OP *o)
6662 OP *prev = ((cUNOPo->op_first->op_sibling)
6663 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6664 OP *o2 = prev->op_sibling;
6671 I32 contextclass = 0;
6675 o->op_private |= OPpENTERSUB_HASTARG;
6676 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6677 if (cvop->op_type == OP_RV2CV) {
6679 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6680 op_null(cvop); /* disable rv2cv */
6681 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6682 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6683 GV *gv = cGVOPx_gv(tmpop);
6686 tmpop->op_private |= OPpEARLY_CV;
6687 else if (SvPOK(cv)) {
6688 namegv = CvANON(cv) ? gv : CvGV(cv);
6689 proto = SvPV((SV*)cv, n_a);
6693 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6694 if (o2->op_type == OP_CONST)
6695 o2->op_private &= ~OPpCONST_STRICT;
6696 else if (o2->op_type == OP_LIST) {
6697 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6698 if (o && o->op_type == OP_CONST)
6699 o->op_private &= ~OPpCONST_STRICT;
6702 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6703 if (PERLDB_SUB && PL_curstash != PL_debstash)
6704 o->op_private |= OPpENTERSUB_DB;
6705 while (o2 != cvop) {
6709 return too_many_arguments(o, gv_ename(namegv));
6727 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6729 arg == 1 ? "block or sub {}" : "sub {}",
6730 gv_ename(namegv), o2);
6733 /* '*' allows any scalar type, including bareword */
6736 if (o2->op_type == OP_RV2GV)
6737 goto wrapref; /* autoconvert GLOB -> GLOBref */
6738 else if (o2->op_type == OP_CONST)
6739 o2->op_private &= ~OPpCONST_STRICT;
6740 else if (o2->op_type == OP_ENTERSUB) {
6741 /* accidental subroutine, revert to bareword */
6742 OP *gvop = ((UNOP*)o2)->op_first;
6743 if (gvop && gvop->op_type == OP_NULL) {
6744 gvop = ((UNOP*)gvop)->op_first;
6746 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6749 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6750 (gvop = ((UNOP*)gvop)->op_first) &&
6751 gvop->op_type == OP_GV)
6753 GV *gv = cGVOPx_gv(gvop);
6754 OP *sibling = o2->op_sibling;
6755 SV *n = newSVpvn("",0);
6757 gv_fullname3(n, gv, "");
6758 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6759 sv_chop(n, SvPVX(n)+6);
6760 o2 = newSVOP(OP_CONST, 0, n);
6761 prev->op_sibling = o2;
6762 o2->op_sibling = sibling;
6778 if (contextclass++ == 0) {
6779 e = strchr(proto, ']');
6780 if (!e || e == proto)
6793 while (*--p != '[');
6794 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6795 gv_ename(namegv), o2);
6801 if (o2->op_type == OP_RV2GV)
6804 bad_type(arg, "symbol", gv_ename(namegv), o2);
6807 if (o2->op_type == OP_ENTERSUB)
6810 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6813 if (o2->op_type == OP_RV2SV ||
6814 o2->op_type == OP_PADSV ||
6815 o2->op_type == OP_HELEM ||
6816 o2->op_type == OP_AELEM ||
6817 o2->op_type == OP_THREADSV)
6820 bad_type(arg, "scalar", gv_ename(namegv), o2);
6823 if (o2->op_type == OP_RV2AV ||
6824 o2->op_type == OP_PADAV)
6827 bad_type(arg, "array", gv_ename(namegv), o2);
6830 if (o2->op_type == OP_RV2HV ||
6831 o2->op_type == OP_PADHV)
6834 bad_type(arg, "hash", gv_ename(namegv), o2);
6839 OP* sib = kid->op_sibling;
6840 kid->op_sibling = 0;
6841 o2 = newUNOP(OP_REFGEN, 0, kid);
6842 o2->op_sibling = sib;
6843 prev->op_sibling = o2;
6845 if (contextclass && e) {
6860 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6861 gv_ename(namegv), SvPV((SV*)cv, n_a));
6866 mod(o2, OP_ENTERSUB);
6868 o2 = o2->op_sibling;
6870 if (proto && !optional &&
6871 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6872 return too_few_arguments(o, gv_ename(namegv));
6877 Perl_ck_svconst(pTHX_ OP *o)
6879 SvREADONLY_on(cSVOPo->op_sv);
6884 Perl_ck_trunc(pTHX_ OP *o)
6886 if (o->op_flags & OPf_KIDS) {
6887 SVOP *kid = (SVOP*)cUNOPo->op_first;
6889 if (kid->op_type == OP_NULL)
6890 kid = (SVOP*)kid->op_sibling;
6891 if (kid && kid->op_type == OP_CONST &&
6892 (kid->op_private & OPpCONST_BARE))
6894 o->op_flags |= OPf_SPECIAL;
6895 kid->op_private &= ~OPpCONST_STRICT;
6902 Perl_ck_substr(pTHX_ OP *o)
6905 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6906 OP *kid = cLISTOPo->op_first;
6908 if (kid->op_type == OP_NULL)
6909 kid = kid->op_sibling;
6911 kid->op_flags |= OPf_MOD;
6917 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6920 Perl_peep(pTHX_ register OP *o)
6922 register OP* oldop = 0;
6925 if (!o || o->op_seq)
6929 SAVEVPTR(PL_curcop);
6930 for (; o; o = o->op_next) {
6936 switch (o->op_type) {
6940 PL_curcop = ((COP*)o); /* for warnings */
6941 o->op_seq = PL_op_seqmax++;
6945 if (cSVOPo->op_private & OPpCONST_STRICT)
6946 no_bareword_allowed(o);
6948 /* Relocate sv to the pad for thread safety.
6949 * Despite being a "constant", the SV is written to,
6950 * for reference counts, sv_upgrade() etc. */
6952 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6953 if (SvPADTMP(cSVOPo->op_sv)) {
6954 /* If op_sv is already a PADTMP then it is being used by
6955 * some pad, so make a copy. */
6956 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6957 SvREADONLY_on(PL_curpad[ix]);
6958 SvREFCNT_dec(cSVOPo->op_sv);
6961 SvREFCNT_dec(PL_curpad[ix]);
6962 SvPADTMP_on(cSVOPo->op_sv);
6963 PL_curpad[ix] = cSVOPo->op_sv;
6964 /* XXX I don't know how this isn't readonly already. */
6965 SvREADONLY_on(PL_curpad[ix]);
6967 cSVOPo->op_sv = Nullsv;
6971 o->op_seq = PL_op_seqmax++;
6975 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6976 if (o->op_next->op_private & OPpTARGET_MY) {
6977 if (o->op_flags & OPf_STACKED) /* chained concats */
6978 goto ignore_optimization;
6980 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6981 o->op_targ = o->op_next->op_targ;
6982 o->op_next->op_targ = 0;
6983 o->op_private |= OPpTARGET_MY;
6986 op_null(o->op_next);
6988 ignore_optimization:
6989 o->op_seq = PL_op_seqmax++;
6992 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6993 o->op_seq = PL_op_seqmax++;
6994 break; /* Scalar stub must produce undef. List stub is noop */
6998 if (o->op_targ == OP_NEXTSTATE
6999 || o->op_targ == OP_DBSTATE
7000 || o->op_targ == OP_SETSTATE)
7002 PL_curcop = ((COP*)o);
7004 /* XXX: We avoid setting op_seq here to prevent later calls
7005 to peep() from mistakenly concluding that optimisation
7006 has already occurred. This doesn't fix the real problem,
7007 though (See 20010220.007). AMS 20010719 */
7008 if (oldop && o->op_next) {
7009 oldop->op_next = o->op_next;
7017 if (oldop && o->op_next) {
7018 oldop->op_next = o->op_next;
7021 o->op_seq = PL_op_seqmax++;
7025 if (o->op_next->op_type == OP_RV2SV) {
7026 if (!(o->op_next->op_private & OPpDEREF)) {
7027 op_null(o->op_next);
7028 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7030 o->op_next = o->op_next->op_next;
7031 o->op_type = OP_GVSV;
7032 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7035 else if (o->op_next->op_type == OP_RV2AV) {
7036 OP* pop = o->op_next->op_next;
7038 if (pop && pop->op_type == OP_CONST &&
7039 (PL_op = pop->op_next) &&
7040 pop->op_next->op_type == OP_AELEM &&
7041 !(pop->op_next->op_private &
7042 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7043 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7048 op_null(o->op_next);
7049 op_null(pop->op_next);
7051 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7052 o->op_next = pop->op_next->op_next;
7053 o->op_type = OP_AELEMFAST;
7054 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7055 o->op_private = (U8)i;
7060 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7062 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7063 /* XXX could check prototype here instead of just carping */
7064 SV *sv = sv_newmortal();
7065 gv_efullname3(sv, gv, Nullch);
7066 Perl_warner(aTHX_ WARN_PROTOTYPE,
7067 "%s() called too early to check prototype",
7071 else if (o->op_next->op_type == OP_READLINE
7072 && o->op_next->op_next->op_type == OP_CONCAT
7073 && (o->op_next->op_next->op_flags & OPf_STACKED))
7075 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7076 o->op_type = OP_RCATLINE;
7077 o->op_flags |= OPf_STACKED;
7078 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7079 op_null(o->op_next->op_next);
7080 op_null(o->op_next);
7083 o->op_seq = PL_op_seqmax++;
7094 o->op_seq = PL_op_seqmax++;
7095 while (cLOGOP->op_other->op_type == OP_NULL)
7096 cLOGOP->op_other = cLOGOP->op_other->op_next;
7097 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7102 o->op_seq = PL_op_seqmax++;
7103 while (cLOOP->op_redoop->op_type == OP_NULL)
7104 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7105 peep(cLOOP->op_redoop);
7106 while (cLOOP->op_nextop->op_type == OP_NULL)
7107 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7108 peep(cLOOP->op_nextop);
7109 while (cLOOP->op_lastop->op_type == OP_NULL)
7110 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7111 peep(cLOOP->op_lastop);
7117 o->op_seq = PL_op_seqmax++;
7118 while (cPMOP->op_pmreplstart &&
7119 cPMOP->op_pmreplstart->op_type == OP_NULL)
7120 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7121 peep(cPMOP->op_pmreplstart);
7125 o->op_seq = PL_op_seqmax++;
7126 if (ckWARN(WARN_SYNTAX) && o->op_next
7127 && o->op_next->op_type == OP_NEXTSTATE) {
7128 if (o->op_next->op_sibling &&
7129 o->op_next->op_sibling->op_type != OP_EXIT &&
7130 o->op_next->op_sibling->op_type != OP_WARN &&
7131 o->op_next->op_sibling->op_type != OP_DIE) {
7132 line_t oldline = CopLINE(PL_curcop);
7134 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7135 Perl_warner(aTHX_ WARN_EXEC,
7136 "Statement unlikely to be reached");
7137 Perl_warner(aTHX_ WARN_EXEC,
7138 "\t(Maybe you meant system() when you said exec()?)\n");
7139 CopLINE_set(PL_curcop, oldline);
7148 SV **svp, **indsvp, *sv;
7153 o->op_seq = PL_op_seqmax++;
7155 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7158 /* Make the CONST have a shared SV */
7159 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7160 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7161 key = SvPV(sv, keylen);
7162 lexname = newSVpvn_share(key,
7163 SvUTF8(sv) ? -(I32)keylen : keylen,
7169 if ((o->op_private & (OPpLVAL_INTRO)))
7172 rop = (UNOP*)((BINOP*)o)->op_first;
7173 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7175 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7176 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7178 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7179 if (!fields || !GvHV(*fields))
7181 key = SvPV(*svp, keylen);
7182 indsvp = hv_fetch(GvHV(*fields), key,
7183 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7185 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7186 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7188 ind = SvIV(*indsvp);
7190 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7191 rop->op_type = OP_RV2AV;
7192 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7193 o->op_type = OP_AELEM;
7194 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7196 if (SvREADONLY(*svp))
7198 SvFLAGS(sv) |= (SvFLAGS(*svp)
7199 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7209 SV **svp, **indsvp, *sv;
7213 SVOP *first_key_op, *key_op;
7215 o->op_seq = PL_op_seqmax++;
7216 if ((o->op_private & (OPpLVAL_INTRO))
7217 /* I bet there's always a pushmark... */
7218 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7219 /* hmmm, no optimization if list contains only one key. */
7221 rop = (UNOP*)((LISTOP*)o)->op_last;
7222 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7224 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7225 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7227 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7228 if (!fields || !GvHV(*fields))
7230 /* Again guessing that the pushmark can be jumped over.... */
7231 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7232 ->op_first->op_sibling;
7233 /* Check that the key list contains only constants. */
7234 for (key_op = first_key_op; key_op;
7235 key_op = (SVOP*)key_op->op_sibling)
7236 if (key_op->op_type != OP_CONST)
7240 rop->op_type = OP_RV2AV;
7241 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7242 o->op_type = OP_ASLICE;
7243 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7244 for (key_op = first_key_op; key_op;
7245 key_op = (SVOP*)key_op->op_sibling) {
7246 svp = cSVOPx_svp(key_op);
7247 key = SvPV(*svp, keylen);
7248 indsvp = hv_fetch(GvHV(*fields), key,
7249 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7251 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7252 "in variable %s of type %s",
7253 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7255 ind = SvIV(*indsvp);
7257 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7259 if (SvREADONLY(*svp))
7261 SvFLAGS(sv) |= (SvFLAGS(*svp)
7262 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7270 o->op_seq = PL_op_seqmax++;
7280 char* Perl_custom_op_name(pTHX_ OP* o)
7282 IV index = PTR2IV(o->op_ppaddr);
7286 if (!PL_custom_op_names) /* This probably shouldn't happen */
7287 return PL_op_name[OP_CUSTOM];
7289 keysv = sv_2mortal(newSViv(index));
7291 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7293 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7295 return SvPV_nolen(HeVAL(he));
7298 char* Perl_custom_op_desc(pTHX_ OP* o)
7300 IV index = PTR2IV(o->op_ppaddr);
7304 if (!PL_custom_op_descs)
7305 return PL_op_desc[OP_CUSTOM];
7307 keysv = sv_2mortal(newSViv(index));
7309 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7311 return PL_op_desc[OP_CUSTOM];
7313 return SvPV_nolen(HeVAL(he));
7319 /* Efficient sub that returns a constant scalar value. */
7321 const_sv_xsub(pTHX_ CV* cv)
7326 Perl_croak(aTHX_ "usage: %s::%s()",
7327 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7331 ST(0) = (SV*)XSANY.any_ptr;