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;
3134 if (DO_UTF8(pat) || (PL_hints & HINT_UTF8))
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 (PL_hints & HINT_UTF8)
3143 pm->op_pmdynflags |= PMdf_UTF8;
3144 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3145 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3147 : OP_REGCMAYBE),0,expr);
3149 NewOp(1101, rcop, 1, LOGOP);
3150 rcop->op_type = OP_REGCOMP;
3151 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3152 rcop->op_first = scalar(expr);
3153 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3154 ? (OPf_SPECIAL | OPf_KIDS)
3156 rcop->op_private = 1;
3159 /* establish postfix order */
3160 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3162 rcop->op_next = expr;
3163 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3166 rcop->op_next = LINKLIST(expr);
3167 expr->op_next = (OP*)rcop;
3170 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3175 if (pm->op_pmflags & PMf_EVAL) {
3177 if (CopLINE(PL_curcop) < PL_multi_end)
3178 CopLINE_set(PL_curcop, PL_multi_end);
3180 #ifdef USE_5005THREADS
3181 else if (repl->op_type == OP_THREADSV
3182 && strchr("&`'123456789+",
3183 PL_threadsv_names[repl->op_targ]))
3187 #endif /* USE_5005THREADS */
3188 else if (repl->op_type == OP_CONST)
3192 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3193 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3194 #ifdef USE_5005THREADS
3195 if (curop->op_type == OP_THREADSV) {
3197 if (strchr("&`'123456789+", curop->op_private))
3201 if (curop->op_type == OP_GV) {
3202 GV *gv = cGVOPx_gv(curop);
3204 if (strchr("&`'123456789+", *GvENAME(gv)))
3207 #endif /* USE_5005THREADS */
3208 else if (curop->op_type == OP_RV2CV)
3210 else if (curop->op_type == OP_RV2SV ||
3211 curop->op_type == OP_RV2AV ||
3212 curop->op_type == OP_RV2HV ||
3213 curop->op_type == OP_RV2GV) {
3214 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3217 else if (curop->op_type == OP_PADSV ||
3218 curop->op_type == OP_PADAV ||
3219 curop->op_type == OP_PADHV ||
3220 curop->op_type == OP_PADANY) {
3223 else if (curop->op_type == OP_PUSHRE)
3224 ; /* Okay here, dangerous in newASSIGNOP */
3234 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3235 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3236 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3237 prepend_elem(o->op_type, scalar(repl), o);
3240 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3241 pm->op_pmflags |= PMf_MAYBE_CONST;
3242 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3244 NewOp(1101, rcop, 1, LOGOP);
3245 rcop->op_type = OP_SUBSTCONT;
3246 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3247 rcop->op_first = scalar(repl);
3248 rcop->op_flags |= OPf_KIDS;
3249 rcop->op_private = 1;
3252 /* establish postfix order */
3253 rcop->op_next = LINKLIST(repl);
3254 repl->op_next = (OP*)rcop;
3256 pm->op_pmreplroot = scalar((OP*)rcop);
3257 pm->op_pmreplstart = LINKLIST(rcop);
3266 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3269 NewOp(1101, svop, 1, SVOP);
3270 svop->op_type = type;
3271 svop->op_ppaddr = PL_ppaddr[type];
3273 svop->op_next = (OP*)svop;
3274 svop->op_flags = flags;
3275 if (PL_opargs[type] & OA_RETSCALAR)
3277 if (PL_opargs[type] & OA_TARGET)
3278 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3279 return CHECKOP(type, svop);
3283 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3286 NewOp(1101, padop, 1, PADOP);
3287 padop->op_type = type;
3288 padop->op_ppaddr = PL_ppaddr[type];
3289 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3290 SvREFCNT_dec(PL_curpad[padop->op_padix]);
3291 PL_curpad[padop->op_padix] = sv;
3293 padop->op_next = (OP*)padop;
3294 padop->op_flags = flags;
3295 if (PL_opargs[type] & OA_RETSCALAR)
3297 if (PL_opargs[type] & OA_TARGET)
3298 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3299 return CHECKOP(type, padop);
3303 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3307 return newPADOP(type, flags, SvREFCNT_inc(gv));
3309 return newSVOP(type, flags, SvREFCNT_inc(gv));
3314 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3317 NewOp(1101, pvop, 1, PVOP);
3318 pvop->op_type = type;
3319 pvop->op_ppaddr = PL_ppaddr[type];
3321 pvop->op_next = (OP*)pvop;
3322 pvop->op_flags = flags;
3323 if (PL_opargs[type] & OA_RETSCALAR)
3325 if (PL_opargs[type] & OA_TARGET)
3326 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3327 return CHECKOP(type, pvop);
3331 Perl_package(pTHX_ OP *o)
3335 save_hptr(&PL_curstash);
3336 save_item(PL_curstname);
3341 name = SvPV(sv, len);
3342 PL_curstash = gv_stashpvn(name,len,TRUE);
3343 sv_setpvn(PL_curstname, name, len);
3347 deprecate("\"package\" with no arguments");
3348 sv_setpv(PL_curstname,"<none>");
3349 PL_curstash = Nullhv;
3351 PL_hints |= HINT_BLOCK_SCOPE;
3352 PL_copline = NOLINE;
3357 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3362 char *packname = Nullch;
3366 if (id->op_type != OP_CONST)
3367 Perl_croak(aTHX_ "Module name must be constant");
3371 if (version != Nullop) {
3372 SV *vesv = ((SVOP*)version)->op_sv;
3374 if (arg == Nullop && !SvNIOKp(vesv)) {
3381 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3382 Perl_croak(aTHX_ "Version number must be constant number");
3384 /* Make copy of id so we don't free it twice */
3385 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3387 /* Fake up a method call to VERSION */
3388 meth = newSVpvn("VERSION",7);
3389 sv_upgrade(meth, SVt_PVIV);
3390 (void)SvIOK_on(meth);
3391 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3392 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3393 append_elem(OP_LIST,
3394 prepend_elem(OP_LIST, pack, list(version)),
3395 newSVOP(OP_METHOD_NAMED, 0, meth)));
3399 /* Fake up an import/unimport */
3400 if (arg && arg->op_type == OP_STUB)
3401 imop = arg; /* no import on explicit () */
3402 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3403 imop = Nullop; /* use 5.0; */
3408 /* Make copy of id so we don't free it twice */
3409 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3411 /* Fake up a method call to import/unimport */
3412 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3413 (void)SvUPGRADE(meth, SVt_PVIV);
3414 (void)SvIOK_on(meth);
3415 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3416 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3417 append_elem(OP_LIST,
3418 prepend_elem(OP_LIST, pack, list(arg)),
3419 newSVOP(OP_METHOD_NAMED, 0, meth)));
3422 if (ckWARN(WARN_MISC) &&
3423 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3424 SvPOK(packsv = ((SVOP*)id)->op_sv))
3426 /* BEGIN will free the ops, so we need to make a copy */
3427 packlen = SvCUR(packsv);
3428 packname = savepvn(SvPVX(packsv), packlen);
3431 /* Fake up the BEGIN {}, which does its thing immediately. */
3433 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3436 append_elem(OP_LINESEQ,
3437 append_elem(OP_LINESEQ,
3438 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3439 newSTATEOP(0, Nullch, veop)),
3440 newSTATEOP(0, Nullch, imop) ));
3443 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3444 Perl_warner(aTHX_ WARN_MISC,
3445 "Package `%s' not found "
3446 "(did you use the incorrect case?)", packname);
3451 PL_hints |= HINT_BLOCK_SCOPE;
3452 PL_copline = NOLINE;
3457 =head1 Embedding Functions
3459 =for apidoc load_module
3461 Loads the module whose name is pointed to by the string part of name.
3462 Note that the actual module name, not its filename, should be given.
3463 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3464 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3465 (or 0 for no flags). ver, if specified, provides version semantics
3466 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3467 arguments can be used to specify arguments to the module's import()
3468 method, similar to C<use Foo::Bar VERSION LIST>.
3473 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3476 va_start(args, ver);
3477 vload_module(flags, name, ver, &args);
3481 #ifdef PERL_IMPLICIT_CONTEXT
3483 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3487 va_start(args, ver);
3488 vload_module(flags, name, ver, &args);
3494 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3496 OP *modname, *veop, *imop;
3498 modname = newSVOP(OP_CONST, 0, name);
3499 modname->op_private |= OPpCONST_BARE;
3501 veop = newSVOP(OP_CONST, 0, ver);
3505 if (flags & PERL_LOADMOD_NOIMPORT) {
3506 imop = sawparens(newNULLLIST());
3508 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3509 imop = va_arg(*args, OP*);
3514 sv = va_arg(*args, SV*);
3516 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3517 sv = va_arg(*args, SV*);
3521 line_t ocopline = PL_copline;
3522 int oexpect = PL_expect;
3524 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3525 veop, modname, imop);
3526 PL_expect = oexpect;
3527 PL_copline = ocopline;
3532 Perl_dofile(pTHX_ OP *term)
3537 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3538 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3539 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3541 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3542 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3543 append_elem(OP_LIST, term,
3544 scalar(newUNOP(OP_RV2CV, 0,
3549 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3555 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3557 return newBINOP(OP_LSLICE, flags,
3558 list(force_list(subscript)),
3559 list(force_list(listval)) );
3563 S_list_assignment(pTHX_ register OP *o)
3568 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3569 o = cUNOPo->op_first;
3571 if (o->op_type == OP_COND_EXPR) {
3572 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3573 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3578 yyerror("Assignment to both a list and a scalar");
3582 if (o->op_type == OP_LIST &&
3583 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3584 o->op_private & OPpLVAL_INTRO)
3587 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3588 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3589 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3592 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3595 if (o->op_type == OP_RV2SV)
3602 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3607 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3608 return newLOGOP(optype, 0,
3609 mod(scalar(left), optype),
3610 newUNOP(OP_SASSIGN, 0, scalar(right)));
3613 return newBINOP(optype, OPf_STACKED,
3614 mod(scalar(left), optype), scalar(right));
3618 if (list_assignment(left)) {
3622 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3623 left = mod(left, OP_AASSIGN);
3631 curop = list(force_list(left));
3632 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3633 o->op_private = 0 | (flags >> 8);
3634 for (curop = ((LISTOP*)curop)->op_first;
3635 curop; curop = curop->op_sibling)
3637 if (curop->op_type == OP_RV2HV &&
3638 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3639 o->op_private |= OPpASSIGN_HASH;
3643 if (!(left->op_private & OPpLVAL_INTRO)) {
3646 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3647 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3648 if (curop->op_type == OP_GV) {
3649 GV *gv = cGVOPx_gv(curop);
3650 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3652 SvCUR(gv) = PL_generation;
3654 else if (curop->op_type == OP_PADSV ||
3655 curop->op_type == OP_PADAV ||
3656 curop->op_type == OP_PADHV ||
3657 curop->op_type == OP_PADANY) {
3658 SV **svp = AvARRAY(PL_comppad_name);
3659 SV *sv = svp[curop->op_targ];
3660 if (SvCUR(sv) == PL_generation)
3662 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3664 else if (curop->op_type == OP_RV2CV)
3666 else if (curop->op_type == OP_RV2SV ||
3667 curop->op_type == OP_RV2AV ||
3668 curop->op_type == OP_RV2HV ||
3669 curop->op_type == OP_RV2GV) {
3670 if (lastop->op_type != OP_GV) /* funny deref? */
3673 else if (curop->op_type == OP_PUSHRE) {
3674 if (((PMOP*)curop)->op_pmreplroot) {
3676 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3678 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3680 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3682 SvCUR(gv) = PL_generation;
3691 o->op_private |= OPpASSIGN_COMMON;
3693 if (right && right->op_type == OP_SPLIT) {
3695 if ((tmpop = ((LISTOP*)right)->op_first) &&
3696 tmpop->op_type == OP_PUSHRE)
3698 PMOP *pm = (PMOP*)tmpop;
3699 if (left->op_type == OP_RV2AV &&
3700 !(left->op_private & OPpLVAL_INTRO) &&
3701 !(o->op_private & OPpASSIGN_COMMON) )
3703 tmpop = ((UNOP*)left)->op_first;
3704 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3706 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3707 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3709 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3710 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3712 pm->op_pmflags |= PMf_ONCE;
3713 tmpop = cUNOPo->op_first; /* to list (nulled) */
3714 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3715 tmpop->op_sibling = Nullop; /* don't free split */
3716 right->op_next = tmpop->op_next; /* fix starting loc */
3717 op_free(o); /* blow off assign */
3718 right->op_flags &= ~OPf_WANT;
3719 /* "I don't know and I don't care." */
3724 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3725 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3727 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3729 sv_setiv(sv, PL_modcount+1);
3737 right = newOP(OP_UNDEF, 0);
3738 if (right->op_type == OP_READLINE) {
3739 right->op_flags |= OPf_STACKED;
3740 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3743 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3744 o = newBINOP(OP_SASSIGN, flags,
3745 scalar(right), mod(scalar(left), OP_SASSIGN) );
3757 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3759 U32 seq = intro_my();
3762 NewOp(1101, cop, 1, COP);
3763 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3764 cop->op_type = OP_DBSTATE;
3765 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3768 cop->op_type = OP_NEXTSTATE;
3769 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3771 cop->op_flags = flags;
3772 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3774 cop->op_private |= NATIVE_HINTS;
3776 PL_compiling.op_private = cop->op_private;
3777 cop->op_next = (OP*)cop;
3780 cop->cop_label = label;
3781 PL_hints |= HINT_BLOCK_SCOPE;
3784 cop->cop_arybase = PL_curcop->cop_arybase;
3785 if (specialWARN(PL_curcop->cop_warnings))
3786 cop->cop_warnings = PL_curcop->cop_warnings ;
3788 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3789 if (specialCopIO(PL_curcop->cop_io))
3790 cop->cop_io = PL_curcop->cop_io;
3792 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3795 if (PL_copline == NOLINE)
3796 CopLINE_set(cop, CopLINE(PL_curcop));
3798 CopLINE_set(cop, PL_copline);
3799 PL_copline = NOLINE;
3802 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3804 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3806 CopSTASH_set(cop, PL_curstash);
3808 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3809 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3810 if (svp && *svp != &PL_sv_undef ) {
3811 (void)SvIOK_on(*svp);
3812 SvIVX(*svp) = PTR2IV(cop);
3816 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3819 /* "Introduce" my variables to visible status. */
3827 if (! PL_min_intro_pending)
3828 return PL_cop_seqmax;
3830 svp = AvARRAY(PL_comppad_name);
3831 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3832 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3833 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3834 SvNVX(sv) = (NV)PL_cop_seqmax;
3837 PL_min_intro_pending = 0;
3838 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3839 return PL_cop_seqmax++;
3843 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3845 return new_logop(type, flags, &first, &other);
3849 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3853 OP *first = *firstp;
3854 OP *other = *otherp;
3856 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3857 return newBINOP(type, flags, scalar(first), scalar(other));
3859 scalarboolean(first);
3860 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3861 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3862 if (type == OP_AND || type == OP_OR) {
3868 first = *firstp = cUNOPo->op_first;
3870 first->op_next = o->op_next;
3871 cUNOPo->op_first = Nullop;
3875 if (first->op_type == OP_CONST) {
3876 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3877 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3878 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3889 else if (first->op_type == OP_WANTARRAY) {
3895 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3896 OP *k1 = ((UNOP*)first)->op_first;
3897 OP *k2 = k1->op_sibling;
3899 switch (first->op_type)
3902 if (k2 && k2->op_type == OP_READLINE
3903 && (k2->op_flags & OPf_STACKED)
3904 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3906 warnop = k2->op_type;
3911 if (k1->op_type == OP_READDIR
3912 || k1->op_type == OP_GLOB
3913 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3914 || k1->op_type == OP_EACH)
3916 warnop = ((k1->op_type == OP_NULL)
3917 ? k1->op_targ : k1->op_type);
3922 line_t oldline = CopLINE(PL_curcop);
3923 CopLINE_set(PL_curcop, PL_copline);
3924 Perl_warner(aTHX_ WARN_MISC,
3925 "Value of %s%s can be \"0\"; test with defined()",
3927 ((warnop == OP_READLINE || warnop == OP_GLOB)
3928 ? " construct" : "() operator"));
3929 CopLINE_set(PL_curcop, oldline);
3936 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3937 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3939 NewOp(1101, logop, 1, LOGOP);
3941 logop->op_type = type;
3942 logop->op_ppaddr = PL_ppaddr[type];
3943 logop->op_first = first;
3944 logop->op_flags = flags | OPf_KIDS;
3945 logop->op_other = LINKLIST(other);
3946 logop->op_private = 1 | (flags >> 8);
3948 /* establish postfix order */
3949 logop->op_next = LINKLIST(first);
3950 first->op_next = (OP*)logop;
3951 first->op_sibling = other;
3953 o = newUNOP(OP_NULL, 0, (OP*)logop);
3960 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3967 return newLOGOP(OP_AND, 0, first, trueop);
3969 return newLOGOP(OP_OR, 0, first, falseop);
3971 scalarboolean(first);
3972 if (first->op_type == OP_CONST) {
3973 if (SvTRUE(((SVOP*)first)->op_sv)) {
3984 else if (first->op_type == OP_WANTARRAY) {
3988 NewOp(1101, logop, 1, LOGOP);
3989 logop->op_type = OP_COND_EXPR;
3990 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3991 logop->op_first = first;
3992 logop->op_flags = flags | OPf_KIDS;
3993 logop->op_private = 1 | (flags >> 8);
3994 logop->op_other = LINKLIST(trueop);
3995 logop->op_next = LINKLIST(falseop);
3998 /* establish postfix order */
3999 start = LINKLIST(first);
4000 first->op_next = (OP*)logop;
4002 first->op_sibling = trueop;
4003 trueop->op_sibling = falseop;
4004 o = newUNOP(OP_NULL, 0, (OP*)logop);
4006 trueop->op_next = falseop->op_next = o;
4013 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4021 NewOp(1101, range, 1, LOGOP);
4023 range->op_type = OP_RANGE;
4024 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4025 range->op_first = left;
4026 range->op_flags = OPf_KIDS;
4027 leftstart = LINKLIST(left);
4028 range->op_other = LINKLIST(right);
4029 range->op_private = 1 | (flags >> 8);
4031 left->op_sibling = right;
4033 range->op_next = (OP*)range;
4034 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4035 flop = newUNOP(OP_FLOP, 0, flip);
4036 o = newUNOP(OP_NULL, 0, flop);
4038 range->op_next = leftstart;
4040 left->op_next = flip;
4041 right->op_next = flop;
4043 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4044 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4045 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4046 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4048 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4049 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4052 if (!flip->op_private || !flop->op_private)
4053 linklist(o); /* blow off optimizer unless constant */
4059 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4063 int once = block && block->op_flags & OPf_SPECIAL &&
4064 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4067 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4068 return block; /* do {} while 0 does once */
4069 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4070 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4071 expr = newUNOP(OP_DEFINED, 0,
4072 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4073 } else if (expr->op_flags & OPf_KIDS) {
4074 OP *k1 = ((UNOP*)expr)->op_first;
4075 OP *k2 = (k1) ? k1->op_sibling : NULL;
4076 switch (expr->op_type) {
4078 if (k2 && k2->op_type == OP_READLINE
4079 && (k2->op_flags & OPf_STACKED)
4080 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4081 expr = newUNOP(OP_DEFINED, 0, expr);
4085 if (k1->op_type == OP_READDIR
4086 || k1->op_type == OP_GLOB
4087 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4088 || k1->op_type == OP_EACH)
4089 expr = newUNOP(OP_DEFINED, 0, expr);
4095 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4096 o = new_logop(OP_AND, 0, &expr, &listop);
4099 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4101 if (once && o != listop)
4102 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4105 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4107 o->op_flags |= flags;
4109 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4114 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4122 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4123 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4124 expr = newUNOP(OP_DEFINED, 0,
4125 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4126 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4127 OP *k1 = ((UNOP*)expr)->op_first;
4128 OP *k2 = (k1) ? k1->op_sibling : NULL;
4129 switch (expr->op_type) {
4131 if (k2 && k2->op_type == OP_READLINE
4132 && (k2->op_flags & OPf_STACKED)
4133 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4134 expr = newUNOP(OP_DEFINED, 0, expr);
4138 if (k1->op_type == OP_READDIR
4139 || k1->op_type == OP_GLOB
4140 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4141 || k1->op_type == OP_EACH)
4142 expr = newUNOP(OP_DEFINED, 0, expr);
4148 block = newOP(OP_NULL, 0);
4150 block = scope(block);
4154 next = LINKLIST(cont);
4157 OP *unstack = newOP(OP_UNSTACK, 0);
4160 cont = append_elem(OP_LINESEQ, cont, unstack);
4161 if ((line_t)whileline != NOLINE) {
4162 PL_copline = whileline;
4163 cont = append_elem(OP_LINESEQ, cont,
4164 newSTATEOP(0, Nullch, Nullop));
4168 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4169 redo = LINKLIST(listop);
4172 PL_copline = whileline;
4174 o = new_logop(OP_AND, 0, &expr, &listop);
4175 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4176 op_free(expr); /* oops, it's a while (0) */
4178 return Nullop; /* listop already freed by new_logop */
4181 ((LISTOP*)listop)->op_last->op_next =
4182 (o == listop ? redo : LINKLIST(o));
4188 NewOp(1101,loop,1,LOOP);
4189 loop->op_type = OP_ENTERLOOP;
4190 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4191 loop->op_private = 0;
4192 loop->op_next = (OP*)loop;
4195 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4197 loop->op_redoop = redo;
4198 loop->op_lastop = o;
4199 o->op_private |= loopflags;
4202 loop->op_nextop = next;
4204 loop->op_nextop = o;
4206 o->op_flags |= flags;
4207 o->op_private |= (flags >> 8);
4212 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4220 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4221 sv->op_type = OP_RV2GV;
4222 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4224 else if (sv->op_type == OP_PADSV) { /* private variable */
4225 padoff = sv->op_targ;
4230 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4231 padoff = sv->op_targ;
4233 iterflags |= OPf_SPECIAL;
4238 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4241 #ifdef USE_5005THREADS
4242 padoff = find_threadsv("_");
4243 iterflags |= OPf_SPECIAL;
4245 sv = newGVOP(OP_GV, 0, PL_defgv);
4248 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4249 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4250 iterflags |= OPf_STACKED;
4252 else if (expr->op_type == OP_NULL &&
4253 (expr->op_flags & OPf_KIDS) &&
4254 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4256 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4257 * set the STACKED flag to indicate that these values are to be
4258 * treated as min/max values by 'pp_iterinit'.
4260 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4261 LOGOP* range = (LOGOP*) flip->op_first;
4262 OP* left = range->op_first;
4263 OP* right = left->op_sibling;
4266 range->op_flags &= ~OPf_KIDS;
4267 range->op_first = Nullop;
4269 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4270 listop->op_first->op_next = range->op_next;
4271 left->op_next = range->op_other;
4272 right->op_next = (OP*)listop;
4273 listop->op_next = listop->op_first;
4276 expr = (OP*)(listop);
4278 iterflags |= OPf_STACKED;
4281 expr = mod(force_list(expr), OP_GREPSTART);
4285 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4286 append_elem(OP_LIST, expr, scalar(sv))));
4287 assert(!loop->op_next);
4288 #ifdef PL_OP_SLAB_ALLOC
4291 NewOp(1234,tmp,1,LOOP);
4292 Copy(loop,tmp,1,LOOP);
4296 Renew(loop, 1, LOOP);
4298 loop->op_targ = padoff;
4299 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4300 PL_copline = forline;
4301 return newSTATEOP(0, label, wop);
4305 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4310 if (type != OP_GOTO || label->op_type == OP_CONST) {
4311 /* "last()" means "last" */
4312 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4313 o = newOP(type, OPf_SPECIAL);
4315 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4316 ? SvPVx(((SVOP*)label)->op_sv, n_a)
4322 if (label->op_type == OP_ENTERSUB)
4323 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4324 o = newUNOP(type, OPf_STACKED, label);
4326 PL_hints |= HINT_BLOCK_SCOPE;
4331 Perl_cv_undef(pTHX_ CV *cv)
4333 #ifdef USE_5005THREADS
4335 MUTEX_DESTROY(CvMUTEXP(cv));
4336 Safefree(CvMUTEXP(cv));
4339 #endif /* USE_5005THREADS */
4342 if (CvFILE(cv) && !CvXSUB(cv)) {
4343 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4344 Safefree(CvFILE(cv));
4349 if (!CvXSUB(cv) && CvROOT(cv)) {
4350 #ifdef USE_5005THREADS
4351 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4352 Perl_croak(aTHX_ "Can't undef active subroutine");
4355 Perl_croak(aTHX_ "Can't undef active subroutine");
4356 #endif /* USE_5005THREADS */
4359 SAVEVPTR(PL_curpad);
4362 op_free(CvROOT(cv));
4363 CvROOT(cv) = Nullop;
4366 SvPOK_off((SV*)cv); /* forget prototype */
4368 /* Since closure prototypes have the same lifetime as the containing
4369 * CV, they don't hold a refcount on the outside CV. This avoids
4370 * the refcount loop between the outer CV (which keeps a refcount to
4371 * the closure prototype in the pad entry for pp_anoncode()) and the
4372 * closure prototype, and the ensuing memory leak. --GSAR */
4373 if (!CvANON(cv) || CvCLONED(cv))
4374 SvREFCNT_dec(CvOUTSIDE(cv));
4375 CvOUTSIDE(cv) = Nullcv;
4377 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4380 if (CvPADLIST(cv)) {
4381 /* may be during global destruction */
4382 if (SvREFCNT(CvPADLIST(cv))) {
4383 I32 i = AvFILLp(CvPADLIST(cv));
4385 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4386 SV* sv = svp ? *svp : Nullsv;
4389 if (sv == (SV*)PL_comppad_name)
4390 PL_comppad_name = Nullav;
4391 else if (sv == (SV*)PL_comppad) {
4392 PL_comppad = Nullav;
4393 PL_curpad = Null(SV**);
4397 SvREFCNT_dec((SV*)CvPADLIST(cv));
4399 CvPADLIST(cv) = Nullav;
4407 #ifdef DEBUG_CLOSURES
4409 S_cv_dump(pTHX_ CV *cv)
4412 CV *outside = CvOUTSIDE(cv);
4413 AV* padlist = CvPADLIST(cv);
4420 PerlIO_printf(Perl_debug_log,
4421 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4423 (CvANON(cv) ? "ANON"
4424 : (cv == PL_main_cv) ? "MAIN"
4425 : CvUNIQUE(cv) ? "UNIQUE"
4426 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4429 : CvANON(outside) ? "ANON"
4430 : (outside == PL_main_cv) ? "MAIN"
4431 : CvUNIQUE(outside) ? "UNIQUE"
4432 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4437 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4438 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4439 pname = AvARRAY(pad_name);
4440 ppad = AvARRAY(pad);
4442 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4443 if (SvPOK(pname[ix]))
4444 PerlIO_printf(Perl_debug_log,
4445 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4446 (int)ix, PTR2UV(ppad[ix]),
4447 SvFAKE(pname[ix]) ? "FAKE " : "",
4449 (IV)I_32(SvNVX(pname[ix])),
4452 #endif /* DEBUGGING */
4454 #endif /* DEBUG_CLOSURES */
4457 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4461 AV* protopadlist = CvPADLIST(proto);
4462 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4463 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4464 SV** pname = AvARRAY(protopad_name);
4465 SV** ppad = AvARRAY(protopad);
4466 I32 fname = AvFILLp(protopad_name);
4467 I32 fpad = AvFILLp(protopad);
4471 assert(!CvUNIQUE(proto));
4475 SAVESPTR(PL_comppad_name);
4476 SAVESPTR(PL_compcv);
4478 cv = PL_compcv = (CV*)NEWSV(1104,0);
4479 sv_upgrade((SV *)cv, SvTYPE(proto));
4480 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4483 #ifdef USE_5005THREADS
4484 New(666, CvMUTEXP(cv), 1, perl_mutex);
4485 MUTEX_INIT(CvMUTEXP(cv));
4487 #endif /* USE_5005THREADS */
4489 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4490 : savepv(CvFILE(proto));
4492 CvFILE(cv) = CvFILE(proto);
4494 CvGV(cv) = CvGV(proto);
4495 CvSTASH(cv) = CvSTASH(proto);
4496 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
4497 CvSTART(cv) = CvSTART(proto);
4499 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4502 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4504 PL_comppad_name = newAV();
4505 for (ix = fname; ix >= 0; ix--)
4506 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4508 PL_comppad = newAV();
4510 comppadlist = newAV();
4511 AvREAL_off(comppadlist);
4512 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4513 av_store(comppadlist, 1, (SV*)PL_comppad);
4514 CvPADLIST(cv) = comppadlist;
4515 av_fill(PL_comppad, AvFILLp(protopad));
4516 PL_curpad = AvARRAY(PL_comppad);
4518 av = newAV(); /* will be @_ */
4520 av_store(PL_comppad, 0, (SV*)av);
4521 AvFLAGS(av) = AVf_REIFY;
4523 for (ix = fpad; ix > 0; ix--) {
4524 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4525 if (namesv && namesv != &PL_sv_undef) {
4526 char *name = SvPVX(namesv); /* XXX */
4527 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4528 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4529 CvOUTSIDE(cv), cxstack_ix, 0, 0);
4531 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4533 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4535 else { /* our own lexical */
4538 /* anon code -- we'll come back for it */
4539 sv = SvREFCNT_inc(ppad[ix]);
4541 else if (*name == '@')
4543 else if (*name == '%')
4552 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4553 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4556 SV* sv = NEWSV(0,0);
4562 /* Now that vars are all in place, clone nested closures. */
4564 for (ix = fpad; ix > 0; ix--) {
4565 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4567 && namesv != &PL_sv_undef
4568 && !(SvFLAGS(namesv) & SVf_FAKE)
4569 && *SvPVX(namesv) == '&'
4570 && CvCLONE(ppad[ix]))
4572 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4573 SvREFCNT_dec(ppad[ix]);
4576 PL_curpad[ix] = (SV*)kid;
4580 #ifdef DEBUG_CLOSURES
4581 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4583 PerlIO_printf(Perl_debug_log, " from:\n");
4585 PerlIO_printf(Perl_debug_log, " to:\n");
4592 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4594 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4596 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4603 Perl_cv_clone(pTHX_ CV *proto)
4606 LOCK_CRED_MUTEX; /* XXX create separate mutex */
4607 cv = cv_clone2(proto, CvOUTSIDE(proto));
4608 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4613 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4615 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4616 SV* msg = sv_newmortal();
4620 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4621 sv_setpv(msg, "Prototype mismatch:");
4623 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4625 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4626 sv_catpv(msg, " vs ");
4628 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4630 sv_catpv(msg, "none");
4631 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4635 static void const_sv_xsub(pTHX_ CV* cv);
4639 =head1 Optree Manipulation Functions
4641 =for apidoc cv_const_sv
4643 If C<cv> is a constant sub eligible for inlining. returns the constant
4644 value returned by the sub. Otherwise, returns NULL.
4646 Constant subs can be created with C<newCONSTSUB> or as described in
4647 L<perlsub/"Constant Functions">.
4652 Perl_cv_const_sv(pTHX_ CV *cv)
4654 if (!cv || !CvCONST(cv))
4656 return (SV*)CvXSUBANY(cv).any_ptr;
4660 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4667 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4668 o = cLISTOPo->op_first->op_sibling;
4670 for (; o; o = o->op_next) {
4671 OPCODE type = o->op_type;
4673 if (sv && o->op_next == o)
4675 if (o->op_next != o) {
4676 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4678 if (type == OP_DBSTATE)
4681 if (type == OP_LEAVESUB || type == OP_RETURN)
4685 if (type == OP_CONST && cSVOPo->op_sv)
4687 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4688 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4689 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4693 /* We get here only from cv_clone2() while creating a closure.
4694 Copy the const value here instead of in cv_clone2 so that
4695 SvREADONLY_on doesn't lead to problems when leaving
4700 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4712 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4722 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4726 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4728 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4732 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4738 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4743 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4744 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4745 SV *sv = sv_newmortal();
4746 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4747 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4752 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4753 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4763 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4764 maximum a prototype before. */
4765 if (SvTYPE(gv) > SVt_NULL) {
4766 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4767 && ckWARN_d(WARN_PROTOTYPE))
4769 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4771 cv_ckproto((CV*)gv, NULL, ps);
4774 sv_setpv((SV*)gv, ps);
4776 sv_setiv((SV*)gv, -1);
4777 SvREFCNT_dec(PL_compcv);
4778 cv = PL_compcv = NULL;
4779 PL_sub_generation++;
4783 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4785 #ifdef GV_UNIQUE_CHECK
4786 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4787 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4791 if (!block || !ps || *ps || attrs)
4794 const_sv = op_const_sv(block, Nullcv);
4797 bool exists = CvROOT(cv) || CvXSUB(cv);
4799 #ifdef GV_UNIQUE_CHECK
4800 if (exists && GvUNIQUE(gv)) {
4801 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4805 /* if the subroutine doesn't exist and wasn't pre-declared
4806 * with a prototype, assume it will be AUTOLOADed,
4807 * skipping the prototype check
4809 if (exists || SvPOK(cv))
4810 cv_ckproto(cv, gv, ps);
4811 /* already defined (or promised)? */
4812 if (exists || GvASSUMECV(gv)) {
4813 if (!block && !attrs) {
4814 /* just a "sub foo;" when &foo is already defined */
4815 SAVEFREESV(PL_compcv);
4818 /* ahem, death to those who redefine active sort subs */
4819 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4820 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4822 if (ckWARN(WARN_REDEFINE)
4824 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4826 line_t oldline = CopLINE(PL_curcop);
4827 if (PL_copline != NOLINE)
4828 CopLINE_set(PL_curcop, PL_copline);
4829 Perl_warner(aTHX_ WARN_REDEFINE,
4830 CvCONST(cv) ? "Constant subroutine %s redefined"
4831 : "Subroutine %s redefined", name);
4832 CopLINE_set(PL_curcop, oldline);
4840 SvREFCNT_inc(const_sv);
4842 assert(!CvROOT(cv) && !CvCONST(cv));
4843 sv_setpv((SV*)cv, ""); /* prototype is "" */
4844 CvXSUBANY(cv).any_ptr = const_sv;
4845 CvXSUB(cv) = const_sv_xsub;
4850 cv = newCONSTSUB(NULL, name, const_sv);
4853 SvREFCNT_dec(PL_compcv);
4855 PL_sub_generation++;
4862 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4863 * before we clobber PL_compcv.
4867 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4868 stash = GvSTASH(CvGV(cv));
4869 else if (CvSTASH(cv))
4870 stash = CvSTASH(cv);
4872 stash = PL_curstash;
4875 /* possibly about to re-define existing subr -- ignore old cv */
4876 rcv = (SV*)PL_compcv;
4877 if (name && GvSTASH(gv))
4878 stash = GvSTASH(gv);
4880 stash = PL_curstash;
4882 apply_attrs(stash, rcv, attrs, FALSE);
4884 if (cv) { /* must reuse cv if autoloaded */
4886 /* got here with just attrs -- work done, so bug out */
4887 SAVEFREESV(PL_compcv);
4891 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4892 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4893 CvOUTSIDE(PL_compcv) = 0;
4894 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4895 CvPADLIST(PL_compcv) = 0;
4896 /* inner references to PL_compcv must be fixed up ... */
4898 AV *padlist = CvPADLIST(cv);
4899 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4900 AV *comppad = (AV*)AvARRAY(padlist)[1];
4901 SV **namepad = AvARRAY(comppad_name);
4902 SV **curpad = AvARRAY(comppad);
4903 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4904 SV *namesv = namepad[ix];
4905 if (namesv && namesv != &PL_sv_undef
4906 && *SvPVX(namesv) == '&')
4908 CV *innercv = (CV*)curpad[ix];
4909 if (CvOUTSIDE(innercv) == PL_compcv) {
4910 CvOUTSIDE(innercv) = cv;
4911 if (!CvANON(innercv) || CvCLONED(innercv)) {
4912 (void)SvREFCNT_inc(cv);
4913 SvREFCNT_dec(PL_compcv);
4919 /* ... before we throw it away */
4920 SvREFCNT_dec(PL_compcv);
4921 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4922 ++PL_sub_generation;
4929 PL_sub_generation++;
4933 CvFILE_set_from_cop(cv, PL_curcop);
4934 CvSTASH(cv) = PL_curstash;
4935 #ifdef USE_5005THREADS
4937 if (!CvMUTEXP(cv)) {
4938 New(666, CvMUTEXP(cv), 1, perl_mutex);
4939 MUTEX_INIT(CvMUTEXP(cv));
4941 #endif /* USE_5005THREADS */
4944 sv_setpv((SV*)cv, ps);
4946 if (PL_error_count) {
4950 char *s = strrchr(name, ':');
4952 if (strEQ(s, "BEGIN")) {
4954 "BEGIN not safe after errors--compilation aborted";
4955 if (PL_in_eval & EVAL_KEEPERR)
4956 Perl_croak(aTHX_ not_safe);
4958 /* force display of errors found but not reported */
4959 sv_catpv(ERRSV, not_safe);
4960 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4968 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4969 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4972 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4973 mod(scalarseq(block), OP_LEAVESUBLV));
4976 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4978 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4979 OpREFCNT_set(CvROOT(cv), 1);
4980 CvSTART(cv) = LINKLIST(CvROOT(cv));
4981 CvROOT(cv)->op_next = 0;
4982 CALL_PEEP(CvSTART(cv));
4984 /* now that optimizer has done its work, adjust pad values */
4986 SV **namep = AvARRAY(PL_comppad_name);
4987 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4990 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4993 * The only things that a clonable function needs in its
4994 * pad are references to outer lexicals and anonymous subs.
4995 * The rest are created anew during cloning.
4997 if (!((namesv = namep[ix]) != Nullsv &&
4998 namesv != &PL_sv_undef &&
5000 *SvPVX(namesv) == '&')))
5002 SvREFCNT_dec(PL_curpad[ix]);
5003 PL_curpad[ix] = Nullsv;
5006 assert(!CvCONST(cv));
5007 if (ps && !*ps && op_const_sv(block, cv))
5011 AV *av = newAV(); /* Will be @_ */
5013 av_store(PL_comppad, 0, (SV*)av);
5014 AvFLAGS(av) = AVf_REIFY;
5016 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5017 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5019 if (!SvPADMY(PL_curpad[ix]))
5020 SvPADTMP_on(PL_curpad[ix]);
5024 /* If a potential closure prototype, don't keep a refcount on outer CV.
5025 * This is okay as the lifetime of the prototype is tied to the
5026 * lifetime of the outer CV. Avoids memory leak due to reference
5029 SvREFCNT_dec(CvOUTSIDE(cv));
5031 if (name || aname) {
5033 char *tname = (name ? name : aname);
5035 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5036 SV *sv = NEWSV(0,0);
5037 SV *tmpstr = sv_newmortal();
5038 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5042 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5044 (long)PL_subline, (long)CopLINE(PL_curcop));
5045 gv_efullname3(tmpstr, gv, Nullch);
5046 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5047 hv = GvHVn(db_postponed);
5048 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5049 && (pcv = GvCV(db_postponed)))
5055 call_sv((SV*)pcv, G_DISCARD);
5059 if ((s = strrchr(tname,':')))
5064 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5067 if (strEQ(s, "BEGIN")) {
5068 I32 oldscope = PL_scopestack_ix;
5070 SAVECOPFILE(&PL_compiling);
5071 SAVECOPLINE(&PL_compiling);
5074 PL_beginav = newAV();
5075 DEBUG_x( dump_sub(gv) );
5076 av_push(PL_beginav, (SV*)cv);
5077 GvCV(gv) = 0; /* cv has been hijacked */
5078 call_list(oldscope, PL_beginav);
5080 PL_curcop = &PL_compiling;
5081 PL_compiling.op_private = PL_hints;
5084 else if (strEQ(s, "END") && !PL_error_count) {
5087 DEBUG_x( dump_sub(gv) );
5088 av_unshift(PL_endav, 1);
5089 av_store(PL_endav, 0, (SV*)cv);
5090 GvCV(gv) = 0; /* cv has been hijacked */
5092 else if (strEQ(s, "CHECK") && !PL_error_count) {
5094 PL_checkav = newAV();
5095 DEBUG_x( dump_sub(gv) );
5096 if (PL_main_start && ckWARN(WARN_VOID))
5097 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5098 av_unshift(PL_checkav, 1);
5099 av_store(PL_checkav, 0, (SV*)cv);
5100 GvCV(gv) = 0; /* cv has been hijacked */
5102 else if (strEQ(s, "INIT") && !PL_error_count) {
5104 PL_initav = newAV();
5105 DEBUG_x( dump_sub(gv) );
5106 if (PL_main_start && ckWARN(WARN_VOID))
5107 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5108 av_push(PL_initav, (SV*)cv);
5109 GvCV(gv) = 0; /* cv has been hijacked */
5114 PL_copline = NOLINE;
5119 /* XXX unsafe for threads if eval_owner isn't held */
5121 =for apidoc newCONSTSUB
5123 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5124 eligible for inlining at compile-time.
5130 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5136 SAVECOPLINE(PL_curcop);
5137 CopLINE_set(PL_curcop, PL_copline);
5140 PL_hints &= ~HINT_BLOCK_SCOPE;
5143 SAVESPTR(PL_curstash);
5144 SAVECOPSTASH(PL_curcop);
5145 PL_curstash = stash;
5147 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5149 CopSTASH(PL_curcop) = stash;
5153 cv = newXS(name, const_sv_xsub, __FILE__);
5154 CvXSUBANY(cv).any_ptr = sv;
5156 sv_setpv((SV*)cv, ""); /* prototype is "" */
5164 =for apidoc U||newXS
5166 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5172 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5174 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5177 if ((cv = (name ? GvCV(gv) : Nullcv))) {
5179 /* just a cached method */
5183 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5184 /* already defined (or promised) */
5185 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5186 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5187 line_t oldline = CopLINE(PL_curcop);
5188 if (PL_copline != NOLINE)
5189 CopLINE_set(PL_curcop, PL_copline);
5190 Perl_warner(aTHX_ WARN_REDEFINE,
5191 CvCONST(cv) ? "Constant subroutine %s redefined"
5192 : "Subroutine %s redefined"
5194 CopLINE_set(PL_curcop, oldline);
5201 if (cv) /* must reuse cv if autoloaded */
5204 cv = (CV*)NEWSV(1105,0);
5205 sv_upgrade((SV *)cv, SVt_PVCV);
5209 PL_sub_generation++;
5213 #ifdef USE_5005THREADS
5214 New(666, CvMUTEXP(cv), 1, perl_mutex);
5215 MUTEX_INIT(CvMUTEXP(cv));
5217 #endif /* USE_5005THREADS */
5218 (void)gv_fetchfile(filename);
5219 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5220 an external constant string */
5221 CvXSUB(cv) = subaddr;
5224 char *s = strrchr(name,':');
5230 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5233 if (strEQ(s, "BEGIN")) {
5235 PL_beginav = newAV();
5236 av_push(PL_beginav, (SV*)cv);
5237 GvCV(gv) = 0; /* cv has been hijacked */
5239 else if (strEQ(s, "END")) {
5242 av_unshift(PL_endav, 1);
5243 av_store(PL_endav, 0, (SV*)cv);
5244 GvCV(gv) = 0; /* cv has been hijacked */
5246 else if (strEQ(s, "CHECK")) {
5248 PL_checkav = newAV();
5249 if (PL_main_start && ckWARN(WARN_VOID))
5250 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5251 av_unshift(PL_checkav, 1);
5252 av_store(PL_checkav, 0, (SV*)cv);
5253 GvCV(gv) = 0; /* cv has been hijacked */
5255 else if (strEQ(s, "INIT")) {
5257 PL_initav = newAV();
5258 if (PL_main_start && ckWARN(WARN_VOID))
5259 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5260 av_push(PL_initav, (SV*)cv);
5261 GvCV(gv) = 0; /* cv has been hijacked */
5272 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5281 name = SvPVx(cSVOPo->op_sv, n_a);
5284 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5285 #ifdef GV_UNIQUE_CHECK
5287 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5291 if ((cv = GvFORM(gv))) {
5292 if (ckWARN(WARN_REDEFINE)) {
5293 line_t oldline = CopLINE(PL_curcop);
5294 if (PL_copline != NOLINE)
5295 CopLINE_set(PL_curcop, PL_copline);
5296 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5297 CopLINE_set(PL_curcop, oldline);
5304 CvFILE_set_from_cop(cv, PL_curcop);
5306 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5307 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5308 SvPADTMP_on(PL_curpad[ix]);
5311 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5312 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5313 OpREFCNT_set(CvROOT(cv), 1);
5314 CvSTART(cv) = LINKLIST(CvROOT(cv));
5315 CvROOT(cv)->op_next = 0;
5316 CALL_PEEP(CvSTART(cv));
5318 PL_copline = NOLINE;
5323 Perl_newANONLIST(pTHX_ OP *o)
5325 return newUNOP(OP_REFGEN, 0,
5326 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5330 Perl_newANONHASH(pTHX_ OP *o)
5332 return newUNOP(OP_REFGEN, 0,
5333 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5337 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5339 return newANONATTRSUB(floor, proto, Nullop, block);
5343 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5345 return newUNOP(OP_REFGEN, 0,
5346 newSVOP(OP_ANONCODE, 0,
5347 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5351 Perl_oopsAV(pTHX_ OP *o)
5353 switch (o->op_type) {
5355 o->op_type = OP_PADAV;
5356 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5357 return ref(o, OP_RV2AV);
5360 o->op_type = OP_RV2AV;
5361 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5366 if (ckWARN_d(WARN_INTERNAL))
5367 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5374 Perl_oopsHV(pTHX_ OP *o)
5376 switch (o->op_type) {
5379 o->op_type = OP_PADHV;
5380 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5381 return ref(o, OP_RV2HV);
5385 o->op_type = OP_RV2HV;
5386 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5391 if (ckWARN_d(WARN_INTERNAL))
5392 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5399 Perl_newAVREF(pTHX_ OP *o)
5401 if (o->op_type == OP_PADANY) {
5402 o->op_type = OP_PADAV;
5403 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5406 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5407 && ckWARN(WARN_DEPRECATED)) {
5408 Perl_warner(aTHX_ WARN_DEPRECATED,
5409 "Using an array as a reference is deprecated");
5411 return newUNOP(OP_RV2AV, 0, scalar(o));
5415 Perl_newGVREF(pTHX_ I32 type, OP *o)
5417 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5418 return newUNOP(OP_NULL, 0, o);
5419 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5423 Perl_newHVREF(pTHX_ OP *o)
5425 if (o->op_type == OP_PADANY) {
5426 o->op_type = OP_PADHV;
5427 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5430 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5431 && ckWARN(WARN_DEPRECATED)) {
5432 Perl_warner(aTHX_ WARN_DEPRECATED,
5433 "Using a hash as a reference is deprecated");
5435 return newUNOP(OP_RV2HV, 0, scalar(o));
5439 Perl_oopsCV(pTHX_ OP *o)
5441 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5447 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5449 return newUNOP(OP_RV2CV, flags, scalar(o));
5453 Perl_newSVREF(pTHX_ OP *o)
5455 if (o->op_type == OP_PADANY) {
5456 o->op_type = OP_PADSV;
5457 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5460 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5461 o->op_flags |= OPpDONE_SVREF;
5464 return newUNOP(OP_RV2SV, 0, scalar(o));
5467 /* Check routines. */
5470 Perl_ck_anoncode(pTHX_ OP *o)
5475 name = NEWSV(1106,0);
5476 sv_upgrade(name, SVt_PVNV);
5477 sv_setpvn(name, "&", 1);
5480 ix = pad_alloc(o->op_type, SVs_PADMY);
5481 av_store(PL_comppad_name, ix, name);
5482 av_store(PL_comppad, ix, cSVOPo->op_sv);
5483 SvPADMY_on(cSVOPo->op_sv);
5484 cSVOPo->op_sv = Nullsv;
5485 cSVOPo->op_targ = ix;
5490 Perl_ck_bitop(pTHX_ OP *o)
5492 o->op_private = PL_hints;
5497 Perl_ck_concat(pTHX_ OP *o)
5499 if (cUNOPo->op_first->op_type == OP_CONCAT)
5500 o->op_flags |= OPf_STACKED;
5505 Perl_ck_spair(pTHX_ OP *o)
5507 if (o->op_flags & OPf_KIDS) {
5510 OPCODE type = o->op_type;
5511 o = modkids(ck_fun(o), type);
5512 kid = cUNOPo->op_first;
5513 newop = kUNOP->op_first->op_sibling;
5515 (newop->op_sibling ||
5516 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5517 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5518 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5522 op_free(kUNOP->op_first);
5523 kUNOP->op_first = newop;
5525 o->op_ppaddr = PL_ppaddr[++o->op_type];
5530 Perl_ck_delete(pTHX_ OP *o)
5534 if (o->op_flags & OPf_KIDS) {
5535 OP *kid = cUNOPo->op_first;
5536 switch (kid->op_type) {
5538 o->op_flags |= OPf_SPECIAL;
5541 o->op_private |= OPpSLICE;
5544 o->op_flags |= OPf_SPECIAL;
5549 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5558 Perl_ck_die(pTHX_ OP *o)
5561 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5567 Perl_ck_eof(pTHX_ OP *o)
5569 I32 type = o->op_type;
5571 if (o->op_flags & OPf_KIDS) {
5572 if (cLISTOPo->op_first->op_type == OP_STUB) {
5574 o = newUNOP(type, OPf_SPECIAL,
5575 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5583 Perl_ck_eval(pTHX_ OP *o)
5585 PL_hints |= HINT_BLOCK_SCOPE;
5586 if (o->op_flags & OPf_KIDS) {
5587 SVOP *kid = (SVOP*)cUNOPo->op_first;
5590 o->op_flags &= ~OPf_KIDS;
5593 else if (kid->op_type == OP_LINESEQ) {
5596 kid->op_next = o->op_next;
5597 cUNOPo->op_first = 0;
5600 NewOp(1101, enter, 1, LOGOP);
5601 enter->op_type = OP_ENTERTRY;
5602 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5603 enter->op_private = 0;
5605 /* establish postfix order */
5606 enter->op_next = (OP*)enter;
5608 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5609 o->op_type = OP_LEAVETRY;
5610 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5611 enter->op_other = o;
5619 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5621 o->op_targ = (PADOFFSET)PL_hints;
5626 Perl_ck_exit(pTHX_ OP *o)
5629 HV *table = GvHV(PL_hintgv);
5631 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5632 if (svp && *svp && SvTRUE(*svp))
5633 o->op_private |= OPpEXIT_VMSISH;
5635 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5641 Perl_ck_exec(pTHX_ OP *o)
5644 if (o->op_flags & OPf_STACKED) {
5646 kid = cUNOPo->op_first->op_sibling;
5647 if (kid->op_type == OP_RV2GV)
5656 Perl_ck_exists(pTHX_ OP *o)
5659 if (o->op_flags & OPf_KIDS) {
5660 OP *kid = cUNOPo->op_first;
5661 if (kid->op_type == OP_ENTERSUB) {
5662 (void) ref(kid, o->op_type);
5663 if (kid->op_type != OP_RV2CV && !PL_error_count)
5664 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5666 o->op_private |= OPpEXISTS_SUB;
5668 else if (kid->op_type == OP_AELEM)
5669 o->op_flags |= OPf_SPECIAL;
5670 else if (kid->op_type != OP_HELEM)
5671 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5680 Perl_ck_gvconst(pTHX_ register OP *o)
5682 o = fold_constants(o);
5683 if (o->op_type == OP_CONST)
5690 Perl_ck_rvconst(pTHX_ register OP *o)
5692 SVOP *kid = (SVOP*)cUNOPo->op_first;
5694 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5695 if (kid->op_type == OP_CONST) {
5699 SV *kidsv = kid->op_sv;
5702 /* Is it a constant from cv_const_sv()? */
5703 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5704 SV *rsv = SvRV(kidsv);
5705 int svtype = SvTYPE(rsv);
5706 char *badtype = Nullch;
5708 switch (o->op_type) {
5710 if (svtype > SVt_PVMG)
5711 badtype = "a SCALAR";
5714 if (svtype != SVt_PVAV)
5715 badtype = "an ARRAY";
5718 if (svtype != SVt_PVHV) {
5719 if (svtype == SVt_PVAV) { /* pseudohash? */
5720 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5721 if (ksv && SvROK(*ksv)
5722 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5731 if (svtype != SVt_PVCV)
5736 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5739 name = SvPV(kidsv, n_a);
5740 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5741 char *badthing = Nullch;
5742 switch (o->op_type) {
5744 badthing = "a SCALAR";
5747 badthing = "an ARRAY";
5750 badthing = "a HASH";
5755 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5759 * This is a little tricky. We only want to add the symbol if we
5760 * didn't add it in the lexer. Otherwise we get duplicate strict
5761 * warnings. But if we didn't add it in the lexer, we must at
5762 * least pretend like we wanted to add it even if it existed before,
5763 * or we get possible typo warnings. OPpCONST_ENTERED says
5764 * whether the lexer already added THIS instance of this symbol.
5766 iscv = (o->op_type == OP_RV2CV) * 2;
5768 gv = gv_fetchpv(name,
5769 iscv | !(kid->op_private & OPpCONST_ENTERED),
5772 : o->op_type == OP_RV2SV
5774 : o->op_type == OP_RV2AV
5776 : o->op_type == OP_RV2HV
5779 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5781 kid->op_type = OP_GV;
5782 SvREFCNT_dec(kid->op_sv);
5784 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5785 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5786 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5788 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5790 kid->op_sv = SvREFCNT_inc(gv);
5792 kid->op_private = 0;
5793 kid->op_ppaddr = PL_ppaddr[OP_GV];
5800 Perl_ck_ftst(pTHX_ OP *o)
5802 I32 type = o->op_type;
5804 if (o->op_flags & OPf_REF) {
5807 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5808 SVOP *kid = (SVOP*)cUNOPo->op_first;
5810 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5812 OP *newop = newGVOP(type, OPf_REF,
5813 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5820 if (type == OP_FTTTY)
5821 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5824 o = newUNOP(type, 0, newDEFSVOP());
5830 Perl_ck_fun(pTHX_ OP *o)
5836 int type = o->op_type;
5837 register I32 oa = PL_opargs[type] >> OASHIFT;
5839 if (o->op_flags & OPf_STACKED) {
5840 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5843 return no_fh_allowed(o);
5846 if (o->op_flags & OPf_KIDS) {
5848 tokid = &cLISTOPo->op_first;
5849 kid = cLISTOPo->op_first;
5850 if (kid->op_type == OP_PUSHMARK ||
5851 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5853 tokid = &kid->op_sibling;
5854 kid = kid->op_sibling;
5856 if (!kid && PL_opargs[type] & OA_DEFGV)
5857 *tokid = kid = newDEFSVOP();
5861 sibl = kid->op_sibling;
5864 /* list seen where single (scalar) arg expected? */
5865 if (numargs == 1 && !(oa >> 4)
5866 && kid->op_type == OP_LIST && type != OP_SCALAR)
5868 return too_many_arguments(o,PL_op_desc[type]);
5881 if ((type == OP_PUSH || type == OP_UNSHIFT)
5882 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5883 Perl_warner(aTHX_ WARN_SYNTAX,
5884 "Useless use of %s with no values",
5887 if (kid->op_type == OP_CONST &&
5888 (kid->op_private & OPpCONST_BARE))
5890 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5891 OP *newop = newAVREF(newGVOP(OP_GV, 0,
5892 gv_fetchpv(name, TRUE, SVt_PVAV) ));
5893 if (ckWARN(WARN_DEPRECATED))
5894 Perl_warner(aTHX_ WARN_DEPRECATED,
5895 "Array @%s missing the @ in argument %"IVdf" of %s()",
5896 name, (IV)numargs, PL_op_desc[type]);
5899 kid->op_sibling = sibl;
5902 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5903 bad_type(numargs, "array", PL_op_desc[type], kid);
5907 if (kid->op_type == OP_CONST &&
5908 (kid->op_private & OPpCONST_BARE))
5910 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5911 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5912 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5913 if (ckWARN(WARN_DEPRECATED))
5914 Perl_warner(aTHX_ WARN_DEPRECATED,
5915 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5916 name, (IV)numargs, PL_op_desc[type]);
5919 kid->op_sibling = sibl;
5922 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5923 bad_type(numargs, "hash", PL_op_desc[type], kid);
5928 OP *newop = newUNOP(OP_NULL, 0, kid);
5929 kid->op_sibling = 0;
5931 newop->op_next = newop;
5933 kid->op_sibling = sibl;
5938 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5939 if (kid->op_type == OP_CONST &&
5940 (kid->op_private & OPpCONST_BARE))
5942 OP *newop = newGVOP(OP_GV, 0,
5943 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5945 if (kid == cLISTOPo->op_last)
5946 cLISTOPo->op_last = newop;
5950 else if (kid->op_type == OP_READLINE) {
5951 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5952 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5955 I32 flags = OPf_SPECIAL;
5959 /* is this op a FH constructor? */
5960 if (is_handle_constructor(o,numargs)) {
5961 char *name = Nullch;
5965 /* Set a flag to tell rv2gv to vivify
5966 * need to "prove" flag does not mean something
5967 * else already - NI-S 1999/05/07
5970 if (kid->op_type == OP_PADSV) {
5971 SV **namep = av_fetch(PL_comppad_name,
5973 if (namep && *namep)
5974 name = SvPV(*namep, len);
5976 else if (kid->op_type == OP_RV2SV
5977 && kUNOP->op_first->op_type == OP_GV)
5979 GV *gv = cGVOPx_gv(kUNOP->op_first);
5981 len = GvNAMELEN(gv);
5983 else if (kid->op_type == OP_AELEM
5984 || kid->op_type == OP_HELEM)
5986 name = "__ANONIO__";
5992 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5993 namesv = PL_curpad[targ];
5994 (void)SvUPGRADE(namesv, SVt_PV);
5996 sv_setpvn(namesv, "$", 1);
5997 sv_catpvn(namesv, name, len);
6000 kid->op_sibling = 0;
6001 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6002 kid->op_targ = targ;
6003 kid->op_private |= priv;
6005 kid->op_sibling = sibl;
6011 mod(scalar(kid), type);
6015 tokid = &kid->op_sibling;
6016 kid = kid->op_sibling;
6018 o->op_private |= numargs;
6020 return too_many_arguments(o,OP_DESC(o));
6023 else if (PL_opargs[type] & OA_DEFGV) {
6025 return newUNOP(type, 0, newDEFSVOP());
6029 while (oa & OA_OPTIONAL)
6031 if (oa && oa != OA_LIST)
6032 return too_few_arguments(o,OP_DESC(o));
6038 Perl_ck_glob(pTHX_ OP *o)
6043 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6044 append_elem(OP_GLOB, o, newDEFSVOP());
6046 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6047 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6049 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6052 #if !defined(PERL_EXTERNAL_GLOB)
6053 /* XXX this can be tightened up and made more failsafe. */
6057 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
6059 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6060 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6061 GvCV(gv) = GvCV(glob_gv);
6062 SvREFCNT_inc((SV*)GvCV(gv));
6063 GvIMPORTED_CV_on(gv);
6066 #endif /* PERL_EXTERNAL_GLOB */
6068 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6069 append_elem(OP_GLOB, o,
6070 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6071 o->op_type = OP_LIST;
6072 o->op_ppaddr = PL_ppaddr[OP_LIST];
6073 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6074 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6075 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6076 append_elem(OP_LIST, o,
6077 scalar(newUNOP(OP_RV2CV, 0,
6078 newGVOP(OP_GV, 0, gv)))));
6079 o = newUNOP(OP_NULL, 0, ck_subr(o));
6080 o->op_targ = OP_GLOB; /* hint at what it used to be */
6083 gv = newGVgen("main");
6085 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6091 Perl_ck_grep(pTHX_ OP *o)
6095 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6097 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6098 NewOp(1101, gwop, 1, LOGOP);
6100 if (o->op_flags & OPf_STACKED) {
6103 kid = cLISTOPo->op_first->op_sibling;
6104 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6107 kid->op_next = (OP*)gwop;
6108 o->op_flags &= ~OPf_STACKED;
6110 kid = cLISTOPo->op_first->op_sibling;
6111 if (type == OP_MAPWHILE)
6118 kid = cLISTOPo->op_first->op_sibling;
6119 if (kid->op_type != OP_NULL)
6120 Perl_croak(aTHX_ "panic: ck_grep");
6121 kid = kUNOP->op_first;
6123 gwop->op_type = type;
6124 gwop->op_ppaddr = PL_ppaddr[type];
6125 gwop->op_first = listkids(o);
6126 gwop->op_flags |= OPf_KIDS;
6127 gwop->op_private = 1;
6128 gwop->op_other = LINKLIST(kid);
6129 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6130 kid->op_next = (OP*)gwop;
6132 kid = cLISTOPo->op_first->op_sibling;
6133 if (!kid || !kid->op_sibling)
6134 return too_few_arguments(o,OP_DESC(o));
6135 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6136 mod(kid, OP_GREPSTART);
6142 Perl_ck_index(pTHX_ OP *o)
6144 if (o->op_flags & OPf_KIDS) {
6145 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6147 kid = kid->op_sibling; /* get past "big" */
6148 if (kid && kid->op_type == OP_CONST)
6149 fbm_compile(((SVOP*)kid)->op_sv, 0);
6155 Perl_ck_lengthconst(pTHX_ OP *o)
6157 /* XXX length optimization goes here */
6162 Perl_ck_lfun(pTHX_ OP *o)
6164 OPCODE type = o->op_type;
6165 return modkids(ck_fun(o), type);
6169 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6171 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6172 switch (cUNOPo->op_first->op_type) {
6174 /* This is needed for
6175 if (defined %stash::)
6176 to work. Do not break Tk.
6178 break; /* Globals via GV can be undef */
6180 case OP_AASSIGN: /* Is this a good idea? */
6181 Perl_warner(aTHX_ WARN_DEPRECATED,
6182 "defined(@array) is deprecated");
6183 Perl_warner(aTHX_ WARN_DEPRECATED,
6184 "\t(Maybe you should just omit the defined()?)\n");
6187 /* This is needed for
6188 if (defined %stash::)
6189 to work. Do not break Tk.
6191 break; /* Globals via GV can be undef */
6193 Perl_warner(aTHX_ WARN_DEPRECATED,
6194 "defined(%%hash) is deprecated");
6195 Perl_warner(aTHX_ WARN_DEPRECATED,
6196 "\t(Maybe you should just omit the defined()?)\n");
6207 Perl_ck_rfun(pTHX_ OP *o)
6209 OPCODE type = o->op_type;
6210 return refkids(ck_fun(o), type);
6214 Perl_ck_listiob(pTHX_ OP *o)
6218 kid = cLISTOPo->op_first;
6221 kid = cLISTOPo->op_first;
6223 if (kid->op_type == OP_PUSHMARK)
6224 kid = kid->op_sibling;
6225 if (kid && o->op_flags & OPf_STACKED)
6226 kid = kid->op_sibling;
6227 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6228 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6229 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6230 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6231 cLISTOPo->op_first->op_sibling = kid;
6232 cLISTOPo->op_last = kid;
6233 kid = kid->op_sibling;
6238 append_elem(o->op_type, o, newDEFSVOP());
6244 Perl_ck_sassign(pTHX_ OP *o)
6246 OP *kid = cLISTOPo->op_first;
6247 /* has a disposable target? */
6248 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6249 && !(kid->op_flags & OPf_STACKED)
6250 /* Cannot steal the second time! */
6251 && !(kid->op_private & OPpTARGET_MY))
6253 OP *kkid = kid->op_sibling;
6255 /* Can just relocate the target. */
6256 if (kkid && kkid->op_type == OP_PADSV
6257 && !(kkid->op_private & OPpLVAL_INTRO))
6259 kid->op_targ = kkid->op_targ;
6261 /* Now we do not need PADSV and SASSIGN. */
6262 kid->op_sibling = o->op_sibling; /* NULL */
6263 cLISTOPo->op_first = NULL;
6266 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6274 Perl_ck_match(pTHX_ OP *o)
6276 o->op_private |= OPpRUNTIME;
6281 Perl_ck_method(pTHX_ OP *o)
6283 OP *kid = cUNOPo->op_first;
6284 if (kid->op_type == OP_CONST) {
6285 SV* sv = kSVOP->op_sv;
6286 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6288 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6289 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6292 kSVOP->op_sv = Nullsv;
6294 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6303 Perl_ck_null(pTHX_ OP *o)
6309 Perl_ck_open(pTHX_ OP *o)
6311 HV *table = GvHV(PL_hintgv);
6315 svp = hv_fetch(table, "open_IN", 7, FALSE);
6317 mode = mode_from_discipline(*svp);
6318 if (mode & O_BINARY)
6319 o->op_private |= OPpOPEN_IN_RAW;
6320 else if (mode & O_TEXT)
6321 o->op_private |= OPpOPEN_IN_CRLF;
6324 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6326 mode = mode_from_discipline(*svp);
6327 if (mode & O_BINARY)
6328 o->op_private |= OPpOPEN_OUT_RAW;
6329 else if (mode & O_TEXT)
6330 o->op_private |= OPpOPEN_OUT_CRLF;
6333 if (o->op_type == OP_BACKTICK)
6339 Perl_ck_repeat(pTHX_ OP *o)
6341 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6342 o->op_private |= OPpREPEAT_DOLIST;
6343 cBINOPo->op_first = force_list(cBINOPo->op_first);
6351 Perl_ck_require(pTHX_ OP *o)
6355 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6356 SVOP *kid = (SVOP*)cUNOPo->op_first;
6358 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6360 for (s = SvPVX(kid->op_sv); *s; s++) {
6361 if (*s == ':' && s[1] == ':') {
6363 Move(s+2, s+1, strlen(s+2)+1, char);
6364 --SvCUR(kid->op_sv);
6367 if (SvREADONLY(kid->op_sv)) {
6368 SvREADONLY_off(kid->op_sv);
6369 sv_catpvn(kid->op_sv, ".pm", 3);
6370 SvREADONLY_on(kid->op_sv);
6373 sv_catpvn(kid->op_sv, ".pm", 3);
6377 /* handle override, if any */
6378 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6379 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6380 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6382 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6383 OP *kid = cUNOPo->op_first;
6384 cUNOPo->op_first = 0;
6386 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6387 append_elem(OP_LIST, kid,
6388 scalar(newUNOP(OP_RV2CV, 0,
6397 Perl_ck_return(pTHX_ OP *o)
6400 if (CvLVALUE(PL_compcv)) {
6401 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6402 mod(kid, OP_LEAVESUBLV);
6409 Perl_ck_retarget(pTHX_ OP *o)
6411 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6418 Perl_ck_select(pTHX_ OP *o)
6421 if (o->op_flags & OPf_KIDS) {
6422 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6423 if (kid && kid->op_sibling) {
6424 o->op_type = OP_SSELECT;
6425 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6427 return fold_constants(o);
6431 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6432 if (kid && kid->op_type == OP_RV2GV)
6433 kid->op_private &= ~HINT_STRICT_REFS;
6438 Perl_ck_shift(pTHX_ OP *o)
6440 I32 type = o->op_type;
6442 if (!(o->op_flags & OPf_KIDS)) {
6446 #ifdef USE_5005THREADS
6447 if (!CvUNIQUE(PL_compcv)) {
6448 argop = newOP(OP_PADAV, OPf_REF);
6449 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6452 argop = newUNOP(OP_RV2AV, 0,
6453 scalar(newGVOP(OP_GV, 0,
6454 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6457 argop = newUNOP(OP_RV2AV, 0,
6458 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6459 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6460 #endif /* USE_5005THREADS */
6461 return newUNOP(type, 0, scalar(argop));
6463 return scalar(modkids(ck_fun(o), type));
6467 Perl_ck_sort(pTHX_ OP *o)
6471 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6473 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6474 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6476 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6478 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6480 if (kid->op_type == OP_SCOPE) {
6484 else if (kid->op_type == OP_LEAVE) {
6485 if (o->op_type == OP_SORT) {
6486 op_null(kid); /* wipe out leave */
6489 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6490 if (k->op_next == kid)
6492 /* don't descend into loops */
6493 else if (k->op_type == OP_ENTERLOOP
6494 || k->op_type == OP_ENTERITER)
6496 k = cLOOPx(k)->op_lastop;
6501 kid->op_next = 0; /* just disconnect the leave */
6502 k = kLISTOP->op_first;
6507 if (o->op_type == OP_SORT) {
6508 /* provide scalar context for comparison function/block */
6514 o->op_flags |= OPf_SPECIAL;
6516 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6519 firstkid = firstkid->op_sibling;
6522 /* provide list context for arguments */
6523 if (o->op_type == OP_SORT)
6530 S_simplify_sort(pTHX_ OP *o)
6532 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6536 if (!(o->op_flags & OPf_STACKED))
6538 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6539 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6540 kid = kUNOP->op_first; /* get past null */
6541 if (kid->op_type != OP_SCOPE)
6543 kid = kLISTOP->op_last; /* get past scope */
6544 switch(kid->op_type) {
6552 k = kid; /* remember this node*/
6553 if (kBINOP->op_first->op_type != OP_RV2SV)
6555 kid = kBINOP->op_first; /* get past cmp */
6556 if (kUNOP->op_first->op_type != OP_GV)
6558 kid = kUNOP->op_first; /* get past rv2sv */
6560 if (GvSTASH(gv) != PL_curstash)
6562 if (strEQ(GvNAME(gv), "a"))
6564 else if (strEQ(GvNAME(gv), "b"))
6568 kid = k; /* back to cmp */
6569 if (kBINOP->op_last->op_type != OP_RV2SV)
6571 kid = kBINOP->op_last; /* down to 2nd arg */
6572 if (kUNOP->op_first->op_type != OP_GV)
6574 kid = kUNOP->op_first; /* get past rv2sv */
6576 if (GvSTASH(gv) != PL_curstash
6578 ? strNE(GvNAME(gv), "a")
6579 : strNE(GvNAME(gv), "b")))
6581 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6583 o->op_private |= OPpSORT_REVERSE;
6584 if (k->op_type == OP_NCMP)
6585 o->op_private |= OPpSORT_NUMERIC;
6586 if (k->op_type == OP_I_NCMP)
6587 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6588 kid = cLISTOPo->op_first->op_sibling;
6589 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6590 op_free(kid); /* then delete it */
6594 Perl_ck_split(pTHX_ OP *o)
6598 if (o->op_flags & OPf_STACKED)
6599 return no_fh_allowed(o);
6601 kid = cLISTOPo->op_first;
6602 if (kid->op_type != OP_NULL)
6603 Perl_croak(aTHX_ "panic: ck_split");
6604 kid = kid->op_sibling;
6605 op_free(cLISTOPo->op_first);
6606 cLISTOPo->op_first = kid;
6608 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6609 cLISTOPo->op_last = kid; /* There was only one element previously */
6612 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6613 OP *sibl = kid->op_sibling;
6614 kid->op_sibling = 0;
6615 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6616 if (cLISTOPo->op_first == cLISTOPo->op_last)
6617 cLISTOPo->op_last = kid;
6618 cLISTOPo->op_first = kid;
6619 kid->op_sibling = sibl;
6622 kid->op_type = OP_PUSHRE;
6623 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6626 if (!kid->op_sibling)
6627 append_elem(OP_SPLIT, o, newDEFSVOP());
6629 kid = kid->op_sibling;
6632 if (!kid->op_sibling)
6633 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6635 kid = kid->op_sibling;
6638 if (kid->op_sibling)
6639 return too_many_arguments(o,OP_DESC(o));
6645 Perl_ck_join(pTHX_ OP *o)
6647 if (ckWARN(WARN_SYNTAX)) {
6648 OP *kid = cLISTOPo->op_first->op_sibling;
6649 if (kid && kid->op_type == OP_MATCH) {
6650 char *pmstr = "STRING";
6651 if (PM_GETRE(kPMOP))
6652 pmstr = PM_GETRE(kPMOP)->precomp;
6653 Perl_warner(aTHX_ WARN_SYNTAX,
6654 "/%s/ should probably be written as \"%s\"",
6662 Perl_ck_subr(pTHX_ OP *o)
6664 OP *prev = ((cUNOPo->op_first->op_sibling)
6665 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6666 OP *o2 = prev->op_sibling;
6673 I32 contextclass = 0;
6677 o->op_private |= OPpENTERSUB_HASTARG;
6678 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6679 if (cvop->op_type == OP_RV2CV) {
6681 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6682 op_null(cvop); /* disable rv2cv */
6683 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6684 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6685 GV *gv = cGVOPx_gv(tmpop);
6688 tmpop->op_private |= OPpEARLY_CV;
6689 else if (SvPOK(cv)) {
6690 namegv = CvANON(cv) ? gv : CvGV(cv);
6691 proto = SvPV((SV*)cv, n_a);
6695 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6696 if (o2->op_type == OP_CONST)
6697 o2->op_private &= ~OPpCONST_STRICT;
6698 else if (o2->op_type == OP_LIST) {
6699 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6700 if (o && o->op_type == OP_CONST)
6701 o->op_private &= ~OPpCONST_STRICT;
6704 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6705 if (PERLDB_SUB && PL_curstash != PL_debstash)
6706 o->op_private |= OPpENTERSUB_DB;
6707 while (o2 != cvop) {
6711 return too_many_arguments(o, gv_ename(namegv));
6729 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6731 arg == 1 ? "block or sub {}" : "sub {}",
6732 gv_ename(namegv), o2);
6735 /* '*' allows any scalar type, including bareword */
6738 if (o2->op_type == OP_RV2GV)
6739 goto wrapref; /* autoconvert GLOB -> GLOBref */
6740 else if (o2->op_type == OP_CONST)
6741 o2->op_private &= ~OPpCONST_STRICT;
6742 else if (o2->op_type == OP_ENTERSUB) {
6743 /* accidental subroutine, revert to bareword */
6744 OP *gvop = ((UNOP*)o2)->op_first;
6745 if (gvop && gvop->op_type == OP_NULL) {
6746 gvop = ((UNOP*)gvop)->op_first;
6748 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6751 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6752 (gvop = ((UNOP*)gvop)->op_first) &&
6753 gvop->op_type == OP_GV)
6755 GV *gv = cGVOPx_gv(gvop);
6756 OP *sibling = o2->op_sibling;
6757 SV *n = newSVpvn("",0);
6759 gv_fullname3(n, gv, "");
6760 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6761 sv_chop(n, SvPVX(n)+6);
6762 o2 = newSVOP(OP_CONST, 0, n);
6763 prev->op_sibling = o2;
6764 o2->op_sibling = sibling;
6780 if (contextclass++ == 0) {
6781 e = strchr(proto, ']');
6782 if (!e || e == proto)
6795 while (*--p != '[');
6796 bad_type(arg, Perl_form("one of %s", p),
6797 gv_ename(namegv), o2);
6803 if (o2->op_type == OP_RV2GV)
6806 bad_type(arg, "symbol", gv_ename(namegv), o2);
6809 if (o2->op_type == OP_ENTERSUB)
6812 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6815 if (o2->op_type == OP_RV2SV ||
6816 o2->op_type == OP_PADSV ||
6817 o2->op_type == OP_HELEM ||
6818 o2->op_type == OP_AELEM ||
6819 o2->op_type == OP_THREADSV)
6822 bad_type(arg, "scalar", gv_ename(namegv), o2);
6825 if (o2->op_type == OP_RV2AV ||
6826 o2->op_type == OP_PADAV)
6829 bad_type(arg, "array", gv_ename(namegv), o2);
6832 if (o2->op_type == OP_RV2HV ||
6833 o2->op_type == OP_PADHV)
6836 bad_type(arg, "hash", gv_ename(namegv), o2);
6841 OP* sib = kid->op_sibling;
6842 kid->op_sibling = 0;
6843 o2 = newUNOP(OP_REFGEN, 0, kid);
6844 o2->op_sibling = sib;
6845 prev->op_sibling = o2;
6847 if (contextclass && e) {
6862 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6863 gv_ename(namegv), SvPV((SV*)cv, n_a));
6868 mod(o2, OP_ENTERSUB);
6870 o2 = o2->op_sibling;
6872 if (proto && !optional &&
6873 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6874 return too_few_arguments(o, gv_ename(namegv));
6879 Perl_ck_svconst(pTHX_ OP *o)
6881 SvREADONLY_on(cSVOPo->op_sv);
6886 Perl_ck_trunc(pTHX_ OP *o)
6888 if (o->op_flags & OPf_KIDS) {
6889 SVOP *kid = (SVOP*)cUNOPo->op_first;
6891 if (kid->op_type == OP_NULL)
6892 kid = (SVOP*)kid->op_sibling;
6893 if (kid && kid->op_type == OP_CONST &&
6894 (kid->op_private & OPpCONST_BARE))
6896 o->op_flags |= OPf_SPECIAL;
6897 kid->op_private &= ~OPpCONST_STRICT;
6904 Perl_ck_substr(pTHX_ OP *o)
6907 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6908 OP *kid = cLISTOPo->op_first;
6910 if (kid->op_type == OP_NULL)
6911 kid = kid->op_sibling;
6913 kid->op_flags |= OPf_MOD;
6919 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6922 Perl_peep(pTHX_ register OP *o)
6924 register OP* oldop = 0;
6927 if (!o || o->op_seq)
6931 SAVEVPTR(PL_curcop);
6932 for (; o; o = o->op_next) {
6938 switch (o->op_type) {
6942 PL_curcop = ((COP*)o); /* for warnings */
6943 o->op_seq = PL_op_seqmax++;
6947 if (cSVOPo->op_private & OPpCONST_STRICT)
6948 no_bareword_allowed(o);
6950 /* Relocate sv to the pad for thread safety.
6951 * Despite being a "constant", the SV is written to,
6952 * for reference counts, sv_upgrade() etc. */
6954 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6955 if (SvPADTMP(cSVOPo->op_sv)) {
6956 /* If op_sv is already a PADTMP then it is being used by
6957 * some pad, so make a copy. */
6958 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6959 SvREADONLY_on(PL_curpad[ix]);
6960 SvREFCNT_dec(cSVOPo->op_sv);
6963 SvREFCNT_dec(PL_curpad[ix]);
6964 SvPADTMP_on(cSVOPo->op_sv);
6965 PL_curpad[ix] = cSVOPo->op_sv;
6966 /* XXX I don't know how this isn't readonly already. */
6967 SvREADONLY_on(PL_curpad[ix]);
6969 cSVOPo->op_sv = Nullsv;
6973 o->op_seq = PL_op_seqmax++;
6977 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6978 if (o->op_next->op_private & OPpTARGET_MY) {
6979 if (o->op_flags & OPf_STACKED) /* chained concats */
6980 goto ignore_optimization;
6982 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6983 o->op_targ = o->op_next->op_targ;
6984 o->op_next->op_targ = 0;
6985 o->op_private |= OPpTARGET_MY;
6988 op_null(o->op_next);
6990 ignore_optimization:
6991 o->op_seq = PL_op_seqmax++;
6994 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6995 o->op_seq = PL_op_seqmax++;
6996 break; /* Scalar stub must produce undef. List stub is noop */
7000 if (o->op_targ == OP_NEXTSTATE
7001 || o->op_targ == OP_DBSTATE
7002 || o->op_targ == OP_SETSTATE)
7004 PL_curcop = ((COP*)o);
7006 /* XXX: We avoid setting op_seq here to prevent later calls
7007 to peep() from mistakenly concluding that optimisation
7008 has already occurred. This doesn't fix the real problem,
7009 though (See 20010220.007). AMS 20010719 */
7010 if (oldop && o->op_next) {
7011 oldop->op_next = o->op_next;
7019 if (oldop && o->op_next) {
7020 oldop->op_next = o->op_next;
7023 o->op_seq = PL_op_seqmax++;
7027 if (o->op_next->op_type == OP_RV2SV) {
7028 if (!(o->op_next->op_private & OPpDEREF)) {
7029 op_null(o->op_next);
7030 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7032 o->op_next = o->op_next->op_next;
7033 o->op_type = OP_GVSV;
7034 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7037 else if (o->op_next->op_type == OP_RV2AV) {
7038 OP* pop = o->op_next->op_next;
7040 if (pop->op_type == OP_CONST &&
7041 (PL_op = pop->op_next) &&
7042 pop->op_next->op_type == OP_AELEM &&
7043 !(pop->op_next->op_private &
7044 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7045 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7050 op_null(o->op_next);
7051 op_null(pop->op_next);
7053 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7054 o->op_next = pop->op_next->op_next;
7055 o->op_type = OP_AELEMFAST;
7056 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7057 o->op_private = (U8)i;
7062 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7064 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7065 /* XXX could check prototype here instead of just carping */
7066 SV *sv = sv_newmortal();
7067 gv_efullname3(sv, gv, Nullch);
7068 Perl_warner(aTHX_ WARN_PROTOTYPE,
7069 "%s() called too early to check prototype",
7073 else if (o->op_next->op_type == OP_READLINE
7074 && o->op_next->op_next->op_type == OP_CONCAT
7075 && (o->op_next->op_next->op_flags & OPf_STACKED))
7077 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7078 o->op_type = OP_RCATLINE;
7079 o->op_flags |= OPf_STACKED;
7080 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7081 op_null(o->op_next->op_next);
7082 op_null(o->op_next);
7085 o->op_seq = PL_op_seqmax++;
7096 o->op_seq = PL_op_seqmax++;
7097 while (cLOGOP->op_other->op_type == OP_NULL)
7098 cLOGOP->op_other = cLOGOP->op_other->op_next;
7099 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7104 o->op_seq = PL_op_seqmax++;
7105 while (cLOOP->op_redoop->op_type == OP_NULL)
7106 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7107 peep(cLOOP->op_redoop);
7108 while (cLOOP->op_nextop->op_type == OP_NULL)
7109 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7110 peep(cLOOP->op_nextop);
7111 while (cLOOP->op_lastop->op_type == OP_NULL)
7112 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7113 peep(cLOOP->op_lastop);
7119 o->op_seq = PL_op_seqmax++;
7120 while (cPMOP->op_pmreplstart &&
7121 cPMOP->op_pmreplstart->op_type == OP_NULL)
7122 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7123 peep(cPMOP->op_pmreplstart);
7127 o->op_seq = PL_op_seqmax++;
7128 if (ckWARN(WARN_SYNTAX) && o->op_next
7129 && o->op_next->op_type == OP_NEXTSTATE) {
7130 if (o->op_next->op_sibling &&
7131 o->op_next->op_sibling->op_type != OP_EXIT &&
7132 o->op_next->op_sibling->op_type != OP_WARN &&
7133 o->op_next->op_sibling->op_type != OP_DIE) {
7134 line_t oldline = CopLINE(PL_curcop);
7136 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7137 Perl_warner(aTHX_ WARN_EXEC,
7138 "Statement unlikely to be reached");
7139 Perl_warner(aTHX_ WARN_EXEC,
7140 "\t(Maybe you meant system() when you said exec()?)\n");
7141 CopLINE_set(PL_curcop, oldline);
7150 SV **svp, **indsvp, *sv;
7155 o->op_seq = PL_op_seqmax++;
7157 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7160 /* Make the CONST have a shared SV */
7161 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7162 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7163 key = SvPV(sv, keylen);
7164 lexname = newSVpvn_share(key,
7165 SvUTF8(sv) ? -(I32)keylen : keylen,
7171 if ((o->op_private & (OPpLVAL_INTRO)))
7174 rop = (UNOP*)((BINOP*)o)->op_first;
7175 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7177 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7178 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7180 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7181 if (!fields || !GvHV(*fields))
7183 key = SvPV(*svp, keylen);
7184 indsvp = hv_fetch(GvHV(*fields), key,
7185 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7187 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7188 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7190 ind = SvIV(*indsvp);
7192 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7193 rop->op_type = OP_RV2AV;
7194 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7195 o->op_type = OP_AELEM;
7196 o->op_ppaddr = PL_ppaddr[OP_AELEM];
7198 if (SvREADONLY(*svp))
7200 SvFLAGS(sv) |= (SvFLAGS(*svp)
7201 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7211 SV **svp, **indsvp, *sv;
7215 SVOP *first_key_op, *key_op;
7217 o->op_seq = PL_op_seqmax++;
7218 if ((o->op_private & (OPpLVAL_INTRO))
7219 /* I bet there's always a pushmark... */
7220 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7221 /* hmmm, no optimization if list contains only one key. */
7223 rop = (UNOP*)((LISTOP*)o)->op_last;
7224 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7226 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7227 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7229 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7230 if (!fields || !GvHV(*fields))
7232 /* Again guessing that the pushmark can be jumped over.... */
7233 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7234 ->op_first->op_sibling;
7235 /* Check that the key list contains only constants. */
7236 for (key_op = first_key_op; key_op;
7237 key_op = (SVOP*)key_op->op_sibling)
7238 if (key_op->op_type != OP_CONST)
7242 rop->op_type = OP_RV2AV;
7243 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7244 o->op_type = OP_ASLICE;
7245 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7246 for (key_op = first_key_op; key_op;
7247 key_op = (SVOP*)key_op->op_sibling) {
7248 svp = cSVOPx_svp(key_op);
7249 key = SvPV(*svp, keylen);
7250 indsvp = hv_fetch(GvHV(*fields), key,
7251 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7253 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7254 "in variable %s of type %s",
7255 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7257 ind = SvIV(*indsvp);
7259 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7261 if (SvREADONLY(*svp))
7263 SvFLAGS(sv) |= (SvFLAGS(*svp)
7264 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7272 o->op_seq = PL_op_seqmax++;
7282 char* Perl_custom_op_name(pTHX_ OP* o)
7284 IV index = PTR2IV(o->op_ppaddr);
7288 if (!PL_custom_op_names) /* This probably shouldn't happen */
7289 return PL_op_name[OP_CUSTOM];
7291 keysv = sv_2mortal(newSViv(index));
7293 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7295 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7297 return SvPV_nolen(HeVAL(he));
7300 char* Perl_custom_op_desc(pTHX_ OP* o)
7302 IV index = PTR2IV(o->op_ppaddr);
7306 if (!PL_custom_op_descs)
7307 return PL_op_desc[OP_CUSTOM];
7309 keysv = sv_2mortal(newSViv(index));
7311 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7313 return PL_op_desc[OP_CUSTOM];
7315 return SvPV_nolen(HeVAL(he));
7321 /* Efficient sub that returns a constant scalar value. */
7323 const_sv_xsub(pTHX_ CV* cv)
7328 Perl_croak(aTHX_ "usage: %s::%s()",
7329 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7333 ST(0) = (SV*)XSANY.any_ptr;